aboutsummaryrefslogtreecommitdiff
path: root/Demos/Pong/Main.hs
blob: c768142cc71dc5c9d00273742a90f7e197794f8c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
module Main where

import           Pong

import           Spear.App
import           Spear.Game
import           Spear.Math.AABB
import           Spear.Math.Matrix4         as Matrix4 hiding (position)
import           Spear.Math.Spatial
import           Spear.Math.Spatial2
import           Spear.Math.Vector
import           Spear.Render.Core.Pipeline
import           Spear.Render.Core.State
import           Spear.Render.Immediate
import           Spear.Window

import           Data.Maybe                 (mapMaybe)


data GameState = GameState
  { window          :: Window
  , renderCoreState :: RenderCoreState
  , immRenderState  :: ImmRenderState
  , viewProjection  :: Matrix4
  , world           :: [GameObject]
  }

app = App step render resize

main =
  withWindow (1920, 1200) (Just "Pong") initGame endGame $
    loop app

initGame :: Window -> Game () GameState
initGame window = do
  (immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState
  return $ GameState window renderCoreState immRenderState Matrix4.id newWorld

endGame :: Game GameState ()
endGame = do
  game <- getGameState
  runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game)

step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
step elapsed dt inputEvents = do
  gs <- getGameState
  let events = translateEvents inputEvents
  modifyGameState $ \gs ->
    gs
      { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs)
      }
  return (not $ exitRequested inputEvents)

render :: Game GameState ()
render = do
  gameState <- getGameState
  immRenderState' <- flip execSubGame (immRenderState gameState) $ do
    immStart
    immSetViewProjectionMatrix (viewProjection gameState)
    -- Clear the background to a different colour than the playable area to make
    -- the latter distinguishable.
    gameIO $ do
      setClearColour (0.2, 0.2, 0.2, 0.0)
      clearBuffers [ColourBuffer]
    render' $ world gameState
    immEnd
  saveGameState $ gameState { immRenderState = immRenderState' }

render' :: [GameObject] -> Game ImmRenderState ()
render' world = do
  immLoadIdentity
  renderBackground
  -- Draw objects.
  immSetColour (vec4 1.0 1.0 1.0 1.0)
  mapM_ renderGO world

renderBackground :: Game ImmRenderState ()
renderBackground =
  let pmin = 0 :: Float
      pmax = 1 :: Float
  in do
    immSetColour (vec4 0.6 0.35 0.6 1.0)
    immDrawQuads2d [
      (vec2 pmin pmin
      ,vec2 pmax pmin
      ,vec2 pmax pmax
      ,vec2 pmin pmax)]

renderGO :: GameObject -> Game ImmRenderState ()
renderGO go = do
  let (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax)) = aabb go
      (Vector2 xcenter ycenter) = position go
  immPreservingMatrix $ do
    immTranslate (vec3 xcenter ycenter 0)
    immDrawQuads2d [
      (vec2 xmin ymin
      ,vec2 xmax ymin
      ,vec2 xmax ymax
      ,vec2 xmin ymax)]

resize :: WindowEvent -> Game GameState ()
resize (ResizeEvent w h) =
  let r = fromIntegral w / fromIntegral h
      pad    = if r > 1 then (r-1) / 2 else (1/r - 1) / 2
      left   = if r > 1 then -pad else 0
      right  = if r > 1 then 1 + pad else 1
      bottom = if r > 1 then 0 else -pad
      top    = if r > 1 then 1 else 1 + pad
  in do
    gameIO $ setViewport 0 0 w h
    modifyGameState $ \state -> state {
      viewProjection = Matrix4.ortho left right bottom top (-1) 1
    }

translateEvents = mapMaybe translateEvents'
  where translateEvents' (KeyDown KEY_A) = Just MoveLeft
        translateEvents' (KeyDown KEY_D) = Just MoveRight
        translateEvents' (KeyUp KEY_A)   = Just StopLeft
        translateEvents' (KeyUp KEY_D)   = Just StopRight
        translateEvents' _               = Nothing

exitRequested = elem (KeyDown KEY_ESC)