From 91c70c6ec62e407bd6d0233fbc2c64bafc3b6cdc Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 26 Dec 2018 23:19:20 +0100 Subject: [PATCH] add new example --- affection.cabal | 23 ++++ examples/example01/Main.hs | 2 +- examples/example02/Main.hs | 260 ++++++++++++++++++++++++++++++++++++ examples/example02/Types.hs | 77 +++++++++++ 4 files changed, 361 insertions(+), 1 deletion(-) create mode 100644 examples/example02/Main.hs create mode 100644 examples/example02/Types.hs diff --git a/affection.cabal b/affection.cabal index 378b5c5..a5d0918 100644 --- a/affection.cabal +++ b/affection.cabal @@ -152,3 +152,26 @@ executable example01 , deepseq else buildable: False + +-- Another small game of life implementation +executable example02 + hs-source-dirs: examples/example02 + main-is: Main.hs + other-modules: Types + ghc-options: -threaded -Wall + default-language: Haskell2010 + default-extensions: OverloadedStrings + if flag(examples) + build-depends: base >=4.9 && < 5 + , affection + , sdl2 + , stm + , OpenGL + , random + , containers + , linear + , matrix + , nanovg >= 0.6.0.0 + , deepseq + else + buildable: False diff --git a/examples/example01/Main.hs b/examples/example01/Main.hs index 08fe6df..9dfd6c2 100644 --- a/examples/example01/Main.hs +++ b/examples/example01/Main.hs @@ -221,7 +221,7 @@ update _ = do else putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud) { lifeMat = newLifeMat - , foodMat = newFoodMat + --, foodMat = newFoodMat , timeMat = newTimeMat } diff --git a/examples/example02/Main.hs b/examples/example02/Main.hs new file mode 100644 index 0000000..7a32bb2 --- /dev/null +++ b/examples/example02/Main.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +import Affection as A +import SDL (($=)) +import qualified SDL +import qualified Graphics.Rendering.OpenGL as GL + +import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) +import Control.Monad (when) +import Control.DeepSeq (deepseq) + +import Data.Matrix as M +import qualified Data.Set as S + +import System.Random (randomRIO) + +import NanoVG hiding (V2(..)) + +import Linear + +import Foreign.C.Types (CInt(..)) + +-- internal imports + +import Types + +foreign import ccall unsafe "glewInit" + glewInit :: IO CInt + +maxFood :: Word +maxFood = 255 + +main :: IO () +main = do + logIO A.Debug "Starting" + let conf = AffectionConfig + { initComponents = All + , windowTitle = "affection: example01" + , windowConfig = SDL.defaultWindow + { SDL.windowOpenGL = Just SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + , SDL.windowInitialSize = SDL.V2 600 600 + , SDL.windowResizable = True + } + , initScreenMode = SDL.Windowed + , canvasSize = Nothing + , loadState = load + , preLoop = pre + , eventLoop = handle + , updateLoop = update + , drawLoop = draw + , cleanUp = clean + } + withAffection conf + +load :: IO UserData +load = do + -- emptyMatrix <- zero 60 60 + liftIO $ logIO A.Debug "init GLEW" + _ <- glewInit + liftIO $ logIO A.Debug "making random" + randList <- mapM (\_ -> randomRIO (0,1)) [0..3599] + liftIO $ logIO A.Debug "creating context" + 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 + { subsystems = Subsystems + (Window empty1) + (Keyboard empty3) + , lifeMat = fullMatrix + , foodMat = fromList 60 60 (repeat maxFood) + , timeMat = M.zero 60 60 + , nano = nanoCtx + } + +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 + +toggleFullScreen :: KeyboardMessage -> Affection UserData () +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) = + case SDL.keysymKeycode sym of + SDL.KeycodeEscape -> do + liftIO $ logIO A.Debug "Yo dog I heard..." + quit + _ -> return () +exitOnEsc _ = return () + +reloadOnR :: KeyboardMessage -> Affection UserData () +reloadOnR (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeR -> reload + _ -> return () +reloadOnR _ = return () + +reload :: Affection UserData () +reload = do + ud <- getAffection + 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 maxFood) + , timeMat = M.zero 60 60 + } + +showFPS :: KeyboardMessage -> Affection UserData () +showFPS (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeF -> do + dt <- getDelta + liftIO $ logIO A.Debug $ "FPS: " ++ show (1 / dt) + _ -> return () +showFPS _ = return () + +exitOnWindowClose :: WindowMessage -> Affection UserData () +exitOnWindowClose wm = + case wm of + MsgWindowClose _ _ -> do + liftIO $ logIO A.Debug "I heard another one..." + quit + _ -> return () +exitOnWindowClose _ = return () + +handle :: [SDL.EventPayload] -> Affection UserData () +handle es = do + (Subsystems a b) <- subsystems <$> getAffection + _ <- consumeSDLEvents a =<< consumeSDLEvents b es + return () + +update :: Double -> Affection UserData () +update _ = do + ud <- getAffection + 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 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud)) + | x == 1 && y == 60 = + (submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud)) + <-> + (submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud)) + | x == 60 && y == 1 = + (submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud)) + <-> + (submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud)) + | x == 60 && y == 60 = + (submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud)) + <-> + (submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud)) + | x == 1 = + (submatrix (y - 1) (y + 1) 60 60 (lifeMat ud)) + <|> + (submatrix (y - 1) (y + 1) 1 2 (lifeMat ud)) + | y == 1 = + (submatrix 60 60 (x - 1) (x + 1) (lifeMat ud)) + <-> + (submatrix 1 2 (x - 1) (x + 1) (lifeMat ud)) + | x == 60 = + (submatrix (y - 1) (y + 1) 59 60 (lifeMat ud)) + <|> + (submatrix (y - 1) (y + 1) 1 1 (lifeMat ud)) + | y == 60 = + (submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud)) + <-> + (submatrix 1 1 (x - 1) (x + 1) (lifeMat ud)) + | otherwise = + (submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud)) + life = countLife subm + ret + | life == 0 && lifeMat ud 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 + ) + | 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) + 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 + ) + ) [0..3599] + let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList) + newFoodMat = fromList 60 60 (map (\(_, x, _) -> x) newList) + 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 + } + +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 + 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) + -- logIO A.Debug $ show mult + beginPath ctx + rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10 + if mult == 1 + 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) + fill ctx + ) [0..3599] + restore (nano ud) + endFrame (nano ud) + +clean _ = return () diff --git a/examples/example02/Types.hs b/examples/example02/Types.hs new file mode 100644 index 0000000..217edfa --- /dev/null +++ b/examples/example02/Types.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Types where + +import Affection + +import Data.Matrix as M + +import NanoVG + +import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) + +data UserData = UserData + { lifeMat :: Matrix Word + , foodMat :: Matrix Word + , timeMat :: Matrix Word + , subsystems :: Subsystems + , nano :: Context + } + +data Subsystems = Subsystems + { subWindow :: Types.Window + , subKeyboard :: Types.Keyboard + } + +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) + +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) + +instance Participant Types.Window UserData where + type Mesg Types.Window UserData = WindowMessage + + partSubscribers (Window t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Window t) = generalSubscribe t + + partUnSubscribe (Window t) = generalUnSubscribe t + +instance SDLSubsystem Types.Window UserData where + consumeSDLEvents = consumeSDLWindowEvents + +instance Participant Keyboard UserData where + type Mesg Keyboard UserData = KeyboardMessage + + partSubscribers (Keyboard t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Keyboard t) = generalSubscribe t + + partUnSubscribe (Keyboard t) = generalUnSubscribe t + +instance SDLSubsystem Keyboard UserData where + consumeSDLEvents = consumeSDLKeyboardEvents + +generalSubscribe + :: TVar [(UUID, msg -> Affection UserData ())] + -> (msg -> Affection UserData ()) + -> Affection UserData UUID +generalSubscribe t funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + +generalUnSubscribe + :: TVar [(UUID, msg -> Affection UserData ())] + -> UUID + -> Affection UserData () +generalUnSubscribe t uuid = + liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) + where + filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool + filterMsg (u, _) p = u /= p