Literate Futoshiki solver

futoshiki.lhs

Introduction
============

Futoshiki (不等式, meaning “inequality”) is a Japanese logic puzzle similar to
Sudoku and the like. Numbers from 1 to n must be placed on an n-by-n grid
(which usually already contains some values) such that each row and each column
is a permutation of `[1..n]`. Additionally, less-than or greater-than signs are
placed between cells, constraining their mutual ordering.

An example puzzle looks like this:

    [2]   [ ]   [ ]   [ ]
                 ^
    [ ]   [ ]   [ ]   [ ]
    
    [ ] > [ ]   [ ] < [ ]
    
    [ ] > [ ]   [ ]   [2]

We will write a program to solve a given Futoshiki puzzle in Haskell. First,
let’s import some functions we will need:

> {-# LANGUAGE FlexibleInstances #-}
> module Main where

> import Control.Monad
> import Data.Array
> import Data.Char
> import Data.Foldable (foldrM)
> import Data.List
> import Data.Maybe
> import Data.Ord
> import Data.Set (Set)
> import qualified Data.Set as S

Puzzle state
============

We will represent the puzzle state as

* an array of cells containing values, and
* a list of inequality constraints.

Cell values are represented by `Int`s.

> type Value = Int

A cell is a set of candidates. It can be solved or unsolved.

> type Cell = Set Value

> solved :: Cell -> Bool
> solved c = S.size c == 1

> unsolved :: Cell -> Bool
> unsolved = not . solved

The grid is a two-dimensional array of cells.

> type Position = (Int, Int)
> type Grid = Array Position Cell

An inequality constraint says one position in the array is less than another:

> data Inequality = LessThan Position Position deriving (Show, Eq, Ord)

Finally we can define our puzzle representation:

> data Puzzle = Puzzle { grid :: Grid, ineqs :: [Inequality] }
>     deriving (Eq, Show)

This helper function gets us the dimension of a puzzle.

> dim :: Puzzle -> Int
> dim p = let ((0, 0), (x, _)) = bounds (grid p)
>         in x + 1

Reading puzzles
===============

*(If you don't care about parsing/printing the puzzles, skip [here](#solve).)*

The format we will parse looks like this:

    1 .<.
    ^    
    .<3 .
    ^   ^
    . 1<2

First, we wish to parse a string with newlines into a proper 2D array:

> readArray :: String -> Array Position Char
> readArray s =

We find the dimensions of our string as a 2D “box” – its longest line defines
its width, its number of lines defines its height. The bounds for the array are
the corners `(0, 0)` and `(width-1, height-1)`.

>     let ls     = lines s
>         width  = maximum (map length ls)
>         height = length ls
>         bounds = ((0, 0), (width-1, height-1))

Then we also need to pass `array` a list of `[(index, element)]` tuples. We
define a function that gets us the character at `(x, y)`, and then use it on
all indices in the coordinate range to make an array.

`charAt (x, y)` returns the xth character of the yth line, padded with spaces.

>         charAt (x, y) = ((ls !! y) ++ repeat ' ') !! x
>         assocs        = [(i, charAt i) | i <- range bounds]
>     in array bounds assocs

We will now read a string into such an array and transform it into something
that fits our puzzle model. 

> readPuzzle :: String -> Puzzle
> readPuzzle s = let

We read `s` into an array:

>   arr = readArray s

The dimension of the puzzle (`n` in the introductory explanation) must be
square, otherwise we error out.

>   dim = case bounds arr of 
>           ((0, 0), (x, y)) | x == y -> x `div` 2 + 1
>           _ -> error "makePuzzle: invalid puzzle size"
>   gridBounds = ((0, 0), (dim-1, dim-1))

Now our array has a layout like this:

        0   1   2   3   4
    0  [1] [ ] [.] [<] [.]
    1  [^]     [ ]     [ ]
    2  [.] [<] [3] [ ] [.]
    3  [^]     [ ]     [^]
    4  [.] [ ] [1] [<] [2]

We can see that the cells with even coordinates contain the “number” symbols,
and the cells between them (with one component even, the other odd) contain the
“inequality” symbols. The remaining characters (such as the space at `(1, 1)`)
are unimportant.

We use this fact to extract an `assocs` list of cells from the array:

>   assocs = [((x, y), makeCell $ arr ! (2*x, 2*y))
>                | (x, y) <- range gridBounds]

A dot (`.`) represents a cell in which all values are candidates; a digit
(`0-9A-F`) represents an already solved cell.

>   makeCell '.' = S.fromList [1..dim]
>   makeCell c = case checkDigit c of
>                  Just d -> S.fromList [d]
>                  Nothing -> error "makeCell: invalid cell character "
>   checkDigit c | isHexDigit c && 1 <= d && d <= dim = Just d
>                | otherwise                          = Nothing
>     where d = digitToInt c

We can construct the grid, now, from the bounds we found and the `assocs` list:

>   grid = array gridBounds assocs

We read the inequalities next. As we mentioned earlier, the inequality signs
can be found on the coordinates where one component is even and the other is
odd. This is when `x` ≠ `y` (mod 2):

>   inequalityCoords = [(x, y) | (x, y) <- indices arr,
>                                x `mod` 2 /= y `mod` 2]

`readLT` parses a potential inequality sign at `(x, y)` into the inequality
between its neighbours that it represents. If no such sign was found, it
returns `Nothing`.

>   readLT (x, y) '<' = Just $ LessThan ((x - 1) `div` 2, y `div` 2)
>                                       ((x + 1) `div` 2, y `div` 2)
>   readLT (x, y) '>' = Just $ LessThan ((x + 1) `div` 2, y `div` 2)
>                                       ((x - 1) `div` 2, y `div` 2)
>   readLT (x, y) '^' = Just $ LessThan (x `div` 2, (y - 1) `div` 2)
>                                       (x `div` 2, (y + 1) `div` 2)
>   readLT (x, y) 'v' = Just $ LessThan (x `div` 2, (y + 1) `div` 2)
>                                       (x `div` 2, (y - 1) `div` 2)
>   readLT _ ' ' = Nothing
>   readLT _ _   = error "readLT: invalid inequality character"

We read the equalities at these coordinates and collect them in a list:

>   inequalities = catMaybes [readLT p (arr ! p) | p <- inequalityCoords]

And finally we return the puzzle we’ve finished parsing.

>   in Puzzle grid inequalities

Printing puzzles
================

We will also define a method to display these puzzles nicely. To do this, we
define how to show each character, and use unlines with a list comprehension to
put them all together into our final representation.

> showPuzzle :: Puzzle -> String
> showPuzzle p = unlines [[showCharAt (x, y) | x <- [0..2 * dim p - 2]]
>                                            | y <- [0..2 * dim p - 2]]

The same even/odd rules as before apply to `showCharAt`:

>   where showCharAt (x, y) | even x && even y =
>                                 showCell (grid p ! (x `div` 2, y `div` 2))
>                           | odd x && odd y = ' '
>                           | otherwise = showIneq (x, y)

`showCell` displays `.` for unsolved cells and a digit for solved ones:

>         showCell c | solved c  = intToDigit $ S.elemAt 0 c
>                    | otherwise = '.'

`showIneq` looks for inequalities in the list that have a center at `(x, y)`,
then compare its coordinates to find out which way it should point:

>         showIneq c = ineqChar $ listToMaybe $ filter (centersTo c) (ineqs p)
>         ineqChar Nothing = ' '
>         ineqChar (Just (LessThan (x1, y1) (x2, y2)))
>             | x1 < x2 = '<'
>             | x2 < x1 = '>'
>             | y1 < y2 = '^'
>             | y2 < y1 = 'v'
>         centersTo (x, y) (LessThan (x1, y1) (x2, y2))
>             = (x1 + x2, y1 + y2) == (x, y)

<a name="solve"></a>
Solving puzzles
===============

Now let’s get to solving these. These functions get us rows and columns of
the grid:

> rows :: Puzzle -> [[Cell]]
> rows p = [[grid p ! (x, y) | x <- [0..n-1]] | y <- [0..n-1]]
>   where n = dim p

> columns :: Puzzle -> [[Cell]]
> columns = transpose . rows

And these are the corresponding setters:

> setRows :: Puzzle -> [[Cell]] -> Puzzle
> setRows p rs = p { grid = grid p // assocs }
>   where assocs = [((x, y), rs !! y !! x) | x <- [0..n-1], y <- [0..n-1]]
>         n = dim p

> setColumns :: Puzzle -> [[Cell]] -> Puzzle
> setColumns p cs = setRows p (transpose cs)

We combine them into “modifiers” that take a `[[Cell]] -> [[Cell]]` function
and lift it to a `Puzzle -> Puzzle` one, by applying said function to either
rows or columns and `set`ting the results back into the puzzle.

> onRows :: ([[Cell]] -> [[Cell]]) -> (Puzzle -> Puzzle)
> onRows f p = setRows p . f . rows $ p

> onColumns :: ([[Cell]] -> [[Cell]]) -> (Puzzle -> Puzzle)
> onColumns f p = setColumns p . f . columns $ p

Eliminating solved cells
------------------------

Next, we want a general function that takes a list of cells, and deletes all
its solved values from the unsolved cells in it. First, we gather all of the
solved values:

> removeSolved :: [Cell] -> [Cell]
> removeSolved cs = let
>     sols :: [Value]
>     sols = [sol | [sol] <- map S.toList cs]

Then we describe a function `rem` that, given `sol` and `cs`, deletes `sol`
from all unsolved cells in `cs`:

>     rem :: Value -> [Cell] -> [Cell]
>     rem sol cs = [if unsolved c then S.delete sol c else c | c <- cs]

Now we wish to delete each solved value from the list. We must apply:

    rem s1 $ rem s2 $ ... $ rem sn cs
                    
where `s0` through `sn` are elements from `sols`. This is a right fold!

>     in foldr rem cs sols

Placing isolated cells
----------------------

We write a similar function that recognizes situations where only one cell in
a list can contain a given value `v`:

> placeOne :: Value -> [Cell] -> [Cell]
> placeOne v cs = let
>     positions = length $ filter (v `S.member`) cs
>     isolate c = if (v `S.member` c) then S.singleton v else c
>     in if positions == 1 then map isolate cs else cs

We use it to build a function that, given a range of values, gives us a new
`[Cell] -> [Cell]` function that tries to place *all* values in the range:

> placeAll :: [Value] -> [Cell] -> [Cell]
> placeAll range cs = foldr placeOne cs range

The step we will apply to both rows and columns for a given puzzle, then, is:

> rowColStep :: Puzzle -> ([Cell] -> [Cell])
> rowColStep p = removeSolved . placeAll [1..dim p]

We get it to act on both rows and columns like this:

> stepRows :: Puzzle -> Puzzle
> stepRows p = onRows (map (rowColStep p)) p

> stepColumns :: Puzzle -> Puzzle
> stepColumns p = onColumns (map (rowColStep p)) p

Next, we wish to narrow down candidates based on the inequality constraints in
our puzzle: for each inequality `grid(x1, y1) < grid(x2, y2)`, we can keep only
candidates at `(x1, y1)` that are less than the greatest candidate in
`(x2, y2)`. Similarly, we can keep only candidates at `(x2, y2)` that are
greater than the least candidate in `(x1, y1)`.

> applyInequality :: Inequality -> Puzzle -> Puzzle
> applyInequality (LessThan p1 p2) p = let
>     c1 = grid p ! p1
>     c2 = grid p ! p2
>     c1' = S.filter (< S.findMax c2) c1
>     c2' = S.filter (> S.findMin c1) c2
>     in p { grid = grid p // [(p1, c1'), (p2, c2')] }

Given a puzzle `p`, we wish to apply all inequalities in `ineqs p` to it:

    applyInequality q0 $ applyInequality q1 $ ... $ applyInequality qn p
    
where `q0` through `qn` are elements from `ineqs p`. Whoa! Another right fold:

> stepInequalities :: Puzzle -> Puzzle
> stepInequalities p = foldr applyInequality p (ineqs p)

To make a step in solving the puzzle, we handle all rows, columns, and
inequalities once:

> stepPuzzle :: Puzzle -> Puzzle
> stepPuzzle = stepInequalities . stepRows . stepColumns

Our first strategy, then, is to repeatedly call `stepPuzzle` until we no longer
make any progress eliminating candidates:

> eliminate :: Puzzle -> Puzzle
> eliminate p = let p' = stepPuzzle p
>               in if p' == p then p else eliminate p'

We can solve an easy puzzle now:

> easyPuzzle :: Puzzle
> easyPuzzle = readPuzzle $ unlines [ "2 . . ." ,
>                                     "    ^  " ,
>                                     ". . . ." ,
>                                     "       " ,
>                                     ".>. .<." ,
>                                     "       " ,
>                                     ".>. . 2" ]

In GHCi:

    *Main> putStrLn . showPuzzle $ eliminate easyPuzzle
    2 4 3 1
        ^
    1 2 4 3
    
    3>1 2<4
    
    4>3 1 2

Introducing backtracking
========================

This strategy, however, will not always yield a solution. When we get stuck,
we’ll apply a backtracking approach – this requires us to rewrite our
functions to not crash in case the puzzle becomes unsolvable. If any of the
cells contains no candidates at all, this has become the case. As it stands,
`stepRows` and `stepColumns` are total, but `applyInequality` will crash if
either of the squares the inequality points to is empty. We rewrite it to
return `Nothing` instead:

> maybeMax :: Set a -> Maybe a
> maybeMax = fmap fst . S.maxView

> maybeMin :: Set a -> Maybe a
> maybeMin = fmap fst . S.minView

> applyInequality' :: Inequality -> Puzzle -> Maybe Puzzle
> applyInequality' (LessThan p1 p2) p = let
>   c1 = grid p ! p1
>   c2 = grid p ! p2
>   in case (maybeMin c1, maybeMax c2) of
>       (Just minC1, Just maxC2) ->
>         let c1' = S.filter (< maxC2) c1
>             c2' = S.filter (> minC1) c2
>             in Just $ p { grid = grid p // [(p1, c1'), (p2, c2')] }
>       _ -> Nothing

We rewrite `stepInequalities` to use this new function:

> stepInequalities' :: Puzzle -> Maybe Puzzle
> stepInequalities' p = foldrM applyInequality' p (ineqs p)

This also affects `stepPuzzle`...

> stepPuzzle' :: Puzzle -> Maybe Puzzle
> stepPuzzle' = stepInequalities' . stepRows . stepColumns

And finally `eliminate`:

> eliminate' :: Puzzle -> Maybe Puzzle
> eliminate' p = case stepPuzzle' p of
>                  Just p' -> if p == p' then Just p' else eliminate' p'
>                  Nothing -> Nothing

Now we will introduce backtracking. We need a way to recognize the solvability
of a given puzzle -- it is stuck if any cell is out of candidates:

> unsolvable :: Puzzle -> Bool
> unsolvable p = any (S.null) (elems $ grid p)

We can update `eliminate'` to turn unsolvable states into `Nothing`:

> eliminate'' :: Puzzle -> Maybe Puzzle
> eliminate'' p = do
>   p' <- eliminate' p
>   guard (not $ unsolvable p')
>   return p'

To solve with backtracking, we call `eliminate''`, and recurse with guesses
filled in if the puzzle is not yet solved. If the recursive call to
`backtrackSolve` returns `Nothing`, we move on to the next guess.

We write a function `whereToBacktrack` that finds the unsolved cell closest to
being solved (i.e., with the least amount of candidates), or `Nothing` if the
entire puzzle is solved.

> whereToBacktrack :: Grid -> Maybe (Position, [Value])
> whereToBacktrack g = do
>   let sortByElementSize = sortBy (comparing (S.size . snd))
>       unsolvedAssocs    = filter (unsolved . snd) (assocs g)
>   (pos, c) <- listToMaybe $ sortByElementSize unsolvedAssocs
>   return (pos, S.toList c)

Then we can write `backtrackSolve`:

> backtrackSolve :: Puzzle -> Maybe Puzzle
> backtrackSolve p = do
>   p' <- eliminate'' p

If `eliminate'' p` returns `Nothing` we’re stuck here and return `Nothing` too.
Otherwise we find out where to backtrack:

>   case whereToBacktrack (grid p') of

If we do find somewhere to go, fill in all possible values and recurse.

>     Just (pos, vs) -> do              -- we have backtracking to do
>       let place assoc = p' { grid = grid p' // [assoc] }
>           branches = [place (pos, S.singleton v) | v <- vs]
>       listToMaybe . catMaybes $ map backtrackSolve branches

If not, we've solved the puzzle!

>     Nothing -> return p'

Now we can solve all puzzles! Here's an example:

> hardPuzzle :: Puzzle
> hardPuzzle = readPuzzle $ unlines [ ". .<. .<.>.>." ,
>                                     "v v          " ,
>                                     ". .>.>. .>.>." ,
>                                     "             " ,
>                                     ". . . . . . ." ,
>                                     "            v" ,
>                                     ". .<. .<5 . 4" ,
>                                     "    ^        " ,
>                                     "3<. 4 . .>.>." ,
>                                     "    v        " ,
>                                     ". . . . . . ." ,
>                                     "          v  " ,
>                                     ". . .>. . . 7" ]

In GHCi:

    *Main> putStrLn $ showPuzzle $ fromJust $ backtrackSolve hardPuzzle
    5 6<7 1<4>3>2
    v v
    1 4>3>2 7>6>5
    
    7 2 5 4 3 1 6
                v
    6 1<2 3<5 7 4
        ^
    3<5 4 7 6>2>1
        v
    4 7 1 6 2 5 3
              v
    2 3 6>5 1 4 7