aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Spear.cabal2
-rw-r--r--Spear/App/Application.hs38
-rw-r--r--Spear/App/Input.hs10
-rw-r--r--Spear/Assets/Image.hsc32
-rw-r--r--Spear/Assets/Model.hsc51
-rw-r--r--Spear/GLSL.hs195
-rw-r--r--Spear/Game.hs72
-rw-r--r--Spear/Math/Camera.hs4
-rw-r--r--Spear/Render/AnimatedModel.hs45
-rw-r--r--Spear/Render/Model.hsc9
-rw-r--r--Spear/Render/StaticModel.hs39
-rw-r--r--Spear/Scene/Loader.hs116
-rw-r--r--Spear/Setup.hs59
13 files changed, 190 insertions, 482 deletions
diff --git a/Spear.cabal b/Spear.cabal
index f7d0536..2f21fad 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -29,7 +29,7 @@ library
29 Spear.Render.Material Spear.Render.Model Spear.Render.Program 29 Spear.Render.Material Spear.Render.Model Spear.Render.Program
30 Spear.Render.StaticModel Spear.Scene.Graph Spear.Scene.Light 30 Spear.Render.StaticModel Spear.Scene.Graph Spear.Scene.Light
31 Spear.Scene.Loader Spear.Scene.Scene Spear.Scene.SceneResources 31 Spear.Scene.Loader Spear.Scene.Scene Spear.Scene.SceneResources
32 Spear.Setup Spear.Sys.Timer Spear.Sys.Store Spear.Sys.Store.ID 32 Spear.Sys.Timer Spear.Sys.Store Spear.Sys.Store.ID
33 Spear.Math.Quad Spear.Math.Ray 33 Spear.Math.Quad Spear.Math.Ray
34 Spear.Math.Segment Spear.Math.Utils Spear.Math.Spatial2 34 Spear.Math.Segment Spear.Math.Utils Spear.Math.Spatial2
35 Spear.Math.Spatial3 35 Spear.Math.Spatial3
diff --git a/Spear/App/Application.hs b/Spear/App/Application.hs
index 33400b8..82bfde0 100644
--- a/Spear/App/Application.hs
+++ b/Spear/App/Application.hs
@@ -8,12 +8,10 @@ module Spear.App.Application
8, Size(..) 8, Size(..)
9, DisplayBits(..) 9, DisplayBits(..)
10, WindowMode(..) 10, WindowMode(..)
11, Opened(..)
12, WindowSizeCallback 11, WindowSizeCallback
13 -- * Setup 12 -- * Setup
14, setup 13, setup
15, quit 14, quit
16, releaseWindow
17 -- * Main loop 15 -- * Main loop
18, run 16, run
19, runCapped 17, runCapped
@@ -23,9 +21,7 @@ module Spear.App.Application
23) 21)
24where 22where
25 23
26
27import Spear.Game 24import Spear.Game
28import Spear.Setup
29import Spear.Sys.Timer as Timer 25import Spear.Sys.Timer as Timer
30 26
31import Control.Applicative 27import Control.Applicative
@@ -37,25 +33,24 @@ import Graphics.Rendering.OpenGL as GL
37import System.Exit 33import System.Exit
38import Unsafe.Coerce 34import Unsafe.Coerce
39 35
40
41-- | Window dimensions. 36-- | Window dimensions.
42type Dimensions = (Int, Int) 37type Dimensions = (Int, Int)
43 38
44-- | A tuple specifying the desired OpenGL context, of the form (Major, Minor). 39-- | A tuple specifying the desired OpenGL context, of the form (Major, Minor).
45type Context = (Int, Int) 40type Context = (Int, Int)
46 41
47
48-- | Represents a window. 42-- | Represents a window.
49newtype SpearWindow = SpearWindow { rkey :: Resource } 43newtype SpearWindow = SpearWindow { rkey :: Resource }
50 44
45instance ResourceClass SpearWindow where
46 getResource = rkey
51 47
52-- | Set up an application 'SpearWindow'. 48-- | Set up an application 'SpearWindow'.
53setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context 49setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context
54 -> WindowSizeCallback -> Setup SpearWindow 50 -> WindowSizeCallback -> Game s SpearWindow
55setup (w, h) displayBits windowMode (major, minor) onResize' = do 51setup (w, h) displayBits windowMode (major, minor) onResize' = do
56 glfwInit 52 glfwInit
57 53 gameIO $ do
58 setupIO $ do
59 openWindowHint OpenGLVersionMajor major 54 openWindowHint OpenGLVersionMajor major
60 openWindowHint OpenGLVersionMinor minor 55 openWindowHint OpenGLVersionMinor minor
61 disableSpecial AutoPollEvent 56 disableSpecial AutoPollEvent
@@ -73,45 +68,35 @@ setup (w, h) displayBits windowMode (major, minor) onResize' = do
73 rkey <- register quit 68 rkey <- register quit
74 return $ SpearWindow rkey 69 return $ SpearWindow rkey
75 70
76 71glfwInit :: Game s ()
77-- | Release the given 'SpearWindow'.
78releaseWindow :: SpearWindow -> Setup ()
79releaseWindow = release . rkey
80
81
82glfwInit :: Setup ()
83glfwInit = do 72glfwInit = do
84 result <- setupIO GLFW.initialize 73 result <- gameIO GLFW.initialize
85 case result of 74 case result of
86 False -> setupError "GLFW.initialize failed" 75 False -> gameError "GLFW.initialize failed"
87 True -> return () 76 True -> return ()
88 77
89
90-- | Close the application's window. 78-- | Close the application's window.
91quit :: IO () 79quit :: IO ()
92quit = GLFW.terminate 80quit = GLFW.terminate
93 81
94
95-- | Return true if the application should continue running, false otherwise. 82-- | Return true if the application should continue running, false otherwise.
96type Update s = Float -> Game s (Bool) 83type Update s = Float -> Game s (Bool)
97 84
98
99-- | Run the application's main loop. 85-- | Run the application's main loop.
100run :: Update s -> Game s () 86run :: Update s -> Game s ()
101run update = do 87run update = do
102 timer <- gameIO $ start newTimer 88 timer <- gameIO $ start newTimer
103 run' timer update 89 run' timer update
104 90
105
106run' :: Timer -> Update s -> Game s () 91run' :: Timer -> Update s -> Game s ()
107run' timer update = do 92run' timer update = do
108 timer' <- gameIO $ tick timer 93 timer' <- gameIO $ tick timer
109 continue <- update $ getDelta timer' 94 continue <- update $ getDelta timer'
110 case continue of 95 opened <- gameIO $ getParam Opened
96 case continue && opened of
111 False -> return () 97 False -> return ()
112 True -> run' timer' update 98 True -> run' timer' update
113 99
114
115-- | Run the application's main loop, with a limit on the frame rate. 100-- | Run the application's main loop, with a limit on the frame rate.
116runCapped :: Int -> Update s -> Game s () 101runCapped :: Int -> Update s -> Game s ()
117runCapped maxFPS update = do 102runCapped maxFPS update = do
@@ -119,12 +104,12 @@ runCapped maxFPS update = do
119 timer <- gameIO $ start newTimer 104 timer <- gameIO $ start newTimer
120 runCapped' ddt timer update 105 runCapped' ddt timer update
121 106
122
123runCapped' :: Float -> Timer -> Update s -> Game s () 107runCapped' :: Float -> Timer -> Update s -> Game s ()
124runCapped' ddt timer update = do 108runCapped' ddt timer update = do
125 timer' <- gameIO $ tick timer 109 timer' <- gameIO $ tick timer
126 continue <- update $ getDelta timer' 110 continue <- update $ getDelta timer'
127 case continue of 111 opened <- gameIO $ getParam Opened
112 case continue && opened of
128 False -> return () 113 False -> return ()
129 True -> do 114 True -> do
130 t'' <- gameIO $ tick timer' 115 t'' <- gameIO $ tick timer'
@@ -132,7 +117,6 @@ runCapped' ddt timer update = do
132 when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) 117 when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt)
133 runCapped' ddt timer' update 118 runCapped' ddt timer' update
134 119
135
136onResize :: WindowSizeCallback -> Size -> IO () 120onResize :: WindowSizeCallback -> Size -> IO ()
137onResize callback s@(Size w h) = do 121onResize callback s@(Size w h) = do
138 GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) 122 GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h))
diff --git a/Spear/App/Input.hs b/Spear/App/Input.hs
index 44b94a9..0207147 100644
--- a/Spear/App/Input.hs
+++ b/Spear/App/Input.hs
@@ -14,6 +14,7 @@ module Spear.App.Input
14, getKeyboard 14, getKeyboard
15, newMouse 15, newMouse
16, getMouse 16, getMouse
17, newInput
17, getInput 18, getInput
18, pollInput 19, pollInput
19 -- * Toggled input 20 -- * Toggled input
@@ -68,7 +69,7 @@ data Input = Input
68 } 69 }
69 70
70 71
71-- | Return a dummy keyboard. 72-- | Return a new dummy keyboard.
72-- 73--
73-- This function should be called to get an initial keyboard. 74-- This function should be called to get an initial keyboard.
74-- 75--
@@ -90,7 +91,7 @@ getKeyboard =
90 >>= return . keyboard' 91 >>= return . keyboard'
91 92
92 93
93-- | Return a dummy mouse. 94-- | Return a new dummy mouse.
94-- 95--
95-- This function should be called to get an initial mouse. 96-- This function should be called to get an initial mouse.
96-- 97--
@@ -133,6 +134,11 @@ getMouse oldMouse =
133 } 134 }
134 135
135 136
137-- | Return a new dummy input.
138newInput :: Input
139newInput = Input newKeyboard newMouse
140
141
136-- | Get input devices. 142-- | Get input devices.
137getInput :: Input -> IO Input 143getInput :: Input -> IO Input
138getInput (Input _ oldMouse) = do 144getInput (Input _ oldMouse) = do
diff --git a/Spear/Assets/Image.hsc b/Spear/Assets/Image.hsc
index 2b5c482..0efbca6 100644
--- a/Spear/Assets/Image.hsc
+++ b/Spear/Assets/Image.hsc
@@ -6,7 +6,6 @@ module Spear.Assets.Image
6 Image 6 Image
7 -- * Loading and unloading 7 -- * Loading and unloading
8, loadImage 8, loadImage
9, releaseImage
10 -- * Accessors 9 -- * Accessors
11, width 10, width
12, height 11, height
@@ -15,8 +14,7 @@ module Spear.Assets.Image
15) 14)
16where 15where
17 16
18 17import Spear.Game
19import Spear.Setup
20import Foreign.Ptr 18import Foreign.Ptr
21import Foreign.Storable 19import Foreign.Storable
22import Foreign.C.Types 20import Foreign.C.Types
@@ -26,11 +24,9 @@ import Foreign.Marshal.Alloc (alloca)
26import Data.List (splitAt, elemIndex) 24import Data.List (splitAt, elemIndex)
27import Data.Char (toLower) 25import Data.Char (toLower)
28 26
29
30#include "Image.h" 27#include "Image.h"
31#include "BMP/BMP_load.h" 28#include "BMP/BMP_load.h"
32 29
33
34data ImageErrorCode 30data ImageErrorCode
35 = ImageSuccess 31 = ImageSuccess
36 | ImageReadError 32 | ImageReadError
@@ -40,7 +36,6 @@ data ImageErrorCode
40 | ImageNoSuitableLoader 36 | ImageNoSuitableLoader
41 deriving (Eq, Enum, Show) 37 deriving (Eq, Enum, Show)
42 38
43
44data CImage = CImage 39data CImage = CImage
45 { cwidth :: CInt 40 { cwidth :: CInt
46 , cheight :: CInt 41 , cheight :: CInt
@@ -48,7 +43,6 @@ data CImage = CImage
48 , cpixels :: Ptr CUChar 43 , cpixels :: Ptr CUChar
49 } 44 }
50 45
51
52instance Storable CImage where 46instance Storable CImage where
53 sizeOf _ = #{size Image} 47 sizeOf _ = #{size Image}
54 alignment _ = alignment (undefined :: CInt) 48 alignment _ = alignment (undefined :: CInt)
@@ -66,36 +60,34 @@ instance Storable CImage where
66 #{poke Image, bpp} ptr bpp 60 #{poke Image, bpp} ptr bpp
67 #{poke Image, pixels} ptr pixels 61 #{poke Image, pixels} ptr pixels
68 62
69
70-- | Represents an image 'Resource'. 63-- | Represents an image 'Resource'.
71data Image = Image 64data Image = Image
72 { imageData :: CImage 65 { imageData :: CImage
73 , rkey :: Resource 66 , rkey :: Resource
74 } 67 }
75 68
69instance ResourceClass Image where
70 getResource = rkey
76 71
77foreign import ccall "Image.h image_free" 72foreign import ccall "Image.h image_free"
78 image_free :: Ptr CImage -> IO () 73 image_free :: Ptr CImage -> IO ()
79 74
80
81foreign import ccall "BMP_load.h BMP_load" 75foreign import ccall "BMP_load.h BMP_load"
82 bmp_load' :: Ptr CChar -> Ptr CImage -> IO Int 76 bmp_load' :: Ptr CChar -> Ptr CImage -> IO Int
83 77
84
85bmp_load :: Ptr CChar -> Ptr CImage -> IO ImageErrorCode 78bmp_load :: Ptr CChar -> Ptr CImage -> IO ImageErrorCode
86bmp_load file image = bmp_load' file image >>= \code -> return . toEnum $ code 79bmp_load file image = bmp_load' file image >>= \code -> return . toEnum $ code
87 80
88
89-- | Load the image specified by the given file. 81-- | Load the image specified by the given file.
90loadImage :: FilePath -> Setup Image 82loadImage :: FilePath -> Game s Image
91loadImage file = do 83loadImage file = do
92 dotPos <- case elemIndex '.' file of 84 dotPos <- case elemIndex '.' file of
93 Nothing -> setupError $ "file name has no extension: " ++ file 85 Nothing -> gameError $ "file name has no extension: " ++ file
94 Just p -> return p 86 Just p -> return p
95 87
96 let ext = map toLower . tail . snd $ splitAt dotPos file 88 let ext = map toLower . tail . snd $ splitAt dotPos file
97 89
98 result <- setupIO . alloca $ \ptr -> do 90 result <- gameIO . alloca $ \ptr -> do
99 status <- withCString file $ \fileCstr -> do 91 status <- withCString file $ \fileCstr -> do
100 case ext of 92 case ext of
101 "bmp" -> bmp_load fileCstr ptr 93 "bmp" -> bmp_load fileCstr ptr
@@ -111,34 +103,24 @@ loadImage file = do
111 103
112 case result of 104 case result of
113 Right image -> register (freeImage image) >>= return . Image image 105 Right image -> register (freeImage image) >>= return . Image image
114 Left err -> setupError $ "loadImage: " ++ err 106 Left err -> gameError $ "loadImage: " ++ err
115
116
117-- | Release the given 'Image'.
118releaseImage :: Image -> Setup ()
119releaseImage = release . rkey
120
121 107
122-- | Free the given 'CImage'. 108-- | Free the given 'CImage'.
123freeImage :: CImage -> IO () 109freeImage :: CImage -> IO ()
124freeImage image = Foreign.with image image_free 110freeImage image = Foreign.with image image_free
125 111
126
127-- | Return the given image's width. 112-- | Return the given image's width.
128width :: Image -> Int 113width :: Image -> Int
129width = fromIntegral . cwidth . imageData 114width = fromIntegral . cwidth . imageData
130 115
131
132-- | Return the given image's height. 116-- | Return the given image's height.
133height :: Image -> Int 117height :: Image -> Int
134height = fromIntegral . cheight . imageData 118height = fromIntegral . cheight . imageData
135 119
136
137-- | Return the given image's bits per pixel. 120-- | Return the given image's bits per pixel.
138bpp :: Image -> Int 121bpp :: Image -> Int
139bpp = fromIntegral . cbpp . imageData 122bpp = fromIntegral . cbpp . imageData
140 123
141
142-- | Return the given image's pixels. 124-- | Return the given image's pixels.
143pixels :: Image -> Ptr CUChar 125pixels :: Image -> Ptr CUChar
144pixels = cpixels . imageData 126pixels = cpixels . imageData
diff --git a/Spear/Assets/Model.hsc b/Spear/Assets/Model.hsc
index 6c4cfe5..5e6e756 100644
--- a/Spear/Assets/Model.hsc
+++ b/Spear/Assets/Model.hsc
@@ -27,9 +27,7 @@ module Spear.Assets.Model
27) 27)
28where 28where
29 29
30 30import Spear.Game
31import Spear.Setup
32
33 31
34import qualified Data.ByteString.Char8 as B 32import qualified Data.ByteString.Char8 as B
35import Data.Char (toLower) 33import Data.Char (toLower)
@@ -45,12 +43,10 @@ import Foreign.Marshal.Alloc (alloca, allocaBytes)
45import Foreign.Marshal.Array (allocaArray, copyArray, peekArray) 43import Foreign.Marshal.Array (allocaArray, copyArray, peekArray)
46import Unsafe.Coerce (unsafeCoerce) 44import Unsafe.Coerce (unsafeCoerce)
47 45
48
49#include "Model.h" 46#include "Model.h"
50#include "MD2/MD2_load.h" 47#include "MD2/MD2_load.h"
51#include "OBJ/OBJ_load.h" 48#include "OBJ/OBJ_load.h"
52 49
53
54data ModelErrorCode 50data ModelErrorCode
55 = ModelSuccess 51 = ModelSuccess
56 | ModelReadError 52 | ModelReadError
@@ -60,15 +56,12 @@ data ModelErrorCode
60 | ModelNoSuitableLoader 56 | ModelNoSuitableLoader
61 deriving (Eq, Enum, Show) 57 deriving (Eq, Enum, Show)
62 58
63
64sizeFloat = #{size float} 59sizeFloat = #{size float}
65sizePtr = #{size int*} 60sizePtr = #{size int*}
66 61
67
68-- | A 2D vector. 62-- | A 2D vector.
69data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float 63data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float
70 64
71
72instance Storable Vec2 where 65instance Storable Vec2 where
73 sizeOf _ = 2*sizeFloat 66 sizeOf _ = 2*sizeFloat
74 alignment _ = alignment (undefined :: CFloat) 67 alignment _ = alignment (undefined :: CFloat)
@@ -82,11 +75,9 @@ instance Storable Vec2 where
82 pokeByteOff ptr 0 f0 75 pokeByteOff ptr 0 f0
83 pokeByteOff ptr sizeFloat f1 76 pokeByteOff ptr sizeFloat f1
84 77
85
86-- | A 3D vector. 78-- | A 3D vector.
87data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float 79data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float
88 80
89
90instance Storable Vec3 where 81instance Storable Vec3 where
91 sizeOf _ = 3*sizeFloat 82 sizeOf _ = 3*sizeFloat
92 alignment _ = alignment (undefined :: CFloat) 83 alignment _ = alignment (undefined :: CFloat)
@@ -102,11 +93,9 @@ instance Storable Vec3 where
102 pokeByteOff ptr sizeFloat f1 93 pokeByteOff ptr sizeFloat f1
103 pokeByteOff ptr (2*sizeFloat) f2 94 pokeByteOff ptr (2*sizeFloat) f2
104 95
105
106-- | A 2D texture coordinate. 96-- | A 2D texture coordinate.
107data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float 97data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float
108 98
109
110instance Storable TexCoord where 99instance Storable TexCoord where
111 sizeOf _ = 2*sizeFloat 100 sizeOf _ = 2*sizeFloat
112 alignment _ = alignment (undefined :: CFloat) 101 alignment _ = alignment (undefined :: CFloat)
@@ -120,7 +109,6 @@ instance Storable TexCoord where
120 pokeByteOff ptr 0 f0 109 pokeByteOff ptr 0 f0
121 pokeByteOff ptr sizeFloat f1 110 pokeByteOff ptr sizeFloat f1
122 111
123
124-- | A raw triangle holding vertex/normal and texture indices. 112-- | A raw triangle holding vertex/normal and texture indices.
125data CTriangle = CTriangle 113data CTriangle = CTriangle
126 { vertexIndex0 :: {-# UNPACK #-} !CUShort 114 { vertexIndex0 :: {-# UNPACK #-} !CUShort
@@ -131,7 +119,6 @@ data CTriangle = CTriangle
131 , textureIndex3 :: {-# UNPACK #-} !CUShort 119 , textureIndex3 :: {-# UNPACK #-} !CUShort
132 } 120 }
133 121
134
135instance Storable CTriangle where 122instance Storable CTriangle where
136 sizeOf _ = #{size triangle} 123 sizeOf _ = #{size triangle}
137 alignment _ = alignment (undefined :: CUShort) 124 alignment _ = alignment (undefined :: CUShort)
@@ -156,11 +143,9 @@ instance Storable CTriangle where
156 #{poke triangle, textureIndices[1]} ptr t1 143 #{poke triangle, textureIndices[1]} ptr t1
157 #{poke triangle, textureIndices[2]} ptr t2 144 #{poke triangle, textureIndices[2]} ptr t2
158 145
159
160-- | A 3D axis-aligned bounding box. 146-- | A 3D axis-aligned bounding box.
161data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3 147data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3
162 148
163
164instance Storable Box where 149instance Storable Box where
165 sizeOf _ = 6 * sizeFloat 150 sizeOf _ = 6 * sizeFloat
166 alignment _ = alignment (undefined :: CFloat) 151 alignment _ = alignment (undefined :: CFloat)
@@ -182,11 +167,9 @@ instance Storable Box where
182 pokeByteOff ptr (4*sizeFloat) ymax 167 pokeByteOff ptr (4*sizeFloat) ymax
183 pokeByteOff ptr (5*sizeFloat) zmax 168 pokeByteOff ptr (5*sizeFloat) zmax
184 169
185
186-- | A model skin. 170-- | A model skin.
187newtype Skin = Skin { skinName :: B.ByteString } 171newtype Skin = Skin { skinName :: B.ByteString }
188 172
189
190instance Storable Skin where 173instance Storable Skin where
191 sizeOf (Skin s) = 64 174 sizeOf (Skin s) = 64
192 alignment _ = 1 175 alignment _ = 1
@@ -198,7 +181,6 @@ instance Storable Skin where
198 poke ptr (Skin s) = do 181 poke ptr (Skin s) = do
199 B.useAsCStringLen s $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len 182 B.useAsCStringLen s $ \(sptr, len) -> copyArray (unsafeCoerce ptr) sptr len
200 183
201
202-- | A model animation. 184-- | A model animation.
203-- 185--
204-- See also: 'animation', 'animationByName', 'numAnimations'. 186-- See also: 'animation', 'animationByName', 'numAnimations'.
@@ -208,7 +190,6 @@ data Animation = Animation
208 , end :: Int 190 , end :: Int
209 } 191 }
210 192
211
212instance Storable Animation where 193instance Storable Animation where
213 sizeOf _ = #{size animation} 194 sizeOf _ = #{size animation}
214 alignment _ = alignment (undefined :: CUInt) 195 alignment _ = alignment (undefined :: CUInt)
@@ -224,7 +205,6 @@ instance Storable Animation where
224 #{poke animation, start} ptr start 205 #{poke animation, start} ptr start
225 #{poke animation, end} ptr end 206 #{poke animation, end} ptr end
226 207
227
228-- | A 3D model. 208-- | A 3D model.
229data Model = Model 209data Model = Model
230 { vertices :: S.Vector Vec3 -- ^ Array of 'numFrames' * 'numVerts' vertices. 210 { vertices :: S.Vector Vec3 -- ^ Array of 'numFrames' * 'numVerts' vertices.
@@ -241,7 +221,6 @@ data Model = Model
241 , numAnimations :: Int -- ^ Number of animations. 221 , numAnimations :: Int -- ^ Number of animations.
242 } 222 }
243 223
244
245instance Storable Model where 224instance Storable Model where
246 sizeOf _ = #{size Model} 225 sizeOf _ = #{size Model}
247 alignment _ = alignment (undefined :: CUInt) 226 alignment _ = alignment (undefined :: CUInt)
@@ -291,7 +270,6 @@ instance Storable Model where
291 #{poke Model, numSkins} ptr numSkins 270 #{poke Model, numSkins} ptr numSkins
292 #{poke Model, numAnimations} ptr numAnimations 271 #{poke Model, numAnimations} ptr numAnimations
293 272
294
295-- | A model triangle. 273-- | A model triangle.
296-- 274--
297-- See also: 'triangles''. 275-- See also: 'triangles''.
@@ -307,7 +285,6 @@ data Triangle = Triangle
307 , t2 :: TexCoord 285 , t2 :: TexCoord
308 } 286 }
309 287
310
311instance Storable Triangle where 288instance Storable Triangle where
312 sizeOf _ = #{size model_triangle} 289 sizeOf _ = #{size model_triangle}
313 alignment _ = alignment (undefined :: Float) 290 alignment _ = alignment (undefined :: Float)
@@ -335,39 +312,33 @@ instance Storable Triangle where
335 #{poke model_triangle, t1} ptr t1 312 #{poke model_triangle, t1} ptr t1
336 #{poke model_triangle, t2} ptr t2 313 #{poke model_triangle, t2} ptr t2
337 314
338
339foreign import ccall "Model.h model_free" 315foreign import ccall "Model.h model_free"
340 model_free :: Ptr Model -> IO () 316 model_free :: Ptr Model -> IO ()
341 317
342
343foreign import ccall "MD2_load.h MD2_load" 318foreign import ccall "MD2_load.h MD2_load"
344 md2_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int 319 md2_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int
345 320
346
347foreign import ccall "OBJ_load.h OBJ_load" 321foreign import ccall "OBJ_load.h OBJ_load"
348 obj_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int 322 obj_load' :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO Int
349 323
350
351md2_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode 324md2_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode
352md2_load file clockwise leftHanded model = 325md2_load file clockwise leftHanded model =
353 md2_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code 326 md2_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code
354 327
355
356obj_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode 328obj_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode
357obj_load file clockwise leftHanded model = 329obj_load file clockwise leftHanded model =
358 obj_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code 330 obj_load' file clockwise leftHanded model >>= \code -> return . toEnum $ code
359 331
360
361-- | Load the model specified by the given file. 332-- | Load the model specified by the given file.
362loadModel :: FilePath -> Setup Model 333loadModel :: FilePath -> Game s Model
363loadModel file = do 334loadModel file = do
364 dotPos <- case elemIndex '.' file of 335 dotPos <- case elemIndex '.' file of
365 Nothing -> setupError $ "file name has no extension: " ++ file 336 Nothing -> gameError $ "file name has no extension: " ++ file
366 Just p -> return p 337 Just p -> return p
367 338
368 let ext = map toLower . tail . snd $ splitAt dotPos file 339 let ext = map toLower . tail . snd $ splitAt dotPos file
369 340
370 result <- setupIO . alloca $ \ptr -> do 341 result <- gameIO . alloca $ \ptr -> do
371 status <- withCString file $ \fileCstr -> do 342 status <- withCString file $ \fileCstr -> do
372 case ext of 343 case ext of
373 "md2" -> md2_load fileCstr 0 0 ptr 344 "md2" -> md2_load fileCstr 0 0 ptr
@@ -387,25 +358,21 @@ loadModel file = do
387 358
388 case result of 359 case result of
389 Right model -> return model 360 Right model -> return model
390 Left err -> setupError $ "loadModel: " ++ err 361 Left err -> gameError $ "loadModel: " ++ err
391
392 362
393-- | Return 'True' if the model is animated, 'False' otherwise. 363-- | Return 'True' if the model is animated, 'False' otherwise.
394animated :: Model -> Bool 364animated :: Model -> Bool
395animated = (>1) . numFrames 365animated = (>1) . numFrames
396 366
397
398-- | Return the model's ith animation. 367-- | Return the model's ith animation.
399animation :: Model -> Int -> Animation 368animation :: Model -> Int -> Animation
400animation model i = animations model S.! i 369animation model i = animations model S.! i
401 370
402
403-- | Return the animation specified by the given string. 371-- | Return the animation specified by the given string.
404animationByName :: Model -> String -> Maybe Animation 372animationByName :: Model -> String -> Maybe Animation
405animationByName model anim = 373animationByName model anim =
406 let anim' = B.pack anim in S.find ((==) anim' . name) $ animations model 374 let anim' = B.pack anim in S.find ((==) anim' . name) $ animations model
407 375
408
409-- | Return a copy of the model's triangles. 376-- | Return a copy of the model's triangles.
410triangles' :: Model -> IO [Triangle] 377triangles' :: Model -> IO [Triangle]
411triangles' model = 378triangles' model =
@@ -416,11 +383,9 @@ triangles' model =
416 tris <- peekArray n arrayPtr 383 tris <- peekArray n arrayPtr
417 return tris 384 return tris
418 385
419
420foreign import ccall "Model.h model_copy_triangles" 386foreign import ccall "Model.h model_copy_triangles"
421 model_copy_triangles :: Ptr Model -> Ptr Triangle -> IO () 387 model_copy_triangles :: Ptr Model -> Ptr Triangle -> IO ()
422 388
423
424-- | Transform the model's vertices. 389-- | Transform the model's vertices.
425transformVerts :: Model -> (Vec3 -> Vec3) -> Model 390transformVerts :: Model -> (Vec3 -> Vec3) -> Model
426transformVerts model f = model { vertices = vertices' } 391transformVerts model f = model { vertices = vertices' }
@@ -429,7 +394,6 @@ transformVerts model f = model { vertices = vertices' }
429 vertices' = S.generate n f' 394 vertices' = S.generate n f'
430 f' i = f $ vertices model S.! i 395 f' i = f $ vertices model S.! i
431 396
432
433-- | Transform the model's normals. 397-- | Transform the model's normals.
434transformNormals :: Model -> (Vec3 -> Vec3) -> Model 398transformNormals :: Model -> (Vec3 -> Vec3) -> Model
435transformNormals model f = model { normals = normals' } 399transformNormals model f = model { normals = normals' }
@@ -438,7 +402,6 @@ transformNormals model f = model { normals = normals' }
438 normals' = S.generate n f' 402 normals' = S.generate n f'
439 f' i = f $ normals model S.! i 403 f' i = f $ normals model S.! i
440 404
441
442-- | Translate the model such that its lowest point has y = 0. 405-- | Translate the model such that its lowest point has y = 0.
443toGround :: Model -> IO Model 406toGround :: Model -> IO Model
444toGround model = 407toGround model =
@@ -447,11 +410,9 @@ toGround model =
447 in 410 in
448 with model' model_to_ground >> return model' 411 with model' model_to_ground >> return model'
449 412
450
451foreign import ccall "Model.h model_to_ground" 413foreign import ccall "Model.h model_to_ground"
452 model_to_ground :: Ptr Model -> IO () 414 model_to_ground :: Ptr Model -> IO ()
453 415
454
455-- | Get the model's 3D bounding boxes. 416-- | Get the model's 3D bounding boxes.
456modelBoxes :: Model -> IO (V.Vector Box) 417modelBoxes :: Model -> IO (V.Vector Box)
457modelBoxes model = 418modelBoxes model =
@@ -474,8 +435,6 @@ modelBoxes model =
474 box = Box pmin pmax 435 box = Box pmin pmax
475 peekBoxes ptr n (cur+1) (off + 6*sizeFloat) $ fmap (box:) l 436 peekBoxes ptr n (cur+1) (off + 6*sizeFloat) $ fmap (box:) l
476 fmap (V.fromList . reverse) getBoxes 437 fmap (V.fromList . reverse) getBoxes
477
478
479 438
480foreign import ccall "Model.h model_compute_boxes" 439foreign import ccall "Model.h model_compute_boxes"
481 model_compute_boxes :: Ptr Model -> Ptr Vec2 -> IO () 440 model_compute_boxes :: Ptr Model -> Ptr Vec2 -> IO ()
diff --git a/Spear/GLSL.hs b/Spear/GLSL.hs
index 2947515..8541e1f 100644
--- a/Spear/GLSL.hs
+++ b/Spear/GLSL.hs
@@ -6,7 +6,6 @@ module Spear.GLSL
6, ShaderType(..) 6, ShaderType(..)
7 -- ** Programs 7 -- ** Programs
8, newProgram 8, newProgram
9, releaseProgram
10, linkProgram 9, linkProgram
11, useProgram 10, useProgram
12, withGLSLProgram 11, withGLSLProgram
@@ -15,7 +14,6 @@ module Spear.GLSL
15, detachShader 14, detachShader
16, loadShader 15, loadShader
17, newShader 16, newShader
18, releaseShader
19 -- *** Source loading 17 -- *** Source loading
20, loadSource 18, loadSource
21, shaderSource 19, shaderSource
@@ -36,12 +34,10 @@ module Spear.GLSL
36 -- ** Helper functions 34 -- ** Helper functions
37, ($=) 35, ($=)
38, Data.StateVar.get 36, Data.StateVar.get
39
40 -- * VAOs 37 -- * VAOs
41, VAO 38, VAO
42 -- ** Creation and destruction 39 -- ** Creation and destruction
43, newVAO 40, newVAO
44, releaseVAO
45 -- ** Manipulation 41 -- ** Manipulation
46, bindVAO 42, bindVAO
47, enableVAOAttrib 43, enableVAOAttrib
@@ -49,20 +45,17 @@ module Spear.GLSL
49 -- ** Rendering 45 -- ** Rendering
50, drawArrays 46, drawArrays
51, drawElements 47, drawElements
52
53 -- * Buffers 48 -- * Buffers
54, GLBuffer 49, GLBuffer
55, TargetBuffer(..) 50, TargetBuffer(..)
56, BufferUsage(..) 51, BufferUsage(..)
57 -- ** Creation and destruction 52 -- ** Creation and destruction
58, newBuffer 53, newBuffer
59, releaseBuffer
60 -- ** Manipulation 54 -- ** Manipulation
61, bindBuffer 55, bindBuffer
62, bufferData 56, bufferData
63, bufferDatal 57, bufferDatal
64, withGLBuffer 58, withGLBuffer
65
66 -- * Textures 59 -- * Textures
67, Texture 60, Texture
68, SettableStateVar 61, SettableStateVar
@@ -70,14 +63,12 @@ module Spear.GLSL
70 -- ** Creation and destruction 63 -- ** Creation and destruction
71, newTexture 64, newTexture
72, loadTextureImage 65, loadTextureImage
73, releaseTexture
74 -- ** Manipulation 66 -- ** Manipulation
75, bindTexture 67, bindTexture
76, loadTextureData 68, loadTextureData
77, texParami 69, texParami
78, texParamf 70, texParamf
79, activeTexture 71, activeTexture
80
81 -- * Error Handling 72 -- * Error Handling
82, getGLError 73, getGLError
83, printGLError 74, printGLError
@@ -89,12 +80,11 @@ module Spear.GLSL
89) 80)
90where 81where
91 82
92
93import Spear.Assets.Image 83import Spear.Assets.Image
84import Spear.Game
94import Spear.Math.Matrix3 (Matrix3) 85import Spear.Math.Matrix3 (Matrix3)
95import Spear.Math.Matrix4 (Matrix4) 86import Spear.Math.Matrix4 (Matrix4)
96import Spear.Math.Vector 87import Spear.Math.Vector
97import Spear.Setup
98 88
99import Control.Monad 89import Control.Monad
100import Control.Monad.Trans.Class 90import Control.Monad.Trans.Class
@@ -114,47 +104,45 @@ import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory
114import System.IO (hPutStrLn, stderr) 104import System.IO (hPutStrLn, stderr)
115import Unsafe.Coerce 105import Unsafe.Coerce
116 106
117
118-- 107--
119-- MANAGEMENT 108-- MANAGEMENT
120-- 109--
121 110
122
123-- | A GLSL shader handle. 111-- | A GLSL shader handle.
124data GLSLShader = GLSLShader 112data GLSLShader = GLSLShader
125 { getShader :: GLuint 113 { getShader :: GLuint
126 , getShaderKey :: Resource 114 , getShaderKey :: Resource
127 } 115 }
128 116
117instance ResourceClass GLSLShader where
118 getResource = getShaderKey
129 119
130-- | A GLSL program handle. 120-- | A GLSL program handle.
131data GLSLProgram = GLSLProgram 121data GLSLProgram = GLSLProgram
132 { getProgram :: GLuint 122 { getProgram :: GLuint
133 , getProgramKey :: Resource 123 , getProgramKey :: Resource
134 } 124 }
135 125
136 126instance ResourceClass GLSLProgram where
127 getResource = getProgramKey
128
137-- | Supported shader types. 129-- | Supported shader types.
138data ShaderType = VertexShader | FragmentShader deriving (Eq, Show) 130data ShaderType = VertexShader | FragmentShader deriving (Eq, Show)
139 131
140
141toGLShader :: ShaderType -> GLenum 132toGLShader :: ShaderType -> GLenum
142toGLShader VertexShader = gl_VERTEX_SHADER 133toGLShader VertexShader = gl_VERTEX_SHADER
143toGLShader FragmentShader = gl_FRAGMENT_SHADER 134toGLShader FragmentShader = gl_FRAGMENT_SHADER
144 135
145
146-- | Apply the given function to the program's id. 136-- | Apply the given function to the program's id.
147withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a 137withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a
148withGLSLProgram prog f = f $ getProgram prog 138withGLSLProgram prog f = f $ getProgram prog
149 139
150
151-- | Get the location of the given uniform variable within the given program. 140-- | Get the location of the given uniform variable within the given program.
152uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint 141uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint
153uniformLocation prog var = makeGettableStateVar get 142uniformLocation prog var = makeGettableStateVar get
154 where 143 where
155 get = withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str) 144 get = withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str)
156 145
157
158-- | Get or set the location of the given variable to a fragment shader colour number. 146-- | Get or set the location of the given variable to a fragment shader colour number.
159fragLocation :: GLSLProgram -> String -> StateVar GLint 147fragLocation :: GLSLProgram -> String -> StateVar GLint
160fragLocation prog var = makeStateVar get set 148fragLocation prog var = makeStateVar get set
@@ -163,7 +151,6 @@ fragLocation prog var = makeStateVar get set
163 set idx = withCString var $ \str -> 151 set idx = withCString var $ \str ->
164 glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) 152 glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
165 153
166
167-- | Get or set the location of the given attribute within the given program. 154-- | Get or set the location of the given attribute within the given program.
168attribLocation :: GLSLProgram -> String -> StateVar GLint 155attribLocation :: GLSLProgram -> String -> StateVar GLint
169attribLocation prog var = makeStateVar get set 156attribLocation prog var = makeStateVar get set
@@ -172,26 +159,19 @@ attribLocation prog var = makeStateVar get set
172 set idx = withCString var $ \str -> 159 set idx = withCString var $ \str ->
173 glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) 160 glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
174 161
175
176-- | Create a new program. 162-- | Create a new program.
177newProgram :: [GLSLShader] -> Setup GLSLProgram 163newProgram :: [GLSLShader] -> Game s GLSLProgram
178newProgram shaders = do 164newProgram shaders = do
179 h <- setupIO glCreateProgram 165 h <- gameIO glCreateProgram
180 when (h == 0) $ setupError "glCreateProgram failed" 166 when (h == 0) $ gameError "glCreateProgram failed"
181 rkey <- register $ deleteProgram h 167 rkey <- register $ deleteProgram h
182 let program = GLSLProgram h rkey 168 let program = GLSLProgram h rkey
183 169
184 mapM_ (setupIO . attachShader program) shaders 170 mapM_ (gameIO . attachShader program) shaders
185 linkProgram program 171 linkProgram program
186 172
187 return program 173 return program
188 174
189
190-- | Release the program.
191releaseProgram :: GLSLProgram -> Setup ()
192releaseProgram = release . getProgramKey
193
194
195-- | Delete the program. 175-- | Delete the program.
196deleteProgram :: GLuint -> IO () 176deleteProgram :: GLuint -> IO ()
197--deleteProgram = glDeleteProgram 177--deleteProgram = glDeleteProgram
@@ -199,12 +179,11 @@ deleteProgram prog = do
199 putStrLn $ "Deleting shader program " ++ show prog 179 putStrLn $ "Deleting shader program " ++ show prog
200 glDeleteProgram prog 180 glDeleteProgram prog
201 181
202
203-- | Link the program. 182-- | Link the program.
204linkProgram :: GLSLProgram -> Setup () 183linkProgram :: GLSLProgram -> Game s ()
205linkProgram prog = do 184linkProgram prog = do
206 let h = getProgram prog 185 let h = getProgram prog
207 err <- setupIO $ do 186 err <- gameIO $ do
208 glLinkProgram h 187 glLinkProgram h
209 alloca $ \statptr -> do 188 alloca $ \statptr -> do
210 glGetProgramiv h gl_LINK_STATUS statptr 189 glGetProgramiv h gl_LINK_STATUS statptr
@@ -215,52 +194,41 @@ linkProgram prog = do
215 194
216 case length err of 195 case length err of
217 0 -> return () 196 0 -> return ()
218 _ -> setupError err 197 _ -> gameError err
219
220 198
221-- | Use the program. 199-- | Use the program.
222useProgram :: GLSLProgram -> IO () 200useProgram :: GLSLProgram -> IO ()
223useProgram prog = glUseProgram $ getProgram prog 201useProgram prog = glUseProgram $ getProgram prog
224 202
225
226-- | Attach the given shader to the given program. 203-- | Attach the given shader to the given program.
227attachShader :: GLSLProgram -> GLSLShader -> IO () 204attachShader :: GLSLProgram -> GLSLShader -> IO ()
228attachShader prog shader = glAttachShader (getProgram prog) (getShader shader) 205attachShader prog shader = glAttachShader (getProgram prog) (getShader shader)
229 206
230
231-- | Detach the given GLSL from the given program. 207-- | Detach the given GLSL from the given program.
232detachShader :: GLSLProgram -> GLSLShader -> IO () 208detachShader :: GLSLProgram -> GLSLShader -> IO ()
233detachShader prog shader = glDetachShader (getProgram prog) (getShader shader) 209detachShader prog shader = glDetachShader (getProgram prog) (getShader shader)
234 210
235
236-- | Load a shader from the file specified by the given string. 211-- | Load a shader from the file specified by the given string.
237-- 212--
238-- This function creates a new shader. To load source code into an existing shader, 213-- This function creates a new shader. To load source code into an existing shader,
239-- see 'loadSource', 'shaderSource' and 'readSource'. 214-- see 'loadSource', 'shaderSource' and 'readSource'.
240loadShader :: FilePath -> ShaderType -> Setup GLSLShader 215loadShader :: FilePath -> ShaderType -> Game s GLSLShader
241loadShader file shaderType = do 216loadShader file shaderType = do
242 shader <- newShader shaderType 217 shader <- newShader shaderType
243 loadSource file shader 218 loadSource file shader
244 compile file shader 219 compile file shader
245 return shader 220 return shader
246 221
247
248-- | Create a new shader. 222-- | Create a new shader.
249newShader :: ShaderType -> Setup GLSLShader 223newShader :: ShaderType -> Game s GLSLShader
250newShader shaderType = do 224newShader shaderType = do
251 h <- setupIO $ glCreateShader (toGLShader shaderType) 225 h <- gameIO $ glCreateShader (toGLShader shaderType)
252 case h of 226 case h of
253 0 -> setupError "glCreateShader failed" 227 0 -> gameError "glCreateShader failed"
254 _ -> do 228 _ -> do
255 rkey <- register $ deleteShader h 229 rkey <- register $ deleteShader h
256 return $ GLSLShader h rkey 230 return $ GLSLShader h rkey
257 231
258
259-- | Release the shader.
260releaseShader :: GLSLShader -> Setup ()
261releaseShader = release . getShaderKey
262
263
264-- | Free the shader. 232-- | Free the shader.
265deleteShader :: GLuint -> IO () 233deleteShader :: GLuint -> IO ()
266--deleteShader = glDeleteShader 234--deleteShader = glDeleteShader
@@ -268,36 +236,33 @@ deleteShader shader = do
268 putStrLn $ "Deleting shader " ++ show shader 236 putStrLn $ "Deleting shader " ++ show shader
269 glDeleteShader shader 237 glDeleteShader shader
270 238
271
272-- | Load a shader source from the file specified by the given string 239-- | Load a shader source from the file specified by the given string
273-- into the shader. 240-- into the shader.
274loadSource :: FilePath -> GLSLShader -> Setup () 241loadSource :: FilePath -> GLSLShader -> Game s ()
275loadSource file h = do 242loadSource file h = do
276 exists <- setupIO $ doesFileExist file 243 exists <- gameIO $ doesFileExist file
277 case exists of 244 case exists of
278 False -> setupError "the specified shader file does not exist" 245 False -> gameError "the specified shader file does not exist"
279 True -> setupIO $ do 246 True -> gameIO $ do
280 code <- readSource file 247 code <- readSource file
281 withCString code $ shaderSource h 248 withCString code $ shaderSource h
282 249
283
284-- | Load the given shader source into the shader. 250-- | Load the given shader source into the shader.
285shaderSource :: GLSLShader -> CString -> IO () 251shaderSource :: GLSLShader -> CString -> IO ()
286shaderSource shader str = 252shaderSource shader str =
287 let ptr = unsafeCoerce str 253 let ptr = unsafeCoerce str
288 in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr 254 in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr
289 255
290
291-- | Compile the shader. 256-- | Compile the shader.
292compile :: FilePath -> GLSLShader -> Setup () 257compile :: FilePath -> GLSLShader -> Game s ()
293compile file shader = do 258compile file shader = do
294 let h = getShader shader 259 let h = getShader shader
295 260
296 -- Compile 261 -- Compile
297 setupIO $ glCompileShader h 262 gameIO $ glCompileShader h
298 263
299 -- Verify status 264 -- Verify status
300 err <- setupIO $ alloca $ \statusPtr -> do 265 err <- gameIO $ alloca $ \statusPtr -> do
301 glGetShaderiv h gl_COMPILE_STATUS statusPtr 266 glGetShaderiv h gl_COMPILE_STATUS statusPtr
302 result <- peek statusPtr 267 result <- peek statusPtr
303 case result of 268 case result of
@@ -306,13 +271,11 @@ compile file shader = do
306 271
307 case length err of 272 case length err of
308 0 -> return () 273 0 -> return ()
309 _ -> setupError $ "Unable to compile shader " ++ file ++ ":\n" ++ err 274 _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err
310
311 275
312type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () 276type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO ()
313type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () 277type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()
314 278
315
316getStatus :: StatusCall -> LogCall -> GLuint -> IO String 279getStatus :: StatusCall -> LogCall -> GLuint -> IO String
317getStatus getStatus getLog h = do 280getStatus getStatus getLog h = do
318 alloca $ \lenPtr -> do 281 alloca $ \lenPtr -> do
@@ -322,14 +285,12 @@ getStatus getStatus getLog h = do
322 0 -> return "" 285 0 -> return ""
323 _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len) 286 _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len)
324 287
325
326getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String 288getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String
327getErrorString getLog h len str = do 289getErrorString getLog h len str = do
328 let ptr = unsafeCoerce str 290 let ptr = unsafeCoerce str
329 getLog h len nullPtr ptr 291 getLog h len nullPtr ptr
330 peekCString str 292 peekCString str
331 293
332
333-- | Load the shader source specified by the given file. 294-- | Load the shader source specified by the given file.
334-- 295--
335-- This function implements an #include mechanism, so the given file can 296-- This function implements an #include mechanism, so the given file can
@@ -337,7 +298,6 @@ getErrorString getLog h len str = do
337readSource :: FilePath -> IO String 298readSource :: FilePath -> IO String
338readSource = fmap B.unpack . readSource' 299readSource = fmap B.unpack . readSource'
339 300
340
341readSource' :: FilePath -> IO B.ByteString 301readSource' :: FilePath -> IO B.ByteString
342readSource' file = do 302readSource' file = do
343 let includeB = B.pack "#include" 303 let includeB = B.pack "#include"
@@ -365,14 +325,12 @@ readSource' file = do
365 325
366 return code 326 return code
367 327
368
369-- | Load a 2D vector. 328-- | Load a 2D vector.
370uniformVec2 :: GLint -> Vector2 -> IO () 329uniformVec2 :: GLint -> Vector2 -> IO ()
371uniformVec2 loc v = glUniform2f loc x' y' 330uniformVec2 loc v = glUniform2f loc x' y'
372 where x' = unsafeCoerce $ x v 331 where x' = unsafeCoerce $ x v
373 y' = unsafeCoerce $ y v 332 y' = unsafeCoerce $ y v
374 333
375
376-- | Load a 3D vector. 334-- | Load a 3D vector.
377uniformVec3 :: GLint -> Vector3 -> IO () 335uniformVec3 :: GLint -> Vector3 -> IO ()
378uniformVec3 loc v = glUniform3f loc x' y' z' 336uniformVec3 loc v = glUniform3f loc x' y' z'
@@ -380,7 +338,6 @@ uniformVec3 loc v = glUniform3f loc x' y' z'
380 y' = unsafeCoerce $ y v 338 y' = unsafeCoerce $ y v
381 z' = unsafeCoerce $ z v 339 z' = unsafeCoerce $ z v
382 340
383
384-- | Load a 4D vector. 341-- | Load a 4D vector.
385uniformVec4 :: GLint -> Vector4 -> IO () 342uniformVec4 :: GLint -> Vector4 -> IO ()
386uniformVec4 loc v = glUniform4f loc x' y' z' w' 343uniformVec4 loc v = glUniform4f loc x' y' z' w'
@@ -389,21 +346,18 @@ uniformVec4 loc v = glUniform4f loc x' y' z' w'
389 z' = unsafeCoerce $ z v 346 z' = unsafeCoerce $ z v
390 w' = unsafeCoerce $ w v 347 w' = unsafeCoerce $ w v
391 348
392
393-- | Load a 3x3 matrix. 349-- | Load a 3x3 matrix.
394uniformMat3 :: GLint -> Matrix3 -> IO () 350uniformMat3 :: GLint -> Matrix3 -> IO ()
395uniformMat3 loc mat = 351uniformMat3 loc mat =
396 with mat $ \ptrMat -> 352 with mat $ \ptrMat ->
397 glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) 353 glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
398 354
399
400-- | Load a 4x4 matrix. 355-- | Load a 4x4 matrix.
401uniformMat4 :: GLint -> Matrix4 -> IO () 356uniformMat4 :: GLint -> Matrix4 -> IO ()
402uniformMat4 loc mat = 357uniformMat4 loc mat =
403 with mat $ \ptrMat -> 358 with mat $ \ptrMat ->
404 glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) 359 glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
405 360
406
407-- | Load a list of floats. 361-- | Load a list of floats.
408uniformfl :: GLint -> [GLfloat] -> IO () 362uniformfl :: GLint -> [GLfloat] -> IO ()
409uniformfl loc vals = withArray vals $ \ptr -> 363uniformfl loc vals = withArray vals $ \ptr ->
@@ -413,7 +367,6 @@ uniformfl loc vals = withArray vals $ \ptr ->
413 3 -> glUniform3fv loc 1 ptr 367 3 -> glUniform3fv loc 1 ptr
414 4 -> glUniform4fv loc 1 ptr 368 4 -> glUniform4fv loc 1 ptr
415 369
416
417-- | Load a list of integers. 370-- | Load a list of integers.
418uniformil :: GLint -> [GLint] -> IO () 371uniformil :: GLint -> [GLint] -> IO ()
419uniformil loc vals = withArray vals $ \ptr -> 372uniformil loc vals = withArray vals $ \ptr ->
@@ -423,65 +376,50 @@ uniformil loc vals = withArray vals $ \ptr ->
423 3 -> glUniform3iv loc 1 ptr 376 3 -> glUniform3iv loc 1 ptr
424 4 -> glUniform4iv loc 1 ptr 377 4 -> glUniform4iv loc 1 ptr
425 378
426
427
428
429
430
431-- 379--
432-- VAOs 380-- VAOs
433-- 381--
434 382
435
436-- | A vertex array object. 383-- | A vertex array object.
437data VAO = VAO 384data VAO = VAO
438 { getVAO :: GLuint 385 { getVAO :: GLuint
439 , vaoKey :: Resource 386 , vaoKey :: Resource
440 } 387 }
441 388
389instance ResourceClass VAO where
390 getResource = vaoKey
442 391
443instance Eq VAO where 392instance Eq VAO where
444 vao1 == vao2 = getVAO vao1 == getVAO vao2 393 vao1 == vao2 = getVAO vao1 == getVAO vao2
445 394
446
447instance Ord VAO where 395instance Ord VAO where
448 vao1 < vao2 = getVAO vao1 < getVAO vao2 396 vao1 < vao2 = getVAO vao1 < getVAO vao2
449 397
450
451-- | Create a new vao. 398-- | Create a new vao.
452newVAO :: Setup VAO 399newVAO :: Game s VAO
453newVAO = do 400newVAO = do
454 h <- setupIO . alloca $ \ptr -> do 401 h <- gameIO . alloca $ \ptr -> do
455 glGenVertexArrays 1 ptr 402 glGenVertexArrays 1 ptr
456 peek ptr 403 peek ptr
457 404
458 rkey <- register $ deleteVAO h 405 rkey <- register $ deleteVAO h
459 return $ VAO h rkey 406 return $ VAO h rkey
460 407
461
462-- | Release the vao.
463releaseVAO :: VAO -> Setup ()
464releaseVAO = release . vaoKey
465
466
467-- | Delete the vao. 408-- | Delete the vao.
468deleteVAO :: GLuint -> IO () 409deleteVAO :: GLuint -> IO ()
469deleteVAO vao = Foreign.with vao $ glDeleteVertexArrays 1 410deleteVAO vao = Foreign.with vao $ glDeleteVertexArrays 1
470 411
471
472-- | Bind the vao. 412-- | Bind the vao.
473bindVAO :: VAO -> IO () 413bindVAO :: VAO -> IO ()
474bindVAO = glBindVertexArray . getVAO 414bindVAO = glBindVertexArray . getVAO
475 415
476
477-- | Enable the given vertex attribute of the bound vao. 416-- | Enable the given vertex attribute of the bound vao.
478-- 417--
479-- See also 'bindVAO'. 418-- See also 'bindVAO'.
480enableVAOAttrib :: GLuint -- ^ Attribute index. 419enableVAOAttrib :: GLuint -- ^ Attribute index.
481 -> IO () 420 -> IO ()
482enableVAOAttrib = glEnableVertexAttribArray 421enableVAOAttrib = glEnableVertexAttribArray
483 422
484
485-- | Bind the bound buffer to the given point. 423-- | Bind the bound buffer to the given point.
486attribVAOPointer 424attribVAOPointer
487 :: GLuint -- ^ The index of the generic vertex attribute to be modified. 425 :: GLuint -- ^ The index of the generic vertex attribute to be modified.
@@ -494,7 +432,6 @@ attribVAOPointer
494attribVAOPointer idx ncomp dattype normalise stride off = 432attribVAOPointer idx ncomp dattype normalise stride off =
495 glVertexAttribPointer idx ncomp dattype (unsafeCoerce normalise) stride (unsafeCoerce off) 433 glVertexAttribPointer idx ncomp dattype (unsafeCoerce normalise) stride (unsafeCoerce off)
496 434
497
498-- | Draw the bound vao. 435-- | Draw the bound vao.
499drawArrays 436drawArrays
500 :: GLenum -- ^ The kind of primitives to render. 437 :: GLenum -- ^ The kind of primitives to render.
@@ -503,7 +440,6 @@ drawArrays
503 -> IO () 440 -> IO ()
504drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count) 441drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count)
505 442
506
507-- | Draw the bound vao, indexed mode. 443-- | Draw the bound vao, indexed mode.
508drawElements 444drawElements
509 :: GLenum -- ^ The kind of primitives to render. 445 :: GLenum -- ^ The kind of primitives to render.
@@ -513,22 +449,18 @@ drawElements
513 -> IO () 449 -> IO ()
514drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs 450drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
515 451
516
517
518
519
520
521-- 452--
522-- BUFFER 453-- BUFFER
523-- 454--
524 455
525
526-- | An OpenGL buffer. 456-- | An OpenGL buffer.
527data GLBuffer = GLBuffer 457data GLBuffer = GLBuffer
528 { getBuffer :: GLuint 458 { getBuffer :: GLuint
529 , rkey :: Resource 459 , rkey :: Resource
530 } 460 }
531 461
462instance ResourceClass GLBuffer where
463 getResource = rkey
532 464
533-- | The type of target buffer. 465-- | The type of target buffer.
534data TargetBuffer 466data TargetBuffer
@@ -538,14 +470,12 @@ data TargetBuffer
538 | PixelUnpackBuffer 470 | PixelUnpackBuffer
539 deriving (Eq, Show) 471 deriving (Eq, Show)
540 472
541
542fromTarget :: TargetBuffer -> GLenum 473fromTarget :: TargetBuffer -> GLenum
543fromTarget ArrayBuffer = gl_ARRAY_BUFFER 474fromTarget ArrayBuffer = gl_ARRAY_BUFFER
544fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER 475fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER
545fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER 476fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER
546fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER 477fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER
547 478
548
549-- | A buffer usage. 479-- | A buffer usage.
550data BufferUsage 480data BufferUsage
551 = StreamDraw 481 = StreamDraw
@@ -559,7 +489,6 @@ data BufferUsage
559 | DynamicCopy 489 | DynamicCopy
560 deriving (Eq, Show) 490 deriving (Eq, Show)
561 491
562
563fromUsage :: BufferUsage -> GLenum 492fromUsage :: BufferUsage -> GLenum
564fromUsage StreamDraw = gl_STREAM_DRAW 493fromUsage StreamDraw = gl_STREAM_DRAW
565fromUsage StreamRead = gl_STREAM_READ 494fromUsage StreamRead = gl_STREAM_READ
@@ -571,33 +500,24 @@ fromUsage DynamicDraw = gl_DYNAMIC_DRAW
571fromUsage DynamicRead = gl_DYNAMIC_READ 500fromUsage DynamicRead = gl_DYNAMIC_READ
572fromUsage DynamicCopy = gl_DYNAMIC_COPY 501fromUsage DynamicCopy = gl_DYNAMIC_COPY
573 502
574
575-- | Create a new buffer. 503-- | Create a new buffer.
576newBuffer :: Setup GLBuffer 504newBuffer :: Game s GLBuffer
577newBuffer = do 505newBuffer = do
578 h <- setupIO . alloca $ \ptr -> do 506 h <- gameIO . alloca $ \ptr -> do
579 glGenBuffers 1 ptr 507 glGenBuffers 1 ptr
580 peek ptr 508 peek ptr
581 509
582 rkey <- register $ deleteBuffer h 510 rkey <- register $ deleteBuffer h
583 return $ GLBuffer h rkey 511 return $ GLBuffer h rkey
584 512
585
586-- | Release the buffer.
587releaseBuffer :: GLBuffer -> Setup ()
588releaseBuffer = release . rkey
589
590
591-- | Delete the buffer. 513-- | Delete the buffer.
592deleteBuffer :: GLuint -> IO () 514deleteBuffer :: GLuint -> IO ()
593deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1 515deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1
594 516
595
596-- | Bind the buffer. 517-- | Bind the buffer.
597bindBuffer :: GLBuffer -> TargetBuffer -> IO () 518bindBuffer :: GLBuffer -> TargetBuffer -> IO ()
598bindBuffer buf target = glBindBuffer (fromTarget target) $ getBuffer buf 519bindBuffer buf target = glBindBuffer (fromTarget target) $ getBuffer buf
599 520
600
601-- | Set the buffer's data. 521-- | Set the buffer's data.
602bufferData :: TargetBuffer 522bufferData :: TargetBuffer
603 -> Int -- ^ Buffer size in bytes. 523 -> Int -- ^ Buffer size in bytes.
@@ -606,7 +526,6 @@ bufferData :: TargetBuffer
606 -> IO () 526 -> IO ()
607bufferData target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage) 527bufferData target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage)
608 528
609
610-- | Set the buffer's data. 529-- | Set the buffer's data.
611bufferDatal :: Storable a 530bufferDatal :: Storable a
612 => TargetBuffer 531 => TargetBuffer
@@ -617,16 +536,10 @@ bufferDatal :: Storable a
617bufferDatal target n bufData usage = withArray bufData $ 536bufferDatal target n bufData usage = withArray bufData $
618 \ptr -> bufferData target (n * length bufData) ptr usage 537 \ptr -> bufferData target (n * length bufData) ptr usage
619 538
620
621-- | Apply the given function the buffer's id. 539-- | Apply the given function the buffer's id.
622withGLBuffer :: GLBuffer -> (GLuint -> a) -> a 540withGLBuffer :: GLBuffer -> (GLuint -> a) -> a
623withGLBuffer buf f = f $ getBuffer buf 541withGLBuffer buf f = f $ getBuffer buf
624 542
625
626
627
628
629
630-- 543--
631-- TEXTURE 544-- TEXTURE
632-- 545--
@@ -637,31 +550,25 @@ data Texture = Texture
637 , texKey :: Resource 550 , texKey :: Resource
638 } 551 }
639 552
640
641instance Eq Texture where 553instance Eq Texture where
642 t1 == t2 = getTex t1 == getTex t2 554 t1 == t2 = getTex t1 == getTex t2
643 555
644
645instance Ord Texture where 556instance Ord Texture where
646 t1 < t2 = getTex t1 < getTex t2 557 t1 < t2 = getTex t1 < getTex t2
647 558
559instance ResourceClass Texture where
560 getResource = texKey
648 561
649-- | Create a new texture. 562-- | Create a new texture.
650newTexture :: Setup Texture 563newTexture :: Game s Texture
651newTexture = do 564newTexture = do
652 tex <- setupIO . alloca $ \ptr -> do 565 tex <- gameIO . alloca $ \ptr -> do
653 glGenTextures 1 ptr 566 glGenTextures 1 ptr
654 peek ptr 567 peek ptr
655 568
656 rkey <- register $ deleteTexture tex 569 rkey <- register $ deleteTexture tex
657 return $ Texture tex rkey 570 return $ Texture tex rkey
658 571
659
660-- | Release the texture.
661releaseTexture :: Texture -> Setup ()
662releaseTexture = release . texKey
663
664
665-- | Delete the texture. 572-- | Delete the texture.
666deleteTexture :: GLuint -> IO () 573deleteTexture :: GLuint -> IO ()
667--deleteTexture tex = with tex $ glDeleteTextures 1 574--deleteTexture tex = with tex $ glDeleteTextures 1
@@ -669,16 +576,15 @@ deleteTexture tex = do
669 putStrLn $ "Releasing texture " ++ show tex 576 putStrLn $ "Releasing texture " ++ show tex
670 with tex $ glDeleteTextures 1 577 with tex $ glDeleteTextures 1
671 578
672
673-- | Load the 'Texture' specified by the given file. 579-- | Load the 'Texture' specified by the given file.
674loadTextureImage :: FilePath 580loadTextureImage :: FilePath
675 -> GLenum -- ^ Texture's min filter. 581 -> GLenum -- ^ Texture's min filter.
676 -> GLenum -- ^ Texture's mag filter. 582 -> GLenum -- ^ Texture's mag filter.
677 -> Setup Texture 583 -> Game s Texture
678loadTextureImage file minFilter magFilter = do 584loadTextureImage file minFilter magFilter = do
679 image <- loadImage file 585 image <- loadImage file
680 tex <- newTexture 586 tex <- newTexture
681 setupIO $ do 587 gameIO $ do
682 let w = width image 588 let w = width image
683 h = height image 589 h = height image
684 pix = pixels image 590 pix = pixels image
@@ -691,12 +597,10 @@ loadTextureImage file minFilter magFilter = do
691 597
692 return tex 598 return tex
693 599
694
695-- | Bind the texture. 600-- | Bind the texture.
696bindTexture :: Texture -> IO () 601bindTexture :: Texture -> IO ()
697bindTexture = glBindTexture gl_TEXTURE_2D . getTex 602bindTexture = glBindTexture gl_TEXTURE_2D . getTex
698 603
699
700-- | Load data onto the bound texture. 604-- | Load data onto the bound texture.
701-- 605--
702-- See also 'bindTexture'. 606-- See also 'bindTexture'.
@@ -721,31 +625,22 @@ loadTextureData target level internalFormat width height border format texType t
721 texType 625 texType
722 texData 626 texData
723 627
724
725-- | Set the bound texture's parameter to the given value. 628-- | Set the bound texture's parameter to the given value.
726texParami :: GLenum -> GLenum -> SettableStateVar GLenum 629texParami :: GLenum -> GLenum -> SettableStateVar GLenum
727texParami target param = makeSettableStateVar $ \val -> glTexParameteri target param $ fromIntegral . fromEnum $ val 630texParami target param = makeSettableStateVar $ \val -> glTexParameteri target param $ fromIntegral . fromEnum $ val
728 631
729
730-- | Set the bound texture's parameter to the given value. 632-- | Set the bound texture's parameter to the given value.
731texParamf :: GLenum -> GLenum -> SettableStateVar Float 633texParamf :: GLenum -> GLenum -> SettableStateVar Float
732texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val) 634texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val)
733 635
734
735-- | Set the active texture unit. 636-- | Set the active texture unit.
736activeTexture :: SettableStateVar GLenum 637activeTexture :: SettableStateVar GLenum
737activeTexture = makeSettableStateVar glActiveTexture 638activeTexture = makeSettableStateVar glActiveTexture
738 639
739
740
741
742
743
744-- 640--
745-- ERROR 641-- ERROR
746-- 642--
747 643
748
749-- | Get the last OpenGL error. 644-- | Get the last OpenGL error.
750getGLError :: IO (Maybe String) 645getGLError :: IO (Maybe String)
751getGLError = fmap translate glGetError 646getGLError = fmap translate glGetError
@@ -758,22 +653,20 @@ getGLError = fmap translate glGetError
758 | err == gl_OUT_OF_MEMORY = Just "Out of memory" 653 | err == gl_OUT_OF_MEMORY = Just "Out of memory"
759 | otherwise = Just "Unknown error" 654 | otherwise = Just "Unknown error"
760 655
761
762-- | Print the last OpenGL error. 656-- | Print the last OpenGL error.
763printGLError :: IO () 657printGLError :: IO ()
764printGLError = getGLError >>= \err -> case err of 658printGLError = getGLError >>= \err -> case err of
765 Nothing -> return () 659 Nothing -> return ()
766 Just str -> hPutStrLn stderr str 660 Just str -> hPutStrLn stderr str
767 661
768
769-- | Run the given setup action and check for OpenGL errors. 662-- | Run the given setup action and check for OpenGL errors.
770-- 663--
771-- If an OpenGL error is produced, an exception is thrown containing 664-- If an OpenGL error is produced, an exception is thrown containing
772-- the given string appended to the string describing the error. 665-- the given string appended to the string describing the error.
773assertGL :: Setup a -> String -> Setup a 666assertGL :: Game s a -> String -> Game s a
774assertGL action err = do 667assertGL action err = do
775 result <- action 668 result <- action
776 status <- setupIO getGLError 669 status <- gameIO getGLError
777 case status of 670 case status of
778 Just str -> setupError $ "OpenGL error raised: " ++ err ++ "; " ++ str 671 Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str
779 Nothing -> return result 672 Nothing -> return result
diff --git a/Spear/Game.hs b/Spear/Game.hs
index 08fc460..6bb1fa6 100644
--- a/Spear/Game.hs
+++ b/Spear/Game.hs
@@ -1,42 +1,88 @@
1module Spear.Game 1module Spear.Game
2( 2(
3 Game 3 Game
4, gameIO 4, Resource
5, ResourceClass(..)
6 -- * Game State
5, getGameState 7, getGameState
6, saveGameState 8, saveGameState
7, modifyGameState 9, modifyGameState
10 -- * Game Resources
11, register
12, unregister
13, gameError
14, assertMaybe
15 -- * Running and IO
8, runGame 16, runGame
17, runGame'
18, evalSubGame
19, execSubGame
20, gameIO
9) 21)
10where 22where
11 23
12
13import Control.Monad.Trans.Class (lift) 24import Control.Monad.Trans.Class (lift)
14import Control.Monad.State.Strict 25import Control.Monad.State.Strict
26import Control.Monad.Error
27import qualified Control.Monad.Trans.Resource as R
15 28
29type Resource = R.ReleaseKey
30type Game s = StateT s (R.ResourceT (ErrorT String IO))
16 31
17type Game s = StateT s IO 32class ResourceClass a where
18 33 getResource :: a -> Resource
19 34
20-- | Perform the given IO action in the 'Game' monad. 35 release :: a -> Game s ()
21gameIO :: IO a -> Game s a 36 release = unregister . getResource
22gameIO = lift 37
23 38 clean :: a -> IO ()
39 clean = R.release . getResource
24 40
25-- | Retrieve the game state. 41-- | Retrieve the game state.
26getGameState :: Game s s 42getGameState :: Game s s
27getGameState = get 43getGameState = get
28 44
29
30-- | Save the game state. 45-- | Save the game state.
31saveGameState :: s -> Game s () 46saveGameState :: s -> Game s ()
32saveGameState = put 47saveGameState = put
33 48
34
35-- | Modify the game state. 49-- | Modify the game state.
36modifyGameState :: (s -> s) -> Game s () 50modifyGameState :: (s -> s) -> Game s ()
37modifyGameState = modify 51modifyGameState = modify
38 52
53-- | Register the given cleaner.
54register :: IO () -> Game s Resource
55register = lift . R.register
56
57-- | Release the given 'Resource'.
58unregister :: Resource -> Game s ()
59unregister = lift . R.release
60
61-- | Throw an error from the 'Game' monad.
62gameError :: String -> Game s a
63gameError = lift . lift . throwError
64
65-- | Throw the given error string if given 'Nothing'.
66assertMaybe :: Maybe a -> String -> Game s a
67assertMaybe Nothing err = gameError err
68assertMaybe (Just x) _ = return x
69
70-- | Run the given game.
71runGame :: Game s a -> s -> IO (Either String (a,s))
72runGame game state = runErrorT . R.runResourceT . runStateT game $ state
39 73
40-- | Run the given game. 74-- | Run the given game.
41runGame :: Game s a -> s -> IO () 75runGame' :: Game s a -> s -> IO ()
42runGame game state = runStateT game state >> return () 76runGame' game state = runGame game state >> return ()
77
78-- | Run the given game and return its result.
79evalSubGame :: Game s a -> s -> Game t a
80evalSubGame g s = lift $ evalStateT g s
81
82-- | Run the given game and return its state.
83execSubGame :: Game s a -> s -> Game t s
84execSubGame g s = lift $ execStateT g s
85
86-- | Perform the given IO action in the 'Game' monad.
87gameIO :: IO a -> Game s a
88gameIO = lift . lift . lift
diff --git a/Spear/Math/Camera.hs b/Spear/Math/Camera.hs
index e22f3c2..a86d5f5 100644
--- a/Spear/Math/Camera.hs
+++ b/Spear/Math/Camera.hs
@@ -27,7 +27,7 @@ perspective :: Float -- ^ Fovy - Vertical field of view angle in degrees.
27perspective fovy r n f right up fwd pos = 27perspective fovy r n f right up fwd pos =
28 Camera 28 Camera
29 { projection = M.perspective fovy r n f 29 { projection = M.perspective fovy r n f
30 , transform = M.transform right up fwd pos 30 , transform = M.transform right up (neg fwd) pos
31 } 31 }
32 32
33 33
@@ -47,7 +47,7 @@ ortho :: Float -- ^ Left.
47ortho l r b t n f right up fwd pos = 47ortho l r b t n f right up fwd pos =
48 Camera 48 Camera
49 { projection = M.ortho l r b t n f 49 { projection = M.ortho l r b t n f
50 , transform = M.transform right up fwd pos 50 , transform = M.transform right up (neg fwd) pos
51 } 51 }
52 52
53 53
diff --git a/Spear/Render/AnimatedModel.hs b/Spear/Render/AnimatedModel.hs
index dfaadfd..e554272 100644
--- a/Spear/Render/AnimatedModel.hs
+++ b/Spear/Render/AnimatedModel.hs
@@ -7,7 +7,6 @@ module Spear.Render.AnimatedModel
7 -- * Construction and destruction 7 -- * Construction and destruction
8, animatedModelResource 8, animatedModelResource
9, animatedModelRenderer 9, animatedModelRenderer
10, Spear.Render.AnimatedModel.release
11 -- * Accessors 10 -- * Accessors
12, animationSpeed 11, animationSpeed
13, box 12, box
@@ -28,9 +27,9 @@ module Spear.Render.AnimatedModel
28) 27)
29where 28where
30 29
31
32import Spear.Assets.Model 30import Spear.Assets.Model
33import Spear.Collision 31import Spear.Collision
32import Spear.Game
34import Spear.GLSL 33import Spear.GLSL
35import Spear.Math.AABB 34import Spear.Math.AABB
36import Spear.Math.Matrix4 (Matrix4) 35import Spear.Math.Matrix4 (Matrix4)
@@ -38,17 +37,14 @@ import Spear.Math.Vector
38import Spear.Render.Material 37import Spear.Render.Material
39import Spear.Render.Model 38import Spear.Render.Model
40import Spear.Render.Program 39import Spear.Render.Program
41import Spear.Setup as Setup
42 40
43import Control.Applicative ((<$>), (<*>)) 41import Control.Applicative ((<$>), (<*>))
44import qualified Data.Vector as V 42import qualified Data.Vector as V
45import Graphics.Rendering.OpenGL.Raw.Core31 43import Graphics.Rendering.OpenGL.Raw.Core31
46import Unsafe.Coerce (unsafeCoerce) 44import Unsafe.Coerce (unsafeCoerce)
47 45
48
49type AnimationSpeed = Float 46type AnimationSpeed = Float
50 47
51
52-- | An animated model resource. 48-- | An animated model resource.
53-- 49--
54-- Contains model data necessary to render an animated model. 50-- Contains model data necessary to render an animated model.
@@ -63,14 +59,14 @@ data AnimatedModelResource = AnimatedModelResource
63 , rkey :: Resource 59 , rkey :: Resource
64 } 60 }
65 61
66
67instance Eq AnimatedModelResource where 62instance Eq AnimatedModelResource where
68 m1 == m2 = vao m1 == vao m2 63 m1 == m2 = vao m1 == vao m2
69 64
70
71instance Ord AnimatedModelResource where 65instance Ord AnimatedModelResource where
72 m1 < m2 = vao m1 < vao m2 66 m1 < m2 = vao m1 < vao m2
73 67
68instance ResourceClass AnimatedModelResource where
69 getResource = rkey
74 70
75-- | An animated model renderer. 71-- | An animated model renderer.
76-- 72--
@@ -92,31 +88,28 @@ data AnimatedModelRenderer = AnimatedModelRenderer
92 , animationSpeed :: Float -- ^ Get the renderer's animation speed. 88 , animationSpeed :: Float -- ^ Get the renderer's animation speed.
93 } 89 }
94 90
95
96instance Eq AnimatedModelRenderer where 91instance Eq AnimatedModelRenderer where
97 m1 == m2 = modelResource m1 == modelResource m2 92 m1 == m2 = modelResource m1 == modelResource m2
98 93
99
100instance Ord AnimatedModelRenderer where 94instance Ord AnimatedModelRenderer where
101 m1 < m2 = modelResource m1 < modelResource m2 95 m1 < m2 = modelResource m1 < modelResource m2
102 96
103
104-- | Create an model resource from the given model. 97-- | Create an model resource from the given model.
105animatedModelResource :: AnimatedProgramChannels 98animatedModelResource :: AnimatedProgramChannels
106 -> Material 99 -> Material
107 -> Texture 100 -> Texture
108 -> Model 101 -> Model
109 -> Setup AnimatedModelResource 102 -> Game s AnimatedModelResource
110 103
111animatedModelResource 104animatedModelResource
112 (AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan) 105 (AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan)
113 material texture model = do 106 material texture model = do
114 RenderModel elements numFrames numVertices <- setupIO . renderModelFromModel $ model 107 RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model
115 elementBuf <- newBuffer 108 elementBuf <- newBuffer
116 vao <- newVAO 109 vao <- newVAO
117 boxes <- setupIO $ modelBoxes model 110 boxes <- gameIO $ modelBoxes model
118 111
119 setupIO $ do 112 gameIO $ do
120 113
121 let elemSize = 56 114 let elemSize = 56
122 elemSize' = fromIntegral elemSize 115 elemSize' = fromIntegral elemSize
@@ -139,27 +132,20 @@ animatedModelResource
139 enableVAOAttrib normChan2 132 enableVAOAttrib normChan2
140 enableVAOAttrib texChan 133 enableVAOAttrib texChan
141 134
142 rkey <- register . runSetup_ $ do 135 rkey <- register $ do
143 setupIO $ putStrLn "Releasing animated model resource" 136 putStrLn "Releasing animated model resource"
144 releaseVAO vao 137 clean vao
145 releaseBuffer elementBuf 138 clean elementBuf
146 139
147 return $ AnimatedModelResource 140 return $ AnimatedModelResource
148 model vao (unsafeCoerce numFrames) (unsafeCoerce numVertices) 141 model vao (unsafeCoerce numFrames) (unsafeCoerce numVertices)
149 material texture boxes rkey 142 material texture boxes rkey
150 143
151
152-- | Release the given model resource.
153release :: AnimatedModelResource -> Setup ()
154release = Setup.release . rkey
155
156
157-- | Create a renderer from the given model resource. 144-- | Create a renderer from the given model resource.
158animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer 145animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer
159animatedModelRenderer animSpeed modelResource = 146animatedModelRenderer animSpeed modelResource =
160 AnimatedModelRenderer modelResource 0 0 0 0 0 animSpeed 147 AnimatedModelRenderer modelResource 0 0 0 0 0 animSpeed
161 148
162
163-- | Update the renderer. 149-- | Update the renderer.
164update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) = 150update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) =
165 AnimatedModelRenderer model curAnim startFrame endFrame curFrame' fp' s 151 AnimatedModelRenderer model curAnim startFrame endFrame curFrame' fp' s
@@ -171,22 +157,18 @@ update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s
171 in if x > endFrame then startFrame else x 157 in if x > endFrame then startFrame else x
172 else curFrame 158 else curFrame
173 159
174
175-- | Get the model's ith bounding box. 160-- | Get the model's ith bounding box.
176box :: Int -> AnimatedModelResource -> Box 161box :: Int -> AnimatedModelResource -> Box
177box i model = boxes model V.! i 162box i model = boxes model V.! i
178 163
179
180-- | Get the renderer's current animation. 164-- | Get the renderer's current animation.
181currentAnimation :: Enum a => AnimatedModelRenderer -> a 165currentAnimation :: Enum a => AnimatedModelRenderer -> a
182currentAnimation = toEnum . currentAnim 166currentAnimation = toEnum . currentAnim
183 167
184
185-- | Get the renderer's model resource. 168-- | Get the renderer's model resource.
186modelRes :: AnimatedModelRenderer -> AnimatedModelResource 169modelRes :: AnimatedModelRenderer -> AnimatedModelResource
187modelRes = modelResource 170modelRes = modelResource
188 171
189
190-- | Get the renderer's next frame. 172-- | Get the renderer's next frame.
191nextFrame :: AnimatedModelRenderer -> Int 173nextFrame :: AnimatedModelRenderer -> Int
192nextFrame rend = 174nextFrame rend =
@@ -196,7 +178,6 @@ nextFrame rend =
196 then frameStart rend 178 then frameStart rend
197 else curFrame + 1 179 else curFrame + 1
198 180
199
200-- | Set the active animation to the given one. 181-- | Set the active animation to the given one.
201setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer 182setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer
202setAnimation anim modelRend = 183setAnimation anim modelRend =
@@ -205,12 +186,10 @@ setAnimation anim modelRend =
205 in 186 in
206 modelRend { currentAnim = anim', frameStart = f1, frameEnd = f2, currentFrame = f1 } 187 modelRend { currentAnim = anim', frameStart = f1, frameEnd = f2, currentFrame = f1 }
207 188
208
209-- | Set the renderer's animation speed. 189-- | Set the renderer's animation speed.
210setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer 190setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer
211setAnimationSpeed s r = r { animationSpeed = s } 191setAnimationSpeed s r = r { animationSpeed = s }
212 192
213
214-- | Bind the given renderer to prepare it for rendering. 193-- | Bind the given renderer to prepare it for rendering.
215bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () 194bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO ()
216bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend = 195bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend =
@@ -221,7 +200,6 @@ bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend
221 activeTexture $= gl_TEXTURE0 200 activeTexture $= gl_TEXTURE0
222 glUniform1i texLoc 0 201 glUniform1i texLoc 0
223 202
224
225-- | Render the model described by the given renderer. 203-- | Render the model described by the given renderer.
226render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () 204render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO ()
227render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) = 205render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) =
@@ -235,7 +213,6 @@ render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) =
235 glUniform1f (fpLoc uniforms) (unsafeCoerce fp) 213 glUniform1f (fpLoc uniforms) (unsafeCoerce fp)
236 drawArrays gl_TRIANGLES (n*curFrame) n 214 drawArrays gl_TRIANGLES (n*curFrame) n
237 215
238
239-- | Compute AABB collisioners in view space from the given model. 216-- | Compute AABB collisioners in view space from the given model.
240mkColsFromAnimated 217mkColsFromAnimated
241 :: Int -- ^ Source frame 218 :: Int -- ^ Source frame
diff --git a/Spear/Render/Model.hsc b/Spear/Render/Model.hsc
index b6c561b..d7dbdfe 100644
--- a/Spear/Render/Model.hsc
+++ b/Spear/Render/Model.hsc
@@ -7,9 +7,8 @@ module Spear.Render.Model
7) 7)
8where 8where
9 9
10
11import qualified Spear.Assets.Model as Assets 10import qualified Spear.Assets.Model as Assets
12import Spear.Setup 11import Spear.Game
13 12
14import Foreign.Ptr 13import Foreign.Ptr
15import Foreign.C.Types 14import Foreign.C.Types
@@ -18,22 +17,18 @@ import Foreign.Marshal.Array
18import Foreign.Marshal.Utils (with) 17import Foreign.Marshal.Utils (with)
19import Foreign.Storable 18import Foreign.Storable
20 19
21
22#include "RenderModel.h" 20#include "RenderModel.h"
23 21
24
25data Vec3 = Vec3 !CFloat !CFloat !CFloat 22data Vec3 = Vec3 !CFloat !CFloat !CFloat
26 23
27data TexCoord = TexCoord !CFloat !CFloat 24data TexCoord = TexCoord !CFloat !CFloat
28 25
29
30data RenderModel = RenderModel 26data RenderModel = RenderModel
31 { elements :: Ptr CChar 27 { elements :: Ptr CChar
32 , numFrames :: CUInt 28 , numFrames :: CUInt
33 , numVertices :: CUInt -- ^ Number of vertices per frame. 29 , numVertices :: CUInt -- ^ Number of vertices per frame.
34 } 30 }
35 31
36
37instance Storable RenderModel where 32instance Storable RenderModel where
38 sizeOf _ = #{size RenderModel} 33 sizeOf _ = #{size RenderModel}
39 alignment _ = alignment (undefined :: CUInt) 34 alignment _ = alignment (undefined :: CUInt)
@@ -49,11 +44,9 @@ instance Storable RenderModel where
49 #{poke RenderModel, numFrames} ptr numFrames 44 #{poke RenderModel, numFrames} ptr numFrames
50 #{poke RenderModel, numVertices} ptr numVertices 45 #{poke RenderModel, numVertices} ptr numVertices
51 46
52
53foreign import ccall "RenderModel.h render_model_from_model_asset" 47foreign import ccall "RenderModel.h render_model_from_model_asset"
54 render_model_from_model_asset :: Ptr Assets.Model -> Ptr RenderModel -> IO Int 48 render_model_from_model_asset :: Ptr Assets.Model -> Ptr RenderModel -> IO Int
55 49
56
57-- | Convert the given 'Model' to a 'ModelData' instance. 50-- | Convert the given 'Model' to a 'ModelData' instance.
58renderModelFromModel :: Assets.Model -> IO RenderModel 51renderModelFromModel :: Assets.Model -> IO RenderModel
59renderModelFromModel m = with m $ \mPtr -> alloca $ \mdPtr -> do 52renderModelFromModel m = with m $ \mPtr -> alloca $ \mdPtr -> do
diff --git a/Spear/Render/StaticModel.hs b/Spear/Render/StaticModel.hs
index ed8d065..fc7006e 100644
--- a/Spear/Render/StaticModel.hs
+++ b/Spear/Render/StaticModel.hs
@@ -6,7 +6,6 @@ module Spear.Render.StaticModel
6 -- * Construction and destruction 6 -- * Construction and destruction
7, staticModelResource 7, staticModelResource
8, staticModelRenderer 8, staticModelRenderer
9, Spear.Render.StaticModel.release
10 -- * Manipulation 9 -- * Manipulation
11, box 10, box
12, modelRes 11, modelRes
@@ -18,9 +17,9 @@ module Spear.Render.StaticModel
18) 17)
19where 18where
20 19
21
22import Spear.Assets.Model 20import Spear.Assets.Model
23import Spear.Collision 21import Spear.Collision
22import Spear.Game
24import Spear.GLSL 23import Spear.GLSL
25import Spear.Math.AABB 24import Spear.Math.AABB
26import Spear.Math.Matrix4 (Matrix4) 25import Spear.Math.Matrix4 (Matrix4)
@@ -28,13 +27,11 @@ import Spear.Math.Vector
28import Spear.Render.Material 27import Spear.Render.Material
29import Spear.Render.Model 28import Spear.Render.Model
30import Spear.Render.Program 29import Spear.Render.Program
31import Spear.Setup as Setup
32 30
33import qualified Data.Vector as V 31import qualified Data.Vector as V
34import Graphics.Rendering.OpenGL.Raw.Core31 32import Graphics.Rendering.OpenGL.Raw.Core31
35import Unsafe.Coerce (unsafeCoerce) 33import Unsafe.Coerce (unsafeCoerce)
36 34
37
38data StaticModelResource = StaticModelResource 35data StaticModelResource = StaticModelResource
39 { vao :: VAO 36 { vao :: VAO
40 , nVertices :: Int 37 , nVertices :: Int
@@ -44,40 +41,37 @@ data StaticModelResource = StaticModelResource
44 , rkey :: Resource 41 , rkey :: Resource
45 } 42 }
46 43
47
48instance Eq StaticModelResource where 44instance Eq StaticModelResource where
49 m1 == m2 = vao m1 == vao m2 45 m1 == m2 = vao m1 == vao m2
50 46
51
52instance Ord StaticModelResource where 47instance Ord StaticModelResource where
53 m1 < m2 = vao m1 < vao m2 48 m1 < m2 = vao m1 < vao m2
54 49
50instance ResourceClass StaticModelResource where
51 getResource = rkey
55 52
56data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource } 53data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource }
57 54
58
59instance Eq StaticModelRenderer where 55instance Eq StaticModelRenderer where
60 m1 == m2 = model m1 == model m2 56 m1 == m2 = model m1 == model m2
61 57
62
63instance Ord StaticModelRenderer where 58instance Ord StaticModelRenderer where
64 m1 < m2 = model m1 < model m2 59 m1 < m2 = model m1 < model m2
65 60
66
67-- | Create a model resource from the given model. 61-- | Create a model resource from the given model.
68staticModelResource :: StaticProgramChannels 62staticModelResource :: StaticProgramChannels
69 -> Material 63 -> Material
70 -> Texture 64 -> Texture
71 -> Model 65 -> Model
72 -> Setup StaticModelResource 66 -> Game s StaticModelResource
73 67
74staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do 68staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do
75 RenderModel elements _ numVertices <- setupIO . renderModelFromModel $ model 69 RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model
76 elementBuf <- newBuffer 70 elementBuf <- newBuffer
77 vao <- newVAO 71 vao <- newVAO
78 boxes <- setupIO $ modelBoxes model 72 boxes <- gameIO $ modelBoxes model
79 73
80 setupIO $ do 74 gameIO $ do
81 75
82 let elemSize = 32 76 let elemSize = 32
83 elemSize' = fromIntegral elemSize 77 elemSize' = fromIntegral elemSize
@@ -96,35 +90,26 @@ staticModelResource (StaticProgramChannels vertChan normChan texChan) material t
96 enableVAOAttrib normChan 90 enableVAOAttrib normChan
97 enableVAOAttrib texChan 91 enableVAOAttrib texChan
98 92
99 rkey <- register . runSetup_ $ do 93 rkey <- register $ do
100 setupIO $ putStrLn "Releasing static model resource" 94 putStrLn "Releasing static model resource"
101 releaseVAO vao 95 clean vao
102 releaseBuffer elementBuf 96 clean elementBuf
103 97
104 return $ StaticModelResource 98 return $ StaticModelResource
105 vao (unsafeCoerce numVertices) material texture boxes rkey 99 vao (unsafeCoerce numVertices) material texture boxes rkey
106 100
107
108-- | Release the given model resource.
109release :: StaticModelResource -> Setup ()
110release = Setup.release . rkey
111
112
113-- | Create a renderer from the given model resource. 101-- | Create a renderer from the given model resource.
114staticModelRenderer :: StaticModelResource -> StaticModelRenderer 102staticModelRenderer :: StaticModelResource -> StaticModelRenderer
115staticModelRenderer = StaticModelRenderer 103staticModelRenderer = StaticModelRenderer
116 104
117
118-- | Get the model's ith bounding box. 105-- | Get the model's ith bounding box.
119box :: Int -> StaticModelResource -> Box 106box :: Int -> StaticModelResource -> Box
120box i model = boxes model V.! i 107box i model = boxes model V.! i
121 108
122
123-- | Get the renderer's model resource. 109-- | Get the renderer's model resource.
124modelRes :: StaticModelRenderer -> StaticModelResource 110modelRes :: StaticModelRenderer -> StaticModelResource
125modelRes = model 111modelRes = model
126 112
127
128-- | Bind the given renderer to prepare it for rendering. 113-- | Bind the given renderer to prepare it for rendering.
129bind :: StaticProgramUniforms -> StaticModelRenderer -> IO () 114bind :: StaticProgramUniforms -> StaticModelRenderer -> IO ()
130bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) = 115bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) =
@@ -135,7 +120,6 @@ bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelR
135 activeTexture $= gl_TEXTURE0 120 activeTexture $= gl_TEXTURE0
136 glUniform1i texLoc 0 121 glUniform1i texLoc 0
137 122
138
139-- | Render the given renderer. 123-- | Render the given renderer.
140render :: StaticProgramUniforms -> StaticModelRenderer -> IO () 124render :: StaticProgramUniforms -> StaticModelRenderer -> IO ()
141render uniforms (StaticModelRenderer model) = 125render uniforms (StaticModelRenderer model) =
@@ -147,7 +131,6 @@ render uniforms (StaticModelRenderer model) =
147 glUniform1f (shiLoc uniforms) $ unsafeCoerce shi 131 glUniform1f (shiLoc uniforms) $ unsafeCoerce shi
148 drawArrays gl_TRIANGLES 0 $ nVertices model 132 drawArrays gl_TRIANGLES 0 $ nVertices model
149 133
150
151-- | Compute AABB collisioners in view space from the given model. 134-- | Compute AABB collisioners in view space from the given model.
152mkColsFromStatic 135mkColsFromStatic
153 :: Matrix4 -- ^ Modelview matrix 136 :: Matrix4 -- ^ Modelview matrix
diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs
index 07d4f05..09d69eb 100644
--- a/Spear/Scene/Loader.hs
+++ b/Spear/Scene/Loader.hs
@@ -17,9 +17,9 @@ module Spear.Scene.Loader
17) 17)
18where 18where
19 19
20
21import Spear.Assets.Model as Model 20import Spear.Assets.Model as Model
22import Spear.Collision 21import Spear.Collision
22import Spear.Game
23import qualified Spear.GLSL as GLSL 23import qualified Spear.GLSL as GLSL
24import Spear.Math.Matrix3 as M3 24import Spear.Math.Matrix3 as M3
25import Spear.Math.Matrix4 as M4 25import Spear.Math.Matrix4 as M4
@@ -33,7 +33,6 @@ import Spear.Scene.GameObject as GO
33import Spear.Scene.Graph 33import Spear.Scene.Graph
34import Spear.Scene.Light 34import Spear.Scene.Light
35import Spear.Scene.SceneResources 35import Spear.Scene.SceneResources
36import Spear.Setup
37 36
38import Control.Monad.State.Strict 37import Control.Monad.State.Strict
39import Control.Monad.Trans (lift) 38import Control.Monad.Trans (lift)
@@ -43,37 +42,27 @@ import qualified Data.StateVar as SV (get)
43import Graphics.Rendering.OpenGL.Raw.Core31 42import Graphics.Rendering.OpenGL.Raw.Core31
44import Text.Printf (printf) 43import Text.Printf (printf)
45 44
46 45type Loader = Game SceneResources
47type Loader = StateT SceneResources Setup
48
49
50loaderSetup = lift
51loaderIO = loaderSetup . setupIO
52loaderError = loaderSetup . setupError
53
54 46
55-- | Load the scene specified by the given file. 47-- | Load the scene specified by the given file.
56loadScene :: FilePath -> Setup (SceneResources, SceneGraph) 48loadScene :: FilePath -> Game s (SceneResources, SceneGraph)
57loadScene file = do 49loadScene file = do
58 result <- setupIO $ loadSceneGraphFromFile file 50 result <- gameIO $ loadSceneGraphFromFile file
59 case result of 51 case result of
60 Left err -> setupError $ show err 52 Left err -> gameError $ show err
61 Right g -> case validate g of 53 Right g -> case validate g of
62 Nothing -> do 54 Nothing -> do
63 sceneRes <- resourceMap g 55 sceneRes <- resourceMap g
64 return (sceneRes, g) 56 return (sceneRes, g)
65 Just err -> setupError err 57 Just err -> gameError err
66
67 58
68-- | Validate the given SceneGraph. 59-- | Validate the given SceneGraph.
69validate :: SceneGraph -> Maybe String 60validate :: SceneGraph -> Maybe String
70validate _ = Nothing 61validate _ = Nothing
71 62
72
73-- | Load the scene described by the given 'SceneGraph'. 63-- | Load the scene described by the given 'SceneGraph'.
74resourceMap :: SceneGraph -> Setup SceneResources 64resourceMap :: SceneGraph -> Game s SceneResources
75resourceMap g = execStateT (resourceMap' g) emptySceneResources 65resourceMap g = execSubGame (resourceMap' g) emptySceneResources
76
77 66
78resourceMap' :: SceneGraph -> Loader () 67resourceMap' :: SceneGraph -> Loader ()
79resourceMap' node@(SceneLeaf nid props) = do 68resourceMap' node@(SceneLeaf nid props) = do
@@ -86,63 +75,51 @@ resourceMap' node@(SceneLeaf nid props) = do
86resourceMap' node@(SceneNode nid props children) = do 75resourceMap' node@(SceneNode nid props children) = do
87 mapM_ resourceMap' children 76 mapM_ resourceMap' children
88 77
89
90-- Lookup the given resource in the data pool. Load it if it is not present, otherwise return it. 78-- Lookup the given resource in the data pool. Load it if it is not present, otherwise return it.
91loadResource :: String -- ^ Resource name. 79loadResource :: String -- ^ Resource name.
92 -> (SceneResources -> Map String a) -- ^ Map getter. 80 -> (SceneResources -> Map String a) -- ^ Map getter.
93 -> (String -> a -> Loader ()) -- ^ Function to modify resources. 81 -> (String -> a -> Loader ()) -- ^ Function to modify resources.
94 -> Setup a -- ^ Resource loader. 82 -> Loader a -- ^ Resource loader.
95 -> Loader a 83 -> Loader a
96loadResource key field modifyResources load = do 84loadResource key field modifyResources load = do
97 sceneData <- get 85 sceneData <- get
98 case M.lookup key $ field sceneData of 86 case M.lookup key $ field sceneData of
99 Just val -> return val 87 Just val -> return val
100 Nothing -> do 88 Nothing -> do
101 loaderIO $ printf "Loading %s..." key 89 gameIO $ printf "Loading %s..." key
102 resource <- loaderSetup load 90 resource <- load
103 loaderIO $ printf "done\n" 91 gameIO $ printf "done\n"
104 modifyResources key resource 92 modifyResources key resource
105 return resource 93 return resource
106 94
107
108addShader name shader = modify $ \sceneData -> 95addShader name shader = modify $ \sceneData ->
109 sceneData { shaders = M.insert name shader $ shaders sceneData } 96 sceneData { shaders = M.insert name shader $ shaders sceneData }
110 97
111
112addCustomProgram name prog = modify $ \sceneData -> 98addCustomProgram name prog = modify $ \sceneData ->
113 sceneData { customPrograms = M.insert name prog $ customPrograms sceneData } 99 sceneData { customPrograms = M.insert name prog $ customPrograms sceneData }
114 100
115
116addStaticProgram name prog = modify $ \sceneData -> 101addStaticProgram name prog = modify $ \sceneData ->
117 sceneData { staticPrograms = M.insert name prog $ staticPrograms sceneData } 102 sceneData { staticPrograms = M.insert name prog $ staticPrograms sceneData }
118 103
119
120addAnimatedProgram name prog = modify $ \sceneData -> 104addAnimatedProgram name prog = modify $ \sceneData ->
121 sceneData { animatedPrograms = M.insert name prog $ animatedPrograms sceneData } 105 sceneData { animatedPrograms = M.insert name prog $ animatedPrograms sceneData }
122 106
123
124addTexture name tex = modify $ \sceneData -> 107addTexture name tex = modify $ \sceneData ->
125 sceneData { textures = M.insert name tex $ textures sceneData } 108 sceneData { textures = M.insert name tex $ textures sceneData }
126 109
127
128addStaticModel name model = modify $ 110addStaticModel name model = modify $
129 \sceneData -> sceneData { staticModels = M.insert name model $ staticModels sceneData } 111 \sceneData -> sceneData { staticModels = M.insert name model $ staticModels sceneData }
130 112
131
132addAnimatedModel name model = modify $ 113addAnimatedModel name model = modify $
133 \sceneData -> sceneData { animatedModels = M.insert name model $ animatedModels sceneData } 114 \sceneData -> sceneData { animatedModels = M.insert name model $ animatedModels sceneData }
134 115
135
136-- Get the given resource from the data pool. 116-- Get the given resource from the data pool.
137getResource :: (SceneResources -> Map String a) -> String -> Loader a 117getResource :: (SceneResources -> Map String a) -> String -> Loader a
138getResource field key = do 118getResource field key = do
139 sceneData <- get 119 sceneData <- get
140 case M.lookup key $ field sceneData of 120 case M.lookup key $ field sceneData of
141 Just val -> return val 121 Just val -> return val
142 Nothing -> loaderSetup . setupError $ "Oops, the given resource has not been loaded: " ++ key 122 Nothing -> gameError $ "Oops, the given resource has not been loaded: " ++ key
143
144
145
146 123
147---------------------- 124----------------------
148-- Resource Loading -- 125-- Resource Loading --
@@ -163,9 +140,9 @@ newModel (SceneLeaf _ props) = do
163 let rotation = asRotation $ value "rotation" props 140 let rotation = asRotation $ value "rotation" props
164 scale = asVec3 $ value "scale" props 141 scale = asVec3 $ value "scale" props
165 142
166 loaderIO $ printf "Loading model %s..." name 143 gameIO $ printf "Loading model %s..." name
167 model <- loaderSetup $ loadModel' file rotation scale 144 model <- loadModel' file rotation scale
168 loaderIO . putStrLn $ "done" 145 gameIO . putStrLn $ "done"
169 texture <- loadTexture tex 146 texture <- loadTexture tex
170 sceneRes <- get 147 sceneRes <- get
171 148
@@ -174,25 +151,24 @@ newModel (SceneLeaf _ props) = do
174 case animated model of 151 case animated model of
175 False -> 152 False ->
176 case M.lookup prog $ staticPrograms sceneRes of 153 case M.lookup prog $ staticPrograms sceneRes of
177 Nothing -> (loaderError $ "Static shader program " ++ prog ++ " does not exist") >> return () 154 Nothing -> (gameError $ "Static shader program " ++ prog ++ " does not exist") >> return ()
178 Just p -> 155 Just p ->
179 let StaticProgram _ channels _ = p 156 let StaticProgram _ channels _ = p
180 in do 157 in do
181 model' <- loaderSetup $ staticModelResource channels material texture model 158 model' <- staticModelResource channels material texture model
182 loadResource name staticModels addStaticModel (return model') 159 loadResource name staticModels addStaticModel (return model')
183 return () 160 return ()
184 True -> 161 True ->
185 case M.lookup prog $ animatedPrograms sceneRes of 162 case M.lookup prog $ animatedPrograms sceneRes of
186 Nothing -> (loaderError $ "Animated shader program " ++ prog ++ " does not exist") >> return () 163 Nothing -> (gameError $ "Animated shader program " ++ prog ++ " does not exist") >> return ()
187 Just p -> 164 Just p ->
188 let AnimatedProgram _ channels _ = p 165 let AnimatedProgram _ channels _ = p
189 in do 166 in do
190 model' <- loaderSetup $ animatedModelResource channels material texture model 167 model' <- animatedModelResource channels material texture model
191 loadResource name animatedModels addAnimatedModel (return model') 168 loadResource name animatedModels addAnimatedModel (return model')
192 return () 169 return ()
193 170
194 171loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model
195loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Setup Model
196loadModel' file rotation scale = do 172loadModel' file rotation scale = do
197 let transform = 173 let transform =
198 (case rotation of 174 (case rotation of
@@ -204,8 +180,7 @@ loadModel' file rotation scale = do
204 Just s -> flip Model.transformVerts $ 180 Just s -> flip Model.transformVerts $
205 \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z')) 181 \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z'))
206 182
207 (fmap transform $ Model.loadModel file) >>= setupIO . toGround 183 (fmap transform $ Model.loadModel file) >>= gameIO . toGround
208
209 184
210rotateModel :: Rotation -> Model -> Model 185rotateModel :: Rotation -> Model -> Model
211rotateModel (Rotation ax ay az order) model = 186rotateModel (Rotation ax ay az order) model =
@@ -226,22 +201,20 @@ rotateModel (Rotation ax ay az order) model =
226 in 201 in
227 flip Model.transformVerts vTransform . flip Model.transformNormals nTransform $ model 202 flip Model.transformVerts vTransform . flip Model.transformNormals nTransform $ model
228 203
229
230loadTexture :: FilePath -> Loader GLSL.Texture 204loadTexture :: FilePath -> Loader GLSL.Texture
231loadTexture file = 205loadTexture file =
232 loadResource file textures addTexture $ 206 loadResource file textures addTexture $
233 GLSL.loadTextureImage file gl_LINEAR gl_LINEAR 207 GLSL.loadTextureImage file gl_LINEAR gl_LINEAR
234 208
235
236newShaderProgram :: SceneGraph -> Loader () 209newShaderProgram :: SceneGraph -> Loader ()
237newShaderProgram (SceneLeaf _ props) = do 210newShaderProgram (SceneLeaf _ props) = do
238 (vsName, vertShader) <- Spear.Scene.Loader.loadShader GLSL.VertexShader props 211 (vsName, vertShader) <- Spear.Scene.Loader.loadShader GLSL.VertexShader props
239 (fsName, fragShader) <- Spear.Scene.Loader.loadShader GLSL.FragmentShader props 212 (fsName, fragShader) <- Spear.Scene.Loader.loadShader GLSL.FragmentShader props
240 name <- asString $ mandatory' "name" props 213 name <- asString $ mandatory' "name" props
241 stype <- asString $ mandatory' "type" props 214 stype <- asString $ mandatory' "type" props
242 prog <- loaderSetup $ GLSL.newProgram [vertShader, fragShader] 215 prog <- GLSL.newProgram [vertShader, fragShader]
243 216
244 let getUniformLoc name = loaderSetup $ (setupIO . SV.get $ GLSL.uniformLocation prog name) `GLSL.assertGL` name 217 let getUniformLoc name = (gameIO . SV.get $ GLSL.uniformLocation prog name) `GLSL.assertGL` name
245 218
246 case stype of 219 case stype of
247 "static" -> do 220 "static" -> do
@@ -312,12 +285,8 @@ newShaderProgram (SceneLeaf _ props) = do
312 loadResource name customPrograms addCustomProgram $ return prog 285 loadResource name customPrograms addCustomProgram $ return prog
313 return () 286 return ()
314 287
315
316
317
318
319loadShader :: GLSL.ShaderType -> [Property] -> Loader (String, GLSL.GLSLShader) 288loadShader :: GLSL.ShaderType -> [Property] -> Loader (String, GLSL.GLSLShader)
320loadShader _ [] = loaderSetup . setupError $ "Loader::vertexShader: empty list" 289loadShader _ [] = gameError $ "Loader::vertexShader: empty list"
321loadShader shaderType ((stype, file):xs) = 290loadShader shaderType ((stype, file):xs) =
322 if shaderType == GLSL.VertexShader && stype == "vertex-shader" || 291 if shaderType == GLSL.VertexShader && stype == "vertex-shader" ||
323 shaderType == GLSL.FragmentShader && stype == "fragment-shader" 292 shaderType == GLSL.FragmentShader && stype == "fragment-shader"
@@ -325,22 +294,17 @@ loadShader shaderType ((stype, file):xs) =
325 in loadShader' f shaderType >>= \shader -> return (f, shader) 294 in loadShader' f shaderType >>= \shader -> return (f, shader)
326 else Spear.Scene.Loader.loadShader shaderType xs 295 else Spear.Scene.Loader.loadShader shaderType xs
327 296
328
329loadShader' :: String -> GLSL.ShaderType -> Loader GLSL.GLSLShader 297loadShader' :: String -> GLSL.ShaderType -> Loader GLSL.GLSLShader
330loadShader' file shaderType = loadResource file shaders addShader $ GLSL.loadShader file shaderType 298loadShader' file shaderType = loadResource file shaders addShader $ GLSL.loadShader file shaderType
331 299
332
333newLight :: SceneGraph -> Loader () 300newLight :: SceneGraph -> Loader ()
334newLight _ = return () 301newLight _ = return ()
335 302
336
337
338
339-------------------- 303--------------------
340-- Object Loading -- 304-- Object Loading --
341-------------------- 305--------------------
342 306
343loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Setup GameObject 307loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Game s GameObject
344loadGO style sceneRes props transf = do 308loadGO style sceneRes props transf = do
345 modelName <- asString . mandatory "model" $ props 309 modelName <- asString . mandatory "model" $ props
346 axis <- asVec3 . mandatory "axis" $ props 310 axis <- asVec3 . mandatory "axis" $ props
@@ -353,12 +317,11 @@ loadGO style sceneRes props transf = do
353 Just model -> 317 Just model ->
354 return $ goNew style (Left model) [] transf axis 318 return $ goNew style (Left model) [] transf axis
355 Nothing -> 319 Nothing ->
356 setupError $ "model " ++ modelName ++ " not found" 320 gameError $ "model " ++ modelName ++ " not found"
357 return $ case animSpeed of 321 return $ case animSpeed of
358 Nothing -> go 322 Nothing -> go
359 Just s -> GO.setAnimationSpeed s go 323 Just s -> GO.setAnimationSpeed s go
360 324
361
362type CreateGameObject m a 325type CreateGameObject m a
363 = String -- ^ The object's name. 326 = String -- ^ The object's name.
364 -> SceneResources 327 -> SceneResources
@@ -366,7 +329,6 @@ type CreateGameObject m a
366 -> Matrix3 -- ^ The object's transform. 329 -> Matrix3 -- ^ The object's transform.
367 -> m a 330 -> m a
368 331
369
370-- | Load objects from the given 'SceneGraph'. 332-- | Load objects from the given 'SceneGraph'.
371loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a] 333loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a]
372loadObjects newGO sceneRes g = 334loadObjects newGO sceneRes g =
@@ -374,7 +336,6 @@ loadObjects newGO sceneRes g =
374 Nothing -> return [] 336 Nothing -> return []
375 Just n -> sequence . concat . fmap (newObject newGO sceneRes) $ children n 337 Just n -> sequence . concat . fmap (newObject newGO sceneRes) $ children n
376 338
377
378-- to-do: use a strict accumulator and make loadObjects tail recursive. 339-- to-do: use a strict accumulator and make loadObjects tail recursive.
379newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a] 340newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a]
380newObject newGO sceneRes (SceneNode nid props children) = 341newObject newGO sceneRes (SceneNode nid props children) =
@@ -383,7 +344,6 @@ newObject newGO sceneRes (SceneNode nid props children) =
383 344
384newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props] 345newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props]
385 346
386
387newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a 347newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a
388newObject' newGO sceneRes nid props = do 348newObject' newGO sceneRes nid props = do
389 -- Optional properties. 349 -- Optional properties.
@@ -399,15 +359,11 @@ newObject' newGO sceneRes nid props = do
399 359
400 newGO goType sceneRes props (M3.transform right up position) 360 newGO goType sceneRes props (M3.transform right up position)
401 361
402
403vectors :: Maybe Vector2 -> (Vector2, Vector2) 362vectors :: Maybe Vector2 -> (Vector2, Vector2)
404vectors up = case up of 363vectors up = case up of
405 Nothing -> (unitx2, unity2) 364 Nothing -> (unitx2, unity2)
406 Just u -> (perp u, u) 365 Just u -> (perp u, u)
407 366
408
409
410
411---------------------- 367----------------------
412-- Helper functions -- 368-- Helper functions --
413---------------------- 369----------------------
@@ -418,53 +374,43 @@ value name props = case L.find ((==) name . fst) props of
418 Nothing -> Nothing 374 Nothing -> Nothing
419 Just prop -> Just . snd $ prop 375 Just prop -> Just . snd $ prop
420 376
421
422unspecified :: Maybe a -> a -> a 377unspecified :: Maybe a -> a -> a
423unspecified (Just x) _ = x 378unspecified (Just x) _ = x
424unspecified Nothing x = x 379unspecified Nothing x = x
425 380
426 381mandatory :: String -> [Property] -> Game s [String]
427mandatory :: String -> [Property] -> Setup [String]
428mandatory name props = case value name props of 382mandatory name props = case value name props of
429 Nothing -> setupError $ "Loader::mandatory: key not found: " ++ name 383 Nothing -> gameError $ "Loader::mandatory: key not found: " ++ name
430 Just x -> return x 384 Just x -> return x
431 385
432
433mandatory' :: String -> [Property] -> Loader [String] 386mandatory' :: String -> [Property] -> Loader [String]
434mandatory' name props = loaderSetup $ mandatory name props 387mandatory' name props = mandatory name props
435
436 388
437asString :: Functor f => f [String] -> f String 389asString :: Functor f => f [String] -> f String
438asString = fmap concat 390asString = fmap concat
439 391
440
441asFloat :: Functor f => f [String] -> f Float 392asFloat :: Functor f => f [String] -> f Float
442asFloat = fmap (read . concat) 393asFloat = fmap (read . concat)
443 394
444
445asVec2 :: Functor f => f [String] -> f Vector2 395asVec2 :: Functor f => f [String] -> f Vector2
446asVec2 val = fmap toVec2 val 396asVec2 val = fmap toVec2 val
447 where toVec2 (x:y:_) = vec2 (read x) (read y) 397 where toVec2 (x:y:_) = vec2 (read x) (read y)
448 toVec2 (x:[]) = let x' = read x in vec2 x' x' 398 toVec2 (x:[]) = let x' = read x in vec2 x' x'
449 399
450
451asVec3 :: Functor f => f [String] -> f Vector3 400asVec3 :: Functor f => f [String] -> f Vector3
452asVec3 val = fmap toVec3 val 401asVec3 val = fmap toVec3 val
453 where toVec3 (x:y:z:_) = vec3 (read x) (read y) (read z) 402 where toVec3 (x:y:z:_) = vec3 (read x) (read y) (read z)
454 toVec3 (x:[]) = let x' = read x in vec3 x' x' x' 403 toVec3 (x:[]) = let x' = read x in vec3 x' x' x'
455 404
456
457asVec4 :: Functor f => f [String] -> f Vector4 405asVec4 :: Functor f => f [String] -> f Vector4
458asVec4 val = fmap toVec4 val 406asVec4 val = fmap toVec4 val
459 where toVec4 (x:y:z:w:_) = vec4 (read x) (read y) (read z) (read w) 407 where toVec4 (x:y:z:w:_) = vec4 (read x) (read y) (read z) (read w)
460 toVec4 (x:[]) = let x' = read x in vec4 x' x' x' x' 408 toVec4 (x:[]) = let x' = read x in vec4 x' x' x' x'
461 409
462
463asRotation :: Functor f => f [String] -> f Rotation 410asRotation :: Functor f => f [String] -> f Rotation
464asRotation val = fmap parseRotation val 411asRotation val = fmap parseRotation val
465 where parseRotation (ax:ay:az:order:_) = Rotation (read ax) (read ay) (read az) (readOrder order) 412 where parseRotation (ax:ay:az:order:_) = Rotation (read ax) (read ay) (read az) (readOrder order)
466 413
467
468data Rotation = Rotation 414data Rotation = Rotation
469 { ax :: Float 415 { ax :: Float
470 , ay :: Float 416 , ay :: Float
@@ -472,10 +418,8 @@ data Rotation = Rotation
472 , order :: RotationOrder 418 , order :: RotationOrder
473 } 419 }
474 420
475
476data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq 421data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq
477 422
478
479readOrder :: String -> RotationOrder 423readOrder :: String -> RotationOrder
480readOrder "xyz" = XYZ 424readOrder "xyz" = XYZ
481readOrder "xzy" = XZY 425readOrder "xzy" = XZY
diff --git a/Spear/Setup.hs b/Spear/Setup.hs
deleted file mode 100644
index 0326c4b..0000000
--- a/Spear/Setup.hs
+++ /dev/null
@@ -1,59 +0,0 @@
1module Spear.Setup
2(
3 Setup
4, Resource
5, register
6, release
7, runSetup
8, runSetup_
9, setupError
10, setupIO
11, assertMaybe
12)
13where
14
15
16import Control.Monad.Error
17import qualified Control.Monad.Trans.Resource as R
18import qualified Control.Monad.Trans.Class as MT (lift)
19
20
21type Setup = R.ResourceT (ErrorT String IO)
22
23type Resource = R.ReleaseKey
24
25
26-- | Register the given cleaner.
27register :: IO () -> Setup Resource
28register = R.register
29
30
31-- | Release the given 'Resource'.
32release :: Resource -> Setup ()
33release = R.release
34
35
36-- | Run the given 'Setup', freeing all of its allocated resources.
37runSetup :: Setup a -> IO (Either String a)
38runSetup = runErrorT . R.runResourceT
39
40
41-- | Run the given 'Setup', freeing all of its allocated resources.
42runSetup_ :: Setup a -> IO ()
43runSetup_ s = (runErrorT . R.runResourceT) s >> return ()
44
45
46-- | Throw an error from the 'Setup' monad.
47setupError :: String -> Setup a
48setupError = MT.lift . throwError
49
50
51-- | Lift the given IO action into the 'Setup' monad.
52setupIO :: IO a -> Setup a
53setupIO = MT.lift . MT.lift
54
55
56-- | Throw the given error string if given 'Nothing'.
57assertMaybe :: Maybe a -> String -> Setup a
58assertMaybe Nothing err = setupError err
59assertMaybe (Just x) _ = return x