{-# 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.HashMap.Strict as HM import qualified Data.HashSet as HS import qualified Data.Matrix as X import Data.List as L import Data.Foldable (foldrM, foldlM) import Data.Maybe (fromJust, catMaybes) -- import Data.Vector as V import System.Random (randomRIO) import Control.Monad as CM (when, unless) 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 , initScreenMode = SDL.Windowed , 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 :: HS.HashSet (Int, Int) , indices :: [(Int, Int)] , cells :: HM.HashMap (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 <- foldrM (\index@(row, col) acc -> 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", "color") }) tempProps traceIO $ show index return $ HM.insert index Actor { actorProperties = tempAProps , actorNodes = tempMap } acc ) HM.empty indices traceM "loading complete" return UserData { nodeGraph = myMap , foreground = buffer , keysDown = [] , indices = indices , liveIndices = HS.empty , cells = cells , updateActors = [] } loadList :: Affection UserData () loadList = do ud@UserData{..} <- getAffection -- init <- foldrM (\coord acc -> do init <- foldlM (\acc coord -> do trig <- liftIO $ randomRIO (True, False) if trig then return (HS.insert coord acc) else return acc ) HS.empty indices putAffection ud { liveIndices = init } getNeighbors :: (Int, Int) -> [(Int, Int)] getNeighbors (row, col) = map (\(pr, pc) -> (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" ud@UserData{..} <- getAffection let livingActors = parMap rpar (cells HM.!) $ HS.toList 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) -- let new = HS.fromList $ catMaybes $ parMap rpar (\coord@(row, col) -> -- let neighs = -- foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 $ -- getNeighbors coord -- ret -- | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) = -- Just coord -- | neighs == 3 = -- Just coord -- | otherwise = -- Nothing -- in ret -- ) (HS.toList relevant) new <- foldrM (\coord@(row, col) acc -> do -- new <- foldlM (\acc coord@(row, col) -> do let !neighs = sum $ map (\n -> if n `elem` liveIndices ud then 1 else 0)$ getNeighbors coord ret | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) = HS.insert coord acc | neighs == 3 = HS.insert coord acc | otherwise = acc return ret ) HS.empty relevant -- 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 :: HS.HashSet (Int, Int) -> Affection UserData (HS.HashSet (Int, Int)) getRelevant ls = do getRelevant' ls where getRelevant' xs = foldlM (\acc x -> let neighs = getNeighbors x slice = (x : neighs) rels = foldr (\y a -> -- rels = foldl (\a y -> if y `elem` acc then a else HS.insert y a ) HS.empty slice in return (acc `HS.union` rels) ) HS.empty 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 () parHSMap f = (`using` parTraversable rpar) . HM.map f -- catHSMaybe = -- foldr (\x acc -> -- case x of -- Just a -> a `HS.insert` acc -- Nothing -> acc -- ) HS.empty