From fc452c53ffd18355c004a89550df3ca2a7ac740a Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 29 Mar 2017 00:43:09 +0200 Subject: [PATCH] new example: game of life --- affection.cabal | 22 ++ examples/example05.hs | 462 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 484 insertions(+) create mode 100644 examples/example05.hs diff --git a/affection.cabal b/affection.cabal index 0daf7f6..23dad16 100644 --- a/affection.cabal +++ b/affection.cabal @@ -177,3 +177,25 @@ executable example04 , monad-parallel else buildable: False + +executable example05 + hs-source-dirs: examples + main-is: example05.hs + ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts + default-language: Haskell2010 + default-extensions: OverloadedStrings + if flag(examples) + build-depends: base + , affection + , sdl2 + , gegl + , babl + , containers + , mtl + , random + , matrix + , random + , monad-parallel + , parallel + else + buildable: False diff --git a/examples/example05.hs b/examples/example05.hs new file mode 100644 index 0000000..e1e53c6 --- /dev/null +++ b/examples/example05.hs @@ -0,0 +1,462 @@ +{-# LANGUAGE RecordWildCards, BangPatterns #-} + +import Affection +import qualified SDL +import qualified GEGL as G +import qualified BABL as B +import qualified Data.Map.Strict as M +import qualified Data.Matrix as X +import Data.List as L +import Data.Maybe (fromJust, catMaybes) +-- import Data.Vector as V +import System.Random (randomRIO) +import Control.Monad as CM (when, unless, foldM) +import qualified Control.Monad.Parallel as MP +import Control.Parallel.Strategies +import Foreign.C.Types +import Foreign.Marshal.Utils + +import Debug.Trace + +dimension :: Int +dimension = 30 + +resolution :: Int +resolution = 600 + +main :: IO () +main = do + conf <- return AffectionConfig + { initComponents = All + , windowTitle = "Affection: example00" + , windowConfig = SDL.defaultWindow + { windowInitialSize = SDL.V2 + (CInt $ fromIntegral resolution) + (CInt $ fromIntegral resolution) + } + , canvasSize = Nothing + , preLoop = loadMatrix + , eventLoop = handle + , updateLoop = Main.update + , drawLoop = draw + , loadState = load + , cleanUp = clean + } + withAffection conf + +data UserData = UserData + { nodeGraph :: M.Map String G.GeglNode + , foreground :: G.GeglBuffer + , keysDown :: [SDL.Keycode] + , matrix :: X.Matrix Bool + , indices :: [(Int, Int)] + -- , cells :: [((Int, Int), M.Map String G.GeglNode)] + , cells :: [((Int, Int), Actor String)] + , updateActors :: [Actor String] + } + +load :: IO UserData +load = do + traceM "loading" + root <- G.gegl_node_new + traceM "new root node" + let bgProps = props $ do + prop "x" (0 :: Double) + prop "y" (0 :: Double) + prop "width" (fromIntegral resolution :: Double) + prop "height" (fromIntegral resolution :: Double) + prop "color" $ G.RGB 0 0 0 + bg <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" bgProps + traceM "background" + over <- G.gegl_node_new_child root G.defaultOverOperation + traceM "over" + buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 resolution resolution) =<< + B.babl_format (B.PixelFormat B.RGBA B.CFfloat) + sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $ + props $ + prop "buffer" buffer + traceM "buffer-sink" + crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $ + props $ do + prop "width" (fromIntegral resolution :: Double) + prop "height" (fromIntegral resolution :: Double) + G.gegl_node_link_many [bg, over, crop, sink] + nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" [] + _ <- G.gegl_node_connect_to nop "output" over "aux" + traceM "connections made" + myMap <- return $ M.fromList + [ ("root" , root) + , ("over" , over) + , ("background" , bg) + , ("sink" , sink) + , ("nop" , nop) + , ("crop" , crop) + ] + traceM "building matrix" + let !emptyMatrix = X.matrix dimension dimension (const False) + !indices = [(row, col) | row <- [1..dimension], col <- [1..dimension]] + traceM "building cells" + cells <- foldM (\acc index@(row, col) -> do + tempOver <- G.gegl_node_new_child root $ G.defaultOverOperation + let !scale = (fromIntegral resolution) / (fromIntegral dimension) + tempProps = + props $ do + prop "x" (((fromIntegral col) - 1) * scale :: Double) + prop "y" (((fromIntegral row) - 1) * scale :: Double) + prop "width" (scale :: Double) + prop "height" (scale :: Double) + prop "color" $ G.RGB 1 1 1 + tempRect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" + tempProps + G.gegl_node_connect_to tempRect "output" tempOver "aux" + -- unless (null acc) $ + -- G.gegl_node_link tempOver ((actorNodes $ snd $ head acc) M.! "over") + let tempMap = M.fromList + [ ("over", tempOver) + , ("rect", tempRect) + ] + tempAProps = + map (\p -> ActorProperty + { apName = G.propertyName p + , apValue = G.propertyValue p + , apMapping = Just "rect" + }) tempProps + traceIO $ show index + return $ (index, Actor + { actorProperties = tempAProps + , actorNodes = tempMap + }) : acc + ) + ([] :: [((Int, Int), Actor String)]) + indices + :: IO [((Int, Int), Actor String)] + -- _ <- G.gegl_node_link ((actorNodes $ snd $ last cells) M.! "over") nop + traceM "loading complete" + return UserData + { nodeGraph = myMap + , foreground = buffer + , keysDown = [] + , matrix = emptyMatrix + , indices = indices + , cells = cells + , updateActors = [] + } + +loadMatrix :: Affection UserData () +loadMatrix = do + !init <- liftIO $ X.fromList dimension dimension <$> MP.mapM (const (randomRIO (False, True))) [1..(dimension ^ 2)] + ud <- getAffection + putAffection ud + { matrix = init + } + traceM "matrix initialized" + +getNeighbors :: (Int, Int) -> Affection UserData (X.Matrix Bool) +getNeighbors (row, col) + | row == 1 && col == 1 = do + UserData{..} <- getAffection + return $ X.joinBlocks + ( X.submatrix + dimension + dimension + dimension + dimension + matrix + , X.submatrix + dimension + dimension + col + (col + 1) + matrix + , X.submatrix + row + (row + 1) + dimension + dimension + matrix + , X.submatrix + row + (row + 1) + col + (col + 1) + matrix + ) + | row == 1 && col == dimension = do + UserData{..} <- getAffection + return $ X.joinBlocks + ( X.submatrix + dimension + dimension + (col - 1) + col + matrix + , X.submatrix + dimension + dimension + 1 + 1 + matrix + , X.submatrix + row + (row + 1) + (col - 1) + col + matrix + , X.submatrix + row + (row + 1) + 1 + 1 + matrix + ) + | row == dimension && col == 1 = do + UserData{..} <- getAffection + return $ X.joinBlocks + ( X.submatrix + (row - 1) + row + dimension + dimension + matrix + , X.submatrix + (row - 1) + row + col + (col + 1) + matrix + , X.submatrix + 1 + 1 + dimension + dimension + matrix + , X.submatrix + 1 + 1 + col + (col + 1) + matrix + ) + | row == dimension && col == dimension = do + UserData{..} <- getAffection + return $ X.joinBlocks + ( X.submatrix + (row - 1) + row + (col - 1) + col + matrix + , X.submatrix + (row - 1) + row + 1 + 1 + matrix + , X.submatrix + 1 + 1 + (col - 1) + col + matrix + , X.submatrix + 1 + 1 + 1 + 1 + matrix + ) + | row == 1 = do + UserData{..} <- getAffection + return $ + X.submatrix + dimension + dimension + (col - 1) + (col + 1) + matrix + X.<-> + X.submatrix + row + (row + 1) + (col - 1) + (col + 1) + matrix + | row == dimension = do + UserData{..} <- getAffection + return $ + X.submatrix + (row - 1) + row + (col - 1) + (col + 1) + matrix + X.<-> + X.submatrix + 1 + 1 + (col - 1) + (col + 1) + matrix + | col == 1 = do + UserData{..} <- getAffection + return $ + X.submatrix + (row - 1) + (row + 1) + dimension + dimension + matrix + X.<|> + X.submatrix + (row - 1) + (row + 1) + col + (col + 1) + matrix + | col == dimension = do + UserData{..} <- getAffection + return $ + X.submatrix + (row - 1) + (row + 1) + (col - 1) + col + matrix + X.<|> + X.submatrix + (row - 1) + (row + 1) + 1 + 1 + matrix + | otherwise = do + UserData{..} <- getAffection + return $ X.submatrix (row - 1) (row + 1) (col - 1) (col + 1) matrix + +draw :: Affection UserData () +draw = do + traceM "drawing" + ud@UserData{..} <- getAffection + _ <- liftIO $ MP.mapM + (\(_, a) -> G.gegl_node_disconnect (actorNodes a M.! "over") "input" + ) cells + -- _ <- liftIO $ G.gegl_node_disconnect (nodeGraph M.! "nop") "input" + let livingActors = catMaybes $ map (\coord -> do + if matrix X.! coord + then lookup coord cells + else Nothing + ) indices + unless (null livingActors) $ do + liftIO $ G.gegl_node_link_many $ + map (\a -> (actorNodes a) M.! "over") livingActors + _ <- liftIO $ G.gegl_node_link ((actorNodes $ last livingActors) M.! "over") + (nodeGraph M.! "nop") + return () + -- MP.mapM_ applyProperties updateActors + process (nodeGraph M.! "sink") + present (G.GeglRectangle 0 0 resolution resolution) foreground True + render + Nothing + Nothing + putAffection ud + { updateActors = [] + } + +update :: Double -> Affection UserData () +update dt = do + traceM "updating" + + ud <- getAffection + elapsed <- getElapsedTime + + traceM $ show (1 / dt) ++ " FPS" + traceM $ show $ keysDown ud + new <- MP.mapM (\coord@(row, col) -> do + neighs <- X.toList <$> getNeighbors coord + if True `elem` neighs + then do + let !living = sum $ parMap rpar (fromBool) neighs + if matrix ud X.! coord + then + if living - 1 == 2 || living - 1 == 3 + then + return True + else do + -- tud <- getAffection + -- let nac = updateProperties (props $ do + -- prop "color" $ G.RGB 0 0 0 + -- ) (fromJust $ lookup coord (cells tud)) + -- putAffection tud + -- { updateActors = + -- nac : updateActors tud + -- , cells = (coord, nac) : + -- (deleteBy (\a b -> fst a == fst b) (coord, nac) (cells tud)) + -- } + return False + else + if living == 3 + then do + -- tud <- getAffection + -- let nac = updateProperties (props $ do + -- prop "color" $ G.RGB 1 1 1 + -- ) (fromJust $ lookup coord (cells tud)) + -- putAffection tud + -- { updateActors = + -- nac : updateActors tud + -- , cells = (coord, nac) : + -- (deleteBy (\a b -> fst a == fst b) (coord, nac) (cells tud)) + -- } + return True + else + return False + else + return False + ) (indices ud) + ud2 <- getAffection + putAffection ud2 + { matrix = X.fromList dimension dimension new + } + -- when (floor elapsed < floor (elapsed + dt)) $ do + -- new <- mapM (\coord@(col, row) -> do + -- living <- foldl (\acc b -> if b then acc + 1 else acc) 0 <$> + -- getNeighbors coord + -- if matrix ud X.! coord + -- then + -- if living == 2 || living == 3 then return $ True else return $ False + -- else + -- if living == 3 then return $ True else return $ False + -- ) (indices ud) + -- traceM $ show $ X.fromList 10 10 new + -- putAffection ud + -- { matrix = X.fromList 10 10 new + -- } + + mapM_ (\code -> + when (code == SDL.KeycodeR) loadMatrix + ) (keysDown ud) + +handle :: SDL.EventPayload -> Affection UserData () +handle (SDL.KeyboardEvent dat) = + when (not (SDL.keyboardEventRepeat dat)) $ do + ud <- getAffection + if (SDL.keyboardEventKeyMotion dat == SDL.Pressed) + then + putAffection ud + { keysDown = + SDL.keysymKeycode (SDL.keyboardEventKeysym dat) : keysDown ud + } + else + putAffection ud + { keysDown = + delete (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) (keysDown ud) + } + +handle (SDL.WindowClosedEvent _) = do + traceM "seeya!" + quit + +handle _ = + return () + +clean :: UserData -> IO () +clean _ = return ()