6 people like it.

# Sudoku Solver

Fast Sudoku solver in less than 100 lines of F#

 ``` 1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: ``` ``````type Assignments = Map<(int*int),int> // (r,c), d type Available = Map> type Board = Assignments * Available (*row*) * Available (*col*) type AssignmentResult = Done of Board | Infeasible let blockSet = set [1..9] let blockCheck (board:Board) = let asgns,_,_ = board let completedBlockSumOk = asgns |> Map.toSeq |> Seq.map (fun ((r,c),d) -> ((r-1)/3,(c-1)/3), d) |> Seq.groupBy fst |> Seq.filter (fun (block,cells) -> Seq.length cells = 9) |> Seq.forall (fun (block,xs) -> xs |> Seq.map snd |> set = blockSet) if completedBlockSumOk then Done board else Infeasible let available (board:Board) (r,c) = let asgns,ravl,cavl = board Set.intersect ravl.[r] cavl.[c] let assign ((r,c),d) (board:Board) = let asgn,ravl,cavl = board let asgn' = asgn |> Map.add (r,c) d let rSet = ravl.[r] |> Set.remove d let cSet = cavl.[c] |> Set.remove d let ravl' = ravl |> Map.add r rSet let cavl' = cavl |> Map.add c cSet let board' = (asgn',ravl',cavl') blockCheck board' let assignChecked ((r,c), d) (board:Board) = let asgn,ravl,cavl = board if asgn |> Map.containsKey (r,c) then Infeasible else if available board (r,c) |> Set.contains d then assign ((r,c),d) board else Infeasible let newBoard() : Board = Map.empty, [for r in 1 .. 9 -> r, set [1 .. 9]] |> Map.ofList, [for c in 1 .. 9 -> c, set [1 .. 9]] |> Map.ofList let initBoard assignments = (newBoard(),assignments) ||> Seq.fold (fun board ((r,c),d) -> match assignChecked ((r,c),d) board with | Done board -> board | Infeasible -> failwith "invalid assignments" ) let unassignedCells (board:Board) = let asgn,_,_ = board [for r in 1 .. 9 do for c in 1 .. 9 do if asgn |> Map.containsKey (r,c) |> not then yield (r,c)] let solve (board:Board) = let cells = unassignedCells board //cells to fill let rec backtrack asgns rem = match asgns with | [] -> failwith "no solution" | ((r,c),ds,board)::rest -> tryAssign board rest rem ((r,c),ds) //backtrack to prev assignment - try next available digit for the cell and tryAssign board asgns rem curChoices = match curChoices with | ((r,c),[]) -> backtrack asgns ((r,c)::rem) | ((r,c),d::rest) -> match assign ((r,c),d) board with | Done board2 -> loop board2 (((r,c),rest,board)::asgns) rem | Infeasible -> tryAssign board asgns rem ((r,c),rest) and loop board asgns rem = if List.length asgns + List.length rem <> List.length cells then failwith \$"{asgns.Length} + {rem.Length} <> {cells.Length}" match rem with | [] -> board //solution; all empty cells assigned successfully | (r,c)::restRem -> let avail = available board (r,c) |> Set.toList tryAssign board asgns restRem ((r,c),avail) loop board [] cells (************* Test solver *************) open System let cells (ls:string list list) = ls |> List.mapi (fun r cols -> cols |> List.mapi (fun c strd -> match Int32.TryParse strd with | true,d -> Some((r+1,c+1),d) | _ -> None)) |> List.collect (List.choose (fun x->x)) let boardData1 = [ ["5";"3";".";".";"7";".";".";".";"."]; ["6";".";".";"1";"9";"5";".";".";"."]; [".";"9";"8";".";".";".";".";"6";"."]; ["8";".";".";".";"6";".";".";".";"3"]; ["4";".";".";"8";".";"3";".";".";"1"]; ["7";".";".";".";"2";".";".";".";"6"]; [".";"6";".";".";".";".";"2";"8";"."]; [".";".";".";"4";"1";"9";".";".";"5"]; [".";".";".";".";"8";".";".";"7";"9"] ] let board1 = initBoard (cells boardData1) let board1S = solve board1 let board1SolutionData = //there is only 1 solution [ ["5";"3";"4";"6";"7";"8";"9";"1";"2"]; ["6";"7";"2";"1";"9";"5";"3";"4";"8"]; ["1";"9";"8";"3";"4";"2";"5";"6";"7"]; ["8";"5";"9";"7";"6";"1";"4";"2";"3"]; ["4";"2";"6";"8";"5";"3";"7";"9";"1"]; ["7";"1";"3";"9";"2";"4";"8";"5";"6"]; ["9";"6";"1";"5";"3";"7";"2";"8";"4"]; ["2";"8";"7";"4";"1";"9";"6";"3";"5"]; ["3";"4";"5";"2";"8";"6";"1";"7";"9"] ] let board1Solution = initBoard (cells board1SolutionData) board1S = board1Solution //check solution ``````
Multiple items
module Map

from Microsoft.FSharp.Collections

