make example00 affectionate and working!

This commit is contained in:
nek0 2020-05-04 06:23:22 +02:00
parent c8d3ad6c56
commit 7df3bb8cf6
2 changed files with 80 additions and 80 deletions

View file

@ -6,8 +6,9 @@ module Main where
import Affection as A import Affection as A
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.MVar
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad (when) import Control.Monad
import qualified SDL hiding (Window(..)) import qualified SDL hiding (Window(..))
@ -16,9 +17,19 @@ import Data.String
data StateData = StateData data StateData = StateData
{ sdSubs :: Subsystems { sdSubs :: Subsystems
, sdJoys :: [SDL.Joystick] , sdJoys :: MVar [SDL.Joystick]
, doNextStep :: MVar Bool
} }
instance Affectionate StateData where
loadState = load
preLoop = pre
handleEvents = handle
update = Main.update
draw = Main.draw
cleanUp = clean
hasNextStep = liftIO . readMVar . doNextStep
data Subsystems = Subsystems data Subsystems = Subsystems
{ subWindow :: Main.Window { subWindow :: Main.Window
, subMouse :: Main.Mouse , subMouse :: Main.Mouse
@ -26,36 +37,13 @@ data Subsystems = Subsystems
, subJoystick :: Main.Joystick , subJoystick :: Main.Joystick
} }
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection StateData ())]) newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection ())])
generalSubscribers instance Participant Main.Window where
:: TVar [(UUID, msg -> Affection StateData ())] type Mesg Main.Window = WindowMessage
-> Affection StateData [msg -> Affection StateData ()]
generalSubscribers t = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
generalSubscribe
:: TVar [(UUID, msg -> Affection StateData ())]
-> (msg -> Affection StateData())
-> Affection StateData UUID
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection StateData ())]
-> UUID
-> Affection StateData ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance Participant Main.Window StateData where
type Mesg Main.Window StateData = WindowMessage
partSubscribers (Window t) = generalSubscribers t partSubscribers (Window t) = generalSubscribers t
@ -63,11 +51,11 @@ instance Participant Main.Window StateData where
partUnSubscribe (Window t) = generalUnSubscribe t partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Main.Window StateData where instance SDLSubsystem Main.Window where
consumeSDLEvents = consumeSDLWindowEvents consumeSDLEvents = consumeSDLWindowEvents
instance Participant Mouse StateData where instance Participant Mouse where
type Mesg Mouse StateData = MouseMessage type Mesg Mouse = MouseMessage
partSubscribers (Mouse t) = generalSubscribers t partSubscribers (Mouse t) = generalSubscribers t
@ -75,11 +63,11 @@ instance Participant Mouse StateData where
partUnSubscribe (Mouse t) = generalUnSubscribe t partUnSubscribe (Mouse t) = generalUnSubscribe t
instance SDLSubsystem Mouse StateData where instance SDLSubsystem Mouse where
consumeSDLEvents = consumeSDLMouseEvents consumeSDLEvents = consumeSDLMouseEvents
instance Participant Keyboard StateData where instance Participant Keyboard where
type Mesg Keyboard StateData = KeyboardMessage type Mesg Keyboard = KeyboardMessage
partSubscribers (Keyboard t) = generalSubscribers t partSubscribers (Keyboard t) = generalSubscribers t
@ -87,11 +75,11 @@ instance Participant Keyboard StateData where
partUnSubscribe (Keyboard t) = generalUnSubscribe t partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard StateData where instance SDLSubsystem Keyboard where
consumeSDLEvents = consumeSDLKeyboardEvents consumeSDLEvents = consumeSDLKeyboardEvents
instance Participant Joystick StateData where instance Participant Joystick where
type Mesg Joystick StateData = JoystickMessage type Mesg Joystick = JoystickMessage
partSubscribers (Joystick t) = generalSubscribers t partSubscribers (Joystick t) = generalSubscribers t
@ -99,7 +87,7 @@ instance Participant Joystick StateData where
partUnSubscribe (Joystick t) = generalUnSubscribe t partUnSubscribe (Joystick t) = generalUnSubscribe t
instance SDLSubsystem Joystick StateData where instance SDLSubsystem Joystick where
consumeSDLEvents = consumeSDLJoystickEvents consumeSDLEvents = consumeSDLJoystickEvents
main :: IO () main :: IO ()
@ -116,17 +104,10 @@ main = do
{ SDL.glProfile = SDL.Core SDL.Normal 3 3 { SDL.glProfile = SDL.Core SDL.Normal 3 3
} }
} }
, SDL.Windowed
) )
] ]
, initScreenMode = SDL.Windowed } :: AffectionConfig StateData
, canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
}
withAffection conf withAffection conf
load :: IO StateData load :: IO StateData
@ -137,49 +118,45 @@ load =
<*> (Keyboard <$> newTVarIO []) <*> (Keyboard <$> newTVarIO [])
<*> (Joystick <$> newTVarIO []) <*> (Joystick <$> newTVarIO [])
) )
<*> return [] <*> newMVar []
<*> newMVar True
pre :: Affection StateData () pre :: StateData -> Affection ()
pre = do pre sd = do
sd <- getAffection _ <- partSubscribe (subKeyboard $ sdSubs sd) (exitOnQ (doNextStep sd))
_ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ _ <- partSubscribe (subWindow $ sdSubs sd) (exitOnWindowClose (doNextStep sd))
_ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose _ <- partSubscribe (subJoystick $ sdSubs sd) (joyConnectDisconnect (sdJoys sd))
_ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect
return () return ()
exitOnQ :: KeyboardMessage -> Affection StateData () exitOnQ :: MVar Bool -> KeyboardMessage -> Affection ()
exitOnQ (MsgKeyboardEvent _ _ _ _ sym) = exitOnQ break (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeQ -> do SDL.KeycodeQ -> do
liftIO $ logIO Debug "Yo dog I heard..." liftIO $ logIO Debug "Yo dog I heard..."
quit void $ liftIO $ swapMVar break False
_ -> return () _ -> return ()
exitOnWindowClose :: WindowMessage -> Affection StateData () exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
exitOnWindowClose wm = exitOnWindowClose break wm =
case wm of case wm of
MsgWindowClose _ _ -> do MsgWindowClose _ _ -> do
liftIO $ logIO Debug "I heard another one..." liftIO $ logIO Debug "I heard another one..."
quit void $ liftIO $ swapMVar break False
_ -> return () _ -> return ()
joyConnectDisconnect :: JoystickMessage -> Affection StateData () joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection ()
joyConnectDisconnect msg = do joyConnectDisconnect mvjs msg = do
mj <- joystickAutoConnect msg mj <- joystickAutoConnect msg
when (isJust mj) $ do when (isJust mj) $ do
sd <- getAffection js <- liftIO $ readMVar mvjs
putAffection sd void $ liftIO $ swapMVar mvjs (fromJust mj : js)
{ sdJoys = fromJust mj : sdJoys sd js <- liftIO $ readMVar mvjs
} njs <- joystickAutoDisconnect js msg
sd <- getAffection liftIO $ putMVar mvjs njs
njs <- joystickAutoDisconnect (sdJoys sd) msg
putAffection sd
{ sdJoys = njs
}
handle :: [SDL.EventPayload] -> Affection StateData () handle :: StateData -> [SDL.EventPayload] -> Affection ()
handle es = do handle sd es = do
(Subsystems a b c d) <- sdSubs <$> getAffection let (Subsystems a b c d) = sdSubs sd
leftovers <- consumeSDLEvents a leftovers <- consumeSDLEvents a
=<< consumeSDLEvents b =<< consumeSDLEvents b
=<< consumeSDLEvents c =<< consumeSDLEvents c
@ -187,8 +164,31 @@ handle es = do
mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e)) mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e))
leftovers leftovers
update _ = return () update _ _ = return ()
draw = return () draw _ = return ()
clean _ = return () clean _ = return ()
generalSubscribers
:: TVar [(UUID, msg -> Affection ())]
-> Affection [msg -> Affection ()]
generalSubscribers t = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
generalSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection())
-> Affection UUID
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> UUID
-> Affection ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))

View file

@ -7,7 +7,7 @@ import Affection.Types
import qualified SDL import qualified SDL
-- | This class denotes a Subsystem to be part of SDL -- | This class denotes a Subsystem to be part of SDL
class SDLSubsystem s us where class SDLSubsystem s where
-- | Consume the given 'SDL.EventPayload's and return only those not -- | Consume the given 'SDL.EventPayload's and return only those not
-- recognised -- recognised
consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload] consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload]