dusting off
This commit is contained in:
nek0
parent
1bb1af935b
commit
6e11ff9b1e
6 changed files with 12 additions and 73 deletions
|
|
@ -36,18 +36,12 @@ flag examples
|
|||
|
||||
library
|
||||
exposed-modules: Affection
|
||||
-- , Affection.Draw
|
||||
-- , Affection.Particle
|
||||
, Affection.Types
|
||||
, Affection.StateMachine
|
||||
, Affection.MouseInteractable
|
||||
-- , Affection.Property
|
||||
-- , Affection.Actor
|
||||
-- , Affection.Animation
|
||||
, Affection.Util
|
||||
, Affection.MessageBus.Util
|
||||
, Affection.MessageBus.Class
|
||||
, Affection.MessageBus.Engine
|
||||
, Affection.MessageBus.Message
|
||||
default-extensions: OverloadedStrings
|
||||
|
||||
|
|
@ -69,8 +63,6 @@ library
|
|||
, text
|
||||
, mtl
|
||||
, time
|
||||
-- , gegl
|
||||
-- , babl
|
||||
, monad-loops
|
||||
, monad-parallel
|
||||
, containers
|
||||
|
|
@ -79,7 +71,6 @@ library
|
|||
, bytestring
|
||||
, OpenGL
|
||||
, stm
|
||||
-- , sdl2-image
|
||||
|
||||
-- executable example00
|
||||
-- hs-source-dirs: examples
|
||||
|
|
|
|||
|
|
@ -5,8 +5,6 @@ module Affection
|
|||
, get
|
||||
, getAffection
|
||||
, putAffection
|
||||
-- , withWindow
|
||||
-- , withDefaultWindow
|
||||
, delaySec
|
||||
, get
|
||||
, put
|
||||
|
|
@ -17,7 +15,6 @@ import SDL (($=))
|
|||
import qualified SDL
|
||||
import qualified SDL.Internal.Numbered as SDL (toNumber)
|
||||
import qualified SDL.Raw as Raw
|
||||
-- import qualified GEGL as G
|
||||
|
||||
import Data.Maybe
|
||||
import Data.IORef
|
||||
|
|
@ -33,22 +30,13 @@ import Foreign.Storable (peek)
|
|||
import Debug.Trace
|
||||
|
||||
import Affection.Types as A
|
||||
-- import Affection.Draw as A
|
||||
-- import Affection.Particle as A
|
||||
import Affection.StateMachine as A
|
||||
import Affection.MouseInteractable as A
|
||||
-- import Affection.Property as A
|
||||
-- import Affection.Actor as A
|
||||
-- import Affection.Animation as A
|
||||
import Affection.Util as A
|
||||
import Affection.MessageBus.Class as A
|
||||
import Affection.MessageBus.Message as A
|
||||
import Affection.MessageBus.Engine as A
|
||||
import Affection.MessageBus.Util as A
|
||||
import Affection.MessageBus as A
|
||||
|
||||
import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
|
||||
|
||||
-- import qualified BABL as B
|
||||
|
||||
-- | Main function which bootstraps everything else.
|
||||
withAffection
|
||||
|
|
@ -61,7 +49,6 @@ withAffection AffectionConfig{..} = do
|
|||
SDL.initializeAll
|
||||
Only is ->
|
||||
SDL.initialize is
|
||||
-- G.gegl_init
|
||||
-- give SDL render quality
|
||||
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
|
||||
-- just checking…
|
||||
|
|
@ -73,54 +60,23 @@ withAffection AffectionConfig{..} = do
|
|||
window <- SDL.createWindow windowTitle windowConfig
|
||||
SDL.showWindow window
|
||||
context <- SDL.glCreateContext(window)
|
||||
-- -- create renderer
|
||||
-- renderer <- SDL.createRenderer
|
||||
-- window
|
||||
-- (-1)
|
||||
-- SDL.defaultRenderer
|
||||
-- -- make draw texture
|
||||
-- texture <- SDL.createTexture
|
||||
-- renderer
|
||||
-- SDL.ABGR8888
|
||||
-- SDL.TextureAccessStreaming
|
||||
-- (case canvasSize of
|
||||
-- Just (cw, ch) -> (SDL.V2
|
||||
-- (CInt $ fromIntegral cw)
|
||||
-- (CInt $ fromIntegral ch)
|
||||
-- )
|
||||
-- Nothing ->
|
||||
-- SDL.windowInitialSize windowConfig
|
||||
-- )
|
||||
-- -- make draw surface
|
||||
-- -- pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr
|
||||
let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig
|
||||
(w, h) = case canvasSize of
|
||||
Just (cw, ch) -> (cw, ch)
|
||||
Nothing -> (fromIntegral rw, fromIntegral rh)
|
||||
-- -- stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
|
||||
-- bablFormat = B.PixelFormat B.RGBA B.CFu8
|
||||
-- cpp = B.babl_components_per_pixel bablFormat
|
||||
-- !stride = cpp * w
|
||||
-- format <- B.babl_format bablFormat
|
||||
-- get current time
|
||||
SDL.setWindowMode window initScreenMode
|
||||
SDL.swapInterval $= SDL.SynchronizedUpdates
|
||||
-- get current time
|
||||
execTime <- getTime Monotonic
|
||||
initContainer <- (\x -> AffectionData
|
||||
{ quitEvent = False
|
||||
, userState = x
|
||||
, drawWindow = window
|
||||
, glContext = context
|
||||
-- , windowRenderer = renderer
|
||||
-- , drawTexture = texture
|
||||
-- , drawFormat = format
|
||||
, drawDimensions = case canvasSize of
|
||||
Just (cw, ch) -> (cw, ch)
|
||||
Nothing -> (w, h)
|
||||
, screenMode = initScreenMode
|
||||
-- , drawStride = stride
|
||||
-- , drawCPP = cpp
|
||||
-- , drawStack = []
|
||||
, elapsedTime = 0
|
||||
, deltaTime = 0
|
||||
, sysTime = execTime
|
||||
|
|
@ -138,15 +94,10 @@ withAffection AffectionConfig{..} = do
|
|||
-- Measure time difference form last run
|
||||
now <- liftIO $ getTime Monotonic
|
||||
let lastTime = sysTime ad
|
||||
-- -- clean draw requests from last run
|
||||
-- MP.mapM_ (invalidateDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad)
|
||||
-- clean the renderer form last time
|
||||
-- SDL.clear renderer
|
||||
-- compute dt and update elapsedTime
|
||||
let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9)
|
||||
!ne = elapsedTime ad + dt
|
||||
put $ ad
|
||||
-- { drawStack = []
|
||||
{ elapsedTime = ne
|
||||
, deltaTime = dt
|
||||
}
|
||||
|
|
@ -161,14 +112,8 @@ withAffection AffectionConfig{..} = do
|
|||
liftIO $ flush
|
||||
-- handle all new draw requests
|
||||
ad2 <- get
|
||||
-- clear <- catMaybes <$>
|
||||
-- mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2)
|
||||
-- -- save all draw requests to clear in next run
|
||||
-- put $ ad2
|
||||
-- { drawStack = clear }
|
||||
-- actual drawing
|
||||
SDL.glSwapWindow window
|
||||
-- SDL.present (windowRenderer ad2)
|
||||
-- save new time
|
||||
ad3 <- get
|
||||
when (sysTime ad == sysTime ad3) (
|
||||
|
|
@ -178,7 +123,6 @@ withAffection AffectionConfig{..} = do
|
|||
)
|
||||
)
|
||||
) initContainer
|
||||
-- G.gegl_exit
|
||||
cleanUp $ userState nState
|
||||
SDL.destroyWindow window
|
||||
SDL.quit
|
||||
|
|
|
|||
7
src/Affection/MessageBus.hs
Normal file
7
src/Affection/MessageBus.hs
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
module Affection.Messagebus
|
||||
( module M
|
||||
) where
|
||||
|
||||
import Affection.MessageBus.Class as M
|
||||
import Affection.MessageBus.Message as M
|
||||
import Affection.MessageBus.Util as M
|
||||
|
|
@ -16,4 +16,4 @@ class (Message msg) => Participant prt msg where
|
|||
|
||||
partListen :: prt -> IO msg
|
||||
|
||||
partBroadcast :: prt -> msg -> IO ()
|
||||
partEmit :: prt -> msg -> IO ()
|
||||
|
|
|
|||
|
|
@ -1,3 +0,0 @@
|
|||
module Affection.MessageBus.Engine where
|
||||
|
||||
import Affection.MessageBus.Class
|
||||
|
|
@ -6,13 +6,13 @@ import Data.Time.Clock (UTCTime(..))
|
|||
class Message msg where
|
||||
msgTime :: msg -> UTCTime
|
||||
|
||||
data EngineMessage m
|
||||
data SystemMessage m
|
||||
= MsgUserMessage
|
||||
{ msgPayload :: m
|
||||
, msgWhen :: UTCTime
|
||||
} -- ^ Generic user defined message with custom payload
|
||||
| MsgEngineReady UTCTime
|
||||
|
||||
instance Message (EngineMessage m) where
|
||||
instance Message (SystemMessage m) where
|
||||
msgTime (MsgUserMessage _ t) = t
|
||||
msgTime (MsgEngineReady t) = t
|
||||
|
|
|
|||
Loading…
Reference in a new issue