• GitHub: https://gist.github.com/ambuc/ec5d72fcc6d931afa745e3c8ac100edb

The Puzzle

One Tough Puzzle is a physical jigsaw puzzle made up of nine square pieces. Each side of the square as either a tab or a blank in the shape of one of the four card suits. The goal is to put them all together so they fit, like any jigsaw puzzle.

I will use this post as a tour of some cool Haskell features I’ve been enjoying for the past few months doing Project Euler problems.

The Problem

We number the spaces like so:

+-----------+
| 0 | 1 | 2 |
+-----------+
| 3 | 4 | 5 |
+-----------+
| 6 | 7 | 8 |
+-----------+

Nine pieces in nine slots gives us $9! = 362880$ positional combinations, and nine pieces which can be rotated any of four ways gives us $4^9 = 262144$ rotational combinations, for a total of just over $23\times 10^9$ combinations (accounting for rotational symmetry). Too many to brute force.

The Solution

We can instead try to solve the problem a little bit at a time. Our algorithm will be as follows:

• For position n:
  • generate all possible options for position n
  • validate position n with regard to the pieces around it
  • repeat for position n+1 until done

This has the advantage of trimming the search space as quickly as possible, to avoid having to validate all twenty-three billion possible grids. We will check in at the end and see how many grids or fractions thereof we actually did have to validate.

Using Haskell

My language of choice for this is Haskell, mostly because I’ve been doing Project Euler problems in it recently and I really like the custom data types and flexibility.

data

Haskell has the ability to define custom data types, and compose and define them in interesting ways. In this puzzle we want to be able to inspect and compare tabs and blanks, puzzle pieces, etc.

data Suit = Club | Heart | Diamond | Spade           deriving (Show, Read, Eq)
data Sex  = Out | In                                 deriving (Show, Read, Eq)
data Side = Side { suit :: Suit , sex :: Sex}        deriving (Show, Read)
data Piece = Piece { north :: Side , east  :: Side
                   , south :: Side , west  :: Side } deriving (Show, Read, Eq)

deriving after a custom data type tells Haskell to infer how to print (show), read, or compare variables of that type. Comparisons can be

• Eq, which lets us tell whether or not two things are equal.
• Ord, which lets us tell whether one thing is bigger than another.

In our case, we don’t really have a way to decide whether one Suit or Sex is “bigger” than another, but we do want to check equality.

We define Side and Piece with named fields, which lets us extract those fields with generated getters:

λ> let foo = Side {suit=Club, sex=Out}
λ> suit foo
Club

For two puzzle pieces to be able to meet at an edge, they need to have the same Suit and opposite Sex es. This makes it convenient to define a custom instance of Eq for Side variables. This lets us redefine a == b to check whether two sides are compatible, rather than equal.

instance Eq Side where x == y = (suit x == suit y) && (sex x /= sex y)

Input

I defined the nine pieces in plaintext as follows:

[ "HDdh", "CHsh", "DCcd", "SDsh", "SDhd", "SShc", "CHdc", "HDcc", "HSsc"]

where each character is the tab or blank on the North, East, South, and West faces of a piece. Each letter stands for Heart, Diamond, Spade, or Club, and is uppercase if the side sticks out rather than in.

We have to write a bit of parsing code to turn this a list of Piece objects.

parsePiece [n,e,s,w] = Piece { north = parseSide n, east = parseSide e           
                             , south = parseSide s, west = parseSide w }         
  where parseSide c = Side { suit = parseSuit c, sex =  parseSex c }             
        parseSuit c | toLower c == 'c' = Club                                    
                    | toLower c == 'd' = Diamond                                 
                    | toLower c == 's' = Spade                                   
                    | otherwise        = Heart                                   
        parseSex  c = if isLower c then In else Out                              

Later, we can call

let allPieces = map parsePiece $ [ "HDdh", "CHsh", ... ]

explore

Theory

At the core of this solution is a function I named explore, which takes a known grid and a list of candidates and generates a list of potential grids and their remaining candidates. We represent a grid as a list of pieces [Piece].

explore :: ([Piece], [Piece]) -> [([Piece], [Piece])]

Here is an example of explore in action.

--          known grid
--          |        candidates
--          |        |
--          v        v
λ> explore ([1, 2], [3, 4, 5])
[ ([1, 2, 3], [4, 5]),
  ([1, 2, 4], [3, 5]),
  ([1, 2, 5], [3, 4]) ]

One caveat here is that we don’t just append all the items in the candidates pool to the known grid; because these are puzzle pieces, we need to append all possible rotations of each candidate. So a closer approximation with lower- and upper-case letters might be:

λ> explore ([], ['c', 'd', 'e'])
[ (['c'], ['d', 'e']),
  (['C'], ['d', 'e']),
  (['d'], ['c', 'e']),
  (['D'], ['c', 'e']),
  ... ]

Once we have this explore function, we can validate the list it generates, and then call explore on every remaining grid again. We can repeat this until we are left with complete, valid grids.

Practice

Here’s what the real explore function looks like:

