Category / Haskell

by Carsten König

0hh1 puzzle in haskell

I recently came upon yet another great little puzzle: 0h h1:

example 0h h1 game

The rules are quite simple:

  • you have to fill each cell with either a red or a blue value
  • each row and each column must have the same number of red and blue cells
  • no duplicate rows or columns are allowed
  • there may only be two adjacent cells of the same color (horizontal and vertical)

Where we are going

The goal of this mini-series is to give a reimplementation of this using Haskell (or a Haskell-like language) in the browser.

Today I gonna start by just getting a model of this into Haskell and to have some fun with cheating (finding solutions).

data model

Let’s start with a data-model, where we represent a row of the puzzle by a list of cells (empty, blue, red) and the puzzle itself as a list of it’s rows:

data Cell
  = Empty
  | Red
  | Blue
  deriving Show

type Row    = [Cell]
type Puzzle = [Row]

I have to give equality of Cells a special treading:

instance Eq Cell where
  Red   == Red    = True
  Blue  == Blue   = True
  _     == _      = False

because I want to rows to be seen as equal only when the non-empty cells are equal. Because I have to check if a cell is empty from time to time I therefore need another helper:

isEmpty :: Cell -> Bool
isEmpty Empty = True
isEmpty _     = False

because (== Empty) now always returns False.

find all solutions

The task for now should be to find all possible solutions. As the problem size is rather small (after all I want to be able to solve this later – so it has to be really small)
it is ok to brute-force the solution. So the strategy is rather simple: find a possible row based on the current one, make sure that you still get a valid puzzle if you replace the row and recurse into the rest of the puzzle:

possibleSolutions :: Puzzle -> [Puzzle]
possibleSolutions = findSols id 
  where
    findSols _ []     = [[]]
    findSols f (x:xs) = do
      x' <- possibleRows x
      guard (validPuzzle . f $ x':xs)
      xs' <- findSols (f . (x':)) xs
      return (x':xs')

deciding if a puzzle-state is valid

The problem is symmetric in the rows and columns of the puzzle. We can exploit this by observing that the columns are the rows of the transposed puzzle:

validPuzzle :: Puzzle -> Bool
validPuzzle puzzle = validRows puzzle' && validRows puzzle
  where puzzle' = transpose puzzle

Now the rows of a puzzle are valid, if there are no duplicate rows and if each row itself is valid:

validRows :: [Row] -> Bool
validRows rows = all validRow rows && not (containsDup rows)

The test for duplicates just compares each row with it’s successors:

containsDup :: Eq a => [[a]] -> Bool
containsDup [] = False
containsDup (x:xs) = elem x xs || containsDup xs

The check for a single row involves checking that there are no tripples (3 or more consecutive cells of the same color) and checking that each row has the same number of red and blue cells:

validRow :: Row -> Bool
validRow row = not (hasTripples row) && hasBalancedColors row

hasBalancedColors :: Row -> Bool
hasBalancedColors row = any isEmpty row 
                        || count Red == count Blue
  where count color = length . filter (== color) $ row

hasTripples :: Row -> Bool
hasTripples row = 
    any (\ xs -> all (== Blue) xs 
              || all (== Red) xs) 
    $ window 3 row

Here we ignore the balanced check if a row has still empty cells and we use a small helper function:

window :: Int -> [a] -> [[a]]
window n xs
  | length xs >= n = take n xs : window n (drop 1 xs)
  | otherwise     = []

filling up puzzles

To find all filled up puzzles for a certain puzzle we recursively collect all possibilites for it’s rows using a list-comprehension,
that draws from all possibilites for the first row, and all recursive possibilities for the remaining rows and conses them:

filledPuzzles :: Puzzle -> [Puzzle]
filledPuzzles [] = [[]]
filledPuzzles (x:xs) = 
    [ x':xs' | x' <- possibleRows x, xs' <- filledPuzzles xs ]

To find all possibilities for a single row we generate all filled rows for that row and filter for valid rows (yeah it’s a bit of a premature optimization but I think it’s not too bad here):

possibleRows :: Row -> [Row]
possibleRows = filter validRow . filledRows

to find all filled rows based on a given one we look for empty cells in the row and compute all combinations for those holes using a simple recursive algoithm:

filledRows :: Row -> [Row]
filledRows [] = [[]]
filledRows (x:xs)
  | isEmpty x = map (Red:) xss ++ map (Blue:) xss
  | otherwise = map (x:) xss
  where xss = filledRows xs

example

Let’s try out what we have got so far using this example:

example :: Puzzle
example =
  [[Red,   Empty, Empty, Empty, Red,   Blue]
  ,[Empty, Empty, Empty, Empty, Empty, Blue]
  ,[Empty, Blue,  Empty, Red,   Empty, Empty]
  ,[Empty, Empty, Empty, Red,   Red,   Empty]
  ,[Blue,  Empty, Empty, Empty, Empty, Empty]
  ,[Red,   Empty, Blue,  Empty, Empty, Empty]]

possibleSolutions example gives back a one-element list:

[ [[Red,  Red,  Blue, Blue, Red,  Blue]
  ,[Blue, Red,  Red,  Blue, Red,  Blue]
  ,[Blue, Blue, Red,  Red,  Blue, Red]
  ,[Red,  Blue, Blue, Red,  Red,  Blue]
  ,[Blue, Red,  Red,  Blue, Blue, Red]
  ,[Red,  Blue, Blue, Red,  Blue, Red]]]

that seems ok.

That’s it for today – I hope you enjoyed.