Anonymous user
Sudoku: Difference between revisions
m
→Constraint Satisfaction (Norvig)
Line 4,139:
<!-- By Martin Freedman, 27/11/2021 -->
<lang fsharp>// https://norvig.com/sudoku.html
// using array O(1) lookup & mutable instead of map O(logn) immutable - now 6 times faster
module
open System
/// from 11 to 99 as squares key maps to 0 to 80 in
let key a b =
/// 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
Line 4,157:
let squares = cross rows cols
/// List of all row, cols and boxes: aka units
let unitlist =
[for c in cols -> cross rows [|c|] ]@
Line 4,165:
/// Dictionary of units for each square
let units =
[|for s in squares do
/// 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] |
▲ [for s in squares do units[s] |> Array.concat |> Array.distinct |> Array.except [s] |> tuple2 s]
|> Map.ofList▼
/// folds folder returning Some on completion or returns None if not
Line 4,183 ⟶ 4,180:
/// Assign digit d to values[s] and propagate (via eliminate)
/// Return Some values, except None if a contradiction is detected.
let rec assign (values:
values[s]
|>
|> List.
/// 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:
let peerElim (
match Seq.length
| 0 -> None // contradiction - removed last value
| 1 -> peers[s] |> List.ofArray |> all (fun
| _ -> Some
let unitsElim
units[s]
|> List.ofArray
|> all (fun
match Seq.length sx with
| 0 -> None
| 1 -> assign
| _ -> Some
match values[s] |> Seq.contains d with
| false -> Some values // Already eliminated, nothing to do
| true ->
values
peerElim values1 |> Option.bind unitsElim▼
|> peerElim
/// Convert grid into a Map of {square: char} with "0","."or"," for empties.
Line 4,218 ⟶ 4,217:
if Seq.length cells = 81 then cells |> Seq.zip squares |> Map.ofSeq |> Some else None
/// Convert grid to a Map of constraint
let applyCPS (parsedGrid:Map<_,
let values = [| for s in squares do
parsedGrid
|>
/// Calculate string centre for each square - which can contain more than 1 digit when debugging
Line 4,234:
/// Display these values as a 2-D grid. Used for debugging
let prettyPrint (values:
let asString = Seq.map string >> String.concat ""
let width = 1 + ([for s in squares do Seq.length values[s]] |> List.max)
Line 4,240:
[for r in rows do
for c in cols do
sprintf "%s%s" (centre (asString values[key r c])
sprintf "\n%s"(if List.contains r [3;6] then line else "") ]
|> String.concat ""
Line 4,246:
/// 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:
[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
Line 4,259 ⟶ 4,262:
let solveNoSearch: string -> string = solver applyCPS
let solveWithSearch: string -> string = solver (applyCPS >> (Option.bind search))
let solveWithSearchToMapOnly:string ->
'''Usage'''<lang fsharp>open System
open
open System.Diagnostics
open System.IO
Line 4,277 ⟶ 4,280:
printfn "Try again with search:"
simple |> solveWithSearch |> printfn "%s"
Line 4,303 ⟶ 4,305:
if result |> Seq.forall Option.isSome then
let total = watch.ElapsedMilliseconds
printfn $"\nPuzzles:{result.Length}, Total:%.2f{((float)total)/1000.0} s, Average:%.2f{avg} ms"
else
printfn "Some sudoku17 puzzles failed"
Line 4,336 ⟶ 4,339:
Try again with search:
4 1 7 |3 6 9 |8 2 5
6 3 2 |1 5 8 |9 4 7
Line 4,373 ⟶ 4,364:
5 9 8 |7 3 6 |2 4 1
Elapsed milliseconds =
All puzzles in sudoku17
Puzzles:49151, Total:
===SLPsolve===
| |||