still won't work

This commit is contained in:
nek0 2017-12-13 15:19:53 +01:00
parent 1cbda31499
commit 78f058db6b
15 changed files with 239 additions and 263 deletions

View file

@ -70,6 +70,7 @@ library
, Affection.MessageBus.Message.WindowMessage
, Affection.MessageBus.Message.KeyboardMessage
, Affection.MessageBus.Message.MouseMessage
, Affection.Subsystems
, Affection.Subsystems.Class
, Affection.Subsystems.AffectionWindow
, Affection.Subsystems.AffectionKeyboard
@ -104,23 +105,26 @@ library
, stm
, uuid
-- executable example00
-- hs-source-dirs: examples
-- main-is: example00.hs
-- ghc-options: -threaded -Wall
-- default-language: Haskell2010
-- default-extensions: OverloadedStrings
-- if flag(examples)
-- build-depends: base
-- , affection
-- , sdl2
-- , gegl
-- , babl
-- , containers
-- , mtl
-- else
-- buildable: False
--
executable example00
if flag(debug)
cpp-options: -DDEBUG
if flag(warn)
cpp-options: -DWARN
if flag(error)
cpp-options: -DERROR
hs-source-dirs: examples
main-is: example00.hs
ghc-options: -threaded -Wall
default-language: Haskell2010
default-extensions: OverloadedStrings
if flag(examples)
build-depends: base
, affection
, sdl2
, stm
else
buildable: False
-- executable example01
-- hs-source-dirs: examples
-- main-is: example01.hs
@ -209,26 +213,26 @@ library
-- , monad-parallel
-- else
-- buildable: False
executable example05
hs-source-dirs: examples
main-is: example05.hs
ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts
default-language: Haskell2010
default-extensions: OverloadedStrings
if flag(examples)
build-depends: base
, affection
, sdl2
, gegl
, babl
, containers
, unordered-containers
, mtl
, random
, matrix
, random
, monad-parallel
, parallel
else
buildable: False
--
-- executable example05
-- hs-source-dirs: examples
-- main-is: example05.hs
-- ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts
-- default-language: Haskell2010
-- default-extensions: OverloadedStrings
-- if flag(examples)
-- build-depends: base
-- , affection
-- , sdl2
-- , gegl
-- , babl
-- , containers
-- , unordered-containers
-- , mtl
-- , random
-- , matrix
-- , random
-- , monad-parallel
-- , parallel
-- else
-- buildable: False

View file

@ -1,117 +1,71 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
import Affection
import qualified SDL
import qualified SDL.Raw as Raw
import qualified GEGL as G
import qualified BABL as B
import qualified Data.Map.Strict as M
import Control.Monad (when)
import Control.Concurrent.STM
import Foreign.Storable (peek)
import Foreign.C.Types (CInt(..))
data StateData = StateData
{ sdSubs :: Subsystems
}
import Debug.Trace
-- main :: IO ()
-- main = withAllAffection $
-- withDefaultWindow "test" $ do
-- changeColor $ RGBA 255 255 255 255
-- clear
-- present
-- liftIO $ delaySec 2
data Subsystems = Subsystems
{ subWindow :: AffectionWindow StateData
, subMouse :: AffectionMouse StateData
, subKeyboard :: AffectionKeyboard StateData
}
main :: IO ()
main = do
conf <- return $ AffectionConfig
logIO Debug "Starting"
let conf = AffectionConfig
{ initComponents = All
, windowTitle = "Affection: example00"
, windowTitle = "affection: example00"
, windowConfig = SDL.defaultWindow
, preLoop = return ()
, initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, loadState = load
, cleanUp = clean
}
withAffection conf
data UserData = UserData
{ nodeGraph :: M.Map String G.GeglNode
}
load :: IO UserData
load :: IO StateData
load = do
traceM "loading"
root <- G.gegl_node_new
traceM "new root node"
checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $
props $ do
prop "color1" $ G.RGBA 0.4 0.4 0.4 1
prop "color2" $ G.RGBA 0.6 0.6 0.6 1
traceM "checkerboard"
over <- G.gegl_node_new_child root G.defaultOverOperation
traceM "over"
text <- G.gegl_node_new_child root $ G.textOperation $
props $ do
prop "string" ("Hello world!"::String)
prop "color" $ G.RGBA 0 0 1 0.5
prop "size" (40::Int)
traceM "text"
G.gegl_node_link checkerboard over
G.gegl_node_connect_to text "output" over "aux"
traceM "connections made"
myMap <- return $ M.fromList
[ ("root" , root)
, ("over" , over)
, ("checkerboard", checkerboard)
, ("text" , text)
]
traceM "loading complete"
return $ UserData
{ nodeGraph = myMap
}
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())])
empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
return $ StateData $ Subsystems
(AffectionWindow empty1)
(AffectionMouse empty2)
(AffectionKeyboard empty3)
draw :: Affection UserData ()
draw = do
traceM "drawing"
AffectionData{..} <- get
let UserData{..} = userState
liftIO $ SDL.lockSurface drawSurface
pixels <- liftIO $ SDL.surfacePixels drawSurface
let SDL.Surface rawSurfacePtr _ = drawSurface
rawSurface <- liftIO $ peek rawSurfacePtr
pixelFormat <- liftIO $ peek $ Raw.surfaceFormat rawSurface
format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8)
SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface
let (w, h) = (fromIntegral rw, fromIntegral rh)
liftIO $ G.gegl_node_blit
(nodeGraph M.! "over" :: G.GeglNode)
1
(G.GeglRectangle 0 0 w h)
format
pixels
(fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w)
[G.GeglBlitDefault]
liftIO $ SDL.unlockSurface drawSurface
liftIO $ SDL.updateWindowSurface drawWindow
pre :: Affection StateData ()
pre = do
sd <- getAffection
_ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
return ()
handle :: SDL.EventPayload -> Affection UserData ()
handle = const $ return ()
exitOnQ :: KeyboardMessage -> Affection StateData ()
exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of
SDL.KeycodeQ -> quit
otherwise -> return ()
update :: Double -> Affection UserData ()
update sec = do
traceM "updating"
ad <- get
ud@UserData{..} <- getAffection
handle :: [SDL.EventPayload] -> Affection StateData ()
handle es = do
(Subsystems a b c) <- sdSubs <$> getAffection
_ <- consumeSDLEvents a es
_ <- consumeSDLEvents b es
_ <- consumeSDLEvents c es
return ()
-- sec <- getDelta
traceM $ (show $ 1 / sec) ++ " FPS"
when (elapsedTime ad > 5) $
put $ ad
{ quitEvent = True
}
update _ = return ()
draw = return ()
clean :: UserData -> IO ()
clean _ = return ()

View file

@ -24,6 +24,9 @@ import Affection.StateMachine as A
import Affection.MouseInteractable as A
import Affection.Util as A
import Affection.MessageBus as A
import Affection.Subsystems as A
import Affection.Logging as A
import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
@ -45,7 +48,7 @@ withAffection AffectionConfig{..} = do
do
renderQuality <- SDL.get SDL.HintRenderScaleQuality
when (renderQuality /= SDL.ScaleLinear) $
putStrLn "Warning: Linear texture filtering not enabled!"
logIO Warn "Linear texture filtering not enabled!"
-- construct window
window <- SDL.createWindow windowTitle windowConfig
SDL.showWindow window
@ -94,7 +97,8 @@ withAffection AffectionConfig{..} = do
}
-- poll events
evs <- preHandleEvents =<< liftIO SDL.pollEvents
mapM_ eventLoop evs
-- mapM_ eventLoop evs
eventLoop evs
-- execute user defined update loop
unless (pausedTime ad) (updateLoop dt)
-- execute user defined draw loop

View file

@ -1,7 +1,10 @@
module Affection.MessageBus
( module M
, module Msg
) where
import Affection.MessageBus.Class as M
import Affection.MessageBus.Message as M
import Affection.MessageBus.Util as M
import Affection.MessageBus.Message as Msg

