Data commit

Task/Sudoku/F-Sharp/sudoku-1.fs

@@ -0,0 +1,74 @@
+module SudokuBacktrack
+
+//Helpers
+let tuple2 a b = a,b
+let flip  f a b = f b a
+let (>>=) f g = Option.bind g f
+
+/// "A1" to "I9" squares as key in values dictionary
+let key a b = $"{a}{b}"
+
+/// Cross product of elements in ax and elements in bx
+let cross ax bx = [| for a in ax do for b in bx do key a b |]
+
+// constants
+let valid   = "1234567890.,"
+let rows    = "ABCDEFGHI"
+let cols    = "123456789"
+let squares = cross rows cols
+
+// List of all row, cols and boxes:  aka units
+let unitList =
+    [for c in cols do cross rows (string c) ]@ // row units
+    [for r in rows do cross (string r) cols ]@ // col units
+    [for rs in ["ABC";"DEF";"GHI"] do for cs in ["123";"456";"789"] do cross rs cs ] // box units
+
+/// Dictionary of units for each square
+let units =
+    [for s in squares do s, [| for u in unitList do if u |> Array.contains s then u |] ] |> Map.ofSeq
+
+/// Dictionary of all peer squares in the relevant units wrt square in question
+let peers =
+    [for s in squares do units[s] |> Array.concat |> Array.distinct |> Array.except [s] |> tuple2 s] |> Map.ofSeq
+
+/// Should parse grid in many input formats or return None
+let parseGrid grid =
+    let ints = [for c in grid do if valid |> Seq.contains c then if ",." |> Seq.contains c then 0 else (c |> string |> int)]
+    if Seq.length ints = 81 then ints |> Seq.zip squares |> Map.ofSeq |> Some else None
+
+/// Outputs single line puzzle with 0 as empty squares
+let asString  =  function
+    | Some values -> values |> Map.toSeq |> Seq.map (snd>>string) |> String.concat ""
+    | _ ->  "No solution or Parse Failure"
+
+/// Outputs puzzle in 2D format with 0 as empty squares
+let prettyPrint = function
+    | Some (values:Map<_,_>) ->
+        [for r in rows do [for c in cols do (values[key r c] |> string) ] |> String.concat " " ] |> String.concat "\n"
+    | _ ->  "No solution or Parse Failure"
+
+/// Is digit allowed in the square in question? !!! hot path !!!!
+/// Array/Array2D no faster and they need explicit copy since not immutable
+let constraints (values:Map<_,_>) s d = peers[s] |> Seq.map (fun p -> values[p]) |> Seq.exists ((=) d) |> not
+
+/// Move to next square or None if out of bounds
+let next s = squares |> Array.tryFindIndex ((=)s) |> function Some i when i + 1 < 81 -> Some squares[i + 1] | _ -> None
+
+/// Backtrack recursively and immutably from index
+let rec backtracker (values:Map<_,_>) = function
+    | None -> Some values // solved!
+    | Some s when values[s] > 0 -> backtracker values (next s)  // square not empty
+    | Some s ->
+        let rec tracker  = function
+            | [] -> None
+            | d::dx ->
+                values
+                |> Map.change s (Option.map (fun _ -> d))
+                |> flip backtracker (next s)
+                |> function
+                | None ->  tracker dx
+                | success -> success
+        [for d in 1..9 do if constraints values s d then d] |> tracker
+
+/// solve sudoku using simple backtracking
+let solve grid = grid |> parseGrid >>= flip backtracker (Some "A1")

Task/Sudoku/F-Sharp/sudoku-2.fs

@@ -0,0 +1,13 @@
+open System
+open SudokuBacktrack
+
+[<EntryPoint>]
+let main argv =
+     let puzzle =  "000028000800010000000000700000600403200004000100700000030400500000000010060000000"
+     puzzle |> printfn "Puzzle:\n%s"
+     puzzle |> parseGrid |> prettyPrint |> printfn "Formatted:\n%s"
+     puzzle |> solve |> prettyPrint |> printfn "Solution:\n%s"
+
+     printfn "Press any key to exit"
+     Console.ReadKey() |> ignore
+     0

