The Wireworld Computer. WASD to pan.
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^nUpdating 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