From 8a5370c857ba30aa4bfad629b0202a5f656552b1 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 28 Dec 2017 16:56:49 +0100 Subject: [PATCH] new examples --- examples/example00/Main.hs | 145 ++++++++++++++++++++++++++ examples/example01/Main.hs | 201 ++++++++++++++++++++++++++++++++++++ examples/example01/Types.hs | 75 ++++++++++++++ 3 files changed, 421 insertions(+) create mode 100644 examples/example00/Main.hs create mode 100644 examples/example01/Main.hs create mode 100644 examples/example01/Types.hs diff --git a/examples/example00/Main.hs b/examples/example00/Main.hs new file mode 100644 index 0000000..c9090b8 --- /dev/null +++ b/examples/example00/Main.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +import Affection +import qualified SDL + +import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) + +newtype StateData = StateData + { sdSubs :: Subsystems + } + +data Subsystems = Subsystems + { subWindow :: Window + , subMouse :: Mouse + , subKeyboard :: Keyboard + } + +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) +newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) + +generalSubscribe + :: TVar [(UUID, msg -> Affection StateData ())] + -> (msg -> Affection StateData()) + -> Affection StateData UUID +generalSubscribe t funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + +instance Participant Window StateData where + type Mesg Window StateData = WindowMessage + + partSubscribers (Window t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Window t) = generalSubscribe t + + partUnSubscribe (Window t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Window StateData where + consumeSDLEvents = consumeSDLWindowEvents + +instance Participant Mouse StateData where + type Mesg Mouse StateData = MouseMessage + + partSubscribers (Mouse t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Mouse t) = generalSubscribe t + + partUnSubscribe (Mouse t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Mouse StateData where + consumeSDLEvents = consumeSDLMouseEvents + +instance Participant Keyboard StateData where + type Mesg Keyboard StateData = KeyboardMessage + + partSubscribers (Keyboard t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Keyboard t) = generalSubscribe t + + partUnSubscribe (Keyboard t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Keyboard StateData where + consumeSDLEvents = consumeSDLKeyboardEvents + +main :: IO () +main = do + logIO Debug "Starting" + let conf = AffectionConfig + { initComponents = All + , windowTitle = "affection: example00" + , windowConfig = SDL.defaultWindow + { SDL.windowOpenGL = Just SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + } + , initScreenMode = SDL.Windowed + , canvasSize = Nothing + , loadState = load + , preLoop = pre + , eventLoop = handle + , updateLoop = update + , drawLoop = draw + , cleanUp = clean + } + withAffection conf + +load :: IO StateData +load = do + empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())]) + empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())]) + empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())]) + return $ StateData $ Subsystems + (Window empty1) + (Mouse empty2) + (Keyboard empty3) + +pre :: Affection StateData () +pre = do + sd <- getAffection + _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ + _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose + return () + +exitOnQ :: KeyboardMessage -> Affection StateData () +exitOnQ (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeQ -> do + liftIO $ logIO Debug "Yo dog I heard..." + quit + _ -> return () + +exitOnWindowClose :: WindowMessage -> Affection StateData () +exitOnWindowClose wm = + case wm of + MsgWindowClose _ _ -> do + liftIO $ logIO Debug "I heard another one..." + quit + _ -> return () + +handle :: [SDL.EventPayload] -> Affection StateData () +handle es = do + (Subsystems a b c) <- sdSubs <$> getAffection + _ <- consumeSDLEvents a es + _ <- consumeSDLEvents b es + _ <- consumeSDLEvents c es + return () + +update _ = return () + +draw = return () + +clean _ = return () diff --git a/examples/example01/Main.hs b/examples/example01/Main.hs new file mode 100644 index 0000000..28a1ec7 --- /dev/null +++ b/examples/example01/Main.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +import Affection as A +import qualified SDL + +import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) +import Control.Monad (when) + +import Data.Matrix as M +import qualified Data.Set as S + +import System.Random (randomRIO) + +import NanoVG + +import Foreign.C.Types (CInt(..)) + +-- internal imports + +import Types + +foreign import ccall unsafe "glewInit" + glewInit :: IO CInt + +main :: IO () +main = do + logIO A.Debug "Starting" + let conf = AffectionConfig + { initComponents = All + , windowTitle = "affection: example00" + , windowConfig = SDL.defaultWindow + { SDL.windowOpenGL = Just SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + , SDL.windowInitialSize = SDL.V2 600 600 + } + , 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 + , nano = nanoCtx + } + +pre :: Affection UserData () +pre = do + sd <- getAffection + _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc + _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR + _ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose + return () + +exitOnEsc :: KeyboardMessage -> Affection UserData () +exitOnEsc (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeEscape -> do + liftIO $ logIO A.Debug "Yo dog I heard..." + quit + _ -> return () + +reloadOnR :: KeyboardMessage -> Affection UserData () +reloadOnR (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeR -> do + ud <- getAffection + randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599] + let fullMatrix = fromList 60 60 randList + nState <- liftIO $ load + putAffection ud + { lifeMat = fullMatrix + } + _ -> return () + +exitOnWindowClose :: WindowMessage -> Affection UserData () +exitOnWindowClose wm = + case wm of + MsgWindowClose _ _ -> do + liftIO $ logIO A.Debug "I heard another one..." + quit + _ -> 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 + -- when (lastUpdate ud < floor now) $ do + liftIO $ logIO A.Debug "stepping life" + newList <- mapM (\coord -> do + let x = (coord `div` 60) + 1 + y = (coord `mod` 60) + 1 + subm + | x == 1 && y == 1 = + (submatrix 60 60 60 60 (lifeMat ud) <-> submatrix 1 2 60 60 (lifeMat ud)) + <|> + (submatrix 60 60 1 2 (lifeMat ud) <-> submatrix 1 2 1 2 (lifeMat ud)) + | x == 1 && y == 60 = + (submatrix 60 60 59 60 (lifeMat ud) <-> submatrix 1 2 59 60 (lifeMat ud)) + <|> + (submatrix 60 60 1 1 (lifeMat ud) <-> submatrix 1 2 1 1 (lifeMat ud)) + | x == 60 && y == 1 = + (submatrix 59 60 60 60 (lifeMat ud) <-> submatrix 1 1 60 60 (lifeMat ud)) + <|> + (submatrix 59 60 1 2 (lifeMat ud) <-> submatrix 1 1 1 2 (lifeMat ud)) + | x == 60 && y == 60 = + (submatrix 59 60 59 60 (lifeMat ud) <-> submatrix 1 1 59 60 (lifeMat ud)) + <|> + (submatrix 59 60 1 1 (lifeMat ud) <-> submatrix 1 1 1 1 (lifeMat ud)) + | x == 1 = + (submatrix 60 60 (y - 1) (y + 1) (lifeMat ud)) + <-> + (submatrix 1 2 (y - 1) (y + 1) (lifeMat ud)) + | y == 1 = + (submatrix (x - 1) (x + 1) 60 60 (lifeMat ud)) + <|> + (submatrix (x - 1) (x + 1) 1 2 (lifeMat ud)) + | x == 60 = + (submatrix 1 1 (y - 1) (y + 1) (lifeMat ud)) + <-> + (submatrix 59 60 (y - 1) (y + 1) (lifeMat ud)) + | y == 60 = + (submatrix (x - 1) (x + 1) 1 1 (lifeMat ud)) + <|> + (submatrix (x -1 ) (x + 1) 59 60 (lifeMat ud)) + | otherwise = + submatrix (x - 1) (x + 1) (y - 1) (y + 1) (lifeMat ud) + life = countLife subm + if (lifeMat ud) M.! (x, y) == 1 + then if life == 2 || life == 3 + then return 1 + else return 0 + else if life == 3 + then return 1 + else return 0 + ) [0..3599] + let newM = fromList 60 60 newList + putAffection ud + { lifeMat = newM + } + +countLife :: Matrix Word -> Word +countLife mat = res - (mat M.! (2, 2)) + where + res = foldr (\a acc -> a + acc) 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 `div` 60 + y = coord `mod` 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 do + fillColor ctx (rgba 255 255 255 255) + else do + fillColor ctx (rgba 0 0 0 255) + fill ctx + ) [0..3599] + restore (nano ud) + endFrame (nano ud) + +clean _ = return () diff --git a/examples/example01/Types.hs b/examples/example01/Types.hs new file mode 100644 index 0000000..615651e --- /dev/null +++ b/examples/example01/Types.hs @@ -0,0 +1,75 @@ +{-# 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 + , subsystems :: Subsystems + , nano :: Context + } + +data Subsystems = Subsystems + { subWindow :: Window + , subKeyboard :: Keyboard + } + +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) + +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) + +instance Participant Window UserData where + type Mesg 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 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