Task/Sudoku/F-Sharp/sudoku-3.fs

@@ -0,0 +1,125 @@
+// https://norvig.com/sudoku.html
+// using array O(1) lookup & mutable  instead of map O(logn) immutable - now 6 times faster
+module SudokuCPSArray
+open System
+
+/// from 11 to 99 as squares key maps to 0 to 80 in arrays
+let key a b = (9*a + b) - 10
+
+/// Keys generator
+let cross ax bx = [| for a in ax do for b in bx do key a b |]
+
+let digits  = [|1..9|]
+let rows    = digits
+let cols    = digits
+let empty   = "0,."
+let valid   = "123456789"+empty
+let boxi    = [for b in 1..3..9 -> [|b..b+2|]]
+let squares = cross rows cols
+
+/// List of all row, cols and boxes:  aka units
+let unitlist =
+    [for c in cols -> cross rows [|c|] ]@
+    [for r in rows -> cross [|r|] cols ]@
+    [for rs in boxi do for cs in boxi do cross rs cs ]
+
+/// Dictionary of units for each square
+let units =
+    [|for s in squares do [| for u in unitlist do if u |> Array.contains s then u |] |]
+
+/// Dictionary of all peer squares in the relevant units wrt square in question
+let peers =
+    [| for s in squares do units[s] |> Array.concat |> Array.distinct |> Array.except [s] |]
+
+/// folds folder returning Some on completion or returns None if not
+let rec all folder state source =
+    match state, source with
+    | None, _ -> None
+    | Some st, [] -> Some st
+    | Some st , hd::rest -> folder st hd |> (fun st1 -> all folder st1 rest)
+
+/// Assign digit d to values[s] and propagate (via eliminate)
+/// Return Some values, except None if a contradiction is detected.
+let rec assign (values:int[][]) (s) d =
+    values[s]
+    |> Array.filter ((<>)d)
+    |> List.ofArray |> all (fun vx d1 -> eliminate vx s d1) (Some values)
+
+/// Eliminate digit d from values[s] and propagate when values[s] size is 1.
+/// Return Some values, except return None if a contradiction is detected.
+and eliminate (values:int[][]) s d =
+    let peerElim (values1:int[][]) = // If a square s is reduced to one value d, then *eliminate* d from the peers.
+        match Seq.length values1[s] with
+        | 0 -> None // contradiction - removed last value
+        | 1 -> peers[s] |> List.ofArray |> all (fun vx1 s1 ->  eliminate vx1 s1 (values1[s] |> Seq.head) ) (Some values1)
+        | _ -> Some values1
+
+    let unitsElim values1 = // If a unit u is reduced to only one place for a value d, then *assign* it there.
+        units[s]
+        |> List.ofArray
+        |> all (fun (vx1:int[][]) u ->
+           let sx = [for s in u do if vx1[s] |> Seq.contains d then s]
+           match Seq.length sx with
+           | 0 -> None
+           | 1 -> assign vx1 (Seq.head sx) d
+           | _ -> Some vx1) (Some values1)
+
+    match values[s] |> Seq.contains d with
+    | false ->  Some values // Already eliminated, nothing to do
+    | true ->
+        values[s] <- values[s]|> Array.filter ((<>)d)
+        values
+        |> peerElim
+        |> Option.bind unitsElim
+
+/// Convert grid into a Map of {square: char} with "0","."or"," for empties.
+let parseGrid grid =
+    let cells = [for c in grid do if valid |> Seq.contains c then if empty |> Seq.contains c then 0 else ((string>>int)c)]
+    if Seq.length cells = 81 then cells |> Seq.zip squares |> Map.ofSeq |> Some  else None
+
+/// Convert grid to a Map of constraint propagated possible values, or return None if a contradiction is detected.
+let applyCPS (parsedGrid:Map<_,_>) =
+    let values = [| for s in squares do digits |]
+    parsedGrid
+    |> Seq.filter (fun (KeyValue(_,d)) -> digits |> Seq.contains d)
+    |> List.ofSeq
+    |> all (fun vx (KeyValue(s,d)) -> assign vx s d) (Some values)
+
+/// Calculate string centre for each square - which can contain more than 1 digit when debugging
+let centre s width =
+    let n = width - (Seq.length s)
+    if n <= 0 then s
+    else
+        let half = n/2 + (if (n%2>0 && width%2>0) then 1 else 0)
+        sprintf "%s%s%s" (String(' ',half)) s (String(' ', n - half))
+
+/// Display these values as a 2-D grid. Used for debugging
+let prettyPrint (values:int[][]) =
+    let asString = Seq.map string >> String.concat ""
+    let width = 1 + ([for s in squares do Seq.length values[s]] |> List.max)
+    let line = sprintf "%s\n" ((String('-',width*3) |> Seq.replicate 3) |> String.concat "+")
+    [for r in rows do
+        for c in cols do
+            sprintf "%s%s" (centre (asString values[key r c]) width) (if List.contains c [3;6] then "|" else "")
+        sprintf "\n%s"(if List.contains r [3;6] then line else "") ]
+    |> String.concat ""
+
+/// Outputs single line puzzle with 0 as empty squares
+let asString values = values |> Map.toSeq |> Seq.map (snd>>string) |> String.concat ""
+
+let copy values = values |> Array.map Array.copy
+
+/// Using depth-first search and propagation, try all possible values.
+let rec search (values:int[][])=
+    [for s in squares do if Seq.length values[s] > 1 then Seq.length values[s] ,s]
+    |> function
+    | [] -> Some values // Solved!
+    | list -> // tryPick ~ Norvig's `some`
+        list |> List.minBy fst
+        |> fun (_,s) -> values[s] |> Seq.tryPick (fun d -> assign (copy values) s d |> (Option.bind search))
+
+let run n g f = parseGrid >> function None -> n | Some m -> f m |> g
+let solver = run "Parse Error" (Option.fold (fun _ t -> t |> prettyPrint) "No Solution")
+let solveNoSearch: string -> string = solver applyCPS
+let solveWithSearch: string -> string = solver (applyCPS >> (Option.bind search))
+let solveWithSearchToMapOnly:string -> int[][] option = run None id (applyCPS >> (Option.bind search))

