diff options
40 files changed, 1420 insertions, 779 deletions
diff --git a/Demos/Balls/Main.hs b/Demos/Balls/Main.hs new file mode 100644 index 0000000..d266d85 --- /dev/null +++ b/Demos/Balls/Main.hs | |||
@@ -0,0 +1,176 @@ | |||
1 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
2 | --{-# LANGUAGE NoImplicitPrelude #-} | ||
3 | {-# LANGUAGE FlexibleContexts #-} | ||
4 | {-# LANGUAGE TypeSynonymInstances #-} | ||
5 | |||
6 | module Main where | ||
7 | |||
8 | import Spear.App | ||
9 | import Spear.Game | ||
10 | import Spear.Math.AABB | ||
11 | import qualified Spear.Math.Matrix3 as Matrix3 | ||
12 | import qualified Spear.Math.Matrix4 as Matrix4 | ||
13 | import Spear.Math.Spatial | ||
14 | import Spear.Math.Spatial2 | ||
15 | import Spear.Math.Vector | ||
16 | import Spear.Physics.Collision | ||
17 | --import Spear.Prelude | ||
18 | import Spear.Render.Core.Pipeline | ||
19 | import Spear.Render.Core.State | ||
20 | import Spear.Render.Immediate | ||
21 | import Spear.Sound.Sound | ||
22 | import Spear.Sound.State | ||
23 | import Spear.Window | ||
24 | |||
25 | import Control.Monad (when) | ||
26 | |||
27 | |||
28 | ballSize = 0.01 | ||
29 | numBalls = 1000 | ||
30 | |||
31 | data Ball = Ball | ||
32 | { ballPosition :: {-# UNPACK #-} !Vector2 | ||
33 | , ballVelocity :: {-# UNPACK #-} !Vector2 | ||
34 | } | ||
35 | |||
36 | instance Positional Ball Vector2 where | ||
37 | setPosition p ball = ball { ballPosition = p } | ||
38 | position = ballPosition | ||
39 | translate v ball = ball { ballPosition = v + ballPosition ball } | ||
40 | |||
41 | instance Bounded2 Ball where | ||
42 | boundingVolume ball = aabb2Volume $ translate (ballPosition ball) (AABB2 (-size) size) | ||
43 | where size = vec2 s s | ||
44 | s = ballSize / (2::Float) | ||
45 | |||
46 | data World = World | ||
47 | { viewProjection :: Matrix4.Matrix4 | ||
48 | , balls :: [Ball] | ||
49 | } | ||
50 | |||
51 | type GameState = AppState World | ||
52 | |||
53 | |||
54 | options = defaultAppOptions { title = "Balls" } | ||
55 | |||
56 | app = App options initGame endGame step render resize | ||
57 | |||
58 | |||
59 | main :: IO () | ||
60 | main = runApp app | ||
61 | |||
62 | initGame :: Game AppContext World | ||
63 | initGame = | ||
64 | let | ||
65 | world = zipWith Ball positions velocities | ||
66 | positions = (+vec2 0.5 0.5) . makePosition <$> numbers | ||
67 | makePosition i = radius * vec2 (sin (f*i)) (cos (f*i)) | ||
68 | velocities = makeVelocity <$> numbers | ||
69 | makeVelocity i = scale speed $ vec2 (sin (f*i)) (cos (f*i)) | ||
70 | numbers = [1..numBalls] | ||
71 | f = 2*pi / numBalls | ||
72 | radius = 0.05 | ||
73 | speed = 0.4 | ||
74 | in | ||
75 | return $ World Matrix4.id world | ||
76 | |||
77 | endGame :: Game GameState () | ||
78 | endGame = return () | ||
79 | |||
80 | |||
81 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool | ||
82 | step elapsed dt inputEvents = do | ||
83 | modifyGameState $ \world -> world | ||
84 | { balls = moveBalls dt $ balls world | ||
85 | } | ||
86 | return (not $ exitRequested inputEvents) | ||
87 | |||
88 | exitRequested = elem (KeyDown KEY_ESC) | ||
89 | |||
90 | moveBalls :: Elapsed -> [Ball] -> [Ball] | ||
91 | moveBalls dt = (bounceBall dt . moveBall dt <$>) | ||
92 | |||
93 | moveBall :: Elapsed -> Ball -> Ball | ||
94 | moveBall dt ball = translate (scale (realToFrac dt) $ ballVelocity ball) ball | ||
95 | |||
96 | bounceBall :: Elapsed -> Ball -> Ball | ||
97 | bounceBall dt ball = | ||
98 | let | ||
99 | (AABB2Volume (AABB2 pmin pmax)) = boundingVolume ball | ||
100 | sideCollision = x pmin < 0 || x pmax > 1 | ||
101 | backCollision = y pmin < 0 || y pmax > 1 | ||
102 | flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v | ||
103 | flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v | ||
104 | velocity = ballVelocity ball | ||
105 | velocity' | ||
106 | = flipX | ||
107 | . flipY | ||
108 | $ velocity | ||
109 | collision = velocity' /= velocity | ||
110 | -- Apply offset when collision occurs to avoid sticky collisions. | ||
111 | delta = if collision then 1 else 0 | ||
112 | dt' = realToFrac dt | ||
113 | in | ||
114 | ball | ||
115 | { ballPosition = ballPosition ball + scale (delta * dt') velocity' | ||
116 | , ballVelocity = velocity' | ||
117 | } | ||
118 | |||
119 | |||
120 | render :: Game GameState () | ||
121 | render = do | ||
122 | gameState <- getGameState | ||
123 | siblingGame $ do | ||
124 | immStart | ||
125 | immSetViewProjectionMatrix (viewProjection gameState) | ||
126 | -- Clear the background to a different colour than the playable area to make | ||
127 | -- the latter distinguishable. | ||
128 | setClearColour (0.2, 0.2, 0.2, 0.0) | ||
129 | clearBuffers [ColourBuffer] | ||
130 | render' $ balls gameState | ||
131 | immEnd | ||
132 | |||
133 | render' :: [Ball] -> Game ImmRenderState () | ||
134 | render' balls = do | ||
135 | immLoadIdentity | ||
136 | renderBackground | ||
137 | -- Draw objects. | ||
138 | immSetColour (vec4 1.0 1.0 1.0 1.0) | ||
139 | mapM_ renderBall balls | ||
140 | |||
141 | renderBackground :: Game ImmRenderState () | ||
142 | renderBackground = | ||
143 | let pmin = 0 :: Float | ||
144 | pmax = 1 :: Float | ||
145 | in do | ||
146 | immSetColour (vec4 0.0 0.25 0.41 1.0) | ||
147 | immDrawQuads2d [ | ||
148 | (vec2 pmin pmin | ||
149 | ,vec2 pmax pmin | ||
150 | ,vec2 pmax pmax | ||
151 | ,vec2 pmin pmax)] | ||
152 | |||
153 | renderBall :: Ball -> Game ImmRenderState () | ||
154 | renderBall ball = | ||
155 | let (AABB2Volume (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax))) = boundingVolume ball | ||
156 | in | ||
157 | immDrawQuads2d [ | ||
158 | (vec2 xmin ymin | ||
159 | ,vec2 xmax ymin | ||
160 | ,vec2 xmax ymax | ||
161 | ,vec2 xmin ymax)] | ||
162 | |||
163 | |||
164 | resize :: WindowEvent -> Game GameState () | ||
165 | resize (ResizeEvent w h) = | ||
166 | let r = fromIntegral w / fromIntegral h | ||
167 | pad = if r > 1 then (r-1) / 2 else (1/r - 1) / 2 | ||
168 | left = if r > 1 then -pad else 0 | ||
169 | right = if r > 1 then 1 + pad else 1 | ||
170 | bottom = if r > 1 then 0 else -pad | ||
171 | top = if r > 1 then 1 else 1 + pad | ||
172 | in do | ||
173 | setViewport 0 0 w h | ||
174 | modifyGameState $ \pong -> pong { | ||
175 | viewProjection = Matrix4.ortho left right bottom top (-1) 1 | ||
176 | } | ||
diff --git a/Demos/Pong/Main.hs b/Demos/Pong/Main.hs index 0237a26..22b1021 100644 --- a/Demos/Pong/Main.hs +++ b/Demos/Pong/Main.hs | |||
@@ -1,3 +1,5 @@ | |||
1 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
2 | |||
1 | module Main where | 3 | module Main where |
2 | 4 | ||
3 | import Pong | 5 | import Pong |
@@ -5,66 +7,85 @@ import Pong | |||
5 | import Spear.App | 7 | import Spear.App |
6 | import Spear.Game | 8 | import Spear.Game |
7 | import Spear.Math.AABB | 9 | import Spear.Math.AABB |
8 | import Spear.Math.Matrix4 as Matrix4 hiding (position) | 10 | import Spear.Math.Matrix4 as Matrix4 |
9 | import Spear.Math.Spatial | 11 | import Spear.Math.Spatial |
10 | import Spear.Math.Spatial2 | 12 | import Spear.Math.Spatial2 |
11 | import Spear.Math.Vector | 13 | import Spear.Math.Vector |
14 | import Spear.Physics.Collision | ||
12 | import Spear.Render.Core.Pipeline | 15 | import Spear.Render.Core.Pipeline |
13 | import Spear.Render.Core.State | 16 | import Spear.Render.Core.State |
14 | import Spear.Render.Immediate | 17 | import Spear.Render.Immediate |
18 | import Spear.Sound.Sound | ||
19 | import Spear.Sound.State | ||
15 | import Spear.Window | 20 | import Spear.Window |
16 | 21 | ||
17 | import Data.Maybe (mapMaybe) | 22 | import Control.Monad (when) |
18 | 23 | ||
19 | 24 | ||
20 | data GameState = GameState | 25 | data Pong = Pong |
21 | { window :: Window | 26 | { viewProjection :: Matrix4 |
22 | , renderCoreState :: RenderCoreState | 27 | , backgroundMusic :: SoundSource |
23 | , immRenderState :: ImmRenderState | ||
24 | , viewProjection :: Matrix4 | ||
25 | , world :: [GameObject] | 28 | , world :: [GameObject] |
26 | } | 29 | } |
27 | 30 | ||
28 | app = App step render resize | 31 | type GameState = AppState Pong |
32 | |||
33 | |||
34 | options = defaultAppOptions { title = "Pong" } | ||
35 | |||
36 | app = App options initGame endGame step render resize | ||
29 | 37 | ||
30 | main = | ||
31 | withWindow (900, 600) (Just "Pong") initGame endGame $ | ||
32 | loop app | ||
33 | 38 | ||
34 | initGame :: Window -> Game () GameState | 39 | main :: IO () |
35 | initGame window = do | 40 | main = runApp app |
36 | (immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState | 41 | |
37 | return $ GameState window renderCoreState immRenderState Matrix4.id newWorld | 42 | initGame :: Game AppContext Pong |
43 | initGame = do | ||
44 | music <- siblingGame $ do | ||
45 | musicBuffer <- loadAudioFile "/home/jeanne/Casual Tiki Party Main.wav" | ||
46 | music <- makeSoundSource | ||
47 | setSoundSourceBuffer music musicBuffer | ||
48 | setSoundLoopMode music Loop | ||
49 | playSounds [music] | ||
50 | return music | ||
51 | return $ Pong Matrix4.id music newWorld | ||
38 | 52 | ||
39 | endGame :: Game GameState () | 53 | endGame :: Game GameState () |
40 | endGame = do | 54 | endGame = return () |
41 | game <- getGameState | 55 | |
42 | runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game) | ||
43 | 56 | ||
44 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool | 57 | step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool |
45 | step elapsed dt inputEvents = do | 58 | step elapsed dt inputEvents = do |
46 | gs <- getGameState | 59 | appState <- get |
47 | let events = translateEvents inputEvents | 60 | gameState <- getGameState |
48 | modifyGameState $ \gs -> | 61 | events <- processInput (appWindow appState) |
49 | gs | 62 | --when (events /= []) $ liftIO . putStrLn $ show events |
50 | { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gs) | 63 | modifyGameState $ \pong -> pong |
51 | } | 64 | { world = stepWorld (realToFrac elapsed) (realToFrac dt) events (world gameState) |
65 | } | ||
52 | return (not $ exitRequested inputEvents) | 66 | return (not $ exitRequested inputEvents) |
53 | 67 | ||
68 | processInput :: Window -> Game GameState [GameEvent] | ||
69 | processInput window = processKeys window | ||
70 | [ (KEY_A, MoveLeft) | ||
71 | , (KEY_D, MoveRight) | ||
72 | ] | ||
73 | |||
74 | exitRequested = elem (KeyDown KEY_ESC) | ||
75 | |||
76 | |||
54 | render :: Game GameState () | 77 | render :: Game GameState () |
55 | render = do | 78 | render = do |
56 | gameState <- getGameState | 79 | gameState <- getGameState |
57 | immRenderState' <- flip execSubGame (immRenderState gameState) $ do | 80 | siblingGame $ do |
58 | immStart | 81 | immStart |
59 | immSetViewProjectionMatrix (viewProjection gameState) | 82 | immSetViewProjectionMatrix (viewProjection gameState) |
60 | -- Clear the background to a different colour than the playable area to make | 83 | -- Clear the background to a different colour than the playable area to make |
61 | -- the latter distinguishable. | 84 | -- the latter distinguishable. |
62 | gameIO $ do | 85 | setClearColour (0.2, 0.2, 0.2, 0.0) |
63 | setClearColour (0.2, 0.2, 0.2, 0.0) | 86 | clearBuffers [ColourBuffer] |
64 | clearBuffers [ColourBuffer] | ||
65 | render' $ world gameState | 87 | render' $ world gameState |
66 | immEnd | 88 | immEnd |
67 | saveGameState $ gameState { immRenderState = immRenderState' } | ||
68 | 89 | ||
69 | render' :: [GameObject] -> Game ImmRenderState () | 90 | render' :: [GameObject] -> Game ImmRenderState () |
70 | render' world = do | 91 | render' world = do |
@@ -79,7 +100,7 @@ renderBackground = | |||
79 | let pmin = 0 :: Float | 100 | let pmin = 0 :: Float |
80 | pmax = 1 :: Float | 101 | pmax = 1 :: Float |
81 | in do | 102 | in do |
82 | immSetColour (vec4 0.6 0.35 0.6 1.0) | 103 | immSetColour (vec4 0.0 0.25 0.41 1.0) |
83 | immDrawQuads2d [ | 104 | immDrawQuads2d [ |
84 | (vec2 pmin pmin | 105 | (vec2 pmin pmin |
85 | ,vec2 pmax pmin | 106 | ,vec2 pmax pmin |
@@ -87,18 +108,16 @@ renderBackground = | |||
87 | ,vec2 pmin pmax)] | 108 | ,vec2 pmin pmax)] |
88 | 109 | ||
89 | renderGO :: GameObject -> Game ImmRenderState () | 110 | renderGO :: GameObject -> Game ImmRenderState () |
90 | renderGO go = do | 111 | renderGO go = |
91 | let (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax)) = aabb go | 112 | let (AABB2Volume (AABB2 (Vector2 xmin ymin) (Vector2 xmax ymax))) = boundingVolume go |
92 | (Vector2 xcenter ycenter) = position go | 113 | in |
93 | immPreservingMatrix $ do | ||
94 | immTranslate (vec3 xcenter ycenter 0) | ||
95 | immDrawQuads2d [ | 114 | immDrawQuads2d [ |
96 | (vec2 xmin ymin | 115 | (vec2 xmin ymin |
97 | ,vec2 xmax ymin | 116 | ,vec2 xmax ymin |
98 | ,vec2 xmax ymax | 117 | ,vec2 xmax ymax |
99 | ,vec2 xmin ymax)] | 118 | ,vec2 xmin ymax)] |
100 | 119 | ||
101 | -- TODO: Fix the resize hang. | 120 | |
102 | resize :: WindowEvent -> Game GameState () | 121 | resize :: WindowEvent -> Game GameState () |
103 | resize (ResizeEvent w h) = | 122 | resize (ResizeEvent w h) = |
104 | let r = fromIntegral w / fromIntegral h | 123 | let r = fromIntegral w / fromIntegral h |
@@ -108,16 +127,7 @@ resize (ResizeEvent w h) = | |||
108 | bottom = if r > 1 then 0 else -pad | 127 | bottom = if r > 1 then 0 else -pad |
109 | top = if r > 1 then 1 else 1 + pad | 128 | top = if r > 1 then 1 else 1 + pad |
110 | in do | 129 | in do |
111 | gameIO $ setViewport 0 0 w h | 130 | setViewport 0 0 w h |
112 | modifyGameState $ \state -> state { | 131 | modifyGameState $ \pong -> pong { |
113 | viewProjection = Matrix4.ortho left right bottom top (-1) 1 | 132 | viewProjection = Matrix4.ortho left right bottom top (-1) 1 |
114 | } | 133 | } |
115 | |||
116 | translateEvents = mapMaybe translateEvents' | ||
117 | where translateEvents' (KeyDown KEY_LEFT) = Just MoveLeft | ||
118 | translateEvents' (KeyDown KEY_RIGHT) = Just MoveRight | ||
119 | translateEvents' (KeyUp KEY_LEFT) = Just StopLeft | ||
120 | translateEvents' (KeyUp KEY_RIGHT) = Just StopRight | ||
121 | translateEvents' _ = Nothing | ||
122 | |||
123 | exitRequested = elem (KeyDown KEY_ESC) | ||
diff --git a/Demos/Pong/Pong.hs b/Demos/Pong/Pong.hs index 104a92e..0df05ea 100644 --- a/Demos/Pong/Pong.hs +++ b/Demos/Pong/Pong.hs | |||
@@ -3,12 +3,11 @@ | |||
3 | {-# LANGUAGE TypeSynonymInstances #-} | 3 | {-# LANGUAGE TypeSynonymInstances #-} |
4 | 4 | ||
5 | module Pong | 5 | module Pong |
6 | ( GameEvent (..), | 6 | ( GameEvent (..) |
7 | GameObject, | 7 | , GameObject |
8 | newWorld, | 8 | , newWorld |
9 | stepWorld, | 9 | , stepWorld |
10 | aabb, | 10 | ) |
11 | ) | ||
12 | where | 11 | where |
13 | 12 | ||
14 | import Spear.Math.AABB | 13 | import Spear.Math.AABB |
@@ -16,21 +15,23 @@ import Spear.Math.Algebra | |||
16 | import Spear.Math.Spatial | 15 | import Spear.Math.Spatial |
17 | import Spear.Math.Spatial2 | 16 | import Spear.Math.Spatial2 |
18 | import Spear.Math.Vector | 17 | import Spear.Math.Vector |
18 | import Spear.Physics.Collision | ||
19 | import Spear.Prelude | 19 | import Spear.Prelude |
20 | import Spear.Step | 20 | import Spear.Step |
21 | 21 | ||
22 | import Data.Monoid (mconcat) | 22 | import Data.Monoid (mconcat) |
23 | 23 | ||
24 | 24 | ||
25 | -- Configuration | 25 | -- Configuration |
26 | 26 | ||
27 | padSize = vec2 0.07 0.02 | 27 | padSize = vec2 0.070 0.015 |
28 | ballSize = 0.012 :: Float | 28 | ballSize = vec2 0.012 0.012 |
29 | ballSpeed = 0.6 :: Float | 29 | ballSpeed = 0.7 :: Float |
30 | initialBallVelocity = vec2 1 1 | 30 | initialBallVelocity = vec2 1 1 |
31 | maxBounceAngle = (65::Float) * (pi::Float)/(180::Float) | 31 | maxBounceAngle = (65::Float) * (pi::Float)/(180::Float) |
32 | playerSpeed = 1.0 :: Float | 32 | playerSpeed = 1.0 :: Float |
33 | enemySpeed = 3.0 :: Float | 33 | enemySpeed = 7.0 :: Float |
34 | enemyMomentum = 1.0 :: Float | ||
34 | initialEnemyPos = vec2 0.5 0.9 | 35 | initialEnemyPos = vec2 0.5 0.9 |
35 | initialPlayerPos = vec2 0.5 0.1 | 36 | initialPlayerPos = vec2 0.5 0.1 |
36 | initialBallPos = vec2 0.5 0.5 | 37 | initialBallPos = vec2 0.5 0.5 |
@@ -40,16 +41,22 @@ initialBallPos = vec2 0.5 0.5 | |||
40 | data GameEvent | 41 | data GameEvent |
41 | = MoveLeft | 42 | = MoveLeft |
42 | | MoveRight | 43 | | MoveRight |
43 | | StopLeft | 44 | | Collision GameObjectId GameObjectId |
44 | | StopRight | 45 | deriving (Eq, Show) |
45 | deriving (Eq, Ord) | ||
46 | 46 | ||
47 | -- Game objects | 47 | -- Game objects |
48 | 48 | ||
49 | data GameObjectId | ||
50 | = Ball | ||
51 | | Enemy | ||
52 | | Player | ||
53 | deriving (Eq, Show) | ||
54 | |||
49 | data GameObject = GameObject | 55 | data GameObject = GameObject |
50 | { aabb :: AABB2, | 56 | { gameObjectId :: !GameObjectId |
51 | basis :: Transform2, | 57 | , gameObjectSize :: {-# UNPACK #-} !Vector2 |
52 | gostep :: Step [GameObject] [GameEvent] GameObject GameObject | 58 | , basis :: {-# UNPACK #-} !Transform2 |
59 | , gostep :: Step [GameObject] [GameEvent] GameObject GameObject | ||
53 | } | 60 | } |
54 | 61 | ||
55 | 62 | ||
@@ -79,108 +86,113 @@ instance Spatial GameObject Vector2 Angle Transform2 where | |||
79 | transform = basis | 86 | transform = basis |
80 | 87 | ||
81 | 88 | ||
82 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | 89 | instance Bounded2 GameObject where |
83 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | 90 | boundingVolume obj = aabb2Volume $ translate (position obj) (AABB2 (-size) size) |
84 | 91 | where size = gameObjectSize obj | |
85 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | ||
86 | update elapsed dt evts gos go = | ||
87 | let (go', s') = runStep (gostep go) elapsed dt gos evts go | ||
88 | in go' {gostep = s'} | ||
89 | 92 | ||
90 | ballBox, padBox :: AABB2 | ||
91 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize | ||
92 | padBox = AABB2 (-padSize) padSize | ||
93 | 93 | ||
94 | newWorld = | 94 | newWorld = |
95 | [ GameObject ballBox (makeAt initialBallPos) $ stepBall initialBallVelocity, | 95 | [ GameObject Ball ballSize (makeAt initialBallPos) $ stepBall initialBallVelocity, |
96 | GameObject padBox (makeAt initialEnemyPos) stepEnemy, | 96 | GameObject Enemy padSize (makeAt initialEnemyPos) stepEnemy, |
97 | GameObject padBox (makeAt initialPlayerPos) stepPlayer | 97 | GameObject Player padSize (makeAt initialPlayerPos) stepPlayer |
98 | ] | 98 | ] |
99 | where makeAt = newTransform2 unitx2 unity2 | 99 | where makeAt = newTransform2 unitx2 unity2 |
100 | 100 | ||
101 | |||
102 | -- Step the game world: | ||
103 | -- 1. Simulate physics. | ||
104 | -- 2. Collide objects and clip -> produce collision events. | ||
105 | -- 3. Update game objects <- input collision events. | ||
106 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | ||
107 | stepWorld elapsed dt events gos@[ball, enemy, player] = | ||
108 | let | ||
109 | collisions = collide [ball] [enemy, player] | ||
110 | collisionEvents = (\(x,y) -> Collision (gameObjectId x) (gameObjectId y)) <$> collisions | ||
111 | events' = events ++ collisionEvents | ||
112 | in | ||
113 | map (update elapsed dt events' gos) gos | ||
114 | |||
115 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | ||
116 | update elapsed dt events gos go = | ||
117 | let (go', s') = runStep (gostep go) elapsed dt gos events go | ||
118 | in go' { gostep = s' } | ||
119 | |||
120 | |||
101 | -- Ball steppers | 121 | -- Ball steppers |
102 | 122 | ||
103 | stepBall vel = collideBall vel .> moveBall | 123 | stepBall vel = bounceBall vel .> moveBall -- .> clamp |
104 | 124 | ||
105 | -- TODO: in collideBall and paddleBounce, we should an apply an offset to the | 125 | bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject) |
106 | -- ball when collision is detected. | 126 | bounceBall vel = step $ \_ dt gos events ball -> |
107 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) | 127 | let (AABB2Volume (AABB2 pmin pmax)) = boundingVolume ball |
108 | collideBall vel = step $ \_ dt gos _ ball -> | 128 | sideCollision = x pmin < 0 || x pmax > 1 |
109 | let (AABB2 pmin pmax) = translate (position ball) (aabb ball) | 129 | backCollision = y pmin < 0 || y pmax > 1 |
110 | collideSide = x pmin < 0 || x pmax > 1 | 130 | flipX v@(Vector2 x y) = if sideCollision then vec2 (-x) y else v |
111 | collideBack = y pmin < 0 || y pmax > 1 | 131 | flipY v@(Vector2 x y) = if backCollision then vec2 x (-y) else v |
112 | collidePaddle = any (collide ball) (tail gos) | 132 | collideWithPaddles vel = foldl (paddleBounce ball events) vel (tail gos) |
113 | flipX v@(Vector2 x y) = if collideSide then vec2 (-x) y else v | 133 | vel' = normalise |
114 | flipY v@(Vector2 x y) = if collideBack then vec2 x (-y) else v | 134 | . collideWithPaddles |
115 | vel' = normalise . (\v -> foldl (paddleBounce ball) v (tail gos)) . flipX . flipY $ vel | 135 | . flipX |
116 | -- A small delta to apply when collision occurs. | 136 | . flipY |
117 | delta = (1::Float) + if collideSide || collideBack || collidePaddle then (2::Float)*dt else (0::Float) | 137 | $ vel |
118 | in ((ballSpeed * delta * vel', ball), collideBall vel') | 138 | collision = vel' /= vel |
119 | 139 | -- Apply offset when collision occurs to avoid sticky collisions. | |
120 | paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2 | 140 | delta = (1::Float) + if collision then (3::Float)*dt else (0::Float) |
121 | paddleBounce ball v paddle = | 141 | in ((ballSpeed * delta * vel', ball), bounceBall vel') |
122 | if collide ball paddle | 142 | |
143 | paddleBounce :: GameObject -> [GameEvent] -> Vector2 -> GameObject -> Vector2 | ||
144 | paddleBounce ball events vel paddle = | ||
145 | let collision = Collision Ball (gameObjectId paddle) `elem` events | ||
146 | in if collision | ||
123 | then | 147 | then |
124 | let (AABB2 pmin pmax) = translate (position paddle) (aabb paddle) | 148 | let (AABB2Volume (AABB2 pmin pmax)) = boundingVolume paddle |
125 | center = (x pmin + x pmax) / (2::Float) | 149 | center = (x pmin + x pmax) / (2::Float) |
126 | -- Normalized offset of the ball from the paddle's center, [-1, +1]. | 150 | -- Normalized offset of the ball from the paddle's center, [-1, +1]. |
127 | -- It's outside the [-1, +1] range if there is no collision. | 151 | -- It's outside the [-1, +1] range if there is no collision. |
128 | offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float)) | 152 | offset = (x (position ball) - center) / ((x pmax - x pmin) / (2::Float)) |
129 | angle = offset * maxBounceAngle | 153 | angle = offset * maxBounceAngle |
130 | -- When it bounces off of a paddle, y vel is flipped. | 154 | -- When it bounces off of a paddle, y vel is flipped. |
131 | ysign = -(signum (y v)) | 155 | ysign = -(signum (y vel)) |
132 | in vec2 (sin angle) (ysign * cos angle) | 156 | in vec2 (sin angle) (ysign * cos angle) |
133 | else v | 157 | else vel |
134 | |||
135 | collide :: GameObject -> GameObject -> Bool | ||
136 | collide go1 go2 = | ||
137 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = | ||
138 | translate (position go1) (aabb go1) | ||
139 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = | ||
140 | translate (position go2) (aabb go2) | ||
141 | in not $ | ||
142 | xmax1 < xmin2 | ||
143 | || xmin1 > xmax2 | ||
144 | || ymax1 < ymin2 | ||
145 | || ymin1 > ymax2 | ||
146 | 158 | ||
147 | moveBall :: Step s e (Vector2, GameObject) GameObject | 159 | moveBall :: Step s e (Vector2, GameObject) GameObject |
148 | moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall) | 160 | moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall) |
149 | 161 | ||
162 | |||
150 | -- Enemy stepper | 163 | -- Enemy stepper |
151 | 164 | ||
152 | stepEnemy = movePad | 165 | stepEnemy = movePad 0 .> spure clamp |
166 | |||
167 | movePad :: Float -> Step [GameObject] e GameObject GameObject | ||
168 | movePad previousMomentumVector = step $ \_ dt gos _ pad -> | ||
169 | let ball = head gos | ||
170 | heading = (x . position $ ball) - (x . position $ pad) | ||
171 | chaseVector = enemySpeed * heading | ||
172 | momentumVector = previousMomentumVector + enemyMomentum * heading * dt | ||
173 | vx = chaseVector * dt + momentumVector | ||
174 | in (translate (vec2 vx 0) pad, movePad momentumVector) | ||
153 | 175 | ||
154 | movePad :: Step s e GameObject GameObject | ||
155 | movePad = step $ \elapsed _ _ _ pad -> | ||
156 | let enemyY = 0.9 | ||
157 | p = vec2 px enemyY | ||
158 | px = | ||
159 | (sin (enemySpeed * elapsed) * (0.5::Float) + (0.5::Float)) | ||
160 | * ((1::Float) - (2::Float) * x padSize) | ||
161 | + x padSize | ||
162 | in (setPosition p pad, movePad) | ||
163 | 176 | ||
164 | -- Player stepper | 177 | -- Player stepper |
165 | 178 | ||
166 | stepPlayer = sfold moveGO .> clamp | 179 | stepPlayer = sfold movePlayer .> spure clamp |
167 | 180 | ||
168 | moveGO = | 181 | movePlayer = mconcat |
169 | mconcat | 182 | [ swhen MoveLeft $ movePlayer' (vec2 (-playerSpeed) 0) |
170 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-playerSpeed) 0), | 183 | , swhen MoveRight $ movePlayer' (vec2 playerSpeed 0) |
171 | switch StopRight sid MoveRight (moveGO' $ vec2 playerSpeed 0) | 184 | ] |
172 | ] | ||
173 | 185 | ||
174 | moveGO' :: Vector2 -> Step s e GameObject GameObject | 186 | movePlayer' :: Vector2 -> Step s e GameObject GameObject |
175 | moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir) | 187 | movePlayer' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, movePlayer' dir) |
176 | 188 | ||
177 | clamp :: Step s e GameObject GameObject | 189 | clamp :: GameObject -> GameObject |
178 | clamp = spure $ \go -> | 190 | clamp go = |
179 | let p' = vec2 (clamp' x s (1 - s)) y | 191 | let p' = vec2 (clamp' x sx (1 - sx)) y |
180 | (Vector2 x y) = position go | 192 | (Vector2 x y) = position go |
181 | clamp' x a b | 193 | clamp' x a b |
182 | | x < a = a | 194 | | x < a = a |
183 | | x > b = b | 195 | | x > b = b |
184 | | otherwise = x | 196 | | otherwise = x |
185 | (Vector2 s _) = padSize | 197 | (Vector2 sx _) = gameObjectSize go |
186 | in setPosition p' go | 198 | in setPosition p' go |
@@ -12,9 +12,7 @@ Installation (Ubuntu) | |||
12 | Install dependencies, then build with cabal: | 12 | Install dependencies, then build with cabal: |
13 | 13 | ||
14 | ``` | 14 | ``` |
15 | $ sudo apt install libxxf86vm-dev libglfw3-dev | 15 | $ sudo apt install libxxf86vm-dev libglfw3-dev libopenal-dev libopenalut-dev |
16 | $ git clone https://github.com/jeannekamikaze/Spear.git | ||
17 | $ cd Spear | ||
18 | $ cabal build | 16 | $ cabal build |
19 | ``` | 17 | ``` |
20 | 18 | ||
diff --git a/Spear.cabal b/Spear.cabal index b044ae2..56eb302 100644 --- a/Spear.cabal +++ b/Spear.cabal | |||
@@ -14,6 +14,8 @@ data-dir: "" | |||
14 | library | 14 | library |
15 | build-depends: | 15 | build-depends: |
16 | GLFW-b -any, | 16 | GLFW-b -any, |
17 | OpenAL -any, | ||
18 | ALUT -any, | ||
17 | OpenGL >= 3, | 19 | OpenGL >= 3, |
18 | OpenGLRaw -any, | 20 | OpenGLRaw -any, |
19 | StateVar -any, | 21 | StateVar -any, |
@@ -21,9 +23,11 @@ library | |||
21 | bytestring -any, | 23 | bytestring -any, |
22 | directory -any, | 24 | directory -any, |
23 | exceptions -any, | 25 | exceptions -any, |
26 | file-embed -any, | ||
24 | hashable -any, | 27 | hashable -any, |
25 | hashmap -any, | 28 | hashmap -any, |
26 | mtl -any, | 29 | mtl -any, |
30 | text -any, | ||
27 | transformers -any, | 31 | transformers -any, |
28 | resourcet -any, | 32 | resourcet -any, |
29 | parsec >= 3, | 33 | parsec >= 3, |
@@ -62,6 +66,8 @@ library | |||
62 | Spear.Math.Vector.Vector2 | 66 | Spear.Math.Vector.Vector2 |
63 | Spear.Math.Vector.Vector3 | 67 | Spear.Math.Vector.Vector3 |
64 | Spear.Math.Vector.Vector4 | 68 | Spear.Math.Vector.Vector4 |
69 | Spear.Physics.Collision | ||
70 | Spear.Physics.RigidBody | ||
65 | Spear.Prelude | 71 | Spear.Prelude |
66 | Spear.Render.AnimatedModel | 72 | Spear.Render.AnimatedModel |
67 | Spear.Render.Core | 73 | Spear.Render.Core |
@@ -75,10 +81,13 @@ library | |||
75 | Spear.Render.Material | 81 | Spear.Render.Material |
76 | Spear.Render.Model | 82 | Spear.Render.Model |
77 | Spear.Render.Program | 83 | Spear.Render.Program |
84 | Spear.Render.Shaders | ||
78 | Spear.Render.StaticModel | 85 | Spear.Render.StaticModel |
79 | Spear.Scene.Graph | 86 | Spear.Scene.Graph |
80 | Spear.Scene.Loader | 87 | Spear.Scene.Loader |
81 | Spear.Scene.SceneResources | 88 | Spear.Scene.SceneResources |
89 | Spear.Sound.Sound | ||
90 | Spear.Sound.State | ||
82 | Spear.Step | 91 | Spear.Step |
83 | Spear.Sys.Store | 92 | Spear.Sys.Store |
84 | Spear.Sys.Store.ID | 93 | Spear.Sys.Store.ID |
@@ -91,8 +100,6 @@ library | |||
91 | 100 | ||
92 | build-tools: hsc2hs -any | 101 | build-tools: hsc2hs -any |
93 | 102 | ||
94 | cc-options: -O2 -g -Wno-unused-result | ||
95 | |||
96 | c-sources: | 103 | c-sources: |
97 | Spear/Assets/Image/Image.c | 104 | Spear/Assets/Image/Image.c |
98 | Spear/Assets/Image/BMP/BMP_load.c | 105 | Spear/Assets/Image/BMP/BMP_load.c |
@@ -123,18 +130,26 @@ library | |||
123 | Spear/Assets/Image | 130 | Spear/Assets/Image |
124 | Spear/Assets/Image/BMP | 131 | Spear/Assets/Image/BMP |
125 | Spear/Assets/Model | 132 | Spear/Assets/Model |
126 | Spear/Contrib/glad/include/ | ||
127 | Spear/Render | 133 | Spear/Render |
128 | Spear/Sys | 134 | Spear/Sys |
129 | 135 | ||
130 | hs-source-dirs: . | 136 | hs-source-dirs: . |
131 | 137 | ||
132 | ghc-options: -O2 | 138 | cc-options: -O2 -Wno-unused-result |
133 | 139 | ghc-options: -O2 | |
134 | ghc-prof-options: -O2 -fprof-auto -fprof-cafs | 140 | ghc-prof-options: -O2 -g -fprof-auto -fprof-cafs |
135 | 141 | ||
136 | executable pong | 142 | executable pong |
137 | hs-source-dirs: Demos/Pong | 143 | hs-source-dirs: Demos/Pong |
138 | main-is: Main.hs | 144 | main-is: Main.hs |
139 | other-modules: Pong | 145 | other-modules: Pong |
140 | build-depends: base, Spear, OpenGL | 146 | build-depends: base, Spear |
147 | ghc-options: -O2 | ||
148 | ghc-prof-options: -O2 -g -fprof-auto -fprof-cafs | ||
149 | |||
150 | executable balls | ||
151 | hs-source-dirs: Demos/Balls | ||
152 | main-is: Main.hs | ||
153 | build-depends: base, Spear | ||
154 | ghc-options: -O2 | ||
155 | ghc-prof-options: -O2 -g -fprof-auto -fprof-cafs | ||
diff --git a/Spear/App.hs b/Spear/App.hs index f70dd06..e85c46b 100644 --- a/Spear/App.hs +++ b/Spear/App.hs | |||
@@ -1,20 +1,35 @@ | |||
1 | {-# LANGUAGE FlexibleInstances #-} | ||
2 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
3 | |||
1 | module Spear.App | 4 | module Spear.App |
2 | ( App(..), | 5 | ( App(..) |
3 | Elapsed, | 6 | , AppOptions(..) |
4 | Dt, | 7 | , AppContext(..) |
5 | Step, | 8 | , AppState(..) |
6 | loop, | 9 | , Elapsed |
7 | ) | 10 | , Dt |
11 | , Step | ||
12 | , defaultAppOptions | ||
13 | , getGameState | ||
14 | , putGameState | ||
15 | , modifyGameState | ||
16 | , runApp | ||
17 | , loop | ||
18 | ) | ||
8 | where | 19 | where |
9 | 20 | ||
10 | import Control.Monad | ||
11 | import Data.Fixed (mod') | ||
12 | import GHC.Float | ||
13 | import Spear.Game | 21 | import Spear.Game |
14 | import Spear.Sys.Timer as Timer | 22 | import Spear.Render.Core.State |
23 | import Spear.Render.Immediate | ||
24 | import Spear.Sound.Sound | ||
25 | import Spear.Sound.State | ||
26 | import Spear.Sys.Timer as Timer | ||
15 | import Spear.Window | 27 | import Spear.Window |
16 | 28 | ||
17 | maxFPS = 60 | 29 | import Control.Monad |
30 | import Data.Fixed (mod') | ||
31 | import GHC.Float | ||
32 | |||
18 | 33 | ||
19 | -- | Time elapsed. | 34 | -- | Time elapsed. |
20 | type Elapsed = Double | 35 | type Elapsed = Double |
@@ -25,68 +40,217 @@ type Dt = Double | |||
25 | -- | Return true if the application should continue running, false otherwise. | 40 | -- | Return true if the application should continue running, false otherwise. |
26 | type Step s = Elapsed -> Dt -> [InputEvent] -> Game s Bool | 41 | type Step s = Elapsed -> Dt -> [InputEvent] -> Game s Bool |
27 | 42 | ||
28 | -- | Application functions. | 43 | -- | Application options. |
44 | -- | ||
45 | -- Use `defaultOptions` for default options. | ||
46 | data AppOptions = AppOptions | ||
47 | { title :: String | ||
48 | , windowWidth :: Int | ||
49 | , windowHeight :: Int | ||
50 | , maxFPS :: Int | ||
51 | , animationFPS :: Int | ||
52 | , enableProfiling :: Bool | ||
53 | } | ||
54 | |||
55 | -- | Default application options. | ||
56 | defaultAppOptions = AppOptions | ||
57 | { title = "Spear Application" | ||
58 | , windowWidth = 1920 | ||
59 | , windowHeight = 1080 | ||
60 | , maxFPS = 0 -- If non-zero, cap frame rate to this value. | ||
61 | , animationFPS = 60 -- If non-zero, use fixed time step animation. | ||
62 | , enableProfiling = False | ||
63 | } | ||
64 | |||
65 | -- | Application descriptor. | ||
29 | data App s = App | 66 | data App s = App |
30 | { stepApp :: Step s | 67 | { appOptions :: AppOptions |
31 | , renderApp :: Game s () | 68 | , initApp :: Game AppContext s |
32 | , resizeApp :: WindowEvent -> Game s () | 69 | , endApp :: Game (AppState s) () |
70 | , stepApp :: Step (AppState s) | ||
71 | , renderApp :: Game (AppState s) () | ||
72 | , resizeApp :: WindowEvent -> Game (AppState s) () | ||
73 | } | ||
74 | |||
75 | -- | Application context. | ||
76 | -- | ||
77 | -- The application context is the initial state from which the application's | ||
78 | -- `AppState` is bootstrapped with `initApp`. | ||
79 | data AppContext = AppContext | ||
80 | { contextWindow :: Window | ||
81 | , contextRenderCoreState :: RenderCoreState | ||
82 | , contextSoundState :: SoundState | ||
83 | , contextImmRenderState :: ImmRenderState | ||
84 | } | ||
85 | |||
86 | instance HasState AppContext RenderCoreState where | ||
87 | getInnerState = contextRenderCoreState | ||
88 | setInnerState context state = context { contextRenderCoreState = state } | ||
89 | |||
90 | instance HasState AppContext SoundState where | ||
91 | getInnerState = contextSoundState | ||
92 | setInnerState context state = context { contextSoundState = state } | ||
93 | |||
94 | instance HasState AppContext ImmRenderState where | ||
95 | getInnerState = contextImmRenderState | ||
96 | setInnerState context state = context { contextImmRenderState = state } | ||
97 | |||
98 | -- | Application state. | ||
99 | data AppState s = AppState | ||
100 | { appWindow :: Window | ||
101 | , appRenderCoreState :: RenderCoreState | ||
102 | , appSoundState :: SoundState | ||
103 | , appImmRenderState :: ImmRenderState | ||
104 | , appCustomState :: s | ||
33 | } | 105 | } |
34 | 106 | ||
107 | -- Requires FlexibleInstances. | ||
108 | instance HasState (AppState s) s where | ||
109 | getInnerState = appCustomState | ||
110 | setInnerState appState state = appState { appCustomState = state } | ||
111 | |||
112 | instance HasState (AppState s) RenderCoreState where | ||
113 | getInnerState = appRenderCoreState | ||
114 | setInnerState appState state = appState { appRenderCoreState = state } | ||
115 | |||
116 | instance HasState (AppState s) SoundState where | ||
117 | getInnerState = appSoundState | ||
118 | setInnerState appState state = appState { appSoundState = state } | ||
119 | |||
120 | instance HasState (AppState s) ImmRenderState where | ||
121 | getInnerState = appImmRenderState | ||
122 | setInnerState appState state = appState { appImmRenderState = state } | ||
123 | |||
124 | |||
125 | -- | Get the custom state in the app state. | ||
126 | getGameState :: Game (AppState s) s | ||
127 | getGameState = appCustomState <$> get | ||
128 | |||
129 | -- | Put the custom state in the app state. | ||
130 | putGameState :: s -> Game (AppState s) () | ||
131 | putGameState custom = do | ||
132 | appState <- get | ||
133 | put $ appState { appCustomState = custom } | ||
134 | |||
135 | -- | Modify the custom state in the app state. | ||
136 | modifyGameState :: (s -> s) -> Game (AppState s) () | ||
137 | modifyGameState f = modify $ \appState -> appState { appCustomState = f (appCustomState appState )} | ||
138 | |||
139 | -- | Run the application. | ||
140 | runApp :: App s -> IO () | ||
141 | runApp app = | ||
142 | let ops = appOptions app | ||
143 | w = windowWidth ops | ||
144 | h = windowHeight ops | ||
145 | in -- Initialize subsystems. | ||
146 | withWindow (w, h) (title ops) $ \window -> | ||
147 | withSoundContext $ eval runGame () $ do | ||
148 | -- Create initial context. | ||
149 | -- We could modify function signatures such as: | ||
150 | -- newImmRenderer :: HasState s RenderCoreState => Game s ImmRenderState | ||
151 | -- to simplify things a bit. But I'm not sure I want HasState to | ||
152 | -- proliferate like that right now. | ||
153 | initialSoundState <- eval runSiblingGame () initSoundSystem | ||
154 | (immRenderState, renderCoreState) <- runSiblingGame newRenderCoreState newImmRenderer | ||
155 | let context = AppContext window renderCoreState initialSoundState immRenderState | ||
156 | -- Create initial app state. | ||
157 | (gameState, context') <- runSiblingGame context (initApp app) | ||
158 | let appState = AppState { | ||
159 | appWindow = contextWindow context' | ||
160 | , appRenderCoreState = contextRenderCoreState context' | ||
161 | , appSoundState = contextSoundState context' | ||
162 | , appImmRenderState = contextImmRenderState context' | ||
163 | , appCustomState = gameState | ||
164 | } | ||
165 | -- Run app. | ||
166 | (result, endAppState) <- runChildGame appState $ do | ||
167 | loop app window | ||
168 | endApp app | ||
169 | -- Shut down. | ||
170 | exec' runSiblingGame (appRenderCoreState endAppState) $ deleteImmRenderer (appImmRenderState endAppState) | ||
171 | exec' runSiblingGame (appSoundState endAppState) destroySoundSystem | ||
172 | |||
35 | -- | Enter the main application loop. | 173 | -- | Enter the main application loop. |
36 | loop :: App s -> Window -> Game s () | 174 | loop :: App s -> Window -> Game (AppState s) () |
37 | loop app window = do | 175 | loop app window = do |
38 | -- For convenience, trigger an initial resize followed by a render of the | 176 | -- For convenience, trigger an initial resize followed by a render of the |
39 | -- application's initial state. | 177 | -- application's initial state. |
40 | (width, height) <- gameIO $ getWindowSize window | 178 | (width, height) <- getWindowSize window |
41 | resizeApp app (ResizeEvent width height) | 179 | resizeApp app (ResizeEvent width height) |
42 | renderApp app | 180 | renderApp app |
43 | 181 | ||
44 | let ddt = secToTimeDelta $ 1.0 / fromIntegral maxFPS -- Desired delta time. | 182 | let ddt = fpsToDdt . maxFPS . appOptions $ app -- Desired render time step. |
45 | timer <- gameIO newTimer | 183 | let animationDdt = fpsToDdt . animationFPS . appOptions $ app -- Desired animation time step. |
46 | gameIO $ Timer.start timer | 184 | |
47 | loop' window ddt timer 0 0 app | 185 | timer <- newTimer |
186 | Timer.start timer | ||
187 | let lastAnimationTime = lastTick timer | ||
188 | loop' window ddt animationDdt lastAnimationTime timer app | ||
48 | 189 | ||
49 | loop' :: | 190 | loop' :: |
50 | Window -> | 191 | Window -> |
51 | TimeDelta -> -- Desired frame delta time. | 192 | TimeDelta -> -- Desired render time delta. |
193 | TimeDelta -> -- Desired animation time delta. | ||
194 | TimePoint -> -- Time point of last animation update. | ||
52 | Timer -> | 195 | Timer -> |
53 | TimeDelta -> -- Total elapsed app time. | ||
54 | TimeDelta -> -- Time budget. | ||
55 | App s -> | 196 | App s -> |
56 | Game s () | 197 | Game (AppState s) () |
57 | loop' window ddt inputTimer elapsed timeBudget app = do | 198 | loop' window renderDdt animationDdt lastAnimationTime inputTimer app = do |
58 | timer <- gameIO $ tick inputTimer | 199 | timer <- tick inputTimer |
59 | 200 | windowEvents <- pollWindowEvents window | |
60 | let timeBudgetThisFrame = timeBudget + deltaTime timer | 201 | close <- shouldWindowClose window |
61 | let steps = timeBudgetThisFrame `div` ddt | 202 | |
62 | 203 | (continue, lastAnimationTimeNextFrame) <- case animationDdt of | |
63 | continue <- and <$> forM [1..steps] (\i -> do | 204 | 0 -> do |
64 | let t = timeDeltaToSec $ elapsed + i * ddt | 205 | -- Variable time step game animation. |
65 | let dt = timeDeltaToSec ddt | 206 | let t = timeDeltaToSec $ runningTime timer |
66 | inputEvents <- gameIO $ pollInputEvents window | 207 | let dt = timeDeltaToSec $ deltaTime timer |
67 | stepApp app t dt inputEvents) | 208 | inputEvents <- pollInputEvents window |
68 | 209 | continue <- stepApp app t dt inputEvents | |
69 | let elapsed' = elapsed + steps * ddt | 210 | return (continue, lastAnimationTime) |
70 | let timeBudget' = timeBudgetThisFrame `mod` ddt | 211 | |
71 | 212 | _ -> do | |
72 | when continue $ do | 213 | -- Fixed time step animation. |
73 | windowEvents <- gameIO $ pollWindowEvents window | 214 | let ddt = animationDdt |
74 | forM_ windowEvents $ \event -> case event of | 215 | {- let elapsed = runningTime timer |
75 | ResizeEvent {} -> resizeApp app event | 216 | let dt = timeDeltaToSec ddt |
217 | let timeBudgetThisFrame = timeBudget + deltaTime timer | ||
218 | let timeBudgetNextFrame = timeBudgetThisFrame `mod` ddt | ||
219 | let steps = timeBudgetThisFrame `div` ddt -} | ||
220 | --liftIO . print $ "Steps: " ++ show steps ++ ", Budget: " ++ show timeBudgetThisFrame ++ ", ddt: " ++ show ddt | ||
221 | let elapsed = runningTime timer | ||
222 | let dt = timeDeltaToSec ddt | ||
223 | let timeBudgetThisFrame = timeDiff lastAnimationTime (lastTick timer) | ||
224 | let steps = timeBudgetThisFrame `div` ddt | ||
225 | let lastAnimationTimeNextFrame = timeAdd lastAnimationTime (steps * ddt) | ||
226 | --liftIO . print $ "Steps: " ++ show steps ++ ", Budget: " ++ show timeBudgetThisFrame ++ ", ddt: " ++ show ddt | ||
227 | continue <- and <$> forM [1..steps] (\i -> do | ||
228 | inputEvents <- pollInputEvents window | ||
229 | let t = timeDeltaToSec $ elapsed + i * ddt | ||
230 | stepApp app t dt inputEvents) | ||
231 | return (continue, lastAnimationTimeNextFrame) | ||
232 | |||
233 | -- Process window events. | ||
234 | resized <- or <$> forM windowEvents (\event -> case event of | ||
235 | ResizeEvent {} -> resizeApp app event >> return True) | ||
236 | |||
237 | -- For smoother resizing, render only while not resizing. | ||
238 | unless resized $ do | ||
76 | renderApp app | 239 | renderApp app |
77 | gameIO $ swapBuffers window | 240 | swapBuffers window |
78 | 241 | ||
79 | frameEnd <- gameIO now | 242 | -- Limit frame rate if so requested by the application. |
243 | -- This currently makes the rendering stutter and is not very desirable. | ||
244 | when ((maxFPS . appOptions $ app) > 0) $ do | ||
245 | frameEnd <- now | ||
246 | let ddt = renderDdt | ||
80 | let frameTime = timeDiff (lastTick timer) frameEnd | 247 | let frameTime = timeDiff (lastTick timer) frameEnd |
81 | when (frameTime < ddt) $ do | 248 | when (frameTime < ddt) $ do |
82 | gameIO $ Timer.sleep (ddt - frameTime) | 249 | Timer.sleep (ddt - frameTime) |
83 | 250 | ||
84 | close <- gameIO $ shouldWindowClose window | 251 | when (continue && not close) $ do |
85 | when (continue && not close) $ | 252 | loop' window renderDdt animationDdt lastAnimationTimeNextFrame timer app |
86 | loop' | 253 | |
87 | window | 254 | -- | Convert FPS to desired delta time. |
88 | ddt | 255 | fpsToDdt :: Int -> TimeDelta |
89 | timer | 256 | fpsToDdt fps = if fps > 0 then secToTimeDelta (1.0 / fromIntegral fps) else 0 |
90 | elapsed' | ||
91 | timeBudget' | ||
92 | app | ||
diff --git a/Spear/Assets/Image.hsc b/Spear/Assets/Image.hsc index f9fc025..db90afe 100644 --- a/Spear/Assets/Image.hsc +++ b/Spear/Assets/Image.hsc | |||
@@ -46,24 +46,24 @@ data CImage = CImage | |||
46 | instance Storable CImage where | 46 | instance Storable CImage where |
47 | sizeOf _ = #{size Image} | 47 | sizeOf _ = #{size Image} |
48 | alignment _ = alignment (undefined :: CInt) | 48 | alignment _ = alignment (undefined :: CInt) |
49 | 49 | ||
50 | peek ptr = do | 50 | peek ptr = do |
51 | width <- #{peek Image, width} ptr | 51 | width <- #{peek Image, width} ptr |
52 | height <- #{peek Image, height} ptr | 52 | height <- #{peek Image, height} ptr |
53 | bpp <- #{peek Image, bpp} ptr | 53 | bpp <- #{peek Image, bpp} ptr |
54 | pixels <- #{peek Image, pixels} ptr | 54 | pixels <- #{peek Image, pixels} ptr |
55 | return $ CImage width height bpp pixels | 55 | return $ CImage width height bpp pixels |
56 | 56 | ||
57 | poke ptr (CImage width height bpp pixels) = do | 57 | poke ptr (CImage width height bpp pixels) = do |
58 | #{poke Image, width} ptr width | 58 | #{poke Image, width} ptr width |
59 | #{poke Image, height} ptr height | 59 | #{poke Image, height} ptr height |
60 | #{poke Image, bpp} ptr bpp | 60 | #{poke Image, bpp} ptr bpp |
61 | #{poke Image, pixels} ptr pixels | 61 | #{poke Image, pixels} ptr pixels |
62 | 62 | ||
63 | -- | Represents an image 'Resource'. | 63 | -- | An image resource. |
64 | data Image = Image | 64 | data Image = Image |
65 | { imageData :: CImage | 65 | { imageData :: CImage |
66 | , rkey :: Resource | 66 | , rkey :: ReleaseKey |
67 | } | 67 | } |
68 | 68 | ||
69 | instance ResourceClass Image where | 69 | instance ResourceClass Image where |
@@ -84,15 +84,15 @@ loadImage file = do | |||
84 | dotPos <- case elemIndex '.' file of | 84 | dotPos <- case elemIndex '.' file of |
85 | Nothing -> gameError $ "file name has no extension: " ++ file | 85 | Nothing -> gameError $ "file name has no extension: " ++ file |
86 | Just p -> return p | 86 | Just p -> return p |
87 | 87 | ||
88 | let ext = map toLower . tail . snd $ splitAt dotPos file | 88 | let ext = map toLower . tail . snd $ splitAt dotPos file |
89 | 89 | ||
90 | result <- gameIO . alloca $ \ptr -> do | 90 | result <- liftIO . alloca $ \ptr -> do |
91 | status <- withCString file $ \fileCstr -> do | 91 | status <- withCString file $ \fileCstr -> do |
92 | case ext of | 92 | case ext of |
93 | "bmp" -> bmp_load fileCstr ptr | 93 | "bmp" -> bmp_load fileCstr ptr |
94 | _ -> return ImageNoSuitableLoader | 94 | _ -> return ImageNoSuitableLoader |
95 | 95 | ||
96 | case status of | 96 | case status of |
97 | ImageSuccess -> peek ptr >>= return . Right | 97 | ImageSuccess -> peek ptr >>= return . Right |
98 | ImageReadError -> return . Left $ "read error" | 98 | ImageReadError -> return . Left $ "read error" |
@@ -100,7 +100,7 @@ loadImage file = do | |||
100 | ImageFileNotFound -> return . Left $ "file not found" | 100 | ImageFileNotFound -> return . Left $ "file not found" |
101 | ImageInvalidFormat -> return . Left $ "invalid format" | 101 | ImageInvalidFormat -> return . Left $ "invalid format" |
102 | ImageNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext | 102 | ImageNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext |
103 | 103 | ||
104 | case result of | 104 | case result of |
105 | Right image -> register (freeImage image) >>= return . Image image | 105 | Right image -> register (freeImage image) >>= return . Image image |
106 | Left err -> gameError $ "loadImage: " ++ err | 106 | Left err -> gameError $ "loadImage: " ++ err |
diff --git a/Spear/Assets/Model.hsc b/Spear/Assets/Model.hsc index 74666f2..02e1edf 100644 --- a/Spear/Assets/Model.hsc +++ b/Spear/Assets/Model.hsc | |||
@@ -65,12 +65,12 @@ data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float | |||
65 | instance Storable Vec2 where | 65 | instance Storable Vec2 where |
66 | sizeOf _ = 2*sizeFloat | 66 | sizeOf _ = 2*sizeFloat |
67 | alignment _ = alignment (undefined :: CFloat) | 67 | alignment _ = alignment (undefined :: CFloat) |
68 | 68 | ||
69 | peek ptr = do | 69 | peek ptr = do |
70 | f0 <- peekByteOff ptr 0 | 70 | f0 <- peekByteOff ptr 0 |
71 | f1 <- peekByteOff ptr sizeFloat | 71 | f1 <- peekByteOff ptr sizeFloat |
72 | return $ Vec2 f0 f1 | 72 | return $ Vec2 f0 f1 |
73 | 73 | ||
74 | poke ptr (Vec2 f0 f1) = do | 74 | poke ptr (Vec2 f0 f1) = do |
75 | pokeByteOff ptr 0 f0 | 75 | pokeByteOff ptr 0 f0 |
76 | pokeByteOff ptr sizeFloat f1 | 76 | pokeByteOff ptr sizeFloat f1 |
@@ -81,13 +81,13 @@ data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Flo | |||
81 | instance Storable Vec3 where | 81 | instance Storable Vec3 where |
82 | sizeOf _ = 3*sizeFloat | 82 | sizeOf _ = 3*sizeFloat |
83 | alignment _ = alignment (undefined :: CFloat) | 83 | alignment _ = alignment (undefined :: CFloat) |
84 | 84 | ||
85 | peek ptr = do | 85 | peek ptr = do |
86 | f0 <- peekByteOff ptr 0 | 86 | f0 <- peekByteOff ptr 0 |
87 | f1 <- peekByteOff ptr sizeFloat | 87 | f1 <- peekByteOff ptr sizeFloat |
88 | f2 <- peekByteOff ptr (2*sizeFloat) | 88 | f2 <- peekByteOff ptr (2*sizeFloat) |
89 | return $ Vec3 f0 f1 f2 | 89 | return $ Vec3 f0 f1 f2 |
90 | 90 | ||
91 | poke ptr (Vec3 f0 f1 f2) = do | 91 | poke ptr (Vec3 f0 f1 f2) = do |
92 | pokeByteOff ptr 0 f0 | 92 | pokeByteOff ptr 0 f0 |
93 | pokeByteOff ptr sizeFloat f1 | 93 | pokeByteOff ptr sizeFloat f1 |
@@ -99,12 +99,12 @@ data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float | |||
99 | instance Storable TexCoord where | 99 | instance Storable TexCoord where |
100 | sizeOf _ = 2*sizeFloat | 100 | sizeOf _ = 2*sizeFloat |
101 | alignment _ = alignment (undefined :: CFloat) | 101 | alignment _ = alignment (undefined :: CFloat) |
102 | 102 | ||
103 | peek ptr = do | 103 | peek ptr = do |
104 | f0 <- peekByteOff ptr 0 | 104 | f0 <- peekByteOff ptr 0 |
105 | f1 <- peekByteOff ptr sizeFloat | 105 | f1 <- peekByteOff ptr sizeFloat |
106 | return $ TexCoord f0 f1 | 106 | return $ TexCoord f0 f1 |
107 | 107 | ||
108 | poke ptr (TexCoord f0 f1) = do | 108 | poke ptr (TexCoord f0 f1) = do |
109 | pokeByteOff ptr 0 f0 | 109 | pokeByteOff ptr 0 f0 |
110 | pokeByteOff ptr sizeFloat f1 | 110 | pokeByteOff ptr sizeFloat f1 |
@@ -122,23 +122,23 @@ data CTriangle = CTriangle | |||
122 | instance Storable CTriangle where | 122 | instance Storable CTriangle where |
123 | sizeOf _ = #{size triangle} | 123 | sizeOf _ = #{size triangle} |
124 | alignment _ = alignment (undefined :: CUShort) | 124 | alignment _ = alignment (undefined :: CUShort) |
125 | 125 | ||
126 | peek ptr = do | 126 | peek ptr = do |
127 | v0 <- #{peek triangle, vertexIndices[0]} ptr | 127 | v0 <- #{peek triangle, vertexIndices[0]} ptr |
128 | v1 <- #{peek triangle, vertexIndices[1]} ptr | 128 | v1 <- #{peek triangle, vertexIndices[1]} ptr |
129 | v2 <- #{peek triangle, vertexIndices[2]} ptr | 129 | v2 <- #{peek triangle, vertexIndices[2]} ptr |
130 | 130 | ||
131 | t0 <- #{peek triangle, textureIndices[0]} ptr | 131 | t0 <- #{peek triangle, textureIndices[0]} ptr |
132 | t1 <- #{peek triangle, textureIndices[1]} ptr | 132 | t1 <- #{peek triangle, textureIndices[1]} ptr |
133 | t2 <- #{peek triangle, textureIndices[2]} ptr | 133 | t2 <- #{peek triangle, textureIndices[2]} ptr |
134 | 134 | ||
135 | return $ CTriangle v0 v1 v2 t0 t1 t2 | 135 | return $ CTriangle v0 v1 v2 t0 t1 t2 |
136 | 136 | ||
137 | poke ptr (CTriangle v0 v1 v2 t0 t1 t2) = do | 137 | poke ptr (CTriangle v0 v1 v2 t0 t1 t2) = do |
138 | #{poke triangle, vertexIndices[0]} ptr v0 | 138 | #{poke triangle, vertexIndices[0]} ptr v0 |
139 | #{poke triangle, vertexIndices[1]} ptr v1 | 139 | #{poke triangle, vertexIndices[1]} ptr v1 |
140 | #{poke triangle, vertexIndices[2]} ptr v2 | 140 | #{poke triangle, vertexIndices[2]} ptr v2 |
141 | 141 | ||
142 | #{poke triangle, textureIndices[0]} ptr t0 | 142 | #{poke triangle, textureIndices[0]} ptr t0 |
143 | #{poke triangle, textureIndices[1]} ptr t1 | 143 | #{poke triangle, textureIndices[1]} ptr t1 |
144 | #{poke triangle, textureIndices[2]} ptr t2 | 144 | #{poke triangle, textureIndices[2]} ptr t2 |
@@ -149,7 +149,7 @@ data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3 | |||
149 | instance Storable Box where | 149 | instance Storable Box where |
150 | sizeOf _ = 6 * sizeFloat | 150 | sizeOf _ = 6 * sizeFloat |
151 | alignment _ = alignment (undefined :: CFloat) | 151 | alignment _ = alignment (undefined :: CFloat) |
152 | 152 | ||
153 | peek ptr = do | 153 | peek ptr = do |
154 | xmin <- peekByteOff ptr 0 | 154 | xmin <- peekByteOff ptr 0 |
155 | ymin <- peekByteOff ptr sizeFloat | 155 | ymin <- peekByteOff ptr sizeFloat |
@@ -158,7 +158,7 @@ instance Storable Box where | |||
158 | ymax <- peekByteOff ptr $ 4*sizeFloat | 158 | ymax <- peekByteOff ptr $ 4*sizeFloat |
159 | zmax <- peekByteOff ptr $ 5*sizeFloat | 159 | zmax <- peekByteOff ptr $ 5*sizeFloat |
160 | return $ Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax) | 160 | return $ Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax) |
161 | 161 | ||
162 | poke ptr (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = do | 162 | poke ptr (Box (Vec3 xmin ymin zmin) (Vec3 xmax ymax zmax)) = do |
163 | pokeByteOff ptr 0 xmin | 163 | pokeByteOff ptr 0 xmin |
164 | pokeByteOff ptr sizeFloat ymin | 164 | pokeByteOff ptr sizeFloat ymin |
@@ -173,11 +173,11 @@ newtype Skin = Skin { skinName :: B.ByteString } | |||
173 | instance Storable Skin where | 173 | instance Storable Skin where |
174 | sizeOf (Skin s) = 64 | 174 | sizeOf (Skin s) = 64 |
175 | alignment _ = 1 | 175 | alignment _ = 1 |
176 | 176 | ||
177 | peek ptr = do | 177 | peek ptr = do |
178 | s <- B.packCString $ unsafeCoerce ptr | 178 | s <- B.packCString $ unsafeCoerce ptr |
179 | return $ Skin s | 179 | return $ Skin s |
180 | 180 | ||
181 | poke ptr (Skin s) = do | 181 | poke ptr (Skin s) = do |
182 | B.useAsCStringLen s $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len | 182 | B.useAsCStringLen s $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len |
183 | 183 | ||
@@ -193,13 +193,13 @@ data Animation = Animation | |||
193 | instance Storable Animation where | 193 | instance Storable Animation where |
194 | sizeOf _ = #{size animation} | 194 | sizeOf _ = #{size animation} |
195 | alignment _ = alignment (undefined :: CUInt) | 195 | alignment _ = alignment (undefined :: CUInt) |
196 | 196 | ||
197 | peek ptr = do | 197 | peek ptr = do |
198 | name <- B.packCString (unsafeCoerce ptr) | 198 | name <- B.packCString (unsafeCoerce ptr) |
199 | start <- #{peek animation, start} ptr | 199 | start <- #{peek animation, start} ptr |
200 | end <- #{peek animation, end} ptr | 200 | end <- #{peek animation, end} ptr |
201 | return $ Animation name start end | 201 | return $ Animation name start end |
202 | 202 | ||
203 | poke ptr (Animation name start end) = do | 203 | poke ptr (Animation name start end) = do |
204 | B.useAsCStringLen name $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len | 204 | B.useAsCStringLen name $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len |
205 | #{poke animation, start} ptr start | 205 | #{poke animation, start} ptr start |
@@ -224,7 +224,7 @@ data Model = Model | |||
224 | instance Storable Model where | 224 | instance Storable Model where |
225 | sizeOf _ = #{size Model} | 225 | sizeOf _ = #{size Model} |
226 | alignment _ = alignment (undefined :: CUInt) | 226 | alignment _ = alignment (undefined :: CUInt) |
227 | 227 | ||
228 | peek ptr = do | 228 | peek ptr = do |
229 | numFrames <- #{peek Model, numFrames} ptr | 229 | numFrames <- #{peek Model, numFrames} ptr |
230 | numVertices <- #{peek Model, numVertices} ptr | 230 | numVertices <- #{peek Model, numVertices} ptr |
@@ -232,7 +232,7 @@ instance Storable Model where | |||
232 | numTexCoords <- #{peek Model, numTexCoords} ptr | 232 | numTexCoords <- #{peek Model, numTexCoords} ptr |
233 | numSkins <- #{peek Model, numSkins} ptr | 233 | numSkins <- #{peek Model, numSkins} ptr |
234 | numAnimations <- #{peek Model, numAnimations} ptr | 234 | numAnimations <- #{peek Model, numAnimations} ptr |
235 | pVerts <- peek (unsafeCoerce ptr) | 235 | pVerts <- peek (unsafeCoerce ptr) |
236 | pNormals <- peekByteOff ptr sizePtr | 236 | pNormals <- peekByteOff ptr sizePtr |
237 | pTexCoords <- peekByteOff ptr (2*sizePtr) | 237 | pTexCoords <- peekByteOff ptr (2*sizePtr) |
238 | pTriangles <- peekByteOff ptr (3*sizePtr) | 238 | pTriangles <- peekByteOff ptr (3*sizePtr) |
@@ -247,7 +247,7 @@ instance Storable Model where | |||
247 | return $ | 247 | return $ |
248 | Model vertices normals texCoords triangles skins animations | 248 | Model vertices normals texCoords triangles skins animations |
249 | numFrames numVertices numTriangles numTexCoords numSkins numAnimations | 249 | numFrames numVertices numTriangles numTexCoords numSkins numAnimations |
250 | 250 | ||
251 | poke ptr | 251 | poke ptr |
252 | (Model verts normals texCoords tris skins animations | 252 | (Model verts normals texCoords tris skins animations |
253 | numFrames numVerts numTris numTex numSkins numAnimations) = | 253 | numFrames numVerts numTris numTex numSkins numAnimations) = |
@@ -288,7 +288,7 @@ data Triangle = Triangle | |||
288 | instance Storable Triangle where | 288 | instance Storable Triangle where |
289 | sizeOf _ = #{size model_triangle} | 289 | sizeOf _ = #{size model_triangle} |
290 | alignment _ = alignment (undefined :: Float) | 290 | alignment _ = alignment (undefined :: Float) |
291 | 291 | ||
292 | peek ptr = do | 292 | peek ptr = do |
293 | v0 <- #{peek model_triangle, v0} ptr | 293 | v0 <- #{peek model_triangle, v0} ptr |
294 | v1 <- #{peek model_triangle, v1} ptr | 294 | v1 <- #{peek model_triangle, v1} ptr |
@@ -300,7 +300,7 @@ instance Storable Triangle where | |||
300 | t1 <- #{peek model_triangle, t1} ptr | 300 | t1 <- #{peek model_triangle, t1} ptr |
301 | t2 <- #{peek model_triangle, t2} ptr | 301 | t2 <- #{peek model_triangle, t2} ptr |
302 | return $ Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2 | 302 | return $ Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2 |
303 | 303 | ||
304 | poke ptr (Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2) = do | 304 | poke ptr (Triangle v0 v1 v2 n0 n1 n2 t0 t1 t2) = do |
305 | #{poke model_triangle, v0} ptr v0 | 305 | #{poke model_triangle, v0} ptr v0 |
306 | #{poke model_triangle, v1} ptr v1 | 306 | #{poke model_triangle, v1} ptr v1 |
@@ -335,16 +335,16 @@ loadModel file = do | |||
335 | dotPos <- case elemIndex '.' file of | 335 | dotPos <- case elemIndex '.' file of |
336 | Nothing -> gameError $ "file name has no extension: " ++ file | 336 | Nothing -> gameError $ "file name has no extension: " ++ file |
337 | Just p -> return p | 337 | Just p -> return p |
338 | 338 | ||
339 | let ext = map toLower . tail . snd $ splitAt dotPos file | 339 | let ext = map toLower . tail . snd $ splitAt dotPos file |
340 | 340 | ||
341 | result <- gameIO . alloca $ \ptr -> do | 341 | result <- liftIO . alloca $ \ptr -> do |
342 | status <- withCString file $ \fileCstr -> do | 342 | status <- withCString file $ \fileCstr -> do |
343 | case ext of | 343 | case ext of |
344 | "md2" -> md2_load fileCstr 0 0 ptr | 344 | "md2" -> md2_load fileCstr 0 0 ptr |
345 | "obj" -> obj_load fileCstr 0 0 ptr | 345 | "obj" -> obj_load fileCstr 0 0 ptr |
346 | _ -> return ModelNoSuitableLoader | 346 | _ -> return ModelNoSuitableLoader |
347 | 347 | ||
348 | case status of | 348 | case status of |
349 | ModelSuccess -> do | 349 | ModelSuccess -> do |
350 | model <- peek ptr | 350 | model <- peek ptr |
@@ -355,7 +355,7 @@ loadModel file = do | |||
355 | ModelFileNotFound -> return . Left $ "file not found" | 355 | ModelFileNotFound -> return . Left $ "file not found" |
356 | ModelFileMismatch -> return . Left $ "file mismatch" | 356 | ModelFileMismatch -> return . Left $ "file mismatch" |
357 | ModelNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext | 357 | ModelNoSuitableLoader -> return . Left $ "no suitable loader for extension " ++ ext |
358 | 358 | ||
359 | case result of | 359 | case result of |
360 | Right model -> return model | 360 | Right model -> return model |
361 | Left err -> gameError $ "loadModel: " ++ err | 361 | Left err -> gameError $ "loadModel: " ++ err |
@@ -392,7 +392,7 @@ transformVerts model f = model { vertices = vertices' } | |||
392 | where | 392 | where |
393 | n = numVerts model * numFrames model | 393 | n = numVerts model * numFrames model |
394 | vertices' = S.generate n f' | 394 | vertices' = S.generate n f' |
395 | f' i = f $ vertices model S.! i | 395 | f' i = f $ vertices model S.! i |
396 | 396 | ||
397 | -- | Transform the model's normals. | 397 | -- | Transform the model's normals. |
398 | transformNormals :: Model -> (Vec3 -> Vec3) -> Model | 398 | transformNormals :: Model -> (Vec3 -> Vec3) -> Model |
@@ -400,14 +400,14 @@ transformNormals model f = model { normals = normals' } | |||
400 | where | 400 | where |
401 | n = numVerts model * numFrames model | 401 | n = numVerts model * numFrames model |
402 | normals' = S.generate n f' | 402 | normals' = S.generate n f' |
403 | f' i = f $ normals model S.! i | 403 | f' i = f $ normals model S.! i |
404 | 404 | ||
405 | -- | Translate the model such that its lowest point has y = 0. | 405 | -- | Translate the model such that its lowest point has y = 0. |
406 | toGround :: Model -> IO Model | 406 | toGround :: Model -> IO Model |
407 | toGround model = | 407 | toGround model = |
408 | let model' = model { vertices = S.generate n $ \i -> vertices model S.! i } | 408 | let model' = model { vertices = S.generate n $ \i -> vertices model S.! i } |
409 | n = numVerts model * numFrames model | 409 | n = numVerts model * numFrames model |
410 | in | 410 | in |
411 | with model' model_to_ground >> return model' | 411 | with model' model_to_ground >> return model' |
412 | 412 | ||
413 | foreign import ccall "Model.h model_to_ground" | 413 | foreign import ccall "Model.h model_to_ground" |
diff --git a/Spear/GL.hs b/Spear/GL.hs index f463109..3c1734b 100644 --- a/Spear/GL.hs +++ b/Spear/GL.hs | |||
@@ -36,7 +36,7 @@ module Spear.GL | |||
36 | Data.StateVar.get, | 36 | Data.StateVar.get, |
37 | 37 | ||
38 | -- * VAOs | 38 | -- * VAOs |
39 | VAO, | 39 | VAO(..), |
40 | newVAO, | 40 | newVAO, |
41 | bindVAO, | 41 | bindVAO, |
42 | unbindVAO, | 42 | unbindVAO, |
@@ -48,7 +48,7 @@ module Spear.GL | |||
48 | drawElements, | 48 | drawElements, |
49 | 49 | ||
50 | -- * Buffers | 50 | -- * Buffers |
51 | GLBuffer, | 51 | GLBuffer(..), |
52 | TargetBuffer (..), | 52 | TargetBuffer (..), |
53 | BufferUsage (..), | 53 | BufferUsage (..), |
54 | newBuffer, | 54 | newBuffer, |
@@ -122,7 +122,7 @@ import Unsafe.Coerce | |||
122 | -- | A GLSL shader handle. | 122 | -- | A GLSL shader handle. |
123 | data GLSLShader = GLSLShader | 123 | data GLSLShader = GLSLShader |
124 | { getShader :: GLuint, | 124 | { getShader :: GLuint, |
125 | getShaderKey :: Resource | 125 | getShaderKey :: ReleaseKey |
126 | } | 126 | } |
127 | 127 | ||
128 | instance ResourceClass GLSLShader where | 128 | instance ResourceClass GLSLShader where |
@@ -131,7 +131,7 @@ instance ResourceClass GLSLShader where | |||
131 | -- | A GLSL program handle. | 131 | -- | A GLSL program handle. |
132 | data GLSLProgram = GLSLProgram | 132 | data GLSLProgram = GLSLProgram |
133 | { getProgram :: GLuint, | 133 | { getProgram :: GLuint, |
134 | getProgramKey :: Resource | 134 | getProgramKey :: ReleaseKey |
135 | } | 135 | } |
136 | 136 | ||
137 | instance ResourceClass GLSLProgram where | 137 | instance ResourceClass GLSLProgram where |
@@ -173,11 +173,11 @@ attribLocation prog var = makeStateVar get set | |||
173 | -- | Create a new program. | 173 | -- | Create a new program. |
174 | newProgram :: [GLSLShader] -> Game s GLSLProgram | 174 | newProgram :: [GLSLShader] -> Game s GLSLProgram |
175 | newProgram shaders = do | 175 | newProgram shaders = do |
176 | h <- gameIO glCreateProgram | 176 | h <- liftIO glCreateProgram |
177 | when (h == 0) $ gameError "glCreateProgram failed" | 177 | when (h == 0) $ gameError "glCreateProgram failed" |
178 | rkey <- register $ deleteProgram h | 178 | rkey <- register $ deleteProgram h |
179 | let program = GLSLProgram h rkey | 179 | let program = GLSLProgram h rkey |
180 | mapM_ (gameIO . attachShader program) shaders | 180 | mapM_ (liftIO . attachShader program) shaders |
181 | linkProgram program | 181 | linkProgram program |
182 | return program | 182 | return program |
183 | 183 | ||
@@ -192,7 +192,7 @@ deleteProgram prog = do | |||
192 | linkProgram :: GLSLProgram -> Game s () | 192 | linkProgram :: GLSLProgram -> Game s () |
193 | linkProgram prog = do | 193 | linkProgram prog = do |
194 | let h = getProgram prog | 194 | let h = getProgram prog |
195 | err <- gameIO $ do | 195 | err <- liftIO $ do |
196 | glLinkProgram h | 196 | glLinkProgram h |
197 | alloca $ \statptr -> do | 197 | alloca $ \statptr -> do |
198 | glGetProgramiv h GL_LINK_STATUS statptr | 198 | glGetProgramiv h GL_LINK_STATUS statptr |
@@ -235,7 +235,7 @@ loadShader shaderType file = do | |||
235 | -- | Create a new shader. | 235 | -- | Create a new shader. |
236 | newShader :: ShaderType -> Game s GLSLShader | 236 | newShader :: ShaderType -> Game s GLSLShader |
237 | newShader shaderType = do | 237 | newShader shaderType = do |
238 | h <- gameIO $ glCreateShader (toGLShader shaderType) | 238 | h <- liftIO $ glCreateShader (toGLShader shaderType) |
239 | case h of | 239 | case h of |
240 | 0 -> gameError "glCreateShader failed" | 240 | 0 -> gameError "glCreateShader failed" |
241 | _ -> do | 241 | _ -> do |
@@ -253,10 +253,10 @@ deleteShader shader = do | |||
253 | -- into the shader. | 253 | -- into the shader. |
254 | loadSource :: FilePath -> GLSLShader -> Game s () | 254 | loadSource :: FilePath -> GLSLShader -> Game s () |
255 | loadSource file h = do | 255 | loadSource file h = do |
256 | exists <- gameIO $ doesFileExist file | 256 | exists <- liftIO $ doesFileExist file |
257 | case exists of | 257 | case exists of |
258 | False -> gameError "the specified shader file does not exist" | 258 | False -> gameError "the specified shader file does not exist" |
259 | True -> gameIO $ do | 259 | True -> liftIO $ do |
260 | code <- readSource file | 260 | code <- readSource file |
261 | withCString code $ shaderSource h | 261 | withCString code $ shaderSource h |
262 | 262 | ||
@@ -272,10 +272,10 @@ compile file shader = do | |||
272 | let h = getShader shader | 272 | let h = getShader shader |
273 | 273 | ||
274 | -- Compile | 274 | -- Compile |
275 | gameIO $ glCompileShader h | 275 | liftIO $ glCompileShader h |
276 | 276 | ||
277 | -- Verify status | 277 | -- Verify status |
278 | err <- gameIO $ | 278 | err <- liftIO $ |
279 | alloca $ \statusPtr -> do | 279 | alloca $ \statusPtr -> do |
280 | glGetShaderiv h GL_COMPILE_STATUS statusPtr | 280 | glGetShaderiv h GL_COMPILE_STATUS statusPtr |
281 | result <- peek statusPtr | 281 | result <- peek statusPtr |
@@ -438,7 +438,7 @@ instance Uniform [Int] where | |||
438 | -- | A vertex array object. | 438 | -- | A vertex array object. |
439 | data VAO = VAO | 439 | data VAO = VAO |
440 | { getVAO :: GLuint, | 440 | { getVAO :: GLuint, |
441 | vaoKey :: Resource | 441 | vaoKey :: ReleaseKey |
442 | } | 442 | } |
443 | 443 | ||
444 | instance ResourceClass VAO where | 444 | instance ResourceClass VAO where |
@@ -454,7 +454,7 @@ instance Ord VAO where | |||
454 | -- | Create a new vao. | 454 | -- | Create a new vao. |
455 | newVAO :: Game s VAO | 455 | newVAO :: Game s VAO |
456 | newVAO = do | 456 | newVAO = do |
457 | h <- gameIO . alloca $ \ptr -> do | 457 | h <- liftIO . alloca $ \ptr -> do |
458 | glGenVertexArrays 1 ptr | 458 | glGenVertexArrays 1 ptr |
459 | peek ptr | 459 | peek ptr |
460 | 460 | ||
@@ -533,11 +533,11 @@ drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs | |||
533 | -- | An OpenGL buffer. | 533 | -- | An OpenGL buffer. |
534 | data GLBuffer = GLBuffer | 534 | data GLBuffer = GLBuffer |
535 | { getBuffer :: GLuint, | 535 | { getBuffer :: GLuint, |
536 | rkey :: Resource | 536 | bufferKey :: ReleaseKey |
537 | } | 537 | } |
538 | 538 | ||
539 | instance ResourceClass GLBuffer where | 539 | instance ResourceClass GLBuffer where |
540 | getResource = rkey | 540 | getResource = bufferKey |
541 | 541 | ||
542 | -- | The type of target buffer. | 542 | -- | The type of target buffer. |
543 | data TargetBuffer | 543 | data TargetBuffer |
@@ -580,7 +580,7 @@ fromUsage DynamicCopy = GL_DYNAMIC_COPY | |||
580 | -- | Create a new buffer. | 580 | -- | Create a new buffer. |
581 | newBuffer :: Game s GLBuffer | 581 | newBuffer :: Game s GLBuffer |
582 | newBuffer = do | 582 | newBuffer = do |
583 | h <- gameIO . alloca $ \ptr -> do | 583 | h <- liftIO . alloca $ \ptr -> do |
584 | glGenBuffers 1 ptr | 584 | glGenBuffers 1 ptr |
585 | peek ptr | 585 | peek ptr |
586 | 586 | ||
@@ -656,7 +656,7 @@ withGLBuffer buf f = f $ getBuffer buf | |||
656 | -- | Represents a texture resource. | 656 | -- | Represents a texture resource. |
657 | data Texture = Texture | 657 | data Texture = Texture |
658 | { getTex :: GLuint, | 658 | { getTex :: GLuint, |
659 | texKey :: Resource | 659 | texKey :: ReleaseKey |
660 | } | 660 | } |
661 | 661 | ||
662 | instance Eq Texture where | 662 | instance Eq Texture where |
@@ -672,7 +672,7 @@ instance ResourceClass Texture where | |||
672 | -- | Create a new texture. | 672 | -- | Create a new texture. |
673 | newTexture :: Game s Texture | 673 | newTexture :: Game s Texture |
674 | newTexture = do | 674 | newTexture = do |
675 | tex <- gameIO . alloca $ \ptr -> do | 675 | tex <- liftIO . alloca $ \ptr -> do |
676 | glGenTextures 1 ptr | 676 | glGenTextures 1 ptr |
677 | peek ptr | 677 | peek ptr |
678 | 678 | ||
@@ -697,7 +697,7 @@ loadTextureImage :: | |||
697 | loadTextureImage file minFilter magFilter = do | 697 | loadTextureImage file minFilter magFilter = do |
698 | image <- loadImage file | 698 | image <- loadImage file |
699 | tex <- newTexture | 699 | tex <- newTexture |
700 | gameIO $ do | 700 | liftIO $ do |
701 | let w = width image | 701 | let w = width image |
702 | h = height image | 702 | h = height image |
703 | pix = pixels image | 703 | pix = pixels image |
@@ -794,7 +794,7 @@ printGLError = | |||
794 | assertGL :: Game s a -> String -> Game s a | 794 | assertGL :: Game s a -> String -> Game s a |
795 | assertGL action err = do | 795 | assertGL action err = do |
796 | result <- action | 796 | result <- action |
797 | status <- gameIO getGLError | 797 | status <- liftIO getGLError |
798 | case status of | 798 | case status of |
799 | Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str | 799 | Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str |
800 | Nothing -> return result | 800 | Nothing -> return result |
diff --git a/Spear/Game.hs b/Spear/Game.hs index 14e3f20..ae986c8 100644 --- a/Spear/Game.hs +++ b/Spear/Game.hs | |||
@@ -1,143 +1,141 @@ | |||
1 | {-# LANGUAGE FlexibleInstances #-} | ||
2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
3 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
4 | |||
1 | module Spear.Game | 5 | module Spear.Game |
2 | ( Game, | 6 | ( Game |
3 | GameException (..), | 7 | , GameException(..) |
4 | Resource, | 8 | , HasState(..) |
5 | ResourceClass (..), | 9 | , ResourceClass(..) |
6 | 10 | , ReleaseKey | |
7 | -- * Game state | 11 | -- * Game state |
8 | getGameState, | 12 | , get |
9 | saveGameState, | 13 | , put |
10 | modifyGameState, | 14 | , modify |
11 | 15 | -- * Game resources | |
12 | -- * Game resources | 16 | , register |
13 | register, | 17 | , release |
14 | release, | 18 | , release' |
15 | release', | 19 | -- * Error handling |
16 | 20 | , gameError | |
17 | -- * Error handling | 21 | , assertMaybe |
18 | gameError, | 22 | , catch |
19 | assertMaybe, | 23 | -- * Running and IO |
20 | catchGameError, | 24 | , runGame |
21 | catchGameErrorFinally, | 25 | , runChildGame |
22 | 26 | , runSiblingGame | |
23 | -- * Running and IO | 27 | , eval |
24 | runGame, | 28 | , exec |
25 | evalGame, | 29 | , exec' |
26 | runSubGame, | 30 | , siblingGame |
27 | runSubGame', | 31 | , liftIO |
28 | evalSubGame, | 32 | ) |
29 | execSubGame, | ||
30 | runSiblingGame, | ||
31 | runSiblingGame', | ||
32 | evalSiblingGame, | ||
33 | execSiblingGame, | ||
34 | gameIO, | ||
35 | ) | ||
36 | where | 33 | where |
37 | 34 | ||
38 | import Control.Monad.Catch | 35 | import Control.Monad.Catch |
39 | import Control.Monad.State.Strict | 36 | import Control.Monad.State.Strict |
40 | import Control.Monad.Trans.Class (lift) | 37 | import Control.Monad.Trans.Class (lift) |
41 | import qualified Control.Monad.Trans.Resource as R | 38 | import Control.Monad.Trans.Resource |
42 | |||
43 | 39 | ||
44 | type Resource = R.ReleaseKey | ||
45 | 40 | ||
41 | -- | Anything that holds a resource. | ||
42 | -- | ||
43 | -- This is a convenient wrapper so that we can define the general `release'` | ||
44 | -- function on any type of resource. | ||
46 | class ResourceClass a where | 45 | class ResourceClass a where |
47 | getResource :: a -> Resource | 46 | getResource :: a -> ReleaseKey |
48 | |||
49 | type Game s = StateT s (R.ResourceT IO) | ||
50 | 47 | ||
48 | -- | A game exception. | ||
49 | -- | ||
50 | -- This is mostly a convenient wrapper around `String` so that we can throw | ||
51 | -- strings directly with `gameError`. | ||
51 | newtype GameException = GameException String deriving (Show) | 52 | newtype GameException = GameException String deriving (Show) |
52 | 53 | ||
53 | instance Exception GameException | 54 | instance Exception GameException |
54 | 55 | ||
56 | -- | The game monad. | ||
57 | -- | ||
58 | -- The game monad performs three different roles: | ||
59 | -- | ||
60 | -- 1. I/O | ||
61 | -- 2. Resource management. | ||
62 | -- 3. State management. | ||
63 | newtype Game s a = Game { getGame :: StateT s (ResourceT IO) a } | ||
64 | deriving | ||
65 | ( Functor | ||
66 | , Applicative | ||
67 | , Monad | ||
68 | , MonadIO | ||
69 | , MonadThrow | ||
70 | , MonadCatch | ||
71 | , MonadState s | ||
72 | , MonadResource | ||
73 | ) | ||
55 | 74 | ||
56 | -- | Retrieve the game state. | 75 | -- | A class used to define state hierarchies. |
57 | getGameState :: Game s s | 76 | -- |
58 | getGameState = get | 77 | -- By declaring `HasState s t`, a `Game s` monad can then execute actions of a |
59 | 78 | -- `Game t` monad more conveniently with `siblingGame`. | |
60 | -- | Save the game state. | 79 | class HasState s t where |
61 | saveGameState :: s -> Game s () | 80 | getInnerState :: s -> t |
62 | saveGameState = put | 81 | setInnerState :: s -> t -> s |
63 | |||
64 | -- | Modify the game state. | ||
65 | modifyGameState :: (s -> s) -> Game s () | ||
66 | modifyGameState = modify | ||
67 | 82 | ||
68 | -- | Register the given cleaner. | 83 | -- Identity instance. |
69 | register :: IO () -> Game s Resource | 84 | instance HasState s s where |
70 | register = lift . R.register | 85 | getInnerState = id |
86 | setInnerState s s' = s' | ||
71 | 87 | ||
72 | -- | Release the given 'Resource'. | ||
73 | release :: ResourceClass a => a -> Game s () | ||
74 | release = lift . R.release . getResource | ||
75 | 88 | ||
76 | -- | Release the given 'Resource'. | 89 | -- | Release the given 'Resource'. |
77 | release' :: ResourceClass a => a -> IO () | 90 | release' :: ResourceClass a => a -> Game s () |
78 | release' = R.release . getResource | 91 | release' = release . getResource |
79 | 92 | ||
80 | -- | Throw an error from the 'Game' monad. | 93 | -- | Throw an error from the 'Game' monad. |
81 | gameError :: String -> Game s a | 94 | gameError :: String -> Game s a |
82 | gameError = gameError' . GameException | 95 | gameError = throwM . GameException |
83 | |||
84 | -- | Throw an error from the 'Game' monad. | ||
85 | gameError' :: GameException -> Game s a | ||
86 | gameError' = lift . lift . throwM | ||
87 | 96 | ||
88 | -- | Throw the given error if given 'Nothing'. | 97 | -- | Throw the given error if given 'Nothing'. |
89 | assertMaybe :: Maybe a -> GameException -> Game s a | 98 | assertMaybe :: Maybe a -> GameException -> Game s a |
90 | assertMaybe Nothing err = gameError' err | 99 | assertMaybe Nothing err = throwM err |
91 | assertMaybe (Just x) _ = return x | 100 | assertMaybe (Just x) _ = return x |
92 | 101 | ||
93 | -- | Run the given game with the given error handler. | 102 | -- | Run the given game, unrolling the full monad stack and returning the game's |
94 | catchGameError :: Game s a -> (GameException -> Game s a) -> Game s a | 103 | -- result and its final state. |
95 | catchGameError = catch | 104 | -- |
96 | 105 | -- Any resources acquired by the given game are released when this returns. | |
97 | -- | Run the given game, catch any error, run the given finaliser and rethrow the error. | 106 | runGame :: s -> Game s a -> IO (a, s) |
98 | catchGameErrorFinally :: Game s a -> Game s a -> Game s a | 107 | runGame state game = runResourceT . runStateT (getGame game) $ state |
99 | catchGameErrorFinally game finally = catch game $ \err -> finally >> gameError' err | 108 | |
100 | 109 | -- | Run the given child game, unrolling the full monad stack and returning the | |
101 | -- | Run the given game. | 110 | -- game's result and its final state. |
102 | runGame :: Game s a -> s -> IO (a, s) | 111 | -- |
103 | runGame game = R.runResourceT . runStateT game | 112 | -- Like `runGame`, this frees any resources that are acquired by the sub-game. |
113 | -- If you want to keep acquired resources, see `runSiblingGame` instead. | ||
114 | runChildGame :: s -> Game s a -> Game t (a, s) | ||
115 | runChildGame state game = liftIO $ runGame state game | ||
116 | |||
117 | -- | Run the given sibling game, unrolling the state transformer but not the | ||
118 | -- resource transformer. | ||
119 | -- | ||
120 | -- Unlike `runChildGame`, any resources acquired by the sibling game are *not* | ||
121 | -- released. | ||
122 | runSiblingGame :: s -> Game s a -> Game t (a, s) | ||
123 | runSiblingGame state game = Game . lift $ runStateT (getGame game) state | ||
104 | 124 | ||
105 | -- | Run the given game and return its result. | 125 | -- | Run the given game and return its result. |
106 | evalGame :: Game s a -> s -> IO a | 126 | --eval :: (Monad m s, Monad n s) => (m s a -> s -> n (a, s)) -> m s a -> s -> m a |
107 | evalGame g s = fst <$> runGame g s | 127 | eval runner game state = fst <$> runner game state |
108 | 128 | ||
109 | -- | Fully run the given sub game, unrolling the entire monad stack. | 129 | -- | Run the given game and return its final state. |
110 | runSubGame :: Game s a -> s -> Game t (a, s) | 130 | exec runner game state = snd <$> runner game state |
111 | runSubGame g s = gameIO $ runGame g s | 131 | |
112 | 132 | -- | Run the given game and ignore both its result and final state. | |
113 | -- | Like 'runSubGame', but discarding the result. | 133 | exec' runner game state = void $ runner game state |
114 | runSubGame' :: Game s a -> s -> Game t () | 134 | |
115 | runSubGame' g s = void $ runSubGame g s | 135 | -- | Run a sibling game on nested state. |
116 | 136 | siblingGame :: HasState s t => Game t a -> Game s a | |
117 | -- | Run the given sub game and return its result. | 137 | siblingGame tAction = do |
118 | evalSubGame :: Game s a -> s -> Game t a | 138 | outerState <- getInnerState <$> get |
119 | evalSubGame g s = fst <$> runSubGame g s | 139 | (result, outerState') <- runSiblingGame outerState tAction |
120 | 140 | modify $ \outerState -> setInnerState outerState outerState' | |
121 | -- | Run the given sub game and return its state. | 141 | return result |
122 | execSubGame :: Game s a -> s -> Game t s | ||
123 | execSubGame g s = snd <$> runSubGame g s | ||
124 | |||
125 | -- | Run the given sibling game, unrolling StateT but not ResourceT. | ||
126 | runSiblingGame :: Game s a -> s -> Game t (a, s) | ||
127 | runSiblingGame g s = lift $ runStateT g s | ||
128 | |||
129 | -- | Like 'runSiblingGame', but discarding the result. | ||
130 | runSiblingGame' :: Game s a -> s -> Game t () | ||
131 | runSiblingGame' g s = void $ runSiblingGame g s | ||
132 | |||
133 | -- | Run the given sibling game and return its result. | ||
134 | evalSiblingGame :: Game s a -> s -> Game t a | ||
135 | evalSiblingGame g s = fst <$> runSiblingGame g s | ||
136 | |||
137 | -- | Run the given sibling game and return its state. | ||
138 | execSiblingGame :: Game s a -> s -> Game t s | ||
139 | execSiblingGame g s = snd <$> runSiblingGame g s | ||
140 | |||
141 | -- | Perform the given IO action in the 'Game' monad. | ||
142 | gameIO :: IO a -> Game s a | ||
143 | gameIO = lift . lift | ||
diff --git a/Spear/Math/Physics/Rigid.hs b/Spear/Math/Physics/Rigid.hs deleted file mode 100644 index 28995bd..0000000 --- a/Spear/Math/Physics/Rigid.hs +++ /dev/null | |||
@@ -1,125 +0,0 @@ | |||
1 | module Spear.Math.Physics.Rigid | ||
2 | ( | ||
3 | module Spear.Math.Physics.Types | ||
4 | , RigidBody(..) | ||
5 | , rigidBody | ||
6 | , update | ||
7 | , setVelocity | ||
8 | , setAcceleration | ||
9 | ) | ||
10 | where | ||
11 | |||
12 | import qualified Spear.Math.Matrix3 as M3 | ||
13 | import Spear.Math.Spatial2 | ||
14 | import Spear.Math.Vector | ||
15 | import Spear.Physics.Types | ||
16 | |||
17 | import Data.List (foldl') | ||
18 | import Control.Monad.State | ||
19 | |||
20 | data RigidBody = RigidBody | ||
21 | { mass :: {-# UNPACK #-} !Float | ||
22 | , position :: {-# UNPACK #-} !Position | ||
23 | , velocity :: {-# UNPACK #-} !Velocity | ||
24 | , acceleration :: {-# UNPACK #-} !Acceleration | ||
25 | } | ||
26 | |||
27 | instance Spatial2 RigidBody where | ||
28 | |||
29 | move v body = body { position = v + position body } | ||
30 | |||
31 | moveFwd speed body = body { position = position body + scale speed unity2 } | ||
32 | |||
33 | moveBack speed body = body { position = position body + scale (-speed) unity2 } | ||
34 | |||
35 | strafeLeft speed body = body { position = position body + scale (-speed) unitx2 } | ||
36 | |||
37 | strafeRight speed body = body { position = position body + scale speed unitx2 } | ||
38 | |||
39 | rotate angle = id | ||
40 | |||
41 | setRotation angle = id | ||
42 | |||
43 | pos = position | ||
44 | |||
45 | fwd _ = unity2 | ||
46 | |||
47 | up _ = unity2 | ||
48 | |||
49 | right _ = unitx2 | ||
50 | |||
51 | transform body = M3.transform unitx2 unity2 $ position body | ||
52 | |||
53 | setTransform transf body = body { position = M3.position transf } | ||
54 | |||
55 | setPos p body = body { position = p } | ||
56 | |||
57 | -- | Build a 'RigidBody'. | ||
58 | rigidBody :: Mass -> Position -> RigidBody | ||
59 | rigidBody m x = RigidBody m x zero2 zero2 | ||
60 | |||
61 | -- | Update the given 'RigidBody'. | ||
62 | update :: [Force] -> Dt -> RigidBody -> RigidBody | ||
63 | update forces dt body = | ||
64 | let netforce = foldl' (+) zero2 forces | ||
65 | m = mass body | ||
66 | r1 = position body | ||
67 | v1 = velocity body | ||
68 | a1 = acceleration body | ||
69 | r2 = r1 + scale dt v1 + scale (0.5*dt*dt) a1 | ||
70 | v' = v1 + scale (0.5*dt) a1 | ||
71 | a2 = a1 + scale (1/m) netforce | ||
72 | v2 = v1 + scale (dt/2) (a2+a1) + scale (0.5*dt) a2 | ||
73 | in | ||
74 | RigidBody m r2 v2 a2 | ||
75 | |||
76 | -- | Set the body's velocity. | ||
77 | setVelocity :: Velocity -> RigidBody -> RigidBody | ||
78 | setVelocity v body = body { velocity = v } | ||
79 | |||
80 | -- | Set the body's acceleration. | ||
81 | setAcceleration :: Acceleration -> RigidBody -> RigidBody | ||
82 | setAcceleration a body = body { acceleration = a } | ||
83 | |||
84 | |||
85 | -- test | ||
86 | {-gravity = vec2 0 (-10) | ||
87 | b0 = rigidBody 50 $ vec2 0 1000 | ||
88 | |||
89 | |||
90 | debug :: IO () | ||
91 | debug = evalStateT debug' b0 | ||
92 | |||
93 | |||
94 | |||
95 | debug' :: StateT RigidBody IO () | ||
96 | debug' = do | ||
97 | lift . putStrLn $ "Initial body:" | ||
98 | lift . putStrLn . show' $ b0 | ||
99 | lift . putStrLn $ "Falling..." | ||
100 | step $ update [gravity*50] 1 | ||
101 | step $ update [gravity*50] 1 | ||
102 | step $ update [gravity*50] 1 | ||
103 | lift . putStrLn $ "Jumping" | ||
104 | step $ update [gravity*50, vec2 0 9000] 1 | ||
105 | lift . putStrLn $ "Falling..." | ||
106 | step $ update [gravity*50] 1 | ||
107 | step $ update [gravity*50] 1 | ||
108 | step $ update [gravity*50] 1 | ||
109 | |||
110 | |||
111 | step :: (RigidBody -> RigidBody) -> StateT RigidBody IO () | ||
112 | step update = do | ||
113 | modify update | ||
114 | body <- get | ||
115 | lift . putStrLn . show' $ body | ||
116 | |||
117 | |||
118 | show' body = | ||
119 | "mass " ++ (show $ mass body) ++ | ||
120 | ", position " ++ (showVec $ position body) ++ | ||
121 | ", velocity " ++ (showVec $ velocity body) ++ | ||
122 | ", acceleration " ++ (showVec $ acceleration body) | ||
123 | |||
124 | |||
125 | showVec v = (show $ x v) ++ ", " ++ (show $ y v)-} | ||
diff --git a/Spear/Math/Physics/Types.hs b/Spear/Math/Physics/Types.hs deleted file mode 100644 index 59e6c74..0000000 --- a/Spear/Math/Physics/Types.hs +++ /dev/null | |||
@@ -1,11 +0,0 @@ | |||
1 | module Spear.Math.Physics.Types | ||
2 | where | ||
3 | |||
4 | import Spear.Math.Vector | ||
5 | |||
6 | type Dt = Float | ||
7 | type Force = Vector2 | ||
8 | type Mass = Float | ||
9 | type Position = Vector2 | ||
10 | type Velocity = Vector2 | ||
11 | type Acceleration = Vector2 | ||
diff --git a/Spear/Math/Plane.hs b/Spear/Math/Plane.hs index 5440a43..cbf5aed 100644 --- a/Spear/Math/Plane.hs +++ b/Spear/Math/Plane.hs | |||
@@ -2,41 +2,75 @@ | |||
2 | 2 | ||
3 | module Spear.Math.Plane | 3 | module Spear.Math.Plane |
4 | ( | 4 | ( |
5 | Plane | 5 | Plane(..) |
6 | , plane | 6 | , AxisPlane(..) |
7 | , classify | 7 | , plane |
8 | , axisPlane | ||
9 | , planeClassify | ||
10 | , axisPlaneClassify | ||
8 | ) | 11 | ) |
9 | where | 12 | where |
10 | 13 | ||
11 | import Spear.Math.Vector | 14 | import Spear.Math.Vector |
12 | import Spear.Prelude | 15 | import Spear.Prelude |
13 | 16 | ||
17 | |||
18 | data Axis = X | Y | Z deriving (Eq, Show) | ||
19 | |||
20 | data AxisOrientation = PositiveAxis | NegativeAxis deriving (Eq, Show) | ||
21 | |||
14 | data PointPlanePos = Front | Back | Contained deriving (Eq, Show) | 22 | data PointPlanePos = Front | Back | Contained deriving (Eq, Show) |
15 | 23 | ||
24 | -- | A 3D plane. | ||
16 | data Plane = Plane | 25 | data Plane = Plane |
17 | { n :: {-# UNPACK #-} !Vector3, | 26 | { planeNormal :: {-# UNPACK #-} !Vector3 |
18 | d :: {-# UNPACK #-} !Float | 27 | , planeDistance :: {-# UNPACK #-} !Float |
19 | } | 28 | } |
20 | deriving(Eq, Show) | 29 | deriving(Eq, Show) |
21 | 30 | ||
31 | -- | An axis-aligned 3D plane. | ||
32 | data AxisPlane = AxisPlane | ||
33 | { axisPlaneAxis :: !Axis | ||
34 | , axisPlaneDistance :: {-# UNPACK #-} !Float | ||
35 | , axisPlaneNormal :: !AxisOrientation | ||
36 | } | ||
37 | deriving (Eq, Show) | ||
38 | |||
39 | |||
22 | -- | Construct a plane from a normal vector and a distance from the origin. | 40 | -- | Construct a plane from a normal vector and a distance from the origin. |
23 | plane :: Vector3 -> Float -> Plane | 41 | plane :: Vector3 -> Float -> Plane |
24 | plane n d = Plane (normalise n) d | 42 | plane n d = Plane (normalise n) d |
25 | 43 | ||
44 | -- | Construct an axis-aligned plane. | ||
45 | axisPlane :: Axis -> Float -> AxisOrientation -> AxisPlane | ||
46 | axisPlane = AxisPlane | ||
47 | |||
26 | -- | Construct a plane from three points. | 48 | -- | Construct a plane from three points. |
27 | -- | 49 | -- |
28 | -- Points must be given in counter-clockwise order. | 50 | -- Points must be given in counter-clockwise order. |
29 | fromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane | 51 | planeFromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane |
30 | fromPoints p0 p1 p2 = Plane n d | 52 | planeFromPoints p0 p1 p2 = Plane n d |
31 | where n = normalise $ v1 `cross` v2 | 53 | where n = normalise $ v1 `cross` v2 |
32 | v1 = p2 - p1 | 54 | v1 = p2 - p1 |
33 | v2 = p0 - p1 | 55 | v2 = p0 - p1 |
34 | d = p0 `dot` n | 56 | d = p0 `dot` n |
35 | 57 | ||
36 | -- | Classify the given point's relative position with respect to the plane. | 58 | -- | Classify the given point's relative position with respect to the plane. |
37 | classify :: Plane -> Vector3 -> PointPlanePos | 59 | planeClassify :: Plane -> Vector3 -> PointPlanePos |
38 | classify (Plane n d) pt = | 60 | planeClassify (Plane n d) pt = |
39 | case (n `dot` pt - d) `compare` 0 of | 61 | case (n `dot` pt - d) `compare` 0 of |
40 | GT -> Front | 62 | GT -> Front |
41 | LT -> Back | 63 | LT -> Back |
42 | EQ -> Contained | 64 | EQ -> Contained |
65 | |||
66 | -- | Classify the given point's relative position with respect to the plane. | ||
67 | axisPlaneClassify :: AxisPlane -> Vector3 -> PointPlanePos | ||
68 | axisPlaneClassify (AxisPlane axis d _) (Vector3 x y z) = | ||
69 | let classify coord | ||
70 | | coord < d = Back | ||
71 | | coord > d = Front | ||
72 | | otherwise = Contained | ||
73 | in case axis of | ||
74 | X -> classify x | ||
75 | Y -> classify y | ||
76 | Z -> classify z | ||
diff --git a/Spear/Math/Spatial.hs b/Spear/Math/Spatial.hs index bfab6c2..b6a3ede 100644 --- a/Spear/Math/Spatial.hs +++ b/Spear/Math/Spatial.hs | |||
@@ -88,22 +88,22 @@ class (Positional a v, Rotational a v r) => Spatial a v r t | a -> t where | |||
88 | move :: Positional a v => Float -> (a -> v) -> a -> a | 88 | move :: Positional a v => Float -> (a -> v) -> a -> a |
89 | move delta axis a = translate (axis a * delta) a | 89 | move delta axis a = translate (axis a * delta) a |
90 | 90 | ||
91 | -- | Move the spatial upwards. | 91 | -- | Move the spatial along its right axis. |
92 | moveRight delta = move delta right | 92 | moveRight delta = move delta right |
93 | 93 | ||
94 | -- | Move the spatial downwards. | 94 | -- | Move the spatial along its left axis. |
95 | moveLeft delta = moveRight (-delta) | 95 | moveLeft delta = moveRight (-delta) |
96 | 96 | ||
97 | -- | Move the spatial upwards. | 97 | -- | Move the spatial along its up axis. |
98 | moveUp delta = move delta up | 98 | moveUp delta = move delta up |
99 | 99 | ||
100 | -- | Move the spatial downwards. | 100 | -- | Move the spatial along its down axis. |
101 | moveDown delta = moveUp (-delta) | 101 | moveDown delta = moveUp (-delta) |
102 | 102 | ||
103 | -- | Move the spatial forwards. | 103 | -- | Move the spatial along its forward axis. |
104 | moveFwd delta = move delta forward | 104 | moveFwd delta = move delta forward |
105 | 105 | ||
106 | -- | Move the spatial backwards. | 106 | -- | Move the spatial along its backward axis. |
107 | moveBack delta = moveFwd (-delta) | 107 | moveBack delta = moveFwd (-delta) |
108 | 108 | ||
109 | -- | Make the spatial look at the given point. | 109 | -- | Make the spatial look at the given point. |
diff --git a/Spear/Math/Spatial2.hs b/Spear/Math/Spatial2.hs index 1cc2b65..62eb75a 100644 --- a/Spear/Math/Spatial2.hs +++ b/Spear/Math/Spatial2.hs | |||
@@ -14,6 +14,8 @@ import Spear.Math.Vector | |||
14 | import Spear.Prelude | 14 | import Spear.Prelude |
15 | 15 | ||
16 | 16 | ||
17 | -- TODO: These type synonyms don't seem to work well when trying to instantiate | ||
18 | -- the classes. | ||
17 | type Positional2 a = Positional a Vector2 | 19 | type Positional2 a = Positional a Vector2 |
18 | type Rotational2 a = Rotational a Angle | 20 | type Rotational2 a = Rotational a Angle |
19 | type Spatial2 s = Spatial s Vector2 Angle Transform2 | 21 | type Spatial2 s = Spatial s Vector2 Angle Transform2 |
diff --git a/Spear/Math/Vector/Vector.hs b/Spear/Math/Vector/Vector.hs index e7f6d53..d9cd64f 100644 --- a/Spear/Math/Vector/Vector.hs +++ b/Spear/Math/Vector/Vector.hs | |||
@@ -48,3 +48,6 @@ class | |||
48 | 48 | ||
49 | -- | Normalise the given vector. | 49 | -- | Normalise the given vector. |
50 | normalise :: v -> v | 50 | normalise :: v -> v |
51 | |||
52 | -- | Scale the vector. | ||
53 | scale :: Float -> v -> v | ||
diff --git a/Spear/Math/Vector/Vector2.hs b/Spear/Math/Vector/Vector2.hs index 1ede3a9..b74cfef 100644 --- a/Spear/Math/Vector/Vector2.hs +++ b/Spear/Math/Vector/Vector2.hs | |||
@@ -33,7 +33,10 @@ type Position2 = Vector2 | |||
33 | 33 | ||
34 | 34 | ||
35 | -- | Represents a vector in 2D. | 35 | -- | Represents a vector in 2D. |
36 | data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show) | 36 | data Vector2 = Vector2 |
37 | {-# UNPACK #-} !Float | ||
38 | {-# UNPACK #-} !Float | ||
39 | deriving (Eq, Show) | ||
37 | 40 | ||
38 | 41 | ||
39 | instance Addition Vector2 Vector2 where | 42 | instance Addition Vector2 Vector2 where |
@@ -129,6 +132,9 @@ instance Vector Vector2 where | |||
129 | n = if n' == 0 then 1 else n' | 132 | n = if n' == 0 then 1 else n' |
130 | in ((1.0::Float) / n) * v | 133 | in ((1.0::Float) / n) * v |
131 | 134 | ||
135 | {-# INLINABLE scale #-} | ||
136 | scale s (Vector2 x y) = Vector2 (s*x) (s*y) | ||
137 | |||
132 | 138 | ||
133 | sizeFloat = sizeOf (undefined :: CFloat) | 139 | sizeFloat = sizeOf (undefined :: CFloat) |
134 | 140 | ||
diff --git a/Spear/Math/Vector/Vector3.hs b/Spear/Math/Vector/Vector3.hs index db5dc45..6ad4fe1 100644 --- a/Spear/Math/Vector/Vector3.hs +++ b/Spear/Math/Vector/Vector3.hs | |||
@@ -163,6 +163,9 @@ instance Vector Vector3 where | |||
163 | n = if n' == 0 then 1 else n' | 163 | n = if n' == 0 then 1 else n' |
164 | in ((1.0::Float) / n) * v | 164 | in ((1.0::Float) / n) * v |
165 | 165 | ||
166 | {-# INLINABLE scale #-} | ||
167 | scale s (Vector3 x y z) = Vector3 (s*x) (s*y) (s*z) | ||
168 | |||
166 | 169 | ||
167 | sizeFloat = sizeOf (undefined :: CFloat) | 170 | sizeFloat = sizeOf (undefined :: CFloat) |
168 | 171 | ||
diff --git a/Spear/Math/Vector/Vector4.hs b/Spear/Math/Vector/Vector4.hs index 907295e..3ca27c9 100644 --- a/Spear/Math/Vector/Vector4.hs +++ b/Spear/Math/Vector/Vector4.hs | |||
@@ -161,6 +161,9 @@ instance Vector Vector4 where | |||
161 | n = if n' == 0 then 1 else n' | 161 | n = if n' == 0 then 1 else n' |
162 | in ((1.0::Float) / n) * v | 162 | in ((1.0::Float) / n) * v |
163 | 163 | ||
164 | {-# INLINABLE scale #-} | ||
165 | scale s (Vector4 x y z w) = Vector4 (s*x) (s*y) (s*z) (s*w) | ||
166 | |||
164 | 167 | ||
165 | sizeFloat = sizeOf (undefined :: CFloat) | 168 | sizeFloat = sizeOf (undefined :: CFloat) |
166 | 169 | ||
diff --git a/Spear/Physics/Collision.hs b/Spear/Physics/Collision.hs new file mode 100644 index 0000000..9ade9ca --- /dev/null +++ b/Spear/Physics/Collision.hs | |||
@@ -0,0 +1,63 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | ||
2 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
3 | {-# LANGUAGE NoImplicitPrelude #-} | ||
4 | {-# LANGUAGE TypeSynonymInstances #-} | ||
5 | |||
6 | module Spear.Physics.Collision | ||
7 | ( | ||
8 | BoundingVolume2(..) | ||
9 | , Bounded2(..) | ||
10 | , aabb2Volume | ||
11 | , collide | ||
12 | ) | ||
13 | where | ||
14 | |||
15 | import Spear.Math.AABB | ||
16 | import Spear.Math.Spatial | ||
17 | import Spear.Math.Spatial2 | ||
18 | import Spear.Math.Vector | ||
19 | import Spear.Prelude | ||
20 | |||
21 | import Data.Maybe (mapMaybe) | ||
22 | |||
23 | |||
24 | -- Currently supporting AABB2. Add circles later when needed. | ||
25 | data BoundingVolume2 | ||
26 | = AABB2Volume { box2 :: {-# UNPACK #-} !AABB2 } | ||
27 | |||
28 | |||
29 | class Bounded2 a where | ||
30 | boundingVolume :: a -> BoundingVolume2 | ||
31 | |||
32 | |||
33 | -- | Construct a new bounding volume from a 2D axis-aligned box. | ||
34 | aabb2Volume :: AABB2 -> BoundingVolume2 | ||
35 | aabb2Volume = AABB2Volume | ||
36 | |||
37 | |||
38 | -- | Find collisions between the objects in the first list and the objects in | ||
39 | -- the second list. | ||
40 | collide :: Bounded2 a => [a] -> [a] -> [(a,a)] | ||
41 | collide xs ys = | ||
42 | mapMaybe testCollision pairs | ||
43 | where | ||
44 | testCollision [o1, o2] = if objectsCollide o1 o2 then Just (o1, o2) else Nothing | ||
45 | pairs = sequence [xs, ys] | ||
46 | |||
47 | |||
48 | -- | Test two objects for collision. | ||
49 | objectsCollide :: Bounded2 a => a -> a -> Bool | ||
50 | objectsCollide o1 o2 = | ||
51 | collideAABB2 (box2 . boundingVolume $ o1) (box2 . boundingVolume $ o2) | ||
52 | |||
53 | |||
54 | -- | Test two 2D axis-aligned bounding boxes for collision. | ||
55 | collideAABB2 :: AABB2 -> AABB2 -> Bool | ||
56 | collideAABB2 box1 box2 = | ||
57 | let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) = box1 | ||
58 | (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) = box2 | ||
59 | in not $ | ||
60 | xmax1 < xmin2 || | ||
61 | xmin1 > xmax2 || | ||
62 | ymax1 < ymin2 || | ||
63 | ymin1 > ymax2 | ||
diff --git a/Spear/Physics/RigidBody.hs b/Spear/Physics/RigidBody.hs new file mode 100644 index 0000000..1a8fe0a --- /dev/null +++ b/Spear/Physics/RigidBody.hs | |||
@@ -0,0 +1,77 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | ||
2 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
3 | {-# LANGUAGE NoImplicitPrelude #-} | ||
4 | {-# LANGUAGE TypeSynonymInstances #-} | ||
5 | |||
6 | module Spear.Physics.RigidBody | ||
7 | ( | ||
8 | RigidBody2 | ||
9 | , rigidBody | ||
10 | , setVelocity | ||
11 | , setAcceleration | ||
12 | , update | ||
13 | ) | ||
14 | where | ||
15 | |||
16 | import Spear.Math.Spatial | ||
17 | import Spear.Math.Spatial2 | ||
18 | import Spear.Math.Vector | ||
19 | import Spear.Prelude | ||
20 | |||
21 | import Control.Monad.State | ||
22 | import Data.List (foldl') | ||
23 | |||
24 | |||
25 | type Dt = Float | ||
26 | type Force = Vector2 | ||
27 | type Mass = Float | ||
28 | type Position = Vector2 | ||
29 | type Velocity = Vector2 | ||
30 | type Acceleration = Vector2 | ||
31 | |||
32 | |||
33 | {- class RigidBody2 a where | ||
34 | bodyMass :: a -> Float | ||
35 | bodyPosition :: a -> Vector2 | ||
36 | bodyVelocity :: a -> Vector2 | ||
37 | bodyAcceleration :: a -> Vector2 -} | ||
38 | |||
39 | |||
40 | data RigidBody2 = RigidBody2 | ||
41 | { bodyMass :: {-# UNPACK #-} !Float | ||
42 | , bodyPosition :: {-# UNPACK #-} !Position | ||
43 | , bodyVelocity :: {-# UNPACK #-} !Velocity | ||
44 | , bodyAcceleration :: {-# UNPACK #-} !Acceleration | ||
45 | } | ||
46 | |||
47 | |||
48 | instance Positional RigidBody2 Vector2 where | ||
49 | setPosition p body = body { bodyPosition = p } | ||
50 | position = bodyPosition | ||
51 | translate v body = body { bodyPosition = bodyPosition body + v } | ||
52 | |||
53 | |||
54 | -- | Build a 'RigidBody'. | ||
55 | rigidBody :: Mass -> Position -> RigidBody2 | ||
56 | rigidBody mass position = RigidBody2 mass position zero2 zero2 | ||
57 | |||
58 | |||
59 | -- | Set the body's velocity. | ||
60 | setVelocity :: Velocity -> RigidBody2 -> RigidBody2 | ||
61 | setVelocity velocity body = body { bodyVelocity = velocity } | ||
62 | |||
63 | |||
64 | -- | Set the body's acceleration. | ||
65 | setAcceleration :: Acceleration -> RigidBody2 -> RigidBody2 | ||
66 | setAcceleration acceleration body = body { bodyAcceleration = acceleration } | ||
67 | |||
68 | |||
69 | -- | Update the given 'RigidBody'. | ||
70 | update :: [Force] -> Dt -> RigidBody2 -> RigidBody2 | ||
71 | update forces dt body@(RigidBody2 m p v a) = | ||
72 | let f = foldl' (+) zero2 forces | ||
73 | a' = a + (f / m) | ||
74 | v' = v + (a' * dt) | ||
75 | p' = p + (v' * dt) | ||
76 | in | ||
77 | RigidBody2 m p' v' a' | ||
diff --git a/Spear/Render/AnimatedModel.hs b/Spear/Render/AnimatedModel.hs index 8f0d6bd..e5b29ec 100644 --- a/Spear/Render/AnimatedModel.hs +++ b/Spear/Render/AnimatedModel.hs | |||
@@ -66,7 +66,7 @@ data AnimatedModelResource = AnimatedModelResource | |||
66 | material :: Material, | 66 | material :: Material, |
67 | texture :: Texture, | 67 | texture :: Texture, |
68 | boxes :: V.Vector Box, | 68 | boxes :: V.Vector Box, |
69 | rkey :: Resource | 69 | rkey :: ReleaseKey |
70 | } | 70 | } |
71 | 71 | ||
72 | instance Eq AnimatedModelResource where | 72 | instance Eq AnimatedModelResource where |
@@ -121,12 +121,12 @@ animatedModelResource | |||
121 | material | 121 | material |
122 | texture | 122 | texture |
123 | model = do | 123 | model = do |
124 | RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model | 124 | RenderModel elements numFrames numVertices <- liftIO . renderModelFromModel $ model |
125 | elementBuf <- newBuffer | 125 | elementBuf <- newBuffer |
126 | vao <- newVAO | 126 | vao <- newVAO |
127 | boxes <- gameIO $ modelBoxes model | 127 | boxes <- liftIO $ modelBoxes model |
128 | 128 | ||
129 | gameIO $ do | 129 | liftIO $ do |
130 | let elemSize = 56::CUInt | 130 | let elemSize = 56::CUInt |
131 | elemSize' = fromIntegral elemSize | 131 | elemSize' = fromIntegral elemSize |
132 | n = numVertices * numFrames | 132 | n = numVertices * numFrames |
@@ -149,9 +149,8 @@ animatedModelResource | |||
149 | enableVAOAttrib texChan | 149 | enableVAOAttrib texChan |
150 | 150 | ||
151 | rkey <- register $ do | 151 | rkey <- register $ do |
152 | putStrLn "Releasing animated model resource" | 152 | release $ vaoKey vao |
153 | release' vao | 153 | release $ bufferKey elementBuf |
154 | release' elementBuf | ||
155 | 154 | ||
156 | return $ | 155 | return $ |
157 | AnimatedModelResource | 156 | AnimatedModelResource |
diff --git a/Spear/Render/Core/Buffer.hs b/Spear/Render/Core/Buffer.hs index a4e98a4..3003987 100644 --- a/Spear/Render/Core/Buffer.hs +++ b/Spear/Render/Core/Buffer.hs | |||
@@ -14,6 +14,7 @@ import Spear.Math.Vector | |||
14 | import Spear.Render.Core.State | 14 | import Spear.Render.Core.State |
15 | 15 | ||
16 | import Control.Monad (unless, void) | 16 | import Control.Monad (unless, void) |
17 | import Control.Monad.IO.Class | ||
17 | import qualified Data.HashMap as HashMap | 18 | import qualified Data.HashMap as HashMap |
18 | import Data.Word | 19 | import Data.Word |
19 | import Foreign.C.Types | 20 | import Foreign.C.Types |
@@ -53,24 +54,23 @@ makeBufferAndView desc = do | |||
53 | 54 | ||
54 | makeBuffer :: BufferDesc -> Game RenderCoreState Buffer | 55 | makeBuffer :: BufferDesc -> Game RenderCoreState Buffer |
55 | makeBuffer (BufferDesc usage bufferData) = do | 56 | makeBuffer (BufferDesc usage bufferData) = do |
56 | handle <- gameIO $ alloca $ \ptr -> glGenBuffers 1 ptr >> peek ptr | 57 | handle <- liftIO $ alloca $ \ptr -> glGenBuffers 1 ptr >> peek ptr |
57 | resourceKey <- register $ deleteBuffer' handle | 58 | resourceKey <- register $ deleteBuffer' handle |
58 | let buffer = Buffer handle resourceKey usage | 59 | let buffer = Buffer handle resourceKey usage |
59 | gameIO $ updateBuffer buffer bufferData | 60 | liftIO $ updateBuffer buffer bufferData |
60 | modifyGameState (\state -> state { | 61 | modify (\state -> state { |
61 | buffers = HashMap.insert handle buffer (buffers state) }) | 62 | buffers = HashMap.insert handle buffer (buffers state) }) |
62 | return buffer | 63 | return buffer |
63 | 64 | ||
64 | deleteBuffer :: Buffer -> Game RenderCoreState () | 65 | deleteBuffer :: Buffer -> Game RenderCoreState () |
65 | deleteBuffer buffer = do | 66 | deleteBuffer buffer = do |
66 | let matches buffer = (==bufferHandle buffer) . bufferHandle | 67 | modify (\state -> state { |
67 | modifyGameState (\state -> state { | ||
68 | buffers = HashMap.delete (bufferHandle buffer) (buffers state) }) | 68 | buffers = HashMap.delete (bufferHandle buffer) (buffers state) }) |
69 | release buffer | 69 | release' buffer |
70 | 70 | ||
71 | -- TODO: use glBufferSubData for updates. | 71 | -- TODO: use glBufferSubData for updates. |
72 | updateBuffer :: Buffer -> BufferData -> IO () | 72 | updateBuffer :: MonadIO io => Buffer -> BufferData -> io () |
73 | updateBuffer buffer bufferData = | 73 | updateBuffer buffer bufferData = liftIO $ |
74 | unless (bufferEmpty bufferData) $ do | 74 | unless (bufferEmpty bufferData) $ do |
75 | glBindBuffer GL_ARRAY_BUFFER (bufferHandle buffer) | 75 | glBindBuffer GL_ARRAY_BUFFER (bufferHandle buffer) |
76 | uploadData (bufferUsage buffer) bufferData | 76 | uploadData (bufferUsage buffer) bufferData |
diff --git a/Spear/Render/Core/Geometry.hs b/Spear/Render/Core/Geometry.hs index 6c05b38..05c23ec 100644 --- a/Spear/Render/Core/Geometry.hs +++ b/Spear/Render/Core/Geometry.hs | |||
@@ -21,6 +21,7 @@ import Spear.Render.Core.Buffer | |||
21 | import Spear.Render.Core.Constants | 21 | import Spear.Render.Core.Constants |
22 | import Spear.Render.Core.State | 22 | import Spear.Render.Core.State |
23 | 23 | ||
24 | import Control.Monad.IO.Class | ||
24 | import Data.HashMap as HashMap | 25 | import Data.HashMap as HashMap |
25 | import Data.IORef | 26 | import Data.IORef |
26 | import Data.Maybe (fromJust) | 27 | import Data.Maybe (fromJust) |
@@ -87,26 +88,26 @@ newGeometryDesc = GeometryDesc | |||
87 | makeGeometry :: GeometryDesc -> Game RenderCoreState Geometry | 88 | makeGeometry :: GeometryDesc -> Game RenderCoreState Geometry |
88 | makeGeometry desc = do | 89 | makeGeometry desc = do |
89 | gdata <- geometryDescToData desc | 90 | gdata <- geometryDescToData desc |
90 | handle <- gameIO $ alloca $ \ptr -> glGenVertexArrays 1 ptr >> peek ptr | 91 | handle <- liftIO $ alloca $ \ptr -> glGenVertexArrays 1 ptr >> peek ptr |
91 | gameIO $ do | 92 | liftIO $ do |
92 | glBindVertexArray handle | 93 | glBindVertexArray handle |
93 | configureVertexAttributes gdata | 94 | configureVertexAttributes gdata |
94 | glBindVertexArray 0 | 95 | glBindVertexArray 0 |
95 | gdataRef <- gameIO $ newIORef gdata | 96 | gdataRef <- liftIO $ newIORef gdata |
96 | resourceKey <- register $ deleteGeometry' handle | 97 | resourceKey <- register $ deleteGeometry' handle |
97 | let geometry = Geometry handle resourceKey gdataRef | 98 | let geometry = Geometry handle resourceKey gdataRef |
98 | modifyGameState (\state -> state { | 99 | modify (\state -> state { |
99 | geometries = HashMap.insert handle geometry (geometries state) }) | 100 | geometries = HashMap.insert handle geometry (geometries state) }) |
100 | return geometry | 101 | return geometry |
101 | 102 | ||
102 | deleteGeometry :: Geometry -> Game RenderCoreState () | 103 | deleteGeometry :: Geometry -> Game RenderCoreState () |
103 | deleteGeometry geometry = do | 104 | deleteGeometry geometry = do |
104 | modifyGameState (\state -> state { | 105 | modify (\state -> state { |
105 | geometries = HashMap.delete (geometryVao geometry) (geometries state) }) | 106 | geometries = HashMap.delete (geometryVao geometry) (geometries state) }) |
106 | release geometry | 107 | release' geometry |
107 | 108 | ||
108 | renderGeometry :: Geometry -> IO () | 109 | renderGeometry :: MonadIO io => Geometry -> io () |
109 | renderGeometry geometry = do | 110 | renderGeometry geometry = liftIO $ do |
110 | gdata <- readIORef (geometryData geometry) | 111 | gdata <- readIORef (geometryData geometry) |
111 | let mode = toGLPrimitiveType $ geometryPrimitiveType gdata | 112 | let mode = toGLPrimitiveType $ geometryPrimitiveType gdata |
112 | glBindVertexArray (geometryVao geometry) | 113 | glBindVertexArray (geometryVao geometry) |
@@ -121,8 +122,8 @@ renderGeometry geometry = do | |||
121 | 122 | ||
122 | -- Functions for updating dynamic geometry. | 123 | -- Functions for updating dynamic geometry. |
123 | 124 | ||
124 | setPositions :: Geometry -> [Vector3] -> IO () | 125 | setPositions :: MonadIO io => Geometry -> [Vector3] -> io () |
125 | setPositions geometry vectors = do | 126 | setPositions geometry vectors = liftIO $ do |
126 | gdata <- readIORef $ geometryData geometry | 127 | gdata <- readIORef $ geometryData geometry |
127 | case vertexPositions gdata of | 128 | case vertexPositions gdata of |
128 | VertexPositions3d view -> do | 129 | VertexPositions3d view -> do |
diff --git a/Spear/Render/Core/Pipeline.hs b/Spear/Render/Core/Pipeline.hs index 724b391..ee9c7d2 100644 --- a/Spear/Render/Core/Pipeline.hs +++ b/Spear/Render/Core/Pipeline.hs | |||
@@ -13,8 +13,9 @@ module Spear.Render.Core.Pipeline | |||
13 | ) | 13 | ) |
14 | where | 14 | where |
15 | 15 | ||
16 | import Data.Bits ((.|.)) | 16 | import Control.Monad.IO.Class |
17 | import Data.List (foldl') | 17 | import Data.Bits ((.|.)) |
18 | import Data.List (foldl') | ||
18 | import Graphics.GL.Core46 | 19 | import Graphics.GL.Core46 |
19 | 20 | ||
20 | 21 | ||
@@ -24,7 +25,7 @@ data BufferTarget | |||
24 | | StencilBuffer | 25 | | StencilBuffer |
25 | 26 | ||
26 | 27 | ||
27 | clearBuffers :: [BufferTarget] -> IO () | 28 | clearBuffers :: MonadIO io => [BufferTarget] -> io () |
28 | clearBuffers = glClear . toBufferBitfield | 29 | clearBuffers = glClear . toBufferBitfield |
29 | where toBufferBitfield = foldl' (.|.) 0 . (<$>) toGLEnum | 30 | where toBufferBitfield = foldl' (.|.) 0 . (<$>) toGLEnum |
30 | toGLEnum target = case target of | 31 | toGLEnum target = case target of |
@@ -32,28 +33,28 @@ clearBuffers = glClear . toBufferBitfield | |||
32 | DepthBuffer -> GL_DEPTH_BUFFER_BIT | 33 | DepthBuffer -> GL_DEPTH_BUFFER_BIT |
33 | StencilBuffer -> GL_STENCIL_BUFFER_BIT | 34 | StencilBuffer -> GL_STENCIL_BUFFER_BIT |
34 | 35 | ||
35 | setBlending :: Bool -> IO () | 36 | setBlending :: MonadIO io => Bool -> io () |
36 | setBlending enable = | 37 | setBlending enable = |
37 | if enable | 38 | if enable |
38 | then glEnable GL_BLEND >> glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA | 39 | then glEnable GL_BLEND >> glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA |
39 | else glDisable GL_BLEND | 40 | else glDisable GL_BLEND |
40 | 41 | ||
41 | setClearColour :: (Float, Float, Float, Float) -> IO () | 42 | setClearColour :: MonadIO io => (Float, Float, Float, Float) -> io () |
42 | setClearColour (r,g,b,a) = glClearColor r g b a | 43 | setClearColour (r,g,b,a) = glClearColor r g b a |
43 | 44 | ||
44 | setClearDepth :: Double -> IO () | 45 | setClearDepth :: MonadIO io => Double -> io () |
45 | setClearDepth = glClearDepth | 46 | setClearDepth = glClearDepth |
46 | 47 | ||
47 | setClearStencil :: Int -> IO () | 48 | setClearStencil :: MonadIO io => Int -> io () |
48 | setClearStencil = glClearStencil . fromIntegral | 49 | setClearStencil = glClearStencil . fromIntegral |
49 | 50 | ||
50 | setCulling :: Bool -> IO () | 51 | setCulling :: MonadIO io => Bool -> io () |
51 | setCulling enable = (if enable then glEnable else glDisable) GL_CULL_FACE | 52 | setCulling enable = (if enable then glEnable else glDisable) GL_CULL_FACE |
52 | 53 | ||
53 | setDepthMask :: Bool -> IO () | 54 | setDepthMask :: MonadIO io => Bool -> io () |
54 | setDepthMask enable = glDepthMask (if enable then GL_TRUE else GL_FALSE) | 55 | setDepthMask enable = glDepthMask (if enable then GL_TRUE else GL_FALSE) |
55 | 56 | ||
56 | setPolygonOffset :: Float -> Float -> IO () | 57 | setPolygonOffset :: MonadIO io => Float -> Float -> io () |
57 | setPolygonOffset scale bias = do | 58 | setPolygonOffset scale bias = do |
58 | glPolygonOffset scale bias | 59 | glPolygonOffset scale bias |
59 | if scale /= 0 && bias /= 0 | 60 | if scale /= 0 && bias /= 0 |
@@ -61,6 +62,7 @@ setPolygonOffset scale bias = do | |||
61 | else glDisable GL_POLYGON_OFFSET_FILL | 62 | else glDisable GL_POLYGON_OFFSET_FILL |
62 | 63 | ||
63 | setViewport :: | 64 | setViewport :: |
65 | MonadIO io => | ||
64 | -- | x | 66 | -- | x |
65 | Int -> | 67 | Int -> |
66 | -- | y | 68 | -- | y |
@@ -69,6 +71,6 @@ setViewport :: | |||
69 | Int -> | 71 | Int -> |
70 | -- | height | 72 | -- | height |
71 | Int -> | 73 | Int -> |
72 | IO () | 74 | io () |
73 | setViewport x y width height = | 75 | setViewport x y width height = |
74 | glViewport (fromIntegral x) (fromIntegral y) (fromIntegral width) (fromIntegral height) | 76 | glViewport (fromIntegral x) (fromIntegral y) (fromIntegral width) (fromIntegral height) |
diff --git a/Spear/Render/Core/Shader.hs b/Spear/Render/Core/Shader.hs index 4ed4430..ce29d4b 100644 --- a/Spear/Render/Core/Shader.hs +++ b/Spear/Render/Core/Shader.hs | |||
@@ -1,3 +1,5 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
1 | module Spear.Render.Core.Shader | 3 | module Spear.Render.Core.Shader |
2 | ( | 4 | ( |
3 | Define(..) | 5 | Define(..) |
@@ -20,11 +22,15 @@ import Spear.Math.Vector | |||
20 | import Spear.Render.Core.State | 22 | import Spear.Render.Core.State |
21 | 23 | ||
22 | import Control.Monad (mapM_) | 24 | import Control.Monad (mapM_) |
25 | import Control.Monad.IO.Class | ||
23 | import Data.Bits | 26 | import Data.Bits |
27 | import Data.ByteString as B | ||
24 | import Data.Hashable | 28 | import Data.Hashable |
25 | import Data.HashMap as HashMap | 29 | import Data.HashMap as HashMap |
26 | import Data.IORef | 30 | import Data.IORef |
27 | import Data.List (deleteBy, foldl', intercalate) | 31 | import Data.List as List (deleteBy, foldl', intercalate) |
32 | import Data.Text as T | ||
33 | import Data.Text.Encoding as T | ||
28 | import Foreign.C.String | 34 | import Foreign.C.String |
29 | import Foreign.Marshal.Alloc | 35 | import Foreign.Marshal.Alloc |
30 | import Foreign.Marshal.Array | 36 | import Foreign.Marshal.Array |
@@ -35,11 +41,12 @@ import Graphics.GL.Core46 | |||
35 | import Unsafe.Coerce | 41 | import Unsafe.Coerce |
36 | 42 | ||
37 | 43 | ||
38 | type Define = (String, String) | 44 | type Define = (ByteString, ByteString) |
39 | 45 | ||
40 | data ShaderSource | 46 | data ShaderSource |
41 | = ShaderFromString String | 47 | = ShaderFromString String |
42 | | ShaderFromFile FilePath | 48 | | ShaderFromByteString ByteString |
49 | | ShaderFromFile FilePath | ||
43 | deriving Show | 50 | deriving Show |
44 | 51 | ||
45 | data ShaderDesc = ShaderDesc | 52 | data ShaderDesc = ShaderDesc |
@@ -48,27 +55,31 @@ data ShaderDesc = ShaderDesc | |||
48 | , shaderDescDefines :: [Define] | 55 | , shaderDescDefines :: [Define] |
49 | } | 56 | } |
50 | 57 | ||
58 | -- Header prepended to all shaders. | ||
59 | header = "#version 400 core\n" | ||
60 | |||
51 | 61 | ||
52 | compileShader :: ShaderDesc -> Game RenderCoreState Shader | 62 | compileShader :: ShaderDesc -> Game RenderCoreState Shader |
53 | compileShader (ShaderDesc shaderType source defines) = do | 63 | compileShader (ShaderDesc shaderType source defines) = do |
54 | code <- case source of | 64 | code <- case source of |
55 | ShaderFromString code -> return code | 65 | ShaderFromString code -> return (T.encodeUtf8 . T.pack $ code) |
56 | ShaderFromFile file -> gameIO $ readFile file | 66 | ShaderFromByteString code -> return code |
57 | state <- getGameState | 67 | ShaderFromFile file -> liftIO $ B.readFile file |
68 | state <- get | ||
58 | let shaderHash = hash code -- TODO: Should also include defines. | 69 | let shaderHash = hash code -- TODO: Should also include defines. |
59 | case HashMap.lookup shaderHash (shaders state) of | 70 | case HashMap.lookup shaderHash (shaders state) of |
60 | Just shader -> return shader | 71 | Just shader -> return shader |
61 | Nothing -> do | 72 | Nothing -> do |
62 | let definesString = makeDefinesString defines | 73 | let definesString = makeDefinesString defines |
63 | handle <- gameIO $ glCreateShader (toGLShaderType shaderType) | 74 | handle <- liftIO $ glCreateShader (toGLShaderType shaderType) |
64 | gameIO $ withCStringLen code $ \(codeCString, codeLen) -> | 75 | liftIO $ B.useAsCStringLen code $ \(codeCString, codeLen) -> |
65 | withCStringLen definesString $ \(definesCString, definesLen) -> | 76 | B.useAsCStringLen definesString $ \(definesCString, definesLen) -> |
66 | withCStringLen header $ \(headerCString, headerLen) -> | 77 | withCStringLen header $ \(headerCString, headerLen) -> |
67 | withArray [headerCString, definesCString, codeCString] $ \strPtrs -> | 78 | withArray [headerCString, definesCString, codeCString] $ \strPtrs -> |
68 | withArray (fromIntegral <$> [headerLen, definesLen, codeLen] :: [GLint]) | 79 | withArray (fromIntegral <$> [headerLen, definesLen, codeLen] :: [GLint]) |
69 | $ \lengths -> | 80 | $ \lengths -> |
70 | glShaderSource handle 3 strPtrs lengths | 81 | glShaderSource handle 3 strPtrs lengths |
71 | err <- gameIO $ do | 82 | err <- liftIO $ do |
72 | glCompileShader handle | 83 | glCompileShader handle |
73 | alloca $ \statusPtr -> do | 84 | alloca $ \statusPtr -> do |
74 | glGetShaderiv handle GL_COMPILE_STATUS statusPtr | 85 | glGetShaderiv handle GL_COMPILE_STATUS statusPtr |
@@ -79,7 +90,7 @@ compileShader (ShaderDesc shaderType source defines) = do | |||
79 | len <- peek lenPtr | 90 | len <- peek lenPtr |
80 | case len of | 91 | case len of |
81 | 0 -> return $ Just "" | 92 | 0 -> return $ Just "" |
82 | _ -> withCString (replicate (fromIntegral len) '\0') $ \logPtr -> do | 93 | _ -> withCString (Prelude.replicate (fromIntegral len) '\0') $ \logPtr -> do |
83 | glGetShaderInfoLog handle len nullPtr logPtr | 94 | glGetShaderInfoLog handle len nullPtr logPtr |
84 | Just <$> peekCString logPtr | 95 | Just <$> peekCString logPtr |
85 | _ -> return Nothing | 96 | _ -> return Nothing |
@@ -87,7 +98,7 @@ compileShader (ShaderDesc shaderType source defines) = do | |||
87 | Nothing -> do | 98 | Nothing -> do |
88 | resourceKey <- register $ deleteShader' handle | 99 | resourceKey <- register $ deleteShader' handle |
89 | let shader = Shader handle resourceKey shaderType shaderHash | 100 | let shader = Shader handle resourceKey shaderType shaderHash |
90 | saveGameState $ state { | 101 | put $ state { |
91 | shaders = HashMap.insert shaderHash shader (shaders state) | 102 | shaders = HashMap.insert shaderHash shader (shaders state) |
92 | } | 103 | } |
93 | return shader | 104 | return shader |
@@ -96,17 +107,17 @@ compileShader (ShaderDesc shaderType source defines) = do | |||
96 | 107 | ||
97 | compileShaderProgram :: [Shader] -> Game RenderCoreState ShaderProgram | 108 | compileShaderProgram :: [Shader] -> Game RenderCoreState ShaderProgram |
98 | compileShaderProgram shaders = do | 109 | compileShaderProgram shaders = do |
99 | state <- getGameState | 110 | state <- get |
100 | let programHash = hashShaders shaders | 111 | let programHash = hashShaders shaders |
101 | case HashMap.lookup programHash (shaderPrograms state) of | 112 | case HashMap.lookup programHash (shaderPrograms state) of |
102 | Just program -> return program | 113 | Just program -> return program |
103 | Nothing -> do | 114 | Nothing -> do |
104 | handle <- gameIO glCreateProgram | 115 | handle <- liftIO glCreateProgram |
105 | case handle of | 116 | case handle of |
106 | 0 -> gameError "Failed to create shader program" | 117 | 0 -> gameError "Failed to create shader program" |
107 | _ -> do | 118 | _ -> do |
108 | mapM_ (gameIO . glAttachShader handle) (shaderHandle <$> shaders) | 119 | mapM_ (liftIO . glAttachShader handle) (shaderHandle <$> shaders) |
109 | err <- gameIO $ do | 120 | err <- liftIO $ do |
110 | glLinkProgram handle | 121 | glLinkProgram handle |
111 | alloca $ \statusPtr -> do | 122 | alloca $ \statusPtr -> do |
112 | glGetProgramiv handle GL_LINK_STATUS statusPtr | 123 | glGetProgramiv handle GL_LINK_STATUS statusPtr |
@@ -117,51 +128,51 @@ compileShaderProgram shaders = do | |||
117 | len <- peek lenPtr | 128 | len <- peek lenPtr |
118 | case len of | 129 | case len of |
119 | 0 -> return $ Just "Unknown error" | 130 | 0 -> return $ Just "Unknown error" |
120 | _ -> withCString (replicate (fromIntegral len) '\0') $ \logPtr -> do | 131 | _ -> withCString (Prelude.replicate (fromIntegral len) '\0') $ \logPtr -> do |
121 | glGetShaderInfoLog handle len nullPtr logPtr | 132 | glGetShaderInfoLog handle len nullPtr logPtr |
122 | Just <$> peekCString logPtr | 133 | Just <$> peekCString logPtr |
123 | _ -> return Nothing | 134 | _ -> return Nothing |
124 | case err of | 135 | case err of |
125 | Nothing -> do | 136 | Nothing -> do |
126 | resourceKey <- register $ deleteShaderProgram' handle | 137 | resourceKey <- register $ deleteShaderProgram' handle |
127 | uniforms <- gameIO $ newIORef [] | 138 | uniforms <- liftIO $ newIORef [] |
128 | let program = ShaderProgram handle resourceKey programHash uniforms | 139 | let program = ShaderProgram handle resourceKey programHash uniforms |
129 | saveGameState $ state { | 140 | put $ state { |
130 | shaderPrograms = HashMap.insert programHash program (shaderPrograms state) | 141 | shaderPrograms = HashMap.insert programHash program (shaderPrograms state) |
131 | } | 142 | } |
132 | return program | 143 | return program |
133 | Just err -> gameError $ | 144 | Just err -> gameError $ |
134 | "Failed to compile shader program: " ++ err ++ "; shaders: " ++ | 145 | "Failed to compile shader program: " ++ err ++ "; shaders: " ++ |
135 | intercalate ", " (show . shaderHandle <$> shaders) | 146 | List.intercalate ", " (show . shaderHandle <$> shaders) |
136 | 147 | ||
137 | deleteShader :: Shader -> Game RenderCoreState () | 148 | deleteShader :: Shader -> Game RenderCoreState () |
138 | deleteShader shader = do | 149 | deleteShader shader = do |
139 | modifyGameState (\state -> state { | 150 | modify (\state -> state { |
140 | shaders = HashMap.delete (shaderHash shader) (shaders state) }) | 151 | shaders = HashMap.delete (shaderHash shader) (shaders state) }) |
141 | release shader | 152 | release' shader |
142 | 153 | ||
143 | deleteShaderProgram :: ShaderProgram -> Game RenderCoreState () | 154 | deleteShaderProgram :: ShaderProgram -> Game RenderCoreState () |
144 | deleteShaderProgram program = do | 155 | deleteShaderProgram program = do |
145 | modifyGameState (\state -> state { | 156 | modify (\state -> state { |
146 | shaderPrograms = HashMap.delete (shaderProgramHash program) (shaderPrograms state)}) | 157 | shaderPrograms = HashMap.delete (shaderProgramHash program) (shaderPrograms state)}) |
147 | release program | 158 | release' program |
148 | 159 | ||
149 | activateShaderProgram :: ShaderProgram -> IO () | 160 | activateShaderProgram :: MonadIO io => ShaderProgram -> io () |
150 | activateShaderProgram program = do | 161 | activateShaderProgram program = do |
151 | glUseProgram . shaderProgramHandle $ program | 162 | glUseProgram . shaderProgramHandle $ program |
152 | applyUniforms program | 163 | applyUniforms program |
153 | 164 | ||
154 | deactivateShaderProgram :: ShaderProgram -> IO () | 165 | deactivateShaderProgram :: MonadIO io => ShaderProgram -> io () |
155 | deactivateShaderProgram _ = glUseProgram 0 | 166 | deactivateShaderProgram _ = glUseProgram 0 |
156 | 167 | ||
157 | setUniform :: ShaderUniform -> ShaderProgram -> IO () | 168 | setUniform :: MonadIO io => ShaderUniform -> ShaderProgram -> io () |
158 | setUniform uniform program = | 169 | setUniform uniform program = liftIO $ |
159 | modifyIORef (shaderProgramUniforms program) (setUniform' . removeUniform) | 170 | modifyIORef (shaderProgramUniforms program) (setUniform' . removeUniform) |
160 | where removeUniform = deleteBy matchesUniform uniform | 171 | where removeUniform = deleteBy matchesUniform uniform |
161 | matchesUniform uniform u = uniformName u == uniformName uniform | 172 | matchesUniform uniform u = uniformName u == uniformName uniform |
162 | setUniform' = (:) uniform | 173 | setUniform' = (:) uniform |
163 | 174 | ||
164 | applyUniforms :: ShaderProgram -> IO () | 175 | applyUniforms :: MonadIO io => ShaderProgram -> io () |
165 | applyUniforms program = | 176 | applyUniforms program = |
166 | let update (FloatUniform name value) = | 177 | let update (FloatUniform name value) = |
167 | glGetUniformLocation' handle name >>= | 178 | glGetUniformLocation' handle name >>= |
@@ -179,9 +190,9 @@ applyUniforms program = | |||
179 | update (Mat4ArrayUniform name mat4s) = | 190 | update (Mat4ArrayUniform name mat4s) = |
180 | glGetUniformLocation' handle name >>= | 191 | glGetUniformLocation' handle name >>= |
181 | \location -> withArray mat4s $ \ptrMat4s -> | 192 | \location -> withArray mat4s $ \ptrMat4s -> |
182 | glUniformMatrix4fv location (fromIntegral $ length mat4s) GL_FALSE (unsafeCoerce ptrMat4s) | 193 | glUniformMatrix4fv location (fromIntegral $ Prelude.length mat4s) GL_FALSE (unsafeCoerce ptrMat4s) |
183 | handle = shaderProgramHandle program | 194 | handle = shaderProgramHandle program |
184 | in do | 195 | in liftIO $ do |
185 | uniforms <- readIORef (shaderProgramUniforms program) | 196 | uniforms <- readIORef (shaderProgramUniforms program) |
186 | mapM_ update uniforms | 197 | mapM_ update uniforms |
187 | writeIORef (shaderProgramUniforms program) [] | 198 | writeIORef (shaderProgramUniforms program) [] |
@@ -189,7 +200,7 @@ applyUniforms program = | |||
189 | -- Private | 200 | -- Private |
190 | 201 | ||
191 | glGetUniformLocation' :: GLuint -> String -> IO GLint | 202 | glGetUniformLocation' :: GLuint -> String -> IO GLint |
192 | glGetUniformLocation' handle name = | 203 | glGetUniformLocation' handle name = liftIO $ |
193 | withCString name $ \nameCStr -> | 204 | withCString name $ \nameCStr -> |
194 | glGetUniformLocation (fromIntegral handle) (unsafeCoerce nameCStr) | 205 | glGetUniformLocation (fromIntegral handle) (unsafeCoerce nameCStr) |
195 | 206 | ||
@@ -200,7 +211,7 @@ deleteShaderProgram' :: GLuint -> IO () | |||
200 | deleteShaderProgram' = glDeleteProgram | 211 | deleteShaderProgram' = glDeleteProgram |
201 | 212 | ||
202 | hashShaders :: [Shader] -> Int | 213 | hashShaders :: [Shader] -> Int |
203 | hashShaders = foldl' hashF 0 | 214 | hashShaders = List.foldl' hashF 0 |
204 | where hashF hash shader = (hash `shiftL` 32) .|. fromIntegral (shaderHandle shader) | 215 | where hashF hash shader = (hash `shiftL` 32) .|. fromIntegral (shaderHandle shader) |
205 | 216 | ||
206 | toGLShaderType :: ShaderType -> GLenum | 217 | toGLShaderType :: ShaderType -> GLenum |
@@ -208,9 +219,6 @@ toGLShaderType VertexShader = GL_VERTEX_SHADER | |||
208 | toGLShaderType FragmentShader = GL_FRAGMENT_SHADER | 219 | toGLShaderType FragmentShader = GL_FRAGMENT_SHADER |
209 | toGLShaderType ComputeShader = GL_COMPUTE_SHADER | 220 | toGLShaderType ComputeShader = GL_COMPUTE_SHADER |
210 | 221 | ||
211 | makeDefinesString :: [Define] -> String | 222 | makeDefinesString :: [Define] -> ByteString |
212 | makeDefinesString defines = intercalate "\n" body ++ "\n" | 223 | makeDefinesString defines = B.concat[B.intercalate "\n" body, "\n"] |
213 | where body = (\(name, value) -> "#define " ++ name ++ " " ++ value) <$> defines | 224 | where body = (\(name, value) -> B.concat["#define ", name, " ", value]) <$> defines |
214 | |||
215 | -- Header prepended to all shaders. | ||
216 | header = "#version 400 core\n" | ||
diff --git a/Spear/Render/Core/State.hs b/Spear/Render/Core/State.hs index f7e5627..aa42635 100644 --- a/Spear/Render/Core/State.hs +++ b/Spear/Render/Core/State.hs | |||
@@ -18,7 +18,7 @@ data BufferUsage | |||
18 | -- | A data buffer (e.g., vertex attributes, indices). | 18 | -- | A data buffer (e.g., vertex attributes, indices). |
19 | data Buffer = Buffer | 19 | data Buffer = Buffer |
20 | { bufferHandle :: GLuint | 20 | { bufferHandle :: GLuint |
21 | , bufferResource :: Resource | 21 | , bufferResource :: ReleaseKey |
22 | , bufferUsage :: BufferUsage | 22 | , bufferUsage :: BufferUsage |
23 | } | 23 | } |
24 | 24 | ||
@@ -72,7 +72,7 @@ data GeometryData = GeometryData | |||
72 | -- its state cannot become stale after an update. | 72 | -- its state cannot become stale after an update. |
73 | data Geometry = Geometry | 73 | data Geometry = Geometry |
74 | { geometryVao :: GLuint | 74 | { geometryVao :: GLuint |
75 | , geometryResource :: Resource | 75 | , geometryResource :: ReleaseKey |
76 | , geometryData :: IORef GeometryData | 76 | , geometryData :: IORef GeometryData |
77 | } | 77 | } |
78 | 78 | ||
@@ -80,7 +80,7 @@ data Geometry = Geometry | |||
80 | -- | A shader. | 80 | -- | A shader. |
81 | data Shader = Shader | 81 | data Shader = Shader |
82 | { shaderHandle :: GLuint | 82 | { shaderHandle :: GLuint |
83 | , shaderResource :: Resource | 83 | , shaderResource :: ReleaseKey |
84 | , shaderType :: ShaderType | 84 | , shaderType :: ShaderType |
85 | , shaderHash :: Int | 85 | , shaderHash :: Int |
86 | } | 86 | } |
@@ -102,7 +102,7 @@ data ShaderUniform | |||
102 | -- | A shader program. | 102 | -- | A shader program. |
103 | data ShaderProgram = ShaderProgram | 103 | data ShaderProgram = ShaderProgram |
104 | { shaderProgramHandle :: GLuint | 104 | { shaderProgramHandle :: GLuint |
105 | , shaderProgramResource :: Resource | 105 | , shaderProgramResource :: ReleaseKey |
106 | , shaderProgramHash :: Int | 106 | , shaderProgramHash :: Int |
107 | -- Dirty set of uniforms that have been set since the last time uniforms were | 107 | -- Dirty set of uniforms that have been set since the last time uniforms were |
108 | -- applied. OpenGL retains the values of uniforms for a program until the | 108 | -- applied. OpenGL retains the values of uniforms for a program until the |
@@ -123,7 +123,6 @@ type ShaderHash = Int | |||
123 | type ShaderProgramHash = Int | 123 | type ShaderProgramHash = Int |
124 | 124 | ||
125 | 125 | ||
126 | |||
127 | instance ResourceClass Buffer where | 126 | instance ResourceClass Buffer where |
128 | getResource = bufferResource | 127 | getResource = bufferResource |
129 | 128 | ||
diff --git a/Spear/Render/Immediate.hs b/Spear/Render/Immediate.hs index 3c5f6ad..94a7abf 100644 --- a/Spear/Render/Immediate.hs +++ b/Spear/Render/Immediate.hs | |||
@@ -32,6 +32,7 @@ import Spear.Render.Core.Buffer | |||
32 | import Spear.Render.Core.Geometry | 32 | import Spear.Render.Core.Geometry |
33 | import Spear.Render.Core.Shader | 33 | import Spear.Render.Core.Shader |
34 | import Spear.Render.Core.State hiding (shaders) | 34 | import Spear.Render.Core.State hiding (shaders) |
35 | import Spear.Render.Shaders as Shaders | ||
35 | 36 | ||
36 | import Control.Monad (unless) | 37 | import Control.Monad (unless) |
37 | import Data.List (foldl') | 38 | import Data.List (foldl') |
@@ -47,11 +48,8 @@ data ImmRenderState = ImmRenderState | |||
47 | 48 | ||
48 | newImmRenderer :: Game RenderCoreState ImmRenderState | 49 | newImmRenderer :: Game RenderCoreState ImmRenderState |
49 | newImmRenderer = do | 50 | newImmRenderer = do |
50 | -- TODO: Move shaders to Spear project. | 51 | vs <- compileShader $ ShaderDesc VertexShader (ShaderFromByteString Shaders.immediateModeVert) [] |
51 | vs <- compileShader $ ShaderDesc VertexShader | 52 | ps <- compileShader $ ShaderDesc FragmentShader (ShaderFromByteString Shaders.immediateModeFrag) [] |
52 | (ShaderFromFile "/home/jeanne/src/gfx/gfx/shaders/immediate_mode.vert") [] | ||
53 | ps <- compileShader $ ShaderDesc FragmentShader | ||
54 | (ShaderFromFile "/home/jeanne/src/gfx/gfx/shaders/immediate_mode.frag") [] | ||
55 | shader <- compileShaderProgram [vs, ps] | 53 | shader <- compileShaderProgram [vs, ps] |
56 | 54 | ||
57 | triangles <- makeGeometry $ newGeometryDesc | 55 | triangles <- makeGeometry $ newGeometryDesc |
@@ -74,27 +72,28 @@ deleteImmRenderer immState = do | |||
74 | deleteGeometry (triangles immState) | 72 | deleteGeometry (triangles immState) |
75 | 73 | ||
76 | -- The functions below are all defined inside the Game ImmRenderState monad so | 74 | -- The functions below are all defined inside the Game ImmRenderState monad so |
77 | -- that all of the drawing can conveniently happen inside the monad. | 75 | -- that all of the drawing can conveniently happen inside the monad. They could |
76 | -- technically be defined inside MonadIO, but then we would have to explicitly | ||
77 | -- pass in the ImmRenderState. | ||
78 | 78 | ||
79 | immStart :: Game ImmRenderState () | 79 | immStart :: Game ImmRenderState () |
80 | immStart = do | 80 | immStart = do |
81 | state <- getGameState | 81 | state <- get |
82 | gameIO $ activateShaderProgram (shader state) | 82 | activateShaderProgram (shader state) |
83 | 83 | ||
84 | immEnd :: Game ImmRenderState () | 84 | immEnd :: Game ImmRenderState () |
85 | immEnd = do | 85 | immEnd = do |
86 | state <- getGameState | 86 | state <- get |
87 | gameIO $ deactivateShaderProgram (shader state) | 87 | deactivateShaderProgram (shader state) |
88 | 88 | ||
89 | immDrawTriangles :: [Vector3] -> Game ImmRenderState () | 89 | immDrawTriangles :: [Vector3] -> Game ImmRenderState () |
90 | immDrawTriangles vertices = do | 90 | immDrawTriangles vertices = |
91 | unless (null vertices) $ do | 91 | unless (null vertices) $ do |
92 | loadMatrixStack | 92 | loadMatrixStack |
93 | state <- getGameState | 93 | state <- get |
94 | gameIO $ do | 94 | setPositions (triangles state) vertices |
95 | setPositions (triangles state) vertices | 95 | applyUniforms (shader state) |
96 | applyUniforms (shader state) | 96 | renderGeometry (triangles state) |
97 | renderGeometry (triangles state) | ||
98 | 97 | ||
99 | -- NOTE: consider using triangle strips for quads. This will require a separate | 98 | -- NOTE: consider using triangle strips for quads. This will require a separate |
100 | -- Geometry. Using Vector3 for everything currently makes this simple. | 99 | -- Geometry. Using Vector3 for everything currently makes this simple. |
@@ -112,42 +111,42 @@ immDrawQuads2d = | |||
112 | immDrawQuads . (<$>) (\(p0, p1, p2, p3) -> (to3d p0, to3d p1, to3d p2, to3d p3)) | 111 | immDrawQuads . (<$>) (\(p0, p1, p2, p3) -> (to3d p0, to3d p1, to3d p2, to3d p3)) |
113 | 112 | ||
114 | immLoadIdentity :: Game ImmRenderState () | 113 | immLoadIdentity :: Game ImmRenderState () |
115 | immLoadIdentity = modifyGameState $ \state -> state { | 114 | immLoadIdentity = modify $ \state -> state { |
116 | matrixStack = [Matrix4.id] } | 115 | matrixStack = [Matrix4.id] } |
117 | 116 | ||
118 | immTranslate :: Vector3 -> Game ImmRenderState () | 117 | immTranslate :: Vector3 -> Game ImmRenderState () |
119 | immTranslate vector = modifyGameState $ pushMatrix (Matrix4.translatev vector) | 118 | immTranslate vector = modify $ pushMatrix (Matrix4.translatev vector) |
120 | 119 | ||
121 | immPushMatrix :: Matrix4 -> Game ImmRenderState () | 120 | immPushMatrix :: Matrix4 -> Game ImmRenderState () |
122 | immPushMatrix matrix = modifyGameState $ pushMatrix matrix | 121 | immPushMatrix matrix = modify $ pushMatrix matrix |
123 | 122 | ||
124 | immPopMatrix :: Game ImmRenderState () | 123 | immPopMatrix :: Game ImmRenderState () |
125 | immPopMatrix = modifyGameState $ \state -> state { | 124 | immPopMatrix = modify $ \state -> state { |
126 | matrixStack = case matrixStack state of | 125 | matrixStack = case matrixStack state of |
127 | [x] -> [x] -- Always keep the identity matrix on the stack. | 126 | [x] -> [x] -- Always keep the identity matrix on the stack. |
128 | x:xs -> xs } | 127 | x:xs -> xs } |
129 | 128 | ||
130 | immPreservingMatrix :: Game ImmRenderState a -> Game ImmRenderState a | 129 | immPreservingMatrix :: Game ImmRenderState a -> Game ImmRenderState a |
131 | immPreservingMatrix f = do | 130 | immPreservingMatrix f = do |
132 | originalStack <- matrixStack <$> getGameState | 131 | originalStack <- matrixStack <$> get |
133 | result <- f | 132 | result <- f |
134 | modifyGameState $ \state -> state { matrixStack = originalStack } | 133 | modify $ \state -> state { matrixStack = originalStack } |
135 | return result | 134 | return result |
136 | 135 | ||
137 | immSetColour :: Vector4 -> Game ImmRenderState () | 136 | immSetColour :: Vector4 -> Game ImmRenderState () |
138 | immSetColour colour = do | 137 | immSetColour colour = do |
139 | state <- getGameState | 138 | state <- get |
140 | gameIO $ setUniform (Vec4Uniform "Colour" colour) (shader state) | 139 | setUniform (Vec4Uniform "Colour" colour) (shader state) |
141 | 140 | ||
142 | immSetModelMatrix :: Matrix4 -> Game ImmRenderState () | 141 | immSetModelMatrix :: Matrix4 -> Game ImmRenderState () |
143 | immSetModelMatrix model = do | 142 | immSetModelMatrix model = do |
144 | state <- getGameState | 143 | state <- get |
145 | gameIO $ setUniform (Mat4Uniform "Model" model) (shader state) | 144 | setUniform (Mat4Uniform "Model" model) (shader state) |
146 | 145 | ||
147 | immSetViewProjectionMatrix :: Matrix4 -> Game ImmRenderState () | 146 | immSetViewProjectionMatrix :: Matrix4 -> Game ImmRenderState () |
148 | immSetViewProjectionMatrix viewProjection = do | 147 | immSetViewProjectionMatrix viewProjection = do |
149 | state <- getGameState | 148 | state <- get |
150 | gameIO $ setUniform (Mat4Uniform "ViewProjection" viewProjection) (shader state) | 149 | setUniform (Mat4Uniform "ViewProjection" viewProjection) (shader state) |
151 | 150 | ||
152 | -- Private | 151 | -- Private |
153 | 152 | ||
@@ -157,7 +156,7 @@ pushMatrix matrix state = state { | |||
157 | 156 | ||
158 | loadMatrixStack :: Game ImmRenderState () | 157 | loadMatrixStack :: Game ImmRenderState () |
159 | loadMatrixStack = do | 158 | loadMatrixStack = do |
160 | state <- getGameState | 159 | state <- get |
161 | immSetModelMatrix (head $ matrixStack state) | 160 | immSetModelMatrix (head $ matrixStack state) |
162 | 161 | ||
163 | to3d :: Vector2 -> Vector3 | 162 | to3d :: Vector2 -> Vector3 |
diff --git a/Spear/Render/Shaders.hs b/Spear/Render/Shaders.hs new file mode 100644 index 0000000..bdf403d --- /dev/null +++ b/Spear/Render/Shaders.hs | |||
@@ -0,0 +1,12 @@ | |||
1 | {-# LANGUAGE TemplateHaskell #-} | ||
2 | |||
3 | module Spear.Render.Shaders where | ||
4 | |||
5 | import Data.ByteString | ||
6 | import Data.FileEmbed | ||
7 | |||
8 | immediateModeFrag :: ByteString | ||
9 | immediateModeFrag = $(embedFile "Spear/Render/Shaders/immediate_mode.frag") | ||
10 | |||
11 | immediateModeVert :: ByteString | ||
12 | immediateModeVert = $(embedFile "Spear/Render/Shaders/immediate_mode.vert") | ||
diff --git a/Spear/Render/Shaders/immediate_mode.frag b/Spear/Render/Shaders/immediate_mode.frag new file mode 100644 index 0000000..ac23b5c --- /dev/null +++ b/Spear/Render/Shaders/immediate_mode.frag | |||
@@ -0,0 +1,10 @@ | |||
1 | precision highp float; | ||
2 | |||
3 | uniform vec4 Colour; | ||
4 | |||
5 | out vec4 FragColour; | ||
6 | |||
7 | void main() | ||
8 | { | ||
9 | FragColour = vec4(pow(Colour.rgb, vec3(1.0/2.2)), Colour.a); | ||
10 | } | ||
diff --git a/Spear/Render/Shaders/immediate_mode.vert b/Spear/Render/Shaders/immediate_mode.vert new file mode 100644 index 0000000..65070bb --- /dev/null +++ b/Spear/Render/Shaders/immediate_mode.vert | |||
@@ -0,0 +1,11 @@ | |||
1 | precision highp float; | ||
2 | |||
3 | uniform mat4 Model; | ||
4 | uniform mat4 ViewProjection; | ||
5 | |||
6 | layout (location = 0) in vec3 vPosition; | ||
7 | |||
8 | void main() | ||
9 | { | ||
10 | gl_Position = ViewProjection * Model * vec4(vPosition, 1.0); | ||
11 | } | ||
diff --git a/Spear/Render/StaticModel.hs b/Spear/Render/StaticModel.hs index f4cddf8..5168cf2 100644 --- a/Spear/Render/StaticModel.hs +++ b/Spear/Render/StaticModel.hs | |||
@@ -44,7 +44,7 @@ data StaticModelResource = StaticModelResource | |||
44 | material :: Material, | 44 | material :: Material, |
45 | texture :: Texture, | 45 | texture :: Texture, |
46 | boxes :: V.Vector Box, | 46 | boxes :: V.Vector Box, |
47 | rkey :: Resource | 47 | rkey :: ReleaseKey |
48 | } | 48 | } |
49 | 49 | ||
50 | instance Eq StaticModelResource where | 50 | instance Eq StaticModelResource where |
@@ -74,12 +74,12 @@ staticModelResource :: | |||
74 | Model -> | 74 | Model -> |
75 | Game s StaticModelResource | 75 | Game s StaticModelResource |
76 | staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do | 76 | staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do |
77 | RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model | 77 | RenderModel elements _ numVertices <- liftIO . renderModelFromModel $ model |
78 | elementBuf <- newBuffer | 78 | elementBuf <- newBuffer |
79 | vao <- newVAO | 79 | vao <- newVAO |
80 | boxes <- gameIO $ modelBoxes model | 80 | boxes <- liftIO $ modelBoxes model |
81 | 81 | ||
82 | gameIO $ do | 82 | liftIO $ do |
83 | let elemSize = 32::CUInt | 83 | let elemSize = 32::CUInt |
84 | elemSize' = fromIntegral elemSize | 84 | elemSize' = fromIntegral elemSize |
85 | n = numVertices | 85 | n = numVertices |
@@ -98,9 +98,8 @@ staticModelResource (StaticProgramChannels vertChan normChan texChan) material t | |||
98 | enableVAOAttrib texChan | 98 | enableVAOAttrib texChan |
99 | 99 | ||
100 | rkey <- register $ do | 100 | rkey <- register $ do |
101 | putStrLn "Releasing static model resource" | 101 | release $ vaoKey vao |
102 | release' vao | 102 | release $ bufferKey elementBuf |
103 | release' elementBuf | ||
104 | 103 | ||
105 | return $ | 104 | return $ |
106 | StaticModelResource | 105 | StaticModelResource |
diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs index 3cd89f3..0593c77 100644 --- a/Spear/Scene/Loader.hs +++ b/Spear/Scene/Loader.hs | |||
@@ -43,7 +43,7 @@ type Loader = Game SceneResources | |||
43 | -- | Load the scene specified by the given file. | 43 | -- | Load the scene specified by the given file. |
44 | loadScene :: FilePath -> Game s (SceneResources, SceneGraph) | 44 | loadScene :: FilePath -> Game s (SceneResources, SceneGraph) |
45 | loadScene file = do | 45 | loadScene file = do |
46 | result <- gameIO $ loadSceneGraphFromFile file | 46 | result <- liftIO $ loadSceneGraphFromFile file |
47 | case result of | 47 | case result of |
48 | Left err -> gameError $ show err | 48 | Left err -> gameError $ show err |
49 | Right g -> case validate g of | 49 | Right g -> case validate g of |
@@ -58,7 +58,7 @@ validate _ = Nothing | |||
58 | 58 | ||
59 | -- | Load the scene described by the given 'SceneGraph'. | 59 | -- | Load the scene described by the given 'SceneGraph'. |
60 | resourceMap :: SceneGraph -> Game s SceneResources | 60 | resourceMap :: SceneGraph -> Game s SceneResources |
61 | resourceMap g = execSubGame (resourceMap' g) emptySceneResources | 61 | resourceMap g = exec runChildGame emptySceneResources (resourceMap' g) |
62 | 62 | ||
63 | resourceMap' :: SceneGraph -> Loader () | 63 | resourceMap' :: SceneGraph -> Loader () |
64 | resourceMap' node@(SceneLeaf nid props) = do | 64 | resourceMap' node@(SceneLeaf nid props) = do |
@@ -85,9 +85,9 @@ loadResource key field modifyResources load = do | |||
85 | case M.lookup key $ field sceneData of | 85 | case M.lookup key $ field sceneData of |
86 | Just val -> return val | 86 | Just val -> return val |
87 | Nothing -> do | 87 | Nothing -> do |
88 | gameIO $ printf "Loading %s..." key | 88 | liftIO $ printf "Loading %s..." key |
89 | resource <- load | 89 | resource <- load |
90 | gameIO $ printf "done\n" | 90 | liftIO $ printf "done\n" |
91 | modifyResources key resource | 91 | modifyResources key resource |
92 | return resource | 92 | return resource |
93 | 93 | ||
@@ -139,9 +139,9 @@ newModel (SceneLeaf _ props) = do | |||
139 | let rotation = asRotation $ value "rotation" props | 139 | let rotation = asRotation $ value "rotation" props |
140 | scale = asVec3 $ value "scale" props | 140 | scale = asVec3 $ value "scale" props |
141 | 141 | ||
142 | gameIO $ printf "Loading model %s..." name | 142 | liftIO $ printf "Loading model %s..." name |
143 | model <- loadModel' file rotation scale | 143 | model <- loadModel' file rotation scale |
144 | gameIO . putStrLn $ "done" | 144 | liftIO . putStrLn $ "done" |
145 | texture <- loadTexture tex | 145 | texture <- loadTexture tex |
146 | sceneRes <- get | 146 | sceneRes <- get |
147 | 147 | ||
@@ -180,7 +180,7 @@ loadModel' file rotation scale = do | |||
180 | \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z') | 180 | \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z') |
181 | ) | 181 | ) |
182 | 182 | ||
183 | (fmap transform $ Model.loadModel file) >>= gameIO . toGround | 183 | (fmap transform $ Model.loadModel file) >>= liftIO . toGround |
184 | 184 | ||
185 | rotateModel :: Rotation -> Model -> Model | 185 | rotateModel :: Rotation -> Model -> Model |
186 | rotateModel (Rotation ax ay az order) model = | 186 | rotateModel (Rotation ax ay az order) model = |
@@ -213,7 +213,7 @@ newShaderProgram (SceneLeaf _ props) = do | |||
213 | stype <- asString $ mandatory' "type" props | 213 | stype <- asString $ mandatory' "type" props |
214 | prog <- GL.newProgram [vertShader, fragShader] | 214 | prog <- GL.newProgram [vertShader, fragShader] |
215 | 215 | ||
216 | let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name | 216 | let getUniformLoc name = (liftIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name |
217 | 217 | ||
218 | case stype of | 218 | case stype of |
219 | "static" -> do | 219 | "static" -> do |
diff --git a/Spear/Sound/Sound.hs b/Spear/Sound/Sound.hs new file mode 100644 index 0000000..887cf97 --- /dev/null +++ b/Spear/Sound/Sound.hs | |||
@@ -0,0 +1,104 @@ | |||
1 | module Spear.Sound.Sound | ||
2 | ( LoopMode(..) | ||
3 | , withSoundContext | ||
4 | , initSoundSystem | ||
5 | , destroySoundSystem | ||
6 | , loadAudioFile | ||
7 | , deleteSoundBuffer | ||
8 | , makeSoundSource | ||
9 | , deleteSoundSource | ||
10 | , setSoundSourceBuffer | ||
11 | , setSoundLoopMode | ||
12 | , playSounds | ||
13 | ) | ||
14 | where | ||
15 | |||
16 | import Spear.Game | ||
17 | import Spear.Sound.State | ||
18 | |||
19 | import Control.Monad.IO.Class | ||
20 | import Data.Set as Set | ||
21 | import Data.StateVar (($=)) | ||
22 | import qualified Sound.ALUT as AL | ||
23 | |||
24 | |||
25 | data LoopMode | ||
26 | = SingleShot | ||
27 | | Loop | ||
28 | deriving (Show) | ||
29 | |||
30 | |||
31 | -- | Create the sound context and run an IO action within the context. | ||
32 | withSoundContext :: IO a -> IO a | ||
33 | withSoundContext action = AL.withProgNameAndArgs AL.runALUT $ | ||
34 | \name args -> action | ||
35 | |||
36 | -- | Initialize the sound system. | ||
37 | initSoundSystem :: Game () SoundState | ||
38 | initSoundSystem = return newSoundState | ||
39 | |||
40 | -- | Destroy the sound system. | ||
41 | destroySoundSystem :: Game SoundState () | ||
42 | destroySoundSystem = do | ||
43 | state <- get | ||
44 | -- The order here matters; sources before buffers since buffers are attached | ||
45 | -- to sources. | ||
46 | mapM_ release' (toList $ sources state) | ||
47 | mapM_ release' (toList $ buffers state) | ||
48 | put newSoundState | ||
49 | |||
50 | -- | Load an audio file. | ||
51 | loadAudioFile :: FilePath -> Game SoundState SoundBuffer | ||
52 | loadAudioFile path = do | ||
53 | alBuffer <- liftIO $ AL.createBuffer (AL.File path) | ||
54 | resourceKey <- register $ AL.deleteObjectName alBuffer | ||
55 | let buffer = SoundBuffer alBuffer resourceKey | ||
56 | modify (\state -> state { | ||
57 | buffers = Set.insert buffer (buffers state) | ||
58 | }) | ||
59 | return buffer | ||
60 | |||
61 | -- | Delete the sound buffer. | ||
62 | deleteSoundBuffer :: SoundBuffer -> Game SoundState () | ||
63 | deleteSoundBuffer buffer = do | ||
64 | modify (\state -> state { | ||
65 | buffers = Set.delete buffer (buffers state) | ||
66 | }) | ||
67 | release' buffer | ||
68 | |||
69 | -- | Create a sound source. | ||
70 | -- | ||
71 | -- The new source sounds flat, like background music or sound effects in a 2D | ||
72 | -- game. Change the source's (and listener's) properties to simulate 3D sound. | ||
73 | makeSoundSource :: Game SoundState SoundSource | ||
74 | makeSoundSource = do | ||
75 | alSource <- AL.genObjectName | ||
76 | resourceKey <- register $ AL.deleteObjectName alSource | ||
77 | let source = SoundSource alSource resourceKey | ||
78 | modify (\state -> state { | ||
79 | sources = Set.insert source (sources state) | ||
80 | }) | ||
81 | return source | ||
82 | |||
83 | -- | Delete the sound source. | ||
84 | deleteSoundSource :: SoundSource -> Game SoundState () | ||
85 | deleteSoundSource source = do | ||
86 | modify (\state -> state { | ||
87 | sources = Set.delete source (sources state) | ||
88 | }) | ||
89 | release' source | ||
90 | |||
91 | -- | Set the sound that the sound source emits. | ||
92 | setSoundSourceBuffer :: MonadIO io => SoundSource -> SoundBuffer -> io () | ||
93 | setSoundSourceBuffer source buffer = | ||
94 | AL.buffer (alSource source) $= Just (alBuffer buffer) | ||
95 | |||
96 | -- | Set the sound's loop mode. | ||
97 | setSoundLoopMode :: MonadIO io => SoundSource -> LoopMode -> io () | ||
98 | setSoundLoopMode source mode = AL.loopingMode (alSource source) $= alMode mode | ||
99 | where alMode SingleShot = AL.OneShot | ||
100 | alMode Loop = AL.Looping | ||
101 | |||
102 | -- | Play the sound sources. | ||
103 | playSounds :: MonadIO io => [SoundSource] -> io () | ||
104 | playSounds = AL.play . (alSource <$>) | ||
diff --git a/Spear/Sound/State.hs b/Spear/Sound/State.hs new file mode 100644 index 0000000..d843de5 --- /dev/null +++ b/Spear/Sound/State.hs | |||
@@ -0,0 +1,54 @@ | |||
1 | module Spear.Sound.State where | ||
2 | |||
3 | import Spear.Game | ||
4 | |||
5 | import Data.Hashable | ||
6 | import Data.Set as Set | ||
7 | import qualified Sound.ALUT as AL | ||
8 | |||
9 | |||
10 | -- | A sound buffer. | ||
11 | data SoundBuffer = SoundBuffer | ||
12 | { alBuffer :: AL.Buffer | ||
13 | , bufferResource :: ReleaseKey | ||
14 | } | ||
15 | |||
16 | -- | A sound source. | ||
17 | data SoundSource = SoundSource | ||
18 | { alSource :: AL.Source | ||
19 | , sourceResource :: ReleaseKey | ||
20 | } | ||
21 | |||
22 | -- | Sound state. | ||
23 | data SoundState = SoundState | ||
24 | { buffers :: Set SoundBuffer | ||
25 | , sources :: Set SoundSource | ||
26 | } | ||
27 | |||
28 | |||
29 | instance ResourceClass SoundBuffer where | ||
30 | getResource = bufferResource | ||
31 | |||
32 | instance ResourceClass SoundSource where | ||
33 | getResource = sourceResource | ||
34 | |||
35 | instance Eq SoundBuffer where | ||
36 | a == b = alBuffer a == alBuffer b | ||
37 | |||
38 | instance Eq SoundSource where | ||
39 | a == b = alSource a == alSource b | ||
40 | |||
41 | instance Ord SoundBuffer where | ||
42 | a < b = alBuffer a < alBuffer b | ||
43 | a <= b = alBuffer a <= alBuffer b | ||
44 | |||
45 | instance Ord SoundSource where | ||
46 | a < b = alSource a < alSource b | ||
47 | a <= b = alSource a <= alSource b | ||
48 | |||
49 | |||
50 | newSoundState :: SoundState | ||
51 | newSoundState = SoundState | ||
52 | { buffers = Set.empty | ||
53 | , sources = Set.empty | ||
54 | } | ||
diff --git a/Spear/Step.hs b/Spear/Step.hs index cb4f71c..43c3415 100644 --- a/Spear/Step.hs +++ b/Spear/Step.hs | |||
@@ -21,6 +21,7 @@ module Spear.Step | |||
21 | (.>), | 21 | (.>), |
22 | (<.), | 22 | (<.), |
23 | szip, | 23 | szip, |
24 | swhen, | ||
24 | switch, | 25 | switch, |
25 | multiSwitch, | 26 | multiSwitch, |
26 | ) | 27 | ) |
@@ -36,21 +37,34 @@ type Elapsed = Float | |||
36 | type Dt = Float | 37 | type Dt = Float |
37 | 38 | ||
38 | -- | A step function. | 39 | -- | A step function. |
39 | newtype Step state events input a = Step | 40 | newtype Step state events input output = Step |
40 | { runStep :: Elapsed -> Dt -> state -> events -> input -> (a, Step state events input a) | 41 | { runStep :: Elapsed -> Dt -> state -> events -> input -> (output, Step state events input output) |
41 | } | 42 | } |
42 | 43 | ||
43 | instance Functor (Step s e a) where | 44 | instance Functor (Step state events input) where |
44 | fmap f (Step s1) = Step $ \elapsed dt g e x -> | 45 | fmap f (Step s1) = Step $ \elapsed dt g e x -> |
45 | let (a, s') = s1 elapsed dt g e x | 46 | let (a, s') = s1 elapsed dt g e x |
46 | in (f a, fmap f s') | 47 | in (f a, fmap f s') |
47 | 48 | ||
48 | instance Semigroup (Step s e a a) where | 49 | instance Semigroup (Step state events input input) where |
49 | (<>) = (.>) | 50 | (<>) = (.>) |
50 | 51 | ||
51 | instance Monoid (Step s e a a) where | 52 | instance Monoid (Step state events input input) where |
52 | mempty = sid | 53 | mempty = sid |
53 | 54 | ||
55 | instance Applicative (Step state events input) where | ||
56 | pure = sreturn | ||
57 | fStep <*> inputStep = Step $ \t dt state events input -> | ||
58 | let (a, inputStep') = runStep inputStep t dt state events input | ||
59 | (f, fStep') = runStep fStep t dt state events input | ||
60 | in (f a, fStep' <*> inputStep') | ||
61 | |||
62 | instance Monad (Step state events input) where | ||
63 | return = pure | ||
64 | inputStep >>= f = Step $ \t dt state events input -> | ||
65 | let (a, inputStep') = runStep inputStep t dt state events input | ||
66 | in runStep (f a) t dt state events input | ||
67 | |||
54 | -- | Construct a step from a function. | 68 | -- | Construct a step from a function. |
55 | step :: (Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b)) -> Step s e a b | 69 | step :: (Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b)) -> Step s e a b |
56 | step = Step | 70 | step = Step |
@@ -63,6 +77,10 @@ sid = Step $ \_ _ _ _ a -> (a, sid) | |||
63 | spure :: (a -> b) -> Step s e a b | 77 | spure :: (a -> b) -> Step s e a b |
64 | spure f = Step $ \_ _ _ _ x -> (f x, spure f) | 78 | spure f = Step $ \_ _ _ _ x -> (f x, spure f) |
65 | 79 | ||
80 | -- | Construct a step that returns a constant value. | ||
81 | sreturn :: b -> Step s e a b | ||
82 | sreturn b = Step $ \_ _ _ _ _ -> (b, sreturn b) | ||
83 | |||
66 | -- | The step that returns the first component in the tuple. | 84 | -- | The step that returns the first component in the tuple. |
67 | sfst :: Step s e (a, b) a | 85 | sfst :: Step s e (a, b) a |
68 | sfst = spure fst | 86 | sfst = spure fst |
@@ -73,29 +91,12 @@ ssnd = spure snd | |||
73 | 91 | ||
74 | -- | Construct a step that folds a given list of inputs. | 92 | -- | Construct a step that folds a given list of inputs. |
75 | -- | 93 | -- |
76 | -- The step is run N+1 times, where N is the size of the input list. | 94 | -- The step is run once per input, or not at all if the list is empty. |
77 | sfold :: Step s (Maybe e) a a -> Step s [e] a a | 95 | sfold :: Step s (Maybe e) a a -> Step s [e] a a |
78 | sfold s = Step $ \elapsed dt g es a -> | 96 | sfold s = Step $ \elapsed dt g es a -> |
79 | case es of | 97 | let (a', s') = foldl' f (a, s) es |
80 | [] -> | 98 | f (a, s) e = runStep s elapsed dt g (Just e) a |
81 | let (b', s') = runStep s elapsed dt g Nothing a | 99 | in (a', sfold s') |
82 | in (b', sfold s') | ||
83 | es -> | ||
84 | let (b', s') = sfold' elapsed dt g s a es | ||
85 | in (b', sfold s') | ||
86 | |||
87 | sfold' :: | ||
88 | Elapsed -> | ||
89 | Dt -> | ||
90 | s -> | ||
91 | Step s (Maybe e) a a -> | ||
92 | a -> | ||
93 | [e] -> | ||
94 | (a, Step s (Maybe e) a a) | ||
95 | sfold' elapsed dt g s a = foldl' f (a', s') | ||
96 | where | ||
97 | f (a, s) e = runStep s elapsed dt g (Just e) a | ||
98 | (a', s') = runStep s elapsed dt g Nothing a | ||
99 | 100 | ||
100 | -- Combinators | 101 | -- Combinators |
101 | 102 | ||
@@ -117,9 +118,22 @@ szip f (Step s1) (Step s2) = Step $ \elapsed dt g e d -> | |||
117 | (b, s2') = s2 elapsed dt g e d | 118 | (b, s2') = s2 elapsed dt g e d |
118 | in (f a b, szip f s1' s2') | 119 | in (f a b, szip f s1' s2') |
119 | 120 | ||
120 | -- | Construct a step that switches between two steps based on input. | 121 | -- | Construct a step that is executed when the given event occurs. |
122 | swhen :: Eq e => e -> Step s () a a -> Step s (Maybe e) a a | ||
123 | swhen expectedEvent step = Step $ \elapsed dt state maybeEvent a -> | ||
124 | case maybeEvent of | ||
125 | Nothing -> (a, swhen expectedEvent step) | ||
126 | Just event -> | ||
127 | if event == expectedEvent | ||
128 | then let (a', step') = runStep step elapsed dt state () a | ||
129 | in (a', swhen expectedEvent step') | ||
130 | else (a, swhen expectedEvent step) | ||
131 | |||
132 | -- | Construct a step that switches between two steps based on input events. | ||
121 | -- | 133 | -- |
122 | -- The initial step is the first one. | 134 | -- The current step runs with every 'runStep' even when there are no new events. |
135 | -- | ||
136 | -- The initial step is the identity, 'sid'. | ||
123 | switch :: | 137 | switch :: |
124 | Eq e => | 138 | Eq e => |
125 | e -> | 139 | e -> |
@@ -127,16 +141,8 @@ switch :: | |||
127 | e -> | 141 | e -> |
128 | Step s (Maybe e) a a -> | 142 | Step s (Maybe e) a a -> |
129 | Step s (Maybe e) a a | 143 | Step s (Maybe e) a a |
130 | switch flag1 s1 flag2 s2 = switch' s1 flag1 s1 flag2 s2 | 144 | switch = switch' sid |
131 | 145 | ||
132 | switch' :: | ||
133 | Eq e => | ||
134 | Step s (Maybe e) a a -> | ||
135 | e -> | ||
136 | Step s (Maybe e) a a -> | ||
137 | e -> | ||
138 | Step s (Maybe e) a a -> | ||
139 | Step s (Maybe e) a a | ||
140 | switch' cur flag1 s1 flag2 s2 = Step $ \elapsed dt g e a -> | 146 | switch' cur flag1 s1 flag2 s2 = Step $ \elapsed dt g e a -> |
141 | case e of | 147 | case e of |
142 | Nothing -> | 148 | Nothing -> |
@@ -146,11 +152,15 @@ switch' cur flag1 s1 flag2 s2 = Step $ \elapsed dt g e a -> | |||
146 | let next | 152 | let next |
147 | | e' == flag1 = s1 | 153 | | e' == flag1 = s1 |
148 | | e' == flag2 = s2 | 154 | | e' == flag2 = s2 |
149 | | otherwise = cur | 155 | | otherwise = cur |
150 | (a', s') = runStep next elapsed dt g e a | 156 | (a', s') = runStep next elapsed dt g e a |
151 | in (a', switch' s' flag1 s1 flag2 s2) | 157 | in (a', switch' s' flag1 s1 flag2 s2) |
152 | 158 | ||
153 | -- | Construct a step that switches among multiple steps based on input. | 159 | -- | Construct a step that switches among multiple steps based on input events. |
160 | -- | ||
161 | -- The current step runs with every 'runStep' even when there are no new events. | ||
162 | -- | ||
163 | -- The initial step is the identity, 'sid'. | ||
154 | multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a | 164 | multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a |
155 | multiSwitch xs = multiSwitch' Nothing sid (Map.fromList xs) | 165 | multiSwitch xs = multiSwitch' Nothing sid (Map.fromList xs) |
156 | 166 | ||
diff --git a/Spear/Sys/Timer.hsc b/Spear/Sys/Timer.hsc index 98b88d6..46a692d 100644 --- a/Spear/Sys/Timer.hsc +++ b/Spear/Sys/Timer.hsc | |||
@@ -14,6 +14,7 @@ module Spear.Sys.Timer | |||
14 | , timeDeltaToSec | 14 | , timeDeltaToSec |
15 | , secToTimeDelta | 15 | , secToTimeDelta |
16 | , timePointToNs | 16 | , timePointToNs |
17 | , timeAdd | ||
17 | , sleep | 18 | , sleep |
18 | ) | 19 | ) |
19 | where | 20 | where |
@@ -24,6 +25,7 @@ import Foreign.Marshal.Alloc (alloca) | |||
24 | import Foreign.Ptr | 25 | import Foreign.Ptr |
25 | import Foreign.Storable | 26 | import Foreign.Storable |
26 | import Control.Monad | 27 | import Control.Monad |
28 | import Control.Monad.IO.Class | ||
27 | import System.IO.Unsafe | 29 | import System.IO.Unsafe |
28 | 30 | ||
29 | #include "Timer/timer.h" | 31 | #include "Timer/timer.h" |
@@ -115,6 +117,9 @@ foreign import ccall safe "timer.h sec_to_time_delta" | |||
115 | foreign import ccall safe "timer.h time_point_to_ns" | 117 | foreign import ccall safe "timer.h time_point_to_ns" |
116 | c_time_point_to_ns :: Ptr TimePoint -> Word64 | 118 | c_time_point_to_ns :: Ptr TimePoint -> Word64 |
117 | 119 | ||
120 | foreign import ccall safe "timer.h time_add" | ||
121 | c_time_add :: Ptr TimePoint -> TimeDelta -> Ptr TimePoint -> IO () | ||
122 | |||
118 | foreign import ccall "timer.h time_sleep" | 123 | foreign import ccall "timer.h time_sleep" |
119 | c_time_sleep :: TimeDelta -> IO () | 124 | c_time_sleep :: TimeDelta -> IO () |
120 | 125 | ||
@@ -130,22 +135,22 @@ withTimer' c_func timer = alloca $ \ptr -> do | |||
130 | peek ptr | 135 | peek ptr |
131 | 136 | ||
132 | -- | Construct a new timer. | 137 | -- | Construct a new timer. |
133 | newTimer :: IO Timer | 138 | newTimer :: MonadIO io => io Timer |
134 | newTimer = alloca $ \ptr -> do | 139 | newTimer = liftIO . alloca $ \ptr -> do |
135 | c_timer_make ptr | 140 | c_timer_make ptr |
136 | peek ptr | 141 | peek ptr |
137 | 142 | ||
138 | -- | Start the timer. | 143 | -- | Start the timer. |
139 | start :: Timer -> IO () | 144 | start :: MonadIO io => Timer -> io () |
140 | start = withTimer c_timer_start | 145 | start = liftIO . withTimer c_timer_start |
141 | 146 | ||
142 | -- | Update the timer. | 147 | -- | Update the timer. |
143 | tick :: Timer -> IO Timer | 148 | tick :: MonadIO io => Timer -> io Timer |
144 | tick = withTimer' c_timer_tick | 149 | tick = liftIO . withTimer' c_timer_tick |
145 | 150 | ||
146 | -- | Get the current time. | 151 | -- | Get the current time. |
147 | now :: IO TimePoint | 152 | now :: MonadIO io => io TimePoint |
148 | now = alloca $ \ptr -> do | 153 | now = liftIO . alloca $ \ptr -> do |
149 | c_time_now ptr | 154 | c_time_now ptr |
150 | peek ptr | 155 | peek ptr |
151 | 156 | ||
@@ -172,6 +177,15 @@ timePointToNs t = unsafeDupablePerformIO $ alloca $ \ptr -> do | |||
172 | poke ptr t | 177 | poke ptr t |
173 | return $ c_time_point_to_ns ptr | 178 | return $ c_time_point_to_ns ptr |
174 | 179 | ||
180 | -- | Add a time delta to a timestamp. | ||
181 | timeAdd :: TimePoint -> TimeDelta -> TimePoint | ||
182 | timeAdd t dt = unsafeDupablePerformIO $ | ||
183 | alloca $ \tPtr -> | ||
184 | alloca $ \ptr -> do | ||
185 | poke tPtr t | ||
186 | c_time_add tPtr dt ptr | ||
187 | peek ptr | ||
188 | |||
175 | -- | Put the caller thread to sleep for the given amount of time. | 189 | -- | Put the caller thread to sleep for the given amount of time. |
176 | sleep :: TimeDelta -> IO () | 190 | sleep :: MonadIO io => TimeDelta -> io () |
177 | sleep = c_time_sleep | 191 | sleep = liftIO . c_time_sleep |
diff --git a/Spear/Sys/Timer/timer.c b/Spear/Sys/Timer/timer.c index 8487f48..4a2fb2b 100644 --- a/Spear/Sys/Timer/timer.c +++ b/Spear/Sys/Timer/timer.c | |||
@@ -48,7 +48,7 @@ void time_now(time_point* t) { | |||
48 | #ifdef _WIN32 | 48 | #ifdef _WIN32 |
49 | QueryPerformanceCounter((LARGE_INTEGER*)t); | 49 | QueryPerformanceCounter((LARGE_INTEGER*)t); |
50 | #else | 50 | #else |
51 | clock_gettime(CLOCK_REALTIME, t); | 51 | clock_gettime(CLOCK_MONOTONIC_RAW, t); |
52 | #endif | 52 | #endif |
53 | } | 53 | } |
54 | 54 | ||
@@ -87,6 +87,15 @@ uint64_t time_point_to_ns(time_point* t) { | |||
87 | #endif | 87 | #endif |
88 | } | 88 | } |
89 | 89 | ||
90 | void time_add(const time_point* t, time_delta dt, time_point* out) { | ||
91 | #ifdef _WIN32 | ||
92 | *out = *t + dt; | ||
93 | #else | ||
94 | out->tv_sec = t->tv_sec + (dt / nanoseconds); | ||
95 | out->tv_nsec = t->tv_nsec + (dt % nanoseconds); | ||
96 | #endif | ||
97 | } | ||
98 | |||
90 | void time_sleep(time_delta dt) { | 99 | void time_sleep(time_delta dt) { |
91 | #ifdef _WIN32 | 100 | #ifdef _WIN32 |
92 | const int64_t ms = dt / microseconds; | 101 | const int64_t ms = dt / microseconds; |
diff --git a/Spear/Sys/Timer/timer.h b/Spear/Sys/Timer/timer.h index e426135..da4e7c7 100644 --- a/Spear/Sys/Timer/timer.h +++ b/Spear/Sys/Timer/timer.h | |||
@@ -53,6 +53,9 @@ time_delta sec_to_time_delta(double seconds); | |||
53 | /// Convert the time point to nanoseconds. | 53 | /// Convert the time point to nanoseconds. |
54 | uint64_t time_point_to_ns(time_point*); | 54 | uint64_t time_point_to_ns(time_point*); |
55 | 55 | ||
56 | /// Add a time delta to a timestamp. | ||
57 | void time_add(const time_point*, time_delta, time_point* out); | ||
58 | |||
56 | /// Put the caller thread to sleep for the given amount of time. | 59 | /// Put the caller thread to sleep for the given amount of time. |
57 | void time_sleep(time_delta dt); | 60 | void time_sleep(time_delta dt); |
58 | 61 | ||
diff --git a/Spear/Window.hs b/Spear/Window.hs index 3cdc5f5..a873362 100644 --- a/Spear/Window.hs +++ b/Spear/Window.hs | |||
@@ -7,7 +7,6 @@ module Spear.Window | |||
7 | Window, | 7 | Window, |
8 | Width, | 8 | Width, |
9 | Height, | 9 | Height, |
10 | Init, | ||
11 | WindowEvent(..), | 10 | WindowEvent(..), |
12 | withWindow, | 11 | withWindow, |
13 | pollWindowEvents, | 12 | pollWindowEvents, |
@@ -21,10 +20,10 @@ module Spear.Window | |||
21 | whenKeyUp, | 20 | whenKeyUp, |
22 | processKeys, | 21 | processKeys, |
23 | processButtons, | 22 | processButtons, |
24 | InputEvent (..), | 23 | InputEvent(..), |
25 | Key (..), | 24 | Key(..), |
26 | MouseButton (..), | 25 | MouseButton(..), |
27 | MouseProp (..), | 26 | MouseProp(..), |
28 | MousePos, | 27 | MousePos, |
29 | MouseDelta, | 28 | MouseDelta, |
30 | ) | 29 | ) |
@@ -35,6 +34,7 @@ import Spear.Game | |||
35 | import Control.Concurrent.MVar | 34 | import Control.Concurrent.MVar |
36 | import Control.Exception | 35 | import Control.Exception |
37 | import Control.Monad (foldM, unless, void, when) | 36 | import Control.Monad (foldM, unless, void, when) |
37 | import Control.Monad.IO.Class | ||
38 | import Data.Functor ((<&>)) | 38 | import Data.Functor ((<&>)) |
39 | import Data.Maybe (fromJust, fromMaybe, isJust) | 39 | import Data.Maybe (fromJust, fromMaybe, isJust) |
40 | import qualified Graphics.UI.GLFW as GLFW | 40 | import qualified Graphics.UI.GLFW as GLFW |
@@ -52,12 +52,6 @@ type Dimensions = (Width, Height) | |||
52 | 52 | ||
53 | type WindowTitle = String | 53 | type WindowTitle = String |
54 | 54 | ||
55 | -- | Game initialiser. | ||
56 | type Init s = Window -> Game () s | ||
57 | |||
58 | -- | Game finalizer. | ||
59 | type End s = Game s () | ||
60 | |||
61 | -- | Window exception. | 55 | -- | Window exception. |
62 | newtype WindowException = WindowException String deriving (Show) | 56 | newtype WindowException = WindowException String deriving (Show) |
63 | 57 | ||
@@ -83,32 +77,19 @@ data Window = Window | |||
83 | } | 77 | } |
84 | 78 | ||
85 | 79 | ||
86 | withWindow :: | 80 | withWindow :: MonadIO io => Dimensions -> WindowTitle -> (Window -> IO a) -> io a |
87 | Dimensions -> | 81 | withWindow dim@(w, h) windowTitle run = liftIO $ do |
88 | Maybe WindowTitle -> | 82 | window <- do |
89 | Init s -> | 83 | success <- GLFW.init |
90 | End s -> | 84 | unless success $ throw (WindowException "GLFW.initialize failed") |
91 | (Window -> Game s a) -> | 85 | setup dim windowTitle |
92 | IO a | 86 | result <- run window |
93 | withWindow dim@(w, h) windowTitle init end run = do | 87 | GLFW.destroyWindow $ glfwWindow window |
94 | flip evalGame () $ do | 88 | GLFW.terminate |
95 | window <- gameIO $ do | 89 | return result |
96 | success <- GLFW.init | 90 | |
97 | unless success $ throw (WindowException "GLFW.initialize failed") | 91 | setup :: MonadIO io => Dimensions -> WindowTitle -> io Window |
98 | setup dim windowTitle | 92 | setup (w, h) windowTitle = liftIO $ do |
99 | gameState <- init window | ||
100 | (result, endGameState) <- runSubGame (run window) gameState | ||
101 | runSubGame' end endGameState | ||
102 | gameIO $ do | ||
103 | GLFW.destroyWindow $ glfwWindow window | ||
104 | GLFW.terminate | ||
105 | return result | ||
106 | |||
107 | setup :: | ||
108 | Dimensions -> | ||
109 | Maybe WindowTitle -> | ||
110 | IO Window | ||
111 | setup (w, h) windowTitle = do | ||
112 | closeRequest <- newEmptyMVar | 93 | closeRequest <- newEmptyMVar |
113 | windowEvents <- newEmptyMVar | 94 | windowEvents <- newEmptyMVar |
114 | inputEvents <- newEmptyMVar | 95 | inputEvents <- newEmptyMVar |
@@ -118,7 +99,7 @@ setup (w, h) windowTitle = do | |||
118 | GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor major | 99 | GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor major |
119 | GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor minor | 100 | GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor minor |
120 | when (major >= 3) $ GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core | 101 | when (major >= 3) $ GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core |
121 | GLFW.createWindow w h (fromMaybe "Spear" windowTitle) Nothing Nothing | 102 | GLFW.createWindow w h windowTitle Nothing Nothing |
122 | 103 | ||
123 | unless (isJust maybeWindow) | 104 | unless (isJust maybeWindow) |
124 | $ throwIO (WindowException "GLFW.openWindow failed") | 105 | $ throwIO (WindowException "GLFW.openWindow failed") |
@@ -127,24 +108,25 @@ setup (w, h) windowTitle = do | |||
127 | 108 | ||
128 | GLFW.makeContextCurrent maybeWindow | 109 | GLFW.makeContextCurrent maybeWindow |
129 | 110 | ||
111 | GLFW.swapInterval (-1) -- 1 enable vsync. -1 for adaptive vsync. | ||
112 | |||
130 | GLFW.setWindowCloseCallback window . Just $ onWindowClose closeRequest | 113 | GLFW.setWindowCloseCallback window . Just $ onWindowClose closeRequest |
131 | GLFW.setWindowSizeCallback window . Just $ onResize windowEvents | 114 | GLFW.setWindowSizeCallback window . Just $ onResize windowEvents |
132 | GLFW.setKeyCallback window . Just $ onKey inputEvents | 115 | GLFW.setKeyCallback window . Just $ onKey inputEvents |
133 | GLFW.setCharCallback window . Just $ onChar inputEvents | ||
134 | GLFW.setMouseButtonCallback window . Just $ onMouseButton inputEvents | 116 | GLFW.setMouseButtonCallback window . Just $ onMouseButton inputEvents |
135 | GLFW.setCursorPosCallback window . Just $ onMouseMove mousePos inputEvents | 117 | GLFW.setCursorPosCallback window . Just $ onMouseMove mousePos inputEvents |
136 | 118 | ||
137 | return $ Window window closeRequest inputEvents windowEvents | 119 | return $ Window window closeRequest inputEvents windowEvents |
138 | 120 | ||
139 | -- | Poll for input events. | 121 | -- | Poll for input events. |
140 | pollInputEvents :: Window -> IO [InputEvent] | 122 | pollInputEvents :: MonadIO io => Window -> io [InputEvent] |
141 | pollInputEvents window = do | 123 | pollInputEvents window = liftIO $ do |
142 | GLFW.pollEvents | 124 | GLFW.pollEvents |
143 | getEvents (inputEventsMVar window) | 125 | getEvents (inputEventsMVar window) |
144 | 126 | ||
145 | -- | Poll for window events. | 127 | -- | Poll for window events. |
146 | pollWindowEvents :: Window -> IO [WindowEvent] | 128 | pollWindowEvents :: MonadIO io => Window -> io [WindowEvent] |
147 | pollWindowEvents window = do | 129 | pollWindowEvents window = liftIO $ do |
148 | GLFW.pollEvents | 130 | GLFW.pollEvents |
149 | getEvents (windowEventsMVar window) | 131 | getEvents (windowEventsMVar window) |
150 | 132 | ||
@@ -156,16 +138,16 @@ getEvents mvar = tryTakeMVar mvar >>= \xs -> do | |||
156 | Just events -> return events | 138 | Just events -> return events |
157 | 139 | ||
158 | -- | Return true when the user requests to close the window. | 140 | -- | Return true when the user requests to close the window. |
159 | shouldWindowClose :: Window -> IO Bool | 141 | shouldWindowClose :: MonadIO io => Window -> io Bool |
160 | shouldWindowClose = getRequest . closeRequestMVar | 142 | shouldWindowClose = liftIO . getRequest . closeRequestMVar |
161 | 143 | ||
162 | -- | Swaps buffers. | 144 | -- | Swaps buffers. |
163 | swapBuffers :: Window -> IO () | 145 | swapBuffers :: MonadIO io => Window -> io () |
164 | swapBuffers = GLFW.swapBuffers . glfwWindow | 146 | swapBuffers = liftIO . GLFW.swapBuffers . glfwWindow |
165 | 147 | ||
166 | -- | Get the window's size. | 148 | -- | Get the window's size. |
167 | getWindowSize :: Window -> IO (Width, Height) | 149 | getWindowSize :: MonadIO io => Window -> io (Width, Height) |
168 | getWindowSize = GLFW.getWindowSize . glfwWindow | 150 | getWindowSize = liftIO . GLFW.getWindowSize . glfwWindow |
169 | 151 | ||
170 | getRequest :: MVar Bool -> IO Bool | 152 | getRequest :: MVar Bool -> IO Bool |
171 | getRequest mvar = | 153 | getRequest mvar = |
@@ -178,19 +160,16 @@ onWindowClose closeRequest window = putMVar closeRequest True | |||
178 | -- the last in a poll can be ignored, we just replace the contents of the mvar | 160 | -- the last in a poll can be ignored, we just replace the contents of the mvar |
179 | -- here instead of adding the event to the list. | 161 | -- here instead of adding the event to the list. |
180 | onResize :: MVar [WindowEvent] -> GLFW.WindowSizeCallback | 162 | onResize :: MVar [WindowEvent] -> GLFW.WindowSizeCallback |
181 | onResize windowEvents window w h = putMVar windowEvents [ResizeEvent w h] | 163 | onResize windowEvents window w h = modifyMVar_ windowEvents (return <$> const [ResizeEvent w h]) |
182 | 164 | ||
183 | onKey :: MVar [InputEvent] -> GLFW.KeyCallback | 165 | onKey :: MVar [InputEvent] -> GLFW.KeyCallback |
184 | onKey events window key _ GLFW.KeyState'Pressed _ = addEvent events $ KeyDown (fromGLFWkey key) | 166 | onKey events window key _ GLFW.KeyState'Pressed _ = addEvent events $ KeyDown (fromGLFWkey key) |
185 | onKey events window key _ GLFW.KeyState'Released _ = addEvent events $ KeyUp (fromGLFWkey key) | 167 | onKey events window key _ GLFW.KeyState'Released _ = addEvent events $ KeyUp (fromGLFWkey key) |
186 | onKey events window key _ GLFW.KeyState'Repeating _ = return () | 168 | onKey events window key _ GLFW.KeyState'Repeating _ = return () |
187 | 169 | ||
188 | onChar :: MVar [InputEvent] -> GLFW.CharCallback | ||
189 | onChar events window char = addEvent events $ KeyDown . fromGLFWkey . read $ [char] | ||
190 | |||
191 | onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback | 170 | onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback |
192 | onMouseButton events window button GLFW.MouseButtonState'Pressed _ = addEvent events $ MouseDown (fromGLFWbutton button) | 171 | onMouseButton events window button GLFW.MouseButtonState'Pressed _ = addEvent events $ MouseDown (fromGLFWbutton button) |
193 | onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp (fromGLFWbutton button) | 172 | onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp (fromGLFWbutton button) |
194 | 173 | ||
195 | onMouseMove :: MVar MousePos -> MVar [InputEvent] -> GLFW.CursorPosCallback | 174 | onMouseMove :: MVar MousePos -> MVar [InputEvent] -> GLFW.CursorPosCallback |
196 | onMouseMove oldPos events window x y = do | 175 | onMouseMove oldPos events window x y = do |
@@ -214,39 +193,39 @@ addEvent mvar val = | |||
214 | -- Input | 193 | -- Input |
215 | 194 | ||
216 | -- | Run the game action when the key is down. | 195 | -- | Run the game action when the key is down. |
217 | whenKeyDown :: GLFW.Window -> Key -> Game s a -> Game s () | 196 | whenKeyDown :: GLFW.Window -> Key -> Game s () -> Game s () |
218 | whenKeyDown = whenKeyInState (== GLFW.KeyState'Pressed) | 197 | whenKeyDown = whenKeyInState GLFW.KeyState'Pressed |
219 | 198 | ||
220 | -- | Run the game action when the key is up. | 199 | -- | Run the game action when the key is up. |
221 | whenKeyUp :: GLFW.Window -> Key -> Game s a -> Game s () | 200 | whenKeyUp :: GLFW.Window -> Key -> Game s () -> Game s () |
222 | whenKeyUp = whenKeyInState (== GLFW.KeyState'Released) | 201 | whenKeyUp = whenKeyInState GLFW.KeyState'Released |
223 | 202 | ||
224 | whenKeyInState :: (GLFW.KeyState -> Bool) -> GLFW.Window -> Key -> Game s a -> Game s () | 203 | whenKeyInState :: GLFW.KeyState -> GLFW.Window -> Key -> Game s () -> Game s () |
225 | whenKeyInState pred window key game = do | 204 | whenKeyInState state window key game = do |
226 | isDown <- fmap pred $ gameIO . GLFW.getKey window . toGLFWkey $ key | 205 | isDown <- fmap (==state) $ liftIO . GLFW.getKey window . toGLFWkey $ key |
227 | when isDown $ void game | 206 | when isDown game |
228 | 207 | ||
229 | -- | Process the keyboard keys, returning those values for which their | 208 | -- | Check whether the given keys are pressed and return the value associated |
230 | -- corresponding key is pressed. | 209 | -- with each of the pressed keys. |
231 | processKeys :: GLFW.Window -> [(Key, a)] -> Game s [a] | 210 | processKeys :: Window -> [(Key, a)] -> Game s [a] |
232 | processKeys window = foldM f [] | 211 | processKeys window = foldM f [] |
233 | where | 212 | where |
234 | f acc (key, result) = do | 213 | f acc (key, result) = do |
235 | isDown <- | 214 | isDown <- |
236 | fmap (== GLFW.KeyState'Pressed) $ | 215 | fmap (== GLFW.KeyState'Pressed) $ |
237 | gameIO . GLFW.getKey window . toGLFWkey $ | 216 | liftIO . GLFW.getKey (glfwWindow window) . toGLFWkey $ |
238 | key | 217 | key |
239 | return $ if isDown then result : acc else acc | 218 | return $ if isDown then result : acc else acc |
240 | 219 | ||
241 | -- | Process the mouse buttons, returning those values for which their | 220 | -- | Check whether the given buttons are pressed and return the value associated |
242 | -- corresponding button is pressed. | 221 | -- with each of the pressed buttons. |
243 | processButtons :: GLFW.Window -> [(MouseButton, a)] -> Game s [a] | 222 | processButtons :: Window -> [(MouseButton, a)] -> Game s [a] |
244 | processButtons window = foldM f [] | 223 | processButtons window = foldM f [] |
245 | where | 224 | where |
246 | f acc (button, result) = do | 225 | f acc (button, result) = do |
247 | isDown <- | 226 | isDown <- |
248 | fmap (== GLFW.MouseButtonState'Pressed) $ | 227 | fmap (== GLFW.MouseButtonState'Pressed) $ |
249 | gameIO . GLFW.getMouseButton window . toGLFWbutton $ | 228 | liftIO . GLFW.getMouseButton (glfwWindow window) . toGLFWbutton $ |
250 | button | 229 | button |
251 | return $ if isDown then result : acc else acc | 230 | return $ if isDown then result : acc else acc |
252 | 231 | ||