comonad-coactions-0.1.0.1: examples/ElementaryCA.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PatternSynonyms #-}

module Main where

import Control.Comonad.Coaction
import Control.Comonad.Identity
import Control.Comonad.Store
import Control.Concurrent
import Control.Monad
import Data.Bits
import Data.Finite
import Data.Vector.Sized qualified as V
import Data.Word
import GHC.TypeLits
import System.Console.Terminal.Size
import System.IO
import System.Random

type Cell = Bool

pattern Off :: Cell
pattern Off = False

pattern On :: Cell
pattern On = True

{-# COMPLETE On, Off #-}

cellToChar :: Cell -> Char
cellToChar = \case
  Off -> ' '
  On -> '█'

cellsToString :: (Foldable f) => f Cell -> String
cellsToString = foldr ((:) . cellToChar) ""

pattern Store :: (s -> a) -> s -> Store s a
pattern Store a b = StoreT (Identity a) b

{-# COMPLETE Store #-}

rule :: (KnownNat n) => Word8 -> V.Vector n Cell -> V.Vector n Cell
rule rn =
  rextend \(Store f i) ->
    let i' = getFinite i
        nbhd = foldl ((+) . (* 2)) 0 $ fromEnum . f . modulo . (+ i') <$> [-1, 0, 1]
     in testBit rn nbhd

mainLoop :: forall n. Maybe (SNat n) -> Word8 -> IO ()
mainLoop (Just SNat) rn =
  do
    x <- sequence . V.replicate @n $ randomIO
    forever $ go x
  where
    go x = do
      putStrLn $ cellsToString x
      threadDelay 30_000
      go $ rule rn x
mainLoop Nothing _ = pure ()

main :: IO ()
main = do
  putStr "Enter rule number (0 to 255): "
  hFlush stdout
  ruleNumber <- readLn
  Just Window{width} <- size
  let loop = withSomeSNat width mainLoop
  loop ruleNumber