adjust to new affection

This commit is contained in:
nek0 2017-12-27 18:44:22 +01:00
parent ac86e5bbfd
commit ab6b274b06
3 changed files with 22 additions and 17 deletions

View file

@ -67,7 +67,7 @@ executable haskelloids
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: base >=4.9 && <4.11 build-depends: base >=4.9 && <4.11
, affection <= 0.0.0.7 , affection <= 0.0.0.8
, sdl2 >= 2.1.3.1 , sdl2 >= 2.1.3.1
, OpenGL , OpenGL

View file

@ -129,16 +129,16 @@ updateGame sec = do
|| any (checkFriendlyFire (ship ud2)) (shots ud2) || any (checkFriendlyFire (ship ud2)) (shots ud2)
) )
&& isNothing (wonlost ud2) && isNothing (wonlost ud2)
) ) $ do
(putAffection ud2 liftIO $ logIO A.Debug "You Lost!"
{ wonlost = Just Lost putAffection ud2
} { wonlost = Just Lost
) }
when (isNothing (wonlost ud2) && null (haskelloids ud2)) when (isNothing (wonlost ud2) && null (haskelloids ud2)) $ do
(putAffection ud2 liftIO $ logIO A.Debug "You Won!"
putAffection ud2
{ wonlost = Just Won { wonlost = Just Won
} }
)
checkShotDown :: Affection UserData () checkShotDown :: Affection UserData ()
checkShotDown = checkShotDown =

View file

@ -1,4 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types where module Types where
@ -66,13 +67,15 @@ data Subsystems = Subsystems
} }
data UUIDClean = UUIDClean data UUIDClean = UUIDClean
{ uuWindow :: [MsgId WindowMessage] { uuWindow :: [UUID]
, uuKeyboard :: [MsgId KeyboardMessage] , uuKeyboard :: [UUID]
} }
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
instance Participant Window WindowMessage UserData where instance Participant Window UserData where
type Mesg Window UserData = WindowMessage
partSubscribers (Window t) = do partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
return $ map snd subTups return $ map snd subTups
@ -80,9 +83,9 @@ instance Participant Window WindowMessage UserData where
partSubscribe (Window t) funct = do partSubscribe (Window t) funct = do
uuid <- genUUID uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return $ MsgId uuid MsgWindowEmptyEvent return uuid
partUnSubscribe (Window t) (MsgId uuid _) = partUnSubscribe (Window t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where where
filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool
@ -93,7 +96,9 @@ instance SDLSubsystem Window UserData where
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
instance Participant Keyboard KeyboardMessage UserData where instance Participant Keyboard UserData where
type Mesg Keyboard UserData = KeyboardMessage
partSubscribers (Keyboard t) = do partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
return $ map snd subTups return $ map snd subTups
@ -101,9 +106,9 @@ instance Participant Keyboard KeyboardMessage UserData where
partSubscribe (Keyboard t) funct = do partSubscribe (Keyboard t) funct = do
uuid <- genUUID uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return $ MsgId uuid MsgKeyboardEmptyEvent return uuid
partUnSubscribe (Keyboard t) (MsgId uuid _) = partUnSubscribe (Keyboard t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where where
filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool