├── .gitignore ├── Makefile ├── README.md ├── Setup.hs ├── conway.cabal ├── demo └── Main.hs ├── src └── Conway.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | /cabal-dev 2 | /dist 3 | /doc 4 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | NAME="$(shell basename `pwd`)" 2 | 3 | .PHONY: all config build doc test small-tests demo clean clobber 4 | 5 | all: build demo 6 | 7 | config: dist/setup-config 8 | 9 | dist/setup-config: 10 | cabal-dev install-deps 11 | cabal-dev configure 12 | 13 | build: config 14 | cabal-dev build | cat 15 | @cabal-dev build &> /dev/null 16 | 17 | doc: build 18 | find src demo -name '*.hs' | xargs haddock --optghc='-package-db '"$$(ls -d cabal-dev/packages-*.conf)" --no-warnings --odir=doc --html 19 | 20 | 21 | test: small-tests 22 | 23 | small-tests: build 24 | find src demo -name '*.hs' | xargs doctest -package-db "$$(ls -d cabal-dev/packages-*.conf)" 25 | @echo 26 | 27 | 28 | demo: build 29 | ./dist/build/$(NAME)-demo/$(NAME)-demo 30 | 31 | 32 | clean: 33 | rm -rf proofs 34 | 35 | clobber: clean 36 | rm -rf dist doc 37 | 38 | distclean: clobber 39 | rm -rf cabal-dev 40 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Comonad-Transformers Demo 2 | ========================= 3 | 4 | > ./conway-demo 5 | # 6 | # 7 | ### 8 | 9 | 10 | (animates forever, press Ctrl-C to stop) 11 | 12 | If a comonad is an environment for cellular automata, then a comonad transformer adds an axis to that environment. 13 | 14 | In this demo, we first construct a comonad representing a 1D neighborhood. We then write a slightly more complicated version which adds an extra 1D neighborhood to an existing comonad: that is our comonad transformer. If we apply the 1D neighborhood transformer to another 1D neighborhood, we obtain a 2D neighborhood. 15 | 16 | We end the demo by implementing Conway's Game of Life on top of this 2D grid. The comonadic nature of the grid makes it very easy to specify the rules of the automata, because the code is run uniformly on each cell, and because the indexing is always relative to the current cell. Those two features are central to comonads. 17 | 18 | Our particular version happens to use numerical indices which wrap around past the edge of the grid, but that is in no way typical of comonads. 19 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /conway.cabal: -------------------------------------------------------------------------------- 1 | Name: conway 2 | Version: 0.1 3 | 4 | -- A short (one-line) description of the package. 5 | Synopsis: A comonadic implementation of Conway's Game of Life. 6 | 7 | -- A longer description of the package. 8 | -- Description: 9 | 10 | Homepage: https://github.com/gelisam/conway 11 | License: PublicDomain 12 | Author: Samuel Gélineau 13 | Maintainer: gelisam@gmail.com 14 | 15 | Category: Demo 16 | 17 | Build-type: Simple 18 | Cabal-version: >=1.8 19 | 20 | Extra-source-files: README.md, 21 | Makefile 22 | 23 | Library 24 | hs-source-dirs: src 25 | 26 | Exposed-modules: Conway 27 | -- Other-modules: 28 | 29 | Build-depends: base, 30 | comonad, 31 | comonad-transformers 32 | ghc-options: -W -Wall 33 | 34 | executable conway-demo 35 | build-depends: base, 36 | conway 37 | main-is: Main.hs 38 | hs-source-dirs: demo 39 | ghc-options: -W -Wall 40 | -------------------------------------------------------------------------------- /demo/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent 4 | 5 | import Conway 6 | 7 | 8 | -- construct an animation based on Conway's Game of Life. 9 | 10 | glider :: ZZ Char 11 | glider = fromList [" # ", 12 | " # ", 13 | "### ", 14 | " ", 15 | " "] 16 | 17 | glider_animation :: [ZZ Char] 18 | glider_animation = life_animation glider 19 | 20 | 21 | -- display such an animation. 22 | 23 | clear :: IO () 24 | clear = putStr "\x1B[2J\x1B[;H" 25 | 26 | display_animation :: [ZZ Char] -> IO () 27 | display_animation = mapM_ $ \screen -> do 28 | clear 29 | threadDelay 100000 30 | mapM_ putStrLn $ toList screen 31 | 32 | animate :: ZZ Char -> IO () 33 | animate = display_animation . life_animation 34 | 35 | 36 | -- display the glider animation. 37 | 38 | main :: IO () 39 | main = animate glider 40 | -------------------------------------------------------------------------------- /src/Conway.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | module Conway where 7 | 8 | import Control.Comonad 9 | import Control.Comonad.Trans.Class 10 | 11 | 12 | class Indexable m i where 13 | (!) :: m a -> i -> a 14 | 15 | 16 | -- a 1D world for cellular automata. 17 | -- index is the current cell, all the others are neighbours. 18 | 19 | data ListZipper a = ListZipper { list :: [a] 20 | , index :: Int 21 | } deriving Show 22 | 23 | shift :: Int -> ListZipper a -> ListZipper a 24 | shift i (z@ListZipper{..}) = z { index = index' `mod` n } where 25 | n = length list 26 | index' = index + i 27 | 28 | instance Indexable ListZipper Int where 29 | ListZipper {..} ! i = list !! i' where 30 | i' = (index + i) `mod` length list 31 | 32 | instance Functor ListZipper where 33 | fmap f (z@ListZipper{..}) = z { list = fmap f list } 34 | 35 | instance Comonad ListZipper where 36 | -- inspect the current cell 37 | extract z = z ! (0::Int) 38 | 39 | -- run f on each cell, making each one the current cell. 40 | extend f z = z { list = list' } where 41 | n = (length . list) z 42 | range = take n [0..] 43 | list' = map (f . flip shift z) range 44 | 45 | 46 | -- and now, a comonad-transformer version of all the above. 47 | 48 | newtype ListZipperT w a = ListZipperT { 49 | runZipperT :: w (ListZipper a) 50 | } 51 | 52 | shiftT :: Functor w => Int -> ListZipperT w a -> ListZipperT w a 53 | shiftT i = ListZipperT . fmap (shift i) . runZipperT 54 | 55 | instance Comonad w => Indexable (ListZipperT w) Int where 56 | z ! i = xs !! i' where 57 | ListZipper xs index = (extract . runZipperT) z 58 | i' = (index + i) `mod` length xs 59 | 60 | instance Functor w => Functor (ListZipperT w) where 61 | fmap f = ListZipperT . (fmap . fmap) f . runZipperT 62 | 63 | instance Comonad w => Comonad (ListZipperT w) where 64 | extract = extract . extract . runZipperT 65 | 66 | extend :: forall a b. (ListZipperT w a -> b) -> ListZipperT w a -> ListZipperT w b 67 | extend f = ListZipperT . extend go . runZipperT where 68 | f' :: w (ListZipper a) -> b 69 | f' = f . ListZipperT 70 | 71 | go :: w (ListZipper a) -> ListZipper b 72 | go wz = ListZipper ys i where 73 | ListZipper xs i = extract wz 74 | 75 | n = length xs 76 | range = take n [0..] 77 | 78 | shifted_wzs :: [w (ListZipper a)] 79 | shifted_wzs = map (\j -> fmap (shift j) wz) range 80 | 81 | ys :: [b] 82 | ys = map f' shifted_wzs 83 | 84 | instance ComonadTrans ListZipperT where 85 | lower = fmap extract . runZipperT 86 | 87 | 88 | -- a 2D world for cellular automata. 89 | 90 | type ZZ a = ListZipperT ListZipper a 91 | 92 | instance Show a => Show (ZZ a) where 93 | show = show . runZipperT 94 | 95 | instance Indexable (ListZipperT ListZipper) (Int, Int) where 96 | z ! (x, y) = extract $ extract $ shift y $ runZipperT $ shiftT x z 97 | 98 | 99 | fromList :: [[a]] -> ZZ a 100 | fromList = ListZipperT . fmap (flip ListZipper 0) . flip ListZipper 0 101 | 102 | toList :: ZZ a -> [[a]] 103 | toList = list . fmap list . runZipperT 104 | 105 | 106 | -- demonstrate how lower and extract could have been used to index 107 | -- along the two dimentions of the grid separately, instead of using 108 | -- the specialized 2D indexing above. 109 | 110 | index_horizontally :: Comonad w => Int -> ListZipperT w a -> a 111 | index_horizontally i = (! i) . extract . runZipperT 112 | 113 | index_vertically :: ComonadTrans t => Int -> t ListZipper a -> a 114 | index_vertically i = (! i) . lower 115 | 116 | 117 | -- the entire logic of Conway's Game of Life, in one function. 118 | 119 | conway :: ZZ Char -> Char 120 | conway z = case count of 121 | 2 -> extract z 122 | 3 -> '#' 123 | _ -> ' ' 124 | where 125 | indices :: [(Int, Int)] 126 | indices = [(x, y) | x <- [-1..1], y <- [-1..1] 127 | , (x, y) /= (0, 0)] 128 | neighbours = map (z!) indices 129 | count = length $ filter (/= ' ') neighbours 130 | 131 | life_step :: ZZ Char -> ZZ Char 132 | life_step = extend conway 133 | 134 | life_animation :: ZZ Char -> [ZZ Char] 135 | life_animation = iterate life_step 136 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-6.20 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | --------------------------------------------------------------------------------