NetWalk

Connect all terminals to the server.

I rewrote the source for this game, because the first version seemed out of place because it was strongly influenced by my C version targeting SDL. I also switched to my own Haskell compiler; orignally I targeted the Haste compiler but this project no longer seems active.

module Main where
import System
import Base
import Map

Random Number Generator

Instead of a library, 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. To reproduce the numbers generated by pcg32-demo.c:

take 777 $ fromPCG $ pcg 42 54

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 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 = Word64

We exploit knowledge of the implementation of 64-bit words in our compiler, which we will probably regret one day!

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, a name we chose because i might be confusing.

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.

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 to avoid fuzzy lines.

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) $ (*> pure ()) $ 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

Unlike our previous version, we draw some images wtih JavaScript and assign to variables such as liveEnd, deadEnd, and backlayer. The Haste compiler is bundled with wrappers for routines that drew on an HTML canvas; our compiler lacks these, and we have no wish to add them for now.

Our compiler also lacks a nice way to call Haskell closures from JavaScript. We concoct an ad hoc string-based scheme based on the get_global() and set_global() functions of our RTS.

The game state is stored in an IORef pair consisting of the board and the list of packets being animated. The latter is non-empty if and only if the game is won, a fact our code depends on. (In our first version, we maintained a flag instead, which is perhaps clearer, but I felt lazy this time!)

This time around, instead of setting timers to go off every 20 milliseconds (at most) and always painting the next frame, we call requestAnimationFrame(). This is more complex, as the frame we paint depends on the time elapsed since the previous call, but produces better animations.

foreign import ccall "get_global" global :: IO a
foreign import ccall "set_global" setGlobal :: a -> IO ()

foreign import ccall "eval_put" eval_put :: Char -> IO ()
foreign import ccall "eval_run" eval_run :: IO ()
foreign import ccall "eval_size" eval_size :: IO Int
foreign import ccall "eval_at" eval_at :: Int -> IO Char

jsEval s = do
  mapM eval_put s
  eval_run
  n <- eval_size
  mapM eval_at [0..n-1]

spinOffRandoms ref = do
  next <- readIORef ref
  let (a, b) = split next
  writeIORef ref b
  pure $ fromPCG a

update ref 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]) ++ ");"
  if size lives == size board
    then do
      board <- pure $ insert rootTop (aye : board!rootTop) $ insert rootBot (-aye : board!rootBot) board
      writeIORef ref (board, newPacketCheck board [])
      jsEval "sctx.drawImage(canvas, 0, 0);"
      jsEval "window.requestAnimationFrame(animate);"
      pure ()
    else writeIORef ref (board, [])
  pure ()

foreign export ccall "main" main
main = do
  timeRef <- newIORef Nothing
  gameRef <- newIORef undefined
  pcgRef <- newIORef =<< overkillPCG
  update gameRef . initGame =<< spinOffRandoms pcgRef
  let
    dispatch "new" _ = do
      jsEval "if (af) window.cancelAnimationFrame(af);\naf = undefined;"
      writeIORef timeRef Nothing
      update gameRef . initGame =<< spinOffRandoms pcgRef
    dispatch "click" as | [mx, my] <- fromIntegral . readInteger <$> as = do
      let z = mx `div` 32 :+ my `div` 32
      (board, packets) <- readIORef gameRef
      case packets of
        [] | z == rootTop || z == rootBot -> update gameRef $ rotateRoot board 1
           | Just ws <- mlookup z board -> update gameRef $ insert z (rot 1 ws) board
           | otherwise -> pure ()
        _ -> writeIORef gameRef (board, newPackets board z ++ packets)
    dispatch "animate" [arg] | now <- readInteger arg = let
      step delta = do
        writeIORef timeRef $ Just now
        (board, packets) <- readIORef gameRef
        jsEval "cctx.drawImage(solved, 0, 0);"
        sequence [jsEval $ "putPacket(" ++ intercalate "," (show <$> [32*x + 2*t*dx, 32*y + 2*t*dy]) ++ ");" | ((x :+ y, dx :+ dy), t) <- packets]
        writeIORef gameRef (board, newPacketCheck board $ adv board delta =<< packets)
      in do
        readIORef timeRef >>= maybe (step 0) \t0 -> do
          let delta = div (fromIntegral $ now - t0) 20
          when (delta > 0) $ step delta
        jsEval "af = window.requestAnimationFrame(animate);"
        pure ()

  setGlobal do
    f:as <- words <$> getContents
    dispatch f as

foreign export ccall "continue" continue
continue = global >>= id

Ben Lynn blynn@cs.stanford.edu 💡