algorithm - Boggle - 计算 N*N 网格上的所有可能路径。表现

Question

在阅读时this question ，我想知道为什么没有人会“简单地”迭代 boggle 网格上的所有可能路径并让单词尝试跟随，然后如果单词特里没有匹配则取消路径。在一个 4 x 4 的小网格上不可能有那么多路径，对吗？有几条路？所以我开始用 F# 编写一个路径计数器函数。结果产生了另一页上没有人说的:网格上的路径比我想象的要多(实际上，路径比词集中的词多)。

虽然所有这些几乎都是我问题的背景故事，但我最终得到的代码运行速度相当慢，而且我发现我无法对代码的某些方面给出好的答案。所以在这里，首先是代码，然后是代码下方，您会发现我认为值得解释的要点...

let moves n state square =
    let allSquares = [0..n*n-1] |> Set.ofList
    let right = Set.difference allSquares (Set.ofList [n-1..n..n*n])
    let left = Set.difference allSquares (Set.ofList [0..n..n*n-1])
    let up = Set.difference allSquares (Set.ofList [0..n-1])
    let down = Set.difference allSquares (Set.ofList [n*n-n..n*n-1])
    let downRight = Set.intersect right down
    let downLeft = Set.intersect left down
    let upRight = Set.intersect right up
    let upLeft = Set.intersect left up
    let appendIfInSet se v res =
        if Set.contains square se then res @ v else res
    []
    |> appendIfInSet right [square + 1]
    |> appendIfInSet left [square - 1]
    |> appendIfInSet up [square - n]
    |> appendIfInSet down [square + n]
    |> appendIfInSet downRight [square + n + 1]
    |> appendIfInSet downLeft [square + n - 1]
    |> appendIfInSet upRight [square - n + 1]
    |> appendIfInSet upLeft [square - n - 1]
    |> List.choose (fun s -> if ((uint64 1 <<< s) &&& state) = 0UL then Some s else None )

let block state square =
    state ||| (uint64 1 <<< square)

