haskelloids/src/Types.hs

119 lines
2.7 KiB
Haskell

{-# 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