data PCG = PCG Word64 Word64 pcg a b = PCG (a + b') b' where b' = 2*b + 1 next :: PCG -> (Word, PCG) next (PCG x inc) = (r, PCG x' inc) where x' = 6364136223846793005*x + inc r = (fromIntegral (x `xor` (x `shiftR` 18) `shiftR` 27) :: Word) `rotateR` (fromIntegral $ x `shiftR` 59) fromPCG p = map (fromIntegral . fst) $ tail $ iterate (next . snd) (undefined, p)
NetWalk
Connect all terminals to the server.
Random Number Generator
We roll our own pseudo-random number generator, which gives us an excuse to learn about permuted congruential generators. Although PRNGs based on those of Bob Jenkins may suit us just fine, a PCG is easier to code, and perhaps also easier to comprehend.
We choose PCG-XSH-RR with 64-bit state and 32-bit output, which is just like a venerable linear congruential generator except we twiddle the bits of the current state before we output it.
The multiplier is a certain constant. The increment can be any odd number, while there are no restrictions on the state.
We hew closely to the the minimal C demo for easy comparison. In C, the next state is precomputed to benefit from parallelization, but it makes no difference in Haskell due to lazy evaluation.
We reproduce the numbers generated by pcg32-demo.c:
take 77 $ fromPCG $ pcg 42 54
We split a PCG into two PCGs by using the next 8 generated 32-bit words to initialize two new PCGs:
split :: PCG -> (PCG, PCG) split p = (PCG (lohi a b) (lohi c d), PCG (lohi e f) (lohi g h)) where [a,b,c,d,e,f,g,h] = take 8 $ fromPCG p lohi lo hi = fromIntegral lo .|. shiftL (fromIntegral hi) 32
Gaussian Integers
The original version represented the board as a C programmer might: with a 2D array. This is expensive in Haskell, because updating a single tile requires copying the rest of the entire array behind the scenes.
In theory, linear Haskell could eliminate this penalty, but for now we use
Map instead of an array. A key is a location of a tile, and the corresponding
value is the list of outgoing edges of the tile.
We also represent coordinates with a Gaussian integer (or more precisely, a
Gaussian Int) instead of a pair. Both data types contain the same
information, but we can naturally define ring operations on Gaussian integers:
infixl 6 :+ data GaussInt = Int :+ Int deriving (Show, Eq) instance Ring GaussInt where (a :+ b) + (c :+ d) = (a + c) :+ (b + d) (a :+ b) - (c :+ d) = (a - c) :+ (b - d) (a :+ b) * (c :+ d) = (a*c - b*d) :+ (a*d + b*c) fromInteger a = fromInteger a :+ 0 aye = 0 :+ 1
A 90-degree rotation is then simply multiplication by aye.
take 5 $ iterate (aye*) 1
We define handy functions for getting at the coordinates, along with a
mathematicaly obscene ordering on our Gaussian integers so they can be used as
keys in a Map.
re (x :+ _) = x im (_ :+ y) = y instance Ord GaussInt where a :+ b <= c :+ d = (a, b) <= (c, d)
Orthogonal Planar Trees
The heart of the game is code that generates a tree sprawled all over a grid, then rotates each tile. For detecting victory and for rendering, we also need a function to explore edges to find all tiles connected to the root.
Throughout our code, the root is a special case because it consists of two vertically adjacent tiles instead of one, while still only having at most 4 edges. Like other tiles, it has at most one for a given cardinal direction, where an edge going up is connected to the top tile and the others are conencted to the bottom.
It seems convenient to leave the two root tiles are disconnected until victory, whereupon we add an internal edge between them to aid the victory animation.
Some functions expect a never-ending list whose items are meant to be produced
by a random number generator. Our fromPCG function produces such a list from
a PCG value.
The first version expected each function to take as much as it needs from a given lazy list and return the rest. This time we remove this requirement, simplifying code at the cost of splitting a PCG to give each function its own list of random numbers.
jsEval "curl_module('../compiler/Map.ob')"
import Map
bnds = (0, 9 :+ 8)
rootTop = div x 2 :+ div y 2 where x :+ y = snd bnds
rootBot = rootTop + aye
isRoot i = i == rootTop || i == rootBot
inRange (x0 :+ y0, x1 :+ y1) (x :+ y) = and [x0 <= x, x <= x1, y0 <= y, y <= y1]
dirs = take 4 $ iterate (aye *) 1
gen [] board _ = board
gen seeds board (r:r1:rs) = let
(as, b@(z, ws):bs) = splitAt (mod r $ length seeds) seeds
exits = [(j, d) | d <- dirs \\ ws, z /= rootTop || re d == 0,
let j = z + d, inRange bnds j, not $ member j board]
in if null exits then gen (as ++ bs) board (r1:rs) else let
(j, d) = exits!!(r1 `mod` length exits)
augT = (z, d:ws)
newT = (j, [-d])
in gen (augT:newT:(as ++ bs)) (uncurry insert newT $ uncurry insert augT board) rs
rot k = map (dirs!!k *)
rotateRoot board r
= insert rootTop (filter (== -aye) ws)
$ insert rootBot (filter (/= -aye) ws) board
where
ws = rot (mod r 4) (board!rootTop ++ board!rootBot)
rotateAll board (r:rs) = fromList $ zipWith go (toAscList $ rotateRoot board r) rs where
go (z, ws) r = (z,) \cases
| z == rootTop || z == rootBot -> ws
| otherwise -> rot (mod r 4) ws
initGame rs = rotateAll board rs1 where
root = [(rootTop, []), (rootBot, [])]
board = gen root (fromList root) rs2
(rs1, rs2) = splitAt ((x + 1)*(y + 1) + 1) rs where x :+ y = snd bnds
walk board = go [rootBot, rootTop] Tip where
go [] acc = acc
go (z:zs) acc
| member z acc = go zs acc
| otherwise = go (js ++ zs) $ insert z () acc
where
js = [j | d <- board!z, let j = z + d, not $ member j acc, maybe False (elem -d) $ mlookup j board]
We have a little more pure code for the logic driving the victory animation.
newPackets board z = [((z, d), 0) | d <- board!z] adv board dt packet@((z, d), t) | t1 < 16 = [((z, d), t1)] | otherwise = [((z1, d1), t1 - 16) | d1 <- maybe [] id $ mlookup z1 board, d1 /= -d] where t1 = min 31 $ t + dt z1 = z + d newPacketCheck board = \case [] -> newPackets board rootBot p -> p
The real world
Alas, getting our hands dirty is inevitable. At some point we must hook up our pure code to a web page via drawing routines, event-handling routines, and so on.
We go above and beyond to initialize our random number generator, calling
crypto.getRandomValues to obtain high-quality starting values:
overkillPCG = do
(s1, _:s2) <- break (== ',') <$> jsEval "{const a=new BigUint64Array(2);self.crypto.getRandomValues(a);a.toString();}"
pure $ pcg (fromInteger $ readInteger s1) $ fromInteger $ readInteger s2
Our tile-drawing function is tightly coupled to our JavaScript, expecting the
variable cctx to be set to the drawing context of the main canvas.
The first version of our code added 0.5 to each coordinate to get crisp thin lines. This time we use CSS.
drawTile lives (z@(x :+ y), ws) = do mapM_ (\(dx :+ dy) -> jsEval $ [r| cctx.strokeStyle = "rgb(|] ++ (if isLive then "0,191,0" else "255,127,127") ++ [r|)"; cctx.strokeRect(|] ++ intercalate "," (show <$> [ox, oy, 16*dx, 16*dy]) ++ [r|); |]) ws when (length ws == 1) $jsEval_ $ [r| cctx.drawImage(|] ++ (if isLive then "liveEnd" else "deadEnd") ++ ", " ++ show (32*x) ++ "," ++ show (32*y) ++ [r|); |] where ox = 32*x + 16 oy = 32*y + 16 isLive = member z lives
We draw images wtih JavaScript and assign them to variables such as liveEnd,
deadEnd, and backlayer.
The following data structure holds the game state.
data GameState = GameState
{ _board :: Map GaussInt [GaussInt]
, _pcg :: PCG
, _tick :: Maybe Int
, _packets :: [((GaussInt, GaussInt), Int)]
}
We animate via requestAnimationFrame(). This is more complex, as the frame
we paint depends on the time elapsed since the previous call, but produces
better animations.
newGame = do
jsEval "if (af) window.cancelAnimationFrame(af);\naf = undefined;"
(board, pcg) <- first (initGame . fromPCG) . split . _pcg <$> global
setGlobal GameState { _pcg = pcg, _tick = Nothing, _packets = [] }
update board
update board = do
jsEval "cctx.drawImage(backlayer, 0, 0);"
let lives = walk board
mapM_ (drawTile lives) $ toAscList board
jsEval $ "box(cctx, 'rgb(95,95,191)'," ++ intercalate "," (show <$> [32*re rootTop + 9, 32*im rootTop + 9, 16, 48]) ++ ");"
gst <- global
if size lives == size board
then do
board <- pure $ insert rootTop (aye : board!rootTop) $ insert rootBot (-aye : board!rootBot) board
setGlobal gst { _board = board, _packets = newPacketCheck board [] }
jsEval_ "sctx.drawImage(canvas, 0, 0);"
jsEval_ "af = window.requestAnimationFrame(animate);"
else setGlobal gst { _board = board }
click mx my = do
let z = mx `div` 32 :+ my `div` 32
gst <- global
let board = _board gst
let packets = _packets gst
case packets of
[] | z == rootTop || z == rootBot -> update $ rotateRoot board 1
| Just ws <- mlookup z board -> update $ insert z (rot 1 ws) board
| otherwise -> pure ()
_ -> setGlobal gst { _packets = newPackets board z ++ packets }
animate now = let
step delta = do
gst <- global
let board = _board gst
let packets = _packets gst
jsEval "cctx.drawImage(solved, 0, 0);"
sequence [jsEval $ "cctx.drawImage(packet, " ++ intercalate "," (show <$> [32*x + 2*t*dx, 32*y + 2*t*dy]) ++ ");" | ((x :+ y, dx :+ dy), t) <- packets]
setGlobal gst
{ _tick = Just now
, _packets = newPacketCheck board $ adv board delta =<< packets
}
in do
_tick <$> global >>= maybe (step 0) \t0 -> do
let delta = div (fromIntegral $ now - t0) 20
when (delta > 0) $ step delta
jsEval_ "af = window.requestAnimationFrame(animate);"
main = do
jsEval "initGame(repl);"
pcg <- overkillPCG
setGlobal GameState { _pcg = pcg }
newGame
main