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.
build-depends: base >=4.9 && <4.11
, affection <= 0.0.0.7
, affection <= 0.0.0.8
, sdl2 >= 2.1.3.1
, OpenGL

View file

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

View file

@ -1,4 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types where
@ -66,13 +67,15 @@ data Subsystems = Subsystems
}
data UUIDClean = UUIDClean
{ uuWindow :: [MsgId WindowMessage]
, uuKeyboard :: [MsgId KeyboardMessage]
{ uuWindow :: [UUID]
, uuKeyboard :: [UUID]
}
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
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
@ -80,9 +83,9 @@ instance Participant Window WindowMessage UserData where
partSubscribe (Window t) funct = do
uuid <- genUUID
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))
where
filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool
@ -93,7 +96,9 @@ instance SDLSubsystem Window UserData where
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
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
@ -101,9 +106,9 @@ instance Participant Keyboard KeyboardMessage UserData where
partSubscribe (Keyboard t) funct = do
uuid <- genUUID
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))
where
filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool