137 lines
4.1 KiB
Haskell
137 lines
4.1 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)
|
|
|
|
import Control.Monad
|
|
import Control.Concurrent.MVar
|
|
import Control.Monad.Trans.Resource (allocate)
|
|
|
|
-- internal imports
|
|
|
|
import Types hiding (draw)
|
|
import StateMachine ()
|
|
import Init
|
|
import Util
|
|
|
|
foreign import ccall unsafe "glewInit"
|
|
glewInit :: IO CInt
|
|
|
|
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
|
|
|
|
main :: IO ()
|
|
main = do
|
|
let config = AffectionConfig
|
|
{ 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
|
|
}
|
|
}
|
|
, SDL.Windowed
|
|
)
|
|
]
|
|
} :: AffectionConfig UserData
|
|
withAffection config
|
|
|
|
pre :: UserData -> Affection ()
|
|
pre ud = do
|
|
ad <- A.get
|
|
let (AffectionWindow awwindow _ _) = head $ drawWindows ad
|
|
threadCtx <- SDL.glCreateContext awwindow
|
|
SDL.glMakeCurrent awwindow (acContext $ head $ glContext ad)
|
|
let Subsystems w _ k j _ = subsystems ud
|
|
_ <- partSubscribe w (fitViewport (1280/720))
|
|
_ <- partSubscribe w (exitOnWindowClose ud)
|
|
_ <- partSubscribe k toggleFullScreen
|
|
_ <- partSubscribe k (quitGame ud)
|
|
u <- partSubscribe j (cacheJoypad ud)
|
|
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
|
void $ liftIO $ swapMVar (threadContext ud) (Just threadCtx)
|
|
void $ liftIO $ swapMVar (window ud) (Just awwindow)
|
|
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
|
|
| SDL.keysymKeycode sym == SDL.KeycodeF5 = do
|
|
ad <- A.get
|
|
curState <- liftIO $ readMVar (state ud)
|
|
when (curState == Main WorldMap || curState == Main MindMap) $ do
|
|
let Subsystems w m k j t = subsystems ud
|
|
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
|
|
SDL.glMakeCurrent
|
|
(awWindow $ head $ drawWindows ad)
|
|
(acContext $ head $ glContext ad)
|
|
(ws, _) <- yieldSystemT (0, defStorage) (return ())
|
|
void $ liftIO $ swapMVar (worldState ud) ws
|
|
void $ liftIO $ swapMVar (state ud) Load
|
|
smLoad Load ud
|
|
| otherwise = return ()
|
|
quitGame _ _ = return ()
|
|
|
|
toggleFullScreen :: KeyboardMessage -> Affection ()
|
|
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
|
|
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
|
|
| otherwise = return ()
|
|
toggleFullScreen _ = return ()
|
|
|
|
update :: UserData -> Double -> Affection ()
|
|
update ud dt = do
|
|
curState <- liftIO $ readMVar (state ud)
|
|
smUpdate curState ud dt
|
|
|
|
draw :: UserData -> Affection ()
|
|
draw ud = do
|
|
curState <- liftIO $ readMVar (state ud)
|
|
liftIO $ beginFrame (nano ud) 1280 720 1
|
|
smDraw curState ud
|
|
liftIO $ endFrame (nano ud)
|
|
|
|
handle :: UserData -> [SDL.EventPayload] -> Affection ()
|
|
handle ud evs = do
|
|
s <- liftIO $ readMVar (state ud)
|
|
smEvent s ud evs
|
|
|
|
exitOnWindowClose :: UserData -> WindowMessage -> Affection ()
|
|
exitOnWindowClose ud (MsgWindowClose _ _) = do
|
|
liftIO $ logIO A.Debug "Window Closed"
|
|
void $ liftIO $ swapMVar (doNextStep ud) False
|
|
exitOnWindowClose _ _ = return ()
|
|
|
|
clean :: UserData -> IO ()
|
|
clean ud = do
|
|
tContext <- readMVar (threadContext ud)
|
|
SDL.glDeleteContext $ fromJust tContext
|