{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Types where import Affection import NanoVG hiding (V2(..)) import Control.Concurrent.STM import Control.Concurrent.MVar data UserData = UserData { ship :: MVar Ship , haskelloids :: MVar [Haskelloid] , shots :: MVar [Pew] , wonlost :: MVar (Maybe WonLost) , state :: MVar (State) , fade :: MVar (MenuFade) , nano :: Context , font :: Font , subsystems :: Subsystems , haskImage :: Image , stateUUIDs :: MVar (UUIDClean) , doNextStep :: MVar Bool } data Ship = Ship { sPos :: V2 Float , sVel :: V2 Float , sThrust :: Bool , sRot :: Float , sImg :: Image } data Pew = Pew { pPos :: V2 Float , pVel :: V2 Float , pTTL :: Double } deriving (Eq) data Haskelloid = Haskelloid { hPos :: V2 Float , hVel :: V2 Float , hRot :: Float , hPitch :: Float , hDiv :: Int , hImg :: Image } deriving (Eq) data State = Menu -- | HighScore | InGame data MenuFade = FadeIn Double | FadeOut Double data WonLost = Won | Lost deriving (Eq) data Subsystems = Subsystems { subWindow :: SubWindow , subKeyboard :: SubKeyboard } data UUIDClean = UUIDClean { uuWindow :: [UUID] , uuKeyboard :: [UUID] } newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())]) instance Participant SubWindow where type Mesg SubWindow = WindowMessage partSubscribers (SubWindow t) = do subTups <- liftIO $ readTVarIO t return $ map snd subTups partSubscribe (SubWindow t) funct = do uuid <- genUUID liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) return uuid partUnSubscribe (SubWindow t) uuid = liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) where filterMsg :: (UUID, WindowMessage -> Affection ()) -> UUID -> Bool filterMsg (u, _) p = u /= p instance SDLSubsystem SubWindow where consumeSDLEvents = consumeSDLWindowEvents newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) instance Participant SubKeyboard where type Mesg SubKeyboard = KeyboardMessage partSubscribers (SubKeyboard t) = do subTups <- liftIO $ readTVarIO t return $ map snd subTups partSubscribe (SubKeyboard t) funct = do uuid <- genUUID liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) return uuid partUnSubscribe (SubKeyboard t) uuid = liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) where filterMsg :: (UUID, KeyboardMessage -> Affection ()) -> UUID -> Bool filterMsg (u, _) p = u /= p instance SDLSubsystem SubKeyboard where consumeSDLEvents = consumeSDLKeyboardEvents