Anonymous user
Sudoku: Difference between revisions
→{{header|F_Sharp|F#}}: Added F# Constraint Propagation (Norvig) Solution
(→{{header|F_Sharp|F#}}: Added F# Constraint Propagation (Norvig) Solution) |
|||
Line 3,982:
=={{header|F_Sharp|F#}}==
===
<!-- By Martin Freedman, 26/11/2021 -->
<lang fsharp>module SudokuBacktrack
Line 4,097:
Press any key to exit
</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===
<lang fsharp>
| |||