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
|