Home · Blog · Resume

2017-01-22

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

**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.

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.

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

- generate all possible options for position

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.

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)
```

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`

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.

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.

- the newList is the old list plus the selected candidate (at index
`excise i xs`

returns the`xs`

minus the element at the`i`

th 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 `Side`

s. The getters `north`

, `east`

, `south`

, and `west`

were also
generated implicitly from the *named fields* above.

OK. Let’s put it together.

```
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.

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.

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.

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

Email · GitHub · LinkedIn · Instagram · RSS