Jump to content

Sudoku: Difference between revisions

Sudoku (view source)

Revision as of 11:59, 1 December 2021

317 bytes removed ,  2 years ago
m
→‎Constraint Satisfaction (Norvig)
Line 4,139:
<!-- By Martin Freedman, 27/11/2021 -->
<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 = ResultOption.bind g f
 
/// folds folder returning Some on compleitioncompletion or returns None if not
let rec all folder state = Seq.fold (fun acc cur -> acc >>= (fun st -> folder st cur)) statefunction
| [] -> state
| hd::rest -> state >>= (fun st -> folder st hd) |> (fun st1 -> all folder st1 rest)
 
/// "A1" to "I9" squares as key in values dictionary
Line 4,189 ⟶ 4,182:
/// 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<_string,int[]>) (s:string) d =
let peerElim (vx:Map<_string,_int[]>) =
match Seq.length vx[s] with // (1) If a square s is reduced to one value d, then eliminate d from the peers.
| 0 -> Error "peer contradiction"None // removed last value
| 1 -> peers[s] |> List.ofArray |> all (fun st s2 -> eliminate st s2 (vx[s] |> Seq.head) ) (OkSome vx)
| _ -> OkSome vx
let unitsElim vx =
|> functionunits[s] // (2) If a unit u is reduced to only one place for a value d, then put it there.▼
units[s] ▼
|> List.ofArray |> all (fun (st:Map<_string,_int[]>) 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"None
| 1 -> assign st (Seq.head dKeys) d
| _ -> OkSome st) (OkSome vx)
 
match values[s] |> Seq.contains d with
| false -> OkSome values // Already eliminated, nothing to do
| s::sxtrue -> ▼
| true -> // (1) If a square s is reduced to one value d, then eliminate d from the peers.
let values2 = values |> Map.change s (Option.map (fun dx -> dx |> Array.filter ((<>)d)))
peerElim values2
▲ units[s]|> function
▲ |> function // (2) If a unit u is reduced to only one place for a value d, then put it there.
| Error errorNone -> Error errorNone // from peers
| OkSome values3 -> unitsElim values3
 
/// Eliminate all the other values (except d) from values[s] and propagate.
Line 4,219 ⟶ 4,212:
values[s]
|> Seq.filter ((<>)d)
|> List.ofSeq |> all (fun st d2 -> eliminate st s d2) (OkSome values)
 
/// 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 |> OkSome else Error $"parseGrid length ={Seq.length cells}"None
 
/// Convert grid to a Map of constraint popagated possible values, or return None if a contradiction is detected.
let applyCPS grid(parsedGrid:Map<string,int>) =
let values = [for s in squares do s, digits]|> Map.ofList
parseGrid gridparsedGrid
|>>= (Seq.filter (fun sd -> digits |> Seq.contains sd.Value)
>> List.ofSeq >> all (fun vx sd -> assign vx sd.Key sd.Value) (OkSome values) )
 
/// Calculate string centre for each square - which can contain more than 1 digit when debugging
Line 4,242 ⟶ 4,235:
 
/// Display these values as a 2-D grid. Used for debugging
let prettyPrint (valuesOptvalues:Result<Map<_,_>,_>) =
let asString = Seq.map string >> String.concat ""
let width = 1 + ([for s in squares do Seq.length values[s]] |> List.max)
match valuesOpt with
let line = sprintf "%s\n" ((String('-',width*3) |> Seq.replicate 3) |> String.concat "+")
| Error error -> error
|[for Okr valuesin rows do ->
let width = 1 + ([for sc in squarescols do Seq.length values[s]] |> List.max)
let line = sprintf "%s\n%s" (centre (String('-',asString values[key r c]) width*3) |>(if Seq"36".replicateContains 3)c then "|>" String.concatelse "+")
[forsprintf "\n%s"(if "CF".Contains r inthen line rowselse do"") ]
|> String.concat ""▼
for c in cols do
sprintf "%s%s" (centre (asString values[key r c]) width) (if "36".Contains c then "|" else "")
sprintf "\n%s"(if "CF".Contains r then line else "") ]
▲ |> String.concat ""
 
/// Outputs single line puzzle with 0 as empty squares
let | OkasString values ->= values |> Map.toSeq |> Seq.map (snd>>string) |> String.concat "" ▼
let asString = function
▲ | Ok values -> values |> Map.toSeq |> Seq.map (snd>>string) |> String.concat ""
| Error error -> error
 
