comonad-coactions-0.1.0.1: examples/HigherRange.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 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) => Integer -> Integer -> V.Vector n Cell -> V.Vector n Cell
rule radius rn =
  rextend \(Store f i) ->
    let i' = getFinite i
        nbhd = foldl ((+) . (* 2)) 0 $ fromEnum . f . modulo . (+ i') <$> [-radius .. radius]
     in testBit rn nbhd

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

main :: IO ()
main = do
  putStr "Enter radius: "
  hFlush stdout
  radius <- readLn
  putStr $ "Enter rule number (from 0 to " ++ show @Integer (2 ^ (2 ^ (2 * radius + 1) :: Integer) - 1) ++ "): "
  hFlush stdout
  ruleNumber <- readLn
  Just Window{width} <- size
  let loop = withSomeSNat width mainLoop
  loop radius ruleNumber