├── .gitignore ├── LICENSE ├── README.md └── conway.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virthualenv 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Ben Jeffrey 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of Ben Jeffrey nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL BEN JEFFREY BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | conway.hs 2 | ========= 3 | 4 | Conway's [Game of Life][gol], implemented in Haskell! 5 | 6 | 7 | 8 | Compile & Run 9 | ------------- 10 | 11 | To compile and run: 12 | 13 | $ ghc conway.hs 14 | $ ./conway 15 | 16 | 17 | 18 | Playing the Game 19 | ---------------- 20 | 21 | By default, the game begins with a lone glider, venturing out over the barren 22 | cells of infinity... 23 | 24 | If this is too sad for your pathetic human heart to bear, then edit the `main` 25 | monad at the top of `conway.hs`, changing `glider` in the line: 26 | 27 | main = playGame glider 28 | 29 | 30 | to any of the (currently 3) built-in initial 31 | boards, defined at the bottom of the file: 32 | 33 | * `blinker` - a line of 3 cells, which rotates or blinks every turn 34 | * [`glider`][glider] - the simplest spaceship 35 | * `lwss` - a slightly larger spaceship. 36 | 37 | 38 | Otherwise you can define your own boards, and use them! 39 | 40 | 41 | 42 | 43 | How it Works 44 | ------------ 45 | 46 | We'll ignore `¡EL MONSTER GRAPHICS ENGINE!` in the source code for now, since, 47 | it's somewhat ah.. incomplete, shall we say? 48 | 49 | No, no, the magic all happens in the `iterateBoard` function! When you feed it a 50 | non-empty board, it gleefully generates a list of all the cells in that board 51 | which could change in the next turn. 52 | 53 | For each of those cells, it counts up how many of its neighbours are alive right 54 | now, and applies Conway's rules of life, in the `iterateCell` function: 55 | 56 | * If a living cell has less than 2 neighbours, it dies of 57 | loneliness (cue: 'Awwww's!) 58 | * If it has more than 3 neighbours, then they step on each others toes or 59 | something - and the poor cell dies then, too! 60 | * But if a living cell has just 2 or 3 neighbours, everything is fine and dandy. 61 | * In fact, if an empty cell has exactly 3 neighbours, then something beautiful 62 | happens - a living cell appears between the 3 of them (because that's 63 | acceptable in some cultures, okay!?) 64 | 65 | And after chewing through all the cells, applying these rules, `iterateBoard` 66 | spits out a new board. Well, almost. It throws away all those pesky dead cells 67 | which were hanging around, and using up space, with the `onlyActiveCells` 68 | function, so we can forget about them! (Although we will never forget their 69 | sacrifices, etc. etc.) 70 | 71 | Everything else is really just a (complicated, computationally inefficient...) 72 | helper function! Just follow the definitions down the page to get to the bottom 73 | of it all, so to speak... 74 | 75 | 76 | 77 | 78 | 79 | 80 | [gol]: http://en.wikipedia.org/wiki/Conway%27s_Game_of_Life 81 | [glider]: http://en.wikipedia.org/wiki/Glider_(Conway%27s_Life) 82 | -------------------------------------------------------------------------------- /conway.hs: -------------------------------------------------------------------------------- 1 | -- conway.hs 2 | -- Conway's Game of Life, implemented in Haskell! 3 | -- ----------------------------------------------------------------------------- 4 | module Main where 5 | 6 | import Data.List 7 | 8 | 9 | 10 | main :: IO () 11 | main = playGame glider 12 | 13 | 14 | 15 | -- Game logic & stuff: 16 | -- ----------------------------------------------------------------------------- 17 | 18 | playGame :: Board -> IO () 19 | playGame bd = mapM_ printBoard (game bd) 20 | 21 | 22 | -- `game` is a (potentially infinite) list of boards 23 | game :: Board -> [Board] 24 | game bd = iterate iterateBoard bd 25 | 26 | 27 | iterateBoard :: Board -> Board 28 | iterateBoard [] = error ("The game of life has ended... " ++ 29 | "It looks like the only winning move is not to play!") 30 | iterateBoard bd = onlyActiveCells [iterateCell c (length (livingNeighboursOf affCells c)) | c <- affCells] 31 | where 32 | affCells = affectedCells bd 33 | 34 | 35 | 36 | 37 | iterateCell :: Cell -> Int -> Cell 38 | iterateCell (ActiveCell p q) n 39 | | n < 2 = EmptyCell {x=p, y=q} 40 | | n <= 3 = ActiveCell {x=p, y=q} 41 | | n > 3 = EmptyCell {x=p, y=q} 42 | iterateCell (EmptyCell p q) n 43 | | n == 3 = ActiveCell {x=p, y=q} 44 | | otherwise = EmptyCell {x=p, y=q} 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | -- Data structures: 53 | -- ----------------------------------------------------------------------------- 54 | 55 | 56 | 57 | data Cell = ActiveCell { x :: Int, y :: Int} 58 | | EmptyCell { x :: Int, y:: Int} 59 | --deriving Show -- (replaced by ¡EL MONSTER GRAPHICS ENGINE!) 60 | deriving Eq 61 | 62 | 63 | type Board = [Cell] 64 | 65 | 66 | 67 | 68 | 69 | 70 | -- Board and row operations: 71 | -- ----------------------------------------------------------------------------- 72 | 73 | onlyActiveCells :: Board -> Board 74 | onlyActiveCells bd = [c | c <- bd, isActive c] 75 | 76 | 77 | affectedCells :: Board -> [Cell] 78 | affectedCells bd = nubBy smPosition $ concat [(bd `cellsAround` c) | c <- bd] 79 | 80 | cellsAround :: [Cell] -> Cell -> [Cell] 81 | bd `cellsAround` c = unionBy smPosition bd (mkEmptyNeighbours c) 82 | 83 | -- -------------------------------- 84 | --prop_affectedCells :: Board -> Bool 85 | --prop_affectedCells bd = bd == (onlyActiveCells $ affectedCells bd) 86 | 87 | 88 | 89 | square :: Board -> Board 90 | square bd = unionBy smPosition bd [EmptyCell {x=p, y=q} | p <-[(minimum ps)..(maximum ps)], q <-[(minimum qs)..(maximum qs)]] 91 | where 92 | (ps,qs) = unzip [(x c, y c) | c <- bd] 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | -- Cell helper functions: 102 | -- ----------------------------------------------------------------------------- 103 | 104 | class Position a where 105 | isIn :: a -> [a] -> Bool 106 | nbrs :: a -> a -> Bool 107 | smPosition :: a -> a -> Bool 108 | 109 | 110 | instance Position Cell 111 | where 112 | isIn cell [] = False 113 | isIn cell (c:cs) 114 | | cell `smPosition` c = True 115 | | otherwise = cell `isIn` cs 116 | -- --------------------------------- 117 | c1 `nbrs` c2 = nbrCellCriteria (x c1) (y c1) (x c2) (y c2) 118 | -- ------------------------------------------------------ 119 | c1 `smPosition` c2 = smPositionCellCriteria (x c1) (y c1) (x c2) (y c2) 120 | -- ----------------------------------------------------------- 121 | 122 | 123 | -- Helpers for Cell's instantiation of `Position` 124 | -- ------------------------------------------------ 125 | nbrCellCriteria :: Int -> Int -> Int -> Int -> Bool 126 | nbrCellCriteria p q r s = and [ (p - r) <= 1 127 | , (p - r) >= (-1) 128 | , (q - s) <= 1 129 | , (q - s) >= (-1) 130 | , (p /= r) || (q /= s) ] 131 | smPositionCellCriteria :: Int -> Int -> Int -> Int -> Bool 132 | smPositionCellCriteria p q r s = and [(p == r), (q==s)] 133 | -- ------------------------------------------------ 134 | 135 | 136 | isActive :: Cell -> Bool 137 | isActive (ActiveCell _ _) = True 138 | isActive (EmptyCell _ _) = False 139 | 140 | 141 | 142 | 143 | -- Neighbouring cells ------------------------ 144 | livingNeighboursOf :: [Cell] -> Cell -> [Cell] 145 | bd `livingNeighboursOf` cell = [c | c <- bd, cell `nbrs` c, isActive c] 146 | 147 | allNeighboursOf :: [Cell] -> Cell -> [Cell] 148 | bd `allNeighboursOf` c = delete c (bd `cellsAround` c) 149 | 150 | 151 | 152 | mkEmptyNeighbours :: Cell -> [Cell] 153 | mkEmptyNeighbours c = [EmptyCell {x=r, y=s} | r <- [p-1..p+1], s <- [q-1..q+1], (r /= s) || (s /= 0)] 154 | where 155 | p = x c 156 | q = y c 157 | ---------------------------------------------- 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | -- ¡EL MONSTER GRAPHICS ENGINE! below: 167 | -- ----------------------------------------------------------------------------- 168 | 169 | 170 | 171 | instance Show Cell where 172 | show (ActiveCell _ _) = " X" 173 | show (EmptyCell _ _) = " ·" 174 | --show (ActiveCell x y) = " (X "++(show x)++","++(show y)++")" 175 | --show (EmptyCell x y) = " (· "++(show x)++","++(show y)++")" 176 | 177 | printBoard :: Board -> IO () 178 | printBoard bd = do 179 | putStr "\n" 180 | putStr (replicate 10 ' ') 181 | let board = rows $ square $ affectedCells bd 182 | let xValues = [ x c | c <- (board !! 0)] 183 | mapM_ (putStr . (" " ++) . show) xValues 184 | putStr "\n\n" 185 | mapM_ (printRow) board 186 | putStr "\n" 187 | 188 | 189 | printRow :: [Cell] -> IO () 190 | printRow row = do 191 | let yValue = show (y (row !! 0)) 192 | putStr (yValue ++ replicate (10 - (length yValue)) ' ' ) 193 | mapM_ (putStr . show) row 194 | putStr "\n" 195 | 196 | 197 | 198 | 199 | -- Sorting the board into rows ------- 200 | rows :: Board -> [[Cell]] 201 | rows = groupBy sameRow . sortBoardY 202 | 203 | sameRow :: Cell -> Cell -> Bool 204 | sameRow c1 c2 = y c1 == y c2 205 | -- ----------------------------------- 206 | 207 | 208 | -- Board & cell sorting 209 | -- ------------------------- 210 | sortBoardY :: Board -> Board 211 | sortBoardY = sortBy sortCellY 212 | 213 | 214 | sortCellX :: Cell -> Cell -> Ordering 215 | sortCellX c1 c2 216 | | x c1 < x c2 = LT 217 | | x c1 > x c2 = GT 218 | -- 'X's must be equal 219 | | y c1 < y c2 = LT 220 | | y c1 > y c2 = GT 221 | -- 'Y's must also be equal 222 | | otherwise = EQ 223 | 224 | sortCellY :: Cell -> Cell -> Ordering 225 | sortCellY c1 c2 226 | | y c1 < y c2 = LT 227 | | y c1 > y c2 = GT 228 | -- 'Y's must be equal 229 | | x c1 < x c2 = LT 230 | | x c1 > x c2 = GT 231 | -- 'X's must also be equal 232 | | otherwise = EQ 233 | -- ------------------------- 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | 242 | -- Sample items 243 | -- ----------------------------------------------------------------------------- 244 | 245 | newCell :: Int -> Int -> Cell 246 | newCell x y = ActiveCell {x=x, y=y} 247 | 248 | 249 | -- blinker, period 2 250 | blinker = [newCell (-1) 0, newCell 0 0, newCell 1 0] 251 | 252 | -- glider 253 | glider = [newCell 0 0, newCell 1 1, newCell 2 1, newCell 0 2, newCell 1 2] 254 | 255 | -- Light-Weight Space Ship 256 | lwss = [newCell 0 0, newCell 3 0, 257 | newCell 4 1, newCell 4 2, newCell 4 3, 258 | newCell 0 2, newCell 1 3, newCell 2 3, newCell 3 3] 259 | 260 | 261 | 262 | -- add x and y offsets to a configuration of cells 263 | offset :: Int -> Int -> [Cell] -> [Cell] 264 | offset a b cs = map (\ActiveCell {x=x, y=y} -> ActiveCell {x=x+a, y=y+b}) cs 265 | 266 | -- stationary blob 267 | bail = [newCell 1 1, newCell 1 2, newCell 2 1, newCell 2 2] 268 | 269 | -- more stationary formations 270 | beehive = [newCell 2 1, newCell 1 2, newCell 3 2, newCell 1 3, newCell 3 3, newCell 2 4] 271 | boat = [newCell 2 2, newCell 1 3, newCell 2 4, newCell 3 3, newCell 3 2] 272 | ship = [newCell 1 4, newCell 2 2, newCell 1 3, newCell 2 4, newCell 3 3, newCell 3 2] 273 | loaf = [newCell 3 1, newCell 2 2, newCell 1 3, newCell 2 4, newCell 3 4, newCell 4 2, newCell 4 3] 274 | 275 | -- alternating vertical and horizontal bar 276 | myblinker = [newCell 1 1, newCell 1 2, newCell 1 3] 277 | 278 | -- Another oscillator 279 | oscillator = [newCell 1 1, newCell 2 1, newCell 3 1, newCell 2 2, newCell 3 2, newCell 4 2] 280 | 281 | -- Both of the following formations develop into oscillators 282 | dec_oscil = 283 | [newCell 1 1, newCell 2 1, newCell 3 1, newCell 4 1, newCell 5 1, 284 | newCell 6 1, newCell 7 1, newCell 8 1, newCell 9 1, newCell 10 1] 285 | 286 | pulsar = 287 | [newCell 2 1, newCell 1 2, newCell 2 2, newCell 3 2, newCell 1 3, 288 | newCell 3 3, newCell 1 4, newCell 2 4, newCell 3 4, newCell 2 5] 289 | 290 | -- moves horizontally at a rate of two cells in four generations 291 | spaceship = 292 | [newCell 1 2, newCell 1 4, newCell 2 1, newCell 3 1, newCell 4 1, 293 | newCell 4 4, newCell 5 1, newCell 5 2, newCell 5 3] 294 | ++ offset 6 6 bail 295 | 296 | -- stationary diagonal "pole" with moving "stripes" 297 | barberpole = 298 | [newCell 1 13, newCell 1 12, newCell 2 13, newCell 3 12, newCell 3 10, 299 | newCell 5 10, newCell 5 8, newCell 7 8, newCell 7 6, newCell 9 6, 300 | newCell 9 4, newCell 11 4, newCell 11 2, newCell 12 1, newCell 13 2, 301 | newCell 13 1] 302 | ++ offset 13 13 bail 303 | 304 | -- moves horizontally, leaving a trail of "smoke" 305 | puffertrain = 306 | [newCell 1 16, newCell 2 15, newCell 3 15, newCell 4 18, newCell 4 15, 307 | newCell 5 17, newCell 5 16, newCell 5 15, newCell 1 11, newCell 2 10, 308 | newCell 2 7, newCell 3 10, newCell 3 9, newCell 3 8, newCell 1 2, 309 | newCell 2 1, newCell 3 1, newCell 4 4, newCell 4 1, newCell 5 3, 310 | newCell 5 2, newCell 5 1] 311 | 312 | -- starts small and grows 313 | rpentomino = [newCell 2 1, newCell 1 2, newCell 2 2, newCell 2 3, newCell 3 3] 314 | 315 | -- shoots a stream of gliders 316 | glidergun = 317 | [newCell 1 5, newCell 1 4, newCell 2 5, newCell 2 4, newCell 12 6, 318 | newCell 12 5, newCell 12 4, newCell 13 7, newCell 13 3, newCell 14 8, 319 | newCell 14 2, newCell 15 7, newCell 15 3, newCell 16 6, newCell 16 5, 320 | newCell 16 4, newCell 17 6, newCell 17 5, newCell 17 4, newCell 22 4, 321 | newCell 22 3, newCell 22 2, newCell 23 9, newCell 23 5, newCell 23 4, 322 | newCell 23 2, newCell 23 1, newCell 24 11, newCell 24 10, newCell 24 5, 323 | newCell 24 4, newCell 24 2, newCell 24 1, newCell 25 10, newCell 25 9, 324 | newCell 25 5, newCell 25 4, newCell 25 3, newCell 25 2, newCell 25 1, 325 | newCell 26 6, newCell 26 5, newCell 26 1, newCell 30 5, newCell 30 4, 326 | newCell 34 3, newCell 34 2, newCell 35 3, newCell 35 2] 327 | 328 | -- Moves left and produces a beehive, then moves right and produces 329 | -- another beehive, then moves left and crashes into the first beehive 330 | queenbeeshuttle = 331 | [newCell 1 1, newCell 2 1, newCell 3 2, newCell 4 3, newCell 4 4, 332 | newCell 4 5, newCell 3 6, newCell 2 7, newCell 1 7] 333 | -- ... but we can get rid of a beehive using a bail 334 | beehivebail = beehive ++ offset 0 5 bail 335 | -- ... so we just put a bail on either side of the queenbeeshuttle 336 | qbsbail = offset 0 2 bail ++ offset 8 0 (queenbeeshuttle ++ offset 12 2 bail) 337 | --------------------------------------------------------------------------------