Life.hs

{-# Language GADTs #-}
{-# Language RankNTypes #-}
{-# Language TypeFamilies #-}

import Control.Monad

---

class Rel a where
  type Delta a :: *
  rel :: Delta a -> a -> a

instance (Rel a, Rel b) => Rel (a, b) where
  type Delta (a, b) = (Delta a, Delta b)
  rel (dx, dy) (x, y) = (rel dx x, rel dy y)

instance Rel Int where
  type Delta Int = Int
  rel dx x = dx + x

---

type Space i a = i -> a

---

offset :: Rel i => Delta i -> Space i a -> Space i a
offset d s = \i -> s (rel d i)

---

class Default a where
  def :: a

instance Default [a] where
  def = []

instance Default Int where
  def = 0

(!!!) :: Default a => [a] -> Int -> a
(x:xs) !!! 0 = x
[] !!! n = def
(_:xs) !!! n = xs !!! (n-1)

---

data Grid a = Grid [[a]]

grid :: Default a => Grid a -> Space (Int, Int) a
grid (Grid xss) (i, j) = xss !!! i !!! j

---

merge :: (a -> b -> c) -> Space i a -> Space i b -> Space i c
merge f s t = \i -> f (s i) (t i)

mergeAll1 :: (a -> a -> a) -> [Space i a] -> Space i a
mergeAll1 f = foldl1 (merge f)

---

data Cell = Dead | Live deriving Show

class Display a where
  display :: a -> Char

instance Display Char where
  display c = c

instance Display Cell where
  display Dead = ' '
  display Live = 'X'

instance Default Cell where
  def = Dead

example1 = grid $ Grid $
  [ [x, x, x, x, x, x]
  , [x, x, x, x, x, x]
  , [x, x, o, o, o, x]
  , [x, o, o, o, x, x]
  , [x, x, x, x, x, x]
  , [x, x, x, x, x, x]
  ]
  where
    o = Live
    x = Dead

showSpace :: Display a => (Int, Int) -> Space (Int, Int) a -> String
showSpace (w, h) s = do
  i <- [0..h]
  j <- [0..w]
  pure $ go i j
  where
    go i j
      | j == w    = '\n'
      | otherwise = display $ s (i, j)

printSpace dim = putStr . showSpace dim

pop :: Cell -> Int
pop Dead = 0
pop Live = 1

-- conway :: Space (Int, Int) Cell -> Space (Int, Int) Cell
conway s = merge rule s ns
  where

    ps = pop . s

    ns = mergeAll1 (+) $ do
      dy <- [-1, 0, 1]
      dx <- [-1, 0, 1]
      pure $ offset (dx, dy) ps

    rule Live 3 = Live
    rule Live 4 = Live
    rule Dead 3 = Live
    rule _ _ = Dead

memo :: Default a => (Int, Int) -> Space (Int, Int) a -> Space (Int, Int) a
memo (w, h) s = grid $ Grid $ map row [0..h-1]
  where
    row i = map (col i) [0..w-1]
    col i j = s (i, j)

play = go example1
 where
   go s = do
     printSpace (6, 6) s
     go (memo (6, 6) $ conway s)

---