{-# 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 ()