more beautiful fullscreen toggle

This commit is contained in:
nek0 2017-12-19 21:53:07 +01:00
parent adda5d3dc4
commit a43f9699d6
5 changed files with 33 additions and 37 deletions

View file

@ -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

View file

@ -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

View file

@ -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)
@ -28,19 +29,31 @@ main = do
, windowTitle = "Haskelloids"
, windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
, 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

View file

@ -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

View file

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