explore :: ([Piece], [Piece]) -> [([Piece], [Piece])]
explore (list, pool) = concatMap pluck [0..(length pool - 1)]
  where pluck i = [ (list ++ [c], excise i pool)
                  | c <- take 4 $ iterate rotate (pool!!i) ]
        excise i xs = take i xs ++ drop (i+1) xs
        rotate piece = Piece { north = east piece, east = south piece
                             , south = west piece, west = north piece }

We define a few helper functions which are pretty useful.

• pluck i implicitly takes the list pool, and returns a list of tuples of the form(newList, newPool), where
  • the newList is the old list plus the selected candidate (at index i), and
  • the newPool is the old pool minus the selected candidate. The whole thing is wrapped in a list comprehension so that rather than returning a tuple, pluck actually returns a list of all four rotations for a selected rotation. concatMap applied pluck to every item in the pool.
• excise i xs returns the xs minus the element at the ith index.
• rotate takes a piece and rotates it 90 degrees. take 4 $ iterate rotate returns a list of the piece at (xs!!i), that piece rotated once, that piece rotate twice… etc, four times. This serves the list comprehension, and then concatMap flattens it into a normal list.

validate

We need to validate each grid or portion of a grid which is generated in an efficient way. If we add pieces in slots zero through nine in order, then each new piece only needs to be compared against the pieces above or to the left of it (if they exist). Thus:

validate :: Int -> [Piece] -> Bool
validate n xs = (not hasAbove || matchAbove) && (not hasLeft || matchLeft)
  where hasLeft    = n `mod` 3 /= 0
        hasAbove   = n >= 3
        matchLeft  = west  (xs!!n) == east  (xs!!(n-1))
        matchAbove = north (xs!!n) == south (xs!!(n-3))

matchLeft and matchAbove both take advantage of our custom instance of Eq for Sides. The getters north, east, south, and west were also generated implicitly from the named fields above.

OK. Let’s put it together.

Finding the solution

step 0 xs = explore ([], xs)
step n xs = filter (\(xs,_) -> validate n xs)
          $ concatMap explore $ step (pred n) xs
main = do
  let allPieces = map parsePiece
                $ [ "HDdh", "CHsh", "DCcd",
                    "SDsh", "SDhd", "SShc",
                    "CHdc", "HDcc", "HSsc" ]
  let sol = fst $ head $ step 8 allPieces

Cool. We can get our list of potential position 0 s easily with step 0 allPieces.

We can then get our list of potential position 1 s with:

step 1 allPieces
-- which turns into
filter (\(xs, _) -> validate 1 xs)) $ concatMap explore $ step 0 xs

This recursion means we validate a list of potential grids before returning it. So, step 8 allPieces generates the list of all potential 8th-poisition grids, which requires Haskell to generate the list of all potential 7th-position grids first, and so on and so on.

Filtering

How much does this save us? Let’s look at the numbers.

λ> print $ length $ step 0 allPieces
36
λ> print $ length $ step 1 allPieces
138
λ> print $ length $ step 2 allPieces
470
λ> print $ length $ step 3 allPieces
1350
λ> print $ length $ step 4 allPieces
474
λ> print $ length $ step 5 allPieces
144
λ> print $ length $ step 6 allPieces
175
λ> print $ length $ step 7 allPieces
28
λ> print $ length $ step 8 allPieces
4

One note – some of these numbers will be off by a factor of four, since a solved grid is the same across any rotation. That’s why there are $4$ valid solutions in the last row – it’s all the same solution across four rotations.

This means there were 36 valid pieces in position 0 (makes sense, since $9\times4$), but only 138 valid pairings for slots 0 and 1 adjacent, far less than the 1152 potentials. We peak at 1350 potential three-in-a-row combinations, and then filter down steadily.

Summing across these numbers, we see that validate must have been called something like 2800 times. Much, much better than validating all 23 billion grids.

Printing

Finally, we define a solution grid like so:

let sol = fst $ head $ step 8 allPieces

Unfortunately this gives us an output like this:

λ> main --solves the puzzle, returns the first valid grid.
[Piece {north = Side {suit = Heart, sex = In}, east = Side {suit = ...

Hard to read and inspect visually. I wrote a prettyprinter which turns that into this:

λ> main
.h. | .c. | .d.
s S | s H | h S
.D. | .S. | .D.
----|-----|----
.d. | .s. | .d.
D h | H h | H c
.H. | .C. | .C.
----|-----|----
.h. | .c. | .c.
S c | C d | D c
.S. | .D. | .H.

Which is much easier to inspect and validate. Here’s the prettyprinter:

renderGrid :: [Piece] -> [String]
renderGrid = intercalate ["----|-----|----"] . map renderRow . chunksOf 3
 where renderRow xs = [ intercalate " | " $ map (\x -> renderSq x!!n) xs
                      | n <- [0..2] ]
       renderSq p = [ "."          ++ [unParse $ north p] ++ "."
                    , [unParse $ west p] ++ " "           ++ [unParse $ east p]
                    , "."          ++ [unParse $ south p] ++ "."
                    ]
       unParse s
         | suit s == Club    = f 'c'
         | suit s == Spade   = f 's'
         | suit s == Diamond = f 'd'
         | otherwise         = f 'h'
         where f = if sex s == Out then toUpper else id

Understanding this particular function is left as an exercise to the reader.

Full Code

You can see the full code here, in a gist.