tracer/src/Main.hs

86 lines
2.2 KiB
Haskell
Raw Normal View History

{-# LANGUAGE ForeignFunctionInterface #-}
2018-02-07 00:18:16 +00:00
module Main where
import Affection as A
import qualified SDL
import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL
2018-02-07 00:18:16 +00:00
import NanoVG hiding (V2(..), V3(..))
import Linear
import Foreign.C.Types (CInt(..))
2018-02-07 00:18:16 +00:00
-- internal imports
import Types
import StateMachine ()
import Init
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
2018-02-07 00:18:16 +00:00
main :: IO ()
main = do
let config = AffectionConfig
{ initComponents = All
, windowTitle = "Tracer"
, windowConfig = SDL.defaultWindow
{ SDL.windowInitialSize = V2 1280 720
, SDL.windowResizable = True
, SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
, canvasSize = Nothing
, preLoop = pre >> smLoad Load
2018-02-07 00:18:16 +00:00
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, loadState = Init.init
2018-02-07 00:18:16 +00:00
, cleanUp = const (return ())
, initScreenMode = SDL.Windowed
}
withAffection config
pre :: Affection UserData ()
pre = do
ad <- A.get
ud <- getAffection
_ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
threadContext <- SDL.glCreateContext (drawWindow ad)
SDL.glMakeCurrent (drawWindow ad) (glContext ad)
2018-02-07 00:18:16 +00:00
Subsystems w m <- subsystems <$> getAffection
_ <- partSubscribe w (fitViewport (1280/720))
2018-02-18 02:11:41 +00:00
_ <- partSubscribe w exitOnWindowClose
putAffection ud
{ threadContext = Just threadContext
, mainContext = Just (glContext ad)
, window = Just (drawWindow ad)
}
2018-02-07 00:18:16 +00:00
update :: Double -> Affection UserData ()
update dt = do
ud <- getAffection
smUpdate (state ud) dt
draw :: Affection UserData ()
draw = do
ud <- getAffection
liftIO $ beginFrame (nano ud) 1280 720 1
smDraw (state ud)
liftIO $ endFrame (nano ud)
handle :: [SDL.EventPayload] -> Affection UserData ()
handle evs = do
s <- state <$> getAffection
smEvent s evs
exitOnWindowClose :: WindowMessage -> Affection UserData ()
exitOnWindowClose (MsgWindowClose _ _) = do
liftIO $ logIO A.Debug "Window Closed"
quit
exitOnWindowClose _ = return ()