haskelloids/src/Main.hs

94 lines
2.4 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Main where
import Affection as A
import qualified SDL
import Linear as L
import NanoVG hiding (V2(..), V4(..))
import Control.Concurrent.MVar
import Control.Monad (when, void)
import Data.String (fromString)
-- internal imports
import Types
import StateMachine ()
import Init
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
main :: IO ()
main = do
logIO A.Debug "Starting"
withAffection (AffectionConfig
{ initComponents = All
, windowTitle = "Haskelloids"
, 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
}
, SDL.Windowed
)]
} :: AffectionConfig UserData)
pre :: UserData -> Affection ()
pre ud = do
let subs = subsystems ud
liftIO $ logIO A.Debug "Setting global resize event listener"
_ <- partSubscribe (subWindow subs) (fitViewport (800/600))
_ <- partSubscribe (subKeyboard subs) $ \kbdev ->
when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeF -> do
dt <- getDelta
liftIO $ logIO A.Debug $ "FPS: " <> (fromString $ show (1/dt))
SDL.KeycodeO -> toggleScreen 0
_ -> return ()
return ()
update :: UserData -> Double -> Affection ()
update ud sec = do
curstate <- liftIO $ readMVar (state ud)
smUpdate curstate ud sec
handle :: UserData -> [SDL.EventPayload] -> Affection ()
handle ud e = do
let (Subsystems w k) = subsystems ud
void $ consumeSDLEvents w =<< consumeSDLEvents k e
draw :: UserData -> Affection ()
draw ud = do
liftIO $ beginFrame (nano ud) 800 600 1
curstate <- liftIO $ readMVar (state ud)
smDraw curstate ud
drawVignette (nano ud)
liftIO $ endFrame (nano ud)
drawVignette :: Context -> Affection ()
drawVignette ctx =
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