114 lines
3 KiB
Haskell
114 lines
3 KiB
Haskell
{-# LANGUAGE ForeignFunctionInterface #-}
|
|
module Main where
|
|
|
|
import Affection as A
|
|
|
|
import Data.Ecstasy
|
|
|
|
import qualified SDL
|
|
|
|
import NanoVG hiding (V2(..), V3(..))
|
|
|
|
import Linear
|
|
|
|
import Foreign.C.Types (CInt(..))
|
|
|
|
import Data.Maybe (fromJust)
|
|
|
|
-- internal imports
|
|
|
|
import Types hiding (draw)
|
|
import StateMachine ()
|
|
import Init
|
|
|
|
foreign import ccall unsafe "glewInit"
|
|
glewInit :: IO CInt
|
|
|
|
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
|
|
, eventLoop = handle
|
|
, updateLoop = update
|
|
, drawLoop = draw
|
|
, loadState = Init.init
|
|
, cleanUp = clean
|
|
, 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
|
|
threadCtx <- SDL.glCreateContext (drawWindow ad)
|
|
SDL.glMakeCurrent (drawWindow ad) (glContext ad)
|
|
let Subsystems w m k = subsystems ud
|
|
_ <- partSubscribe w (fitViewport (1280/720))
|
|
_ <- partSubscribe w exitOnWindowClose
|
|
_ <- partSubscribe k toggleFullScreen
|
|
_ <- partSubscribe k quitGame
|
|
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
|
putAffection ud
|
|
{ threadContext = Just threadCtx
|
|
, window = Just (drawWindow ad)
|
|
, worldState = ws
|
|
}
|
|
|
|
quitGame :: KeyboardMessage -> Affection UserData ()
|
|
quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
|
| SDL.keysymKeycode sym == SDL.KeycodeEscape = do
|
|
ad <- A.get
|
|
ud <- getAffection
|
|
SDL.glMakeCurrent (drawWindow ad) (glContext ad)
|
|
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
|
putAffection ud
|
|
{ worldState = ws
|
|
}
|
|
smLoad Load
|
|
| otherwise = return ()
|
|
quitGame _ = return ()
|
|
|
|
toggleFullScreen :: KeyboardMessage -> Affection UserData ()
|
|
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
|
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
|
|
| otherwise = return ()
|
|
toggleFullScreen _ = return ()
|
|
|
|
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 ()
|
|
|
|
clean :: UserData -> IO ()
|
|
clean ud =
|
|
SDL.glDeleteContext $ fromJust $ threadContext ud
|