{-# 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