Wireworld

Steps: Zoom:

We tweak our Hashlife code. There are now four cell states and new transition rules.

{-# LANGUAGE CPP #-}
#ifdef __HASTE__
{-# LANGUAGE PackageImports #-}
#endif
{-# LANGUAGE LambdaCase, TupleSections, RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
#ifdef __HASTE__
import "mtl" Control.Monad.State.Strict
import Haste
import Haste.DOM
import Haste.Events
import Haste.Foreign (ffi)
import Haste.Graphics.Canvas
import Data.IORef
import Text.Read (readMaybe)
#else
import Control.Monad.State.Strict
#endif
import Data.List (find)
import Data.Map.Strict (Map, (!))
import qualified Data.Map.Strict as M

headcount = sum . map (fromEnum . (3 ==))

nextLife :: Int -> Int -> Int
nextLife 0 _ = 0
nextLife 1 1 = 3
nextLife 1 2 = 3
nextLife 1 _ = 1
nextLife 3 _ = 2
nextLife 2 _ = 1
data ZNode = ZNode Int Int Int Int deriving (Show, Eq, Ord)

zorder :: [(Int, Int)]
zorder = [(0,0), (1,0), (0,1), (1,1)]
base :: Int -> Int -> Int -> Int -> State Mem Int
base a b
     c d = do
  ZNode a0 a1
        a2 a3 <- visit a
  ZNode b0 b1
        b2 b3 <- visit b
  ZNode c0 c1
        c2 c3 <- visit c
  ZNode d0 d1
        d2 d3 <- visit d
  let
    nw = nextLife a3 $ headcount
      [ a0, a1, b0
      , a2,     b2
      , c0, c1, d0
      ]
    ne = nextLife b2 $ headcount
          [ a1, b0, b1
          , a3,     b3
          , c1, d0, d1
      ]
    sw = nextLife c1 $ headcount
      [ a2, a3, b2
      , c0,     d0
      , c2, c3, d2
      ]
    se = nextLife d0 $ headcount
          [ a3, b2, b3
          , c1,     d1
          , c3, d2, d3
          ]
  memo nw ne
       sw se
data Mem = Mem
  { zMem :: !(Map Int ZNode)
  , iMem :: !(Map ZNode Int)
  , cMem :: !(Map (Int, Int) Int)
  } deriving Show

initMem :: Mem
initMem = Mem mempty mempty mempty

intern :: ZNode -> State Mem Int
intern z = do
  Mem m idxs cm <- get
  let next = M.size idxs + 4
  put $ Mem (M.insert next z m) (M.insert z next idxs) cm
  pure next

visit :: Int -> State Mem ZNode
visit 0 = pure $ ZNode 0 0 0 0
visit k = (\(Mem m _ _) -> m!k) <$> get

gosper :: Int -> Int -> Int -> Int -> Int -> State Mem Int
gosper 0 a b c d = base a b c d
gosper n a b
         c d = do
  k <- memo a b c d
  Mem _ _ cm <- get
  case M.lookup (n, k) cm of
    Just v -> pure v
    Nothing -> do
      let rec = gosper $ n - 1
      v <- reduce4x4 rec (reduce3x3 rec) a b c d
      Mem zm im cm <- get
      put $ Mem zm im (M.insert (n, k) v cm)
      pure v

reduce4x4 f g a b
              c d = do
  ZNode a0 a1 a2 a3 <- visit a
  ZNode b0 b1 b2 b3 <- visit b
  ZNode c0 c1 c2 c3 <- visit c
  ZNode d0 d1 d2 d3 <- visit d
  x0 <- f a0 a1
          a2 a3
  x1 <- f    a1 b0
             a3 b2
  x2 <- f       b0 b1
                b2 b3
  x3 <- f a2 a3
          c0 c1
  x4 <- f    a3 b2
             c1 d0
  x5 <- f       b2 b3
                d0 d1
  x6 <- f c0 c1
          c2 c3
  x7 <- f    c1 d0
             c3 d2
  x8 <- f       d0 d1
                d2 d3
  g x0 x1 x2
    x3 x4 x5
    x6 x7 x8

reduce3x3 f
  x0 x1 x2
  x3 x4 x5
  x6 x7 x8 = do
  nw <- f x0 x1
          x3 x4
  ne <- f    x1 x2
             x4 x5
  sw <- f x3 x4
          x6 x7
  se <- f    x4 x5
             x7 x8
  memo nw ne
       sw se

memo :: Int -> Int -> Int -> Int -> State Mem Int
memo 0 0 0 0 = pure 0
memo a b c d = seek >>= maybe (intern z) pure
  where
  z = ZNode a b c d
  seek = (\(Mem _ idxs _) -> M.lookup z idxs) <$> get
data Life = Life
  { lifeSize :: Int
  , lifeOrigin :: (Int, Int)
  , lifeIndex :: Int
  , lifeMemory :: Mem
  } deriving Show

loadChar row col c = case c of
  '@' -> go 3
  '~' -> go 2
  '#' -> go 1
  _ -> []
  where go n = [((col, row), n)]
loadLine row cs = concat $ zipWith (loadChar row) [0..] cs

load css = concat $ zipWith loadLine [0..] (lines css)

fabricate :: [((Int, Int), Int)] -> Life
fabricate [] = Life 0 (0, 0) 0 initMem
fabricate ps = uncurry (Life sz (xmin, ymin))
  $ runState (enc sz (xmin, ymin)) initMem where
  m = M.fromList ps
  (xs, ys) = unzip $ fst <$> ps
  xmin = minimum xs
  ymin = minimum ys
  xmax = maximum xs
  ymax = maximum ys
  loggish n = max 0 $ head (filter (\k -> 2^k >= n) [0..]) - 1
  sz = loggish $ max (ymax - ymin) (xmax - xmin) + 1
  enc _ (ox, oy) | ox > xmax || oy > ymax = pure 0
  enc n (ox, oy) = mapM go zorder >>= (\[a,b,c,d] -> memo a b c d) where
    p = 2^n
    go (dx, dy)
      | n == 0    = pure $ maybe 0 id $ M.lookup (ox + dx, oy + dy) m
      | otherwise = enc (n - 1) (ox + dx*p, oy + dy*p)
pad :: Life -> Life
pad Life{..} = Life
  { lifeSize = n
  , lifeOrigin = (ox - p, oy - p)
  , lifeIndex = i'
  , lifeMemory = st
  } where
  (ox, oy) = lifeOrigin
  p = 2^lifeSize
  n = lifeSize + 1
  i = lifeIndex
  (i', st) = runState (reduce3x3 (middle n)
    0 0 0
    0 i 0
    0 0 0) lifeMemory

middle :: Int -> Int -> Int -> Int -> Int -> State Mem Int
middle n a b c d = do
  ZNode _ _ _ a3 <- visit a
  ZNode _ _ b2 _ <- visit b
  ZNode _ c1 _ _ <- visit c
  ZNode d0 _ _ _ <- visit d
  memo a3 b2 c1 d0

#ifndef __HASTE__
plot ps = putStr $ unlines $
  [[ch $ maybe 0 id $ lookup (c, r) ps | c <- [140..179]] | r <- [100..139]]
  where
  ch 0 = ' '
  ch 1 = '#'
  ch 2 = '~'
  ch 3 = '@'

main :: IO ()
main = do
  pats <- iterate (run 10) . fabricate . load <$> readFile "nodim"
  mapM_ (plot . crop (140, 100) (179, 139)) $ take 10 pats
#endif

baby :: Int -> Life -> Life
baby k Life{..} = Life
  { lifeSize = sz
  , lifeOrigin = (ox + p, oy + p)
  , lifeIndex = i'
  , lifeMemory = st
  } where
  (ox, oy) = lifeOrigin
  sz = lifeSize - 1
  p = 2^sz
  go _ 0 0 0 0 = pure 0
  go n a b c d
    | n <= k = gosper n a b c d
    | otherwise = do
      i <- memo a b c d
      Mem _ _ cm <- get
      case M.lookup (k, i) cm of
        Nothing -> do
          v <- reduce4x4 (middle n) (reduce3x3 $ go $ n - 1) a b c d
          Mem zm im cm <- get
          put $ Mem zm im $ M.insert (k, i) v cm
          pure v
        Just v -> pure v
  (i', st) = runState (visit lifeIndex
    >>= \(ZNode a b c d) -> go sz a b c d) lifeMemory
shrink :: Life -> Life
shrink Life{..} = uncurry ($) $
  runState (go lifeSize lifeOrigin lifeIndex) lifeMemory
  where
  f a b c d = pure $ ZNode a b c d
  zsum (ZNode a b c d) = a + b + c + d
  go 0 d k = pure $ Life 0 d k
  go n (dx, dy) k = do
    ZNode a b c d <- visit k
    reduce4x4 f g a b c d
    where
    g x0 x1 x2 x3 x4 x5 x6 x7 x8 = let
      tot = sum $ zsum <$> [x0, x2, x6, x8]
      xs = [x0,x1,x2,x3,x4,x5,x6,x7,x8]
      xds = zip xs [0..]
      in case find ((tot ==) . zsum . fst) xds of
        Just (ZNode a b c d, i) -> let
          (y, x) = divMod i 3
          in go (n-1) (dx + x*2^(n-1), dy + y*2^(n-1))
            =<< memo a b c d
        Nothing -> pure $ Life n (dx, dy) k

run :: Int -> Life -> Life
run k lf@Life{..} = shrink $ baby k $ iterate pad lf !! n where
  n = max 2 $ k + 1 - lifeSize
-- | Assumes x0 y0 even, x1 y1 odd, x0 < x1, y0 < y1.
crop :: (Int, Int) -> (Int, Int) -> Life -> [((Int, Int), Int)]
crop (x0, y0) (x1, y1) Life{..} = evalState (go lifeSize lifeOrigin lifeIndex) lifeMemory []
  where
  go _ _ 0 = pure id
  go n (x, y) k
    | x > x1 || y > y1 || x + 2*e <= x0 || y + 2*e <= y0 = pure id
    | otherwise = do
      ZNode a b c d <- visit k
      foldr (.) id <$> zipWithM f [a,b,c,d] zorder
    where
    f p (dx, dy)
      | n == 0 = pure $ if p == 0 then id else (((x+dx, y+dy), p):)
      | otherwise = go (n - 1) (x + e*dx, y + e*dy) p
    e = 2^n

crop4 :: (Int, Int) -> (Int, Int) -> Life -> [((Int, Int), Int)]
crop4 (x0, y0) (x1, y1) Life{..} = evalState (go lifeSize lifeOrigin lifeIndex) lifeMemory []
  where
  go _ _ 0 = pure id
  go 4 p k = pure $ if k == 0 then id else ((p, k):)
  go n (x, y) k
    | x > x1 || y > y1 || x + 2*e <= x0 || y + 2*e <= y0 = pure id
    | otherwise = do
      ZNode a b c d <- visit k
      foldr (.) id <$> zipWithM f [a,b,c,d] zorder
    where
    f p (dx, dy) = go (n - 1) (x + e*dx, y + e*dy) p
    e = 2^n

walk _ _ 0 = pure id
walk n (x, y) k = do
  ZNode a b c d <- visit k
  foldr (.) id <$> zipWithM f [a,b,c,d] zorder
  where
  f p (dx, dy)
    | n == 0 = pure $ if p == 0 then id else (((x+dx, y+dy), p):)
    | otherwise = walk (n - 1) (x + e*dx, y + e*dy) p
  e = 2^n

Updating 640x960 pixels every frame is challenging. We cache 32x32 tiles and use ordinary canvas drawing functions, which works decently enough at large steps, but crawls at small step speeds, where caching seems less effective.

(I tried WebGL instead: two triangles make up a board, and we push all the cells on a giant texture every frame. This improved the animation for small steps, but slowed down the larger step sizes. Perhaps I should try a hybrid solution which caches tiles on parts of a texture.)

#ifdef __HASTE__
rgb 1 = RGB 165 42 42
rgb 2 = RGB 0 0 255
rgb 3 = RGB 255 255 255

rough = ffi $ toJSString "(function(x) {rough(x);})" :: Canvas -> IO ()

main :: IO ()
main = withElems
  ["canvas", "level", "slow", "fast", "level", "zoomDown", "zoomUp"]
  $ \[canvasE, levelS, slowB, fastB, lvl, zoomUp, zoomDown] -> do

  Just canvas <- fromElem canvasE
  Just str <- fromJSString <$> (ffi $ toJSString "fetch" :: IO JSString)

  cans <- newIORef M.empty
  tim <- newIORef Nothing
  viewXY <- newIORef (0, 0)

  let chip = fabricate $ load $ str
  lf <- newIORef chip
  let (ox, oy) = lifeOrigin chip
  zoomRef <- newIORef 1
  logSpeed <- newIORef 7
  let
    showSpeed = do
      n <- readIORef logSpeed
      if n < 0
        then setProp levelS "innerHTML" "-"
        else setProp levelS "innerHTML" $ show $ 2^n
    snapshot = do
      render canvas $ color (RGB 0 0 0) $ fill $ rect (0, 0) (640, 960)
      rough canvas
      (vx, vy) <- readIORef viewXY
      zoom <- readIORef zoomRef
      life <- readIORef lf
      let
        z' = fromIntegral zoom
        cell t ((x, y), p) = renderOnTop t
          $ color (rgb p) $ fill $ rect (x', y') (x' + 1, y' + 1)
          where
          x' = fromIntegral x
          y' = fromIntegral y
        tile cs ((x, y), k) = case M.lookup k cs of
          Just t -> do
            blit t
            pure cs
          Nothing -> do
            t <- createCanvas 32 32
            mapM_ (cell t) $ evalState (walk 4 (0, 0) k) (lifeMemory life) []
            blit t
            pure $ M.insert k t cs
          where blit t = renderOnTop canvas $ scale (z', z') $ draw t (fromIntegral $ x - vx, fromIntegral $ y - vy)
      cs <- readIORef cans
      let
        w = div 640 zoom
        h = div 960 zoom
      writeIORef cans =<< foldM tile cs (crop4 (vx,vy) (vx+w-1,vy+h-1) life)
    next = do
      n <- readIORef logSpeed
      modifyIORef lf $ run n
      snapshot
      writeIORef tim =<< Just <$> setTimer (Once 30) next
    pan (dx, dy) = do
      (vx, vy) <- readIORef viewXY
      print (vx, vy)
      writeIORef viewXY $ (vx + 32*dx, vy + 32*dy)
  void $ slowB `onEvent` Click $ const $ do
    n <- readIORef logSpeed
    when (n >= 0) $ do
      writeIORef logSpeed $ n - 1
      showSpeed
      when (n == 0) $ do
        m <- readIORef tim
        case m of
          Nothing -> pure ()
          Just t -> stopTimer t
  void $ fastB `onEvent` Click $ const $ do
    n <- readIORef logSpeed
    writeIORef logSpeed $ n + 1
    showSpeed
    when (n < 0) next
  void $ zoomUp `onEvent` Click $ const $ do
    modifyIORef zoomRef $ max 1 . (`div` 2)
    snapshot
  void $ zoomDown `onEvent` Click $ const $ do
    modifyIORef zoomRef $ min 16 . (*2)
    snapshot
  showSpeed
  snapshot
  writeIORef tim =<< Just <$> setTimer (Once 30) next
  void $ documentBody `onEvent` KeyDown $ \k -> case keyCode k of
    87 -> pan (0, -1)
    65 -> pan (-1, 0)
    83 -> pan (0, 1)
    68 -> pan (1, 0)
    _ -> pure ()
#endif

Ben Lynn blynn@cs.stanford.edu 💡

Wireworld

Contents