Task/Sudoku/F-Sharp/sudoku-4.fs

@@ -0,0 +1,48 @@
+open System
+open SudokuCPSArray
+open System.Diagnostics
+open System.IO
+
+[<EntryPoint>]
+let main argv =
+     printfn "Easy board solution automatic with constraint propagation"
+     let easy = "..3.2.6..9..3.5..1..18.64....81.29..7.......8..67.82....26.95..8..2.3..9..5.1.3.."
+     easy |> solveNoSearch |> printfn "%s"
+
+     printfn "Simple elimination not possible"
+     let simple = "4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......"
+     simple |> run "Parse Error" asString id |> printfn "%s"
+     simple |> solveNoSearch |> printfn "%s"
+
+     printfn "Try again with search:"
+     simple |> solveWithSearch |> printfn "%s"
+
+     let watch = Stopwatch()
+
+     let hard = "85...24..72......9..4.........1.7..23.5...9...4...........8..7..17..........36.4."
+     printfn "Hard"
+     watch.Start()
+     hard |> solveWithSearch |> printfn "%s"
+     watch.Stop()
+     printfn $"Elapsed milliseconds = {watch.ElapsedMilliseconds } ms"
+     watch.Reset()
+
+     let puzzles  =
+        if Seq.length argv = 1 then
+            let num = argv[0] |> int
+            printfn $"First {num} puzzles in sudoku17 (http://staffhome.ecm.uwa.edu.au/~00013890/sudoku17)"
+            File.ReadLines(@"sudoku17.txt") |> Seq.take num |>Array.ofSeq
+        else
+            printfn $"All puzzles in sudoku17 (http://staffhome.ecm.uwa.edu.au/~00013890/sudoku17)"
+            File.ReadLines(@"sudoku17.txt") |>Array.ofSeq
+     watch.Start()
+     let result = puzzles |> Array.map solveWithSearchToMapOnly
+     watch.Stop()
+     if result |> Seq.forall Option.isSome then
+        let total = watch.ElapsedMilliseconds
+        let avg = (float total) /(float result.Length)
+        printfn $"\nPuzzles:{result.Length}, Total:%.2f{((float)total)/1000.0} s, Average:%.2f{avg} ms"
+     else
+        printfn "Some sudoku17 puzzles failed"
+     Console.ReadKey() |> ignore
+     0