--------------------
type Map<'Key,'Value (requires comparison)> =
interface IEnumerable
interface IComparable
interface IEnumerable<KeyValuePair<'Key,'Value>>
interface ICollection<KeyValuePair<'Key,'Value>>
interface IDictionary<'Key,'Value>
new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>
member Add : key:'Key * value:'Value -> Map<'Key,'Value>
member ContainsKey : key:'Key -> bool
...

--------------------
new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>
Multiple items
val int : value:'T -> int (requires member op_Explicit)

--------------------
type int = int32

--------------------
type int<'Measure> = int
type Available = Map<int,Set<int>>
Multiple items
module Set

from Microsoft.FSharp.Collections

--------------------
type Set<'T (requires comparison)> =
interface IComparable
interface IEnumerable
interface IEnumerable<'T>
interface ICollection<'T>
new : elements:seq<'T> -> Set<'T>
member Add : value:'T -> Set<'T>
member Contains : value:'T -> bool
override Equals : obj -> bool
member IsProperSubsetOf : otherSet:Set<'T> -> bool
...

--------------------
new : elements:seq<'T> -> Set<'T>
type Board = Assignments * Available * Available
type Assignments = Map<(int * int),int>
type AssignmentResult =
| Done of Board
| Infeasible
union case AssignmentResult.Done: Board -> AssignmentResult
union case AssignmentResult.Infeasible: AssignmentResult
val blockSet : Set<int>
val set : elements:seq<'T> -> Set<'T> (requires comparison)
val blockCheck : Assignments * Available * Available -> AssignmentResult
val board : Board
val asgns : Assignments
val completedBlockSumOk : bool
val toSeq : table:Map<'Key,'T> -> seq<'Key * 'T> (requires comparison)
module Seq

from Microsoft.FSharp.Collections
val map : mapping:('T -> 'U) -> source:seq<'T> -> seq<'U>
val r : int
val c : int
val d : int
val groupBy : projection:('T -> 'Key) -> source:seq<'T> -> seq<'Key * seq<'T>> (requires equality)
val fst : tuple:('T1 * 'T2) -> 'T1
val filter : predicate:('T -> bool) -> source:seq<'T> -> seq<'T>
val block : int * int
val cells : seq<(int * int) * int>
val length : source:seq<'T> -> int
val forall : predicate:('T -> bool) -> source:seq<'T> -> bool
val xs : seq<(int * int) * int>
val snd : tuple:('T1 * 'T2) -> 'T2
val available : Assignments * Available * Available -> r:int * c:int -> Set<int>
val ravl : Available
val cavl : Available
val intersect : set1:Set<'T> -> set2:Set<'T> -> Set<'T> (requires comparison)
val assign : (int * int) * d:int -> Assignments * Available * Available -> AssignmentResult
val asgn : Assignments
val asgn' : Map<(int * int),int>
val add : key:'Key -> value:'T -> table:Map<'Key,'T> -> Map<'Key,'T> (requires comparison)
val rSet : Set<int>
val remove : value:'T -> set:Set<'T> -> Set<'T> (requires comparison)
val cSet : Set<int>
val ravl' : Map<int,Set<int>>
val cavl' : Map<int,Set<int>>
val board' : Map<(int * int),int> * Map<int,Set<int>> * Map<int,Set<int>>
val assignChecked : (int * int) * d:int -> Assignments * Available * Available -> AssignmentResult
val containsKey : key:'Key -> table:Map<'Key,'T> -> bool (requires comparison)
val contains : element:'T -> set:Set<'T> -> bool (requires comparison)
val newBoard : unit -> Board
val empty<'Key,'T (requires comparison)> : Map<'Key,'T> (requires comparison)
val ofList : elements:('Key * 'T) list -> Map<'Key,'T> (requires comparison)
val initBoard : assignments:seq<(int * int) * int> -> Board
val assignments : seq<(int * int) * int>
val fold : folder:('State -> 'T -> 'State) -> state:'State -> source:seq<'T> -> 'State
val failwith : message:string -> 'T
val unassignedCells : Assignments * Available * Available -> (int * int) list
val not : value:bool -> bool
val solve : (Board -> 'a)
val cells : (int * int) list
val backtrack : (((int * int) * int list * Board) list -> (int * int) list -> unit)
val asgns : ((int * int) * int list * Board) list
val rem : (int * int) list
val ds : int list
val rest : ((int * int) * int list * Board) list
val tryAssign : (Board -> ((int * int) * int list * Board) list -> (int * int) list -> (int * int) * int list -> unit)
val curChoices : (int * int) * int list
val rest : int list
val board2 : Board
val loop : (Board -> ((int * int) * int list * Board) list -> (int * int) list -> unit)
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
| ( [] )
| ( :: ) of Head: 'T * Tail: 'T list
interface IEnumerable
interface IEnumerable<'T>
member GetReverseIndex : rank:int * offset:int -> int
member GetSlice : startIndex:int option * endIndex:int option -> 'T list
member Head : 'T
member IsEmpty : bool
member Item : index:int -> 'T with get
member Length : int
...
val length : list:'T list -> int
property List.Length: int with get