Sudoku: Difference between revisions
Content added Content deleted
(→{{header|F_Sharp|F#}}: Added F# Constraint Propagation (Norvig) Solution) |
|||
Line 3,982: | Line 3,982: | ||
=={{header|F_Sharp|F#}}== |
=={{header|F_Sharp|F#}}== |
||
=== |
===Backtracking=== |
||
<!-- By Martin Freedman, 26/11/2021 --> |
<!-- By Martin Freedman, 26/11/2021 --> |
||
<lang fsharp>module SudokuBacktrack |
<lang fsharp>module SudokuBacktrack |
||
Line 4,097: | Line 4,097: | ||
Press any key to exit |
Press any key to exit |
||
</pre> |
</pre> |
||
===Constraint Propagation (Norvig)=== |
|||
<!-- By Martin Freedman, 27/11/2021 --> |
|||
<lang fsharp>// https://norvig.com/sudoku.html |
|||
module SudokuCPS |
|||
open System |
|||
// helpers |
|||
let tuple2 a b = a,b |
|||
let (>>=) f g = Option.bind g f |
|||
/// folds folder returning Some on completion or returns None if not |
|||
let all folder state = Seq.fold (fun acc cur -> acc >>= (fun st -> folder st cur)) state |
|||
/// "A1" to "I9" squares as key in values dictionary |
|||
let key a b = $"{a}{b}" |
|||
/// 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 = seq {1..9} |
|||
let rows = "ABCDEFGHI" |
|||
let cols = "123456789" |
|||
let empty = "0,." |
|||
let valid = cols+empty |
|||
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"] do for cs in ["123";"456";"789"] do cross rs cs ] |
|||
/// Dictionary of units for each square |
|||
let units = |
|||
[for s in squares do s, [| for u in unitlist do if u |> Array.contains s then u |] ] |
|||
|> Map.ofList |
|||
/// 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] |> tuple2 s] |
|||
|> Map.ofList |
|||
/// 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 d = |
|||
match values[s] |> Seq.contains d with |
|||
| false -> Some values // Already eliminated, nothing to do |
|||
| true -> |
|||
let values2 = values |> Map.change s (Option.map (fun dx -> dx |> Seq.filter ((<>)d))) |
|||
match Seq.length values2[s] with // (1) If a square s is reduced to one value d2, then eliminate d2 from the peers. |
|||
| 0 -> None // Contradiction: removed last value |
|||
| 1 -> peers[s] |> all (fun st s2 -> eliminate st s2 (values2[s] |> Seq.head) ) (Some values2) |
|||
| _ -> 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 d = |
|||
values[s] |
|||
|> Seq.filter ((<>)d) |
|||
|> all (fun st d2 -> eliminate st s d2) (Some 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 |> Some else None |
|||
/// Convert grid to a Map of constraint popagated possible values, or return None if a contradiction is detected. |
|||
let applyCPS grid = |
|||
let values = [for s in squares do s, digits]|> Map.ofList |
|||
parseGrid grid |
|||
>>= (Seq.filter (fun sd -> digits |> Seq.contains sd.Value) |
|||
>> all (fun vx sd -> assign vx sd.Key sd.Value) (Some values) ) |
|||
/// Calculate string centre for each square - which can contain more than 1 digit when debugging |
|||
let centre s width = |
|||
let n = width - (Seq.length s) |
|||
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)) |
|||
let error = "Unable to parse input or solve puzzle" // TODO: Update to Result |
|||
/// Display these values as a 2-D grid. Used for debugging |
|||
let prettyPrint (valuesOpt:Map<_,_> option) = |
|||
let asString = Seq.map string >> String.concat "" |
|||
match valuesOpt with |
|||
| None -> error |
|||
| Some values -> |
|||
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 "+") |
|||
[for r in rows do |
|||
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 asString = function |
|||
| Some values -> values |> Map.toSeq |> Seq.map (snd>>string) |> String.concat "" |
|||
| _ -> error |
|||
/// Using depth-first search and propagation, try all possible values. |
|||
let rec search (values:Map<_,_>) = |
|||
if values |> Map.toSeq |> Seq.forall (fun kvp -> Seq.length (snd kvp) = 1) then Some values |
|||
else |
|||
let rec some = function |
|||
| [] -> None // should not get here |
|||
| s::sx -> |
|||
values[s] |
|||
|> Seq.tryPick (fun d -> assign values s d >>= search) |
|||
|> function |
|||
| Some seqx when Seq.isEmpty seqx -> some sx |
|||
| filled -> filled |
|||
// 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] |
|||
|> List.groupBy fst |> List.min |> snd |> List.map snd |
|||
|> some |
|||
/// Solve Sudoku using Constraint Propagation |
|||
let solve grid = grid |> applyCPS >>= search |> prettyPrint</lang> |
|||
Usage<lang fsharp>open System |
|||
open SudokuCPS |
|||
[<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 |> applyCPS |> prettyPrint |> 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 |> asString |> printfn "%s\n" |
|||
simple |> applyCPS |> prettyPrint |> printfn "%s" |
|||
printfn "Try again with search:" |
|||
simple |> parseGrid |> Option.map (Map.toSeq >> Seq.map (fun (k,v) -> k , string v) >> Map.ofSeq) |> prettyPrint |> printfn "%s" |
|||
simple |> applyCPS >>= search |> prettyPrint |> printfn "%s" |
|||
let hard = "85...24..72......9..4.........1.7..23.5...9...4...........8..7..17..........36.4." |
|||
printfn "Hard" |
|||
hard |> applyCPS >>= search |> prettyPrint |> printfn "%s" |
|||
printfn "Press any key to exit" |
|||
Console.ReadKey() |> ignore |
|||
0 |
|||
</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 |
|||
2 5 1 |8 7 6 |4 9 3 |
|||
------+------+------ |
|||
5 4 8 |1 3 2 |9 7 6 |
|||
7 2 9 |5 6 4 |1 3 8 |
|||
1 3 6 |7 9 8 |2 4 5 |
|||
------+------+------ |
|||
3 7 2 |6 8 9 |5 1 4 |
|||
8 1 4 |2 5 3 |7 6 9 |
|||
6 9 5 |4 1 7 |3 8 2 |
|||
Simple elimination not possible |
|||
400000805030000000000700000020000060000080400000010000000603070500200000104000000 |
|||
4 1679 12679 | 139 2369 1269 | 8 1239 5 |
|||
26789 3 1256789 | 14589 24569 1245689 | 12679 1249 124679 |
|||
2689 15689 125689 | 7 234569 1245689 | 12369 12349 123469 |
|||
------------------------+------------------------+------------------------ |
|||
3789 2 135789 | 3459 34579 4579 | 13579 6 13789 |
|||
3679 15679 135679 | 359 8 25679 | 4 12359 12379 |
|||
36789 456789 356789 | 3459 1 245679 | 23579 23589 23789 |
|||
------------------------+------------------------+------------------------ |
|||
289 89 289 | 6 459 3 | 1259 7 12489 |
|||
5 6789 36789 | 2 479 14789 | 1369 13489 134689 |
|||
1 6789 4 | 589 579 5789 | 23569 23589 23689 |
|||
Try again with search: |
|||
4 0 0 |0 0 0 |8 0 5 |
|||
0 3 0 |0 0 0 |0 0 0 |
|||
0 0 0 |7 0 0 |0 0 0 |
|||
------+------+------ |
|||
0 2 0 |0 0 0 |0 6 0 |
|||
0 0 0 |0 8 0 |4 0 0 |
|||
0 0 0 |0 1 0 |0 0 0 |
|||
------+------+------ |
|||
0 0 0 |6 0 3 |0 7 0 |
|||
5 0 0 |2 0 0 |0 0 0 |
|||
1 0 4 |0 0 0 |0 0 0 |
|||
4 1 7 |3 6 9 |8 2 5 |
|||
6 3 2 |1 5 8 |9 4 7 |
|||
9 5 8 |7 2 4 |3 1 6 |
|||
------+------+------ |
|||
8 2 5 |4 3 7 |1 6 9 |
|||
7 9 1 |5 8 6 |4 3 2 |
|||
3 4 6 |9 1 2 |7 5 8 |
|||
------+------+------ |
|||
2 8 9 |6 4 3 |5 7 1 |
|||
5 7 3 |2 9 1 |6 8 4 |
|||
1 6 4 |8 7 5 |2 9 3 |
|||
Hard |
|||
8 5 9 |6 1 2 |4 3 7 |
|||
7 2 3 |8 5 4 |1 6 9 |
|||
1 6 4 |3 7 9 |5 2 8 |
|||
------+------+------ |
|||
9 8 6 |1 4 7 |3 5 2 |
|||
3 7 5 |2 6 8 |9 1 4 |
|||
2 4 1 |5 9 3 |7 8 6 |
|||
------+------+------ |
|||
4 3 2 |9 8 1 |6 7 5 |
|||
6 1 7 |4 2 5 |8 9 3 |
|||
5 9 8 |7 3 6 |2 4 1 |
|||
Press any key to exit</pre> |
|||
===The Function SLPsolve=== |
===The Function SLPsolve=== |
||
<lang fsharp> |
<lang fsharp> |