Solving a puzzle in Haskell

Chris Smith
Jul 29 · 8 min read

Step 1: Understanding the problem

segments :: [Int]
segments =
[2, 1, 1, 1, 2, 1, 2, 1, 1, 1, 1, 2, 1, 2, 1, 1, 1, 1, 1, 2]
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)

Step 2: Recursive tree search

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]
data SearchState = SearchState {
currentPos :: Pos,
currentDir :: Dir,
remainingSegments :: [Int],
usedPositions :: Set Pos
}
initialSearchStates :: [SearchState]
initialSearchStates = [
SearchState {
currentPos = (0, j, k),
currentDir = F,
remainingSegments = segments,
usedPositions = Set.empty
}
| j <- [0..2], k <- [0..2] ]
goodPosition :: Set Pos -> Pos -> Bool
goodPosition used pos =
inRange ((0,0,0),(2,2,2)) pos && not (pos `Set.member` used)
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)
theAnswer :: [Dir]
theAnswer = head (concatMap search initialSearchStates)

Step 3: Visualization

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)
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
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)
The solver for the snake puzzle

Chris Smith

Written by

Software engineer at Google, volunteer math and computer science teacher, author of the CodeWorld platform, amateur ring theorist, and Haskell enthusiast.

Welcome to a place where words matter. On Medium, smart voices and original ideas take center stage - with no ads in sight. Watch
Follow all the topics you care about, and we’ll deliver the best stories for you to your homepage and inbox. Explore
Get unlimited access to the best stories on Medium — and support writers while you’re at it. Just $5/month. Upgrade