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.

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)

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

Ben Lynn blynn@cs.stanford.edu 💡