side = 4 hole = side^2 goal = [1..hole] oneD (r, c) = r*side + c
15 Shades of Grey
Arrange the grey squares so they appear from brightest to darkest going left to right, top to bottom.
We target my Haskell compiler which comes with a browser-based interpreter and some hacks to aid web development.
Every day I’m shuffling
We have a 4x4 board. We represent a position as a list of integers from 1 to
16, where 16 represents the hole into which tiles can be slid, and the tile at
row r
and column c
has index 4*r + c
in the list.
A new game requires us to permute the list randomly. Sampling a permutation uniformly in linear time is easy with destructive updates, but less so in Haskell (though perhaps linear types can help). Oleg Kiselyov describes [a functional programming solution with O(N log N) complexity, which can be found in the package System.Random.Shuffle In general, we can construct a persistent version of a data structure by paying at most a logarithmic factor.
Since our list only has 16 entries, we’re happy with a simple algorithm with quadratic complexity.
shuf xs = case length xs of 0 -> pure [] n -> do i <- fromInteger . readInteger <$> jsEval ("Math.floor(Math.random() * " ++ show n ++ ");") let (as, x:bs) = splitAt i xs (x:) <$> shuf (as ++ bs)
For example:
print =<< shuf [0..9]
Not just any permutation will do. A 15-puzzle position is solvable if and only if it passes a certain parity check:
parity [] = 0 parity (x:xs) = length (filter (x>) xs) + parity xs + if x == hole then uncurry (+) $ divMod (length xs) side else 0
We generate a valid starting position with rejection sampling, that is, we keep sampling until we find one that satisfies the parity condition.
gen :: IO [Int] gen = do z <- shuf goal if parity z `mod` 2 == 0 then pure z else gen
The game state.:
data Anim = Anim Int (Int, Int) (Int, Int) data GameState = GameState { _board :: [Int] , _cursor :: (Int, Int) , _anim :: Maybe Anim }
The JavaScript on this page defines a few helpers for our code:
A function to draw the current position:
sz = 64 rgb r g b = concat ["rgb(", show r, ",", show g, ",", show b, ")"] getColour n = rgb x x x where x | n == hole = 0 | otherwise = 255 - (225 * (n - 1) `div` (side^2 - 1)) square x y c = jsEval_ $ concat [ "rect(", show x, ", ", show y, ", ", show sz, ", ", show sz, ", ", show c, ");" ] draw b = flip mapM_ (zip [0..] b) $ \(i, n) -> let (r, c) = divMod i side in square (c*sz) (r*sz) $ getColour n
The loop
function handles animation: it draws a tile mid-slide, increments
the frame count, and schedules itself to be called again until the desired
number of frames have been drawn, upon which we check for victory.
We redraw only the two tiles affected by the animation.
frameCount = 8 loop = do gst <- global case _anim gst of Nothing -> checkWin Just (Anim frame tgt@(r1,c1) src@(r0,c0)) -> do let sc b a = a*sz + (b - a)*sz*frame`div`frameCount setGlobal gst { _anim = if frame == frameCount then Nothing else Just $ Anim (frame + 1) tgt src } square (c0*sz) (r0*sz) $ getColour hole square (c1*sz) (r1*sz) $ getColour hole square (sc c0 c1) (sc r0 r1) $ getColour $ _board gst!!oneD src jsEval_ $ "setTimeout(() => run('loop'), 16);" checkWin = do b <- _board <$> global when (b == goal) $ jsEval_ "msg.innerHTML = 'A WINNER IS YOU';"
To start a new game, we shuffle the board, draw it, and also check for victory in the unlikely event that we randomly chose the identity permutation.
newGame = do b <- gen let cur = fst $ head $ dropWhile ((/= hole) . snd) $ zip [0..] b setGlobal GameState { _board = b , _cursor = cur `divMod` side , _anim = Nothing } draw b jsEval_ "msg.innerHTML = '';" checkWin
Only the move
function updates the position on the board. When it does so, it
kicks off the animation of the sliding tile. If there already is an animation
in progress, then we instantly complete the original animation so the already
scheduled loop
will start the new animation. Otherwise we schedule a call to
loop
.
ins i x xs = as ++ x:bs where (as, _:bs) = splitAt i xs move tgt = do gst <- global let i = oneD tgt let bo = ins (oneD $ _cursor gst) (_board gst!!i) $ ins i hole $ _board gst setGlobal gst { _board = bo , _cursor = tgt , _anim = Just $ Anim 0 tgt $ _cursor gst } case _anim gst of Nothing -> loop Just (Anim _ _ (r, c)) -> square (c*sz) (r*sz) $ getColour $ _board gst!!oneD (r, c)
These event handlers are called from JavaScript:
isLegit (r, c) = 0 <= r && r < side && 0 <= c && c < side click x y = do gst <- global when (_board gst /= goal) do let (r, c) = (div y sz, div x sz) let (r0, c0) = _cursor gst when (isLegit (r, c) && (c - c0)^2 + (r - r0)^2 == 1) $ move (r, c) keyDown k = do gst <- global when (_board gst /= goal) do let (r, c) = _cursor gst go tgt = when (isLegit tgt) $ move tgt case k of 38 -> go (r + 1, c) 40 -> go (r - 1, c) 37 -> go (r, c + 1) 39 -> go (r, c - 1) _ -> pure ()
It remains to start a new game and connect our event handlers:
newGame jsEval_ "initGame(repl);"
Using setTimeout
for animations is easy, but can cause problems. it is better
to use requestAnimationFrame
, which we demonstrate elsewhere.