aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Demos/Balls/Main.hs176
-rw-r--r--Demos/Pong/Main.hs104
-rw-r--r--Demos/Pong/Pong.hs186
-rw-r--r--README.md4
-rw-r--r--Spear.cabal29
-rw-r--r--Spear/App.hs278
-rw-r--r--Spear/Assets/Image.hsc18
-rw-r--r--Spear/Assets/Model.hsc60
-rw-r--r--Spear/GL.hs42
-rw-r--r--Spear/Game.hs226
-rw-r--r--Spear/Math/Physics/Rigid.hs125
-rw-r--r--Spear/Math/Physics/Types.hs11
-rw-r--r--Spear/Math/Plane.hs60
-rw-r--r--Spear/Math/Spatial.hs12
-rw-r--r--Spear/Math/Spatial2.hs2
-rw-r--r--Spear/Math/Vector/Vector.hs3
-rw-r--r--Spear/Math/Vector/Vector2.hs8
-rw-r--r--Spear/Math/Vector/Vector3.hs3
-rw-r--r--Spear/Math/Vector/Vector4.hs3
-rw-r--r--Spear/Physics/Collision.hs63
-rw-r--r--Spear/Physics/RigidBody.hs77
-rw-r--r--Spear/Render/AnimatedModel.hs13
-rw-r--r--Spear/Render/Core/Buffer.hs16
-rw-r--r--Spear/Render/Core/Geometry.hs21
-rw-r--r--Spear/Render/Core/Pipeline.hs24
-rw-r--r--Spear/Render/Core/Shader.hs88
-rw-r--r--Spear/Render/Core/State.hs9
-rw-r--r--Spear/Render/Immediate.hs57
-rw-r--r--Spear/Render/Shaders.hs12
-rw-r--r--Spear/Render/Shaders/immediate_mode.frag10
-rw-r--r--Spear/Render/Shaders/immediate_mode.vert11
-rw-r--r--Spear/Render/StaticModel.hs13
-rw-r--r--Spear/Scene/Loader.hs16
-rw-r--r--Spear/Sound/Sound.hs104
-rw-r--r--Spear/Sound/State.hs54
-rw-r--r--Spear/Step.hs88
-rw-r--r--Spear/Sys/Timer.hsc34
-rw-r--r--Spear/Sys/Timer/timer.c11
-rw-r--r--Spear/Sys/Timer/timer.h3
-rw-r--r--Spear/Window.hs125
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
6module Main where
7
8import Spear.App
9import Spear.Game
10import Spear.Math.AABB
11import qualified Spear.Math.Matrix3 as Matrix3
12import qualified Spear.Math.Matrix4 as Matrix4
13import Spear.Math.Spatial
14import Spear.Math.Spatial2
15import Spear.Math.Vector
16import Spear.Physics.Collision
17--import Spear.Prelude
18import Spear.Render.Core.Pipeline
19import Spear.Render.Core.State
20import Spear.Render.Immediate
21import Spear.Sound.Sound
22import Spear.Sound.State
23import Spear.Window
24
25import Control.Monad (when)
26
27
28ballSize = 0.01
29numBalls = 1000
30
31data Ball = Ball
32 { ballPosition :: {-# UNPACK #-} !Vector2
33 , ballVelocity :: {-# UNPACK #-} !Vector2
34 }
35
36instance Positional Ball Vector2 where
37 setPosition p ball = ball { ballPosition = p }
38 position = ballPosition
39 translate v ball = ball { ballPosition = v + ballPosition ball }
40
41instance 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
46data World = World
47 { viewProjection :: Matrix4.Matrix4
48 , balls :: [Ball]
49 }
50
51type GameState = AppState World
52
53
54options = defaultAppOptions { title = "Balls" }
55
56app = App options initGame endGame step render resize
57
58
59main :: IO ()
60main = runApp app
61
62initGame :: Game AppContext World
63initGame =
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
77endGame :: Game GameState ()
78endGame = return ()
79
80
81step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
82step elapsed dt inputEvents = do
83 modifyGameState $ \world -> world
84 { balls = moveBalls dt $ balls world
85 }
86 return (not $ exitRequested inputEvents)
87
88exitRequested = elem (KeyDown KEY_ESC)
89
90moveBalls :: Elapsed -> [Ball] -> [Ball]
91moveBalls dt = (bounceBall dt . moveBall dt <$>)
92
93moveBall :: Elapsed -> Ball -> Ball
94moveBall dt ball = translate (scale (realToFrac dt) $ ballVelocity ball) ball
95
96bounceBall :: Elapsed -> Ball -> Ball
97bounceBall 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
120render :: Game GameState ()
121render = 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
133render' :: [Ball] -> Game ImmRenderState ()
134render' 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
141renderBackground :: Game ImmRenderState ()
142renderBackground =
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
153renderBall :: Ball -> Game ImmRenderState ()
154renderBall 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
164resize :: WindowEvent -> Game GameState ()
165resize (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
1module Main where 3module Main where
2 4
3import Pong 5import Pong
@@ -5,66 +7,85 @@ import Pong
5import Spear.App 7import Spear.App
6import Spear.Game 8import Spear.Game
7import Spear.Math.AABB 9import Spear.Math.AABB
8import Spear.Math.Matrix4 as Matrix4 hiding (position) 10import Spear.Math.Matrix4 as Matrix4
9import Spear.Math.Spatial 11import Spear.Math.Spatial
10import Spear.Math.Spatial2 12import Spear.Math.Spatial2
11import Spear.Math.Vector 13import Spear.Math.Vector
14import Spear.Physics.Collision
12import Spear.Render.Core.Pipeline 15import Spear.Render.Core.Pipeline
13import Spear.Render.Core.State 16import Spear.Render.Core.State
14import Spear.Render.Immediate 17import Spear.Render.Immediate
18import Spear.Sound.Sound
19import Spear.Sound.State
15import Spear.Window 20import Spear.Window
16 21
17import Data.Maybe (mapMaybe) 22import Control.Monad (when)
18 23
19 24
20data GameState = GameState 25data 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
28app = App step render resize 31type GameState = AppState Pong
32
33
34options = defaultAppOptions { title = "Pong" }
35
36app = App options initGame endGame step render resize
29 37
30main =
31 withWindow (900, 600) (Just "Pong") initGame endGame $
32 loop app
33 38
34initGame :: Window -> Game () GameState 39main :: IO ()
35initGame window = do 40main = runApp app
36 (immRenderState, renderCoreState) <- runSiblingGame newImmRenderer newRenderCoreState 41
37 return $ GameState window renderCoreState immRenderState Matrix4.id newWorld 42initGame :: Game AppContext Pong
43initGame = 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
39endGame :: Game GameState () 53endGame :: Game GameState ()
40endGame = do 54endGame = return ()
41 game <- getGameState 55
42 runSubGame' (deleteImmRenderer $ immRenderState game) (renderCoreState game)
43 56
44step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool 57step :: Elapsed -> Dt -> [InputEvent] -> Game GameState Bool
45step elapsed dt inputEvents = do 58step 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
68processInput :: Window -> Game GameState [GameEvent]
69processInput window = processKeys window
70 [ (KEY_A, MoveLeft)
71 , (KEY_D, MoveRight)
72 ]
73
74exitRequested = elem (KeyDown KEY_ESC)
75
76
54render :: Game GameState () 77render :: Game GameState ()
55render = do 78render = 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
69render' :: [GameObject] -> Game ImmRenderState () 90render' :: [GameObject] -> Game ImmRenderState ()
70render' world = do 91render' 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
89renderGO :: GameObject -> Game ImmRenderState () 110renderGO :: GameObject -> Game ImmRenderState ()
90renderGO go = do 111renderGO 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
102resize :: WindowEvent -> Game GameState () 121resize :: WindowEvent -> Game GameState ()
103resize (ResizeEvent w h) = 122resize (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
116translateEvents = 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
123exitRequested = 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
5module Pong 5module Pong
6 ( GameEvent (..), 6( GameEvent (..)
7 GameObject, 7, GameObject
8 newWorld, 8, newWorld
9 stepWorld, 9, stepWorld
10 aabb, 10)
11 )
12where 11where
13 12
14import Spear.Math.AABB 13import Spear.Math.AABB
@@ -16,21 +15,23 @@ import Spear.Math.Algebra
16import Spear.Math.Spatial 15import Spear.Math.Spatial
17import Spear.Math.Spatial2 16import Spear.Math.Spatial2
18import Spear.Math.Vector 17import Spear.Math.Vector
18import Spear.Physics.Collision
19import Spear.Prelude 19import Spear.Prelude
20import Spear.Step 20import Spear.Step
21 21
22import Data.Monoid (mconcat) 22import Data.Monoid (mconcat)
23 23
24 24
25-- Configuration 25-- Configuration
26 26
27padSize = vec2 0.07 0.02 27padSize = vec2 0.070 0.015
28ballSize = 0.012 :: Float 28ballSize = vec2 0.012 0.012
29ballSpeed = 0.6 :: Float 29ballSpeed = 0.7 :: Float
30initialBallVelocity = vec2 1 1 30initialBallVelocity = vec2 1 1
31maxBounceAngle = (65::Float) * (pi::Float)/(180::Float) 31maxBounceAngle = (65::Float) * (pi::Float)/(180::Float)
32playerSpeed = 1.0 :: Float 32playerSpeed = 1.0 :: Float
33enemySpeed = 3.0 :: Float 33enemySpeed = 7.0 :: Float
34enemyMomentum = 1.0 :: Float
34initialEnemyPos = vec2 0.5 0.9 35initialEnemyPos = vec2 0.5 0.9
35initialPlayerPos = vec2 0.5 0.1 36initialPlayerPos = vec2 0.5 0.1
36initialBallPos = vec2 0.5 0.5 37initialBallPos = vec2 0.5 0.5
@@ -40,16 +41,22 @@ initialBallPos = vec2 0.5 0.5
40data GameEvent 41data 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
49data GameObjectId
50 = Ball
51 | Enemy
52 | Player
53 deriving (Eq, Show)
54
49data GameObject = GameObject 55data 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
82stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] 89instance Bounded2 GameObject where
83stepWorld 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
85update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
86update elapsed dt evts gos go =
87 let (go', s') = runStep (gostep go) elapsed dt gos evts go
88 in go' {gostep = s'}
89 92
90ballBox, padBox :: AABB2
91ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = ballSize
92padBox = AABB2 (-padSize) padSize
93 93
94newWorld = 94newWorld =
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.
106stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
107stepWorld 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
115update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
116update 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
103stepBall vel = collideBall vel .> moveBall 123stepBall vel = bounceBall vel .> moveBall -- .> clamp
104 124
105-- TODO: in collideBall and paddleBounce, we should an apply an offset to the 125bounceBall :: Vector2 -> Step [GameObject] [GameEvent] GameObject (Vector2, GameObject)
106-- ball when collision is detected. 126bounceBall vel = step $ \_ dt gos events ball ->
107collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) 127 let (AABB2Volume (AABB2 pmin pmax)) = boundingVolume ball
108collideBall 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.
120paddleBounce :: GameObject -> Vector2 -> GameObject -> Vector2 140 delta = (1::Float) + if collision then (3::Float)*dt else (0::Float)
121paddleBounce ball v paddle = 141 in ((ballSpeed * delta * vel', ball), bounceBall vel')
122 if collide ball paddle 142
143paddleBounce :: GameObject -> [GameEvent] -> Vector2 -> GameObject -> Vector2
144paddleBounce 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
135collide :: GameObject -> GameObject -> Bool
136collide 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
147moveBall :: Step s e (Vector2, GameObject) GameObject 159moveBall :: Step s e (Vector2, GameObject) GameObject
148moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall) 160moveBall = step $ \_ dt _ _ (vel, ball) -> (translate (vel * dt) ball, moveBall)
149 161
162
150-- Enemy stepper 163-- Enemy stepper
151 164
152stepEnemy = movePad 165stepEnemy = movePad 0 .> spure clamp
166
167movePad :: Float -> Step [GameObject] e GameObject GameObject
168movePad 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
154movePad :: Step s e GameObject GameObject
155movePad = 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
166stepPlayer = sfold moveGO .> clamp 179stepPlayer = sfold movePlayer .> spure clamp
167 180
168moveGO = 181movePlayer = 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
174moveGO' :: Vector2 -> Step s e GameObject GameObject 186movePlayer' :: Vector2 -> Step s e GameObject GameObject
175moveGO' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, moveGO' dir) 187movePlayer' dir = step $ \_ dt _ _ go -> (translate (dir * dt) go, movePlayer' dir)
176 188
177clamp :: Step s e GameObject GameObject 189clamp :: GameObject -> GameObject
178clamp = spure $ \go -> 190clamp 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
diff --git a/README.md b/README.md
index 386250d..3296c35 100644
--- a/README.md
+++ b/README.md
@@ -12,9 +12,7 @@ Installation (Ubuntu)
12Install dependencies, then build with cabal: 12Install 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: ""
14library 14library
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
136executable pong 142executable 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
150executable 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
1module Spear.App 4module 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)
8where 19where
9 20
10import Control.Monad
11import Data.Fixed (mod')
12import GHC.Float
13import Spear.Game 21import Spear.Game
14import Spear.Sys.Timer as Timer 22import Spear.Render.Core.State
23import Spear.Render.Immediate
24import Spear.Sound.Sound
25import Spear.Sound.State
26import Spear.Sys.Timer as Timer
15import Spear.Window 27import Spear.Window
16 28
17maxFPS = 60 29import Control.Monad
30import Data.Fixed (mod')
31import GHC.Float
32
18 33
19-- | Time elapsed. 34-- | Time elapsed.
20type Elapsed = Double 35type 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.
26type Step s = Elapsed -> Dt -> [InputEvent] -> Game s Bool 41type Step s = Elapsed -> Dt -> [InputEvent] -> Game s Bool
27 42
28-- | Application functions. 43-- | Application options.
44--
45-- Use `defaultOptions` for default options.
46data 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.
56defaultAppOptions = 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.
29data App s = App 66data 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`.
79data AppContext = AppContext
80 { contextWindow :: Window
81 , contextRenderCoreState :: RenderCoreState
82 , contextSoundState :: SoundState
83 , contextImmRenderState :: ImmRenderState
84 }
85
86instance HasState AppContext RenderCoreState where
87 getInnerState = contextRenderCoreState
88 setInnerState context state = context { contextRenderCoreState = state }
89
90instance HasState AppContext SoundState where
91 getInnerState = contextSoundState
92 setInnerState context state = context { contextSoundState = state }
93
94instance HasState AppContext ImmRenderState where
95 getInnerState = contextImmRenderState
96 setInnerState context state = context { contextImmRenderState = state }
97
98-- | Application state.
99data 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.
108instance HasState (AppState s) s where
109 getInnerState = appCustomState
110 setInnerState appState state = appState { appCustomState = state }
111
112instance HasState (AppState s) RenderCoreState where
113 getInnerState = appRenderCoreState
114 setInnerState appState state = appState { appRenderCoreState = state }
115
116instance HasState (AppState s) SoundState where
117 getInnerState = appSoundState
118 setInnerState appState state = appState { appSoundState = state }
119
120instance 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.
126getGameState :: Game (AppState s) s
127getGameState = appCustomState <$> get
128
129-- | Put the custom state in the app state.
130putGameState :: s -> Game (AppState s) ()
131putGameState custom = do
132 appState <- get
133 put $ appState { appCustomState = custom }
134
135-- | Modify the custom state in the app state.
136modifyGameState :: (s -> s) -> Game (AppState s) ()
137modifyGameState f = modify $ \appState -> appState { appCustomState = f (appCustomState appState )}
138
139-- | Run the application.
140runApp :: App s -> IO ()
141runApp 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.
36loop :: App s -> Window -> Game s () 174loop :: App s -> Window -> Game (AppState s) ()
37loop app window = do 175loop 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
49loop' :: 190loop' ::
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) ()
57loop' window ddt inputTimer elapsed timeBudget app = do 198loop' 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 255fpsToDdt :: Int -> TimeDelta
89 timer 256fpsToDdt 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
46instance Storable CImage where 46instance 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.
64data Image = Image 64data Image = Image
65 { imageData :: CImage 65 { imageData :: CImage
66 , rkey :: Resource 66 , rkey :: ReleaseKey
67 } 67 }
68 68
69instance ResourceClass Image where 69instance 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
65instance Storable Vec2 where 65instance 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
81instance Storable Vec3 where 81instance 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
99instance Storable TexCoord where 99instance 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
122instance Storable CTriangle where 122instance 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
149instance Storable Box where 149instance 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 }
173instance Storable Skin where 173instance 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
193instance Storable Animation where 193instance 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
224instance Storable Model where 224instance 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
288instance Storable Triangle where 288instance 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.
398transformNormals :: Model -> (Vec3 -> Vec3) -> Model 398transformNormals :: 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.
406toGround :: Model -> IO Model 406toGround :: Model -> IO Model
407toGround model = 407toGround 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
413foreign import ccall "Model.h model_to_ground" 413foreign 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.
123data GLSLShader = GLSLShader 123data GLSLShader = GLSLShader
124 { getShader :: GLuint, 124 { getShader :: GLuint,
125 getShaderKey :: Resource 125 getShaderKey :: ReleaseKey
126 } 126 }
127 127
128instance ResourceClass GLSLShader where 128instance ResourceClass GLSLShader where
@@ -131,7 +131,7 @@ instance ResourceClass GLSLShader where
131-- | A GLSL program handle. 131-- | A GLSL program handle.
132data GLSLProgram = GLSLProgram 132data GLSLProgram = GLSLProgram
133 { getProgram :: GLuint, 133 { getProgram :: GLuint,
134 getProgramKey :: Resource 134 getProgramKey :: ReleaseKey
135 } 135 }
136 136
137instance ResourceClass GLSLProgram where 137instance ResourceClass GLSLProgram where
@@ -173,11 +173,11 @@ attribLocation prog var = makeStateVar get set
173-- | Create a new program. 173-- | Create a new program.
174newProgram :: [GLSLShader] -> Game s GLSLProgram 174newProgram :: [GLSLShader] -> Game s GLSLProgram
175newProgram shaders = do 175newProgram 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
192linkProgram :: GLSLProgram -> Game s () 192linkProgram :: GLSLProgram -> Game s ()
193linkProgram prog = do 193linkProgram 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.
236newShader :: ShaderType -> Game s GLSLShader 236newShader :: ShaderType -> Game s GLSLShader
237newShader shaderType = do 237newShader 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.
254loadSource :: FilePath -> GLSLShader -> Game s () 254loadSource :: FilePath -> GLSLShader -> Game s ()
255loadSource file h = do 255loadSource 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.
439data VAO = VAO 439data VAO = VAO
440 { getVAO :: GLuint, 440 { getVAO :: GLuint,
441 vaoKey :: Resource 441 vaoKey :: ReleaseKey
442 } 442 }
443 443
444instance ResourceClass VAO where 444instance ResourceClass VAO where
@@ -454,7 +454,7 @@ instance Ord VAO where
454-- | Create a new vao. 454-- | Create a new vao.
455newVAO :: Game s VAO 455newVAO :: Game s VAO
456newVAO = do 456newVAO = 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.
534data GLBuffer = GLBuffer 534data GLBuffer = GLBuffer
535 { getBuffer :: GLuint, 535 { getBuffer :: GLuint,
536 rkey :: Resource 536 bufferKey :: ReleaseKey
537 } 537 }
538 538
539instance ResourceClass GLBuffer where 539instance ResourceClass GLBuffer where
540 getResource = rkey 540 getResource = bufferKey
541 541
542-- | The type of target buffer. 542-- | The type of target buffer.
543data TargetBuffer 543data TargetBuffer
@@ -580,7 +580,7 @@ fromUsage DynamicCopy = GL_DYNAMIC_COPY
580-- | Create a new buffer. 580-- | Create a new buffer.
581newBuffer :: Game s GLBuffer 581newBuffer :: Game s GLBuffer
582newBuffer = do 582newBuffer = 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.
657data Texture = Texture 657data Texture = Texture
658 { getTex :: GLuint, 658 { getTex :: GLuint,
659 texKey :: Resource 659 texKey :: ReleaseKey
660 } 660 }
661 661
662instance Eq Texture where 662instance Eq Texture where
@@ -672,7 +672,7 @@ instance ResourceClass Texture where
672-- | Create a new texture. 672-- | Create a new texture.
673newTexture :: Game s Texture 673newTexture :: Game s Texture
674newTexture = do 674newTexture = 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 ::
697loadTextureImage file minFilter magFilter = do 697loadTextureImage 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 =
794assertGL :: Game s a -> String -> Game s a 794assertGL :: Game s a -> String -> Game s a
795assertGL action err = do 795assertGL 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
1module Spear.Game 5module 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 )
36where 33where
37 34
38import Control.Monad.Catch 35import Control.Monad.Catch
39import Control.Monad.State.Strict 36import Control.Monad.State.Strict
40import Control.Monad.Trans.Class (lift) 37import Control.Monad.Trans.Class (lift)
41import qualified Control.Monad.Trans.Resource as R 38import Control.Monad.Trans.Resource
42
43 39
44type 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.
46class ResourceClass a where 45class ResourceClass a where
47 getResource :: a -> Resource 46 getResource :: a -> ReleaseKey
48
49type 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`.
51newtype GameException = GameException String deriving (Show) 52newtype GameException = GameException String deriving (Show)
52 53
53instance Exception GameException 54instance 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.
63newtype 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.
57getGameState :: Game s s 76--
58getGameState = 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. 79class HasState s t where
61saveGameState :: s -> Game s () 80 getInnerState :: s -> t
62saveGameState = put 81 setInnerState :: s -> t -> s
63
64-- | Modify the game state.
65modifyGameState :: (s -> s) -> Game s ()
66modifyGameState = modify
67 82
68-- | Register the given cleaner. 83-- Identity instance.
69register :: IO () -> Game s Resource 84instance HasState s s where
70register = lift . R.register 85 getInnerState = id
86 setInnerState s s' = s'
71 87
72-- | Release the given 'Resource'.
73release :: ResourceClass a => a -> Game s ()
74release = lift . R.release . getResource
75 88
76-- | Release the given 'Resource'. 89-- | Release the given 'Resource'.
77release' :: ResourceClass a => a -> IO () 90release' :: ResourceClass a => a -> Game s ()
78release' = R.release . getResource 91release' = release . getResource
79 92
80-- | Throw an error from the 'Game' monad. 93-- | Throw an error from the 'Game' monad.
81gameError :: String -> Game s a 94gameError :: String -> Game s a
82gameError = gameError' . GameException 95gameError = throwM . GameException
83
84-- | Throw an error from the 'Game' monad.
85gameError' :: GameException -> Game s a
86gameError' = lift . lift . throwM
87 96
88-- | Throw the given error if given 'Nothing'. 97-- | Throw the given error if given 'Nothing'.
89assertMaybe :: Maybe a -> GameException -> Game s a 98assertMaybe :: Maybe a -> GameException -> Game s a
90assertMaybe Nothing err = gameError' err 99assertMaybe Nothing err = throwM err
91assertMaybe (Just x) _ = return x 100assertMaybe (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
94catchGameError :: Game s a -> (GameException -> Game s a) -> Game s a 103-- result and its final state.
95catchGameError = 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. 106runGame :: s -> Game s a -> IO (a, s)
98catchGameErrorFinally :: Game s a -> Game s a -> Game s a 107runGame state game = runResourceT . runStateT (getGame game) $ state
99catchGameErrorFinally 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.
102runGame :: Game s a -> s -> IO (a, s) 111--
103runGame 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.
114runChildGame :: s -> Game s a -> Game t (a, s)
115runChildGame 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.
122runSiblingGame :: s -> Game s a -> Game t (a, s)
123runSiblingGame 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.
106evalGame :: 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
107evalGame g s = fst <$> runGame g s 127eval 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.
110runSubGame :: Game s a -> s -> Game t (a, s) 130exec runner game state = snd <$> runner game state
111runSubGame 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. 133exec' runner game state = void $ runner game state
114runSubGame' :: Game s a -> s -> Game t () 134
115runSubGame' g s = void $ runSubGame g s 135-- | Run a sibling game on nested state.
116 136siblingGame :: HasState s t => Game t a -> Game s a
117-- | Run the given sub game and return its result. 137siblingGame tAction = do
118evalSubGame :: Game s a -> s -> Game t a 138 outerState <- getInnerState <$> get
119evalSubGame 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
122execSubGame :: Game s a -> s -> Game t s
123execSubGame g s = snd <$> runSubGame g s
124
125-- | Run the given sibling game, unrolling StateT but not ResourceT.
126runSiblingGame :: Game s a -> s -> Game t (a, s)
127runSiblingGame g s = lift $ runStateT g s
128
129-- | Like 'runSiblingGame', but discarding the result.
130runSiblingGame' :: Game s a -> s -> Game t ()
131runSiblingGame' g s = void $ runSiblingGame g s
132
133-- | Run the given sibling game and return its result.
134evalSiblingGame :: Game s a -> s -> Game t a
135evalSiblingGame g s = fst <$> runSiblingGame g s
136
137-- | Run the given sibling game and return its state.
138execSiblingGame :: Game s a -> s -> Game t s
139execSiblingGame g s = snd <$> runSiblingGame g s
140
141-- | Perform the given IO action in the 'Game' monad.
142gameIO :: IO a -> Game s a
143gameIO = 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 @@
1module Spear.Math.Physics.Rigid
2(
3 module Spear.Math.Physics.Types
4, RigidBody(..)
5, rigidBody
6, update
7, setVelocity
8, setAcceleration
9)
10where
11
12import qualified Spear.Math.Matrix3 as M3
13import Spear.Math.Spatial2
14import Spear.Math.Vector
15import Spear.Physics.Types
16
17import Data.List (foldl')
18import Control.Monad.State
19
20data RigidBody = RigidBody
21 { mass :: {-# UNPACK #-} !Float
22 , position :: {-# UNPACK #-} !Position
23 , velocity :: {-# UNPACK #-} !Velocity
24 , acceleration :: {-# UNPACK #-} !Acceleration
25 }
26
27instance 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'.
58rigidBody :: Mass -> Position -> RigidBody
59rigidBody m x = RigidBody m x zero2 zero2
60
61-- | Update the given 'RigidBody'.
62update :: [Force] -> Dt -> RigidBody -> RigidBody
63update 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.
77setVelocity :: Velocity -> RigidBody -> RigidBody
78setVelocity v body = body { velocity = v }
79
80-- | Set the body's acceleration.
81setAcceleration :: Acceleration -> RigidBody -> RigidBody
82setAcceleration a body = body { acceleration = a }
83
84
85-- test
86{-gravity = vec2 0 (-10)
87b0 = rigidBody 50 $ vec2 0 1000
88
89
90debug :: IO ()
91debug = evalStateT debug' b0
92
93
94
95debug' :: StateT RigidBody IO ()
96debug' = 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
111step :: (RigidBody -> RigidBody) -> StateT RigidBody IO ()
112step update = do
113 modify update
114 body <- get
115 lift . putStrLn . show' $ body
116
117
118show' body =
119 "mass " ++ (show $ mass body) ++
120 ", position " ++ (showVec $ position body) ++
121 ", velocity " ++ (showVec $ velocity body) ++
122 ", acceleration " ++ (showVec $ acceleration body)
123
124
125showVec 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 @@
1module Spear.Math.Physics.Types
2where
3
4import Spear.Math.Vector
5
6type Dt = Float
7type Force = Vector2
8type Mass = Float
9type Position = Vector2
10type Velocity = Vector2
11type 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
3module Spear.Math.Plane 3module 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)
9where 12where
10 13
11import Spear.Math.Vector 14import Spear.Math.Vector
12import Spear.Prelude 15import Spear.Prelude
13 16
17
18data Axis = X | Y | Z deriving (Eq, Show)
19
20data AxisOrientation = PositiveAxis | NegativeAxis deriving (Eq, Show)
21
14data PointPlanePos = Front | Back | Contained deriving (Eq, Show) 22data PointPlanePos = Front | Back | Contained deriving (Eq, Show)
15 23
24-- | A 3D plane.
16data Plane = Plane 25data 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.
32data 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.
23plane :: Vector3 -> Float -> Plane 41plane :: Vector3 -> Float -> Plane
24plane n d = Plane (normalise n) d 42plane n d = Plane (normalise n) d
25 43
44-- | Construct an axis-aligned plane.
45axisPlane :: Axis -> Float -> AxisOrientation -> AxisPlane
46axisPlane = 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.
29fromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane 51planeFromPoints :: Vector3 -> Vector3 -> Vector3 -> Plane
30fromPoints p0 p1 p2 = Plane n d 52planeFromPoints 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.
37classify :: Plane -> Vector3 -> PointPlanePos 59planeClassify :: Plane -> Vector3 -> PointPlanePos
38classify (Plane n d) pt = 60planeClassify (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.
67axisPlaneClassify :: AxisPlane -> Vector3 -> PointPlanePos
68axisPlaneClassify (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
88move :: Positional a v => Float -> (a -> v) -> a -> a 88move :: Positional a v => Float -> (a -> v) -> a -> a
89move delta axis a = translate (axis a * delta) a 89move delta axis a = translate (axis a * delta) a
90 90
91-- | Move the spatial upwards. 91-- | Move the spatial along its right axis.
92moveRight delta = move delta right 92moveRight delta = move delta right
93 93
94-- | Move the spatial downwards. 94-- | Move the spatial along its left axis.
95moveLeft delta = moveRight (-delta) 95moveLeft delta = moveRight (-delta)
96 96
97-- | Move the spatial upwards. 97-- | Move the spatial along its up axis.
98moveUp delta = move delta up 98moveUp delta = move delta up
99 99
100-- | Move the spatial downwards. 100-- | Move the spatial along its down axis.
101moveDown delta = moveUp (-delta) 101moveDown delta = moveUp (-delta)
102 102
103-- | Move the spatial forwards. 103-- | Move the spatial along its forward axis.
104moveFwd delta = move delta forward 104moveFwd delta = move delta forward
105 105
106-- | Move the spatial backwards. 106-- | Move the spatial along its backward axis.
107moveBack delta = moveFwd (-delta) 107moveBack 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
14import Spear.Prelude 14import Spear.Prelude
15 15
16 16
17-- TODO: These type synonyms don't seem to work well when trying to instantiate
18-- the classes.
17type Positional2 a = Positional a Vector2 19type Positional2 a = Positional a Vector2
18type Rotational2 a = Rotational a Angle 20type Rotational2 a = Rotational a Angle
19type Spatial2 s = Spatial s Vector2 Angle Transform2 21type 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.
36data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show) 36data Vector2 = Vector2
37 {-# UNPACK #-} !Float
38 {-# UNPACK #-} !Float
39 deriving (Eq, Show)
37 40
38 41
39instance Addition Vector2 Vector2 where 42instance 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
133sizeFloat = sizeOf (undefined :: CFloat) 139sizeFloat = 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
167sizeFloat = sizeOf (undefined :: CFloat) 170sizeFloat = 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
165sizeFloat = sizeOf (undefined :: CFloat) 168sizeFloat = 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
6module Spear.Physics.Collision
7(
8 BoundingVolume2(..)
9, Bounded2(..)
10, aabb2Volume
11, collide
12)
13where
14
15import Spear.Math.AABB
16import Spear.Math.Spatial
17import Spear.Math.Spatial2
18import Spear.Math.Vector
19import Spear.Prelude
20
21import Data.Maybe (mapMaybe)
22
23
24-- Currently supporting AABB2. Add circles later when needed.
25data BoundingVolume2
26 = AABB2Volume { box2 :: {-# UNPACK #-} !AABB2 }
27
28
29class Bounded2 a where
30 boundingVolume :: a -> BoundingVolume2
31
32
33-- | Construct a new bounding volume from a 2D axis-aligned box.
34aabb2Volume :: AABB2 -> BoundingVolume2
35aabb2Volume = AABB2Volume
36
37
38-- | Find collisions between the objects in the first list and the objects in
39-- the second list.
40collide :: Bounded2 a => [a] -> [a] -> [(a,a)]
41collide 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.
49objectsCollide :: Bounded2 a => a -> a -> Bool
50objectsCollide o1 o2 =
51 collideAABB2 (box2 . boundingVolume $ o1) (box2 . boundingVolume $ o2)
52
53
54-- | Test two 2D axis-aligned bounding boxes for collision.
55collideAABB2 :: AABB2 -> AABB2 -> Bool
56collideAABB2 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
6module Spear.Physics.RigidBody
7(
8 RigidBody2
9, rigidBody
10, setVelocity
11, setAcceleration
12, update
13)
14where
15
16import Spear.Math.Spatial
17import Spear.Math.Spatial2
18import Spear.Math.Vector
19import Spear.Prelude
20
21import Control.Monad.State
22import Data.List (foldl')
23
24
25type Dt = Float
26type Force = Vector2
27type Mass = Float
28type Position = Vector2
29type Velocity = Vector2
30type 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
40data RigidBody2 = RigidBody2
41 { bodyMass :: {-# UNPACK #-} !Float
42 , bodyPosition :: {-# UNPACK #-} !Position
43 , bodyVelocity :: {-# UNPACK #-} !Velocity
44 , bodyAcceleration :: {-# UNPACK #-} !Acceleration
45 }
46
47
48instance 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'.
55rigidBody :: Mass -> Position -> RigidBody2
56rigidBody mass position = RigidBody2 mass position zero2 zero2
57
58
59-- | Set the body's velocity.
60setVelocity :: Velocity -> RigidBody2 -> RigidBody2
61setVelocity velocity body = body { bodyVelocity = velocity }
62
63
64-- | Set the body's acceleration.
65setAcceleration :: Acceleration -> RigidBody2 -> RigidBody2
66setAcceleration acceleration body = body { bodyAcceleration = acceleration }
67
68
69-- | Update the given 'RigidBody'.
70update :: [Force] -> Dt -> RigidBody2 -> RigidBody2
71update 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
72instance Eq AnimatedModelResource where 72instance 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
14import Spear.Render.Core.State 14import Spear.Render.Core.State
15 15
16import Control.Monad (unless, void) 16import Control.Monad (unless, void)
17import Control.Monad.IO.Class
17import qualified Data.HashMap as HashMap 18import qualified Data.HashMap as HashMap
18import Data.Word 19import Data.Word
19import Foreign.C.Types 20import Foreign.C.Types
@@ -53,24 +54,23 @@ makeBufferAndView desc = do
53 54
54makeBuffer :: BufferDesc -> Game RenderCoreState Buffer 55makeBuffer :: BufferDesc -> Game RenderCoreState Buffer
55makeBuffer (BufferDesc usage bufferData) = do 56makeBuffer (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
64deleteBuffer :: Buffer -> Game RenderCoreState () 65deleteBuffer :: Buffer -> Game RenderCoreState ()
65deleteBuffer buffer = do 66deleteBuffer 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.
72updateBuffer :: Buffer -> BufferData -> IO () 72updateBuffer :: MonadIO io => Buffer -> BufferData -> io ()
73updateBuffer buffer bufferData = 73updateBuffer 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
21import Spear.Render.Core.Constants 21import Spear.Render.Core.Constants
22import Spear.Render.Core.State 22import Spear.Render.Core.State
23 23
24import Control.Monad.IO.Class
24import Data.HashMap as HashMap 25import Data.HashMap as HashMap
25import Data.IORef 26import Data.IORef
26import Data.Maybe (fromJust) 27import Data.Maybe (fromJust)
@@ -87,26 +88,26 @@ newGeometryDesc = GeometryDesc
87makeGeometry :: GeometryDesc -> Game RenderCoreState Geometry 88makeGeometry :: GeometryDesc -> Game RenderCoreState Geometry
88makeGeometry desc = do 89makeGeometry 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
102deleteGeometry :: Geometry -> Game RenderCoreState () 103deleteGeometry :: Geometry -> Game RenderCoreState ()
103deleteGeometry geometry = do 104deleteGeometry 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
108renderGeometry :: Geometry -> IO () 109renderGeometry :: MonadIO io => Geometry -> io ()
109renderGeometry geometry = do 110renderGeometry 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
124setPositions :: Geometry -> [Vector3] -> IO () 125setPositions :: MonadIO io => Geometry -> [Vector3] -> io ()
125setPositions geometry vectors = do 126setPositions 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)
14where 14where
15 15
16import Data.Bits ((.|.)) 16import Control.Monad.IO.Class
17import Data.List (foldl') 17import Data.Bits ((.|.))
18import Data.List (foldl')
18import Graphics.GL.Core46 19import Graphics.GL.Core46
19 20
20 21
@@ -24,7 +25,7 @@ data BufferTarget
24 | StencilBuffer 25 | StencilBuffer
25 26
26 27
27clearBuffers :: [BufferTarget] -> IO () 28clearBuffers :: MonadIO io => [BufferTarget] -> io ()
28clearBuffers = glClear . toBufferBitfield 29clearBuffers = 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
35setBlending :: Bool -> IO () 36setBlending :: MonadIO io => Bool -> io ()
36setBlending enable = 37setBlending 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
41setClearColour :: (Float, Float, Float, Float) -> IO () 42setClearColour :: MonadIO io => (Float, Float, Float, Float) -> io ()
42setClearColour (r,g,b,a) = glClearColor r g b a 43setClearColour (r,g,b,a) = glClearColor r g b a
43 44
44setClearDepth :: Double -> IO () 45setClearDepth :: MonadIO io => Double -> io ()
45setClearDepth = glClearDepth 46setClearDepth = glClearDepth
46 47
47setClearStencil :: Int -> IO () 48setClearStencil :: MonadIO io => Int -> io ()
48setClearStencil = glClearStencil . fromIntegral 49setClearStencil = glClearStencil . fromIntegral
49 50
50setCulling :: Bool -> IO () 51setCulling :: MonadIO io => Bool -> io ()
51setCulling enable = (if enable then glEnable else glDisable) GL_CULL_FACE 52setCulling enable = (if enable then glEnable else glDisable) GL_CULL_FACE
52 53
53setDepthMask :: Bool -> IO () 54setDepthMask :: MonadIO io => Bool -> io ()
54setDepthMask enable = glDepthMask (if enable then GL_TRUE else GL_FALSE) 55setDepthMask enable = glDepthMask (if enable then GL_TRUE else GL_FALSE)
55 56
56setPolygonOffset :: Float -> Float -> IO () 57setPolygonOffset :: MonadIO io => Float -> Float -> io ()
57setPolygonOffset scale bias = do 58setPolygonOffset 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
63setViewport :: 64setViewport ::
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 ()
73setViewport x y width height = 75setViewport 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
1module Spear.Render.Core.Shader 3module Spear.Render.Core.Shader
2( 4(
3 Define(..) 5 Define(..)
@@ -20,11 +22,15 @@ import Spear.Math.Vector
20import Spear.Render.Core.State 22import Spear.Render.Core.State
21 23
22import Control.Monad (mapM_) 24import Control.Monad (mapM_)
25import Control.Monad.IO.Class
23import Data.Bits 26import Data.Bits
27import Data.ByteString as B
24import Data.Hashable 28import Data.Hashable
25import Data.HashMap as HashMap 29import Data.HashMap as HashMap
26import Data.IORef 30import Data.IORef
27import Data.List (deleteBy, foldl', intercalate) 31import Data.List as List (deleteBy, foldl', intercalate)
32import Data.Text as T
33import Data.Text.Encoding as T
28import Foreign.C.String 34import Foreign.C.String
29import Foreign.Marshal.Alloc 35import Foreign.Marshal.Alloc
30import Foreign.Marshal.Array 36import Foreign.Marshal.Array
@@ -35,11 +41,12 @@ import Graphics.GL.Core46
35import Unsafe.Coerce 41import Unsafe.Coerce
36 42
37 43
38type Define = (String, String) 44type Define = (ByteString, ByteString)
39 45
40data ShaderSource 46data ShaderSource
41 = ShaderFromString String 47 = ShaderFromString String
42 | ShaderFromFile FilePath 48 | ShaderFromByteString ByteString
49 | ShaderFromFile FilePath
43 deriving Show 50 deriving Show
44 51
45data ShaderDesc = ShaderDesc 52data 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.
59header = "#version 400 core\n"
60
51 61
52compileShader :: ShaderDesc -> Game RenderCoreState Shader 62compileShader :: ShaderDesc -> Game RenderCoreState Shader
53compileShader (ShaderDesc shaderType source defines) = do 63compileShader (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
97compileShaderProgram :: [Shader] -> Game RenderCoreState ShaderProgram 108compileShaderProgram :: [Shader] -> Game RenderCoreState ShaderProgram
98compileShaderProgram shaders = do 109compileShaderProgram 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
137deleteShader :: Shader -> Game RenderCoreState () 148deleteShader :: Shader -> Game RenderCoreState ()
138deleteShader shader = do 149deleteShader 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
143deleteShaderProgram :: ShaderProgram -> Game RenderCoreState () 154deleteShaderProgram :: ShaderProgram -> Game RenderCoreState ()
144deleteShaderProgram program = do 155deleteShaderProgram 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
149activateShaderProgram :: ShaderProgram -> IO () 160activateShaderProgram :: MonadIO io => ShaderProgram -> io ()
150activateShaderProgram program = do 161activateShaderProgram program = do
151 glUseProgram . shaderProgramHandle $ program 162 glUseProgram . shaderProgramHandle $ program
152 applyUniforms program 163 applyUniforms program
153 164
154deactivateShaderProgram :: ShaderProgram -> IO () 165deactivateShaderProgram :: MonadIO io => ShaderProgram -> io ()
155deactivateShaderProgram _ = glUseProgram 0 166deactivateShaderProgram _ = glUseProgram 0
156 167
157setUniform :: ShaderUniform -> ShaderProgram -> IO () 168setUniform :: MonadIO io => ShaderUniform -> ShaderProgram -> io ()
158setUniform uniform program = 169setUniform 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
164applyUniforms :: ShaderProgram -> IO () 175applyUniforms :: MonadIO io => ShaderProgram -> io ()
165applyUniforms program = 176applyUniforms 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
191glGetUniformLocation' :: GLuint -> String -> IO GLint 202glGetUniformLocation' :: GLuint -> String -> IO GLint
192glGetUniformLocation' handle name = 203glGetUniformLocation' 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 ()
200deleteShaderProgram' = glDeleteProgram 211deleteShaderProgram' = glDeleteProgram
201 212
202hashShaders :: [Shader] -> Int 213hashShaders :: [Shader] -> Int
203hashShaders = foldl' hashF 0 214hashShaders = 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
206toGLShaderType :: ShaderType -> GLenum 217toGLShaderType :: ShaderType -> GLenum
@@ -208,9 +219,6 @@ toGLShaderType VertexShader = GL_VERTEX_SHADER
208toGLShaderType FragmentShader = GL_FRAGMENT_SHADER 219toGLShaderType FragmentShader = GL_FRAGMENT_SHADER
209toGLShaderType ComputeShader = GL_COMPUTE_SHADER 220toGLShaderType ComputeShader = GL_COMPUTE_SHADER
210 221
211makeDefinesString :: [Define] -> String 222makeDefinesString :: [Define] -> ByteString
212makeDefinesString defines = intercalate "\n" body ++ "\n" 223makeDefinesString 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.
216header = "#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).
19data Buffer = Buffer 19data 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.
73data Geometry = Geometry 73data 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.
81data Shader = Shader 81data 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.
103data ShaderProgram = ShaderProgram 103data 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
123type ShaderProgramHash = Int 123type ShaderProgramHash = Int
124 124
125 125
126
127instance ResourceClass Buffer where 126instance 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
32import Spear.Render.Core.Geometry 32import Spear.Render.Core.Geometry
33import Spear.Render.Core.Shader 33import Spear.Render.Core.Shader
34import Spear.Render.Core.State hiding (shaders) 34import Spear.Render.Core.State hiding (shaders)
35import Spear.Render.Shaders as Shaders
35 36
36import Control.Monad (unless) 37import Control.Monad (unless)
37import Data.List (foldl') 38import Data.List (foldl')
@@ -47,11 +48,8 @@ data ImmRenderState = ImmRenderState
47 48
48newImmRenderer :: Game RenderCoreState ImmRenderState 49newImmRenderer :: Game RenderCoreState ImmRenderState
49newImmRenderer = do 50newImmRenderer = 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
79immStart :: Game ImmRenderState () 79immStart :: Game ImmRenderState ()
80immStart = do 80immStart = do
81 state <- getGameState 81 state <- get
82 gameIO $ activateShaderProgram (shader state) 82 activateShaderProgram (shader state)
83 83
84immEnd :: Game ImmRenderState () 84immEnd :: Game ImmRenderState ()
85immEnd = do 85immEnd = do
86 state <- getGameState 86 state <- get
87 gameIO $ deactivateShaderProgram (shader state) 87 deactivateShaderProgram (shader state)
88 88
89immDrawTriangles :: [Vector3] -> Game ImmRenderState () 89immDrawTriangles :: [Vector3] -> Game ImmRenderState ()
90immDrawTriangles vertices = do 90immDrawTriangles 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
114immLoadIdentity :: Game ImmRenderState () 113immLoadIdentity :: Game ImmRenderState ()
115immLoadIdentity = modifyGameState $ \state -> state { 114immLoadIdentity = modify $ \state -> state {
116 matrixStack = [Matrix4.id] } 115 matrixStack = [Matrix4.id] }
117 116
118immTranslate :: Vector3 -> Game ImmRenderState () 117immTranslate :: Vector3 -> Game ImmRenderState ()
119immTranslate vector = modifyGameState $ pushMatrix (Matrix4.translatev vector) 118immTranslate vector = modify $ pushMatrix (Matrix4.translatev vector)
120 119
121immPushMatrix :: Matrix4 -> Game ImmRenderState () 120immPushMatrix :: Matrix4 -> Game ImmRenderState ()
122immPushMatrix matrix = modifyGameState $ pushMatrix matrix 121immPushMatrix matrix = modify $ pushMatrix matrix
123 122
124immPopMatrix :: Game ImmRenderState () 123immPopMatrix :: Game ImmRenderState ()
125immPopMatrix = modifyGameState $ \state -> state { 124immPopMatrix = 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
130immPreservingMatrix :: Game ImmRenderState a -> Game ImmRenderState a 129immPreservingMatrix :: Game ImmRenderState a -> Game ImmRenderState a
131immPreservingMatrix f = do 130immPreservingMatrix 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
137immSetColour :: Vector4 -> Game ImmRenderState () 136immSetColour :: Vector4 -> Game ImmRenderState ()
138immSetColour colour = do 137immSetColour 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
142immSetModelMatrix :: Matrix4 -> Game ImmRenderState () 141immSetModelMatrix :: Matrix4 -> Game ImmRenderState ()
143immSetModelMatrix model = do 142immSetModelMatrix 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
147immSetViewProjectionMatrix :: Matrix4 -> Game ImmRenderState () 146immSetViewProjectionMatrix :: Matrix4 -> Game ImmRenderState ()
148immSetViewProjectionMatrix viewProjection = do 147immSetViewProjectionMatrix 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
158loadMatrixStack :: Game ImmRenderState () 157loadMatrixStack :: Game ImmRenderState ()
159loadMatrixStack = do 158loadMatrixStack = do
160 state <- getGameState 159 state <- get
161 immSetModelMatrix (head $ matrixStack state) 160 immSetModelMatrix (head $ matrixStack state)
162 161
163to3d :: Vector2 -> Vector3 162to3d :: 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
3module Spear.Render.Shaders where
4
5import Data.ByteString
6import Data.FileEmbed
7
8immediateModeFrag :: ByteString
9immediateModeFrag = $(embedFile "Spear/Render/Shaders/immediate_mode.frag")
10
11immediateModeVert :: ByteString
12immediateModeVert = $(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 @@
1precision highp float;
2
3uniform vec4 Colour;
4
5out vec4 FragColour;
6
7void 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 @@
1precision highp float;
2
3uniform mat4 Model;
4uniform mat4 ViewProjection;
5
6layout (location = 0) in vec3 vPosition;
7
8void 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
50instance Eq StaticModelResource where 50instance Eq StaticModelResource where
@@ -74,12 +74,12 @@ staticModelResource ::
74 Model -> 74 Model ->
75 Game s StaticModelResource 75 Game s StaticModelResource
76staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do 76staticModelResource (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.
44loadScene :: FilePath -> Game s (SceneResources, SceneGraph) 44loadScene :: FilePath -> Game s (SceneResources, SceneGraph)
45loadScene file = do 45loadScene 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'.
60resourceMap :: SceneGraph -> Game s SceneResources 60resourceMap :: SceneGraph -> Game s SceneResources
61resourceMap g = execSubGame (resourceMap' g) emptySceneResources 61resourceMap g = exec runChildGame emptySceneResources (resourceMap' g)
62 62
63resourceMap' :: SceneGraph -> Loader () 63resourceMap' :: SceneGraph -> Loader ()
64resourceMap' node@(SceneLeaf nid props) = do 64resourceMap' 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
185rotateModel :: Rotation -> Model -> Model 185rotateModel :: Rotation -> Model -> Model
186rotateModel (Rotation ax ay az order) model = 186rotateModel (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 @@
1module 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)
14where
15
16import Spear.Game
17import Spear.Sound.State
18
19import Control.Monad.IO.Class
20import Data.Set as Set
21import Data.StateVar (($=))
22import qualified Sound.ALUT as AL
23
24
25data LoopMode
26 = SingleShot
27 | Loop
28 deriving (Show)
29
30
31-- | Create the sound context and run an IO action within the context.
32withSoundContext :: IO a -> IO a
33withSoundContext action = AL.withProgNameAndArgs AL.runALUT $
34 \name args -> action
35
36-- | Initialize the sound system.
37initSoundSystem :: Game () SoundState
38initSoundSystem = return newSoundState
39
40-- | Destroy the sound system.
41destroySoundSystem :: Game SoundState ()
42destroySoundSystem = 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.
51loadAudioFile :: FilePath -> Game SoundState SoundBuffer
52loadAudioFile 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.
62deleteSoundBuffer :: SoundBuffer -> Game SoundState ()
63deleteSoundBuffer 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.
73makeSoundSource :: Game SoundState SoundSource
74makeSoundSource = 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.
84deleteSoundSource :: SoundSource -> Game SoundState ()
85deleteSoundSource 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.
92setSoundSourceBuffer :: MonadIO io => SoundSource -> SoundBuffer -> io ()
93setSoundSourceBuffer source buffer =
94 AL.buffer (alSource source) $= Just (alBuffer buffer)
95
96-- | Set the sound's loop mode.
97setSoundLoopMode :: MonadIO io => SoundSource -> LoopMode -> io ()
98setSoundLoopMode 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.
103playSounds :: MonadIO io => [SoundSource] -> io ()
104playSounds = 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 @@
1module Spear.Sound.State where
2
3import Spear.Game
4
5import Data.Hashable
6import Data.Set as Set
7import qualified Sound.ALUT as AL
8
9
10-- | A sound buffer.
11data SoundBuffer = SoundBuffer
12 { alBuffer :: AL.Buffer
13 , bufferResource :: ReleaseKey
14 }
15
16-- | A sound source.
17data SoundSource = SoundSource
18 { alSource :: AL.Source
19 , sourceResource :: ReleaseKey
20 }
21
22-- | Sound state.
23data SoundState = SoundState
24 { buffers :: Set SoundBuffer
25 , sources :: Set SoundSource
26 }
27
28
29instance ResourceClass SoundBuffer where
30 getResource = bufferResource
31
32instance ResourceClass SoundSource where
33 getResource = sourceResource
34
35instance Eq SoundBuffer where
36 a == b = alBuffer a == alBuffer b
37
38instance Eq SoundSource where
39 a == b = alSource a == alSource b
40
41instance Ord SoundBuffer where
42 a < b = alBuffer a < alBuffer b
43 a <= b = alBuffer a <= alBuffer b
44
45instance Ord SoundSource where
46 a < b = alSource a < alSource b
47 a <= b = alSource a <= alSource b
48
49
50newSoundState :: SoundState
51newSoundState = 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
36type Dt = Float 37type Dt = Float
37 38
38-- | A step function. 39-- | A step function.
39newtype Step state events input a = Step 40newtype 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
43instance Functor (Step s e a) where 44instance 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
48instance Semigroup (Step s e a a) where 49instance Semigroup (Step state events input input) where
49 (<>) = (.>) 50 (<>) = (.>)
50 51
51instance Monoid (Step s e a a) where 52instance Monoid (Step state events input input) where
52 mempty = sid 53 mempty = sid
53 54
55instance 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
62instance 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.
55step :: (Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b)) -> Step s e a b 69step :: (Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b)) -> Step s e a b
56step = Step 70step = Step
@@ -63,6 +77,10 @@ sid = Step $ \_ _ _ _ a -> (a, sid)
63spure :: (a -> b) -> Step s e a b 77spure :: (a -> b) -> Step s e a b
64spure f = Step $ \_ _ _ _ x -> (f x, spure f) 78spure f = Step $ \_ _ _ _ x -> (f x, spure f)
65 79
80-- | Construct a step that returns a constant value.
81sreturn :: b -> Step s e a b
82sreturn 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.
67sfst :: Step s e (a, b) a 85sfst :: Step s e (a, b) a
68sfst = spure fst 86sfst = 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.
77sfold :: Step s (Maybe e) a a -> Step s [e] a a 95sfold :: Step s (Maybe e) a a -> Step s [e] a a
78sfold s = Step $ \elapsed dt g es a -> 96sfold 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
87sfold' ::
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)
95sfold' 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.
122swhen :: Eq e => e -> Step s () a a -> Step s (Maybe e) a a
123swhen 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'.
123switch :: 137switch ::
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
130switch flag1 s1 flag2 s2 = switch' s1 flag1 s1 flag2 s2 144switch = switch' sid
131 145
132switch' ::
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
140switch' cur flag1 s1 flag2 s2 = Step $ \elapsed dt g e a -> 146switch' 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'.
154multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a 164multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a
155multiSwitch xs = multiSwitch' Nothing sid (Map.fromList xs) 165multiSwitch 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)
19where 20where
@@ -24,6 +25,7 @@ import Foreign.Marshal.Alloc (alloca)
24import Foreign.Ptr 25import Foreign.Ptr
25import Foreign.Storable 26import Foreign.Storable
26import Control.Monad 27import Control.Monad
28import Control.Monad.IO.Class
27import System.IO.Unsafe 29import 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"
115foreign import ccall safe "timer.h time_point_to_ns" 117foreign 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
120foreign import ccall safe "timer.h time_add"
121 c_time_add :: Ptr TimePoint -> TimeDelta -> Ptr TimePoint -> IO ()
122
118foreign import ccall "timer.h time_sleep" 123foreign 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.
133newTimer :: IO Timer 138newTimer :: MonadIO io => io Timer
134newTimer = alloca $ \ptr -> do 139newTimer = 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.
139start :: Timer -> IO () 144start :: MonadIO io => Timer -> io ()
140start = withTimer c_timer_start 145start = liftIO . withTimer c_timer_start
141 146
142-- | Update the timer. 147-- | Update the timer.
143tick :: Timer -> IO Timer 148tick :: MonadIO io => Timer -> io Timer
144tick = withTimer' c_timer_tick 149tick = liftIO . withTimer' c_timer_tick
145 150
146-- | Get the current time. 151-- | Get the current time.
147now :: IO TimePoint 152now :: MonadIO io => io TimePoint
148now = alloca $ \ptr -> do 153now = 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.
181timeAdd :: TimePoint -> TimeDelta -> TimePoint
182timeAdd 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.
176sleep :: TimeDelta -> IO () 190sleep :: MonadIO io => TimeDelta -> io ()
177sleep = c_time_sleep 191sleep = 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
90void 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
90void time_sleep(time_delta dt) { 99void 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.
54uint64_t time_point_to_ns(time_point*); 54uint64_t time_point_to_ns(time_point*);
55 55
56/// Add a time delta to a timestamp.
57void 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.
57void time_sleep(time_delta dt); 60void 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
35import Control.Concurrent.MVar 34import Control.Concurrent.MVar
36import Control.Exception 35import Control.Exception
37import Control.Monad (foldM, unless, void, when) 36import Control.Monad (foldM, unless, void, when)
37import Control.Monad.IO.Class
38import Data.Functor ((<&>)) 38import Data.Functor ((<&>))
39import Data.Maybe (fromJust, fromMaybe, isJust) 39import Data.Maybe (fromJust, fromMaybe, isJust)
40import qualified Graphics.UI.GLFW as GLFW 40import qualified Graphics.UI.GLFW as GLFW
@@ -52,12 +52,6 @@ type Dimensions = (Width, Height)
52 52
53type WindowTitle = String 53type WindowTitle = String
54 54
55-- | Game initialiser.
56type Init s = Window -> Game () s
57
58-- | Game finalizer.
59type End s = Game s ()
60
61-- | Window exception. 55-- | Window exception.
62newtype WindowException = WindowException String deriving (Show) 56newtype WindowException = WindowException String deriving (Show)
63 57
@@ -83,32 +77,19 @@ data Window = Window
83 } 77 }
84 78
85 79
86withWindow :: 80withWindow :: MonadIO io => Dimensions -> WindowTitle -> (Window -> IO a) -> io a
87 Dimensions -> 81withWindow 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
93withWindow 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") 91setup :: MonadIO io => Dimensions -> WindowTitle -> io Window
98 setup dim windowTitle 92setup (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
107setup ::
108 Dimensions ->
109 Maybe WindowTitle ->
110 IO Window
111setup (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.
140pollInputEvents :: Window -> IO [InputEvent] 122pollInputEvents :: MonadIO io => Window -> io [InputEvent]
141pollInputEvents window = do 123pollInputEvents 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.
146pollWindowEvents :: Window -> IO [WindowEvent] 128pollWindowEvents :: MonadIO io => Window -> io [WindowEvent]
147pollWindowEvents window = do 129pollWindowEvents 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.
159shouldWindowClose :: Window -> IO Bool 141shouldWindowClose :: MonadIO io => Window -> io Bool
160shouldWindowClose = getRequest . closeRequestMVar 142shouldWindowClose = liftIO . getRequest . closeRequestMVar
161 143
162-- | Swaps buffers. 144-- | Swaps buffers.
163swapBuffers :: Window -> IO () 145swapBuffers :: MonadIO io => Window -> io ()
164swapBuffers = GLFW.swapBuffers . glfwWindow 146swapBuffers = liftIO . GLFW.swapBuffers . glfwWindow
165 147
166-- | Get the window's size. 148-- | Get the window's size.
167getWindowSize :: Window -> IO (Width, Height) 149getWindowSize :: MonadIO io => Window -> io (Width, Height)
168getWindowSize = GLFW.getWindowSize . glfwWindow 150getWindowSize = liftIO . GLFW.getWindowSize . glfwWindow
169 151
170getRequest :: MVar Bool -> IO Bool 152getRequest :: MVar Bool -> IO Bool
171getRequest mvar = 153getRequest 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.
180onResize :: MVar [WindowEvent] -> GLFW.WindowSizeCallback 162onResize :: MVar [WindowEvent] -> GLFW.WindowSizeCallback
181onResize windowEvents window w h = putMVar windowEvents [ResizeEvent w h] 163onResize windowEvents window w h = modifyMVar_ windowEvents (return <$> const [ResizeEvent w h])
182 164
183onKey :: MVar [InputEvent] -> GLFW.KeyCallback 165onKey :: MVar [InputEvent] -> GLFW.KeyCallback
184onKey events window key _ GLFW.KeyState'Pressed _ = addEvent events $ KeyDown (fromGLFWkey key) 166onKey events window key _ GLFW.KeyState'Pressed _ = addEvent events $ KeyDown (fromGLFWkey key)
185onKey events window key _ GLFW.KeyState'Released _ = addEvent events $ KeyUp (fromGLFWkey key) 167onKey events window key _ GLFW.KeyState'Released _ = addEvent events $ KeyUp (fromGLFWkey key)
186onKey events window key _ GLFW.KeyState'Repeating _ = return () 168onKey events window key _ GLFW.KeyState'Repeating _ = return ()
187 169
188onChar :: MVar [InputEvent] -> GLFW.CharCallback
189onChar events window char = addEvent events $ KeyDown . fromGLFWkey . read $ [char]
190
191onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback 170onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback
192onMouseButton events window button GLFW.MouseButtonState'Pressed _ = addEvent events $ MouseDown (fromGLFWbutton button) 171onMouseButton events window button GLFW.MouseButtonState'Pressed _ = addEvent events $ MouseDown (fromGLFWbutton button)
193onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp (fromGLFWbutton button) 172onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp (fromGLFWbutton button)
194 173
195onMouseMove :: MVar MousePos -> MVar [InputEvent] -> GLFW.CursorPosCallback 174onMouseMove :: MVar MousePos -> MVar [InputEvent] -> GLFW.CursorPosCallback
196onMouseMove oldPos events window x y = do 175onMouseMove 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.
217whenKeyDown :: GLFW.Window -> Key -> Game s a -> Game s () 196whenKeyDown :: GLFW.Window -> Key -> Game s () -> Game s ()
218whenKeyDown = whenKeyInState (== GLFW.KeyState'Pressed) 197whenKeyDown = 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.
221whenKeyUp :: GLFW.Window -> Key -> Game s a -> Game s () 200whenKeyUp :: GLFW.Window -> Key -> Game s () -> Game s ()
222whenKeyUp = whenKeyInState (== GLFW.KeyState'Released) 201whenKeyUp = whenKeyInState GLFW.KeyState'Released
223 202
224whenKeyInState :: (GLFW.KeyState -> Bool) -> GLFW.Window -> Key -> Game s a -> Game s () 203whenKeyInState :: GLFW.KeyState -> GLFW.Window -> Key -> Game s () -> Game s ()
225whenKeyInState pred window key game = do 204whenKeyInState 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.
231processKeys :: GLFW.Window -> [(Key, a)] -> Game s [a] 210processKeys :: Window -> [(Key, a)] -> Game s [a]
232processKeys window = foldM f [] 211processKeys 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.
243processButtons :: GLFW.Window -> [(MouseButton, a)] -> Game s [a] 222processButtons :: Window -> [(MouseButton, a)] -> Game s [a]
244processButtons window = foldM f [] 223processButtons 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