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

Question

在阅读这个问题时，我想知道为什么没有人会“简单地”迭代 boggle 网格上的所有可能路径并让单词尝试跟随，然后如果单词 trie 中没有匹配项则取消路径。在一个小小的 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

在第 30 行，我moves用第一个参数对函数进行了柯里化，希望代码优化可能会从中受益。也许优化我在 move 中创建的 9 个集合，它们只是n. 毕竟，它们不需要一遍又一遍地生成，对吧？另一方面，我不会真的打赌它真的会发生。
所以，问题 #1 是：我怎样才能以尽可能少的代码膨胀方式执行这种优化？（我当然可以创建一个包含 9 个成员的类型，然后为每个可能的 n 创建一个该类型的数组，然后像使用预先计算的集合一样进行查找表，但在我看来这将是代码膨胀）。
许多消息来源暗示平行折叠被认为是至关重要的。如何创建计数功能的并行版本（在多个内核上运行）？
有没有人有聪明的想法如何加快速度？也许一些修剪或记忆等？

起初，当我运行该函数时，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

score 1 · Accepted Answer

至于非优化的生成集。问题更新中发布的第二个版本显示，实际上是这种情况（未由编译器优化）并且它产生了显着的加速。最终版本（在此答案的下方发布）更进一步地采用了这种方法，并进一步加快了路径计数（以及拼图的解决）。

结合在多个内核上的并行执行，最初非常慢（可能 30 秒）的版本可以加速到只有 100 毫秒左右n=4 lmin=3 lmax=8。

对于 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

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

1 回答 1

学过的知识

代码的最终版本

Related

Reference