add new example

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

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
       }
 

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

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