let countAllPaths n lmin lmax =
    let mov = moves n                 // line 30
    let rec count l state sq c =
        let state' = block state sq
        let m = mov state' sq
        match l with
        | x when x <= lmax && x >= lmin ->
            List.fold (fun acc s -> count (l+1) state' s acc) (c+1) m
        | x when x < lmin ->
            List.fold (fun acc s -> count (l+1) state' s acc) (c) m
        | _ ->
            c
    List.fold (fun acc s -> count 0 (block 0UL s) s acc) 0 [0..n*n-1]

[<EntryPoint>] 
let main args =
    printfn "%d: %A" (Array.length args) args
    if 3 = Array.length args then
        let n = int args.[0]
        let lmin = int args.[1]
        let lmax = int args.[2]
        printfn "%d %d %d -> %d" n lmin lmax (countAllPaths n lmin lmax)
    else
        printfn "usage: wordgames.exe n lmin lmax"
    0

1. 在第 30 行，我用第一个参数柯里化(Currying)了 moves 函数，希望代码优化可能会从中受益。也许优化我在 move 中创建的 9 个集合，它们只是 n 的函数。毕竟，它们不需要一遍又一遍地生成，对吧？另一方面，我不会真的打赌它真的会发生。
   所以，问题 #1 是:如何以尽可能少的代码膨胀方式实现这种优化？ (我当然可以创建一个有 9 个成员的类型，然后为每个可能的 n 创建一个该类型的数组，然后像使用预计算集一样查找表，但在我看来这将是代码膨胀)。

2. 许多消息来源暗示平行折叠被认为是至关重要的。如何创建并行版本的计数函数(在多个内核上运行)？

3. 有没有人有如何加快速度的好主意？也许一些修剪或内存等？

起初，当我为 n=4 lmin=3 lmax=8 运行函数时，我认为它需要很长时间，因为我在 fsi 中运行它。但是后来我用 -O 编译了代码，它仍然花费了大约相同的时间......

更新

在等待你们的输入时，我做了代码臃肿的手动优化版本(运行速度更快)，然后找到了一种让它在多核上运行的方法。
总而言之，这 2 项更改使速度提高了 30 倍。这是我想出的(膨胀的)版本(仍在寻找避免膨胀的方法):

let squareSet n =
    let allSquares = [0..n*n-1] |> Set.ofList
    let right = Set.difference allSquares (Set.ofList [n-1..n..n*n])
    let left = Set.difference allSquares (Set.ofList [0..n..n*n-1])
    let up = Set.difference allSquares (Set.ofList [0..n-1])
    let down = Set.difference allSquares (Set.ofList [n*n-n..n*n-1])
    let downRight = Set.intersect right down
    let downLeft = Set.intersect left down
    let upRight = Set.intersect right up
    let upLeft = Set.intersect left up
    [|right;left;up;down;upRight;upLeft;downRight;downLeft|]    

let RIGHT,LEFT,UP,DOWN = 0,1,2,3
let UPRIGHT,UPLEFT,DOWNRIGHT,DOWNLEFT = 4,5,6,7

let squareSets =
    [|Set.empty;Set.empty;Set.empty;Set.empty;Set.empty;Set.empty;Set.empty;Set.empty;|]
    ::
    [    for i in 1..8 do
            yield squareSet i
    ]
    |> Array.ofList


let moves n state square =
    let appendIfInSet se v res =
        if Set.contains square se then res @ v else res

    []
    |> appendIfInSet squareSets.[n].[RIGHT] [square + 1]
    |> appendIfInSet squareSets.[n].[LEFT] [square - 1]
    |> appendIfInSet squareSets.[n].[UP] [square - n]
    |> appendIfInSet squareSets.[n].[DOWN] [square + n]
    |> appendIfInSet squareSets.[n].[DOWNRIGHT] [square + n + 1]
    |> appendIfInSet squareSets.[n].[DOWNLEFT] [square + n - 1]
    |> appendIfInSet squareSets.[n].[UPRIGHT] [square - n + 1]
    |> appendIfInSet squareSets.[n].[UPLEFT] [square - n - 1]
    |> List.choose (fun s -> if ((uint64 1 <<< s) &&& state) = 0UL then Some s else None )

let block state square =
    state ||| (uint64 1 <<< square)

let countAllPaths n lmin lmax =
    let mov = moves n
    let rec count l state sq c =
        let state' = block state sq
        let m = mov state' sq
        match l with
        | x when x <= lmax && x >= lmin ->
            List.fold (fun acc s -> count (l+1) state' s acc) (c+1) m
        | x when x < lmin ->
            List.fold (fun acc s -> count (l+1) state' s acc) (c) m
        | _ ->
            c
    //List.fold (fun acc s -> count 0 (block 0UL s) s acc) 0 [0..n*n-1]
    [0..n*n-1]
    |> Array.ofList
    |> Array.Parallel.map (fun start -> count 0 (block 0UL start) start 0)
    |> Array.sum

[<EntryPoint>] 
let main args =
    printfn "%d: %A" (Array.length args) args
    if 3 = Array.length args then
        let n = int args.[0]
        let lmin = int args.[1]
        let lmax = int args.[2]
        printfn "%d %d %d -> %d" n lmin lmax (countAllPaths n lmin lmax)
    else
        printfn "usage: wordgames.exe n lmin lmax"
    0

Answer 1

至于非优化集的生成。问题更新中发布的第二个版本表明，情况确实如此(未被编译器优化)并且它产生了显着的加速。最终版本(在此答案下方发布)进一步采用了这种方法，并进一步加快了路径计数(以及解决难题)的速度。

结合多核并行执行，对于 n=4 lmin=3 lmax=8，最初非常慢(可能 30 秒)的版本可以加速到只有 100 毫秒左右。案例。

对于 n=6 类问题，并行和手动调整的实现在我的机器上解决了大约 60 毫秒的难题。这是有道理的，这比路径计数更快，因为单词列表探测(使用包含大约 80000 个单词的字典)以及 @GuyCoder 指出的动态编程方法使拼图的解决方案比(蛮力)路径计数。

经验教训

如果涉及到代码优化，f# 编译器似乎并没有太神秘和神奇。如果确实需要性能，手动调整是值得的。

在这种情况下，将单线程递归搜索函数转换为并行(并发)函数并不难。

代码的最终版本

编译:

fsc --optimize+ --tailcalls+ wordgames.fs

(Microsoft (R) F# 编译器版本 14.0.23413.0)

let wordListPath = @"E:\temp\12dicts-6.0.2\International\3of6all.txt"

let acceptableWord (s : string) : bool =
    let s' = s.Trim()
    if s'.Length > 2
    then
        if System.Char.IsLower(s'.[0]) && System.Char.IsLetter(s'.[0]) then true
        else false
    else
        false

let words = 
    System.IO.File.ReadAllLines(wordListPath)
    |> Array.filter acceptableWord


let squareSet n =
    let allSquares = [0..n*n-1] |> Set.ofList
    let right = Set.difference allSquares (Set.ofList [n-1..n..n*n])
    let left = Set.difference allSquares (Set.ofList [0..n..n*n-1])
    let up = Set.difference allSquares (Set.ofList [0..n-1])
    let down = Set.difference allSquares (Set.ofList [n*n-n..n*n-1])
    let downRight = Set.intersect right down
    let downLeft = Set.intersect left down
    let upRight = Set.intersect right up
    let upLeft = Set.intersect left up
    [|right;left;up;down;upRight;upLeft;downRight;downLeft|]    

let RIGHT,LEFT,UP,DOWN = 0,1,2,3
let UPRIGHT,UPLEFT,DOWNRIGHT,DOWNLEFT = 4,5,6,7

let squareSets =
    [|Set.empty;Set.empty;Set.empty;Set.empty;Set.empty;Set.empty;Set.empty;Set.empty;|]
    ::
    [    for i in 1..8 do
            yield squareSet i
    ]
    |> Array.ofList


let movesFromSquare n square =
    let appendIfInSet se v res =
            if Set.contains square se then v :: res  else res

    []
    |> appendIfInSet squareSets.[n].[RIGHT] (square + 1)
    |> appendIfInSet squareSets.[n].[LEFT] (square - 1)
    |> appendIfInSet squareSets.[n].[UP] (square - n)
    |> appendIfInSet squareSets.[n].[DOWN] (square + n)
    |> appendIfInSet squareSets.[n].[DOWNRIGHT] (square + n + 1)
    |> appendIfInSet squareSets.[n].[DOWNLEFT] (square + n - 1)
    |> appendIfInSet squareSets.[n].[UPRIGHT] (square - n + 1)
    |> appendIfInSet squareSets.[n].[UPLEFT] (square - n - 1)

let lutMovesN n =
    Array.init n (fun i -> if i > 0 then Array.init (n*n-1) (fun j -> movesFromSquare i j) else Array.empty)

let lutMoves =
    lutMovesN 8

let moves n state square =
    let appendIfInSet se v res =
            if Set.contains square se then v :: res  else res

    lutMoves.[n].[square]
    |> List.filter (fun s -> ((uint64 1 <<< s) &&& state) = 0UL)

let block state square =
    state ||| (uint64 1 <<< square)

let countAllPaths n lmin lmax =
    let mov = moves n
    let rec count l state sq c =
        let state' = block state sq
        let m = mov state' sq
        match l with
        | x when x <= lmax && x >= lmin ->
            List.fold (fun acc s -> count (l+1) state' s acc) (c+1) m
        | x when x < lmin ->
            List.fold (fun acc s -> count (l+1) state' s acc) (c) m
        | _ ->
            c
    //List.fold (fun acc s -> count 0 (block 0UL s) s acc) 0 [0..n*n-1]
    [|0..n*n-1|]
    |> Array.Parallel.map (fun start -> count 0 (block 0UL start) start 0)
    |> Array.sum


//printfn "%d " (words |> Array.distinct |> Array.length)

let usage() =
    printfn "usage: wordgames.exe [--gen n count problemPath | --count n lmin lmax | --solve problemPath ]"

let rng = System.Random()

let genProblem n (sb : System.Text.StringBuilder) =
    let a = Array.init (n*n) (fun _ -> char (rng.Next(26) + int 'a'))
    sb.Append(a) |> ignore
    sb.AppendLine()

let genProblems nproblems n (sb : System.Text.StringBuilder) : System.Text.StringBuilder =
    for i in 1..nproblems do
        genProblem n sb |> ignore
    sb

let solve n (board : System.String) =
    let ba = board.ToCharArray()

    let testWord (w : string) : bool =
        let testChar k sq = (ba.[sq] = w.[k])
        let rec testSquare state k sq =
            match k with
            | 0 -> testChar 0 sq
            | x -> 
                if testChar x sq
                then
                    let state' = block state x
                    moves n state' x
                    |> List.exists (testSquare state' (x-1))
                else
                    false

        [0..n*n-1]    
        |> List.exists (testSquare 0UL (String.length w - 1))

    words
    |> Array.splitInto 32
    |> Array.Parallel.map (Array.filter testWord)
    |> Array.concat

[<EntryPoint>] 
let main args =
    printfn "%d: %A" (Array.length args) args
    let nargs = Array.length args
    let sw = System.Diagnostics.Stopwatch()
    match nargs with
    | x when x >= 2 ->
        match args.[0] with
        | "--gen" ->
            if nargs = 4
            then
                let n = int args.[1]
                let nproblems = int args.[2]
                let outpath = args.[3]
                let problems = genProblems nproblems n (System.Text.StringBuilder())
                System.IO.File.WriteAllText (outpath,problems.ToString())
                0
            else
                usage()
                0
        | "--count" ->
            if nargs = 4 
            then
                let n = int args.[1]
                let lmin = int args.[2]
                let lmax = int args.[3]
                sw.Start()
                let count = countAllPaths n lmin lmax
                sw.Stop()
                printfn "%d %d %d -> %d (took: %d)" n lmin lmax count (sw.ElapsedMilliseconds)
                0
            else
                usage ()
                0
        | "--solve" ->
            if nargs = 2
            then
                let problems = System.IO.File.ReadAllLines(args.[1])
                problems 
                |> Array.iter 
                    (fun (p : string) -> 
                        let n = int (sqrt (float (String.length p)))
                        sw.Reset()
                        sw.Start()
                        let found = solve n p
                        sw.Stop()
                        printfn "%s\n%A\n%dms" p found (sw.ElapsedMilliseconds)
                    )
                0
            else
                usage ()
                0
        | _ ->
            usage ()
            0
    | _ -> 
        usage ()
        0