haskelloids/src/Main.hs
2017-12-22 09:02:20 +01:00

98 lines
2.7 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Main where
import Affection as A
import SDL (($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import Linear as L
import NanoVG hiding (V2(..), V4(..))
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
-- internal imports
import Types
import StateMachine ()
import Init
main :: IO ()
main = do
logIO A.Debug "Starting"
withAffection AffectionConfig
{ initComponents = All
, windowTitle = "Haskelloids"
, windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
, SDL.glColorPrecision = V4 8 8 8 1
}
}
, initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre >> smLoad Menu
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = \_ -> return ()
}
pre :: Affection UserData ()
pre = do
subs <- subsystems <$> getAffection
liftIO $ logIO A.Debug "Setting global resize event listener"
_ <- partSubscribe (subWindow subs) $ \msg -> case msg of
MsgWindowResize _ _ (V2 w h) -> do
liftIO $ logIO A.Debug "Window has been resized"
let nw = floor (fromIntegral h * (800/600) :: Double)
dw = floor ((fromIntegral w - fromIntegral nw) / 2 :: Double)
GL.viewport $= (GL.Position dw 0, GL.Size nw h)
_ -> return ()
_ <- 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: " ++ show (1/dt)
SDL.KeycodeO -> toggleScreen
_ -> return ()
return ()
update :: Double -> Affection UserData ()
update sec = do
ud <- getAffection
smUpdate (state ud) sec
handle :: [SDL.EventPayload] -> Affection UserData ()
handle e = do
(Subsystems w k) <- subsystems <$> getAffection
_ <- consumeSDLEvents w =<< consumeSDLEvents k e
return ()
draw :: Affection UserData ()
draw = do
ud <- getAffection
-- window <- drawWindow <$> get
-- pf <- liftIO $ SDL.getWindowPixelFormat window
-- liftIO $ logIO A.Debug $ "Window pixel format: " ++ show pf
liftIO $ beginFrame (nano ud) 800 600 1
smDraw (state ud)
drawVignette
liftIO $ endFrame (nano ud)
drawVignette :: Affection UserData ()
drawVignette = do
ctx <- nano <$> getAffection
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