SudokuSolver/Version2.fs

   1 module SudokuSolver.Version2
   2
   3 open System
   4 open System.IO
   5 open System.Collections.Generic
   6
   7 let printUsage progname =
   8     printfn "Usage: %A <filename>" progname
   9
  10 type Pos =
  11     { i: int; j: int }
  12     member this.Next : Pos option =
  13         match this with
  14         | { i = 8; j = 8 } -> None
  15         | { i = i; j = 8 } -> Some { i = i + 1; j = 0 }
  16         | { i = _; j = j } -> Some { this with j = j + 1 }
  17
  18 let zoneRange c =
  19     match c with
  20     | 0 | 1 | 2 -> [0 .. 2]
  21     | 3 | 4 | 5 -> [3 .. 5]
  22     | _ -> [6 .. 8]
  23
  24 // All possible positions.
  25 let AllPos = seq {
  26     for i in 0 .. 8 do
  27        for j in 0 .. 8 -> { i = i; j = j } }
  28
  29 type Board (values : seq<int>) =
  30     let size = 9
  31     let board = Array2D.create size size 0
  32
  33     do
  34         Seq.take (size * size) values |> Seq.zip AllPos |> Seq.iter (fun ({ i = iVal; j = jVal}, value) ->
  35             board.[iVal, jVal] <- value)
  36
  37     let get pos = board.[pos.i, pos.j]
  38     let set pos value = board.[pos.i, pos.j] <- value
  39
  40     let rec nextFree (pos : Pos) : Pos option =
  41         match pos.Next with
  42         | Some pos -> if get pos = 0 then Some pos else nextFree pos
  43         | _ -> None
  44
  45     let isValid pos n =
  46         List.forall (fun j -> get { pos with j = j } <> n) [0 .. 8] &&
  47         List.forall (fun i -> get { pos with i = i } <> n) [0 .. 8] &&
  48         List.forall (fun (i, j) -> get { i = i; j = j } <> n) [
  49             for i' in zoneRange pos.i do
  50                 for j' in zoneRange pos.j -> i', j' ]
  51
  52     let validNumbers pos =
  53         [
  54             let valid = isValid pos
  55             for n in 1 .. 9 do
  56                 if valid n then yield n ]
  57
  58     let show (output : TextWriter) =
  59         for i in 0 .. size - 1 do
  60             for j in 0 .. size - 1 do
  61                 if board.[i, j] = 0
  62                 then output.Write '.'
  63                 else output.Write board.[i, j]
  64                 if (j + 1) % 3 = 0 && j <> size - 1 then
  65                     output.Write '|'
  66             output.WriteLine ()
  67             if (i + 1) % 3 = 0 && i <> size - 1 then
  68                 output.WriteLine "-----------"
  69
  70
  71     let presolve () =
  72         let (|OnlyOneNumber|_|) (pos : Pos) =
  73             if get pos <> 0
  74             then None
  75             else
  76                 let numbers = Array.create 10 false
  77                 let nb = ref 0
  78                 let add n =
  79                     if not numbers.[n]
  80                     then
  81                         numbers.[n] <- true
  82                         nb := !nb + 1
  83
  84                 for i in 0 .. 8 do get { pos with i = i } |> add
  85                 for j in 0 .. 8 do get { pos with j = j } |> add
  86                 for i in zoneRange pos.i do
  87                     for j in zoneRange pos.j do
  88                         get { i = i; j = j } |> add
  89
  90                 match !nb with
  91                 | 9 -> try Some (Array.findIndex not numbers) with _ -> None
  92                 | 10 -> None
  93                 | _ ->
  94                     // For all remaining numbers.
  95                     let remainingNumbers = Array.mapi (fun i p -> i, p) numbers
  96                                             |> Array.fold (fun acc (i, p) -> if not p then i :: acc else acc) []
  97
  98                     let rec findNumber numbers =
  99                         match numbers with
 100                         | [] -> None
 101                         | n :: tail ->
 102                             // If there is no other valid position, then the current is the only one.
 103                             if seq {
 104                                     for i in 0 .. 8 do
 105                                         let pos' = { pos with i = i }
 106                                         if i <> pos.i && get pos' = 0
 107                                         then yield not (isValid pos' n) } |> Seq.forall id ||
 108                                seq {
 109                                     for j in 0 .. 8 do
 110                                         let pos' = { pos with j = j }
 111                                         if j <> pos.j && get pos' = 0
 112                                         then yield not (isValid pos' n) } |> Seq.forall id ||
 113                                seq {
 114                                     for i in zoneRange pos.i do
 115                                         for j in zoneRange pos.j do
 116                                             let pos' = { i = i; j = j }
 117                                             if pos' <> pos && get pos' = 0
 118                                             then yield not (isValid pos' n) } |> Seq.forall id
 119                             then Some n
 120                             else findNumber tail
 121
 122                     findNumber remainingNumbers
 123
 124         while Seq.exists (fun pos ->
 125             match pos with
 126             | OnlyOneNumber n -> set pos n; true
 127             | _ -> false) AllPos do ()
 128
 129     new (input : TextReader) =
 130         Board (seq {
 131             while input.Peek () <> -1 do
 132                 match char (input.Read ()) with
 133                 | ' ' | '.' | '0' -> yield 0
 134                 | a when Char.IsDigit a -> yield int (Char.GetNumericValue a)
 135                 | _ -> () } |> Seq.take 81)
 136
 137     member this.Show = show
 138
 139     member this.Solve () =
 140         let rec solveFrom pos : bool = // Returns true if the solution is valid and complete.
 141             match nextFree pos with
 142             | Some pos' ->
 143                 if List.exists (fun n -> set pos' n; solveFrom pos') (validNumbers pos')
 144                 then true
 145                 else
 146                     set pos' 0
 147                     false
 148             | _ -> true
 149         presolve ()
 150         solveFrom { i = 0; j = -1 }