Commit b7edcdf3 authored by Nicolas Lenz's avatar Nicolas Lenz
Browse files

Various stuff

parent 2a94dfc8
________________________#___________
______________________#_#___________
____________##______##____________##
___________#___#____##____________##
##________#_____#___##______________
##________#___#_##____#_#___________
__________#_____#_______#___________
___________#___#____________________
____________##______________________
video:
rm -f out/*.png out.mp4
stack run
ffmpeg -framerate 12 -i out/%04d.png out.mp4
play:
mpv --loop out.mp4
......@@ -5,6 +5,9 @@ dependencies:
- base
- array
- split
- JuicyPixels
- megaparsec
- text
executables:
game-of-life:
......
module Game where
import Data.Array
import Data.List (intercalate)
import Data.List.Split (divvy)
import Control.Concurrent (threadDelay)
import Control.Monad
import Codec.Picture
{- |
A position on the game board.
The board coordinate system begins at (Pos 0 0) is oriented like this:
0 ----> x
|
|
V
y
-}
data Pos = Pos
{ posX :: Int
, posY :: Int
} deriving (Show, Eq)
instance (Ord Pos) where
compare (Pos x1 y1) (Pos x2 y2) = compare (y1, x1) (y2, x2)
instance (Ix Pos) where
range (Pos x1 y1, Pos x2 y2) = (\(y, x) -> Pos x y) <$> range ((y1, x1), (y2, x2))
index (Pos x1 y1, Pos x2 y2) (Pos x y) = index ((y1, x1), (y2, x2)) (y, x)
inRange (Pos x1 y1, Pos x2 y2) (Pos x y) = inRange ((y1, x1), (y2, x2)) (y, x)
data Cell = Dead | Alive
instance (Show Cell) where
show Dead = "_ "
show Alive = "O "
newtype Board = Board { cells :: Array Pos Cell }
boardFromList :: Int -> [Cell] -> Board
boardFromList width cells = Board $
listArray
(Pos 0 0, Pos (width - 1) ((+(-1)) $ ceiling $ fromIntegral (length cells) / fromIntegral width))
(cells ++ repeat Dead)
boardFromAssocs :: Int -> Int -> [(Pos, Cell)] -> Board
boardFromAssocs width height assocs = Board $ accumArray
(\old new -> new)
Dead
(Pos 0 0, Pos (width - 1) (height - 1))
assocs
padBoard :: Int -> Int -> Int -> Int -> Board -> Board
padBoard top right bottom left board@(Board cells) = boardFromAssocs
(boardWidth board + right + left)
(boardHeight board + top + bottom)
(shift <$> assocs cells)
where shift (Pos x y, val) = (Pos (x + left) (y + top), val)
padBoardAll :: Int -> Board -> Board
padBoardAll padding = padBoard padding padding padding padding
boardWidth, boardHeight :: Board -> Int
boardWidth (Board cells) = let (_, Pos maxX _) = bounds cells in maxX + 1
boardHeight (Board cells) = let (_, Pos _ maxY) = bounds cells in maxY + 1
boardSize :: Board -> (Int, Int)
boardSize board = (boardWidth board, boardHeight board)
instance (Show Board) where
show board@(Board cells) = intercalate "\n" cellRows where
cellStrings = show <$> elems cells :: [String]
cellStringRows = divvy (boardWidth board) (boardWidth board) cellStrings :: [[String]]
cellRows = concat <$> cellStringRows :: [String]
-- | A ruleset for a game of life world.
data Ruleset = Ruleset
[Int] -- ^ amount of neighbors of an alive cell which will let it survive
[Int] -- ^ amount of neighbors of a dead cell which will let it be born anew
-- | The classic Conway world ruleset (23/3):
-- A alive cell will survive with two or three neighbors
-- and a dead cell will be born anew with three neigbors.
conway :: Ruleset
conway = Ruleset [2,3] [3]
-- | Computes the new state of a cell with some amount of neighbors.
newState :: Ruleset -> Int -> Cell -> Cell
newState (Ruleset surv born) neighborCount Alive
| neighborCount `elem` surv = Alive
| otherwise = Dead
newState (Ruleset surv born) neighborCount Dead
| neighborCount `elem` born = Alive
| otherwise = Dead
countAlive :: [Cell] -> Int
countAlive [] = 0
countAlive (Alive:xs) = 1 + countAlive xs
countAlive (Dead:xs) = countAlive xs
transitionCell :: Ruleset -> Board -> Pos -> Cell
transitionCell ruleset board@(Board cells) pos
= newState ruleset (countAlive $ (cells !) <$> neighborsPos (boardWidth board) (boardHeight board) pos) (cells ! pos)
transition :: Ruleset -> Board -> Board
transition ruleset (Board cells) = Board
$ listArray (bounds cells) (transitionCell ruleset (Board cells) <$> indices cells)
neighborsPos :: Int -> Int -> Pos -> [Pos]
neighborsPos width height (Pos x y) = wrap <$> neighborShifts where
neighborShifts :: [Pos]
neighborShifts =
[ Pos (x - 1) (y + 1)
, Pos (x - 1) y
, Pos (x - 1) (y - 1)
, Pos x (y + 1)
, Pos x (y - 1)
, Pos (x + 1) (y + 1)
, Pos (x + 1) y
, Pos (x + 1) (y - 1)
]
wrap :: Pos -> Pos
wrap (Pos x' y') = Pos (x' `mod` (width - 1)) (y' `mod` (height - 1))
-- A trivial test board with a glider
fireworks :: Board
fireworks = boardFromList 3
[ Alive, Alive, Alive
, Alive, Dead, Alive
, Alive, Dead, Alive
, Dead, Dead, Dead
, Alive, Dead, Alive
, Alive, Dead, Alive
, Alive, Alive, Alive
]
fPentomino :: Board
fPentomino = boardFromList 3
[ Dead, Alive, Alive
, Alive, Alive, Dead
, Dead, Alive, Dead
]
heart :: Board
heart = boardFromList 5
[ Dead, Alive, Dead, Alive, Dead
, Alive, Dead, Alive, Dead, Alive
, Alive, Dead, Dead, Dead, Alive
, Dead, Alive, Dead, Alive, Dead
, Dead, Dead, Alive, Dead, Dead
]
boardToImage :: Board -> Int -> Image PixelRGB8
boardToImage board@(Board cells) magnification = generateImage
(\x y -> cellToPixel $ cells ! Pos (floor $ fromIntegral x / fromIntegral magnification) (floor $ fromIntegral y / fromIntegral magnification))
(boardWidth board * magnification)
(boardHeight board * magnification)
cellToPixel :: Cell -> PixelRGB8
cellToPixel Alive = PixelRGB8 0 0 0
cellToPixel Dead = PixelRGB8 255 255 255
saveBoard :: Board -> String -> Int -> IO ()
saveBoard board path magnification = writePng path (boardToImage board magnification)
module Main where
import Text.Printf
import Control.Monad
import Text.Megaparsec
import Text.Megaparsec.Error
import qualified Parser
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Array
import Data.List (intercalate)
import Data.List.Split (divvy)
import Control.Concurrent (threadDelay)
data Cell = Dead | Alive
instance (Show Cell) where
show Dead = "_ "
show Alive = "O "
data Board = Board { cells :: (Array Pos Cell) }
instance (Show Board) where
show (Board cells) = intercalate "\n" cellRows where
(Pos _ _, Pos _ maxX) = bounds cells
cellStrings = show <$> elems cells :: [String]
cellStringRows = divvy (maxX + 1) (maxX + 1) cellStrings :: [[String]]
cellRows = concat <$> cellStringRows :: [String]
{-
The coordinate system is oriented like this:
+---> x
|
V
y
-}
data Pos = Pos
{ posY :: Int
, posX :: Int
} deriving (Show, Eq, Ord, Ix)
-- | A ruleset for a game of life world.
data Ruleset = Ruleset
[Int] -- ^ amount of neighbors of an alive cell which will let it survive
[Int] -- ^ amount of neighbors of a dead cell which will let it be born anew
-- | The classic Conway world ruleset (23/3):
-- A alive cell will survive with two or three neighbors
-- and a dead cell will be born anew with three neigbors.
conway :: Ruleset
conway = Ruleset [2,3] [3]
-- | Computes the new state of a cell with some amount of neighbors.
newState :: Ruleset -> Int -> Cell -> Cell
newState (Ruleset surv born) neighborCount Alive
| neighborCount `elem` surv = Alive
| otherwise = Dead
newState (Ruleset surv born) neighborCount Dead
| neighborCount `elem` born = Alive
| otherwise = Dead
countAlive :: [Cell] -> Int
countAlive [] = 0
countAlive (Alive:xs) = 1 + countAlive xs
countAlive (Dead:xs) = countAlive xs
transitionCell :: Ruleset -> Board -> Pos -> Cell
transitionCell ruleset (Board cells) pos
= newState ruleset (countAlive $ (cells !) <$> neighborsPos (bounds cells) pos) (cells ! pos)
transition :: Ruleset -> Board -> Board
transition ruleset (Board cells) = Board
$ listArray (bounds cells) (transitionCell ruleset (Board cells) <$> indices cells)
neighborsPos :: (Pos, Pos) -> Pos -> [Pos]
neighborsPos (Pos minY minX, Pos maxY maxX) pos = shiftPos pos <$> neighborShifts where
shiftPos :: Pos -> (Int, Int) -> Pos
shiftPos (Pos y x) (shiftY, shiftX) = Pos ((y + shiftY) `mod` maxY) ((x + shiftX) `mod` maxX)
neighborShifts :: [(Int, Int)]
neighborShifts = [(-1, 1), (0, 1), (1, 1), (-1, 0), (1, 0), (-1, -1), (0, -1), (1, -1)]
-- A trivial test board with a glider
testBoard :: Board
testBoard = Board $ listArray (Pos 0 0, Pos 6 6)
[ Dead, Dead, Dead, Dead, Dead, Dead, Dead
, Dead, Dead, Dead, Dead, Dead, Dead, Dead
, Dead, Dead, Dead, Alive, Dead, Dead, Dead
, Dead, Dead, Dead, Dead, Alive, Dead, Dead
, Dead, Dead, Alive, Alive, Alive, Dead, Dead
, Dead, Dead, Dead, Dead, Dead, Dead, Dead
, Dead, Dead, Dead, Dead, Dead, Dead, Dead
]
import Game
main :: IO ()
main = loop testBoard where
loop board = do
print board
putStrLn ""
threadDelay 200000
loop (transition conway board)
main = do
file <- T.readFile "example.gol"
case parse Parser.board "example.gol" file of
Left err -> putStrLn $ errorBundlePretty err
Right board -> do
putStrLn $ printf "Width: %d, Height: %d" (boardWidth board) (boardHeight board)
putStrLn $ "Bounds: " <> show (bounds $ cells board)
print board
putStrLn ""
loop (padBoardAll 18 board) 1
where
loop :: Board -> Int -> IO ()
loop board generation = do
putStrLn $ printf "Generation %04d" generation
print board
saveBoard board (printf "out/%04d.png" generation) 30
putStrLn ""
-- threadDelay 200000
when (generation < 500) $ loop (transition conway board) (generation + 1)
module Parser where
import Data.Text (Text)
import Data.Void
import Text.Megaparsec
import Text.Megaparsec.Char
import Game
type Parser = Parsec Void Text
cell :: Parser Cell
cell = Alive <$ char '#' <|> Dead <$ char '_'
cellS :: Parser Cell
cellS = cell <* space
firstLine :: Parser [Cell]
firstLine = many cell
board :: Parser Board
board = do
space
firstLine <- many cell
space
rest <- many cellS
eof
return $ boardFromList (length firstLine) (firstLine ++ rest)
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment