classy messup

This commit is contained in:
nek0 2017-11-27 23:30:11 +01:00
parent c4e3528885
commit 4ae117aa48
10 changed files with 84 additions and 61 deletions

View file

@ -44,6 +44,8 @@ library
, Affection.MessageBus.Util
, Affection.MessageBus.Class
, Affection.MessageBus.Message
, Affection.Subsystems.Class
, Affection.Subsystems.AffectionWindow
default-extensions: OverloadedStrings
-- Modules included in this library but not exported.

View file

@ -40,7 +40,7 @@ import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
-- | Main function which bootstraps everything else.
withAffection
:: AffectionConfig us -- ^ Configuration of the Game and its engine.
:: AffectionConfig us msg -- ^ Configuration of the Game and its engine.
-> IO ()
withAffection AffectionConfig{..} = do
-- intialiaze SDL

View file

@ -1,16 +1,14 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Affection.MessageBus.Class where
import Control.Concurrent.STM as STM
import Affection.MessageBus.Message
newtype (Message msg) => Channel msg = Channel (TChan msg)
import Affection.Types
class (Message msg) => Participant prt msg where
partChannel :: prt -> Channel msg
-- partConnectChannel :: prt -> Channel msg -> IO ()
partInit :: Affection sd msg prt
partListen :: prt -> IO (Maybe msg)

View file

@ -2,6 +2,7 @@ module Affection.MessageBus.Util where
import Affection.MessageBus.Class
import Affection.MessageBus.Message
import Affection.Types
import Control.Concurrent.STM as STM
-- | Build a new broadcast channel

View file

@ -17,7 +17,7 @@ class MouseClickable a us where
-> (Int, Int) -- The coordinates of the click
-> SDL.InputMotion -- The 'SDL.InputMotion' of the click
-> Int -- The number of clicks
-> Affection us ()
-> Affection us msg ()
-- | A helper function that checks wether provided clickables have been clicked.
-- This function does not consume provided events, but passes them on.
@ -25,7 +25,7 @@ handleMouseClicks
:: (Foldable t, MouseClickable clickable us)
=> SDL.EventPayload -- ^ Piped event in
-> t clickable -- ^ 'MouseClickable' elemt to be checked
-> Affection us SDL.EventPayload -- ^ Unaltered event
-> Affection us msg SDL.EventPayload -- ^ Unaltered event
handleMouseClicks e clickables =
case e of
SDL.MouseButtonEvent dat -> do

View file

@ -7,8 +7,8 @@ import Affection.Types
import qualified SDL
class StateMachine a us where
smLoad :: a -> Affection us ()
smUpdate :: a -> Double -> Affection us ()
smEvent :: a -> SDL.EventPayload -> Affection us ()
smDraw :: a -> Affection us ()
smClean :: a -> Affection us ()
smLoad :: a -> Affection us msg ()
smUpdate :: a -> Double -> Affection us msg ()
smEvent :: a -> SDL.EventPayload -> Affection us msg ()
smDraw :: a -> Affection us msg ()
smClean :: a -> Affection us msg ()

View file

