Sudoku: Difference between revisions

module SudokuCPS

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

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

let rec all folder state = function

| [] -> state

| hd::rest -> state >>= (fun st -> folder st hd) |> (fun st1 -> all folder st1 rest)

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

let peerElim (vx:Map<string,int[]>) =

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

| 0 -> None // removed last value

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

| _ -> Some vx

units[s] // (2) If a unit u is reduced to only one place for a value d, then put it there.

|> List.ofArray |> all (fun (st:Map<string,int[]>) u ->

| 0 -> None

| _ -> Some st) (Some vx)

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

| true ->

|> function

| None -> None // from peers

| Some values3 -> unitsElim values3

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

if Seq.length cells = 81 then cells |> Seq.zip squares |> Map.ofSeq |> Some else None

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

parsedGrid

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

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

let prettyPrint (values:Map<_,_>) =

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 ""

let asString values = values |> Map.toSeq |> Seq.map (snd>>string) |> String.concat ""

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

let rec some sx =

values[Seq.head sx]

|> Seq.tryPick (fun d -> assign values (Seq.head sx) d >>= search)

| Some seqx when Seq.isEmpty seqx -> some (Seq.tail sx)

| Some seq -> Some seq

| _ -> None

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

| [] -> Some values // solved!

| list -> list |> List.sortBy fst |> id |> List.map snd |> id |> some

// Option functions glue/ Command Line Helpers (Could be clearer!)

let optionFuncToString error applyF stringF = function None -> error | Some m -> applyF m |> stringF

let solveNoSearch =

optionFuncToString "Parse Error" applyCPS (Option.fold (fun _ t -> t |> prettyPrint) "No Solution")

let solve =

optionFuncToString "Parse Error" (applyCPS >> (Option.bind search)) (Option.fold (fun _ t -> t |> prettyPrint) "No Solution") </lang>

open System.Diagnostics

open System.IO

let main argv =

easy |> parseGrid |> solveNoSearch |> printfn "%s"

simple |> parseGrid |> optionFuncToString "Parse Error" id asString |> printfn "%s"

simple |> parseGrid |> solveNoSearch |> printfn "%s"

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

simple |> parseGrid |> solve |> printfn "%s"

hard |> parseGrid |> solve |> printfn "%s"

printfn $"All puzzles in sudoku17"

let puzzles = File.ReadAllLines(@"sudoku17.txt") |>Array.ofSeq

let result = puzzles |> Array.map (parseGrid >> solve)

printfn $"\nPuzzles:{result.Length}, Total:{total} ms, Average:{((float total) /(float result.Length))} ms"

0</lang>

{{Output}}Timings run on i7500U @2.75Ghz CPU, 16GB RAM<pre>Easy board solution automatic with constraint propagation

Elapsed milliseconds = 7 ms

All puzzles in sudoku17

Puzzles:49151, Total:184642 ms, Average:3.7566275355537018 ms

</pre>