tracer/src/Main.hs

137 lines
4.1 KiB
Haskell
Raw Permalink 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)
2020-05-05 08:26:16 +00:00
import Control.Monad
import Control.Concurrent.MVar
2022-08-04 16:13:53 +00:00
import Control.Monad.Trans.Resource (allocate)
2018-09-24 22:13:09 +00:00
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
2020-05-05 08:26:16 +00:00
instance Affectionate UserData where
preLoop = (\ud -> pre ud >> smLoad Load ud)
handleEvents = handle
update = Main.update
draw = Main.draw
loadState = Init.init
cleanUp = clean
hasNextStep = liftIO . readMVar . doNextStep
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
2022-09-14 18:10:20 +00:00
{ SDL.windowInitialSize = V2 1920 1080
2019-10-28 17:20:34 +00:00
, SDL.windowResizable = True
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
2020-05-05 08:26:16 +00:00
, SDL.Windowed
2019-10-28 17:20:34 +00:00
)
]
2020-05-05 08:26:16 +00:00
} :: AffectionConfig UserData
2018-02-07 00:18:16 +00:00
withAffection config
2020-05-05 08:26:16 +00:00
pre :: UserData -> Affection ()
pre ud = do
ad <- A.get
2022-08-04 16:13:53 +00:00
let (AffectionWindow awwindow _ _) = head $ drawWindows ad
threadCtx <- SDL.glCreateContext awwindow
SDL.glMakeCurrent awwindow (acContext $ head $ glContext ad)
2020-05-05 08:26:16 +00:00
let Subsystems w _ k j _ = subsystems ud
2022-09-14 18:10:20 +00:00
_ <- partSubscribe w (fitViewport (1920/1080))
2020-05-05 08:26:16 +00:00
_ <- partSubscribe w (exitOnWindowClose ud)
2018-09-18 03:35:40 +00:00
_ <- partSubscribe k toggleFullScreen
2020-05-05 08:26:16 +00:00
_ <- partSubscribe k (quitGame ud)
u <- partSubscribe j (cacheJoypad ud)
2018-08-10 06:58:26 +00:00
(ws, _) <- yieldSystemT (0, defStorage) (return ())
2020-05-05 08:26:16 +00:00
void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx)
2022-08-04 16:13:53 +00:00
void $ liftIO $ swapMVar (window ud) (Just awwindow)
2020-05-05 08:26:16 +00:00
void $ liftIO $ putMVar (worldState ud) ws
void $ liftIO $ putMVar (joyUUID ud) u
quitGame :: UserData -> KeyboardMessage -> Affection ()
quitGame ud (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeEscape =
void $ liftIO $ swapMVar (doNextStep ud) False
2018-09-24 22:13:09 +00:00
| SDL.keysymKeycode sym == SDL.KeycodeF5 = do
2018-09-21 20:25:23 +00:00
ad <- A.get
2020-05-05 08:26:16 +00:00
curState <- liftIO $ readMVar (state ud)
when (curState == Main WorldMap || curState == Main MindMap) $ do
2018-10-08 21:36:52 +00:00
let Subsystems w m k j t = subsystems ud
2020-05-05 08:26:16 +00:00
curUUID <- liftIO $ readMVar (uuid ud)
mapM_ (partUnSubscribe w) curUUID
mapM_ (partUnSubscribe m) curUUID
mapM_ (partUnSubscribe k) curUUID
mapM_ (partUnSubscribe j) curUUID
mapM_ (partUnSubscribe t) curUUID
2019-10-28 17:20:34 +00:00
SDL.glMakeCurrent
2022-08-04 16:13:53 +00:00
(awWindow $ head $ drawWindows ad)
(acContext $ head $ glContext ad)
2018-09-24 22:13:09 +00:00
(ws, _) <- yieldSystemT (0, defStorage) (return ())
2020-05-05 08:26:16 +00:00
void $ liftIO $ swapMVar (worldState ud) ws
void $ liftIO $ swapMVar (state ud) Load
smLoad Load ud
| otherwise = return ()
quitGame _ _ = return ()
toggleFullScreen :: KeyboardMessage -> Affection ()
2018-09-18 03:35:40 +00:00
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
2020-05-05 08:26:16 +00:00
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
2018-09-18 03:35:40 +00:00
| otherwise = return ()
toggleFullScreen _ = return ()
2020-05-05 08:26:16 +00:00
update :: UserData -> Double -> Affection ()
update ud dt = do
curState <- liftIO $ readMVar (state ud)
smUpdate curState ud dt
2018-02-07 00:18:16 +00:00
2020-05-05 08:26:16 +00:00
draw :: UserData -> Affection ()
draw ud = do
curState <- liftIO $ readMVar (state ud)
2018-02-07 00:18:16 +00:00
liftIO $ beginFrame (nano ud) 1280 720 1
2020-05-05 08:26:16 +00:00
smDraw curState ud
2018-02-07 00:18:16 +00:00
liftIO $ endFrame (nano ud)
2020-05-05 08:26:16 +00:00
handle :: UserData -> [SDL.EventPayload] -> Affection ()
handle ud evs = do
s <- liftIO $ readMVar (state ud)
smEvent s ud evs
2018-02-07 00:18:16 +00:00
2020-05-05 08:26:16 +00:00
exitOnWindowClose :: UserData -> WindowMessage -> Affection ()
exitOnWindowClose ud (MsgWindowClose _ _) = do
2018-02-07 00:18:16 +00:00
liftIO $ logIO A.Debug "Window Closed"
2020-05-05 08:26:16 +00:00
void $ liftIO $ swapMVar (doNextStep ud) False
exitOnWindowClose _ _ = return ()
2018-06-23 22:43:09 +00:00
clean :: UserData -> IO ()
2020-05-05 08:26:16 +00:00
clean ud = do
tContext <- readMVar (threadContext ud)
SDL.glDeleteContext $ fromJust tContext