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, Eq)

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

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:

possibleSolutions :: Puzzle -> [Puzzle]
possibleSolutions = filter validPuzzle . filledPuzzles

deciding if a puzzle-state is valid

The problem is symmetric in the rows and columns of the puzzle. We exploit this by only considering the rows of the puzzle and again 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 (== Empty) 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)
  | x == Empty = map (Red:) xss ++ map (Blue:) xss
  | otherwise = map (x:) xss
  where xss = filledRows xs


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.