/// Using depth-first search and propagation, try all possible values.
let rec search (values:Map<_,_>): Result<Map<_,_>,_> =
let rec some sx = function
| [] -> Error "Novalues[Seq.head solution"sx]
|> Seq.tryPick (fun d -> assign values s(Seq.head sx) d >>= search |> function Error _ -> None | Ok seq -> Some seq)▼
▲ | s::sx ->
values[s]
▲ |> Seq.tryPick (fun d -> assign values s d >>= search |> function Error _ -> None | Ok seq -> Some seq)
|> function
| Some seqx when Seq.isEmpty seqx -> some (Seq.tail sx)
| Some seq -> OkSome seq
| _ -> Error "No solution"None
// 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]
|> function
| seqx when Seq.isEmpty seqx[] -> OkSome values // solved!
| seqxlist -> seqxlist |> List.sortBy fst |> id |> List.map snd |> id |> some
 
// Option functions glue/ Command Line Helpers (Could be clearer!)
/// Solve Sudoku using Constraint Propagation
let optionFuncToString error applyF stringF = function None -> error | Some m -> applyF m |> stringF
let solve grid = grid |> applyCPS >>= search |> prettyPrint</lang>
let solveNoSearch =
optionFuncToString "Parse Error" applyCPS (Option.fold (fun _ t -> t |> prettyPrint) "No Solution")
let solve =
optionFuncToString "Parse Error" (applyCPS >> (Option.bind search)) (Option.fold (fun _ t -> t |> prettyPrint) "No Solution") </lang>
'''Usage'''<lang fsharp>open System
open SudokuCPS
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 |> applyCPSparseGrid |> prettyPrintsolveNoSearch |> 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 |> parseGrid |> optionFuncToString "Parse Error" id asString |> printfn "%s\n"
simple |> applyCPSparseGrid |> prettyPrintsolveNoSearch |> printfn "%s"
printfn "Try again with search:"
simple |> parseGrid |> Result.mapoptionFuncToString "Parse Error" (Map.toSeq >> Seq.map (fun (k,v) -> k , string v) >> Map.ofSeq) |> prettyPrint |> printfn "%s"
simple |> parseGrid |> solve |> printfn "%s"
 
let watch = Stopwatch()
 
Line 4,302 ⟶ 4,294:
printfn "Hard"
watch.Start()
hard |> applyCPS >>= searchparseGrid |> prettyPrintsolve |> printfn "%s"
watch.Stop()
printfn $"Elapsed milliseconds = {watch.ElapsedMilliseconds } ms"
watch.Reset()
 
printfn $"First {num}All puzzles in sudoku17" ▼
let num = 10000
let puzzles = File.ReadLinesReadAllLines(@"sudoku17.txt") |> Seq.take num |> ListArray.ofSeq▼
// 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 |> ListArray.map (funparseGrid p -> p |> applyCPS >>= search |> asStringsolve)
watch.Stop()
let total = watch.ElapsedMilliseconds
printfprintfn $"Puzzles\nPuzzles:{numresult.Length}, Total:{total} ms, Average:{((float total) /(float numresult.Length))} ms"
printfn " (i7500U @2.7GHz CPU, 16GB Ram)"
 
Console.ReadKey() |> ignore
0</lang>
{{Output}}Timings run on i7500U @2.75Ghz CPU, 16GB RAM<pre>Easy board solution automatic with constraint propagation▼
</lang>▼
▲{{Output}}<pre>Easy board solution automatic with constraint propagation
4 8 3 |9 2 1 |6 5 7
9 6 7 |3 4 5 |8 2 1
Line 4,336 ⟶ 4,324:
Simple elimination not possible
400000805030000000000700000020000060000080400000010000000603070500200000104000000
 
4 1679 12679 | 139 2369 269 | 8 1239 5
26789 3 1256789 | 14589 24569 245689 | 12679 1249 124679
Line 4,387 ⟶ 4,374:
5 9 8 |7 3 6 |2 4 1
 
Elapsed milliseconds = 87 ms
10000All puzzles in sudoku17
 
Puzzles:10000, Total:46090 ms, Average:4.609 ms (i7500U @2.7GHz CPU, 16GB Ram)</pre>
Puzzles:49151, Total:184642 ms, Average:3.7566275355537018 ms
▲</langpre>
 
===SLPsolve===
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/121405"
Cookies help us deliver our services. By using our services, you agree to our use of cookies.
More information