diff options
Diffstat (limited to 'Demos/Pong/Main.hs')
| -rw-r--r-- | Demos/Pong/Main.hs | 110 |
1 files changed, 67 insertions, 43 deletions
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs index ac0feab..c82b67e 100644 --- a/Demos/Pong/Main.hs +++ b/Demos/Pong/Main.hs | |||
| @@ -1,31 +1,49 @@ | |||
| 1 | module Main where | 1 | module Main where |
| 2 | 2 | ||
| 3 | import Data.Maybe (mapMaybe) | ||
| 4 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
| 5 | import qualified Graphics.Rendering.OpenGL.GL as GL | ||
| 6 | import Graphics.Rendering.OpenGL.GL.VertexSpec (currentColor) | ||
| 7 | import Pong | 3 | import Pong |
| 4 | |||
| 8 | import Spear.App | 5 | import Spear.App |
| 9 | import Spear.Game | 6 | import Spear.Game |
| 10 | import Spear.Math.AABB | 7 | import Spear.Math.AABB |
| 8 | import Spear.Math.Matrix4 as Matrix4 hiding | ||
| 9 | (position) | ||
| 11 | import Spear.Math.Spatial | 10 | import Spear.Math.Spatial |
| 12 | import Spear.Math.Spatial2 | 11 | import Spear.Math.Spatial2 |
| 13 | import Spear.Math.Vector | 12 | import Spear.Math.Vector |
| 13 | import Spear.Render.Core.Pipeline | ||
| 14 | import Spear.Render.Core.State | ||
| 15 | import Spear.Render.Immediate | ||
| 14 | import Spear.Window | 16 | import Spear.Window |
| 15 | 17 | ||
| 18 | import Data.Maybe (mapMaybe) | ||
| 19 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
| 20 | import qualified Graphics.Rendering.OpenGL.GL as GL | ||
| 21 | import Graphics.Rendering.OpenGL.GL.VertexSpec (currentColor) | ||
| 22 | |||
| 23 | |||
| 16 | data GameState = GameState | 24 | data GameState = GameState |
| 17 | { window :: Window, | 25 | { window :: Window |
| 18 | world :: [GameObject] | 26 | , renderCoreState :: RenderCoreState |
| 27 | , immRenderState :: ImmRenderState | ||
| 28 | , viewProjection :: Matrix4 | ||
| 29 | , world :: [GameObject] | ||
| 19 | } | 30 | } |
| 20 | 31 | ||
| 21 | app = App step render resize | 32 | app = App step render resize |
| 22 | 33 | ||
| 23 | main = | 34 | main = |
| 24 | withWindow (900, 600) (2, 0) (Just "Pong") initGame $ | 35 | withWindow (900, 600) (Just "Pong") initGame endGame $ |
| 25 | loop app | 36 | loop app |
| 26 | 37 | ||
| 27 | initGame :: Window -> Game () GameState | 38 | initGame :: Window -> Game () GameState |
| 28 | initGame window = return $ GameState window newWorld | 39 | initGame window = do |
| 40 | (immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState | ||
| 41 | return $ GameState window renderCoreState immRenderState Matrix4.id newWorld | ||
| 42 | |||
| 43 | endGame :: Game GameState () | ||
| 44 | endGame = do | ||
| 45 | game <- getGameState | ||
| 46 | runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game) | ||
| 29 | 47 | ||
| 30 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool | 48 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool |
| 31 | step elapsed dt inputEvents = do | 49 | step elapsed dt inputEvents = do |
| @@ -38,47 +56,54 @@ step elapsed dt inputEvents = do | |||
| 38 | return (not $ exitRequested inputEvents) | 56 | return (not $ exitRequested inputEvents) |
| 39 | 57 | ||
| 40 | render :: Game GameState () | 58 | render :: Game GameState () |
| 41 | render = getGameState >>= \gs -> gameIO . render' $ world gs | 59 | render = do |
| 60 | gameState <- getGameState | ||
| 61 | immRenderState' <- flip execSubGame (immRenderState gameState) $ do | ||
| 62 | immStart | ||
| 63 | immSetViewProjectionMatrix (viewProjection gameState) | ||
| 64 | -- Clear the background to a different colour than the playable area to make | ||
| 65 | -- the latter distinguishable. | ||
| 66 | gameIO $ do | ||
| 67 | setClearColour (0.2, 0.2, 0.2, 0.0) | ||
| 68 | clearBuffers [ColourBuffer] | ||
| 69 | render' $ world gameState | ||
| 70 | immEnd | ||
| 71 | saveGameState $ gameState { immRenderState = immRenderState' } | ||
| 42 | 72 | ||
| 43 | render' :: [GameObject] -> IO () | 73 | render' :: [GameObject] -> Game ImmRenderState () |
| 44 | render' world = do | 74 | render' world = do |
| 45 | -- Clear the background to a different colour than the playable area to make | 75 | immLoadIdentity |
| 46 | -- the latter distinguishable. | ||
| 47 | GL.clearColor $= GL.Color4 0.2 0.2 0.2 0.0 | ||
| 48 | GL.clear [GL.ColorBuffer] | ||
| 49 | GL.matrixMode $= GL.Modelview 0 | ||
| 50 | GL.loadIdentity | ||
| 51 | renderBackground | 76 | renderBackground |
| 52 | -- Draw objects. | 77 | -- Draw objects. |
| 53 | GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0 | 78 | immSetColour (vec4 1.0 1.0 1.0 1.0) |
| 54 | mapM_ renderGO world | 79 | mapM_ renderGO world |
| 55 | 80 | ||
| 56 | renderBackground :: IO () | 81 | renderBackground :: Game ImmRenderState () |
| 57 | renderBackground = | 82 | renderBackground = |
| 58 | let pmin = 0 :: Float | 83 | let pmin = 0 :: Float |
| 59 | pmax = 1 :: Float | 84 | pmax = 1 :: Float |
| 60 | in do | 85 | in do |
| 61 | GL.currentColor $= GL.Color4 0.7 0.5 0.7 1.0 | 86 | immSetColour (vec4 0.6 0.35 0.6 1.0) |
| 62 | GL.renderPrimitive GL.TriangleStrip $ do | 87 | immDrawQuads2d [ |
| 63 | GL.vertex (GL.Vertex2 pmin pmax) | 88 | (vec2 pmin pmin |
| 64 | GL.vertex (GL.Vertex2 pmin pmin) | 89 | ,vec2 pmax pmin |
| 65 | GL.vertex (GL.Vertex2 pmax pmax) | 90 | ,vec2 pmax pmax |
| 66 | GL.vertex (GL.Vertex2 pmax pmin) | 91 | ,vec2 pmin pmax)] |
| 67 | 92 | ||
| 68 | renderGO :: GameObject -> IO () | 93 | renderGO :: GameObject -> Game ImmRenderState () |
| 69 | renderGO go = do | 94 | renderGO go = do |
| 70 | let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go | 95 | let (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax)) = aabb go |
| 71 | (Vector2 xcenter ycenter) = position go | 96 | (Vector2 xcenter ycenter) = position go |
| 72 | (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') | 97 | immPreservingMatrix $ do |
| 73 | GL.preservingMatrix $ do | 98 | immTranslate (vec3 xcenter ycenter 0) |
| 74 | GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) | 99 | immDrawQuads2d [ |
| 75 | GL.renderPrimitive GL.TriangleStrip $ do | 100 | (vec2 xmin ymin |
| 76 | GL.vertex (GL.Vertex2 xmin ymax) | 101 | ,vec2 xmax ymin |
| 77 | GL.vertex (GL.Vertex2 xmin ymin) | 102 | ,vec2 xmax ymax |
| 78 | GL.vertex (GL.Vertex2 xmax ymax) | 103 | ,vec2 xmin ymax)] |
| 79 | GL.vertex (GL.Vertex2 xmax ymin) | 104 | |
| 80 | 105 | -- TODO: Fix the resize hang. | |
| 81 | resize :: WindowEvent -> Game s () | 106 | resize :: WindowEvent -> Game GameState () |
| 82 | resize (ResizeEvent w h) = | 107 | resize (ResizeEvent w h) = |
| 83 | let r = fromIntegral w / fromIntegral h | 108 | let r = fromIntegral w / fromIntegral h |
| 84 | pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2 | 109 | pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2 |
| @@ -86,12 +111,11 @@ resize (ResizeEvent w h) = | |||
| 86 | right = if r > 1 then 1 + pad else 1 | 111 | right = if r > 1 then 1 + pad else 1 |
| 87 | bottom = if r > 1 then 0 else -pad | 112 | bottom = if r > 1 then 0 else -pad |
| 88 | top = if r > 1 then 1 else 1 + pad | 113 | top = if r > 1 then 1 else 1 + pad |
| 89 | in gameIO $ do | 114 | in do |
| 90 | GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) | 115 | gameIO $ setViewport 0 0 w h |
| 91 | GL.matrixMode $= GL.Projection | 116 | modifyGameState $ \state -> state { |
| 92 | GL.loadIdentity | 117 | viewProjection = Matrix4.ortho left right bottom top (-1) 1 |
| 93 | GL.ortho left right bottom top (-1) 1 | 118 | } |
| 94 | GL.matrixMode $= GL.Modelview 0 | ||
| 95 | 119 | ||
| 96 | translateEvents = mapMaybe translateEvents' | 120 | translateEvents = mapMaybe translateEvents' |
| 97 | where translateEvents' (KeyDown KEY_LEFT) = Just MoveLeft | 121 | where translateEvents' (KeyDown KEY_LEFT) = Just MoveLeft |
