haskelloids/src/Main.hs

94 lines
2.4 KiB
Haskell
Raw Permalink Normal View History

2017-01-03 18:36:01 +00:00
{-# LANGUAGE OverloadedStrings #-}
2016-12-26 21:26:25 +00:00
module Main where
2017-12-19 05:49:41 +00:00
import Affection as A
2016-12-27 22:25:58 +00:00
import qualified SDL
2017-12-16 10:55:30 +00:00
import Linear as L
2016-12-27 22:25:58 +00:00
2017-12-19 21:36:42 +00:00
import NanoVG hiding (V2(..), V4(..))
2017-12-19 05:49:41 +00:00
2020-05-04 19:17:06 +00:00
import Control.Concurrent.MVar
import Control.Monad (when, void)
import Data.String (fromString)
2017-12-19 05:49:41 +00:00
2016-12-31 16:01:24 +00:00
-- internal imports
import Types
2017-12-16 10:55:30 +00:00
import StateMachine ()
import Init
2016-12-31 16:01:24 +00:00
2020-05-04 19:17:06 +00:00
instance Affectionate UserData where
loadState = load
preLoop = (\ud -> pre ud >> smLoad Menu ud)
handleEvents = handle
update = Main.update
draw = Main.draw
cleanUp = \_ -> return ()
hasNextStep = liftIO . readMVar . doNextStep
2016-12-26 21:26:25 +00:00
main :: IO ()
2017-12-16 10:55:30 +00:00
main = do
2017-12-19 05:49:41 +00:00
logIO A.Debug "Starting"
2020-05-04 19:17:06 +00:00
withAffection (AffectionConfig
2017-12-16 10:55:30 +00:00
{ initComponents = All
, windowTitle = "Haskelloids"
2020-05-04 19:17:06 +00:00
, windowConfigs = [
( 0
, SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
, SDL.glColorPrecision = V4 8 8 8 1
}
, SDL.windowResizable = True
2017-12-16 10:55:30 +00:00
}
2020-05-04 19:17:06 +00:00
, SDL.Windowed
)]
} :: AffectionConfig UserData)
2016-12-27 22:25:58 +00:00
2020-05-04 19:17:06 +00:00
pre :: UserData -> Affection ()
pre ud = do
let subs = subsystems ud
2017-12-19 20:53:07 +00:00
liftIO $ logIO A.Debug "Setting global resize event listener"
2018-01-11 07:31:14 +00:00
_ <- partSubscribe (subWindow subs) (fitViewport (800/600))
2017-12-20 23:56:16 +00:00
_ <- partSubscribe (subKeyboard subs) $ \kbdev ->
when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeF -> do
dt <- getDelta
2020-05-04 19:17:06 +00:00
liftIO $ logIO A.Debug $ "FPS: " <> (fromString $ show (1/dt))
SDL.KeycodeO -> toggleScreen 0
2017-12-20 23:56:16 +00:00
_ -> return ()
2017-12-19 20:53:07 +00:00
return ()
2020-05-04 19:17:06 +00:00
update :: UserData -> Double -> Affection ()
update ud sec = do
curstate <- liftIO $ readMVar (state ud)
smUpdate curstate ud sec
2016-12-27 22:25:58 +00:00
2020-05-04 19:17:06 +00:00
handle :: UserData -> [SDL.EventPayload] -> Affection ()
handle ud e = do
let (Subsystems w k) = subsystems ud
void $ consumeSDLEvents w =<< consumeSDLEvents k e
2016-12-28 11:19:45 +00:00
2020-05-04 19:17:06 +00:00
draw :: UserData -> Affection ()
draw ud = do
2017-12-20 23:56:16 +00:00
liftIO $ beginFrame (nano ud) 800 600 1
2020-05-04 19:17:06 +00:00
curstate <- liftIO $ readMVar (state ud)
smDraw curstate ud
drawVignette (nano ud)
2017-12-19 05:49:41 +00:00
liftIO $ endFrame (nano ud)
2017-12-21 12:09:15 +00:00
2020-05-04 19:17:06 +00:00
drawVignette :: Context -> Affection ()
drawVignette ctx =
2017-12-21 12:09:15 +00:00
liftIO $ do
save ctx
beginPath ctx
grad <- boxGradient ctx 200 150 400 300 0 500 (rgba 0 0 0 0) (rgba 0 0 0 255)
rect ctx 0 0 800 600
fillPaint ctx grad
fill ctx
restore ctx