1 people like it.

"99 OCaml" #83 Sudoku solver

Every spot in the puzzle belongs to a (horizontal) row and a (vertical) column, as well as to one single 3x3 square (which we call "square" for short). At the beginning, some of the spots carry a single-digit number between 1 and 9. The problem is to fill the missing spots with digits in such a way that every number between 1 and 9 appears exactly once in each row, in each column, and in each square.

Sample sudoku board

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
let problem =
  """ .  .  4 | 8  .  . | .  1  7  
              |         |          
      6  7  . | 9  .  . | .  .  .  
              |         |          
      5  .  8 | .  3  . | .  .  4  
      --------+---------+--------  
      3  .  . | 7  4  . | 1  .  .  
              |         |          
      .  6  9 | .  .  . | 7  8  .  
              |         |          
      .  .  1 | .  6  9 | .  .  5  
      --------+---------+--------  
      1  .  . | .  8  . | 3  .  6  
              |         |          
      .  .  . | .  .  6 | .  9  1  
              |         |          
      2  4  . | .  .  1 | 5  .  .  
  """

Parsing sudoku board and helpers

 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: 
/// Returns all possible positions on a Sudoku board
let positions =
  seq { for x in 0 .. 8 do
          for y in 0 .. 8 do 
            yield x, y }

/// Set of numbers that can appear in a place
let numbers = set [ 1 .. 9 ]

/// Create 2D array containing 'None' for every blank space and
/// 'Some n' for every assigned number. We do this by iterating
/// over lines & over characters and skipping everything that is
/// not '.' or a valid number
let task =
  [ for line in problem.Split('\n') do
      let parsed =
        [ for c in line do
            if c = '.' then yield None
            elif c >= '0' && c <= '9' then yield Some(int c - 48) ] 
      if parsed <> [] then yield parsed ]
  |> array2D

/// We represent the state of the board as a map from indices
/// (this lets us do recursive backtracking nicely)
type Sudoku = Map<int * int, int>

/// Turn the 2D array into a 'Sudoku' value
let state : Sudoku =
  positions |> Seq.choose (fun (x, y) -> 
    task.[x, y] |> Option.map (fun v -> (x, y), v))
  |> Map.ofSeq

Sudoku 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: 
/// Returns the first empty position in the game
/// (or 'None' when all the positions are filled)
let findEmpty (state : Sudoku) = 
  positions |> Seq.tryFind (state.ContainsKey >> not)

/// Returns a list with 3 lists that contain positions 
/// on the board that have to be unique (that is, horizontal
/// line, vertical line and the small square)
let findLines (x, y) = 
  let xs, ys = x/3*3, y/3*3
  [ [ for y in 0 .. 8 -> x, y ]
    [ for x in 0 .. 8 -> x, y ]
    [ for x in 0 .. 2 do for y in 0 .. 2 do yield xs + x, ys + y ] ]

/// Find numbers that are not used on a 'line'
let getUnusedOnLine (state:Sudoku) line =   
  numbers - set (line |> Seq.choose state.TryFind)

/// Recursive sudoku solver. Keeps the current state
/// in an immutable map to make backtracking easy
let rec solve (state:Sudoku) =
  match findEmpty state with
  | Some pos -> 
      // If there is an empty place, find all numbers that we can put there
      let alternatives = 
        findLines pos |> Seq.map (getUnusedOnLine state) |> Set.intersectMany
      // Iterate over alternatives, add the number to the current 'pos'
      // and try calling 'solve' recursively for the rest of the board
      alternatives |> Seq.tryPick (fun v ->
        solve (Map.add pos v state))
  | None -> Some(state)

Printing the result

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
/// Nicely format sudoku board that we get from the solver
let printState (state:Sudoku) =
  let newBlock () =
    [ for i in 0 .. 2 -> String.replicate 9 "-" ]
    |> String.concat "+" |> printfn "+%s+"
  newBlock ()
  for x in 0 .. 8 do 
    printf "|"
    for y in 0 .. 8 do
      match state.TryFind (x, y) with
      | Some v -> printf " %d " v
      | _ -> printf ". "
      if y % 3 = 2 then printf "|"
    printfn ""
    if x % 3 = 2 then newBlock()
    
// Run the solver and print the result!
let solved = solve state
printState solved.Value

Result for the sample board

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
// +---------+---------+---------+
// | 9  3  4 | 8  2  5 | 6  1  7 |
// | 6  7  2 | 9  1  4 | 8  5  3 |
// | 5  1  8 | 6  3  7 | 9  2  4 |
// +---------+---------+---------+
// | 3  2  5 | 7  4  8 | 1  6  9 |
// | 4  6  9 | 1  5  3 | 7  8  2 |
// | 7  8  1 | 2  6  9 | 4  3  5 |
// +---------+---------+---------+
// | 1  9  7 | 5  8  2 | 3  4  6 |
// | 8  5  3 | 4  7  6 | 2  9  1 |
// | 2  4  6 | 3  9  1 | 5  7  8 |
// +---------+---------+---------+
val problem : string

