Anonymous user
Sudoku: Difference between revisions
m
→Constraint Propagation (Norvig)
Line 4,102:
<lang fsharp>// https://norvig.com/sudoku.html
module SudokuCPS
// Throughout this program we have:
// r is a row, e.g. "A"
// c is a column, e.g. "3"
// s is a square, e.g. "A3"
// d is a digit, e.g. 9
// u is a unit, e.g. ["A1","B1","C1","D1","E1","F1","G1","H1","I1"]
// g is a grid, e.g. 81 non-blank chars, e.g. starting with ".18...7...
// values is a dict of possible values, e.g. {"A1":seq{1;2;3;4;8;9}, "A2":seq{8}, ...}
open System
// helpers
let tuple2 a b = a,b
let (>>=) f g =
/// folds folder returning Some on
let all folder state = Seq.fold (fun acc cur -> acc >>= (fun st -> folder st cur)) state
Line 4,117 ⟶ 4,126:
// constants
let digits =
let rows = "ABCDEFGHI"
let cols = "123456789"
Line 4,142 ⟶ 4,151:
/// Eliminate d from values[s] and propagate when values = 1.
/// Return Some values, except return None if a contradiction is detected.
let rec eliminate (values:Map<_,
let peerElim (vx:Map<_,_>) =
match Seq.length vx[s] with
| 1 -> peers[s] |> all (fun st s2 -> eliminate st s2 (
let unitsElim vx =
|> all (fun (st:Map<_,_>) u ->
let dKeys = [for s in u do if st[s] |> Seq.contains d then s]
match Seq.length dKeys with
| 0 -> Error "units contradiction"
| 1 -> assign st (Seq.head dKeys) d
| _ -> Ok st) (Ok vx)
match values[s] |> Seq.contains d with
| false ->
| true
let values2 = values |> Map.change s (Option.map (fun dx -> dx |>
peerElim values2
▲ match Seq.length values2[s] with // (1) If a square s is reduced to one value d2, then eliminate d2 from the peers.
|> function // (2) If a unit u is reduced to only one place for a value d, then put it there.
▲ | 0 -> None // Contradiction: removed last value
| Error error -> Error error // from peers
▲ | 1 -> peers[s] |> all (fun st s2 -> eliminate st s2 (values2[s] |> Seq.head) ) (Some values2)
|
/// Eliminate all the other values (except d) from values[s] and propagate.
/// Return Some values, except None if a contradiction is detected.
and assign (values:Map<_,_>) (s:string) d =
values[s]
|> Seq.filter ((<>)d)
|> all (fun st d2 -> eliminate st s d2) (
/// 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 |>
/// Convert grid to a Map of constraint popagated possible values, or return None if a contradiction is detected.
Line 4,169 ⟶ 4,193:
parseGrid grid
>>= (Seq.filter (fun sd -> digits |> Seq.contains sd.Value)
>> all (fun vx sd -> assign vx sd.Key sd.Value) (
/// Calculate string centre for each square - which can contain more than 1 digit when debugging
Line 4,179 ⟶ 4,203:
sprintf "%s%s%s" (String(' ',half)) s (String(' ', n - half))
/// Display these values as a 2-D grid. Used for debugging
let prettyPrint (valuesOpt:Result<Map<_,_>
let asString = Seq.map string >> String.concat ""
match valuesOpt with
|
|
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 "+")
Line 4,196 ⟶ 4,219:
/// Outputs single line puzzle with 0 as empty squares
let asString = function
|
|
/// Using depth-first search and propagation, try all possible values.
let rec search (values:Map<_,_>): Result<Map<_,_>,_> =
let rec some = function
| [] -> Error "No solution"
|> Seq.tryPick (fun d -> assign values s d >>= search |> function Error _ -> None | Ok seq -> Some seq)
▲ | s::sx ->
|> function
| Some seqx
| Some seq
▲ // Choose the unfilled square(s) s with the fewest possibilities
▲ [for s in squares do if Seq.length values[s] > 1 then Seq.length values[s] ,s]
| seqx when Seq.isEmpty seqx -> Ok values // solved!
| seqx -> seqx |> List.groupBy fst |> List.min |> snd |> List.map snd |> some
▲ |> some
/// Solve Sudoku using Constraint Propagation
Line 4,233 ⟶ 4,256:
printfn "Try again with search:"
simple |> parseGrid |>
simple |>
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 |> applyCPS >>= search |> prettyPrint |> printfn "%s"
watch.Stop()
printfn $"Elapsed milliseconds = {watch.ElapsedMilliseconds } ms"
watch.Reset()
let num = 10000
// http://www.csse.uwa.edu.au/~gordon/sudoku17
printfn $"First {num} puzzles in sudoku17"
let puzzles = File.ReadLines(@"sudoku17.txt") |> Seq.take num |> List.ofSeq
watch.Start()
let result = puzzles |> List.map (fun p -> p |> applyCPS >>= search |> asString)
watch.Stop()
let total = watch.ElapsedMilliseconds
printfn $"Puzzles:{num}, Total:{total} ms, Average:{((float total) /(float num))} ms"
printfn "Press any key to exit"
Line 4,259 ⟶ 4,298:
Simple elimination not possible
400000805030000000000700000020000060000080400000010000000603070500200000104000000
26789
2689 15689 125689 | 7 234569 245689 | 12369 12349 123469
------------------------+------------------------+------------------------
3789 2
3679 15679
36789
------------------------+------------------------+------------------------
289 89 289 | 6 459 3 | 1259 7 12489
5 6789
1 6789 4 | 589 579 5789 | 23569 23589 23689
Try again with search:
4 0 0 |0 0 0 |8 0 5
Line 4,308 ⟶ 4,349:
5 9 8 |7 3 6 |2 4 1
Elapsed milliseconds = 28 ms
First 10000 puzzles in sudoku17
Puzzles:10000, Total:67072 ms, Average:6.7072 ms
Press any key to exit</pre>
| |||