make example00 affectionate and working!
This commit is contained in:
parent
c8d3ad6c56
commit
7df3bb8cf6
2 changed files with 80 additions and 80 deletions
|
|
@ -6,8 +6,9 @@ module Main where
|
|||
import Affection as A
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad (when)
|
||||
import Control.Monad
|
||||
|
||||
import qualified SDL hiding (Window(..))
|
||||
|
||||
|
|
@ -16,9 +17,19 @@ import Data.String
|
|||
|
||||
data StateData = StateData
|
||||
{ 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
|
||||
{ subWindow :: Main.Window
|
||||
, subMouse :: Main.Mouse
|
||||
|
|
@ -26,36 +37,13 @@ data Subsystems = Subsystems
|
|||
, subJoystick :: Main.Joystick
|
||||
}
|
||||
|
||||
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
|
||||
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
|
||||
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
|
||||
newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection StateData ())])
|
||||
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
|
||||
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection ())])
|
||||
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
|
||||
newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection ())])
|
||||
|
||||
generalSubscribers
|
||||
:: TVar [(UUID, msg -> Affection StateData ())]
|
||||
-> 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
|
||||
instance Participant Main.Window where
|
||||
type Mesg Main.Window = WindowMessage
|
||||
|
||||
partSubscribers (Window t) = generalSubscribers t
|
||||
|
||||
|
|
@ -63,11 +51,11 @@ instance Participant Main.Window StateData where
|
|||
|
||||
partUnSubscribe (Window t) = generalUnSubscribe t
|
||||
|
||||
instance SDLSubsystem Main.Window StateData where
|
||||
instance SDLSubsystem Main.Window where
|
||||
consumeSDLEvents = consumeSDLWindowEvents
|
||||
|
||||
instance Participant Mouse StateData where
|
||||
type Mesg Mouse StateData = MouseMessage
|
||||
instance Participant Mouse where
|
||||
type Mesg Mouse = MouseMessage
|
||||
|
||||
partSubscribers (Mouse t) = generalSubscribers t
|
||||
|
||||
|
|
@ -75,11 +63,11 @@ instance Participant Mouse StateData where
|
|||
|
||||
partUnSubscribe (Mouse t) = generalUnSubscribe t
|
||||
|
||||
instance SDLSubsystem Mouse StateData where
|
||||
instance SDLSubsystem Mouse where
|
||||
consumeSDLEvents = consumeSDLMouseEvents
|
||||
|
||||
instance Participant Keyboard StateData where
|
||||
type Mesg Keyboard StateData = KeyboardMessage
|
||||
instance Participant Keyboard where
|
||||
type Mesg Keyboard = KeyboardMessage
|
||||
|
||||
partSubscribers (Keyboard t) = generalSubscribers t
|
||||
|
||||
|
|
@ -87,11 +75,11 @@ instance Participant Keyboard StateData where
|
|||
|
||||
partUnSubscribe (Keyboard t) = generalUnSubscribe t
|
||||
|
||||
instance SDLSubsystem Keyboard StateData where
|
||||
instance SDLSubsystem Keyboard where
|
||||
consumeSDLEvents = consumeSDLKeyboardEvents
|
||||
|
||||
instance Participant Joystick StateData where
|
||||
type Mesg Joystick StateData = JoystickMessage
|
||||
instance Participant Joystick where
|
||||
type Mesg Joystick = JoystickMessage
|
||||
|
||||
partSubscribers (Joystick t) = generalSubscribers t
|
||||
|
||||
|
|
@ -99,7 +87,7 @@ instance Participant Joystick StateData where
|
|||
|
||||
partUnSubscribe (Joystick t) = generalUnSubscribe t
|
||||
|
||||
instance SDLSubsystem Joystick StateData where
|
||||
instance SDLSubsystem Joystick where
|
||||
consumeSDLEvents = consumeSDLJoystickEvents
|
||||
|
||||
main :: IO ()
|
||||
|
|
@ -116,17 +104,10 @@ main = do
|
|||
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
|
||||
}
|
||||
}
|
||||
, SDL.Windowed
|
||||
)
|
||||
]
|
||||
, initScreenMode = SDL.Windowed
|
||||
, canvasSize = Nothing
|
||||
, loadState = load
|
||||
, preLoop = pre
|
||||
, eventLoop = handle
|
||||
, updateLoop = update
|
||||
, drawLoop = draw
|
||||
, cleanUp = clean
|
||||
}
|
||||
} :: AffectionConfig StateData
|
||||
withAffection conf
|
||||
|
||||
load :: IO StateData
|
||||
|
|
@ -137,49 +118,45 @@ load =
|
|||
<*> (Keyboard <$> newTVarIO [])
|
||||
<*> (Joystick <$> newTVarIO [])
|
||||
)
|
||||
<*> return []
|
||||
<*> newMVar []
|
||||
<*> newMVar True
|
||||
|
||||
pre :: Affection StateData ()
|
||||
pre = do
|
||||
sd <- getAffection
|
||||
_ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
|
||||
_ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
|
||||
_ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect
|
||||
pre :: StateData -> Affection ()
|
||||
pre sd = do
|
||||
_ <- partSubscribe (subKeyboard $ sdSubs sd) (exitOnQ (doNextStep sd))
|
||||
_ <- partSubscribe (subWindow $ sdSubs sd) (exitOnWindowClose (doNextStep sd))
|
||||
_ <- partSubscribe (subJoystick $ sdSubs sd) (joyConnectDisconnect (sdJoys sd))
|
||||
return ()
|
||||
|
||||
exitOnQ :: KeyboardMessage -> Affection StateData ()
|
||||
exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
|
||||
exitOnQ :: MVar Bool -> KeyboardMessage -> Affection ()
|
||||
exitOnQ break (MsgKeyboardEvent _ _ _ _ sym) =
|
||||
case SDL.keysymKeycode sym of
|
||||
SDL.KeycodeQ -> do
|
||||
liftIO $ logIO Debug "Yo dog I heard..."
|
||||
quit
|
||||
void $ liftIO $ swapMVar break False
|
||||
_ -> return ()
|
||||
|
||||
exitOnWindowClose :: WindowMessage -> Affection StateData ()
|
||||
exitOnWindowClose wm =
|
||||
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
|
||||
exitOnWindowClose break wm =
|
||||
case wm of
|
||||
MsgWindowClose _ _ -> do
|
||||
liftIO $ logIO Debug "I heard another one..."
|
||||
quit
|
||||
void $ liftIO $ swapMVar break False
|
||||
_ -> return ()
|
||||
|
||||
joyConnectDisconnect :: JoystickMessage -> Affection StateData ()
|
||||
joyConnectDisconnect msg = do
|
||||
joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection ()
|
||||
joyConnectDisconnect mvjs msg = do
|
||||
mj <- joystickAutoConnect msg
|
||||
when (isJust mj) $ do
|
||||
sd <- getAffection
|
||||
putAffection sd
|
||||
{ sdJoys = fromJust mj : sdJoys sd
|
||||
}
|
||||
sd <- getAffection
|
||||
njs <- joystickAutoDisconnect (sdJoys sd) msg
|
||||
putAffection sd
|
||||
{ sdJoys = njs
|
||||
}
|
||||
js <- liftIO $ readMVar mvjs
|
||||
void $ liftIO $ swapMVar mvjs (fromJust mj : js)
|
||||
js <- liftIO $ readMVar mvjs
|
||||
njs <- joystickAutoDisconnect js msg
|
||||
liftIO $ putMVar mvjs njs
|
||||
|
||||
handle :: [SDL.EventPayload] -> Affection StateData ()
|
||||
handle es = do
|
||||
(Subsystems a b c d) <- sdSubs <$> getAffection
|
||||
handle :: StateData -> [SDL.EventPayload] -> Affection ()
|
||||
handle sd es = do
|
||||
let (Subsystems a b c d) = sdSubs sd
|
||||
leftovers <- consumeSDLEvents a
|
||||
=<< consumeSDLEvents b
|
||||
=<< consumeSDLEvents c
|
||||
|
|
@ -187,8 +164,31 @@ handle es = do
|
|||
mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e))
|
||||
leftovers
|
||||
|
||||
update _ = return ()
|
||||
update _ _ = return ()
|
||||
|
||||
draw = return ()
|
||||
draw _ = 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))
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ import Affection.Types
|
|||
import qualified 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
|
||||
-- recognised
|
||||
consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload]
|
||||
|
|
|
|||
Loading…
Reference in a new issue