From f5353c5de2300c48757cd416788def4894d56c44 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 21 Sep 2020 04:26:45 +0200 Subject: [PATCH] start laying out types --- src/Types/Application.hs | 58 ++++++++++++++++++++++++++ src/Types/Subsystems.hs | 89 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 147 insertions(+) create mode 100644 src/Types/Application.hs create mode 100644 src/Types/Subsystems.hs diff --git a/src/Types/Application.hs b/src/Types/Application.hs new file mode 100644 index 0000000..8063223 --- /dev/null +++ b/src/Types/Application.hs @@ -0,0 +1,58 @@ +module Types.Application where + +import Affection + +import qualified SDL + +import Control.Concurrent.STM.TMVar + +import qualified Data.Map.Strict as M + +-- internal imports + +import Types.Subsystems + +data GameData = GameData + { gameState :: TVar State + , gameCurrentLevel :: Tvar Level + , gameSubsystems :: Subsystems + , gameActionTranslation :: TVar ActionTranslation + , gameEnded :: TVar Bool + } + +data State + = Running + | Paused + deriving (Enum, Eq, Show) + +data Level + = MainMenu + | DNAMenu + | Sewer01 + | Sewer02 + | Sewer03 + | Sewer04 + | Alley01 + | Alley02 + | Alley03 + | Alley04 + | Lab01 + | Lab02 + | Lab03 + | Lab04 + | Highway01 + | Highway02 + | Highway03 + | Highway04 + | Complex01 + | Complex02 + | Complex03 + | Complex04 + | Base01 + | Base01 + | Base01 + | Base01 + | Test + deriving (Enum, Eq, Show) + +type ActionTranslation = M.Map SDL.Keycode Action diff --git a/src/Types/Subsystems.hs b/src/Types/Subsystems.hs new file mode 100644 index 0000000..e285c11 --- /dev/null +++ b/src/Types/Subsystems.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MutliParamTypeClasses #-} +module Types.Subsystems where + +import Affection + +import Control.Concurrent.STM.TVar + +data Subsystems = Subsystems + { subWindow :: SubWindow + , subMouse :: SubMouse + , subKeyboard :: SubKeyboard + , subTranslator :: SubTranslator + } + +newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())]) +newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())]) +newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) +newtype SubTranslator = SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())]) + +instance Participant SubWindow where + type Mesg SubWindow = WindowMessage + + partSubscribers (SubWindow t) = generalSubscribers t + + partSubscribe (SubWindow t) = generalSubscribe t + + partUnSubscribe (SubWindow t) = generalUnSubscribe t + +instance SDLSubsystem SubWindow where + consumeSDLEvents = consumeSDLWindowEvents + +instance Participant SubMouse where + type Mesg SubMouse = MouseMessage + + partSubscribers (SubMouse t) = generalSubscribers t + + partSubscribe (SubMouse t) = generalSubscribe t + + partUnSubscribe (SubMouse t) = generalUnSubscribe t + +instance SDLSubsystem SubMouse where + consumeSDLEvents = consumeSDLMouseEvents + +instance Participant SubKeyboard where + type Mesg SubKeyboard = KeyboardMessage + + partSubscribers (SubKeyboard t) = generalSubscribers t + + partSubscribe (SubKeyboard t) = generalSubscribe t + + partUnSubscribe (SubKeyboard t) = generalUnSubscribe t + +instance SDLSubsystem SubKeyboard where + consumeSDLEvents = consumeSDLKeyboardEvents + +instance Participant SubTranslator where + type Mesg SubTranslator = TranslatorMessage + + partSubscribers (SubTranslator t) = generalSubscribers t + + partSubscribe (SubTranslator t) = generalSubscribe t + + partUnSubscribe (SubTranslator t) = generalUnSubscribe t + +generalSubscribers + :: TVar [(UUID, msg -> Affection ())] + -> Affection [(msg -> Affection ())] +generalSubscribers t = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + +generalSubscribe + :: TVar [(UUID, msg -> Affection ())] + -> (msg -> Affection ()) + -> Affection UUID +generalSubscribe t funct = do + uu <- genUUID + liftIO $ atomically $ modifyTVar' t ((uu, funct) :) + return uu + +generalUnSubscribe + :: TVar [(UUID, msg -> Affection ())] + -> UUID + -> Affection () +generalUnSubscribe t uu = + liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu)) + where + filterMsg (u, _) p = u /= p