more beautiful fullscreen toggle

haskelloids.cabal

@@ -68,6 +68,7 @@ executable haskelloids
   build-depends:       base >=4.9 && <4.11
                      , affection <= 0.0.0.7
                      , sdl2 >= 2.1.3.1
+                     , OpenGL
                      , containers
                      , random
                      , linear

src/Init.hs

@@ -6,6 +6,8 @@ import Affection as A
 import SDL (($=))
 import qualified SDL
 
+import qualified Graphics.Rendering.OpenGL as GL
+
 import qualified Data.Set as S
 import Data.Maybe
 
@@ -31,16 +33,22 @@ foreign import ccall unsafe "glewInit"
 
 load :: IO UserData
 load = do
+  liftIO $ logIO A.Debug "Let's drop some Hhnts for SDL"
+  SDL.HintRenderDriver $= SDL.OpenGL
   liftIO $ logIO A.Debug "init GLEW"
   _ <- glewInit
   liftIO $ logIO A.Debug "loading state"
   liftIO $ logIO A.Debug "create context"
-  nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
+  nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes])
   liftIO $ logIO A.Debug "load ship image"
   mshipImage <- createImage nvgCtx (FileName "assets/ship.png") 0
   when (isNothing mshipImage) $ do
-    logIO Error "Failed loading image assets"
+    logIO Error "Failed to load asset ship"
     exitFailure
+  mhaskImage <- liftIO $
+    createImage nvgCtx (FileName "assets/haskelloid.png") 0
+  when (isNothing mhaskImage) $
+    liftIO $ logIO Error "Failed to load asset haskelloid"
   mfont <- createFont nvgCtx "modulo" (FileName "assets/Modulo.ttf")
   when (isNothing mfont) $ do
     logIO Error "Failed to load font"
@@ -49,6 +57,9 @@ load = do
   subs <- Subsystems
     <$> (return . Window =<< newTVarIO [])
     <*> (return . Keyboard =<< newTVarIO [])
+  liftIO $ logIO A.Debug "Setting viewport"
+  GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
+  liftIO $ logIO A.Debug "Returning UserData"
   return UserData
     { ship = Ship
       { sPos = V2 400 300
@@ -63,31 +74,5 @@ load = do
     , nano = nvgCtx
     , font = fromJust mfont
     , subsystems = subs
+    , haskImage = fromJust mhaskImage
     }
-
-
-
-  -- _ <- SDL.setMouseLocationMode SDL.RelativeLocation
-  -- GL.depthFunc $= ust GL.Less
-  -- pane <- GL.genObjectName
-  -- GL.BindVertexArrayObject $= Just pane
-  -- verts <- GL.genObejctName
-  -- let vertCoord =
-  --       [ (-1), (-1), 0
-  --       , 1   , (-1), 0
-  --       , (-1), 1   , 0
-  --       , 1   , 1   , 0
-  --       , (-1), 1   , 0
-  --       , 1   , (-1), 0
-  --       ]
-  -- withArray vertCoord $ \ptr
-  --   GL.bufferData GL.ArrayBuffer $=
-  --     ( fromIntegral $ length vertCoord * 3 * sizeOf (0 :: Double)
-  --     , ptr
-  --     , GL.StaticDraw
-  --     )
-  -- GL.vertexAttribPointer (GL.AttribLocation 0) $=
-  --   ( GL.ToFloat
-  --   , GL.VertexArrayDescriptor 4 GL.Float 0 (plusPtr nullPtr 0)
-  --   )
- -- GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled

src/Main.hs

@@ -4,12 +4,13 @@ module Main where
 import Affection as A
 import SDL (($=))
 import qualified SDL
+import qualified Graphics.Rendering.OpenGL as GL
 
 import qualified Data.Map as M
 
 import Linear as L
 
-import NanoVG
+import NanoVG hiding (V2(..))
 
 import Control.Monad.IO.Class (liftIO)
 
@@ -34,13 +35,25 @@ main = do
     , initScreenMode = SDL.Windowed
     , canvasSize     = Nothing
     , loadState      = load
-    , preLoop        = smLoad Menu
+    , 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
+      let nw = floor $ fromIntegral h * (800/600)
+          dw = floor $ (fromIntegral w - fromIntegral nw) / 2
+      GL.viewport $= (GL.Position dw 0, GL.Size nw h)
+    _ -> return ()
+  return ()
+
 update :: Double -> Affection UserData ()
 update sec = do
   ud <- getAffection

src/Menu.hs

@@ -34,11 +34,7 @@ loadMenu :: Affection UserData ()
 loadMenu = do
   liftIO $ logIO A.Debug "Loading Menu"
   ud <- getAffection
-  mhaskImage <- liftIO $
-    createImage (nano ud) (FileName "assets/haskelloid.png") 0
-  when (isNothing mhaskImage) $
-    liftIO $ logIO Error "Failed to load asset haskelloid"
-  hs <- newHaskelloids (fromJust mhaskImage)
+  hs <- newHaskelloids (haskImage ud)
   _ <- partSubscribe (subKeyboard $ subsystems ud)
     (\kbdev -> case SDL.keysymKeycode (msgKbdKeysym kbdev) of
       SDL.KeycodeEscape -> do

src/Types.hs

@@ -22,6 +22,7 @@ data UserData = UserData
   , nano :: Context
   , font :: Font
   , subsystems :: Subsystems
+  , haskImage :: Image
   }
 
 data Ship = Ship