Sudoku: Difference between revisions

Content added Content deleted
m (→‎Constraint Satisfaction (Norvig): 3.7 ms looked too good, even if could not find issue but this 6.7 ms timings with updated code I trust better)
Line 4,146: Line 4,146:


/// folds folder returning Some on completion or returns None if not
/// folds folder returning Some on completion or returns None if not
let rec all folder state = function
let rec all folder state source =
| [] -> state
match state, source with
| None, _ -> None
⚫
| hd::rest -> state >>= (fun st -> folder st hd) |> (fun st1 -> all folder st1 rest)
| Some st, [] -> Some st
⚫
| Some st , hd::rest -> folder st hd |> (fun st1 -> all folder st1 rest)


/// "A1" to "I9" squares as key in values dictionary
/// "A1" to "I9" squares as key in values dictionary
let key a b = $"{a}{b}"
let key a b = 10*a + b// $"{a}{b}"


/// Keys generator
/// 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 |]
let cross ax bx = [| for a in ax do for b in bx do key a b |]


// constants
// constants
let digits = [|1..9|]
let digits = [|1..9|]
let rows = "ABCDEFGHI"
let rows = digits
let cols = "123456789"
let cols = digits
let empty = "0,."
let empty = "0,."
let valid = cols+empty
let valid = "123456789"+empty
let boxi = [for b in 1..3..9 -> [|b..b+2|]]
let squares = cross rows cols
let squares = cross rows cols


// List of all row, cols and boxes: aka units
// List of all row, cols and boxes: aka units
let unitlist =
let unitlist =
[for c in cols do cross rows (string c) ]@
[for c in cols -> cross rows [|c|] ]@
[for r in rows do cross (string r) cols ]@
[for r in rows -> cross [|r|] cols ]@
[for rs in ["ABC";"DEF";"GHI"] do for cs in ["123";"456";"789"] do cross rs cs ]
[for rs in boxi do for cs in boxi do cross rs cs ]

/// Dictionary of units for each square
/// Dictionary of units for each square
let units =
let units =
Line 4,182: Line 4,185:
/// Eliminate d from values[s] and propagate when values = 1.
/// Eliminate d from values[s] and propagate when values = 1.
/// Return Some values, except return None if a contradiction is detected.
/// Return Some values, except return None if a contradiction is detected.
let rec eliminate (values:Map<_,_>) (s:string) d =
let rec eliminate (values:Map<_,_>) s d =
let peerElim (vx:Map<_,_>) =
let peerElim (vx:Map<_,_>) =
match Seq.length vx[s] with // (1) If a square s is reduced to one value d, then eliminate d from the peers.
match Seq.length vx[s] with // (1) If a square s is reduced to one value d, then eliminate d from the peers.
Line 4,209: Line 4,212:
/// Eliminate all the other values (except d) from values[s] and propagate.
/// Eliminate all the other values (except d) from values[s] and propagate.
/// Return Some values, except None if a contradiction is detected.
/// Return Some values, except None if a contradiction is detected.
and assign (values:Map<_,_>) (s:string) d =
and assign (values:Map<_,_>) (s) d =
values[s]
values[s]
|> Seq.filter ((<>)d)
|> Seq.filter ((<>)d)
Line 4,216: Line 4,219:
/// Convert grid into a Map of {square: char} with "0","."or"," for empties.
/// Convert grid into a Map of {square: char} with "0","."or"," for empties.
let parseGrid grid =
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)]
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
if Seq.length cells = 81 then cells |> Seq.zip squares |> Map.ofSeq |> Some else None


/// Convert grid to a Map of constraint popagated possible values, or return None if a contradiction is detected.
/// Convert grid to a Map of constraint popagated possible values, or return None if a contradiction is detected.
let applyCPS (parsedGrid:Map<_,_>) =
let applyCPS (parsedGrid:Map<_,int>) =
let values = [for s in squares do s, digits]|> Map.ofList
let values = [for s in squares do s, digits]|> Map.ofList
parsedGrid
parsedGrid
|> (Seq.filter (fun sd -> digits |> Seq.contains sd.Value)
|> (Seq.filter (fun (KeyValue(_,d)) -> digits |> Seq.contains d)
>> List.ofSeq >> all (fun vx sd -> assign vx sd.Key sd.Value) (Some values) )
>> 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
/// Calculate string centre for each square - which can contain more than 1 digit when debugging
Line 4,231: Line 4,234:
if n <= 0 then s
if n <= 0 then s
else
else
let half = n/2 + ( if (n%2>0 && width%2>0) then 1 else 0)
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))
sprintf "%s%s%s" (String(' ',half)) s (String(' ', n - half))


Line 4,241: Line 4,244:
[for r in rows do
[for r in rows do
for c in cols do
for c in cols do
sprintf "%s%s" (centre (asString values[key r c]) width) (if "36".Contains c then "|" else "")
sprintf "%s%s" (centre (asString values[key r c]) width) (if List.contains c [3;6] then "|" else "")
sprintf "\n%s"(if "CF".Contains r then line else "") ]
sprintf "\n%s"(if List.contains r [3;6] then line else "") ]
|> String.concat ""
|> String.concat ""