View file

@ -1,6 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Rank2Types #-}
module Affection.MessageBus.Class
( Participant(..)
, genUUID
@ -26,7 +26,7 @@ class (Show m, Message m) => Participant prt m where
-- | Subscribe to the 'Participant''s events
partSubscribe
:: prt -- ^ The 'Participant' to subscribe to
-> (forall sd. m -> Affection sd ()) -- ^ What to do in case of a 'Message'
-> (m -> Affection sd ()) -- ^ What to do in case of a 'Message'
-- (Subscriber function)
-> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function

View file

@ -3,4 +3,4 @@ module Affection.MessageBus.Message.Class where
import Data.Word (Word32(..))
class Message msg where
msgTime :: msg -> Word32
msgTime :: msg -> Double

View file

@ -2,12 +2,10 @@ module Affection.MessageBus.Message.KeyboardMessage where
import Affection.MessageBus.Message.Class
import Data.Word (Word32(..))
import qualified SDL
data KeyboardMessage = MsgKeyboardEvent
{ msgKbdWhen :: Word32
{ msgKbdWhen :: Double
, msgKbdWindow :: Maybe SDL.Window
, msgKbdKeyMotion :: SDL.InputMotion
, msgKbdLeyRepeat :: Bool

View file

@ -2,7 +2,7 @@ module Affection.MessageBus.Message.MouseMessage where
import Affection.MessageBus.Message.Class
import Data.Word (Word32(..), Word8(..))
import Data.Word (Word8(..))
import Data.Int (Int32(..))
import qualified SDL
@ -11,7 +11,7 @@ import Linear (V2(..))
data MouseMessage
= MsgMouseMotion
{ msgMMWhen :: Word32
{ msgMMWhen :: Double
, msgMMWindow :: Maybe SDL.Window
, msgMMWhich :: SDL.MouseDevice
, msgMMState :: [SDL.MouseButton]
@ -19,7 +19,7 @@ data MouseMessage
, msgMMRelMotion :: V2 Int32
}
| MsgMouseButton
{ msgMBWhen :: Word32
{ msgMBWhen :: Double
, msgMBWindow :: Maybe SDL.Window
, msgMBWhich :: SDL.MouseDevice
, msgMBButton :: SDL.MouseButton
@ -27,7 +27,7 @@ data MouseMessage
, msgMBPos :: V2 Int32
}
| MsgMouseWheel
{ msgMWWhen :: Word32
{ msgMWWhen :: Double
, msgMWWhindow :: Maybe SDL.Window
, msgMWWhich :: SDL.MouseDevice
, msgMWPos :: V2 Int32

View file

@ -2,7 +2,6 @@ module Affection.MessageBus.Message.WindowMessage where
import Affection.MessageBus.Message.Class
import Data.Word (Word32(..))
import Data.Int (Int32(..))
import qualified SDL
@ -10,63 +9,63 @@ import qualified SDL
import Linear (V2(..))
data WindowMessage
-- = MsgEngineReady Word32
-- = MsgEngineReady Double
= MsgWindowShow
{ msgWSWhen :: Word32
{ msgWSWhen :: Double
, msgWSWindow :: SDL.Window
}
| MsgWindowHide
{ msgWHWhen :: Word32
{ msgWHWhen :: Double
, msgWHWindow :: SDL.Window
}
| MsgWindowExpose
{ msgWEWhen :: Word32
{ msgWEWhen :: Double
, msgWEWindow :: SDL.Window
}
| MsgWindowMove
{ msgWMWhen :: Word32
{ msgWMWhen :: Double
, msgWMWindow :: SDL.Window
, msgWMNewPos :: V2 Int32
}
| MsgWindowResize
{ msgWRWhen :: Word32
{ msgWRWhen :: Double
, msgWRWindow :: SDL.Window
, msgWRNewSize :: V2 Int32
}
| MsgWindowSizeChange
{ msgWSCWhen :: Word32
{ msgWSCWhen :: Double
, msgWSCWindow :: SDL.Window
}
| MsgWindowMinimize
{ msgWMinWhen :: Word32
{ msgWMinWhen :: Double
, msgWMinWindow :: SDL.Window
}
| MsgWindowMaximize
{ msgWMaxWhen :: Word32
{ msgWMaxWhen :: Double
, msgWMaxWindow :: SDL.Window
}
| MsgWindowRestore
{ msgWRestWhen :: Word32
{ msgWRestWhen :: Double
, msgWRestWindow :: SDL.Window
}
| MsgWindowGainMouseFocus
{ msgWGMFWhen :: Word32
{ msgWGMFWhen :: Double
, msgWGMFWindow :: SDL.Window
}
| MsgWindowLoseMouseFocus
{ msgWLMFWhen :: Word32
{ msgWLMFWhen :: Double
, msgWLMFWindow :: SDL.Window
}
| MsgWindowGainKeyboardFocus
{ msgWGKFWhen :: Word32
{ msgWGKFWhen :: Double
, msgWGKFWindow :: SDL.Window
}
| MsgWindowLoseKeyboardFocus
{ msgWLKFWhen :: Word32
{ msgWLKFWhen :: Double
, msgWLKFWindow :: SDL.Window
}
| MsgWindowClose
{ msgWCWhen :: Word32
{ msgWCWhen :: Double
, msgWCWindow :: SDL.Window
}
deriving (Show)

View file

@ -0,0 +1,8 @@
module Affection.Subsystems
( module S
) where
import Affection.Subsystems.Class as S
import Affection.Subsystems.AffectionKeyboard as S
import Affection.Subsystems.AffectionWindow as S
import Affection.Subsystems.AffectionMouse as S

View file

@ -5,6 +5,7 @@ module Affection.Subsystems.AffectionKeyboard where
import Affection.MessageBus
import Affection.Subsystems.Class
import Affection.Types
import Affection.Util
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM as STM
@ -30,13 +31,14 @@ instance Participant (AffectionKeyboard sd) KeyboardMessage where
return $ map snd subTups
instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where
consumeSDLEvents ak evs = doConsume evs
consumeSDLEvents ak eps = doConsume eps
where
doConsume [] = return []
doConsume (e:es) = case SDL.eventPayload e of
doConsume (e:es) = do
ts <- getElapsedTime
case e of
SDL.KeyboardEvent dat -> do
partEmit ak (MsgKeyboardEvent
(SDL.eventTimestamp e)
ts
(SDL.keyboardEventWindow dat)
(SDL.keyboardEventKeyMotion dat)
(SDL.keyboardEventRepeat dat)

View file

@ -5,6 +5,7 @@ module Affection.Subsystems.AffectionMouse where
import Affection.MessageBus
import Affection.Subsystems.Class
import Affection.Types
import Affection.Util
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM
@ -32,13 +33,14 @@ instance Participant (AffectionMouse sd) MouseMessage where
return $ map snd subTups
instance SDLSubsystem (AffectionMouse sd) MouseMessage where
consumeSDLEvents am evs = doConsume evs
consumeSDLEvents am eps = doConsume eps
where
doConsume [] = return []
doConsume (e:es) = case SDL.eventPayload e of
doConsume (e:es) = do
ts <- getElapsedTime
case e of
SDL.MouseMotionEvent dat -> do
partEmit am (MsgMouseMotion
(SDL.eventTimestamp e)
ts
(SDL.mouseMotionEventWindow dat)
(SDL.mouseMotionEventWhich dat)
(SDL.mouseMotionEventState dat)
@ -48,7 +50,7 @@ instance SDLSubsystem (AffectionMouse sd) MouseMessage where
doConsume es
SDL.MouseButtonEvent dat -> do
partEmit am (MsgMouseButton
(SDL.eventTimestamp e)
ts
(SDL.mouseButtonEventWindow dat)
(SDL.mouseButtonEventWhich dat)
(SDL.mouseButtonEventButton dat)
@ -58,7 +60,7 @@ instance SDLSubsystem (AffectionMouse sd) MouseMessage where
doConsume es
SDL.MouseWheelEvent dat -> do
partEmit am (MsgMouseWheel
(SDL.eventTimestamp e)
ts
(SDL.mouseWheelEventWindow dat)
(SDL.mouseWheelEventWhich dat)
(SDL.mouseWheelEventPos dat)

View file

@ -3,6 +3,7 @@
module Affection.Subsystems.AffectionWindow where
import Affection.Types
import Affection.Util
import Affection.MessageBus
import Affection.Subsystems.Class
@ -30,50 +31,51 @@ instance Participant (AffectionWindow sd) WindowMessage where
return $ map snd subTups
instance SDLSubsystem (AffectionWindow sd) WindowMessage where
consumeSDLEvents aw evs = doConsume evs
consumeSDLEvents aw eps = doConsume eps
where
doConsume [] = return []
doConsume (e:es) = case SDL.eventPayload e of
doConsume (e:es) = do
ts <- getElapsedTime
case e of
SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
partEmit aw (MsgWindowShow (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowShow ts window)
doConsume es
SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
partEmit aw (MsgWindowHide (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowHide ts window)
doConsume es
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
partEmit aw (MsgWindowExpose (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowExpose ts window)
doConsume es
SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
partEmit aw (MsgWindowMove (SDL.eventTimestamp e) window newPos)
partEmit aw (MsgWindowMove ts window newPos)
doConsume es
SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
partEmit aw (MsgWindowResize (SDL.eventTimestamp e) window newSize)
partEmit aw (MsgWindowResize ts window newSize)
doConsume es
SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
partEmit aw (MsgWindowSizeChange (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowSizeChange ts window)
doConsume es
SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
partEmit aw (MsgWindowMinimize (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowMinimize ts window)
doConsume es
SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
partEmit aw (MsgWindowMaximize (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowMaximize ts window)
doConsume es
SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
partEmit aw (MsgWindowRestore (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowRestore ts window)
doConsume es
SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
partEmit aw (MsgWindowGainMouseFocus (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowGainMouseFocus ts window)
doConsume es
SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
partEmit aw (MsgWindowLoseMouseFocus (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowLoseMouseFocus ts window)
doConsume es
SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
partEmit aw (MsgWindowGainKeyboardFocus (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowGainKeyboardFocus ts window)
doConsume es
SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
partEmit aw (MsgWindowLoseKeyboardFocus (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowLoseKeyboardFocus ts window)
doConsume es
SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
partEmit aw (MsgWindowClose (SDL.eventTimestamp e) window)
partEmit aw (MsgWindowClose ts window)
doConsume es
_ -> fmap (e :) (doConsume es)

View file

@ -8,4 +8,4 @@ import Affection.MessageBus
import qualified SDL
class (Message m, Participant s m) => SDLSubsystem s m where
consumeSDLEvents :: s -> [SDL.Event] -> Affection sd [SDL.Event]
consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection sd [SDL.EventPayload]

View file

@ -64,16 +64,16 @@ data AffectionConfig us = AffectionConfig
-- ^ size of the texture canvas
, initScreenMode :: SDL.WindowMode
-- ^ Window mode to start in
, loadState :: IO us
-- ^ Provide your own load function to create this data.
, preLoop :: Affection us ()
-- ^ Actions to be performed, before loop starts
, eventLoop :: SDL.EventPayload -> Affection us ()
, eventLoop :: [SDL.EventPayload] -> Affection us ()
-- ^ Main update function. Takes fractions of a second as input.
, updateLoop :: Double -> Affection us ()
-- ^ Main update function. Takes fractions of a second as input.
, drawLoop :: Affection us ()
-- ^ Function for updating graphics.
, loadState :: IO us
-- ^ Provide your own load function to create this data.
, cleanUp :: us -> IO ()
-- ^ Provide your own finisher function to clean your data.
}