115 lines
3.2 KiB
Haskell
115 lines
3.2 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
module Affection
|
|
( withAffection
|
|
, getAffection
|
|
, putAffection
|
|
-- , withWindow
|
|
-- , withDefaultWindow
|
|
, delaySec
|
|
, get
|
|
, put
|
|
, 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 qualified Data.Text as T
|
|
import Data.Maybe
|
|
|
|
import System.Clock
|
|
|
|
import Control.Monad.Loops
|
|
import Control.Monad.State
|
|
import Control.Concurrent.MVar
|
|
|
|
import Foreign.C.Types (CInt(..))
|
|
import Foreign.Storable (peek)
|
|
|
|
import Affection.Types as A
|
|
import Affection.Draw 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
|
|
case initComponents of
|
|
All ->
|
|
SDL.initializeAll
|
|
Only is ->
|
|
SDL.initialize is
|
|
G.gegl_init
|
|
execTime <- newMVar =<< getTime Monotonic
|
|
window <- SDL.createWindow windowTitle windowConfig
|
|
oldSurf@(SDL.Surface ptr _) <- SDL.getWindowSurface window
|
|
rawSurfacePtr <- Raw.convertSurfaceFormat ptr (SDL.toNumber SDL.ABGR8888) 0
|
|
let surface = (flip SDL.Surface Nothing) rawSurfacePtr
|
|
bablFormat = B.PixelFormat B.RGBA B.CFu8
|
|
pixels <- SDL.surfacePixels surface
|
|
format <- B.babl_format bablFormat
|
|
SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions surface
|
|
pixelFormat <- peek . Raw.surfaceFormat =<< peek rawSurfacePtr
|
|
let (w, h) = (fromIntegral rw, fromIntegral rh)
|
|
stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
|
|
cpp = B.babl_components_per_pixel bablFormat
|
|
initContainer <- return . (\x -> AffectionData
|
|
{ quitEvent = False
|
|
, userState = x
|
|
, drawWindow = window
|
|
, drawSurface = surface
|
|
, drawStack = []
|
|
}) =<< loadState surface
|
|
(_, nState) <- runStateT ( A.runState $ do
|
|
preLoop
|
|
whileM_ (do
|
|
current <- get
|
|
return $ not $ A.quitEvent current
|
|
)
|
|
(do
|
|
now <- liftIO $ getTime Monotonic
|
|
lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime
|
|
ad <- get
|
|
mapM_ (invalidateDrawRequest pixels format stride cpp) $ drawStack ad
|
|
put $ ad
|
|
{ drawStack = [] }
|
|
drawLoop
|
|
ad <- get
|
|
clear <- return . catMaybes =<< mapM (handleDrawRequest pixels format stride cpp) (drawStack ad)
|
|
put $ ad
|
|
{ drawStack = clear }
|
|
liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing
|
|
updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) /
|
|
(fromIntegral 10 ^ 9)
|
|
_ <- liftIO $ swapMVar execTime $ now
|
|
return ()
|
|
)
|
|
) initContainer
|
|
G.gegl_exit
|
|
cleanUp $ userState nState
|
|
SDL.quit
|
|
|
|
-- | 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)
|