From f52e94e82ab2524b94294e62d1e3b61727db3085 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 4 May 2020 13:06:36 +0200 Subject: [PATCH] made example02 affectionate and working! --- examples/example02/Main.hs | 207 ++++++++++++++++++------------------ examples/example02/Types.hs | 37 +++---- 2 files changed, 124 insertions(+), 120 deletions(-) diff --git a/examples/example02/Main.hs b/examples/example02/Main.hs index 30454ed..2cd33a2 100644 --- a/examples/example02/Main.hs +++ b/examples/example02/Main.hs @@ -8,8 +8,9 @@ import qualified SDL 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 @@ -28,6 +29,15 @@ import Foreign.C.Types (CInt(..)) import Types +instance Affectionate UserData where + loadState = load + preLoop = pre + handleEvents = handle + update = Main.update + draw = Main.draw + cleanUp = clean + hasNextStep = liftIO . readMVar . doNextStep + foreign import ccall unsafe "glewInit" glewInit :: IO CInt @@ -50,17 +60,10 @@ main = do , SDL.windowInitialSize = SDL.V2 600 600 , SDL.windowResizable = True } + , SDL.Windowed ) ] - , initScreenMode = SDL.Windowed - , canvasSize = Nothing - , loadState = load - , preLoop = pre - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , cleanUp = clean - } + } :: AffectionConfig UserData withAffection conf load :: IO UserData @@ -74,65 +77,64 @@ load = do nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug]) let fullMatrix = fromList 60 60 randList -- logIO A.Debug $ prettyMatrix fullMatrix - empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection UserData ())]) - empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())]) - return $ UserData + empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())]) + empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())]) + (\life food time break -> UserData { subsystems = Subsystems (Window empty1) (Keyboard empty3) - , lifeMat = fullMatrix - , foodMat = fromList 60 60 (repeat maxFood) - , timeMat = M.zero 60 60 + , lifeMat = life + , foodMat = food + , timeMat = time , nano = nanoCtx + , doNextStep = break } + ) + <$> newMVar fullMatrix + <*> newMVar (fromList 60 60 (repeat maxFood)) + <*> newMVar (M.zero 60 60) + <*> newMVar True -pre :: Affection UserData () -pre = do - sd <- getAffection - _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc - _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR - _ <- 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 +pre :: UserData -> Affection () +pre ud = do + 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 + | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0 | 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 - now <- getElapsedTime +reload :: UserData -> Affection () +reload ud = do randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599] let fullMatrix = fromList 60 60 randList - putAffection ud - { lifeMat = fullMatrix - , foodMat = fromList 60 60 (repeat maxFood) - , timeMat = M.zero 60 60 - } + void $ liftIO $ swapMVar (lifeMat ud) fullMatrix + void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat maxFood)) + 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 @@ -141,84 +143,86 @@ 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 _ = do + 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 maxFood ((foodMat ud M.! (y, x)) + 1) - else min maxFood (foodMat ud M.! (y, x)) - , timeMat ud M.! (y, x) + 1 + , if pastTime M.! (y, x) > 10 + then min maxFood ((pastFood M.! (y, x)) + 1) + else min maxFood (pastFood M.! (y, x)) + , pastTime M.! (y, x) + 1 ) ) [0..3599] let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList) @@ -226,30 +230,29 @@ 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 - liftIO $ do +draw :: UserData -> Affection () +draw ud = liftIO $ do + pastLife <- readMVar (lifeMat ud) + pastFood <- readMVar (foodMat ud) beginFrame (nano ud) 600 600 1 save (nano ud) mapM_ (\coord -> do let x = coord `mod` 60 y = coord `div` 60 ctx = nano ud - mult = lifeMat ud M.! (x + 1, y + 1) + mult = pastLife M.! (x + 1, y + 1) -- logIO A.Debug $ show mult beginPath ctx rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10 @@ -257,7 +260,7 @@ draw = do then fillColor ctx (rgba 255 255 255 255) else - fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (foodMat ud M.! (x+1, y+1))) 0 255) + fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (pastFood M.! (x+1, y+1))) 0 255) fill ctx ) [0..3599] restore (nano ud) diff --git a/examples/example02/Types.hs b/examples/example02/Types.hs index 217edfa..e56d7ae 100644 --- a/examples/example02/Types.hs +++ b/examples/example02/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