pituicat/examples/example00/Main.hs

195 lines
5.2 KiB
Haskell
Raw Normal View History

2017-12-28 15:56:49 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
2019-04-29 16:38:52 +00:00
module Main where
2018-09-25 14:10:36 +00:00
import Affection as A
2017-12-28 15:56:49 +00:00
import Control.Concurrent.STM
import Control.Concurrent.MVar
2017-12-28 15:56:49 +00:00
import Control.Monad.IO.Class (liftIO)
import Control.Monad
2017-12-28 15:56:49 +00:00
2018-09-25 14:10:36 +00:00
import qualified SDL hiding (Window(..))
2018-01-09 17:40:54 +00:00
import Data.Maybe (isJust, fromJust)
2019-10-28 16:10:56 +00:00
import Data.String
2018-01-09 17:40:54 +00:00
data StateData = StateData
2017-12-28 15:56:49 +00:00
{ sdSubs :: Subsystems
, sdJoys :: MVar [SDL.Joystick]
, doNextStep :: MVar Bool
2017-12-28 15:56:49 +00:00
}
instance Affectionate StateData where
loadState = load
preLoop = pre
handleEvents = handle
update = Main.update
draw = Main.draw
cleanUp = clean
hasNextStep = liftIO . readMVar . doNextStep
2017-12-28 15:56:49 +00:00
data Subsystems = Subsystems
2018-09-25 14:10:36 +00:00
{ subWindow :: Main.Window
, subMouse :: Main.Mouse
, subKeyboard :: Main.Keyboard
, subJoystick :: Main.Joystick
2017-12-28 15:56:49 +00:00
}
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 ())])
2018-01-09 17:40:54 +00:00
instance Participant Main.Window where
type Mesg Main.Window = WindowMessage
2017-12-28 15:56:49 +00:00
2018-01-09 17:40:54 +00:00
partSubscribers (Window t) = generalSubscribers t
2017-12-28 15:56:49 +00:00
partSubscribe (Window t) = generalSubscribe t
2018-01-09 17:40:54 +00:00
partUnSubscribe (Window t) = generalUnSubscribe t
2017-12-28 15:56:49 +00:00
instance SDLSubsystem Main.Window where
2017-12-28 15:56:49 +00:00
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Mouse where
type Mesg Mouse = MouseMessage
2017-12-28 15:56:49 +00:00
2018-01-09 17:40:54 +00:00
partSubscribers (Mouse t) = generalSubscribers t
2017-12-28 15:56:49 +00:00
partSubscribe (Mouse t) = generalSubscribe t
2018-01-09 17:40:54 +00:00
partUnSubscribe (Mouse t) = generalUnSubscribe t
2017-12-28 15:56:49 +00:00
instance SDLSubsystem Mouse where
2017-12-28 15:56:49 +00:00
consumeSDLEvents = consumeSDLMouseEvents
instance Participant Keyboard where
type Mesg Keyboard = KeyboardMessage
2017-12-28 15:56:49 +00:00
2018-01-09 17:40:54 +00:00
partSubscribers (Keyboard t) = generalSubscribers t
2017-12-28 15:56:49 +00:00
partSubscribe (Keyboard t) = generalSubscribe t
2018-01-09 17:40:54 +00:00
partUnSubscribe (Keyboard t) = generalUnSubscribe t
2017-12-28 15:56:49 +00:00
instance SDLSubsystem Keyboard where
2017-12-28 15:56:49 +00:00
consumeSDLEvents = consumeSDLKeyboardEvents
instance Participant Joystick where
type Mesg Joystick = JoystickMessage
2018-01-09 17:40:54 +00:00
partSubscribers (Joystick t) = generalSubscribers t
partSubscribe (Joystick t) = generalSubscribe t
partUnSubscribe (Joystick t) = generalUnSubscribe t
instance SDLSubsystem Joystick where
2018-01-09 17:40:54 +00:00
consumeSDLEvents = consumeSDLJoystickEvents
2017-12-28 15:56:49 +00:00
main :: IO ()
main = do
logIO Debug "Starting"
let conf = AffectionConfig
{ initComponents = All
, windowTitle = "affection: example00"
2019-01-30 11:00:28 +00:00
, windowConfigs =
[
( 0
, SDL.defaultWindow
2019-10-28 16:10:56 +00:00
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
2019-01-30 11:00:28 +00:00
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
2017-12-28 15:56:49 +00:00
}
, SDL.Windowed
2019-01-30 11:00:28 +00:00
)
]
} :: AffectionConfig StateData
2017-12-28 15:56:49 +00:00
withAffection conf
load :: IO StateData
2018-01-09 17:40:54 +00:00
load =
StateData <$> (Subsystems
<$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO [])
<*> (Keyboard <$> newTVarIO [])
<*> (Joystick <$> newTVarIO [])
)
<*> newMVar []
<*> newMVar True
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))
2017-12-28 15:56:49 +00:00
return ()
exitOnQ :: MVar Bool -> KeyboardMessage -> Affection ()
exitOnQ break (MsgKeyboardEvent _ _ _ _ sym) =
2017-12-28 15:56:49 +00:00
case SDL.keysymKeycode sym of
SDL.KeycodeQ -> do
liftIO $ logIO Debug "Yo dog I heard..."
void $ liftIO $ swapMVar break False
2017-12-28 15:56:49 +00:00
_ -> return ()
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
exitOnWindowClose break wm =
2017-12-28 15:56:49 +00:00
case wm of
MsgWindowClose _ _ -> do
liftIO $ logIO Debug "I heard another one..."
void $ liftIO $ swapMVar break False
2017-12-28 15:56:49 +00:00
_ -> return ()
joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection ()
joyConnectDisconnect mvjs msg = do
2018-01-09 17:40:54 +00:00
mj <- joystickAutoConnect msg
when (isJust mj) $ do
js <- liftIO $ readMVar mvjs
void $ liftIO $ swapMVar mvjs (fromJust mj : js)
js <- liftIO $ readMVar mvjs
njs <- joystickAutoDisconnect js msg
liftIO $ putMVar mvjs njs
handle :: StateData -> [SDL.EventPayload] -> Affection ()
handle sd es = do
let (Subsystems a b c d) = sdSubs sd
2018-01-09 17:40:54 +00:00
leftovers <- consumeSDLEvents a
=<< consumeSDLEvents b
=<< consumeSDLEvents c
=<< consumeSDLEvents d es
2019-10-28 16:10:56 +00:00
mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e))
leftovers
2017-12-28 15:56:49 +00:00
update _ _ = return ()
2017-12-28 15:56:49 +00:00
draw _ = return ()
2017-12-28 15:56:49 +00:00
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))