haskelloids/src/Types.hs

119 lines
2.7 KiB
Haskell
Raw Permalink Normal View History

2017-01-02 15:22:23 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
2017-12-27 17:44:22 +00:00
{-# LANGUAGE TypeFamilies #-}
2017-01-02 15:22:23 +00:00
2016-12-31 16:01:24 +00:00
module Types where
2017-12-16 10:55:30 +00:00
import Affection
2017-12-16 18:06:36 +00:00
import NanoVG hiding (V2(..))
2016-12-31 16:01:24 +00:00
2017-12-19 05:49:41 +00:00
import Control.Concurrent.STM
2020-05-04 19:17:06 +00:00
import Control.Concurrent.MVar
2017-12-19 05:49:41 +00:00
2016-12-31 16:01:24 +00:00
data UserData = UserData
2020-05-04 19:17:06 +00:00
{ 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
2016-12-31 16:01:24 +00:00
}
data Ship = Ship
2017-12-19 07:18:57 +00:00
{ sPos :: V2 Float
, sVel :: V2 Float
2018-01-10 03:28:26 +00:00
, sThrust :: Bool
2017-12-19 07:18:57 +00:00
, sRot :: Float
2017-12-16 10:55:30 +00:00
, sImg :: Image
2016-12-31 16:01:24 +00:00
}
2017-12-20 23:56:16 +00:00
data Pew = Pew
{ pPos :: V2 Float
, pVel :: V2 Float
, pTTL :: Double
2017-12-21 04:21:20 +00:00
} deriving (Eq)
2017-12-20 23:56:16 +00:00
2016-12-31 16:01:24 +00:00
data Haskelloid = Haskelloid
2017-12-19 07:18:57 +00:00
{ hPos :: V2 Float
, hVel :: V2 Float
, hRot :: Float
, hPitch :: Float
2016-12-31 16:01:24 +00:00
, hDiv :: Int
2017-12-16 10:55:30 +00:00
, hImg :: Image
2016-12-31 16:01:24 +00:00
} deriving (Eq)
2017-01-02 15:22:23 +00:00
data State
2016-12-31 16:01:24 +00:00
= Menu
2017-12-20 23:56:16 +00:00
-- | HighScore
2016-12-31 16:01:24 +00:00
| InGame
2017-01-01 21:58:54 +00:00
data MenuFade
= FadeIn Double
| FadeOut Double
2017-12-16 10:55:30 +00:00
data WonLost
= Won
| Lost
deriving (Eq)
2017-12-19 05:49:41 +00:00
data Subsystems = Subsystems
2018-12-27 12:49:12 +00:00
{ subWindow :: SubWindow
, subKeyboard :: SubKeyboard
2017-12-19 05:49:41 +00:00
}
2017-12-20 01:00:28 +00:00
data UUIDClean = UUIDClean
2017-12-27 17:44:22 +00:00
{ uuWindow :: [UUID]
, uuKeyboard :: [UUID]
2017-12-20 01:00:28 +00:00
}
2020-05-04 19:17:06 +00:00
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
2017-12-19 05:49:41 +00:00
2020-05-04 19:17:06 +00:00
instance Participant SubWindow where
type Mesg SubWindow = WindowMessage
2017-12-27 17:44:22 +00:00
2018-12-27 12:49:12 +00:00
partSubscribers (SubWindow t) = do
2017-12-19 05:49:41 +00:00
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
2018-12-27 12:49:12 +00:00
partSubscribe (SubWindow t) funct = do
2017-12-20 01:00:28 +00:00
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
2017-12-27 17:44:22 +00:00
return uuid
2017-12-19 05:49:41 +00:00
2018-12-27 12:49:12 +00:00
partUnSubscribe (SubWindow t) uuid =
2017-12-21 13:43:13 +00:00
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
2017-12-20 01:00:28 +00:00
where
2020-05-04 19:17:06 +00:00
filterMsg :: (UUID, WindowMessage -> Affection ()) -> UUID -> Bool
2017-12-20 01:00:28 +00:00
filterMsg (u, _) p = u /= p
2017-12-19 05:49:41 +00:00
2020-05-04 19:17:06 +00:00
instance SDLSubsystem SubWindow where
2017-12-19 05:49:41 +00:00
consumeSDLEvents = consumeSDLWindowEvents
2020-05-04 19:17:06 +00:00
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
2017-12-19 05:49:41 +00:00
2020-05-04 19:17:06 +00:00
instance Participant SubKeyboard where
type Mesg SubKeyboard = KeyboardMessage
2017-12-27 17:44:22 +00:00
2018-12-27 12:49:12 +00:00
partSubscribers (SubKeyboard t) = do
2017-12-19 05:49:41 +00:00
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
2018-12-27 12:49:12 +00:00
partSubscribe (SubKeyboard t) funct = do
2017-12-20 01:00:28 +00:00
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
2017-12-27 17:44:22 +00:00
return uuid
2017-12-19 05:49:41 +00:00
2018-12-27 12:49:12 +00:00
partUnSubscribe (SubKeyboard t) uuid =
2017-12-21 13:43:13 +00:00
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
2017-12-20 01:00:28 +00:00
where
2020-05-04 19:17:06 +00:00
filterMsg :: (UUID, KeyboardMessage -> Affection ()) -> UUID -> Bool
2017-12-20 01:00:28 +00:00
filterMsg (u, _) p = u /= p
2017-12-19 05:49:41 +00:00
2020-05-04 19:17:06 +00:00
instance SDLSubsystem SubKeyboard where
2017-12-19 05:49:41 +00:00
consumeSDLEvents = consumeSDLKeyboardEvents