Full name: Script.problem
val positions : seq<int * int>

Full name: Script.positions


 Returns all possible positions on a Sudoku board
Multiple items
val seq : sequence:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Core.Operators.seq

--------------------
type seq<'T> = System.Collections.Generic.IEnumerable<'T>

Full name: Microsoft.FSharp.Collections.seq<_>
val x : int
val y : int
val numbers : Set<int>

Full name: Script.numbers


 Set of numbers that can appear in a place
val set : elements:seq<'T> -> Set<'T> (requires comparison)

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.set
val task : int option [,]

Full name: Script.task


 Create 2D array containing 'None' for every blank space and
 'Some n' for every assigned number. We do this by iterating
 over lines & over characters and skipping everything that is
 not '.' or a valid number
val line : string
System.String.Split([<System.ParamArray>] separator: char []) : string []
System.String.Split(separator: string [], options: System.StringSplitOptions) : string []
System.String.Split(separator: char [], options: System.StringSplitOptions) : string []
System.String.Split(separator: char [], count: int) : string []
System.String.Split(separator: string [], count: int, options: System.StringSplitOptions) : string []
System.String.Split(separator: char [], count: int, options: System.StringSplitOptions) : string []
val parsed : int option list
val c : char
union case Option.None: Option<'T>
union case Option.Some: Value: 'T -> Option<'T>
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

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

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
val array2D : rows:seq<#seq<'T>> -> 'T [,]

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.array2D
type Sudoku = Map<(int * int),int>

Full name: Script.Sudoku


 We represent the state of the board as a map from indices
 (this lets us do recursive backtracking nicely)
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
  override Equals : obj -> bool
  member Remove : key:'Key -> Map<'Key,'Value>
  ...

Full name: Microsoft.FSharp.Collections.Map<_,_>

--------------------
new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>
val state : Sudoku

Full name: Script.state


 Turn the 2D array into a 'Sudoku' value
module Seq

from Microsoft.FSharp.Collections
val choose : chooser:('T -> 'U option) -> source:seq<'T> -> seq<'U>

Full name: Microsoft.FSharp.Collections.Seq.choose
module Option

from Microsoft.FSharp.Core
val map : mapping:('T -> 'U) -> option:'T option -> 'U option

Full name: Microsoft.FSharp.Core.Option.map
val v : int
val ofSeq : elements:seq<'Key * 'T> -> Map<'Key,'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.ofSeq
val findEmpty : state:Sudoku -> (int * int) option

Full name: Script.findEmpty


 Returns the first empty position in the game
 (or 'None' when all the positions are filled)
val state : Sudoku
val tryFind : predicate:('T -> bool) -> source:seq<'T> -> 'T option

Full name: Microsoft.FSharp.Collections.Seq.tryFind
member Map.ContainsKey : key:'Key -> bool
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
val findLines : x:int * y:int -> (int * int) list list

Full name: Script.findLines


 Returns a list with 3 lists that contain positions
 on the board that have to be unique (that is, horizontal
 line, vertical line and the small square)
val xs : int
val ys : int
val getUnusedOnLine : state:Sudoku -> line:seq<int * int> -> Set<int>

Full name: Script.getUnusedOnLine


 Find numbers that are not used on a 'line'
val line : seq<int * int>
member Map.TryFind : key:'Key -> 'Value option
val solve : state:Sudoku -> Sudoku option

Full name: Script.solve


 Recursive sudoku solver. Keeps the current state
 in an immutable map to make backtracking easy
val pos : int * int
val alternatives : Set<int>
val map : mapping:('T -> 'U) -> source:seq<'T> -> seq<'U>

Full name: Microsoft.FSharp.Collections.Seq.map
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
  member IsProperSupersetOf : otherSet:Set<'T> -> bool
  ...

Full name: Microsoft.FSharp.Collections.Set<_>

--------------------
new : elements:seq<'T> -> Set<'T>
val intersectMany : sets:seq<Set<'T>> -> Set<'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Set.intersectMany
val tryPick : chooser:('T -> 'U option) -> source:seq<'T> -> 'U option

Full name: Microsoft.FSharp.Collections.Seq.tryPick
val add : key:'Key -> value:'T -> table:Map<'Key,'T> -> Map<'Key,'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.add
val printState : state:Sudoku -> unit

Full name: Script.printState


 Nicely format sudoku board that we get from the solver
val newBlock : (unit -> unit)
val i : int
module String

from Microsoft.FSharp.Core
val replicate : count:int -> str:string -> string

Full name: Microsoft.FSharp.Core.String.replicate
val concat : sep:string -> strings:seq<string> -> string

Full name: Microsoft.FSharp.Core.String.concat
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
val x : int32
val printf : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printf
val y : int32
val solved : Sudoku option

Full name: Script.solved
property Option.Value: Sudoku
Raw view New version

More information

Link:http://fssnip.net/rk
Posted:1 years ago
Author:Tomas Petricek
Tags: ocaml , sudoku