{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} module Affection ( withAffection , getAffection , putAffection -- , withWindow -- , withDefaultWindow , delaySec , get , put , getElapsedTime , getDelta , quit , module A ) where 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 import System.Clock import Control.Monad.Loops import qualified Control.Monad.Parallel as MP import Control.Monad.State import Foreign.C.Types (CInt(..)) 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 qualified BABL as B -- | Main function which bootstraps everything else. withAffection :: AffectionConfig us -- ^ Configuration of the Game and its engine. -> IO () withAffection AffectionConfig{..} = do -- intialiaze SDL case initComponents of All -> SDL.initializeAll Only is -> SDL.initialize is G.gegl_init -- give SDL render quality SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear -- just checking… do renderQuality <- SDL.get SDL.HintRenderScaleQuality when (renderQuality /= SDL.ScaleLinear) $ putStrLn "Warning: Linear texture filtering not enabled!" -- get current time execTime <- newIORef =<< getTime Monotonic -- construct window window <- SDL.createWindow windowTitle windowConfig SDL.showWindow 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) = 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 initContainer <- (\x -> AffectionData { quitEvent = False , userState = x , drawWindow = window , windowRenderer = renderer -- , drawSurface = surface , drawTexture = texture , drawFormat = format -- , drawPixels = pixels , drawDimensions = case canvasSize of Just (cw, ch) -> (cw, ch) Nothing -> (w, h) , drawStride = stride , drawCPP = cpp , drawStack = [] , elapsedTime = 0 , dt = 0 }) <$> loadState surface (_, nState) <- runStateT ( A.runState $ do preLoop whileM_ (do current <- get return $ not $ A.quitEvent current ) (do -- Measure time difference form last run now <- liftIO $ getTime Monotonic lastTime <- liftIO $ readIORef execTime -- get state ad <- get -- clean draw requests from last run mapM_ (invalidateDrawRequest (drawPixels ad) (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 , dt = dt } -- poll events evs <- preHandleEvents =<< liftIO SDL.pollEvents MP.mapM_ eventLoop evs -- execute user defined update loop updateLoop -- execute user defined draw loop drawLoop -- handle all new draw requests ad2 <- get clear <- catMaybes <$> mapM (handleDrawRequest (drawPixels ad) (drawStride ad) (drawCPP ad)) (drawStack ad2) -- save all draw requests to clear in next run put $ ad2 { drawStack = clear } -- get texture from surface -- texture <- SDL.createTextureFromSurface (windowRenderer ad2) (drawSurface ad2) -- actual drawing SDL.copy (windowRenderer ad2) texture Nothing Nothing SDL.present (windowRenderer ad2) -- clean the texture -- SDL.destroyTexture texture -- save new time liftIO $ writeIORef execTime now ) ) initContainer G.gegl_exit cleanUp $ userState nState SDL.destroyWindow window SDL.quit getSurfaces :: SDL.Window -> IO (SDL.Surface, SDL.Surface) getSurfaces window = do oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0 let surface = SDL.Surface rawSurfacePtr Nothing return (oldSurf, surface) -- Prehandle SDL events in case any window events occur preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload] preHandleEvents evs = -- mapM handle evs -- where -- handle e = -- case SDL.eventPayload e of -- SDL.WindowMovedEvent _ -> do -- liftIO $ traceIO "I was moved" -- return e -- _ -> -- return e return $ map SDL.eventPayload evs -- | Return the userstate to the user getAffection :: Affection us us getAffection = do ad <- get return $ userState ad -- | Put altered user state back putAffection :: us -- User state -> Affection us () putAffection us = do ad <- get put $ ad { userState = us } -- | block a thread for a specified amount of time delaySec :: Int -- ^ Number of seconds -> IO () delaySec dur = SDL.delay (fromIntegral $ dur * 1000) -- | Get time since start but always the same in the current tick. getElapsedTime :: Affection us Double getElapsedTime = elapsedTime <$> get getDelta :: Affection us Double getDelta = dt <$> get quit :: Affection us () quit = do ad <- get put $ ad { quitEvent = True }