Skip to content

Instantly share code, notes, and snippets.

@gatlin

gatlin/conway.hs

Last active December 12, 2021 01:53
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save gatlin/004ec5eaeb1c4f4bd607 to your computer and use it in GitHub Desktop.
Save gatlin/004ec5eaeb1c4f4bd607 to your computer and use it in GitHub Desktop.
Download ZIP
Some conway experiments, will probably be updated often
Raw
conway.hs
-- | This can be run with
-- > cabal run conway.hs
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{- cabal:
build-depends: base, Stream, JuicyPixels, comonad
-}
import Prelude hiding (head, tail, repeat, take)
import Control.Monad (liftM2)
import Control.Comonad ( Comonad(..), ComonadApply(..), (=>>))
import Control.Applicative ( Applicative(..), (<$>) )
import Data.Foldable hiding (toList)
import Data.Stream
( Stream(..), (<:>), head, unfold
, repeat, fromList, toList, take
)
import Codec.Picture
import Codec.Picture.Types (promotePixel)
-- | Streams are comonads [^1]
instance Comonad Stream where
extract = head
duplicate s@(Cons x xs) = Cons s (duplicate xs)
-- | Streams are applicative as well.
instance ComonadApply Stream where
(<@>) = (<*>)
-- | A one-dimensional Stream zipper
data Cursor a = Cursor
{ _viewL :: Stream a -- ^ Values to the left of the focus
, _focus :: a
, _viewR :: Stream a -- ^ Values to the right of the focus
} deriving (Functor, Show)
-- | Move a 'Cursor' focus to the left
--
-- E.g., [ -1, -2, -3, ...] 0 [ 1, 2, 3 ... ]
-- => [ -2, -3, -4, ...] -1 [ 0, 1, 2, ..]
cursorL :: Cursor a -> Cursor a
cursorL (Cursor (Cons l ls) c rs) = Cursor ls l (c <:> rs)
-- | Move a 'Cursor' focus to the right
cursorR :: Cursor a -> Cursor a
cursorR (Cursor ls c (Cons r rs)) = Cursor (c <:> ls) r rs
-- | A 'Cursor' is an 'Applicative' functor, so let's declare this.
instance Applicative Cursor where
(Cursor ls c rs) <*> (Cursor ls' c' rs') =
Cursor (ls <*> ls') (c c') (rs <*> rs')
pure = Cursor <$> pure <*> id <*> pure
-- | A 'Cursor' is also a 'Comonad'.
instance Comonad Cursor where
extract = _focus
duplicate = shift cursorL cursorR
instance ComonadApply Cursor where
(<@>) = (<*>)
-- | Extract a finite portion of a 'Cursor', with the focus on the left.
cursorView :: Int -> Cursor a -> [a]
cursorView n (Cursor _ x rs) = [x] ++ take n rs
-- | Takes a seed value and production rules to produce a 'Cursor'
seed
:: (c -> (a, c)) -- ^ Left-hand element generation rule
-> (c -> a) -- ^ Rule for generating the initial focus
-> (c -> (a, c)) -- ^ Right-hand element generation rule
-> c -- ^ The initial seed
-> Cursor a
seed prev center next =
Cursor <$> unfold prev <*> center <*> unfold next
-- | Transform the branches and focus of a 'Cursor'. Mostly used to shift the
-- focus in one direction or another.
shift
:: (a -> a) -- ^ Rule to shift the left-hand
-> (a -> a) -- ^ Rule to shift the right-hand
-> a -- ^ New focus value
-> Cursor a
shift prev next =
seed (dup . prev) id (dup . next)
where dup a = (a, a)
-- | A two-dimensional 'Cursor'. Up is left on the outer cursor; down is right
data Sheet a = Sheet (Cursor (Cursor a))
deriving (Functor, Show)
instance Comonad Sheet where
extract (Sheet s) = extract $ extract s
duplicate s = Sheet $ fmap horizontal $ vertical s
instance ComonadApply Sheet where
(Sheet f) <@> (Sheet a) = Sheet ((<@>) <$> f <@> a)
-- | Move the focus of a 'Sheet' up
up :: Sheet a -> Sheet a
up (Sheet s) = Sheet (cursorL s)
-- | Move the focus of a 'Sheet' down
down :: Sheet a -> Sheet a
down (Sheet s) = Sheet (cursorR s)
-- | Move the focus of a 'Sheet' left
left :: Sheet a -> Sheet a
left (Sheet s) = Sheet (fmap cursorL s)
-- | Move the focus of a 'Sheet' right
right :: Sheet a -> Sheet a
right (Sheet s) = Sheet (fmap cursorR s)
-- | Generalization of 'shift' for the horizontal dimension.
horizontal :: Sheet a -> Cursor (Sheet a)
horizontal = shift left right
-- | Generalization of 'shift' for the vertical dimension.
vertical :: Sheet a -> Cursor (Sheet a)
vertical = shift up down
-- | Extract a finite subset of a 'Sheet' focused on some point.
sheetView :: Int -> Sheet a -> [[a]]
sheetView n (Sheet ss) = cursorView n $ fmap (cursorView n) ss
-- | Supply a default value and a grid to yield a 'Sheet'.
-- See 'glider' for example usage.
makeSheet :: a -> [[a]] -> Sheet a
makeSheet _default grid = Sheet $ Cursor (repeat fz) fz rs where
rs = fromList $ (map line grid) ++ (toList (repeat fz))
ds = repeat _default
dl = toList ds
fz = Cursor ds _default ds
line l = Cursor ds _default (fromList (l ++ dl))
-- | Extract the neighbors of a 'Sheet' focus (a sub-'Sheet')
neighbors :: [Sheet a -> Sheet a]
neighbors =
horiz ++ vert ++ liftM2 (.) horiz vert where
horiz = [ left, right ]
vert = [ up, down ]
-- * Game of Life code
data CellState = X | O deriving (Eq, Show)
type Pattern = Sheet CellState -- ^ Convenient type alias
-- | Count how many neighbors are alive
aliveNeighbors :: Pattern -> Int
aliveNeighbors z =
card $ fmap (\ dir -> extract $ dir z) neighbors
-- | Cardinality, ie number of @True@ values in a list of booleans
card :: [ CellState ] -> Int
card = length . filter (== X)
-- | The rule applied to each cell in a Conway game each iteration
rule :: Pattern -> CellState
rule z =
case aliveNeighbors z of
2 -> extract z
3 -> X
_ -> O
-- | Update all cells in a 'Pattern' according to some rule
evolve :: Pattern -> Pattern
evolve = extend rule
-- | An example initial state that "glide around"
glider :: Pattern
glider = makeSheet O $
[ [ O, X, O ]
, [ O, O, X ]
, [ X, X, X ] ]
bar :: Pattern
bar = makeSheet O $
[ [ O, X, O ]
, [ O, X, O ]
, [ O, X, O ] ]
pulsar :: Pattern
pulsar = makeSheet O $ -- |
[ [ O, O, X, X, X, O, O, O, X, X, X, O, O ]
, [ O, O, O, O, O, O, O, O, O, O, O, O, O ]
, [ X, O, O, O, O, X, O, X, O, O, O, O, X ]
, [ X, O, O, O, O, X, O, X, O, O, O, O, X ]
, [ X, O, O, O, O, X, O, X, O, O, O, O, X ]
, [ O, O, X, X, X, O, O, O, X, X, X, O, O ]
, [ O, O, O, O, O, O, O, O, O, O, O, O, O ]
, [ O, O, X, X, X, O, O, O, X, X, X, O, O ]
, [ X, O, O, O, O, X, O, X, O, O, O, O, X ]
, [ X, O, O, O, O, X, O, X, O, O, O, O, X ]
, [ X, O, O, O, O, X, O, X, O, O, O, O, X ]
, [ O, O, O, O, O, O, O, O, O, O, O, O, O ]
, [ O, O, X, X, X, O, O, O, X, X, X, O, O ] ]
-- | Display helper for 'Cursor's
dispLine :: Cursor CellState -> String
dispLine z =
fmap dispC $ cursorView 15 z where
dispC X = '*'
dispC O = ' '
-- | Display helper for Patterns
disp :: Pattern -> String
disp (Sheet z) =
unlines $ fmap dispLine $ cursorView 15 z
-- | Generates a 'Stream' of 'Pattern' states, successively 'evolve'-ing them
game_stream :: Pattern -> Stream Pattern
game_stream = unfold $ \g -> (g, evolve g)
run :: Int -> Pattern -> IO ()
run n g = for_ (g & game_stream & take n) $ putStr . disp
-- | In some cases this allows for more intuitive code (see 'run')
(&) :: a -> (a -> c) -> c
(&) = flip ($)
-- * Image related stuff!
color_1 :: PixelRGB8
color_1 = PixelRGB8 250 250 250
{-# INLINE color_1 #-}
color_2 :: PixelRGB8
color_2 = PixelRGB8 0 0 0
{-# INLINE color_2 #-}
-- | Given a pixel radius and a 'Pattern', generate an image
makeImage :: Int -> Pattern -> Image PixelRGB8
makeImage radius ptn = generateImage go side side where
side = radius * 50
{-# INLINE side #-}
go :: Int -> Int -> PixelRGB8
go x y = (ptn' !! (y `div` 50)) !! (x `div` 50)
{-# INLINE go #-}
stateColor x = case extract x of
X -> color_1
O -> color_2
{-# INLINE stateColor #-}
ptn' = sheetView radius $ ptn =>> stateColor
{-# INLINE ptn' #-}
-- | Construct a list of images of a successively evolving pattern
makeGifFrames
:: Int -- ^ Radius
-> Int -- ^ Number
-> Pattern
-> [Image PixelRGB8]
makeGifFrames n prd ptn = game_stream ptn & fmap (makeImage n) & take prd
-- | Create an animated gif of a pattern
makeAnimation
:: Int -- ^ Radius
-> Bool -- ^ Loop?
-> Int -- ^ Number of frames
-> Int -- ^ Frame delay
-> FilePath
-> Pattern
-> IO ()
makeAnimation radius loop period delay path ptn = case go of
Left str -> putStrLn str
Right res -> res >> return ()
where
go = writeGifAnimation path delay loop' frames
{-# INLINE go #-}
loop' = if loop then LoopingForever else LoopingNever
{-# INLINE loop' #-}
frames = makeGifFrames radius period ptn
{-# INLINE frames #-}
main :: IO ()
--main = for_ [bar, glider, pulsar] $ run 50
main = do
makeAnimation 10 True 10 0 "bar.gif" bar
makeAnimation 15 True 10 0 "pulsar.gif" pulsar
makeAnimation 25 True 30 0 "glider.gif" glider
{- [^1]: definition of Stream, for completeness
@
data Stream a = Cons a (Stream a) deriving (Eq, Ord)
infixr 5 `Cons`
instance Functor Stream where
fmap f ~(Cons x xs) = Cons (f x) (fmap f xs)
instance Applicative Stream where
pure = repeat
(<*>) = zipWith ($)
(<:>) :: a -> Stream a -> Stream a
(<:>) = Cons
head :: Stream a -> a
head (Cons x _ ) = x
@
-}
Raw
results.txt
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
*
***
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*
*
* *
**
*
**
**
*
*
***
* *
**
*** ***
* * * *
* * * *
* * * *
*** ***
*** ***
* * * *
* * * *
* * * *
*** ***
* *
* *
** **
*** ** ** ***
* * * * * *
** **
** **
* * * * * *
*** ** ** ***
** **
* *
* *
** **
** **
* * * * * *
*** ** ** ***
* * * * * *
*** ***
*** ***
* * * * * *
*** ** ** ***
* * * * * *
** **
** **
*** ***
* * * *
* * * *
* * * *
*** ***
*** ***
* * * *
* * * *
* * * *
*** ***
* *
* *
** **
*** ** ** ***
* * * * * *
** **
** **
* * * * * *
*** ** ** ***
** **
* *
* *
** **
** **
* * * * * *
*** ** ** ***
* * * * * *
*** ***
*** ***
* * * * * *
*** ** ** ***
* * * * * *
** **
** **
*** ***
* * * *
* * * *
* * * *
*** ***
*** ***
* * * *
* * * *
* * * *
*** ***
* *
* *
** **
*** ** ** ***
* * * * * *
** **
** **
* * * * * *
*** ** ** ***
** **
* *
* *
** **
** **
* * * * * *
*** ** ** ***
* * * * * *
*** ***
*** ***
* * * * * *
*** ** ** ***
* * * * * *
** **
** **
*** ***
* * * *
* * * *
* * * *
*** ***
*** ***
* * * *
* * * *
* * * *
*** ***
* *
* *
** **
*** ** ** ***
* * * * * *
** **
** **
* * * * * *
*** ** ** ***
** **
* *
* *
** **
** **
* * * * * *
*** ** ** ***
* * * * * *
*** ***
*** ***
* * * * * *
*** ** ** ***
* * * * * *
** **
** **
*** ***
* * * *
* * * *
* * * *
*** ***
*** ***
* * * *
* * * *
* * * *
*** ***
* *
* *
** **
*** ** ** ***
* * * * * *
** **
** **
* * * * * *
*** ** ** ***
** **
* *
* *
** **
** **
* * * * * *
*** ** ** ***
* * * * * *
*** ***
*** ***
* * * * * *
*** ** ** ***
* * * * * *
** **
** **
*** ***
* * * *
* * * *
* * * *
*** ***
*** ***
* * * *
* * * *
* * * *
*** ***
* *
* *
** **
*** ** ** ***
* * * * * *
** **
** **
* * * * * *
*** ** ** ***
** **
* *
* *
** **
** **
* * * * * *
*** ** ** ***
* * * * * *
*** ***
*** ***
* * * * * *
*** ** ** ***
* * * * * *
** **
** **
*** ***
* * * *
* * * *
* * * *
*** ***
*** ***
* * * *
* * * *
* * * *
*** ***
* *
* *
** **
*** ** ** ***
* * * * * *
** **
** **
* * * * * *
*** ** ** ***
** **
* *
* *
** **
** **
* * * * * *
*** ** ** ***
* * * * * *
*** ***
*** ***
* * * * * *
*** ** ** ***
* * * * * *
** **
** **
*** ***
* * * *
* * * *
* * * *
*** ***
*** ***
* * * *
* * * *
* * * *
*** ***
* *
* *
** **
*** ** ** ***
* * * * * *
** **
** **
* * * * * *
*** ** ** ***
** **
* *
* *
** **
** **
* * * * * *
*** ** ** ***
* * * * * *
*** ***
*** ***
* * * * * *
*** ** ** ***
* * * * * *
** **
** **
*** ***
* * * *
* * * *
* * * *
*** ***
*** ***
* * * *
* * * *
* * * *
*** ***
* *
* *
** **
*** ** ** ***
* * * * * *
** **
** **
* * * * * *
*** ** ** ***
** **
* *
* *
** **
** **
* * * * * *
*** ** ** ***
* * * * * *
*** ***
*** ***
* * * * * *
*** ** ** ***
* * * * * *
** **
** **
*** ***
* * * *
* * * *
* * * *
*** ***
*** ***
* * * *
* * * *
* * * *
*** ***
* *
* *
** **
*** ** ** ***
* * * * * *
** **
** **
* * * * * *
*** ** ** ***
** **
* *
* *
** **
** **
* * * * * *
*** ** ** ***
* * * * * *
*** ***
*** ***
* * * * * *
*** ** ** ***
* * * * * *
** **
** **
*** ***
* * * *
* * * *
* * * *
*** ***
*** ***
* * * *
* * * *
* * * *
*** ***
* *
* *
** **
*** ** ** ***
* * * * * *
** **
** **
* * * * * *
*** ** ** ***
** **
* *
* *
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment