{-# 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 = 60 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 = loadList , 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] , liveIndices :: [(Int, Int)] , indices :: [(Int, Int)] -- , 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" -- 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)] traceM "loading complete" return UserData { nodeGraph = myMap , foreground = buffer , keysDown = [] , indices = indices , liveIndices = [] -- , cells = cells -- , updateActors = [] } loadList :: Affection UserData () loadList = do ud@UserData{..} <- getAffection init <- foldM (\acc coord -> do trig <- liftIO $ randomRIO (True, False) if trig then return (coord : acc) else return acc ) [] indices putAffection ud { liveIndices = init } getNeighbors :: (Int, Int) -> Affection UserData [(Int, Int)] getNeighbors (row, col) = do UserData{..} <- getAffection mapM (\(pr, pc) -> return (overflow(row + pr), overflow(col + pc)) ) lcs where overflow x | x < 1 = dimension | x > dimension = 1 | otherwise = x lcs :: [(Int, Int)] lcs = [ (-1, -1) , (-1, 0) , (-1, 1) , (0, -1) -- , (0, 0) , (0, 1) , (1, -1) , (1, 0) , (1, 1) ] draw :: Affection UserData () draw = do traceM "drawing" ad <- get ud@UserData{..} <- getAffection SDL.rendererDrawColor (windowRenderer ad) SDL.$= (SDL.V4 0 0 0 255) SDL.clear (windowRenderer ad) SDL.rendererDrawColor (windowRenderer ad) SDL.$= (SDL.V4 255 255 255 255) MP.mapM_ (\(row, col) -> let scale = floor (fromIntegral resolution / fromIntegral dimension) in SDL.fillRect (windowRenderer ad) (Just ( SDL.Rectangle (SDL.P (SDL.V2 (CInt $ fromIntegral $ (col - 1) * scale) (CInt $ fromIntegral $ (row - 1) * scale) )) (SDL.V2 (CInt $ fromIntegral $ scale) (CInt $ fromIntegral $ scale) ) )) ) liveIndices -- render Nothing Nothing -- let livingActors = catMaybes $ parMap rpar (\i -> lookup i cells) liveIndices -- unless (null livingActors) $ do -- liftIO $ G.gegl_node_link_many $ -- parMap rpar (\a -> (actorNodes a) M.! "over") livingActors -- _ <- liftIO $ G.gegl_node_link ((actorNodes $ last livingActors) M.! "over") -- (nodeGraph M.! "nop") -- return () -- process (nodeGraph M.! "sink") -- present (G.GeglRectangle 0 0 resolution resolution) foreground True -- render -- Nothing -- Nothing -- _ <- liftIO $ MP.mapM -- (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input" -- ) livingActors -- 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 relevant <- getRelevant (liveIndices ud) new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do neighs <- foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$> getNeighbors coord let ret | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) = Just coord | neighs == 3 = Just coord | otherwise = Nothing return ret ) relevant ud2 <- getAffection putAffection ud2 { liveIndices = new } mapM_ (\code -> when (code == SDL.KeycodeR) loadList ) (keysDown ud) getRelevant :: [(Int, Int)] -> Affection UserData [(Int, Int)] getRelevant ls = getRelevant' ls where getRelevant' xs = foldM (\acc x -> do neighs <- getNeighbors x let slice = (x : neighs) rels = foldl (\a y -> if y `elem` acc then a else y : a ) [] slice return (acc ++ rels) ) [] xs 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 ()