Task/Sudoku/F-Sharp/sudoku-5.fs

@@ -0,0 +1,28 @@
+// Solve Sudoku Like Puzzles. Nigel Galloway: September 6th., 2018
+let fN y n g=let _q n' g'=[for n in n*n'..n*n'+n-1 do for g in g*g'..g*g'+g-1 do yield (n,g)]
+             let N=[|for n in 0..(y/n)-1 do for g in 0..(y/g)-1 do yield _q n g|]
+             (fun n' g'->N.[((n'/n)*n+g'/g)])
+let fI n=let _q g=[for n in 0..n-1 do yield (g,n)]
+         let N=[|for n in 0..n-1 do yield _q n|]
+         (fun g (_:int)->N.[g])
+let fG n=let _q g=[for n in 0..n-1 do yield (n,g)]
+         let N=[|for n in 0..n-1 do yield _q n|]
+         (fun (_:int) n->N.[n])
+let fE v z n g fn=let N,G,B,fn=fI z,fG z,fN z n g,readCSV ',' fn|>List.ofSeq
+                  let fG n g mask=List.except (N n g@G n g@B n g) mask
+                  let b=List.except(List.map(fun n->(n.row,n.col))fn)[for n in 0..z-1 do for g in 0..z-1 do yield (n,g)]
+                  let q=Map.ofList[for v' in v do yield ((v'),List.choose(fun n->if n.value=v' then Some(n.row,n.col) else None)fn|>List.fold(fun z (n,g)->(n,g)::fG n g z)b)]
+                  (fG,(fun n->Map.find n q),z,v)
+let SLPsolve (N,G,z,l)=
+  let rec nQueens col mask res=[
+    if col=z then yield res else
+    yield! List.filter(fun(n,_)->n=col)mask|>List.collect(fun(n,g)->nQueens (col+1) (N n g mask) ((n,g)::res))]
+  let rec sudoku l res=seq{
+    match l with
+    |h::t->let n=nQueens 0 (List.except (List.concat res) (G h)) []
+           yield! n|>Seq.collect(fun n->sudoku t (n::res))
+    |_->yield res}
+  sudoku l []
+let printSLP n g=
+  List.map2(fun n g->List.map(fun(n',g')->((n',g'),n))g) (List.rev n) g|>List.concat|>List.sortBy (fun ((_,n),_)->n)|>List.groupBy(fun ((n,_),_)->n)|>List.sortBy(fun(n,_)->n)
+  |>List.iter(fun (_,n)->n|>Seq.fold(fun z ((_,g),v)->[z..g-1]|>Seq.iter(fun _->printf " |");printf "%s|" v; g+1 ) 0 |>ignore;printfn "")

Task/Sudoku/F-Sharp/sudoku-6.fs

@@ -0,0 +1,2 @@
+let n=SLPsolve (fE ([1..9]|>List.map(string)) 9 3 3 "sud1.csv")
+printSLP ([1..9]|>List.map(string)) (Seq.item 0 n)