Solving a puzzle in Haskell

This post isn’t particularly deep or insightful, but I hope it’s fun!

Some time last December, I purchased a Christmas gift for a family member from the holiday fair in Union Square park in New York. It’s called a “snake cube puzzle”, and is made out of small wooden cubes, through which are threaded a single length of elastic cord via holes drilled in the smaller cubes. There are 27 small cubes, and the challenge is to assemble them into one large cube, which three to a side.

You can see the original puzzle in this YouTube video:

Well, I ended up changing my mind about the gift, so this puzzle sat on my desk unused for quite a few months. At some point, I unfolded it and attempted it myself. It was not a success! So now I had an unfolded puzzle on my desk. The puzzle that I purchased wasn’t the same configuration as the video above, so I couldn’t just follow those steps, either. Eventually, I decided to apply skills that I do have to solve the problem — so I wrote some code to find a solution.

If you’re impatient, here’s what the solution looks like, and a link to explore it interactively.

CodeWorld Snake Cube Puzzle Solver - Source Code

What follows is an explanation of the process of writing this code.

Step 1: Understanding the problem

The first step is to understand how the puzzle works. Essentially, there are two kinds of smaller cubes: in some, the string passes straight through, while in others, it turns 90 degrees. The straight-line pieces don’t present any choice at all, but the 90-degree turns can be rotated to any of the four directions that are orthogonal to the previous direction. The trick is just to decide the correct direction from which to leave each of the 90-degree turns.

Since there’s no choice to be made in the straight-through pieces, there’s no need to model them as separate pieces. Therefore, I separates the puzzle not into smaller cubes but into segments, where a segment consists of all of the pieces leading up to a corner. I defined the length of a segment to be the number of squares one moves to get from one end to the other, so the puzzle is made up on a sequence of segments, each of length either 1 or 2.

In the video above, the segment lengths are something like: 2, 2, 2, 2, 1, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 1, 2. But my puzzle, again, is different. So I wrote:

segments :: [Int]
segments =
    [2, 1, 1, 1, 2, 1, 2, 1, 1, 1, 1, 2, 1, 2, 1, 1, 1, 1, 1, 2]

It’s clear that I’m going to be working with positions in space, and directions. So I next defined some types for these, and a basic operation relating them.

type Pos = (Int, Int, Int)
data Dir = F | B | L | R | U | D deriving (Show)
move :: Dir -> Pos -> Pos
move F (i, j, k) = (i + 1, j, k)
move B (i, j, k) = (i - 1, j, k)
move L (i, j, k) = (i, j - 1, k)
move R (i, j, k) = (i, j + 1, k)
move U (i, j, k) = (i, j, k + 1)
move D (i, j, k) = (i, j, k - 1)

Admittedly, I was a bit cryptic with one-letter names. If you didn’t figure it out, they are short for Forward, Backward, Left, Right, Up, Down. I’m considering them absolute directions with respect to a fixed orientation. So “left” means to the left from my perspective outside the cube, not a relative left turn from the previous direction.

Step 2: Recursive tree search

Now that I have the basic vocabulary to think about the problem, I’m working up toward writing what I know will be a tree search. At some point, I’m going to have a current direction, and want to know which directions are possible 90-degree turns. Let’s do that.

turns :: Dir -> [Dir]
turns F = [L, R, U, D]
turns B = [L, R, U, D]
turns L = [F, B, U, D]
turns R = [F, B, U, D]
turns U = [F, B, L, R]
turns D = [F, B, L, R]

Okay, time to tackle the tree search. I now ask myself the central question. When I’ve half-completed an attempt at the puzzle, what state do I need to know to complete the attempt? My answer to that is the SearchState type:

data SearchState = SearchState {
    currentPos :: Pos,
    currentDir :: Dir,
    remainingSegments :: [Int],
    usedPositions :: Set Pos
    }

In other words, I need to know:

1. What’s the last position of a segment that I’ve decided to place?
2. What direction am I planning to move next?
3. What are the segments I haven’t placed yet?
4. Which positions already have blocks in them (since two blocks cannot land in the same position)?

With this in mind, I can choose the initial search states. Because of symmetry, it’s only to consider only solutions that start on the near face of the cube, and moving forward. (Because the first segment has length 2, I know the solution cannot start with the first cube in the center, either!) So I’ll define the start states with this in mind.

initialSearchStates :: [SearchState]
initialSearchStates = [
    SearchState {
        currentPos = (0, j, k),
        currentDir = F,
        remainingSegments = segments,
        usedPositions = Set.empty
    }
    | j <- [0..2], k <- [0..2] ]

I’ll also need a way to decide if it’s okay to place a block at a specific position. It’s okay if (a) the position is in-bounds, and (b) there’s not already a block at the position.

goodPosition :: Set Pos -> Pos -> Bool
goodPosition used pos =
    inRange ((0,0,0),(2,2,2)) pos && not (pos `Set.member` used)

