├── Setup.hs ├── docs └── img │ └── example.gif ├── .gitignore ├── stack.yaml.lock ├── .travis.yml ├── README.md ├── LICENSE ├── conway.cabal ├── stack.yaml ├── test └── Spec.hs ├── src ├── Life │ └── Examples.hs └── Life.hs └── app └── Main.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /docs/img/example.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samtay/conway/HEAD/docs/img/example.gif -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | *.swo 3 | 4 | dist 5 | dist-* 6 | cabal-dev 7 | *.o 8 | *.hi 9 | *.chi 10 | *.chs.h 11 | *.dyn_o 12 | *.dyn_hi 13 | .hpc 14 | .hsenv 15 | .cabal-sandbox/ 16 | cabal.sandbox.config 17 | *.prof 18 | *.aux 19 | *.hp 20 | *.eventlog 21 | .stack-work/ 22 | cabal.project.local 23 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 492015 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/8.yaml 11 | sha256: 926bc3d70249dd0ba05277ff00943c0addb35b627cb641752669e7cf771310d0 12 | original: lts-15.8 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: generic 3 | 4 | # Caching so the next build will be fast too. 5 | cache: 6 | directories: 7 | - $HOME/.stack 8 | 9 | # Ensure necessary system libraries are present 10 | addons: 11 | apt: 12 | packages: 13 | - libgmp-dev 14 | 15 | # Download and unpack the stack executable 16 | before_install: 17 | - mkdir -p ~/.local/bin 18 | - export PATH=$HOME/.local/bin:$PATH 19 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 20 | 21 | # Build dependencies 22 | install: 23 | - stack --no-terminal --install-ghc test --only-dependencies 24 | 25 | # Build the package and its tests and run the tests 26 | script: 27 | - stack --no-terminal test 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # conway [![Build Status](https://travis-ci.org/samtay/conway.svg?branch=master)](https://travis-ci.org/samtay/conway) 2 | A terminal interface for playing Conway's Game of Life 3 | 4 | 5 | ![terminal-gif](./docs/img/example.gif) 6 | 7 | This is just a pet project that I thought would be a good exercise in Haskell. 8 | The [Game of Life](https://en.wikipedia.org/wiki/Conway's_Game_of_Life) is a cellular automaton 9 | with simple rules but emergent complexity - a quintessential complex system. 10 | The frontend leverages [brick](http://hackage.haskell.org/package/brick) 11 | while the backend is supported by custom zipper types implementing comonads. 12 | 13 | This codebase comes with a complementary article about the [performance benefits of comonads](https://samtay.github.io/posts/comonadic-game-of-life.html). 14 | 15 | ### installation 16 | First [get stack](https://docs.haskellstack.org/en/stable/README/#how-to-install). Then 17 | ```shell 18 | $ git clone https://github.com/samtay/conway.git 19 | $ cd conway 20 | $ stack build 21 | # execute via stack 22 | $ stack exec life 23 | # alternatively, copy executable to ~/.local/bin 24 | $ stack install life 25 | $ life 26 | ``` 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Sam Tay (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Sam Tay nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /conway.cabal: -------------------------------------------------------------------------------- 1 | name: conway 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/SamTay/conway#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Sam Tay 9 | maintainer: sam.chong.tay@gmail.com 10 | copyright: 2017 Sam Tay 11 | category: Web 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Life 19 | , Life.Examples 20 | build-depends: base 21 | , comonad >= 5 22 | , containers >= 0.5.7 23 | , microlens >= 0.4.7.0 24 | , microlens-th >= 0.4.1.1 25 | default-language: Haskell2010 26 | 27 | executable life 28 | hs-source-dirs: app 29 | main-is: Main.hs 30 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 31 | build-depends: base 32 | , brick >= 0.17 && < 1 33 | , conway 34 | , microlens >= 0.4.7.0 35 | , microlens-th >= 0.4.1.1 36 | , stm >= 2.4.4 37 | , vty >= 5.15 38 | default-language: Haskell2010 39 | 40 | test-suite test 41 | type: exitcode-stdio-1.0 42 | hs-source-dirs: test 43 | main-is: Spec.hs 44 | build-depends: base 45 | , comonad >= 5 46 | , conway 47 | , hspec 48 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 49 | default-language: Haskell2010 50 | 51 | source-repository head 52 | type: git 53 | location: https://github.com/SamTay/conway 54 | -------------------------------------------------------------------------------- /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 | # https://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 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-15.8 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 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: ">=2.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 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Comonad 4 | import Life 5 | import Life.Examples 6 | import Test.Hspec 7 | 8 | -- | Sample size 9 | sSize :: Int 10 | sSize = 20 11 | 12 | -- | Board size (each side) 13 | bSize :: Int 14 | bSize = 20 15 | 16 | main :: IO () 17 | main = hspec $ do 18 | 19 | describe "Still lifes" $ do 20 | it "blocks are still" $ 21 | testStill block 22 | it "beehives are still" $ 23 | testStill beehive 24 | it "tubs are still" $ 25 | testStill tub 26 | 27 | describe "Oscillators" $ do 28 | it "blinkers oscillate with period 2" $ 29 | testOscillate 2 blinker 30 | it "toads oscillate with period 2" $ 31 | testOscillate 2 toad 32 | it "beacons oscillate with period 2" $ 33 | testOscillate 2 beacon 34 | it "pentadecathlons oscillate with period 15" $ 35 | testOscillate 15 pentadecathlon 36 | 37 | describe "Spaceships" $ 38 | it "gliders result in constant population" $ 39 | let ps = map population $ game $ glider bSize bSize 40 | in take sSize ps `shouldBe` replicate sSize 5 41 | 42 | describe "Zipper comonad implementation" $ do 43 | let g = glider 5 5 44 | sg = shift N $ shift W $ g 45 | it "passes first law" $ do 46 | testFirstLaw g 47 | testFirstLaw sg 48 | it "passes second law" $ do 49 | testSecondLaw g 50 | testSecondLaw sg 51 | it "passes third law" $ do 52 | testThirdLaw g 53 | testThirdLaw sg 54 | 55 | testFirstLaw :: Board -> Expectation 56 | testFirstLaw = shouldBe 57 | <$> extract . duplicate 58 | <*> id 59 | 60 | testSecondLaw :: Board -> Expectation 61 | testSecondLaw = shouldBe 62 | <$> fmap extract . duplicate 63 | <*> id 64 | 65 | testThirdLaw :: Board -> Expectation 66 | testThirdLaw = shouldBe 67 | <$> duplicate . duplicate 68 | <*> fmap duplicate . duplicate 69 | 70 | testStill :: (Int -> Int -> Board) -> Expectation 71 | testStill b = testStillB $ b bSize bSize 72 | 73 | testOscillate :: Int -> (Int -> Int -> Board) -> Expectation 74 | testOscillate p b = testOscillateB p $ b bSize bSize 75 | 76 | testStillB :: Board -> Expectation 77 | testStillB b = 78 | take sSize (game b) `shouldBe` replicate sSize b 79 | 80 | testOscillateB :: Int -> Board -> Expectation 81 | testOscillateB p b = 82 | take (sSize * p) (game b) `shouldBe` (take (sSize * p) . cycle . take p $ game b) 83 | 84 | game :: Board -- ^ Initial board 85 | -> [Board] -- ^ Resulting game 86 | game = iterate step 87 | -------------------------------------------------------------------------------- /src/Life/Examples.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Life.Examples 4 | -- Copyright : (c) Sam Tay 2017 5 | -- License : BSD3 6 | -- Maintainer : sam.chong.tay@gmail.com 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- This module exports examples of initial configurations. 11 | -- The grid size is required to create these boards so that the example 12 | -- can be \"centered\" on the grid when rendered (even though the 13 | -- toroidal grid itself does not have a \"center\"). 14 | -- For example: 15 | -- 16 | -- >ghci> blinker 9 9 17 | -- >_|_|_|_|_|_|_|_|_ 18 | -- >_|_|_|_|_|_|_|_|_ 19 | -- >_|_|_|_|_|_|_|_|_ 20 | -- >_|_|_|_|_|_|_|_|_ 21 | -- >_|_|_|X|X|X|_|_|_ 22 | -- >_|_|_|_|_|_|_|_|_ 23 | -- >_|_|_|_|_|_|_|_|_ 24 | -- >_|_|_|_|_|_|_|_|_ 25 | -- >_|_|_|_|_|_|_|_|_ 26 | -- 27 | -- However, make sure the size of the board can handle the example 28 | -- that you want to run. The pentadecathlon is a cool oscillator, 29 | -- but to run it successfully through all 15 steps in its period, 30 | -- it requires a bounding box of at least 11x17. Since boards are implemented 31 | -- using a toroidal grid and coordinates are normalised upon creation, 32 | -- you might not realize anything is wrong: 33 | -- >ghci> let p = pentadecathlon 11 17 34 | -- >ghci> p == (iterate step p !! 15) 35 | -- >True 36 | -- >ghci> let p' = pentadecathlon 11 16 37 | -- >ghci> p' == (iterate step p' !! 15) 38 | -- >False 39 | -- 40 | -- As a rule of thumb, go big or go home. Conway's Game of Life is more 41 | -- interesting when the spacial limits tend to infinity. 42 | ----------------------------------------------------------------------------- 43 | module Life.Examples 44 | ( 45 | -- * Still lifes 46 | block 47 | , beehive 48 | , tub 49 | -- * Oscillators 50 | , blinker 51 | , toad 52 | , beacon 53 | , pentadecathlon 54 | -- * Spaceships 55 | , glider 56 | ) where 57 | 58 | import Life 59 | 60 | block :: Int -> Int -> Board 61 | block = center [(-1,-1), (-1,0), (0,-1), (0,0)] 62 | 63 | beehive :: Int -> Int -> Board 64 | beehive = center [(-1,0), (0,-1), (0,1), (1,-1), (1,1), (2,0)] 65 | 66 | tub :: Int -> Int -> Board 67 | tub = center [(-1,0), (0,-1), (0,1), (1,0)] 68 | 69 | blinker :: Int -> Int -> Board 70 | blinker = center [(-1,0), (0,0), (1,0)] 71 | 72 | toad :: Int -> Int -> Board 73 | toad = center [(-1,0), (0,0), (1,0), (0,1), (1,1), (2,1)] 74 | 75 | beacon :: Int -> Int -> Board 76 | beacon = center [(-1,1), (-1,2), (0,2), (1,-1), (2,0), (2,-1)] 77 | 78 | pentadecathlon :: Int -> Int -> Board 79 | pentadecathlon = center [ (-4,0), (-3,0), (-2,-1), (-2,1), (-1,0), (0,0) 80 | , (1,0), (2,0), (3,-1), (3,1), (4,0), (5,0) 81 | ] 82 | 83 | glider :: Int -> Int -> Board 84 | glider = center [(-1,-1), (0,-1), (0,1), (1,-1), (1,0)] 85 | 86 | center :: [Cell] -- ^ Cells initially alive 87 | -> Int -- ^ Length 88 | -> Int -- ^ Height 89 | -> Board 90 | center cs l h = board l h 91 | $ map (\(x,y) -> (x + xoff, y + yoff)) cs 92 | where xoff = l `div` 2 93 | yoff = h `div` 2 94 | -------------------------------------------------------------------------------- /src/Life.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Life 4 | -- Copyright : (c) Sam Tay 2017 5 | -- License : BSD3 6 | -- Maintainer : sam.chong.tay@gmail.com 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | ----------------------------------------------------------------------------- 11 | {-# LANGUAGE ConstrainedClassMethods #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | {-# LANGUAGE Rank2Types #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TupleSections #-} 16 | {-# LANGUAGE TypeFamilies #-} 17 | module Life 18 | ( 19 | -- * Types and classes 20 | Board 21 | , Cell 22 | , St(..) 23 | , Zipper(..) 24 | , Direction(..) 25 | -- * Construction 26 | , board 27 | -- * Running the game 28 | , step 29 | , population 30 | , gameover 31 | , resize 32 | -- * Lenses 33 | , unzz, zl, zc, zi, zix 34 | ) where 35 | 36 | import qualified Data.Foldable as F 37 | import Data.List (intercalate, nub) 38 | import Data.Maybe (fromMaybe, mapMaybe) 39 | 40 | import Control.Comonad 41 | import Data.Sequence (ViewL (..), ViewR (..), (<|), (><), (|>)) 42 | import qualified Data.Sequence as S 43 | import Lens.Micro 44 | import qualified Lens.Micro.Internal as L 45 | import Lens.Micro.TH 46 | 47 | -- | A modular game of life board 48 | -- 49 | -- With this interpretation, for a board of size @n x n@ 50 | -- the @(n + 1)@th column/row is the same as the boundary at the @1@th column/row. 51 | type Board = ZZ St 52 | 53 | -- | Indexer for the 'Board' 54 | type Cell = (Int, Int) 55 | 56 | -- | Possible cell states 57 | data St = Alive | Dead 58 | deriving (Eq) 59 | 60 | -- | One dimensional finite list with cursor context 61 | -- 62 | -- The first element of the sequence at '_zl' can be thought of 63 | -- as /to the left/ of the cursor, while the last element is /to the right/ 64 | -- of the cursor. The cursor value and index are '_zc' and '_zi' respectively. 65 | -- This can be thought of as a circle. 66 | -- Warning: must have length greater than zero! 67 | data Z a = Z 68 | { _zl :: S.Seq a 69 | , _zc :: a 70 | , _zi :: Int 71 | } 72 | deriving (Eq, Show) 73 | 74 | newtype ZZ a = ZZ { _unzz :: Z (Z a) } 75 | deriving (Eq) -- TODO possibly implement equality up to shifting 76 | 77 | makeLenses ''Z 78 | makeLenses ''ZZ 79 | 80 | -- | Class for a modular bounded container 81 | -- 82 | -- Examples of functions provided for a simple one dimensional list, where appropriate 83 | class Zipper z where 84 | type Index z 85 | data Direction z 86 | 87 | -- | Shift in a direction 88 | shift :: Direction z -> z a -> z a 89 | 90 | -- | Retrieve current cursor value 91 | cursor :: z a -> a 92 | 93 | -- | Retrieve current index value 94 | index :: z a -> Index z 95 | 96 | -- | Retrieve neighborhood of current cursor. 97 | neighborhood :: z a -> [a] 98 | 99 | -- | Destruct to list maintaining order of @(Index z)@, e.g. @(Z ls c rs) -> ls ++ [c] ++ rs@. 100 | toList :: z a -> [a] 101 | 102 | -- | Destruct a list into a mapping with indices 103 | toMap :: (Comonad z) => z a -> [(Index z, a)] 104 | toMap = toList . extend ((,) <$> index <*> cursor) 105 | 106 | -- | Construct zipper from mapping (provide default value so this is always safe, no bottoms) 107 | fromMap :: Ord (Index z) => a -> [(Index z, a)] -> z a 108 | 109 | -- | Lookup by possibly denormalised index (still safe from modularity). 110 | -- 111 | -- e.g. [1,2] ! 2 == 1 112 | (!) :: z a -> (Index z) -> a 113 | 114 | -- | Adjust value at specified index 115 | adjust :: (a -> a) -> Index z -> z a -> z a 116 | 117 | -- | Update value at specified index 118 | update :: a -> Index z -> z a -> z a 119 | update = adjust . const 120 | 121 | -- | Normalize @Index z@ value with respect to modular boundaries 122 | normalize :: z a -> (Index z) -> (Index z) 123 | 124 | -- | Get size (maximum of @Index z@). 125 | size :: z a -> (Index z) 126 | 127 | instance Zipper Z where 128 | type Index Z = Int 129 | data Direction Z = L | R deriving (Eq, Show) 130 | 131 | cursor = _zc 132 | index = _zi 133 | normalize z = (`mod` (size z)) 134 | size (Z l _ _) = S.length l + 1 135 | (!) z k = z ^. zix k 136 | adjust f k z = z & zix k %~ f 137 | neighborhood (Z l _ _) 138 | | S.length l <= 2 = F.toList l 139 | | otherwise = map (S.index l) [0, S.length l - 1] 140 | toList (Z l c i) = F.toList . S.reverse $ b >< (c <| f) 141 | where (f,b) = S.splitAt i l 142 | fromMap _ [] = error "Zipper must have length greater than zero." 143 | fromMap a m = Z (S.fromList ys) (iToa 0) 0 144 | where ys = map iToa rng 145 | iToa i = fromMaybe a $ lookup i m 146 | l = maximum . (0:) $ map fst m 147 | rng = if l == 0 then [] else [l,(l-1)..1] 148 | shift d z@(Z l c i) 149 | | S.null l = z -- shifting length zero amounts to nothing 150 | | d == L = Z (xs |> c) x xi 151 | | d == R = Z (c <| ys) y yi 152 | where 153 | (x :< xs) = S.viewl l 154 | (ys :> y) = S.viewr l 155 | xi = (i - 1) `mod` size z 156 | yi = (i + 1) `mod` size z 157 | 158 | instance Functor Z where 159 | fmap f (Z l c i) = Z (fmap f l) (f c) i 160 | 161 | instance Comonad Z where 162 | extract = cursor 163 | duplicate z = Z (S.fromFunction (size z - 1) fn) z (z ^. zi) 164 | where fn k = compose (k + 1) (shift L) $ z 165 | 166 | -- | This interpretation is a 2D zipper (Z (Z a)). 167 | -- 168 | -- The outer layer is a zipper of columns (x coordinate), 169 | -- and each column is a zipper of @a@ values (y coordinate). 170 | -- Warning: Keep inner column sizes consistent! 171 | instance Zipper ZZ where 172 | type Index ZZ = (Int, Int) 173 | data Direction ZZ = N | E | S | W deriving (Eq, Show) 174 | 175 | cursor = _zc . _zc . _unzz 176 | toList = concatMap toList . toList . _unzz 177 | adjust f (x, y) z = z & (unzz . zix x . zix y) %~ f 178 | (!) z (x, y) = z ^. unzz ^. zix x ^. zix y 179 | normalize z (x,y) = (nx, ny) 180 | where nx = x `mod` z ^. to size ^. _1 181 | ny = y `mod` z ^. to size ^. _2 182 | size z = (x, y) 183 | where x = z ^. unzz ^. to size 184 | y = z ^. unzz ^. zc ^. to size 185 | index z = (x, y) 186 | where x = z ^. unzz ^. zi 187 | y = z ^. unzz ^. zc ^. zi 188 | shift E = (& unzz %~ shift R) 189 | shift W = (& unzz %~ shift L) 190 | shift N = (& unzz %~ fmap (shift R)) 191 | shift S = (& unzz %~ fmap (shift L)) 192 | neighborhood (ZZ (Z l c _)) = ns ++ ew 193 | where ns = neighborhood c 194 | ewc = if (S.length l <= 2) 195 | then F.toList l 196 | else map (S.index l) [0, S.length l - 1] 197 | ew = concatMap neighborhood' ewc 198 | neighborhood' z = (z ^. zc) : neighborhood z 199 | fromMap _ [] = error "Zipper must have length greater than zero." 200 | fromMap a m = ZZ $ Z (S.fromList cs) (iToc 0) 0 201 | where cs = map iToc rc 202 | iToc i = fromMap a . insDef . map (& _1 %~ snd) $ filter ((==i) . fst . fst) m 203 | l = maximum . (0:) $ map (fst . fst) m 204 | h = maximum . (0:) $ map (snd . fst) m 205 | rc = if l == 0 then [] else [l,(l-1)..1] 206 | insDef xs = if h `elem` (map fst xs) then xs else (h,a) : xs 207 | 208 | instance Functor ZZ where 209 | fmap f = ZZ . (fmap . fmap) f . _unzz 210 | 211 | instance Comonad ZZ where 212 | extract = cursor 213 | duplicate z = ZZ $ Z 214 | (fromF (xT - 1) mkCol) (Z (fromF (yT - 1) (mkRow z)) z y) x 215 | where 216 | mkRow zx j = compose (j + 1) (shift S) zx 217 | mkCol i = let zx = compose (i + 1) (shift W) z 218 | in Z (fromF (yT - 1) (mkRow zx)) zx (zx ^. to index ^. _2) 219 | (xT,yT) = size z 220 | (x,y) = index z 221 | fromF = S.fromFunction 222 | 223 | -- | Create a board with given height, length, and initial state 224 | board :: Int -- ^ Length 225 | -> Int -- ^ Height 226 | -> [Cell] -- ^ List of cells initially alive 227 | -> Board 228 | board l h = fromMap Dead . ins (l-1,h-1) . map (,Alive) 229 | where ins m cs = if (m, Alive) `elem` cs 230 | then cs 231 | else ((m, Dead):cs) 232 | 233 | -- | Adjusts the number of columns and rows respectively. 234 | -- 235 | -- For example @resize (-1) 1@ will remove one column and add one row. 236 | resize :: Int -> Int -> Board -> Board 237 | resize l h = resizeH h . resizeL l 238 | where resizeL l z 239 | | l < 0 = z & unzz %~ dropL (-l) 240 | | l > 0 = z & unzz %~ consLc l 241 | | otherwise = z 242 | resizeH h z 243 | | h < 0 = z & unzz %~ fmap (dropL (-h)) 244 | | h > 0 = z & unzz %~ fmap (consLr h) 245 | | otherwise = z 246 | dropL :: Int -> Z a -> Z a 247 | dropL l = (& zl %~ S.drop l) 248 | consLr :: Int -> Z St -> Z St 249 | consLr h = (& zl %~ compose h (Dead <|)) 250 | consLc :: Int -> Z (Z St) -> Z (Z St) 251 | consLc l z = let c = fmap (const Dead) $ z ^. zc 252 | in z & zl %~ compose l (c <|) 253 | 254 | -- | Step the game forward 255 | step :: Board -> Board 256 | step = extend rule 257 | where p = length . filter (==Alive) . neighborhood 258 | rule z = case (cursor z, p z) of 259 | (Alive, 2) -> Alive 260 | (Alive, 3) -> Alive 261 | (Dead, 3) -> Alive 262 | _ -> Dead 263 | 264 | -- | Returns the total number of living cells in a board 265 | population :: Board -> Int 266 | population = length . filter (==Alive) . toList 267 | 268 | -- | Check if every cell is dead (i.e., gameover) 269 | gameover :: Board -> Bool 270 | gameover = (== 0) . population 271 | 272 | -- Nice when sanity checking or playing in the REPL 273 | -- 274 | -- Warning: slow since I implement outer layer as column 275 | -- and this must be rendered first as rows. 276 | instance Show a => Show (ZZ a) where 277 | show z = unlines $ map mkRow [rowT - 1,rowT - 2..0] 278 | where (colT, rowT) = size z 279 | mkRow y = intercalate "|" 280 | $ map (show . (z !) . (,y)) [0..colT - 1] 281 | 282 | instance Show St where 283 | show Alive = "X" 284 | show Dead = "_" 285 | 286 | -------------------- Utility functions -------------------- 287 | 288 | -- | Transform 'Index z' into the index of the @S.Seq@ that @z@ contains 289 | -- unless it is equivalent to current index. 290 | zToLix :: Z a -> Int -> Maybe Int 291 | zToLix z@(Z _ _ i) k 292 | | i == n = Nothing 293 | | i < n = Just $ s - (n - i) - 1 294 | | i > n = Just $ i - n - 1 295 | where n = k `mod` s 296 | s = size z 297 | 298 | compose :: Int -> (a -> a) -> (a -> a) 299 | compose = (foldr (.) id .) . replicate 300 | 301 | -------------------- Some Lens explorations -------------------- 302 | 303 | type instance L.Index (Z a) = Int 304 | type instance L.IxValue (Z a) = a 305 | 306 | -- | Cool! 'Z' is now 'ix'able! 307 | instance L.Ixed (Z a) where 308 | ix k f z@(Z l c i) = maybe 309 | ((\c' -> Z l c' i) <$> f (z ^. zc)) 310 | (\i -> (\l' -> Z l' c i) . (\a -> S.update i a l) <$> f (z ^. zl ^. to (`S.index` i))) 311 | (zToLix z k) 312 | 313 | -- My own lens! Although 'ix' usage is probably more standard than this, 314 | -- it is not possible to use 'ix' as a direct getter: z ^. ix 3 315 | -- does not behave as expected and wants a monoid instance; perhaps is 316 | -- attempting to fold in this context? 317 | -- You can use z ^? ix 3 to get back a Maybe value, but if I know my 318 | -- getter is safe, I don't got time for dat. 319 | -- 320 | -- Might be that I want the 'At' instance.. 321 | zix :: Int -> Lens' (Z a) a 322 | zix k f z@(Z l c i) = maybe 323 | ((\x -> Z l x i) <$> f c) 324 | (\n -> (\x -> Z (S.update n x l) c i) <$> f (S.index l n)) 325 | (zToLix z k) 326 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Main where 4 | 5 | import Control.Concurrent (forkIO, threadDelay) 6 | import Control.Concurrent.STM 7 | import Control.Monad (forever, void) 8 | import Control.Monad.IO.Class (liftIO) 9 | import Data.Maybe (fromMaybe) 10 | import Data.Monoid ((<>)) 11 | import Lens.Micro 12 | (ix, over, set, to, (%~), (&), (.~), (<&>), (^.), (^?), _1, _2) 13 | import Lens.Micro.TH 14 | 15 | import Life hiding (board) 16 | import qualified Life as L 17 | import qualified Life.Examples as LE 18 | 19 | import Brick 20 | import Brick.BChan 21 | import qualified Brick.Focus as F 22 | import qualified Brick.Widgets.Border as B 23 | import qualified Brick.Widgets.Border.Style as BS 24 | import qualified Brick.Widgets.Center as C 25 | import Brick.Widgets.Core 26 | ( emptyWidget 27 | , hBox 28 | , padLeftRight 29 | , padTopBottom 30 | , withBorderStyle 31 | , (<+>) 32 | , (<=>) 33 | ) 34 | import qualified Brick.Widgets.ProgressBar as P 35 | import qualified Graphics.Vty as V 36 | 37 | -- | Name resources (needed for scrollable viewport) 38 | data Name = GridVP | ExampleVP 39 | deriving (Ord, Show, Eq) 40 | 41 | -- | Game state 42 | data Game = Game 43 | { _board :: Board -- ^ Board state 44 | , _time :: Int -- ^ Time elapsed 45 | , _paused :: Bool -- ^ Playing vs. paused 46 | , _speed :: Float -- ^ Speed in [0..1] 47 | , _interval :: TVar Int -- ^ Interval kept in TVar 48 | , _focus :: F.FocusRing Name -- ^ Keeps track of grid focus 49 | , _selected :: Cell -- ^ Keeps track of cell focus 50 | } 51 | 52 | makeLenses ''Game 53 | 54 | -- | Initial game with empty board 55 | initialGame :: TVar Int -> Game 56 | initialGame tv = Game { _board = L.board 20 20 [] 57 | , _time = 0 58 | , _paused = True 59 | , _speed = initialSpeed 60 | , _interval = tv 61 | , _focus = F.focusRing [GridVP, ExampleVP] 62 | , _selected = (0,19) 63 | } 64 | 65 | initialSpeed :: Float 66 | initialSpeed = 0.75 67 | 68 | -- | Speed increments = 0.01 gives 100 discrete speed settings 69 | speedInc :: Float 70 | speedInc = 0.01 71 | 72 | -- | Minimum interval (microseconds) 73 | -- 74 | -- Corresponding speed == 4 frames / second 75 | minI :: Int 76 | minI = 100000 77 | 78 | -- | Maximum interval (microseconds) 79 | -- 80 | -- Corresponding speed == 1 frames / second 81 | maxI :: Int 82 | maxI = 1000000 83 | 84 | -- | Mid interval (microseconds) 85 | midI :: Int 86 | midI = (maxI - minI) `div` 2 + minI 87 | 88 | -- Interface 89 | 90 | -- | Tick is exactly what it sounds like - the tick of the counter event stream 91 | -- It in and of itself does not "count" anything and thus is not a counter 92 | data Tick = Tick 93 | 94 | app :: App Game Tick Name 95 | app = App { appDraw = drawUI 96 | , appChooseCursor = neverShowCursor -- TODO keep track of "focus" in state 97 | -- and implement cursor chooser based on that 98 | -- although.. prob dont need cursor? 99 | , appHandleEvent = handleEvent 100 | , appStartEvent = return -- TODO setup grid size here! 101 | , appAttrMap = const $ gameAttrMap 102 | } 103 | 104 | ---- Drawing 105 | 106 | drawUI :: Game -> [Widget Name] 107 | drawUI g = [ vBox [ drawGrid g 108 | , hBox $ vLimit 10 . padTopBottom 1 109 | <$> [ drawSpeedBar (g^.speed) <=> drawInstruct 110 | , drawPButton (g^.paused) <=> drawCButton 111 | , drawExamples 112 | ] 113 | ] 114 | ] 115 | 116 | -- | Draw grid 117 | -- 118 | -- BIG asterisk *** I wanted this to be reasonably performant, 119 | -- so I'm leveraging the fact that 'toList' returns ordered tiles. 120 | drawGrid :: Game -> Widget n 121 | drawGrid g = withBorderStyle BS.unicodeBold 122 | $ B.borderWithLabel (str "Game of Life") 123 | $ C.center 124 | $ fst $ toCols (emptyWidget, g ^. board ^. to toMap) 125 | where toCols :: (Widget n, [(Cell, St)]) -> (Widget n, [(Cell, St)]) 126 | toCols (w,[]) = (w,[]) 127 | toCols (w,xs) = let (c,cs) = splitAt rowT xs 128 | in toCols (w <+> mkCol c, cs) 129 | 130 | mkCol :: [(Cell, St)] -> Widget n 131 | mkCol = foldr (flip (<=>) . renderSt) emptyWidget 132 | 133 | rowT :: Int 134 | rowT = g ^. board ^. to size ^. _2 135 | 136 | selCell :: Maybe Cell 137 | selCell = if (g^.focus^. to F.focusGetCurrent == Just GridVP) 138 | then Just (normalize (g^.board) $ g^.selected) 139 | else Nothing 140 | 141 | renderSt :: (Cell, St) -> Widget n 142 | renderSt (c, Alive) = addSelAttr c $ withAttr aliveAttr cw 143 | renderSt (c, Dead) = addSelAttr c $ withAttr deadAttr cw 144 | 145 | addSelAttr :: Cell -> Widget n -> Widget n 146 | addSelAttr c = if selCell == Just c then forceAttr selectedAttr else id 147 | 148 | 149 | drawSpeedBar :: Float -> Widget n 150 | drawSpeedBar s = 151 | padBottom (Pad 1) $ 152 | P.progressBar (Just lbl) s 153 | where lbl = "Speed: " 154 | <> show (fromEnum $ s * 100) 155 | <> " " 156 | <> "(Ctrl <-,->)" 157 | 158 | drawInstruct :: Widget n 159 | drawInstruct = padBottom Max $ str $ 160 | "Press 'space' to toggle play/pause, 'n' to take 1 step,\n\ 161 | \Ctrl(left, right) to vary speed, 'c' to clear the board,\n\ 162 | \Ctrl(up, down) to scroll examples, '1,2,..' to draw an example,\n\ 163 | \(left,right,up,down) to scroll grid, 'Enter' to toggle cell state,\n\ 164 | \'+_=-' to expand/contract horizontally/vertically,\n\ 165 | \'Tab' to move focus, and ESC to quit." 166 | 167 | drawPButton :: Bool -> Widget n 168 | drawPButton pause = mkButton $ 169 | if pause 170 | then withAttr pausedAttr $ str "Play (Space)" 171 | else withAttr playingAttr $ str "Pause (Space)" 172 | 173 | drawCButton :: Widget n 174 | drawCButton = mkButton $ str "Clear (c)" 175 | 176 | drawExamples :: Widget Name 177 | drawExamples = 178 | withAttr examplesAttr $ 179 | mkBox BS.unicodeRounded "Examples (Press #)" $ 180 | vLimit 4 $ hLimit 19 $ 181 | viewport ExampleVP Vertical $ 182 | padRight Max $ 183 | str $ unlines $ zipWith lbl [0..] examples 184 | where lbl n (s, _) = show n ++ ". " ++ s 185 | 186 | examples :: [(String, (Int -> Int -> Board))] 187 | examples = 188 | [ ("Glider", LE.glider) 189 | , ("Pentadecathlon", LE.pentadecathlon) 190 | , ("Beacon", LE.beacon) 191 | , ("Toad", LE.toad) 192 | , ("Blinker", LE.blinker) 193 | , ("Tub", LE.tub) 194 | , ("Beehive", LE.beehive) 195 | , ("Block", LE.block) 196 | ] 197 | 198 | mkButton :: Widget n -> Widget n 199 | mkButton = B.border . withBorderStyle BS.unicodeRounded . padLeftRight 1 200 | 201 | mkBox :: BS.BorderStyle -> String -> Widget n -> Widget n 202 | mkBox bs s = withBorderStyle bs . B.borderWithLabel (str s) 203 | 204 | aliveAttr, deadAttr, selectedAttr :: AttrName 205 | aliveAttr = "alive" 206 | deadAttr = "dead" 207 | selectedAttr = "selected" 208 | 209 | pausedAttr, playingAttr :: AttrName 210 | pausedAttr = "paused" 211 | playingAttr = "playing" 212 | 213 | examplesAttr :: AttrName 214 | examplesAttr = "examples" 215 | 216 | gameAttrMap :: AttrMap 217 | gameAttrMap = attrMap V.defAttr 218 | [ (aliveAttr, bg V.white) 219 | , (deadAttr, bg V.black) 220 | , (selectedAttr, bg V.cyan) 221 | , (pausedAttr, fg V.green) 222 | , (playingAttr, fg V.red) 223 | , (examplesAttr, fg V.blue) 224 | , (P.progressIncompleteAttr, V.blue `on` V.yellow) 225 | , (P.progressCompleteAttr, V.blue `on` V.green) 226 | ] 227 | 228 | -- | Cell widget 229 | cw :: Widget n 230 | cw = str " " 231 | 232 | ---- Events 233 | 234 | -- TODO look in mouse demo for handling mouse events in different layers! 235 | handleEvent :: Game -> BrickEvent Name Tick -> EventM Name (Next Game) 236 | handleEvent g (AppEvent Tick) = continue $ 237 | if (g^.paused || g^.speed == 0) 238 | then g 239 | else forward g 240 | handleEvent g (VtyEvent (V.EvKey V.KRight [V.MCtrl])) = handleSpeed g (+) 241 | handleEvent g (VtyEvent (V.EvKey V.KLeft [V.MCtrl])) = handleSpeed g (-) 242 | handleEvent g (VtyEvent (V.EvKey V.KUp [V.MCtrl])) = scrollEx (-1) >> continue g 243 | handleEvent g (VtyEvent (V.EvKey V.KDown [V.MCtrl])) = scrollEx 1 >> continue g 244 | handleEvent g (VtyEvent (V.EvKey V.KRight [])) = handleMove g (over _1 succ) 245 | handleEvent g (VtyEvent (V.EvKey V.KLeft [])) = handleMove g (over _1 pred) 246 | handleEvent g (VtyEvent (V.EvKey V.KUp [])) = handleMove g (over _2 succ) 247 | handleEvent g (VtyEvent (V.EvKey V.KDown [])) = handleMove g (over _2 pred) 248 | handleEvent g (VtyEvent (V.EvKey V.KEnter [])) = onlyWhenFocused g GridVP $ handleSel g 249 | handleEvent g (VtyEvent (V.EvKey (V.KChar '\t') [])) = continue $ g & focus %~ F.focusNext 250 | handleEvent g (VtyEvent (V.EvKey (V.KChar 'n') [])) = continue $ forward g 251 | handleEvent g (VtyEvent (V.EvKey (V.KChar ' ') [])) = continue $ g & paused %~ not 252 | handleEvent g (VtyEvent (V.EvKey (V.KChar 'c') [])) = continue $ g & board %~ fmap (const Dead) 253 | handleEvent g (VtyEvent (V.EvKey (V.KChar '-') [])) = continue $ g & board %~ resize 0 (-1) 254 | handleEvent g (VtyEvent (V.EvKey (V.KChar '_') [])) = continue $ g & board %~ resize (-1) 0 255 | handleEvent g (VtyEvent (V.EvKey (V.KChar '=') [])) = continue $ g & board %~ resize 0 1 256 | handleEvent g (VtyEvent (V.EvKey (V.KChar '+') [])) = continue $ g & board %~ resize 1 0 257 | handleEvent g (VtyEvent (V.EvKey (V.KChar 'q') [])) = halt g 258 | handleEvent g (VtyEvent (V.EvKey (V.KChar n) [])) 259 | | n `elem` ['0'..'9'] = handleExample g n 260 | | otherwise = continue g 261 | handleEvent g (VtyEvent (V.EvKey V.KEsc [])) = halt g 262 | handleEvent g _ = continue g 263 | 264 | forward :: Game -> Game 265 | forward = (& board %~ step) . (& time %~ succ) 266 | 267 | handleSpeed :: Game -> (Float -> Float -> Float) -> EventM n (Next Game) 268 | handleSpeed g (+/-) = do 269 | let newSp = validS $ (g^.speed) +/- speedInc 270 | liftIO $ atomically $ writeTVar (g^.interval) (spToInt newSp) 271 | continue $ g & speed .~ newSp 272 | 273 | handleMove :: Game -> (Cell -> Cell) -> EventM Name (Next Game) 274 | handleMove g mv = onlyWhenFocused g GridVP $ continue $ 275 | g & selected %~ (normalize (g^.board) . mv) 276 | 277 | handleSel :: Game -> EventM Name (Next Game) 278 | handleSel g = handleMove 279 | (g & board %~ (adjust toggle $ g^.selected)) 280 | (over _1 succ) 281 | 282 | handleExample :: Game -> Char -> EventM n (Next Game) 283 | handleExample g n = continue $ fromMaybe g mg 284 | where mg = set time 0 . set paused True 285 | <$> (set board <$> (me <*> Just l <*> Just h) <*> Just g) 286 | me = examples ^? ix (read [n]) <&> snd 287 | (l,h) = g ^. board . to size 288 | 289 | 290 | scrollEx :: Int -> EventM Name () 291 | scrollEx n = (viewportScroll ExampleVP) `vScrollBy` n 292 | 293 | validS :: Float -> Float 294 | validS = clamp 0 1 295 | 296 | toggle :: St -> St 297 | toggle Alive = Dead 298 | toggle Dead = Alive 299 | 300 | -- | Get interval from progress bar float 301 | spToInt :: Float -> Int 302 | spToInt = floor . toInterval . validS 303 | where toInterval x = (fromIntegral $ maxI - minI) * (1 - x) 304 | + fromIntegral minI 305 | 306 | onlyWhenFocused :: Game -> Name -> EventM Name (Next Game) -> EventM Name (Next Game) 307 | onlyWhenFocused g n act = if (g ^. focus ^. to F.focusGetCurrent == Just n) 308 | then act 309 | else continue g 310 | 311 | -- Runtime 312 | 313 | main :: IO () 314 | main = do 315 | chan <- newBChan 10 316 | tv <- atomically $ newTVar (spToInt initialSpeed) 317 | forkIO $ forever $ do 318 | writeBChan chan Tick 319 | int <- atomically $ readTVar tv 320 | threadDelay int 321 | let buildVty = V.mkVty V.defaultConfig 322 | initialVty <- buildVty 323 | customMain initialVty buildVty (Just chan) app (initialGame tv) >>= printResult 324 | 325 | printResult :: Game -> IO () 326 | printResult g = mapM_ putStrLn 327 | [ "Your game ended with" 328 | , " population: " <> p 329 | , " time: " <> t 330 | ] 331 | where p = show $ population $ g^.board 332 | t = show $ g^.time 333 | 334 | -- Little floating box with current time & population 335 | -- Small text at the bottom with current grid size, e.g. 200 x 220 336 | -- Change grid size on terminal resize (& start grid size based on this) 337 | -- Ah. We need custom widgets for contextual info: https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst#implementing-custom-widgets 338 | --------------------------------------------------------------------------------