摆动-计算N*N网格上所有可能的路径。性能

Question

在阅读this question时，我想知道为什么没有人会“简单地”迭代所有可能的路径，让单词尝试跟踪，然后取消路径，如果单词trie中没有匹配的话。不可能有那么多的路径在一个小小的4×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行中，我使用第一个参数对moves函数进行了催促，希望代码优化能够从中受益。也许优化我在移动中创建的9组集合，它们只是n的一个函数。毕竟，它们不需要一次又一次地产生，对吗？另一方面，我不会真的押注它真的会发生。 所以，问题1是:我如何以尽可能少的代码膨胀的方式来执行这个优化？(当然，我可以创建一个包含9个成员的类型，然后为每个可能的n创建一个该类型的数组，然后做一个查找表，比如使用预先计算的集合，但在我看来，这将是代码膨胀)。
2. 许多资料表明，平行褶皱被认为是至关重要的。如何创建计数函数的并行版本(它运行在多个核上)？
3. 有没有人有聪明的想法来加速这件事？也许是修剪或者回忆录之类的？

一开始，当我运行n=4 lmin=3 lmax=8函数时，我认为它花了很长时间，因为我在fsi中运行它。但是后来我用-O编译了代码，它仍然花了差不多相同的时间.

更新

在等待来自你们的输入时，我做了代码膨胀的手动优化版本(运行速度更快)，然后找到了一种使它在多核上运行的方法。

总之，这两个变化使速度提高了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 be左右。

对于n=6类问题，并行和手工优化的实现在我的机器上解决了一个大约60 my的难题。这是有道理的，这比路径计数要快，因为单词列表探测(使用字典约80000字)和@GuyCoder指出的动态编程方法使谜题的解决比(蛮力)路径计数更不复杂。

吸取的教训

如果涉及到代码优化，f#编译器似乎并不那么神秘和神奇。如果确实需要性能，手工调优是值得的。

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

代码的最终版本

编撰：

fsc -优化+-尾调用+ wordgames.fs

(微软(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