diff options
Diffstat (limited to 'demos')
-rw-r--r-- | demos/pong/Main.hs | 81 | ||||
-rw-r--r-- | demos/pong/Pong.hs | 141 | ||||
-rw-r--r-- | demos/pong/Setup.hs | 3 |
3 files changed, 0 insertions, 225 deletions
diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs deleted file mode 100644 index a9dfcdd..0000000 --- a/demos/pong/Main.hs +++ /dev/null | |||
@@ -1,81 +0,0 @@ | |||
1 | module Main where | ||
2 | |||
3 | import Data.Maybe (mapMaybe) | ||
4 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
5 | import qualified Graphics.Rendering.OpenGL.GL as GL | ||
6 | import Pong | ||
7 | import Spear.App | ||
8 | import Spear.Game | ||
9 | import Spear.Math.AABB | ||
10 | import Spear.Math.Spatial2 | ||
11 | import Spear.Math.Vector | ||
12 | import Spear.Window | ||
13 | |||
14 | data GameState = GameState | ||
15 | { window :: Window, | ||
16 | world :: [GameObject] | ||
17 | } | ||
18 | |||
19 | main = | ||
20 | withWindow (900, 600) (2, 0) (Just "Pong") initGame $ | ||
21 | loop step | ||
22 | |||
23 | initGame :: Window -> Game () GameState | ||
24 | initGame window = do | ||
25 | gameIO $ do | ||
26 | GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0 | ||
27 | GL.matrixMode $= GL.Modelview 0 | ||
28 | GL.loadIdentity | ||
29 | return $ GameState window newWorld | ||
30 | |||
31 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool | ||
32 | step elapsed dt inputEvents = do | ||
33 | gs <- getGameState | ||
34 | gameIO . process $ inputEvents | ||
35 | let events = translate inputEvents | ||
36 | modifyGameState $ \gs -> | ||
37 | gs | ||
38 | { world = stepWorld elapsed dt events (world gs) | ||
39 | } | ||
40 | getGameState >>= \gs -> gameIO . render $ world gs | ||
41 | return (not $ exitRequested inputEvents) | ||
42 | |||
43 | render world = do | ||
44 | GL.clear [GL.ColorBuffer] | ||
45 | mapM_ renderGO world | ||
46 | |||
47 | renderGO :: GameObject -> IO () | ||
48 | renderGO go = do | ||
49 | let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go | ||
50 | (Vector2 xcenter ycenter) = pos go | ||
51 | (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') | ||
52 | GL.preservingMatrix $ do | ||
53 | GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) | ||
54 | GL.renderPrimitive (GL.TriangleStrip) $ do | ||
55 | GL.vertex (GL.Vertex2 xmin ymax) | ||
56 | GL.vertex (GL.Vertex2 xmin ymin) | ||
57 | GL.vertex (GL.Vertex2 xmax ymax) | ||
58 | GL.vertex (GL.Vertex2 xmax ymin) | ||
59 | |||
60 | process = mapM_ procEvent | ||
61 | |||
62 | procEvent (Resize w h) = do | ||
63 | GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) | ||
64 | GL.matrixMode $= GL.Projection | ||
65 | GL.loadIdentity | ||
66 | GL.ortho 0 1 0 1 (-1) 1 | ||
67 | GL.matrixMode $= GL.Modelview 0 | ||
68 | procEvent _ = return () | ||
69 | |||
70 | translate = mapMaybe translate' | ||
71 | |||
72 | translate' (KeyDown KEY_LEFT) = Just MoveLeft | ||
73 | translate' (KeyDown KEY_RIGHT) = Just MoveRight | ||
74 | translate' (KeyUp KEY_LEFT) = Just StopLeft | ||
75 | translate' (KeyUp KEY_RIGHT) = Just StopRight | ||
76 | translate' _ = Nothing | ||
77 | |||
78 | exitRequested = any (== (KeyDown KEY_ESC)) | ||
79 | |||
80 | f2d :: Float -> GL.GLdouble | ||
81 | f2d = realToFrac | ||
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs deleted file mode 100644 index accc75d..0000000 --- a/demos/pong/Pong.hs +++ /dev/null | |||
@@ -1,141 +0,0 @@ | |||
1 | module Pong | ||
2 | ( GameEvent (..), | ||
3 | GameObject, | ||
4 | newWorld, | ||
5 | stepWorld, | ||
6 | aabb, | ||
7 | ) | ||
8 | where | ||
9 | |||
10 | import Data.Monoid (mconcat) | ||
11 | import GHC.Float (double2Float) | ||
12 | import Spear.Math.AABB | ||
13 | import Spear.Math.Spatial2 | ||
14 | import Spear.Math.Vector | ||
15 | import Spear.Step | ||
16 | |||
17 | -- Configuration | ||
18 | |||
19 | padSize = vec2 0.05 0.02 | ||
20 | |||
21 | ballSize = 0.01 | ||
22 | |||
23 | ballVelocity = vec2 0.3 0.3 | ||
24 | |||
25 | playerSpeed = 0.7 | ||
26 | |||
27 | initialEnemyPos = vec2 0.5 0.9 | ||
28 | |||
29 | initialPlayerPos = vec2 0.5 0.1 | ||
30 | |||
31 | initialBallPos = vec2 0.5 0.5 | ||
32 | |||
33 | -- Game events | ||
34 | |||
35 | data GameEvent | ||
36 | = MoveLeft | ||
37 | | MoveRight | ||
38 | | StopLeft | ||
39 | | StopRight | ||
40 | deriving (Eq, Ord) | ||
41 | |||
42 | -- Game objects | ||
43 | |||
44 | data GameObject = GameObject | ||
45 | { aabb :: AABB2, | ||
46 | obj :: Obj2, | ||
47 | gostep :: Step [GameObject] [GameEvent] GameObject GameObject | ||
48 | } | ||
49 | |||
50 | instance Spatial2 GameObject where | ||
51 | getObj2 = obj | ||
52 | setObj2 s o = s {obj = o} | ||
53 | |||
54 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | ||
55 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | ||
56 | |||
57 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | ||
58 | update elapsed dt evts gos go = | ||
59 | let (go', s') = runStep (gostep go) elapsed dt gos evts go | ||
60 | in go' {gostep = s'} | ||
61 | |||
62 | ballBox, padBox :: AABB2 | ||
63 | ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = ballSize | ||
64 | padBox = AABB2 (- padSize) padSize | ||
65 | |||
66 | obj2 = obj2FromVectors unitx2 unity2 | ||
67 | |||
68 | newWorld = | ||
69 | [ GameObject ballBox (obj2 initialBallPos) $ stepBall ballVelocity, | ||
70 | GameObject padBox (obj2 initialEnemyPos) stepEnemy, | ||
71 | GameObject padBox (obj2 initialPlayerPos) stepPlayer | ||
72 | ] | ||
73 | |||
74 | -- Ball steppers | ||
75 | |||
76 | stepBall vel = collideBall vel .> moveBall | ||
77 | |||
78 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) | ||
79 | collideBall vel = step $ \_ dt gos _ ball -> | ||
80 | let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball | ||
81 | collideCol = x pmin < 0 || x pmax > 1 | ||
82 | collideRow = y pmin < 0 || y pmax > 1 || any (collide ball) (tail gos) | ||
83 | negx v@(Vector2 x y) = if collideCol then vec2 (- x) y else v | ||
84 | negy v@(Vector2 x y) = if collideRow then vec2 x (- y) else v | ||
85 | vel' = negx . negy $ vel | ||
86 | delta = dt -- A small delta to apply when collision occurs. | ||
87 | adjustX = if collideCol then scale delta (vec2 (x vel) 0) else vec2 0 0 | ||
88 | adjustY = if collideRow then scale delta (vec2 0 (y vel)) else vec2 0 0 | ||
89 | in ((vel' + adjustX + adjustY, ball), collideBall vel') | ||
90 | |||
91 | collide go1 go2 = | ||
92 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = | ||
93 | aabb go1 `aabbAdd` pos go1 | ||
94 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = | ||
95 | aabb go2 `aabbAdd` pos go2 | ||
96 | in not $ | ||
97 | xmax1 < xmin2 || xmin1 > xmax2 | ||
98 | || ymax1 < ymin2 | ||
99 | || ymin1 > ymax2 | ||
100 | |||
101 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax) | ||
102 | |||
103 | moveBall :: Step s e (Vector2, GameObject) GameObject | ||
104 | moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall) | ||
105 | |||
106 | -- Enemy stepper | ||
107 | |||
108 | stepEnemy = movePad | ||
109 | |||
110 | movePad :: Step s e GameObject GameObject | ||
111 | movePad = step $ \elapsed _ _ _ pad -> | ||
112 | let p = vec2 px 0.9 | ||
113 | px = | ||
114 | double2Float (sin elapsed * 0.5 + 0.5) | ||
115 | * (1 - 2 * x padSize) | ||
116 | + x padSize | ||
117 | in (setPos p pad, movePad) | ||
118 | |||
119 | -- Player stepper | ||
120 | |||
121 | stepPlayer = sfold moveGO .> clamp | ||
122 | |||
123 | moveGO = | ||
124 | mconcat | ||
125 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (- playerSpeed) 0), | ||
126 | switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0) | ||
127 | ] | ||
128 | |||
129 | moveGO' :: Vector2 -> Step s e GameObject GameObject | ||
130 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) | ||
131 | |||
132 | clamp :: Step s e GameObject GameObject | ||
133 | clamp = spure $ \go -> | ||
134 | let p' = vec2 (clamp' x s (1 - s)) y | ||
135 | (Vector2 x y) = pos go | ||
136 | clamp' x a b | ||
137 | | x < a = a | ||
138 | | x > b = b | ||
139 | | otherwise = x | ||
140 | (Vector2 s _) = padSize | ||
141 | in setPos p' go | ||
diff --git a/demos/pong/Setup.hs b/demos/pong/Setup.hs deleted file mode 100644 index e8ef27d..0000000 --- a/demos/pong/Setup.hs +++ /dev/null | |||
@@ -1,3 +0,0 @@ | |||
1 | import Distribution.Simple | ||
2 | |||
3 | main = defaultMain | ||