Sudoku: Difference between revisions

← Older editNewer edit →
Content deleted Content added
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:
 
/// folds folder returning Some on completion or returns None if not
let rec all folder state =source function=
|match []state, ->source statewith
| None, _ -> None
| hd::rest -> state >>= (fun st -> folder st hd) |> (fun st1 -> all folder st1 rest)▼
| Some st, [] -> Some st
▲ | Some st , hd::rest -> state >>= (fun st -> folder st hd) |> (fun st1 -> all folder st1 rest)
 
/// "A1" to "I9" squares as key in values dictionary
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 |]
 
// constants
let digits = [|1..9|]
let rows = "ABCDEFGHI"digits
let cols = "123456789"digits
let empty = "0,."
let valid = cols"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 do-> cross rows (string [|c)|] ]@
[for r in rows do-> cross (string [|r)|] cols ]@
[for rs in ["ABC";"DEF";"GHI"]boxi do for cs in ["123";"456";"789"]boxi do cross rs cs ]
 
/// Dictionary of units for each square
let units =
Line 4,182 ⟶ 4,185:
/// 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<_,_>) (s:string) d =
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.
Line 4,209 ⟶ 4,212:
/// 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)
Line 4,216 ⟶ 4,219:
/// 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 popagated possible values, or return None if a contradiction is detected.
let applyCPS (parsedGrid:Map<_,_int>) =
let values = [for s in squares do s, digits]|> Map.ofList
parsedGrid
|> (Seq.filter (fun sd(KeyValue(_,d)) -> digits |> Seq.contains sd.Valued)
>> List.ofSeq >> all (fun vx sd(KeyValue(s,d)) -> assign vx sd.Keys sd.Valued) (Some values) )
 
/// Calculate string centre for each square - which can contain more than 1 digit when debugging
Line 4,231 ⟶ 4,234:
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))
 
Line 4,241 ⟶ 4,244:
[for r in rows do
for c in cols do
sprintf "%s%s" (centre (asString values[key r c]) width) (if "36"List.Containscontains c [3;6] then "|" else "")
sprintf "\n%s"(if "CF"List.Containscontains r [3;6] then line else "") ]
|> String.concat ""
 
Line 4,250 ⟶ 4,253:
/// Using depth-first search and propagation, try all possible values.
let rec search (values:Map<_,_>)=
let rec some sx = function
| [] -> None values[Seq.head// sx]No Solution
| s::sx ->
|> Seq.tryPick (fun d -> assign values (Seq.head sx) d >>= search)▼
values[s]
▲ |> Seq.tryPick (fun d -> assign values (Seq.head sx)s d >>= search)
|> function
| Some seqx when Seq.isEmpty seqx -> some (Seq.tail sx) // reduces calls to find fewest possibilities
| Some seq -> Some seq // returns Some in previous stack's tryPick
| _ -> None // returns None in previous stack's tryPick
// 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
| [] -> Some values // solvedSolved!
| list -> list |> List.sortBy fst |> List.map snd |> some
 
// Core API
// Option functions glue/ Command Line Helpers (Could be clearer!)
let optionFuncToStringrun error applyF stringF applyF = parseGrid >> function None -> error | Some m -> applyF m |> stringF
let solver = optionFuncToStringrun "Parse Error" applyCPS (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 =
let solveWithSearchToMapOnly:string -> Map<int,int[]> optionFuncToStringoption "Parse= Error"run None id (applyCPS >> (Option.bind search)) (Option.fold (fun _ t -> t |> prettyPrint) "No Solution") </lang>
'''Usage'''<lang fsharp>open System
open SudokuCPS
Line 4,278 ⟶ 4,283:
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 |> parseGrid |> 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 |> parseGrid |> optionFuncToStringrun "Parse Error" asString id asString |> printfn "%s"
simple |> parseGrid |> solveNoSearch |> printfn "%s"
printfn "Try again with search:"
simple |> parseGrid |> optionFuncToStringrun "Parse Error" prettyPrint (Map.toSeq >> Seq.map (fun (k,v) -> k , string v) >> Map.ofSeq) prettyPrint |> printfn "%s"
simple |> parseGrid |> solvesolveWithSearch |> printfn "%s"
let watch = Stopwatch()
Line 4,294 ⟶ 4,299:
printfn "Hard"
watch.Start()
hard |> parseGrid |> solvesolveWithSearch |> printfn "%s"
watch.Stop()
printfn $"Elapsed milliseconds = {watch.ElapsedMilliseconds } ms"
watch.Reset()
 
printfn $"Alllet puzzles in sudoku17" =
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"
▲ let puzzles = File.ReadAllLinesReadLines(@"sudoku17.txt") |>Array.ofSeq
watch.Start()
let result = puzzles |> Array.map (parseGrid >> solve) solveWithSearchToMapOnly
watch.Stop()
if result |> Seq.forall Option.isSome then
let total = watch.ElapsedMilliseconds
printfn $"\nPuzzles:{result.Length}, Total:%.2f{((float)total)/1000.0} mss, Average:%.2f{((float total) /(float result.Length))} ms"
 
else
printfn "Some sudoku17 puzzles failed"
Console.ReadKey() |> ignore
0</lang>
Line 4,374 ⟶ 4,387:
5 9 8 |7 3 6 |2 4 1
 
Elapsed milliseconds = 711 ms
All puzzles in sudoku17
 
Puzzles:49151, Total:184642332.50 mss, Average:36.756627535553701876 ms</pre>
</pre>
 
===SLPsolve===
Retrieved from "https://rosettacode.org/wiki/Sudoku"