diff options
author | 3gg <3gg@shellblade.net> | 2022-09-17 17:46:27 -0700 |
---|---|---|
committer | 3gg <3gg@shellblade.net> | 2022-09-17 17:46:27 -0700 |
commit | 8f2ec33e8c15e523b2b60d3bfd8e6360313a0657 (patch) | |
tree | 842ebba3752e32fccca644bb44f5c0ea8eb56ad9 /demos | |
parent | 4ce19dca3441d1e079a66e2f3dc55b77a7f0898f (diff) |
2020s update
Diffstat (limited to 'demos')
-rw-r--r-- | demos/pong/Main.hs | 99 | ||||
-rw-r--r-- | demos/pong/Pong.hs | 125 | ||||
-rw-r--r-- | demos/pong/Setup.hs | 1 | ||||
-rw-r--r-- | demos/pong/cabal.project | 2 | ||||
-rw-r--r-- | demos/pong/pong.cabal | 12 |
5 files changed, 124 insertions, 115 deletions
diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs index d0664b7..3563c30 100644 --- a/demos/pong/Main.hs +++ b/demos/pong/Main.hs | |||
@@ -1,79 +1,82 @@ | |||
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 | ||
3 | import Pong | 6 | import Pong |
4 | 7 | import Spear.Game | |
5 | import Spear.Math.AABB | 8 | import Spear.Math.AABB |
6 | import Spear.Math.Spatial2 | 9 | import Spear.Math.Spatial2 |
7 | import Spear.Math.Vector | 10 | import Spear.Math.Vector |
8 | import Spear.Game | ||
9 | import Spear.Window | 11 | import Spear.Window |
10 | 12 | ||
11 | import Data.Maybe (mapMaybe) | ||
12 | import qualified Graphics.Rendering.OpenGL.GL as GL | ||
13 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
14 | |||
15 | data GameState = GameState | 13 | data GameState = GameState |
16 | { wnd :: Window | 14 | { window :: Window, |
17 | , world :: [GameObject] | 15 | world :: [GameObject] |
18 | } | 16 | } |
19 | 17 | ||
20 | main = run | 18 | main = |
21 | $ withWindow (640,480) [] Window (2,0) (Just "Pong") initGame | 19 | withWindow (900, 600) (2, 0) (Just "Pong") initGame $ |
22 | $ loop (Just 30) step | 20 | loop step |
23 | 21 | ||
24 | initGame wnd = do | 22 | initGame :: Window -> Game () GameState |
25 | gameIO $ do | 23 | initGame window = do |
26 | GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0 | 24 | gameIO $ do |
27 | GL.matrixMode $= GL.Modelview 0 | 25 | GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0 |
28 | GL.loadIdentity | 26 | GL.matrixMode $= GL.Modelview 0 |
29 | return $ GameState wnd newWorld | 27 | GL.loadIdentity |
28 | return $ GameState window newWorld | ||
30 | 29 | ||
31 | step :: Elapsed -> Dt -> Game GameState Bool | 30 | step :: Elapsed -> Dt -> Game GameState Bool |
32 | step elapsed dt = do | 31 | step elapsed dt = do |
33 | gs <- getGameState | 32 | --gameIO $ putStrLn "Tick" |
34 | evts <- events (wnd gs) | 33 | gs <- getGameState |
35 | gameIO . process $ evts | 34 | evts <- events (window gs) |
36 | let evts' = translate evts | 35 | gameIO . process $ evts |
37 | modifyGameState $ \ gs -> gs | 36 | let evts' = translate evts |
38 | { world = stepWorld elapsed dt evts' (world gs) } | 37 | modifyGameState $ \gs -> |
39 | getGameState >>= \gs -> gameIO . render $ world gs | 38 | gs |
40 | return (not $ exitRequested evts) | 39 | { world = stepWorld elapsed dt evts' (world gs) |
40 | } | ||
41 | getGameState >>= \gs -> gameIO . render $ world gs | ||
42 | return (not $ exitRequested evts) | ||
41 | 43 | ||
42 | render world = do | 44 | render world = do |
43 | GL.clear [GL.ColorBuffer] | 45 | GL.clear [GL.ColorBuffer] |
44 | mapM_ renderGO world | 46 | mapM_ renderGO world |
45 | swapBuffers | ||
46 | 47 | ||
47 | renderGO :: GameObject -> IO () | 48 | renderGO :: GameObject -> IO () |
48 | renderGO go = do | 49 | renderGO go = do |
49 | let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go | 50 | let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go |
50 | (Vector2 xcenter ycenter) = pos go | 51 | (Vector2 xcenter ycenter) = pos go |
51 | (xmin,ymin,xmax,ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') | 52 | (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') |
52 | GL.preservingMatrix $ do | 53 | GL.preservingMatrix $ do |
53 | GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) | 54 | GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) |
54 | GL.renderPrimitive (GL.TriangleStrip) $ do | 55 | GL.renderPrimitive (GL.TriangleStrip) $ do |
55 | GL.vertex (GL.Vertex2 xmin ymax) | 56 | GL.vertex (GL.Vertex2 xmin ymax) |
56 | GL.vertex (GL.Vertex2 xmin ymin) | 57 | GL.vertex (GL.Vertex2 xmin ymin) |
57 | GL.vertex (GL.Vertex2 xmax ymax) | 58 | GL.vertex (GL.Vertex2 xmax ymax) |
58 | GL.vertex (GL.Vertex2 xmax ymin) | 59 | GL.vertex (GL.Vertex2 xmax ymin) |
59 | 60 | ||
60 | process = mapM_ procEvent | 61 | process = mapM_ procEvent |
62 | |||
61 | procEvent (Resize w h) = do | 63 | procEvent (Resize w h) = do |
62 | GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) | 64 | GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) |
63 | GL.matrixMode $= GL.Projection | 65 | GL.matrixMode $= GL.Projection |
64 | GL.loadIdentity | 66 | GL.loadIdentity |
65 | GL.ortho 0 1 0 1 (-1) 1 | 67 | GL.ortho 0 1 0 1 (-1) 1 |
66 | GL.matrixMode $= GL.Modelview 0 | 68 | GL.matrixMode $= GL.Modelview 0 |
67 | procEvent _ = return () | 69 | procEvent _ = return () |
68 | 70 | ||
69 | translate = mapMaybe translate' | 71 | translate = mapMaybe translate' |
70 | translate' (KeyDown KEY_LEFT) = Just MoveLeft | 72 | |
73 | translate' (KeyDown KEY_LEFT) = Just MoveLeft | ||
71 | translate' (KeyDown KEY_RIGHT) = Just MoveRight | 74 | translate' (KeyDown KEY_RIGHT) = Just MoveRight |
72 | translate' (KeyUp KEY_LEFT) = Just StopLeft | 75 | translate' (KeyUp KEY_LEFT) = Just StopLeft |
73 | translate' (KeyUp KEY_RIGHT) = Just StopRight | 76 | translate' (KeyUp KEY_RIGHT) = Just StopRight |
74 | translate' _ = Nothing | 77 | translate' _ = Nothing |
75 | 78 | ||
76 | exitRequested = any (==(KeyDown KEY_ESC)) | 79 | exitRequested = any (== (KeyDown KEY_ESC)) |
77 | 80 | ||
78 | f2d :: Float -> GL.GLdouble | 81 | f2d :: Float -> GL.GLdouble |
79 | f2d = realToFrac | 82 | f2d = realToFrac |
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs index 1761823..232c69a 100644 --- a/demos/pong/Pong.hs +++ b/demos/pong/Pong.hs | |||
@@ -1,66 +1,64 @@ | |||
1 | module Pong | 1 | module Pong |
2 | ( | 2 | ( GameEvent (..), |
3 | GameEvent(..) | 3 | GameObject, |
4 | , GameObject | 4 | newWorld, |
5 | , newWorld | 5 | stepWorld, |
6 | , stepWorld | 6 | aabb, |
7 | , aabb | 7 | ) |
8 | ) | ||
9 | where | 8 | where |
10 | 9 | ||
10 | import Data.Monoid (mconcat) | ||
11 | import GHC.Float (double2Float) | ||
11 | import Spear.Math.AABB | 12 | import Spear.Math.AABB |
12 | import Spear.Math.Spatial2 | 13 | import Spear.Math.Spatial2 |
13 | import Spear.Math.Vector | 14 | import Spear.Math.Vector |
14 | import Spear.Step | 15 | import Spear.Step |
15 | 16 | ||
16 | import Data.Monoid (mconcat) | ||
17 | import GHC.Float (double2Float) | ||
18 | |||
19 | -- Game events | 17 | -- Game events |
20 | 18 | ||
21 | data GameEvent | 19 | data GameEvent |
22 | = MoveLeft | 20 | = MoveLeft |
23 | | MoveRight | 21 | | MoveRight |
24 | | StopLeft | 22 | | StopLeft |
25 | | StopRight | 23 | | StopRight |
26 | deriving (Eq, Ord) | 24 | deriving (Eq, Ord) |
27 | 25 | ||
28 | -- Game objects | 26 | -- Game objects |
29 | 27 | ||
30 | data GameObject = GameObject | 28 | data GameObject = GameObject |
31 | { aabb :: AABB2 | 29 | { aabb :: AABB2, |
32 | , obj :: Obj2 | 30 | obj :: Obj2, |
33 | , gostep :: Step [GameObject] [GameEvent] GameObject GameObject | 31 | gostep :: Step [GameObject] [GameEvent] GameObject GameObject |
34 | } | 32 | } |
35 | 33 | ||
36 | instance Spatial2 GameObject where | 34 | instance Spatial2 GameObject where |
37 | getObj2 = obj | 35 | getObj2 = obj |
38 | setObj2 s o = s { obj = o } | 36 | setObj2 s o = s {obj = o} |
39 | 37 | ||
40 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | 38 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] |
41 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | 39 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos |
42 | 40 | ||
43 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | 41 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject |
44 | update elapsed dt evts gos go = | 42 | update elapsed dt evts gos go = |
45 | let (go', s') = runStep (gostep go) elapsed dt gos evts go | 43 | let (go', s') = runStep (gostep go) elapsed dt gos evts go |
46 | in go' { gostep = s' } | 44 | in go' {gostep = s'} |
47 | 45 | ||
48 | ballBox :: AABB2 | 46 | ballBox :: AABB2 |
49 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01 | 47 | ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = 0.01 |
50 | 48 | ||
51 | padSize = vec2 0.05 0.02 | 49 | padSize = vec2 0.05 0.02 |
52 | 50 | ||
53 | padBox = AABB2 (-padSize) padSize | 51 | padBox = AABB2 (- padSize) padSize |
54 | 52 | ||
55 | obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) | 53 | obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) |
56 | 54 | ||
57 | ballVelocity = Vector2 0.3 0.3 | 55 | ballVelocity = Vector2 0.3 0.3 |
58 | 56 | ||
59 | newWorld = | 57 | newWorld = |
60 | [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity | 58 | [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity, |
61 | , GameObject padBox (obj2 0.5 0.9) stepEnemy | 59 | GameObject padBox (obj2 0.5 0.9) stepEnemy, |
62 | , GameObject padBox (obj2 0.5 0.1) stepPlayer | 60 | GameObject padBox (obj2 0.5 0.1) stepPlayer |
63 | ] | 61 | ] |
64 | 62 | ||
65 | -- Ball steppers | 63 | -- Ball steppers |
66 | 64 | ||
@@ -68,27 +66,30 @@ stepBall vel = collideBall vel .> moveBall | |||
68 | 66 | ||
69 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) | 67 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) |
70 | collideBall vel = step $ \_ _ gos _ ball -> | 68 | collideBall vel = step $ \_ _ gos _ ball -> |
71 | let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball | 69 | let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball |
72 | collideCol = x pmin < 0 || x pmax > 1 | 70 | collideCol = x pmin < 0 || x pmax > 1 |
73 | collideRow = y pmin < 0 || y pmax > 1 | 71 | collideRow = |
74 | || any (collide ball) (tail gos) | 72 | y pmin < 0 || y pmax > 1 |
75 | negx v@(Vector2 x y) = if collideCol then vec2 (-x) y else v | 73 | || any (collide ball) (tail gos) |
76 | negy v@(Vector2 x y) = if collideRow then vec2 x (-y) else v | 74 | negx v@(Vector2 x y) = if collideCol then vec2 (- x) y else v |
77 | vel' = negx . negy $ vel | 75 | negy v@(Vector2 x y) = if collideRow then vec2 x (- y) else v |
78 | in ((vel', ball), collideBall vel') | 76 | vel' = negx . negy $ vel |
77 | in ((vel', ball), collideBall vel') | ||
79 | 78 | ||
80 | collide go1 go2 = | 79 | collide go1 go2 = |
81 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) | 80 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = |
82 | = aabb go1 `aabbAdd` pos go1 | 81 | aabb go1 `aabbAdd` pos go1 |
83 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) | 82 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = |
84 | = aabb go2 `aabbAdd` pos go2 | 83 | aabb go2 `aabbAdd` pos go2 |
85 | in not $ xmax1 < xmin2 || xmin1 > xmax2 | 84 | in not $ |
86 | || ymax1 < ymin2 || ymin1 > ymax2 | 85 | xmax1 < xmin2 || xmin1 > xmax2 |
86 | || ymax1 < ymin2 | ||
87 | || ymin1 > ymax2 | ||
87 | 88 | ||
88 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) | 89 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax) |
89 | 90 | ||
90 | moveBall :: Step s e (Vector2, GameObject) GameObject | 91 | moveBall :: Step s e (Vector2, GameObject) GameObject |
91 | moveBall = step $ \_ dt _ _ (vel,ball) -> (move (scale dt vel) ball, moveBall) | 92 | moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall) |
92 | 93 | ||
93 | -- Enemy stepper | 94 | -- Enemy stepper |
94 | 95 | ||
@@ -96,32 +97,34 @@ stepEnemy = movePad | |||
96 | 97 | ||
97 | movePad :: Step s e GameObject GameObject | 98 | movePad :: Step s e GameObject GameObject |
98 | movePad = step $ \elapsed _ _ _ pad -> | 99 | movePad = step $ \elapsed _ _ _ pad -> |
99 | let p = vec2 px 0.9 | 100 | let p = vec2 px 0.9 |
100 | px = double2Float (sin elapsed * 0.5 + 0.5) | 101 | px = |
101 | * (1 - 2 * x padSize) | 102 | double2Float (sin elapsed * 0.5 + 0.5) |
102 | + x padSize | 103 | * (1 - 2 * x padSize) |
103 | in (setPos p pad, movePad) | 104 | + x padSize |
105 | in (setPos p pad, movePad) | ||
104 | 106 | ||
105 | -- Player stepper | 107 | -- Player stepper |
106 | 108 | ||
107 | stepPlayer = sfold moveGO .> clamp | 109 | stepPlayer = sfold moveGO .> clamp |
108 | 110 | ||
109 | moveGO = mconcat | 111 | moveGO = |
110 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0) | 112 | mconcat |
111 | , switch StopRight sid MoveRight (moveGO' $ vec2 1 0) | 113 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0), |
112 | ] | 114 | switch StopRight sid MoveRight (moveGO' $ vec2 1 0) |
115 | ] | ||
113 | 116 | ||
114 | moveGO' :: Vector2 -> Step s e GameObject GameObject | 117 | moveGO' :: Vector2 -> Step s e GameObject GameObject |
115 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) | 118 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) |
116 | 119 | ||
117 | clamp :: Step s e GameObject GameObject | 120 | clamp :: Step s e GameObject GameObject |
118 | clamp = spure $ \go -> | 121 | clamp = spure $ \go -> |
119 | let p' = vec2 (clamp' x s (1 - s)) y | 122 | let p' = vec2 (clamp' x s (1 - s)) y |
120 | (Vector2 x y) = pos go | 123 | (Vector2 x y) = pos go |
121 | clamp' x a b = if x < a then a else if x > b then b else x | 124 | clamp' x a b = if x < a then a else if x > b then b else x |
122 | (Vector2 s _) = padSize | 125 | (Vector2 s _) = padSize |
123 | in setPos p' go | 126 | in setPos p' go |
124 | 127 | ||
125 | toDir True MoveLeft = vec2 (-1) 0 | 128 | toDir True MoveLeft = vec2 (-1) 0 |
126 | toDir True MoveRight = vec2 1 0 | 129 | toDir True MoveRight = vec2 1 0 |
127 | toDir _ _ = vec2 0 0 \ No newline at end of file | 130 | toDir _ _ = vec2 0 0 |
diff --git a/demos/pong/Setup.hs b/demos/pong/Setup.hs index 9a994af..e8ef27d 100644 --- a/demos/pong/Setup.hs +++ b/demos/pong/Setup.hs | |||
@@ -1,2 +1,3 @@ | |||
1 | import Distribution.Simple | 1 | import Distribution.Simple |
2 | |||
2 | main = defaultMain | 3 | main = defaultMain |
diff --git a/demos/pong/cabal.project b/demos/pong/cabal.project new file mode 100644 index 0000000..3dc1fca --- /dev/null +++ b/demos/pong/cabal.project | |||
@@ -0,0 +1,2 @@ | |||
1 | packages: . | ||
2 | ../../ | ||
diff --git a/demos/pong/pong.cabal b/demos/pong/pong.cabal index bebedb9..23ada51 100644 --- a/demos/pong/pong.cabal +++ b/demos/pong/pong.cabal | |||
@@ -1,15 +1,15 @@ | |||
1 | -- Initial pong.cabal generated by cabal init. For further documentation, | 1 | -- Initial pong.cabal generated by cabal init. For further documentation, |
2 | -- see http://haskell.org/cabal/users-guide/ | 2 | -- see http://haskell.org/cabal/users-guide/ |
3 | 3 | ||
4 | name: pong | 4 | name: pong |
5 | version: 0.1.0.0 | 5 | version: 0.1.0.0 |
6 | synopsis: A pong clone | 6 | synopsis: A pong clone |
7 | -- description: | 7 | -- description: |
8 | license: BSD3 | 8 | license: BSD3 |
9 | license-file: LICENSE | 9 | license-file: LICENSE |
10 | author: Marc Sunet | 10 | author: Marc Sunet |
11 | -- maintainer: | 11 | -- maintainer: |
12 | -- copyright: | 12 | -- copyright: |
13 | category: Game | 13 | category: Game |
14 | build-type: Simple | 14 | build-type: Simple |
15 | cabal-version: >=1.8 | 15 | cabal-version: >=1.8 |
@@ -17,5 +17,5 @@ cabal-version: >=1.8 | |||
17 | executable pong | 17 | executable pong |
18 | -- hs-source-dirs: src | 18 | -- hs-source-dirs: src |
19 | main-is: Main.hs | 19 | main-is: Main.hs |
20 | -- other-modules: | 20 | -- other-modules: |
21 | build-depends: base ==4.6.*, Spear, OpenGL | 21 | build-depends: base, Spear, OpenGL |