Sudoku: Difference between revisions

Line 4,139:

<lang fsharp>// https://norvig.com/sudoku.html

// using array O(1) lookup & mutable instead of map O(logn) immutable - now 6 times faster

module ~~SudokuCPS~~

module SudokuCPSArray

open System

/// from 11 to 99 as squares key in ~~values~~ ~~dictionary~~

/// from 11 to 99 as squares key maps to 0 to 80 in arrays

let key a b = 10*a + b// ~~$"{a}{b}"~~

let key a b = (9*a + b) - 10

/// Keys generator

let cross ax bx = [| for a in ax do for b in bx do key a b |]

// constants

let digits = [|1..9|]

let rows = digits

Line 4,157:

let squares = cross rows cols

// List of all row, cols and boxes: aka units

/// 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 s, [| for u in unitlist do if u |> Array.contains s then u |] ]

[|for s in squares do [| 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 =

⚫

let tuple2 a b = a,b

⚫

[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:

Line 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:~~Map<_,_>~~) (s) d =

let rec assign (values:int[][]) (s) d =

values[s]

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

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

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

|> List.ofArray |> all (fun vx d1 -> eliminate vx s d1) (Some values)

/// 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:~~Map<_,_>~~) s d =

and eliminate (values:int[][]) s d =

let peerElim (vx:~~Map<_,_>~~) = // If a square s is reduced to one value d, then *eliminate* d from the peers.

let peerElim (values1:int[][]) = // If a square s is reduced to one value d, then *eliminate* d from the peers.

match Seq.length vx[s] with

match Seq.length values1[s] with

| 0 -> None // removed last value

| 0 -> None // contradiction - removed last value

| 1 -> peers[s] |> List.ofArray |> all (fun st s1 -> eliminate st s1 (vx[s] |> Seq.head) ) (Some vx)

| 1 -> peers[s] |> List.ofArray |> all (fun vx1 s1 -> eliminate vx1 s1 (values1[s] |> Seq.head) ) (Some values1)

| _ -> Some vx

| _ -> Some values1

let unitsElim vx = // If a unit u is reduced to only one place for a value d, then *assign* it there.

let unitsElim values1 = // If a unit u is reduced to only one place for a value d, then *assign* it there.

units[s]

|> List.ofArray ~~|> all (fun (st:Map<_,_>) u ->~~

|> List.ofArray

~~let dKeys =~~ [~~for s in~~ u ~~do if st[s] |~~> ~~Seq.contains d then s]~~

|> all (fun (vx1:int[][]) u ->

~~match~~ Seq.~~length~~ ~~dKeys~~ ~~with~~

let sx = [for s in u do if vx1[s] |> Seq.contains d then s]

match Seq.length sx with

| 0 -> None

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

| 1 -> assign vx1 (Seq.head sx) d

| _ -> Some st) (Some vx)

| _ -> Some vx1) (Some values1)

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

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

| true ->

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

values[s] <- values[s]|> Array.filter ((<>)d)

values

⚫

~~peerElim values1~~ |> Option.bind unitsElim

|> peerElim

⚫

|> Option.bind unitsElim

/// Convert grid into a Map of {square: char} with "0","."or"," for empties.

Line 4,218:

Line 4,217:

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.

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

let applyCPS (parsedGrid:Map<_,~~int~~>) =

let applyCPS (parsedGrid:Map<_,_>) =

let values = [for s in squares do s, digits~~]|>~~ ~~Map.ofList~~

let values = [| for s in squares do digits |]

parsedGrid

|> (Seq.filter (fun (KeyValue(_,d)) -> digits |> Seq.contains d)

|> Seq.filter (fun (KeyValue(_,d)) -> digits |> Seq.contains d)

⚫

|> List.ofSeq

~~>> List.ofSeq >~~> all (fun vx (KeyValue(s,d)) -> assign vx s d) (Some values) )

|> all (fun vx (KeyValue(s,d)) -> assign vx s d) (Some values)

/// 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:~~Map<_,_>~~) =

let prettyPrint (values:int[][]) =

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]) width) (if List.contains c [3;6] then "|" else "")

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:~~Map<_,_>~~)=

let rec search (values:int[][])=

[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 values s d |> (Option.bind search))~~

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:

Line 4,262:

let solveNoSearch: string -> string = solver applyCPS

let solveWithSearch: string -> string = solver (applyCPS >> (Option.bind search))

let solveWithSearchToMapOnly:string -> ~~Map<int,~~int[]> option = run None id (applyCPS >> (Option.bind search)) </lang>

let solveWithSearchToMapOnly:string -> int[][] option = run None id (applyCPS >> (Option.bind search)) </lang>

'''Usage'''<lang fsharp>open System

open ~~SudokuCPS~~

open SudokuCPSArray

open System.Diagnostics

open System.IO

Line 4,277:

Line 4,280:

printfn "Try again with search:"

simple |> run "Parse Error" prettyPrint (Map.toSeq >> Seq.map (fun (k,v) -> k , string v) >> Map.ofSeq) |> printfn "%s"

simple |> solveWithSearch |> printfn "%s"

Line 4,303:

Line 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{(~~(float total) /(float result.Length)~~)} ms"~~

let avg = (float total) /(float result.Length)

printfn $"\nPuzzles:{result.Length}, Total:%.2f{((float)total)/1000.0} s, Average:%.2f{avg} ms"

else

printfn "Some sudoku17 puzzles failed"

Line 4,336:

Line 4,339:

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

Line 4,373:

Line 4,364:

5 9 8 |7 3 6 |2 4 1

Elapsed milliseconds = 15 ms

Elapsed milliseconds = 8 ms

All puzzles in sudoku17

Puzzles:49151, Total:~~327~~.15 s, Average:6.66 ms</pre>

Puzzles:49151, Total:80.99 s, Average:1.65 ms</pre>

===SLPsolve===