Building a Sudoku Solver in F#

If you have no idea what F# is, or you have little or no experience with the language, I recommend that you start your journey of discovery at the Microsoft F# Developer Center. You will find the tools and tutorials you need to get started.

I think it is important to point out that there is absolutely no cost associated with getting started in F#: the IDE, the compiler, and the core API are all free downloads available from the Microsoft website. There really is no excuse not to give it a try.

If you are aware of F# but not convinced that it is important to you, then it may help to know that Lucian Wischik, the Specification Lead for Microsoft Visual Basic (that means he is in charge of where the language is headed) has commented on many occasions that knowing F# will put you 3 to 5 years ahead of where VB.NET is now. Both LINQ and the theory behind the recent Async CTP for VB.NET and C# came directly from F#. I'm sure that one of the most recent F# innovations, Type Providers, will also be hitting VB.NET and C# within the next few years.

Besides helping you stay ahead of the curve, F# is a beautiful and succinct language for dealing with problems related to processing large data sets or traversing various kinds of trees. It is an extremely beautiful language to use when dealing with AI, financial applications or, because of the default support for immutable types, multithreaded/multi-process programming.

I am still new to F#, but I've written this example application to share with anyone who is interested. It solves Sudoku puzzles using some common F# programming features such as pattern matching.

This probably does not represent a program that Don Symes (F#'s creator) would find particularly impressive, but it starts the conversation. One known problem is that this application does not handle unsolvable Sudoku puzzles well. Please feel free to comment, and I will update with explanations and corrections as time permits.

*EDIT* I've added some more explanations for what's going on in the code below as comments.

*EDIT* I've added units of measure for cell/block row/column indices. I've also added sequences where I was using complicated List.fold functions.

*EDIT* This is my final version of the application - took care of most of the bugs. As there are, by my calculations, over 20 decillion possible Sudoku permutations, and this is a brute force method of solving them, don't expect to live long enough to solve a truly complex Sudoku puzzle.

module SudokuSolver

// This is known as a unit of measure. By requiring the programmer 
// to specify the unit of measure common mistakes
// regarding type confusion can be averted. Since the difference 
// between a row index and a column index makes a huge
// difference in code (but can be very difficult to detect if mixed up), 
// I am requiring the programmer to specify what
// he or she means.
// (See http://blogs.msdn.com/b/andrewkennedy/archive/
// 2008/08/29/units-of-measure-in-f-part-one-introducing-units.aspx)
[<measure>] type bc = // A Block Column Index
                static member addUom (c:int) = // Adds the unit of measure
                    c * 1<bc>
                static member remUom (c:int<bc>) = // Removes the unit of measure
                    c / 1<bc>
[<measure>] type br = // A Block Row Index
                static member addUom (c:int) = // Adds the unit of measure
                    c * 1

                static member remUom (c:int
) = // Removes the unit of measure
                    c / 1

[<measure>] type cc = // A Cell Column Index
                static member perBlock = 3<cc>
                static member validValueList = [0<cc>; 1<cc>; 
                2<cc>; 3<cc>; 4<cc>; 5<cc>; 6<cc>; 7<cc>; 8<cc>]
                static member addUom (c:int) = // Adds the unit of measure
                    c * 1<cc>
                static member remUom (c:int<cc>) = // Removes the unit of measure
                    c / 1<cc>
[<measure>] type cr = // A Cell Row Index
                static member perBlock = 3<cr>
                static member validValueList = [0<cr>; 1<cr>; 
                2<cr>; 3<cr>; 4<cr>; 5<cr>; 6<cr>; 7<cr>; 8<cr>]
                static member addUom (c:int) = // Adds the unit of measure
                    c * 1<cr>
                static member remUom (c:int<cr>) = // Removes the unit of measure
                    c / 1<cr>

// This is known as a Type Abbreviation, although rather than 
// shortening the name of the type I am providing more
// information.
// (See http://msdn.microsoft.com/en-us/library/dd233246.aspx)
type CellAddress =
    int<cc> * int<cr>

// This is known as an Active Pattern. Basically, it makes 
// pattern matching easier by subdividing the input data into
// different categories. Here I am simply subdividing 
// a Cell Address into valid and invalid categories, but there is a
// lot of power behind this simple construct.
// (See http://msdn.microsoft.com/en-us/library/dd233248.aspx)
let (|ValidCellAddress|InvalidCellAddress|) (input:CellAddress) =
    let col, row = input
    if (col>= 0<cc> && col <=8<cc>) && 
    (row >= 0<cr> && row <= 8<cr>) then ValidCellAddress(input)
    else InvalidCellAddress(input)

// Type Abbreviation
type BlockAddress =
    int<bc> * int


// Active Pattern
let (|ValidBlockAddress|_|) (input:BlockAddress) =
    let col, row = input
    if (col>= 0<bc> && col <=3<bc>) && (row >= 0
 && row <= 3
) then Some(input)
    else None

// This is known as a discriminating union. The purpose here 
// is essentially to make matching easier. Rather than having 
// to try to encode various states via numeric indicators, 
// I can simply set a Cell value as "solved" with its value or
// "unsolved". This is how the Option type works (with Some/None).
// (See http://msdn.microsoft.com/en-us/library/dd233226.aspx)
type CellValue =
    | Solved of int
    | Unsolved

// Type Abbreviation
type SolutionPath =
    CellAddress * int

// Type Abbreviation
type PotentialCellValues =
    int list

// Type Abbreviation
type CellGrid =
    CellValue[,]

// Discriminated Union. Rather than having to create a class 
// with a property that simply tells me the state of a Grid,
// I can "wrap" the Grid in its state. 
// This makes matching a whole lot easier.
type Solution =
    | Initial of CellGrid
    | Attempt of CellGrid
    | Solved of CellGrid
    | Failure of CellGrid

// Type Abbreviation
type SolutionPathNode =
    CellAddress * SolutionPath list

// Converts a CellAddress to the corresponding BlockAddress. 
// I'm assuming the standard Sudoku grid size of 9x9 cells
// with blocks that are 3x3 cells.
let getBlockAddress (cellAddress:CellAddress) : BlockAddress =
    let col, row = cellAddress
    col / cc.perBlock, row / cr.perBlock

// Steps through a grid compiling a list of integers for 
// a given length and using the given function to determine how
// to step from one cell to the next.
let getGridValues (grid:CellGrid) (cellAddresses:seq<celladdress>) =
    seq {
        for cellAddress in cellAddresses do 
            match cellAddress with
            | InvalidCellAddress(_)                 -> yield None
            | ValidCellAddress(colIndex, rowIndex)  ->
                match grid.[cc.remUom colIndex, cr.remUom rowIndex] with
                | CellValue.Solved(value)   -> yield Some(value)
                | CellValue.Unsolved        -> yield None
    } 
    |> Seq.filter (fun value -> match value with 
    | Some(_) -> true | None -> false) 
    |> Seq.map (fun value -> value.Value) 
    |> Seq.toList
    
// Returns a list of ints for the given column 
// (with a start row and length). Unsolved cells are excluded.
let getSomeColValues (grid:CellGrid) 
(colIndex:int<cc>) (startRow:int<cr>) length =
    getGridValues 
        grid 
        (seq<celladdress> { 
            for i in 1..length do 
                yield colIndex, startRow + cr.addUom (i - 1)
            }
        )

// Returns a list of ints for the given column
let getAllColValues (grid:CellGrid) colIndex =
    getSomeColValues grid colIndex 0<cr> 9

exception UnexpectedState of string

let getValsExcept allVals exVals : int list =
    let rec getValsExcept (fVal:int) (remVals:int list) 
    (fexVal:int option) (remexVals:int list) =
        seq {
            match fVal, remVals, fexVal, remexVals with
            | _, _, None, _ -> 
                yield fVal
                match remVals with
                | h::t  -> yield! getValsExcept h t fexVal remexVals
                | []    -> ()
            | _, _, Some(_fexVal), _ when fVal > _fexVal -> 
                match remexVals with
                | exh::ext ->
                    yield! getValsExcept fVal remVals (Some exh) ext
                | [] ->
                    yield! getValsExcept fVal remVals None []
            | _, _, Some(_fexVal), _ when fVal <= _fexVal -> 
                if fVal < _fexVal then yield fVal
                match remVals with
                | h::t -> yield! getValsExcept h t fexVal remexVals
                | [] -> ()
            | _ -> 
                raise (UnexpectedState "Unexpected state in getValsExcept")
        }
        |> Seq.toList

    match (allVals |> List.sort |> Seq.distinct 
    |> Seq.toList), (exVals |> List.sort |> Seq.distinct |> Seq.toList) with
    | [], _ | _, [] -> allVals
    | fVal::remVals, fexVal::remexVals -> 
    getValsExcept fVal remVals (Some fexVal) remexVals


// Returns a list of ints for the given row 
// (with start column and length). Unsolved cells are excluded.
let getSomeRowValues (grid:CellGrid) rowIndex startCol length =
    getGridValues 
        grid 
        (seq<celladdress> { 
            for i in 1..length do 
                yield startCol + cc.addUom (i - 1), rowIndex
            }
        )
    //getGridValues grid (startCol, rowIndex) [] length 
    //(fun (colIndex, rowIndex) -> colIndex + 1<cc>, rowIndex)

// Returns a list of ints for the given row
let getAllRowValues (grid:CellGrid) rowIndex =
    getSomeRowValues grid rowIndex 0<cc> 9

// Returns a list of ints for the given block. Unsolved cells are excluded.
let getBlockValues (grid:CellGrid) (blockAddress:BlockAddress) =
    let blockCol, blockRow = blockAddress
    getSomeRowValues grid ((blockRow * cr.perBlock) + 
    0<cr>) (blockCol * cc.perBlock) 3 @
    getSomeRowValues grid ((blockRow * cr.perBlock) + 
    1<cr>) (blockCol * cc.perBlock) 3 @
    getSomeRowValues grid ((blockRow * cr.perBlock) + 
    2<cr>) (blockCol * cc.perBlock) 3

// For a given cell, returns a list of ints that are 
// not already listed for the cell's row, column or block.
let getPotentialPathsForCell (grid:CellGrid) 
(address:CellAddress) : SolutionPath list =
    let col, row = address
    match grid.[cc.remUom col, cr.remUom row] with
    | CellValue.Solved(value) -> []
    | CellValue.Unsolved ->
        // Find all of the values that are 
        // currently solved for the cell's row, column and block
        getAllColValues grid col @
        getAllRowValues grid row @
        getBlockValues grid (getBlockAddress address)
        // Based on the list above, choose the values 
        // which have not been solved for yet
        |> getValsExcept [1..9]
        // Return a list of all the values which have not 
        // yet been solved for the cell's row, column and block
        |> List.map (fun v -> ((col, row), v))

// Gets a sequence of possible solution paths. 
// A solution path is a tuple of a tuple of the column index and row index
// and a list of potential values for the row/col index. 
// The solution paths are sorted from the least number of
// potential values (excluding 0) to the greatest. 
// These solution paths can then be used recursively to try various
// solutions.
let getSolutionPathNodes grid : SolutionPathNode list = 
    seq {
        for r in cr.validValueList do
            for c in cc.validValueList do
                yield (c, r), getPotentialPathsForCell grid (c, r)
    } 
    |> Seq.filter (fun ((col, row), paths) -> (List.length paths) > 0)
    |> Seq.sortBy (fun ((col, row), paths) -> List.length paths)
    |> Seq.toList
    
let getIsSolutionComplete (grid:CellGrid) =
    seq {
        for r in cr.validValueList do
            for c in cc.validValueList do
                yield (c, r), grid.[cc.remUom c, cr.remUom r]
    } 
    |> Seq.forall 
        (fun ((c, r), value) -> 
            match value with 
            | CellValue.Solved value -> true 
            | CellValue.Unsolved -> false)


let printSolutionPaths (paths:SolutionPath list) : string =
    let rec buildPath (nextPath:SolutionPath) (remPaths:SolutionPath list) =
        seq {
            let ((c, r), v) = nextPath
            yield sprintf "%i%i=%i" (cc.remUom c) (cr.remUom r) v
            match remPaths with
            | h::t -> yield! buildPath h t
            | [] -> ()
        }
    
    let pathStrings =
        match paths with
        | h::t ->
            buildPath h t
        | [] ->
            Seq.empty<string>

    System.String.Join(" ", pathStrings)
    
// This is a helper function to print a Cell Value to a string.
let printCell (cell:CellValue) =
    match cell with
    | CellValue.Solved(value) -> value.ToString()
    | CellValue.Unsolved -> "_"

// This is a helper function to print a Solution to a string. 
// It's not particularly pretty, but it gets the job done. I
// would be interested in suggestions 
// on making this easier to read/maintain.
let printSolution (solution:Solution) =
    let printGrid (grid:CellGrid) =
        " ----------------------- \n" +
        sprintf "| %s %s %s | %s %s %s | %s %s %s |\n"
            (printCell grid.[0,0]) (printCell grid.[1,0]) (printCell grid.[2,0]) 
            (printCell grid.[3,0]) (printCell grid.[4,0]) (printCell grid.[5,0]) 
            (printCell grid.[6,0]) (printCell grid.[7,0]) (printCell grid.[8,0]) +
        sprintf "| %s %s %s | %s %s %s | %s %s %s |\n" 
            (printCell grid.[0,1]) (printCell grid.[1,1]) (printCell grid.[2,1]) 
            (printCell grid.[3,1]) (printCell grid.[4,1]) (printCell grid.[5,1]) 
            (printCell grid.[6,1]) (printCell grid.[7,1]) (printCell grid.[8,1]) +
        sprintf "| %s %s %s | %s %s %s | %s %s %s |\n" 
            (printCell grid.[0,2]) (printCell grid.[1,2]) (printCell grid.[2,2]) 
            (printCell grid.[3,2]) (printCell grid.[4,2]) (printCell grid.[5,2]) 
            (printCell grid.[6,2]) (printCell grid.[7,2]) (printCell grid.[8,2]) +
        " ----------------------- \n" +
        sprintf "| %s %s %s | %s %s %s | %s %s %s |\n" 
            (printCell grid.[0,3]) (printCell grid.[1,3]) (printCell grid.[2,3]) 
            (printCell grid.[3,3]) (printCell grid.[4,3]) (printCell grid.[5,3]) 
            (printCell grid.[6,3]) (printCell grid.[7,3]) (printCell grid.[8,3]) +
        sprintf "| %s %s %s | %s %s %s | %s %s %s |\n" 
            (printCell grid.[0,4]) (printCell grid.[1,4]) (printCell grid.[2,4]) 
            (printCell grid.[3,4]) (printCell grid.[4,4]) (printCell grid.[5,4]) 
            (printCell grid.[6,4]) (printCell grid.[7,4]) (printCell grid.[8,4]) +
        sprintf "| %s %s %s | %s %s %s | %s %s %s |\n" 
            (printCell grid.[0,5]) (printCell grid.[1,5]) (printCell grid.[2,5]) 
            (printCell grid.[3,5]) (printCell grid.[4,5]) (printCell grid.[5,5]) 
            (printCell grid.[6,5]) (printCell grid.[7,5]) (printCell grid.[8,5]) +
        " ----------------------- \n" +
        sprintf "| %s %s %s | %s %s %s | %s %s %s |\n" 
            (printCell grid.[0,6]) (printCell grid.[1,6]) (printCell grid.[2,6]) 
            (printCell grid.[3,6]) (printCell grid.[4,6]) (printCell grid.[5,6]) 
            (printCell grid.[6,6]) (printCell grid.[7,6]) (printCell grid.[8,6]) +
        sprintf "| %s %s %s | %s %s %s | %s %s %s |\n" 
            (printCell grid.[0,7]) (printCell grid.[1,7]) (printCell grid.[2,7]) 
            (printCell grid.[3,7]) (printCell grid.[4,7]) (printCell grid.[5,7]) 
            (printCell grid.[6,7]) (printCell grid.[7,7]) (printCell grid.[8,7]) +
        sprintf "| %s %s %s | %s %s %s | %s %s %s |\n" 
            (printCell grid.[0,8]) (printCell grid.[1,8]) (printCell grid.[2,8]) 
            (printCell grid.[3,8]) (printCell grid.[4,8]) (printCell grid.[5,8]) 
            (printCell grid.[6,8]) (printCell grid.[7,8]) (printCell grid.[8,8]) +
        " ----------------------- \n"

    match solution with
    | Initial(grid) -> 
        "The puzzle is in its initial state.\n" +
        printGrid grid
    | Attempt(grid) -> 
        "The puzzle is in the process of being solved.\n" +
        printGrid grid
    | Solved(grid) -> 
        "The puzzle has been solved.\n" +
        printGrid grid
    | Failure(grid) -> 
        "The puzzle could not be solved.\n" +
        printGrid grid

let rec followSolutionPath grid (paths:SolutionPath list) 
solveNextDelegate solutionPaths =
    match paths with
    | [] -> Failure grid
    | nextPath::remPaths ->
        // The following handful of lines are not very functional. 
        // I had trouble figuring out how to copy
        // an array with a single change - I would appreciate any pointers. 
        let (col, row), solutionPathValue = nextPath
        let newGrid = Array2D.copy grid
        newGrid.[cc.remUom col, cr.remUom row] 
        <- CellValue.Solved(solutionPathValue)
        //printf "Trying value '%i' 
        at position (%i,%i)\n" nextValue col row
        let result = solveNextDelegate (Attempt newGrid) (nextPath::solutionPaths)
        match result with
        | Failure grid -> 
            followSolutionPath grid remPaths solveNextDelegate solutionPaths
        | _ -> result
        
let rec followSolutionPathNodes grid 
(pathNodes:SolutionPathNode list) solveNextDelegate solutionPaths =
    match pathNodes with
    | [] ->
        Failure grid
    | nextPathNode::remPathNodes ->
        match nextPathNode with
        | InvalidCellAddress(_), _ ->
            Failure grid
        | _, [] ->
            followSolutionPathNodes grid 
            remPathNodes solveNextDelegate solutionPaths
        | ValidCellAddress(cellAddress), paths ->
            let result = followSolutionPath 
            grid paths solveNextDelegate solutionPaths
            match result with 
            | Failure _ -> 
                followSolutionPathNodes 
                grid remPathNodes solveNextDelegate solutionPaths
            | _ -> result
    
let rec solveNext (solution:Solution) (solutionPaths:SolutionPath list) =
    match solution with
    | Failure grid | Solved grid ->
        solution
    | Initial grid -> 
        solveNext (Attempt grid) solutionPaths
    | Attempt grid -> 
        match getSolutionPathNodes grid with
        | [] -> 
            match getIsSolutionComplete grid with
            | true -> 
                Solved grid
            | false -> 
                Failure grid
        | nodes -> 
            followSolutionPathNodes grid nodes solveNext solutionPaths

// This is the function which initializes the grid to 
// its initial values. Coordinates are specified where 0,0 is the
// top-most, left-most cell and 8,8 is the bottom-most, 
// right-most cell. The first number represents the horizontal
// position (x) and the second the vertical (y).
// The sample puzzle below was sourced from Wikipedia 
// (See http://en.wikipedia.org/wiki/Sudoku)
let initPuzzle (puzzle:Solution) =
    match puzzle with
    | Initial(grid) ->
        grid.[0,0] <- CellValue.Solved(5)
        grid.[1,0] <- CellValue.Solved(3)
        grid.[4,0] <- CellValue.Solved(7)

        grid.[0,1] <- CellValue.Solved(6)
        grid.[3,1] <- CellValue.Solved(1)
        grid.[4,1] <- CellValue.Solved(9)
        grid.[5,1] <- CellValue.Solved(5)

        grid.[1,2] <- CellValue.Solved(9)
        grid.[2,2] <- CellValue.Solved(8)
        grid.[7,2] <- CellValue.Solved(6)

        grid.[0,3] <- CellValue.Solved(8)
        grid.[4,3] <- CellValue.Solved(6)
        grid.[8,3] <- CellValue.Solved(3)

        grid.[0,4] <- CellValue.Solved(4)
        grid.[3,4] <- CellValue.Solved(8)
        grid.[5,4] <- CellValue.Solved(3)
        grid.[8,4] <- CellValue.Solved(1)

        grid.[0,5] <- CellValue.Solved(7)
        grid.[4,5] <- CellValue.Solved(2)
        grid.[8,5] <- CellValue.Solved(6)

        grid.[1,6] <- CellValue.Solved(6)
        grid.[6,6] <- CellValue.Solved(2)
        grid.[7,6] <- CellValue.Solved(8)

        grid.[3,7] <- CellValue.Solved(4)
        grid.[4,7] <- CellValue.Solved(1)
        grid.[5,7] <- CellValue.Solved(9)
        grid.[8,7] <- CellValue.Solved(5)

        grid.[4,8] <- CellValue.Solved(8)
        grid.[7,8] <- CellValue.Solved(7)
        grid.[8,8] <- CellValue.Solved(9)
                
        puzzle
    | _ -> 
        puzzle

let puzzle = initPuzzle <| Initial
( Array2D.init 9 9 (fun _ _ -> CellValue.Unsolved) )

printSolution puzzle |> printf "%s"
printf "\n\n"
solveNext puzzle [] |> printSolution |> printf "%s"
ignore <| System.Console.ReadKey(true)