@ -1,17 +1,31 @@
module Affection.Subsystem.AffectionWindow where
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Affection.Subsystems.AffectionWindow where
import Affection.MessageBus
import Affection.Subsystems.Class
import Affection.Types
import Control.Monad.State.Class (get)
import Control.Monad.IO.Class (liftIO)
import qualified SDL
data AffectionWindow = AffectionWindow
data AffectionWindow msg = AffectionWindow
{ windowChannel :: Channel msg
}
instance Participant AffectionWindow where
instance Participant (AffectionWindow (SystemMessage m)) (SystemMessage m) where
partChannel = windowChannel
partInit = do
ad <- get
nchan <- liftIO $ dupChannel $ messageChannel ad
return $ AffectionWindow
{ windowChannel = nchan
}
partListen p = do
let chan = partChannel p
mmsg <- tryPeekChannel chan
@ -21,50 +35,50 @@ instance Participant AffectionWindow where
let chan = partChannel p
writeChannel chan m
instance Subsystem AffectionWindow where
instance Subsystem (AffectionWindow (SystemMessage m)) (SystemMessage m) where
consumeEvents aw evs = doConsume evs
where
doConsume (e:es) = case SDL.eventPayload e of
SDL.WindowShownEvent (SDL.WindowShownEventData window) = do
partEmit aw (MsgWindowShown (SDL.eventTiemstamp e) window)
SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
partEmit aw (MsgWindowShown (SDL.eventTimestamp e) window)
doConsume es
SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) = do
partEmit aw (MsgWindowHidden (SDL.eventTimestemp e) window)
SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
partEmit aw (MsgWindowHidden (SDL.eventTimestamp e) window)
doConsume es
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) = do
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
partEmit aw (MsgWindowExposed (SDL.eventTimestamp e) window)
doConsume es
SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) = do
partEmit aw (MsgWindowMoved (SDL.EventTimestamp e) window newPos)
SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
partEmit aw (MsgWindowMoved (SDL.eventTimestamp e) window newPos)
doConsume es
SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) = do
partEmit aw (MsgWindowResized (SDL.EventTimestamp e) window newSize)
SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
partEmit aw (MsgWindowResized (SDL.eventTimestamp e) window newSize)
doConsume es
SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) = do
partEmit aw (MsgWindowSizeChanged (SDL.EventTimestamp e) window)
SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
partEmit aw (MsgWindowSizeChanged (SDL.eventTimestamp e) window)
doConsume es
SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) = do
partEmit aw (MsgWindowMinimized (SDL.eventTimestemp e) window)
SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
partEmit aw (MsgWindowMinimized (SDL.eventTimestamp e) window)
doConsume es
SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) = do
partEmit aw (MsgWindowMaximized (SDL.eventTimestemp e) window)
SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
partEmit aw (MsgWindowMaximized (SDL.eventTimestamp e) window)
doConsume es
SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) = do
partEmit aw (MsgWindowRestored (SDL.eventTimestemp e) window)
SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
partEmit aw (MsgWindowRestored (SDL.eventTimestamp e) window)
doConsume es
SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) = do
partEmit aw (MsgWindowGainedMouseFocus (SDL.eventTimestemp e) window)
SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
partEmit aw (MsgWindowGainedMouseFocus (SDL.eventTimestamp e) window)
doConsume es
SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) = do
partEmit aw (MsgWindowLostMouseFocus (SDL.eventTimestemp e) window)
SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
partEmit aw (MsgWindowLostMouseFocus (SDL.eventTimestamp e) window)
doConsume es
SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) = do
partEmit aw (MsgWindowGainedKeyboardFocus (SDL.eventTimestemp e) window)
SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
partEmit aw (MsgWindowGainedKeyboardFocus (SDL.eventTimestamp e) window)
doConsume es
SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) = do
partEmit aw (MsgWindowLostKeyboardFocus (SDL.eventTimestemp e) window)
SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
partEmit aw (MsgWindowLostKeyboardFocus (SDL.eventTimestamp e) window)
doConsume es
SDL.WindowClosed (SDL.WindowClosedEventData window) = do
partEmit aw (MsgWindowClosed (SDL.eventTimestemp e) window)
SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
partEmit aw (MsgWindowClosed (SDL.eventTimestamp e) window)
doConsume es
_ = fmap (e :) (doConsume es)
_ -> fmap (e :) (doConsume es)

View file

@ -1,8 +1,10 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Affection.Subsystems.Class where
import Affection.MessageBus.Class
import Affection.MessageBus
import qualified SDL
class (Participant s) => Subsystem s where
class (Message m, Participant s m) => Subsystem s m where
consumeEvents :: s -> [SDL.Event] -> IO [SDL.Event]

View file

