Sudoku: Difference between revisions

Line 4,102:

<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 = ~~Option~~.bind g f

let (>>=) f g = Result.bind g f

/// folds folder returning Some on ~~completion~~ or returns None if not

/// folds folder returning Some on compleition or returns None if not

let all folder state = Seq.fold (fun acc cur -> acc >>= (fun st -> folder st cur)) state

Line 4,117:

Line 4,126:

// constants

let digits = ~~seq {~~1..9}

let digits = [|1..9|]

let rows = "ABCDEFGHI"

let cols = "123456789"

Line 4,142:

Line 4,151:

/// 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 =

let rec eliminate (values:Map<_,int[]>) (s:string) d =

let peerElim (vx:Map<_,_>) =

match Seq.length vx[s] with

⚫

| 0 -> Error "peer contradiction" // removed last value

⚫

| 1 -> peers[s] |> all (fun st s2 -> eliminate st s2 (vx[s] |> Seq.head) ) (Ok vx)

⚫

| _ -> Ok vx

⚫

let unitsElim vx =

⚫

units[s]

|> all (fun (st:Map<_,_>) 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"

| 1 -> assign st (Seq.head dKeys) d

| _ -> Ok st) (Ok vx)

match values[s] |> Seq.contains d with

| false -> ~~Some~~ values // Already eliminated, nothing to do

| false -> Ok values // Already eliminated, nothing to do

⚫

| true -> // (1) If a square s is reduced to one value d, then eliminate d from the peers.

| true ->

let values2 = values |> Map.change s (Option.map (fun dx -> dx |> ~~Seq~~.filter ((<>)d)))

let values2 = values |> Map.change s (Option.map (fun dx -> dx |> Array.filter ((<>)d)))

peerElim values2

⚫

~~match Seq.length values2[s] with~~ // (1) If a square s is reduced to one value d2, then eliminate d2 from the peers.

|> function // (2) If a unit u is reduced to only one place for a value d, then put it there.

⚫

| 0 -> ~~None~~ // ~~Contradiction:~~ removed last value

| Error error -> Error error // from peers

⚫

| 1 -> peers[s] |> all (fun st s2 -> eliminate st s2 (~~values2~~[s] |> Seq.head) ) (~~Some~~ ~~values2~~)

| _ -> ~~Some~~ ~~values2~~

| Ok values3 -> unitsElim values3

⚫

/// 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 =

and assign (values:Map<_,_>) (s:string) d =

values[s]

|> Seq.filter ((<>)d)

|> all (fun st d2 -> eliminate st s d2) (~~Some~~ values)

|> all (fun st d2 -> eliminate st s d2) (Ok 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~~

if Seq.length cells = 81 then cells |> Seq.zip squares |> Map.ofSeq |> Ok else Error $"parseGrid length ={Seq.length cells}"

/// Convert grid to a Map of constraint popagated possible values, or return None if a contradiction is detected.

Line 4,169:

Line 4,193:

parseGrid grid

>>= (Seq.filter (fun sd -> digits |> Seq.contains sd.Value)

>> all (fun vx sd -> assign vx sd.Key sd.Value) (~~Some~~ values) )

>> all (fun vx sd -> assign vx sd.Key sd.Value) (Ok values) )

/// Calculate string centre for each square - which can contain more than 1 digit when debugging

Line 4,179:

Line 4,203:

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 prettyPrint (valuesOpt:Result<Map<_,_>,_>) =

let asString = Seq.map string >> String.concat ""

match valuesOpt with

| ~~None~~ -> error

| Error error -> error

| ~~Some~~ values ->

| Ok 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 "+")

Line 4,196:

Line 4,219:

/// Outputs single line puzzle with 0 as empty squares

let asString = function

| ~~Some~~ values -> values |> Map.toSeq |> Seq.map (snd>>string) |> String.concat ""

| Ok values -> values |> Map.toSeq |> Seq.map (snd>>string) |> String.concat ""

| _ -> error

| Error error -> error

/// Using depth-first search and propagation, try all possible values.

let rec search (values:Map<_,_>) =

let rec search (values:Map<_,_>): Result<Map<_,_>,_> =

let rec some = function

if values |> Map.toSeq |> Seq.forall (fun kvp -> Seq.length (snd kvp) = 1) then Some values

| [] -> Error "No solution"

else

~~let~~ ~~rec~~ ~~some = function~~