And finally, the search itself.

search :: SearchState -> [[Dir]]
search SearchState{ remainingSegments = [] } = [[]]
search SearchState{..}
  | all (goodPosition usedPositions) cover
        = [ currentDir : solution
          | dir' <- turns currentDir
          , solution <- search SearchState{
              currentPos = last covered,
              currentDir = dir',
              remainingSegments = segs,
              usedPositions = foldr Set.insert usedPositions
                                    (init cover)
              }
          ]
  | otherwise = []
  where s:segs = remainingSegments
        cover = take (s + 1) (iterate (move currentDir) currentPos)

Here, cover is defined as the set of spaces that will be covered by the next segment. One simply checks that the next segment can be placed, and then computes the successor states. The successor states have a new position, one of the 90-degree turns as the new direction, and an augmented set of already-used positions. The successor states should be recursively searched.

There’s no particular care taken here to only generate a solution once. In fact, since we make a meaningless choice of a new direction at the end of the puzzle, there will always be four identical solutions in the result set for each list of directions. I could fix this by being more cautious about the recursion setup, but I don’t really care in the end. I just want the first solution.

theAnswer :: [Dir]
theAnswer = head (concatMap search initialSearchStates)

Step 3: Visualization

Now one can just print theAnswer, and have a working solution. I did this, and tried it out, and solved the puzzle. Success!

But it’s not very satisfying. Trying to share this solution with others, I quickly found that strings of F, B, L, R, U, and D are hard for others to understand. So let’s visualize. Fortunately, I have CodeWorld, the programming website I use for teaching functional programming. So opening http://code.world/haskell (because I want to use all of Haskell, not the simplified subset designed for children), I started a visualization.

To visualize, I don’t actually want a list of directions. I want a list of blocks to draw in the appropriate order. I can get this by zipping the directions with the segment lengths:

blocks :: [Pos]
blocks = follow (0, 0, 0) (zip theAnswer segments)
  where follow p [] = [p]
        follow p ((_, 0) : steps) = follow p steps
        follow p ((d, n) : steps)
             = p : follow (move d p) ((d, n - 1) : steps)

I’d like the user to be able to scroll through the partially complete puzzle by pressing up and down arrow keys, so I first built a simulation whose state is the number of blocks to show:

main :: IO ()
main = activityOf initial change picture
initial :: Int
initial = 1
change :: Event -> Int -> Int
change (KeyPress "Up")   n = n + 1
change (KeyPress "Down") n = n - 1
change other             n = n

All that remains is to define picture. Using CodeWorld drawing combinators, I can draw a block with a polygon for each visible side, and the complete picture as a collection of blocks. This leaves a few details:

1. The pictures of individual blocks must be overlapped in the right order, so that blocks nearest the user obscure the blocks further away.
2. The sides must be projected from three dimensions into two. I chose an isometric projection, so that I can be sure there are only three visible sides.

The result looks something like this:

picture :: Int -> Picture
picture n = pictures [
    drawBlock p
    | p <- sortBy (comparing viewSortKey) (take n blocks)
    ]
  where viewSortKey (i, j, k) = (i, -j, -k)
drawBlock :: Pos -> Picture
drawBlock (i, j, k) = pictures [
    -- The front face.
    colored (light gray) $ solidPolygon [
        project p | p <- [ (x + 0.5, y + 0.5, z - 0.5),
                           (x + 0.5, y - 0.5, z - 0.5),
                           (x - 0.5, y - 0.5, z - 0.5),
                           (x - 0.5, y + 0.5, z - 0.5) ] ],
    -- The top face.
    colored gray $ solidPolygon [
        project p | p <- [ (x + 0.5, y + 0.5, z + 0.5),
                           (x + 0.5, y + 0.5, z - 0.5),
                           (x - 0.5, y + 0.5, z - 0.5),
                           (x - 0.5, y + 0.5, z + 0.5) ] ],
    -- The right face.
    colored (dark gray) $ solidPolygon [
        project p | p <- [ (x + 0.5, y + 0.5, z + 0.5),
                           (x + 0.5, y + 0.5, z - 0.5),
                           (x + 0.5, y - 0.5, z - 0.5),
                           (x + 0.5, y - 0.5, z + 0.5) ] ]
    ]
  where x = fromIntegral j
        y = fromIntegral k
        z = fromIntegral i
project :: (Double, Double, Double) -> Point
project (x, y, z) = (3 * x + (1 + sin t / 4) * z,
                     3 * y + (1 + cos t / 4) * z)

And we’re done!

Okay, sort of… for the final version above, I made three small additions. First, I added text to explain how to scroll through the solution. Second, I added color to the blocks. The alternating colors makes it look more like the original puzzle. And finally, I added some change over time to the details of the projection. This last addition was made after I noticed that the 3D effect can be hard for the eye to decode in a static image. Adding some camera motion makes the effect much clearer.

The solver for the snake puzzle