{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Types.UserData where import Affection import Control.Concurrent.STM import qualified SDL import NanoVG hiding (V2(..), V3(..)) import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Ecstasy import Control.Concurrent.MVar import Types.StateData import Types.ImgId import Types.FontId import Types.Animation import Types.Entity data UserData = UserData { state :: State , subsystems :: Subsystems , assetIcons :: M.Map IconId Image , assetImages :: M.Map ImgId Image , assetFonts :: M.Map FontId T.Text , assetAnimations :: M.Map AnimId Animation , joystick :: Maybe SDL.Joystick , translation :: M.Map GamepadAction Action , nano :: Context , uuid :: [UUID] , worldState :: SystemState Entity (AffectionState (AffectionData UserData) IO) , stateData :: StateData , stateMVar :: MVar ( SystemState Entity (AffectionState (AffectionData UserData) IO) , StateData ) , stateProgress :: MVar (Float, T.Text) , threadContext :: Maybe SDL.GLContext , window :: Maybe SDL.Window , joyCache :: [JoystickMessage] , joyUUID :: UUID } data State = Load | Menu SubMenu | Main SubMain deriving (Eq, Show) data SubMain = WorldMap | MindMap deriving (Eq, Show) data SubMenu = Connect | Adjust Action deriving (Eq, Show) defaultTranslation :: M.Map GamepadAction Action defaultTranslation = M.fromList [ (ButtonAction 0 SDL.JoyButtonPressed, Activate) , (AxisAction 1, UpDown 1) , (AxisAction 0, LeftRight 1) ] data Action = Activate | UpDown Int | LeftRight Int deriving (Show, Eq) data GamepadAction = ButtonAction Word8 SDL.JoyButtonState | AxisAction Word8 -- | HatAction Word SDL.JoyHatPosition deriving (Show, Eq, Ord) data AxisAlign = AxisPositive | AxisNegative | AxisNeutral deriving (Show, Eq, Ord) data Subsystems = Subsystems { subWindow :: SubWindow , subMouse :: SubMouse , subkeyboard :: SubKeyboard , subJoypad :: SubJoypad , subTranslator :: SubTranslator } data ActionMessage = ActionMessage { amAction :: Action , amTime :: Double } deriving (Eq, Show) instance Message ActionMessage where msgTime (ActionMessage _ t) = t newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData())]) newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())]) newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) newtype SubJoypad = SubJoypad (TVar [(UUID, JoystickMessage -> Affection UserData ())]) newtype SubTranslator = SubTranslator (TVar [(UUID, ActionMessage -> Affection UserData ())]) instance Participant SubWindow UserData where type Mesg SubWindow UserData = WindowMessage partSubscribers (SubWindow t) = generalSubscribers t partSubscribe (SubWindow t) = generalSubscribe t partUnSubscribe (SubWindow t) = generalUnSubscribe t instance SDLSubsystem SubWindow UserData where consumeSDLEvents = consumeSDLWindowEvents instance Participant SubMouse UserData where type Mesg SubMouse UserData = MouseMessage partSubscribers (SubMouse t) = generalSubscribers t partSubscribe (SubMouse t) = generalSubscribe t partUnSubscribe (SubMouse t) = generalUnSubscribe t instance SDLSubsystem SubMouse UserData where consumeSDLEvents = consumeSDLMouseEvents instance Participant SubKeyboard UserData where type Mesg SubKeyboard UserData = KeyboardMessage partSubscribers (SubKeyboard t) = generalSubscribers t partSubscribe (SubKeyboard t) = generalSubscribe t partUnSubscribe (SubKeyboard t) = generalUnSubscribe t instance SDLSubsystem SubKeyboard UserData where consumeSDLEvents = consumeSDLKeyboardEvents instance Participant SubJoypad UserData where type Mesg SubJoypad UserData = JoystickMessage partSubscribers (SubJoypad t) = generalSubscribers t partSubscribe (SubJoypad t) = generalSubscribe t partUnSubscribe (SubJoypad t) = generalUnSubscribe t instance SDLSubsystem SubJoypad UserData where consumeSDLEvents = consumeSDLJoystickEvents instance Participant SubTranslator UserData where type Mesg SubTranslator UserData = ActionMessage partSubscribers (SubTranslator t) = generalSubscribers t partSubscribe (SubTranslator t) = generalSubscribe t partUnSubscribe (SubTranslator t) = generalUnSubscribe t generalSubscribers :: TVar [(UUID, msg -> Affection UserData ())] -> Affection UserData [(msg -> Affection UserData ())] generalSubscribers t = do subTups <- liftIO $ readTVarIO t return $ map snd subTups generalSubscribe :: TVar [(UUID, msg -> Affection UserData ())] -> (msg -> Affection UserData ()) -> Affection UserData UUID generalSubscribe t funct = do uu <- genUUID liftIO $ atomically $ modifyTVar' t ((uu, funct) :) return uu generalUnSubscribe :: TVar [(UUID, msg -> Affection UserData ())] -> UUID -> Affection UserData () generalUnSubscribe t uu = liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu)) where filterMsg (u, _) p = u /= p