| s::sx ->

| [] ~~-> None // should not get here~~

values[s]

|> Seq.tryPick (fun d -> assign values s d >>= search |> function Error _ -> None | Ok seq -> Some seq)

⚫

| s~~::sx~~ ->

~~values[s]~~

|> function

|> Seq.~~tryPick~~ ~~(fun d~~ -> ~~assign~~ ~~values s d >>=~~ ~~search)~~

| Some seqx when Seq.isEmpty seqx -> some sx

|> ~~function~~

| Some seq -> Ok seq

| ~~Some seqx when Seq.isEmpty seqx~~ -> ~~some~~ sx

| _ -> Error "Another error"

⚫

// Choose the unfilled square(s) s with the fewest possibilities

| filled -> filled

⚫

[for s in squares do if Seq.length values[s] > 1 then Seq.length values[s] ,s]

⚫

// Choose the unfilled square(s) s with the fewest possibilities

⚫

|> function

⚫

[for s in squares do if Seq.length values[s] > 1 then Seq.length values[s] ,s]

| seqx when Seq.isEmpty seqx -> Ok values // solved!

|> List.groupBy fst |> List.min |> snd |> List.map snd

⚫

|> ~~some~~

/// Solve Sudoku using Constraint Propagation

Line 4,233:

Line 4,256:

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 |> parseGrid |> Result.map (Map.toSeq >> Seq.map (fun (k,v) -> k , string v) >> Map.ofSeq) |> prettyPrint |> printfn "%s"

simple |> ~~applyCPS >>= search |> prettyPrint~~ |> printfn "%s"

simple |> solve |> printfn "%s"

let watch = Stopwatch()

let hard = "85...24..72......9..4.........1.7..23.5...9...4...........8..7..17..........36.4."

printfn "Hard"

watch.Start()

hard |> applyCPS >>= search |> prettyPrint |> printfn "%s"

watch.Stop()

printfn $"Elapsed milliseconds = {watch.ElapsedMilliseconds } ms"

watch.Reset()

let num = 10000

// 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 |> List.map (fun p -> p |> applyCPS >>= search |> asString)

watch.Stop()

let total = watch.ElapsedMilliseconds

printfn $"Puzzles:{num}, Total:{total} ms, Average:{((float total) /(float num))} ms"

printfn "Press any key to exit"

Line 4,259:

Line 4,298:

Simple elimination not possible

400000805030000000000700000020000060000080400000010000000603070500200000104000000

4 1679 12679 | 139 2369 1269 | 8 1239 5

~~26789~~ 3 ~~1256789~~ | ~~14589~~ ~~24569~~ ~~1245689~~ | ~~12679~~ ~~1249~~ ~~124679~~

4 1679 12679 | 139 2369 269 | 8 1239 5

~~2689~~ ~~15689~~ ~~125689~~ | 7 ~~234569~~ ~~1245689~~ | ~~12369~~ ~~12349~~ ~~123469~~

26789 3 1256789 | 14589 24569 245689 | 12679 1249 124679

2689 15689 125689 | 7 234569 245689 | 12369 12349 123469

------------------------+------------------------+------------------------

3789 2 ~~135789~~ | 3459 34579 4579 | 13579 6 13789

3789 2 15789 | 3459 34579 4579 | 13579 6 13789

3679 15679 ~~135679~~ | 359 8 25679 | 4 12359 12379

3679 15679 15679 | 359 8 25679 | 4 12359 12379

36789 ~~456789~~ ~~356789~~ | ~~3459~~ 1 ~~245679~~ | 23579 23589 23789

36789 4 56789 | 359 1 25679 | 23579 23589 23789

------------------------+------------------------+------------------------

289 89 289 | 6 459 3 | 1259 7 12489

5 6789 ~~36789~~ | 2 479 ~~14789~~ | ~~1369~~ ~~13489~~ ~~134689~~

5 6789 3 | 2 479 1 | 69 489 4689

1 6789 4 | 589 579 5789 | 23569 23589 23689

Try again with search:

4 0 0 |0 0 0 |8 0 5

Line 4,308:

Line 4,349:

5 9 8 |7 3 6 |2 4 1

Elapsed milliseconds = 28 ms

First 10000 puzzles in sudoku17

Puzzles:10000, Total:67072 ms, Average:6.7072 ms

Press any key to exit</pre>