@ -42,6 +42,7 @@ import Data.Map.Strict as M
import Control.Monad.IO.Class
import Control.Monad.State
import qualified Control.Monad.Parallel as MP
import Control.Concurrent.STM as STM
import System.Clock (TimeSpec)
-- import Control.Monad.Reader
@ -50,8 +51,10 @@ import System.Clock (TimeSpec)
import Foreign.Ptr (Ptr)
import Affection.MessageBus.Message
-- | Configuration for the aplication. needed at startup.
data AffectionConfig us = AffectionConfig
data AffectionConfig us msg = AffectionConfig
{ initComponents :: InitComponents
-- ^ SDL components to initialize at startup
, windowTitle :: T.Text
@ -62,13 +65,13 @@ data AffectionConfig us = AffectionConfig
-- ^ size of the texture canvas
, initScreenMode :: SDL.WindowMode
-- ^ Window mode to start in
, preLoop :: Affection us ()
, preLoop :: Affection us msg ()
-- ^ Actions to be performed, before loop starts
, eventLoop :: SDL.EventPayload -> Affection us ()
, eventLoop :: SDL.EventPayload -> Affection us msg ()
-- ^ Main update function. Takes fractions of a second as input.
, updateLoop :: Double -> Affection us ()
, updateLoop :: Double -> Affection us msg ()
-- ^ Main update function. Takes fractions of a second as input.
, drawLoop :: Affection us ()
, drawLoop :: Affection us msg ()
-- ^ Function for updating graphics.
, loadState :: IO us
-- ^ Provide your own load function to create this data.
@ -82,7 +85,7 @@ data InitComponents
| Only [SDL.InitFlag]
-- | Main type for defining the look, feel and action of the whole application.
data AffectionData us = AffectionData
data AffectionData us msg = AffectionData
-- { affectionConfig :: AffectionConfig us -- ^ Application configuration.
{ quitEvent :: Bool -- ^ Loop breaker.
, userState :: us -- ^ State data provided by user
@ -100,6 +103,7 @@ data AffectionData us = AffectionData
, deltaTime :: Double -- ^ Elapsed time in seconds since last tick
, sysTime :: TimeSpec -- ^ System time (NOT the time on the clock)
, pausedTime :: Bool -- ^ Should the update loop be executed?
, messageChannel :: Channel msg -- ^ The main broadcast channel to duplicate all others from
}
-- -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated
@ -127,7 +131,7 @@ newtype AffectionState us m a = AffectionState
instance MP.MonadParallel m => MP.MonadParallel (AffectionState us m)
type Affection us a = AffectionState (AffectionData us) IO a
type Affection us msg a = AffectionState (AffectionData us msg) IO a
-- -- | Inner 'StateT' monad of Affection
-- type AffectionInner us od a = StateT (AffectionState us od) IO a
@ -228,3 +232,5 @@ type Angle = Double
-- { partStorLatest :: Maybe Particle -- ^ The particle stored last
-- , partStorList :: [Particle] -- ^ List of particles in ascending order of remaining lifetime
-- }
newtype (Message msg) => Channel msg = Channel (TChan msg)

View file

@ -10,12 +10,12 @@ import System.Clock
import Control.Monad.State
-- Prehandle SDL events in case any window events occur
preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload]
preHandleEvents :: [SDL.Event] -> Affection us msg [SDL.EventPayload]
preHandleEvents evs =
return $ map SDL.eventPayload evs
-- | Return the userstate to the user
getAffection :: Affection us us
getAffection :: Affection us msg us
getAffection = do
ad <- get
return $ userState ad
@ -23,7 +23,7 @@ getAffection = do
-- | Put altered user state back
putAffection
:: us -- User state
-> Affection us ()
-> Affection us msg ()
putAffection us = do
ad <- get
put $ ad
@ -36,20 +36,20 @@ delaySec
delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
-- | Get time since start but always the same in the current tick.
getElapsedTime :: Affection us Double
getElapsedTime :: Affection us msg Double
getElapsedTime =
elapsedTime <$> get
getDelta :: Affection us Double
getDelta :: Affection us msg Double
getDelta =
deltaTime <$> get
quit :: Affection us ()
quit :: Affection us msg ()
quit = do
ad <- get
put $ ad { quitEvent = True }
toggleScreen :: Affection us ()
toggleScreen :: Affection us msg ()
toggleScreen = do
ad <- get
newMode <- case screenMode ad of