new examples

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 ()

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 ()

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