tracer/src/Main.hs

134 lines
3.7 KiB
Haskell
Raw Normal View History

{-# LANGUAGE ForeignFunctionInterface #-}
2018-02-07 00:18:16 +00:00
module Main where
import Affection as A
2018-08-10 06:58:26 +00:00
import Data.Ecstasy
2018-02-07 00:18:16 +00:00
import qualified SDL
import NanoVG hiding (V2(..), V3(..))
import Linear
import Foreign.C.Types (CInt(..))
2018-06-23 22:43:09 +00:00
import Data.Maybe (fromJust)
2018-09-24 22:13:09 +00:00
import Control.Monad (when)
2018-02-07 00:18:16 +00:00
-- internal imports
import Types hiding (draw)
2018-02-07 00:18:16 +00:00
import StateMachine ()
import Init
2018-10-12 12:26:06 +00:00
import Util
2018-02-07 00:18:16 +00:00
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
2018-02-07 00:18:16 +00:00
main :: IO ()
main = do
let config = AffectionConfig
2019-10-28 17:20:34 +00:00
{ initComponents = All
, windowTitle = "Tracer"
, windowConfigs =
[ ( 0
, SDL.defaultWindow
{ SDL.windowInitialSize = V2 1280 720
, SDL.windowResizable = True
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
)
]
2018-02-07 00:18:16 +00:00
, canvasSize = Nothing
, preLoop = pre >> smLoad Load
2018-02-07 00:18:16 +00:00
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, loadState = Init.init
2018-06-23 22:43:09 +00:00
, cleanUp = clean
2018-02-07 00:18:16 +00:00
, initScreenMode = SDL.Windowed
}
withAffection config
pre :: Affection UserData ()
pre = do
ad <- A.get
ud <- getAffection
2019-10-28 17:20:34 +00:00
threadCtx <- SDL.glCreateContext (snd $ head $ drawWindows ad)
SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ glContext ad)
2018-10-08 21:36:52 +00:00
let Subsystems w m k j t = subsystems ud
2018-02-07 00:18:16 +00:00
_ <- partSubscribe w (fitViewport (1280/720))
2018-02-18 02:11:41 +00:00
_ <- partSubscribe w exitOnWindowClose
2018-09-18 03:35:40 +00:00
_ <- partSubscribe k toggleFullScreen
_ <- partSubscribe k quitGame
2018-10-12 12:26:06 +00:00
u <- partSubscribe j cacheJoypad
2018-08-10 06:58:26 +00:00
(ws, _) <- yieldSystemT (0, defStorage) (return ())
putAffection ud
2018-07-03 14:19:27 +00:00
{ threadContext = Just threadCtx
2019-10-28 17:20:34 +00:00
, window = Just (snd $ head $ drawWindows ad)
2018-08-10 06:58:26 +00:00
, worldState = ws
2018-10-12 12:26:06 +00:00
, joyUUID = u
}
2018-02-07 00:18:16 +00:00
2018-09-18 03:35:40 +00:00
quitGame :: KeyboardMessage -> Affection UserData ()
quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
2018-09-24 22:13:09 +00:00
| SDL.keysymKeycode sym == SDL.KeycodeEscape = quit
| SDL.keysymKeycode sym == SDL.KeycodeF5 = do
2018-09-21 20:25:23 +00:00
ad <- A.get
ud <- getAffection
2018-09-24 22:13:09 +00:00
when (state ud == Main WorldMap || state ud == Main MindMap) $ do
2018-10-08 21:36:52 +00:00
let Subsystems w m k j t = subsystems ud
2018-09-24 22:13:09 +00:00
mapM_ (partUnSubscribe w) (uuid ud)
mapM_ (partUnSubscribe m) (uuid ud)
mapM_ (partUnSubscribe k) (uuid ud)
2018-10-08 16:54:23 +00:00
mapM_ (partUnSubscribe j) (uuid ud)
2018-10-08 21:36:52 +00:00
mapM_ (partUnSubscribe t) (uuid ud)
2019-10-28 17:20:34 +00:00
SDL.glMakeCurrent
(snd $ head $ drawWindows ad)
(snd $ head $ glContext ad)
2018-09-24 22:13:09 +00:00
(ws, _) <- yieldSystemT (0, defStorage) (return ())
putAffection ud
{ worldState = ws
, state = Load
}
smLoad Load
2018-09-18 03:35:40 +00:00
| otherwise = return ()
quitGame _ = return ()
toggleFullScreen :: KeyboardMessage -> Affection UserData ()
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
| otherwise = return ()
toggleFullScreen _ = return ()
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 ()
2018-06-23 22:43:09 +00:00
clean :: UserData -> IO ()
2018-07-03 14:19:27 +00:00
clean ud =
2018-06-23 22:43:09 +00:00
SDL.glDeleteContext $ fromJust $ threadContext ud