From a7eac3e392ab04632afab0c58e2239b1a8e0fc06 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 4 May 2020 08:23:30 +0200 Subject: [PATCH] make example01 affectionate and working --- examples/example01/Main.hs | 164 ++++++++++++++++++------------------ examples/example01/Types.hs | 37 ++++---- 2 files changed, 100 insertions(+), 101 deletions(-) diff --git a/examples/example01/Main.hs b/examples/example01/Main.hs index 8864712..167fd6f 100644 --- a/examples/example01/Main.hs +++ b/examples/example01/Main.hs @@ -10,7 +10,7 @@ import qualified Graphics.Rendering.OpenGL as GL import Control.Concurrent.STM import Control.Concurrent.MVar import Control.Monad.IO.Class (liftIO) -import Control.Monad (when) +import Control.Monad import Control.DeepSeq (deepseq) import Data.Matrix as M @@ -60,7 +60,7 @@ main = do , SDL.Windowed ) ] - } + } :: AffectionConfig UserData withAffection conf load :: IO UserData @@ -76,7 +76,7 @@ load = do -- logIO A.Debug $ prettyMatrix fullMatrix empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())]) empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())]) - step <- NewMVar True + step <- newMVar True (\life food time -> UserData { subsystems = Subsystems (Window empty1) @@ -94,50 +94,45 @@ load = do pre :: UserData -> Affection () pre ud = do - _ <- partSubscribe (subKeyboard $ subsystems sd) (exitOnEsc (doNextStep ud)) - _ <- partSubscribe (subKeyboard $ subsystems sd) (reloadOnR ud) - _ <- partSubscribe (subKeyboard $ subsystems sd) showFPS - _ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen - _ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose - _ <- partSubscribe (subWindow $ subsystems sd) (fitViewport (600/600)) - now <- getElapsedTime - putAffection sd + void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud)) + void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud) + void $ partSubscribe (subKeyboard $ subsystems ud) showFPS + void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen + void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud)) + void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600)) -toggleFullScreen :: KeyboardMessage -> Affection UserData () +toggleFullScreen :: KeyboardMessage -> Affection () toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym) | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen | otherwise = return () toggleFullScreen _ = return () -exitOnEsc :: KeyboardMessage -> Affection UserData () -exitOnEsc (MsgKeyboardEvent _ _ SDL.Pressed False sym) = +exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection () +exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) = case SDL.keysymKeycode sym of SDL.KeycodeEscape -> do liftIO $ logIO A.Debug "Yo dog I heard..." - quit + void $ liftIO $ swapMVar step False _ -> return () -exitOnEsc _ = return () +exitOnEsc _ _ = return () -reloadOnR :: KeyboardMessage -> Affection UserData () -reloadOnR (MsgKeyboardEvent _ _ _ _ sym) = +reloadOnR :: UserData -> KeyboardMessage -> Affection () +reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) = case SDL.keysymKeycode sym of - SDL.KeycodeR -> reload + SDL.KeycodeR -> reload ud _ -> return () -reloadOnR _ = return () +reloadOnR _ _ = return () -reload :: Affection UserData () -reload = do - ud <- getAffection +reload :: UserData -> Affection () +reload ud = do now <- getElapsedTime randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599] let fullMatrix = fromList 60 60 randList - putAffection ud - { lifeMat = fullMatrix - , foodMat = fromList 60 60 (repeat 10) - , timeMat = M.zero 60 60 - } + void $ liftIO $ swapMVar (lifeMat ud) fullMatrix + void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat 10)) + void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60) -showFPS :: KeyboardMessage -> Affection UserData () +showFPS :: KeyboardMessage -> Affection () showFPS (MsgKeyboardEvent _ _ _ _ sym) = case SDL.keysymKeycode sym of SDL.KeycodeF -> do @@ -146,84 +141,87 @@ showFPS (MsgKeyboardEvent _ _ _ _ sym) = _ -> return () showFPS _ = return () -exitOnWindowClose :: WindowMessage -> Affection UserData () -exitOnWindowClose wm = +exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection () +exitOnWindowClose step wm = case wm of MsgWindowClose _ _ -> do liftIO $ logIO A.Debug "I heard another one..." - quit + void $ liftIO $ swapMVar step False _ -> return () -exitOnWindowClose _ = return () +exitOnWindowClose _ _ = return () -handle :: [SDL.EventPayload] -> Affection UserData () -handle es = do - (Subsystems a b) <- subsystems <$> getAffection +handle :: UserData -> [SDL.EventPayload] -> Affection () +handle ud es = do + let (Subsystems a b) = subsystems ud _ <- consumeSDLEvents a =<< consumeSDLEvents b es return () -update :: Double -> Affection UserData () -update _ = do - ud <- getAffection +update :: UserData -> Double -> Affection () +update ud dt = do + -- liftIO $ logIO A.Debug ("FPS: " <> fromString (show (1/dt))) + pastLife <- liftIO $ readMVar (lifeMat ud) + pastFood <- liftIO $ readMVar (foodMat ud) + pastTime <- liftIO $ readMVar (timeMat ud) newList <- mapM (\coord -> do let x = (coord `mod` 60) + 1 y = (coord `div` 60) + 1 subm | x == 1 && y == 1 = - (submatrix 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud)) + (submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife) <-> - (submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud)) + (submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife) | x == 1 && y == 60 = - (submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud)) + (submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife) <-> - (submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud)) + (submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife) | x == 60 && y == 1 = - (submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud)) + (submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife) <-> - (submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud)) + (submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife) | x == 60 && y == 60 = - (submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud)) + (submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife) <-> - (submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud)) + (submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife) | x == 1 = - (submatrix (y - 1) (y + 1) 60 60 (lifeMat ud)) + (submatrix (y - 1) (y + 1) 60 60 pastLife) <|> - (submatrix (y - 1) (y + 1) 1 2 (lifeMat ud)) + (submatrix (y - 1) (y + 1) 1 2 pastLife) | y == 1 = - (submatrix 60 60 (x - 1) (x + 1) (lifeMat ud)) + (submatrix 60 60 (x - 1) (x + 1) pastLife) <-> - (submatrix 1 2 (x - 1) (x + 1) (lifeMat ud)) + (submatrix 1 2 (x - 1) (x + 1) pastLife) | x == 60 = - (submatrix (y - 1) (y + 1) 59 60 (lifeMat ud)) + (submatrix (y - 1) (y + 1) 59 60 pastLife) <|> - (submatrix (y - 1) (y + 1) 1 1 (lifeMat ud)) + (submatrix (y - 1) (y + 1) 1 1 pastLife) | y == 60 = - (submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud)) + (submatrix 59 60 (x -1 ) (x + 1) pastLife) <-> - (submatrix 1 1 (x - 1) (x + 1) (lifeMat ud)) + (submatrix 1 1 (x - 1) (x + 1) pastLife) | otherwise = - (submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud)) + (submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife) life = countLife subm ret - | life == 0 && lifeMat ud M.! (y, x) == 0 = + | life == 0 && pastLife M.! (y, x) == 0 = ( 0 - , if timeMat ud M.! (y, x) >= 10 - then min 10 (foodMat ud M.! (y, x) + 1) - else min 10 (foodMat ud M.! (y, x)) - , timeMat ud M.! (y, x) + 1 + , if pastTime M.! (y, x) >= 10 + then min 10 (pastFood M.! (y, x) + 1) + else min 10 (pastFood M.! (y, x)) + , pastTime M.! (y, x) + 1 ) | otherwise = (1, 1, 1) - if lifeMat ud M.! (y, x) == 1 - then if (life == 2 || life == 3) && foodMat ud M.! (y, x) > 0 - then return (1, (foodMat ud M.! (y, x)) - 1, 0) - else return (0, foodMat ud M.! (y, x), 0) - else if life == 3 && foodMat ud M.! (y, x) > 0 - then return (1, (foodMat ud M.! (y, x)) - 1, 0) + if pastLife M.! (y, x) == 1 + then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0 + then return (1, (pastFood M.! (y, x)) - 1, 0) + else return (0, pastFood M.! (y, x), 0) + else if life == 3 && pastFood M.! (y, x) > 0 + then return (1, (pastFood M.! (y, x)) - 1, 0) else return ( 0 - , if timeMat ud M.! (y, x) > 10 - then min 10 ((foodMat ud M.! (y, x)) + 1) - else min 10 (foodMat ud M.! (y, x)) - , timeMat ud M.! (y, x) + 1 + , if pastTime M.! (y, x) > 10 + then min 10 ((pastFood M.! (y, x)) + 1) + else min 10 (pastFood M.! (y, x)) + , pastTime M.! (y, x) + 1 ) ) [0..3599] let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList) @@ -231,22 +229,22 @@ update _ = do newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList) if newLifeMat == M.zero 60 60 then - reload - else - putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud) - { lifeMat = newLifeMat - --, foodMat = newFoodMat - , timeMat = newTimeMat - } + reload ud + else do + ((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ()) + void $ liftIO $ swapMVar (lifeMat ud) newLifeMat + void $ liftIO $ swapMVar (timeMat ud) newTimeMat + -- void $ liftIO $ swapMVar (foodMat ud) newFoodMat countLife :: Matrix Word -> Word countLife mat = res - (mat M.! (2, 2)) where res = foldr (flip (+)) 0 mat -draw :: Affection UserData () -draw = do - ud <- getAffection +draw :: UserData -> Affection () +draw ud = do + life <- liftIO $ readMVar (lifeMat ud) + food <- liftIO $ readMVar (foodMat ud) liftIO $ do beginFrame (nano ud) 600 600 1 save (nano ud) @@ -254,7 +252,7 @@ draw = do let x = coord `mod` 60 y = coord `div` 60 ctx = nano ud - mult = lifeMat ud M.! (x + 1, y + 1) + mult = life M.! (x + 1, y + 1) -- logIO A.Debug $ show mult beginPath ctx rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10 @@ -262,7 +260,7 @@ draw = do then fillColor ctx (rgba 255 255 255 255) else - fillColor ctx (rgba 0 (fromIntegral $ 25 * (foodMat ud M.! (x+1, y+1))) 0 255) + fillColor ctx (rgba 0 (fromIntegral $ 25 * (food M.! (x+1, y+1))) 0 255) fill ctx ) [0..3599] restore (nano ud) diff --git a/examples/example01/Types.hs b/examples/example01/Types.hs index 217edfa..e56d7ae 100644 --- a/examples/example01/Types.hs +++ b/examples/example01/Types.hs @@ -10,14 +10,15 @@ import Data.Matrix as M import NanoVG import Control.Concurrent.STM -import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.MVar data UserData = UserData - { lifeMat :: Matrix Word - , foodMat :: Matrix Word - , timeMat :: Matrix Word + { lifeMat :: MVar (Matrix Word) + , foodMat :: MVar (Matrix Word) + , timeMat :: MVar (Matrix Word) , subsystems :: Subsystems , nano :: Context + , doNextStep :: MVar Bool } data Subsystems = Subsystems @@ -25,12 +26,12 @@ data Subsystems = Subsystems , subKeyboard :: Types.Keyboard } -newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())]) -newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) -instance Participant Types.Window UserData where - type Mesg Types.Window UserData = WindowMessage +instance Participant Types.Window where + type Mesg Types.Window = WindowMessage partSubscribers (Window t) = do subTups <- liftIO $ readTVarIO t @@ -40,11 +41,11 @@ instance Participant Types.Window UserData where partUnSubscribe (Window t) = generalUnSubscribe t -instance SDLSubsystem Types.Window UserData where +instance SDLSubsystem Types.Window where consumeSDLEvents = consumeSDLWindowEvents -instance Participant Keyboard UserData where - type Mesg Keyboard UserData = KeyboardMessage +instance Participant Keyboard where + type Mesg Keyboard = KeyboardMessage partSubscribers (Keyboard t) = do subTups <- liftIO $ readTVarIO t @@ -54,24 +55,24 @@ instance Participant Keyboard UserData where partUnSubscribe (Keyboard t) = generalUnSubscribe t -instance SDLSubsystem Keyboard UserData where +instance SDLSubsystem Keyboard where consumeSDLEvents = consumeSDLKeyboardEvents generalSubscribe - :: TVar [(UUID, msg -> Affection UserData ())] - -> (msg -> Affection UserData ()) - -> Affection UserData UUID + :: TVar [(UUID, msg -> Affection ())] + -> (msg -> Affection ()) + -> Affection UUID generalSubscribe t funct = do uuid <- genUUID liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) return uuid generalUnSubscribe - :: TVar [(UUID, msg -> Affection UserData ())] + :: TVar [(UUID, msg -> Affection ())] -> UUID - -> Affection UserData () + -> Affection () generalUnSubscribe t uuid = liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) where - filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool + filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool filterMsg (u, _) p = u /= p