Line 4,250: Line 4,253:
/// Using depth-first search and propagation, try all possible values.
/// Using depth-first search and propagation, try all possible values.
let rec search (values:Map<_,_>)=
let rec search (values:Map<_,_>)=
let rec some sx =
let rec some = function
values[Seq.head sx]
| [] -> None // No Solution
| s::sx ->
⚫
|> Seq.tryPick (fun d -> assign values (Seq.head sx) d >>= search)
values[s]
⚫
|> Seq.tryPick (fun d -> assign values s d >>= search)
|> function
|> function
| Some seqx when Seq.isEmpty seqx -> some (Seq.tail sx)
| Some seqx when Seq.isEmpty seqx -> some sx // reduces calls to find fewest possibilities
| Some seq -> Some seq
| Some seq -> Some seq // returns Some in previous stack's tryPick
| _ -> None
| _ -> None // returns None in previous stack's tryPick
// Choose the unfilled square(s) s with the fewest possibilities
// Choose the unfilled square s with the fewest possibilities
[for s in squares do if Seq.length values[s] > 1 then Seq.length values[s] ,s]
[for s in squares do if Seq.length values[s] > 1 then Seq.length values[s] ,s]
|> function
|> function
| [] -> Some values // solved!
| [] -> Some values // Solved!
| list -> list |> List.sortBy fst |> List.map snd |> some
| list -> list |> List.sortBy fst |> List.map snd |> some


// Core API
// Option functions glue/ Command Line Helpers (Could be clearer!)
let optionFuncToString error applyF stringF = function None -> error | Some m -> applyF m |> stringF
let run error stringF applyF = parseGrid >> function None -> error | Some m -> applyF m |> stringF
⚫
let solver = run "Parse Error" (Option.fold (fun _ t -> t |> prettyPrint) "No Solution")
let solveNoSearch =
let solveNoSearch: string -> string = solver applyCPS
⚫
optionFuncToString "Parse Error" applyCPS (Option.fold (fun _ t -> t |> prettyPrint) "No Solution")
let solveWithSearch: string -> string = solver (applyCPS >> (Option.bind search))
let solve =
optionFuncToString "Parse Error" (applyCPS >> (Option.bind search)) (Option.fold (fun _ t -> t |> prettyPrint) "No Solution") </lang>
let solveWithSearchToMapOnly:string -> Map<int,int[]> option = run None id (applyCPS >> (Option.bind search)) </lang>
'''Usage'''<lang fsharp>open System
'''Usage'''<lang fsharp>open System
open SudokuCPS
open SudokuCPS
Line 4,278: Line 4,283:
printfn "Easy board solution automatic with constraint propagation"
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.."
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 |> parseGrid |> solveNoSearch |> printfn "%s"
easy |> solveNoSearch |> printfn "%s"


printfn "Simple elimination not possible"
printfn "Simple elimination not possible"
let simple = "4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......"
let simple = "4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......"
simple |> parseGrid |> optionFuncToString "Parse Error" id asString |> printfn "%s"
simple |> run "Parse Error" asString id |> printfn "%s"
simple |> parseGrid |> solveNoSearch |> printfn "%s"
simple |> solveNoSearch |> printfn "%s"
printfn "Try again with search:"
printfn "Try again with search:"
simple |> parseGrid |> optionFuncToString "Parse Error" (Map.toSeq >> Seq.map (fun (k,v) -> k , string v) >> Map.ofSeq) prettyPrint |> printfn "%s"
simple |> run "Parse Error" prettyPrint (Map.toSeq >> Seq.map (fun (k,v) -> k , string v) >> Map.ofSeq) |> printfn "%s"
simple |> parseGrid |> solve |> printfn "%s"
simple |> solveWithSearch |> printfn "%s"
let watch = Stopwatch()
let watch = Stopwatch()
Line 4,294: Line 4,299:
printfn "Hard"
printfn "Hard"
watch.Start()
watch.Start()
hard |> parseGrid |> solve |> printfn "%s"
hard |> solveWithSearch |> printfn "%s"
watch.Stop()
watch.Stop()
printfn $"Elapsed milliseconds = {watch.ElapsedMilliseconds } ms"
printfn $"Elapsed milliseconds = {watch.ElapsedMilliseconds } ms"
watch.Reset()
watch.Reset()

printfn $"All puzzles in sudoku17"
let puzzles =
if Seq.length argv = 1 then
⚫
let puzzles = File.ReadAllLines(@"sudoku17.txt") |>Array.ofSeq
let num = argv[0] |> int
printfn $"First {num} puzzles in sudoku17"
File.ReadLines(@"sudoku17.txt") |> Seq.take num |>Array.ofSeq
else
printfn $"All puzzles in sudoku17"
⚫
File.ReadLines(@"sudoku17.txt") |>Array.ofSeq
watch.Start()
watch.Start()
let result = puzzles |> Array.map (parseGrid >> solve)
let result = puzzles |> Array.map solveWithSearchToMapOnly
watch.Stop()
watch.Stop()
if result |> Seq.forall Option.isSome then
let total = watch.ElapsedMilliseconds
let total = watch.ElapsedMilliseconds
printfn $"\nPuzzles:{result.Length}, Total:{total} ms, Average:{((float total) /(float result.Length))} ms"
printfn $"\nPuzzles:{result.Length}, Total:%.2f{((float)total)/1000.0} s, Average:%.2f{((float total) /(float result.Length))} ms"

else
printfn "Some sudoku17 puzzles failed"
Console.ReadKey() |> ignore
Console.ReadKey() |> ignore
0</lang>
0</lang>
Line 4,374: Line 4,387:
5 9 8 |7 3 6 |2 4 1
5 9 8 |7 3 6 |2 4 1


Elapsed milliseconds = 7 ms
Elapsed milliseconds = 11 ms
All puzzles in sudoku17
All puzzles in sudoku17


Puzzles:49151, Total:184642 ms, Average:3.7566275355537018 ms
Puzzles:49151, Total:332.50 s, Average:6.76 ms</pre>
</pre>


===SLPsolve===
===SLPsolve===
Retrieved from "https://rosettacode.org/wiki/Sudoku"