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: 

type Assignments = Map<(int*int),int> // (r,c), d
type Available = Map<int,Set<int>>
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 =
        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 

 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: 

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 IReadOnlyDictionary<'Key,'Value>
  interface IReadOnlyCollection<KeyValuePair<'Key,'Value>>
  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 IReadOnlyCollection<'T>
  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 : Assignments * Available * Available -> Board
val cells : (int * int) list
val backtrack : (((int * int) * int list * Board) list -> (int * int) list -> Board)
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 -> Board)
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 -> Board)
val restRem : (int * int) list
val avail : int list
val toList : set:Set<'T> -> 'T list (requires comparison)
namespace System
val cells : ls:string list list -> ((int * int) * int) list
val ls : string list list
Multiple items
val string : value:'T -> string

--------------------
type string = String
type 'T list = List<'T>
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
    interface IReadOnlyList<'T>
    interface IReadOnlyCollection<'T>
    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 mapi : mapping:(int -> 'T -> 'U) -> list:'T list -> 'U list
val cols : string list
val strd : string
type Int32 =
  struct
    member CompareTo : value:obj -> int + 1 overload
    member Equals : obj:obj -> bool + 1 overload
    member GetHashCode : unit -> int
    member GetTypeCode : unit -> TypeCode
    member ToString : unit -> string + 3 overloads
    member TryFormat : destination:Span<char> * charsWritten:int * ?format:ReadOnlySpan<char> * ?provider:IFormatProvider -> bool
    static val MaxValue : int
    static val MinValue : int
    static member Parse : s:string -> int + 4 overloads
    static member TryParse : s:string * result:int -> bool + 3 overloads
  end
Int32.TryParse(s: ReadOnlySpan<char>, result: byref<int>) : bool
Int32.TryParse(s: string, result: byref<int>) : bool
Int32.TryParse(s: ReadOnlySpan<char>, style: Globalization.NumberStyles, provider: IFormatProvider, result: byref<int>) : bool
Int32.TryParse(s: string, style: Globalization.NumberStyles, provider: IFormatProvider, result: byref<int>) : bool
union case Option.Some: Value: 'T -> Option<'T>
union case Option.None: Option<'T>
val collect : mapping:('T -> 'U list) -> list:'T list -> 'U list
val choose : chooser:('T -> 'U option) -> list:'T list -> 'U list
val x : ((int * int) * int) option
val boardData1 : string list list
val board1 : Board
val board1S : Board
val board1SolutionData : string list list
val board1Solution : Board

More information

Link:http://fssnip.net/85G
Posted:2 years ago
Author:Faisal Waris
Tags: #sudoku

This web site is created using F# and Suave web server. It is hosted on Azure and the source code is on GitHub. Contributions are welcome!

The first version of fssnip.net has been created by @tomaspetricek back in 2010. This web site is a new, open-source and contribution-friendly version.