{-# 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
Wireworld
The Wireworld Computer. WASD to pan.
Steps: Zoom:
We tweak our Hashlife code. There are now four cell states and new transition rules.
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