77 lines
2 KiB
Haskell
77 lines
2 KiB
Haskell
{-# 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
|