affection/examples/example02/Types.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

module Types where

import Affection

import Data.Matrix as M

import NanoVG

import Control.Concurrent.STM
import Control.Concurrent.MVar

data UserData = UserData
  { lifeMat    :: MVar (Matrix Word)
  , foodMat    :: MVar (Matrix Word)
  , timeMat    :: MVar (Matrix Word)
  , subsystems :: Subsystems
  , nano       :: Context
  , doNextStep :: MVar Bool
  }

data Subsystems = Subsystems
  { subWindow   :: Types.Window
  , subKeyboard :: Types.Keyboard
  }

newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])

newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])

instance Participant Types.Window where
  type Mesg Types.Window = 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 where
  consumeSDLEvents = consumeSDLWindowEvents

instance Participant Keyboard where
  type Mesg Keyboard = 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 where
  consumeSDLEvents = consumeSDLKeyboardEvents

generalSubscribe
  :: 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 ())]
  -> UUID
  -> Affection ()
generalUnSubscribe t uuid =
  liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
  where
    filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
    filterMsg (u, _) p = u /= p