diff options
author | Jeanne-Kamikaze <jeannekamikaze@gmail.com> | 2013-02-22 14:01:28 +0100 |
---|---|---|
committer | Jeanne-Kamikaze <jeannekamikaze@gmail.com> | 2013-02-22 14:01:28 +0100 |
commit | 594e76d1df5a2148387fced2730f3ec2d89a7814 (patch) | |
tree | fa08ecf8af33aa6138e13a5347d32c5f160102cf | |
parent | 701203611a58ef7c5a2b9872c73d84805cf69396 (diff) |
Merged Setup and Game
-rw-r--r-- | Spear.cabal | 2 | ||||
-rw-r--r-- | Spear/App/Application.hs | 38 | ||||
-rw-r--r-- | Spear/App/Input.hs | 10 | ||||
-rw-r--r-- | Spear/Assets/Image.hsc | 32 | ||||
-rw-r--r-- | Spear/Assets/Model.hsc | 51 | ||||
-rw-r--r-- | Spear/GLSL.hs | 195 | ||||
-rw-r--r-- | Spear/Game.hs | 72 | ||||
-rw-r--r-- | Spear/Math/Camera.hs | 4 | ||||
-rw-r--r-- | Spear/Render/AnimatedModel.hs | 45 | ||||
-rw-r--r-- | Spear/Render/Model.hsc | 9 | ||||
-rw-r--r-- | Spear/Render/StaticModel.hs | 39 | ||||
-rw-r--r-- | Spear/Scene/Loader.hs | 116 | ||||
-rw-r--r-- | Spear/Setup.hs | 59 |
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 | ) |
24 | where | 22 | where |
25 | 23 | ||
26 | |||
27 | import Spear.Game | 24 | import Spear.Game |
28 | import Spear.Setup | ||
29 | import Spear.Sys.Timer as Timer | 25 | import Spear.Sys.Timer as Timer |
30 | 26 | ||
31 | import Control.Applicative | 27 | import Control.Applicative |
@@ -37,25 +33,24 @@ import Graphics.Rendering.OpenGL as GL | |||
37 | import System.Exit | 33 | import System.Exit |
38 | import Unsafe.Coerce | 34 | import Unsafe.Coerce |
39 | 35 | ||
40 | |||
41 | -- | Window dimensions. | 36 | -- | Window dimensions. |
42 | type Dimensions = (Int, Int) | 37 | type 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). |
45 | type Context = (Int, Int) | 40 | type Context = (Int, Int) |
46 | 41 | ||
47 | |||
48 | -- | Represents a window. | 42 | -- | Represents a window. |
49 | newtype SpearWindow = SpearWindow { rkey :: Resource } | 43 | newtype SpearWindow = SpearWindow { rkey :: Resource } |
50 | 44 | ||
45 | instance ResourceClass SpearWindow where | ||
46 | getResource = rkey | ||
51 | 47 | ||
52 | -- | Set up an application 'SpearWindow'. | 48 | -- | Set up an application 'SpearWindow'. |
53 | setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context | 49 | setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context |
54 | -> WindowSizeCallback -> Setup SpearWindow | 50 | -> WindowSizeCallback -> Game s SpearWindow |
55 | setup (w, h) displayBits windowMode (major, minor) onResize' = do | 51 | setup (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 | 71 | glfwInit :: Game s () | |
77 | -- | Release the given 'SpearWindow'. | ||
78 | releaseWindow :: SpearWindow -> Setup () | ||
79 | releaseWindow = release . rkey | ||
80 | |||
81 | |||
82 | glfwInit :: Setup () | ||
83 | glfwInit = do | 72 | glfwInit = 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. |
91 | quit :: IO () | 79 | quit :: IO () |
92 | quit = GLFW.terminate | 80 | quit = 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. |
96 | type Update s = Float -> Game s (Bool) | 83 | type Update s = Float -> Game s (Bool) |
97 | 84 | ||
98 | |||
99 | -- | Run the application's main loop. | 85 | -- | Run the application's main loop. |
100 | run :: Update s -> Game s () | 86 | run :: Update s -> Game s () |
101 | run update = do | 87 | run update = do |
102 | timer <- gameIO $ start newTimer | 88 | timer <- gameIO $ start newTimer |
103 | run' timer update | 89 | run' timer update |
104 | 90 | ||
105 | |||
106 | run' :: Timer -> Update s -> Game s () | 91 | run' :: Timer -> Update s -> Game s () |
107 | run' timer update = do | 92 | run' 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. |
116 | runCapped :: Int -> Update s -> Game s () | 101 | runCapped :: Int -> Update s -> Game s () |
117 | runCapped maxFPS update = do | 102 | runCapped 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 | |||
123 | runCapped' :: Float -> Timer -> Update s -> Game s () | 107 | runCapped' :: Float -> Timer -> Update s -> Game s () |
124 | runCapped' ddt timer update = do | 108 | runCapped' 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 | |||
136 | onResize :: WindowSizeCallback -> Size -> IO () | 120 | onResize :: WindowSizeCallback -> Size -> IO () |
137 | onResize callback s@(Size w h) = do | 121 | onResize 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. | ||
138 | newInput :: Input | ||
139 | newInput = Input newKeyboard newMouse | ||
140 | |||
141 | |||
136 | -- | Get input devices. | 142 | -- | Get input devices. |
137 | getInput :: Input -> IO Input | 143 | getInput :: Input -> IO Input |
138 | getInput (Input _ oldMouse) = do | 144 | getInput (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 | ) |
16 | where | 15 | where |
17 | 16 | ||
18 | 17 | import Spear.Game | |
19 | import Spear.Setup | ||
20 | import Foreign.Ptr | 18 | import Foreign.Ptr |
21 | import Foreign.Storable | 19 | import Foreign.Storable |
22 | import Foreign.C.Types | 20 | import Foreign.C.Types |
@@ -26,11 +24,9 @@ import Foreign.Marshal.Alloc (alloca) | |||
26 | import Data.List (splitAt, elemIndex) | 24 | import Data.List (splitAt, elemIndex) |
27 | import Data.Char (toLower) | 25 | import 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 | |||
34 | data ImageErrorCode | 30 | data 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 | |||
44 | data CImage = CImage | 39 | data 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 | |||
52 | instance Storable CImage where | 46 | instance 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'. |
71 | data Image = Image | 64 | data Image = Image |
72 | { imageData :: CImage | 65 | { imageData :: CImage |
73 | , rkey :: Resource | 66 | , rkey :: Resource |
74 | } | 67 | } |
75 | 68 | ||
69 | instance ResourceClass Image where | ||
70 | getResource = rkey | ||
76 | 71 | ||
77 | foreign import ccall "Image.h image_free" | 72 | foreign import ccall "Image.h image_free" |
78 | image_free :: Ptr CImage -> IO () | 73 | image_free :: Ptr CImage -> IO () |
79 | 74 | ||
80 | |||
81 | foreign import ccall "BMP_load.h BMP_load" | 75 | foreign 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 | |||
85 | bmp_load :: Ptr CChar -> Ptr CImage -> IO ImageErrorCode | 78 | bmp_load :: Ptr CChar -> Ptr CImage -> IO ImageErrorCode |
86 | bmp_load file image = bmp_load' file image >>= \code -> return . toEnum $ code | 79 | bmp_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. |
90 | loadImage :: FilePath -> Setup Image | 82 | loadImage :: FilePath -> Game s Image |
91 | loadImage file = do | 83 | loadImage 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'. | ||
118 | releaseImage :: Image -> Setup () | ||
119 | releaseImage = release . rkey | ||
120 | |||
121 | 107 | ||
122 | -- | Free the given 'CImage'. | 108 | -- | Free the given 'CImage'. |
123 | freeImage :: CImage -> IO () | 109 | freeImage :: CImage -> IO () |
124 | freeImage image = Foreign.with image image_free | 110 | freeImage image = Foreign.with image image_free |
125 | 111 | ||
126 | |||
127 | -- | Return the given image's width. | 112 | -- | Return the given image's width. |
128 | width :: Image -> Int | 113 | width :: Image -> Int |
129 | width = fromIntegral . cwidth . imageData | 114 | width = fromIntegral . cwidth . imageData |
130 | 115 | ||
131 | |||
132 | -- | Return the given image's height. | 116 | -- | Return the given image's height. |
133 | height :: Image -> Int | 117 | height :: Image -> Int |
134 | height = fromIntegral . cheight . imageData | 118 | height = fromIntegral . cheight . imageData |
135 | 119 | ||
136 | |||
137 | -- | Return the given image's bits per pixel. | 120 | -- | Return the given image's bits per pixel. |
138 | bpp :: Image -> Int | 121 | bpp :: Image -> Int |
139 | bpp = fromIntegral . cbpp . imageData | 122 | bpp = fromIntegral . cbpp . imageData |
140 | 123 | ||
141 | |||
142 | -- | Return the given image's pixels. | 124 | -- | Return the given image's pixels. |
143 | pixels :: Image -> Ptr CUChar | 125 | pixels :: Image -> Ptr CUChar |
144 | pixels = cpixels . imageData | 126 | pixels = 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 | ) |
28 | where | 28 | where |
29 | 29 | ||
30 | 30 | import Spear.Game | |
31 | import Spear.Setup | ||
32 | |||
33 | 31 | ||
34 | import qualified Data.ByteString.Char8 as B | 32 | import qualified Data.ByteString.Char8 as B |
35 | import Data.Char (toLower) | 33 | import Data.Char (toLower) |
@@ -45,12 +43,10 @@ import Foreign.Marshal.Alloc (alloca, allocaBytes) | |||
45 | import Foreign.Marshal.Array (allocaArray, copyArray, peekArray) | 43 | import Foreign.Marshal.Array (allocaArray, copyArray, peekArray) |
46 | import Unsafe.Coerce (unsafeCoerce) | 44 | import 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 | |||
54 | data ModelErrorCode | 50 | data 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 | |||
64 | sizeFloat = #{size float} | 59 | sizeFloat = #{size float} |
65 | sizePtr = #{size int*} | 60 | sizePtr = #{size int*} |
66 | 61 | ||
67 | |||
68 | -- | A 2D vector. | 62 | -- | A 2D vector. |
69 | data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float | 63 | data Vec2 = Vec2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float |
70 | 64 | ||
71 | |||
72 | instance Storable Vec2 where | 65 | instance 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. |
87 | data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float | 79 | data Vec3 = Vec3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float |
88 | 80 | ||
89 | |||
90 | instance Storable Vec3 where | 81 | instance 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. |
107 | data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float | 97 | data TexCoord = TexCoord {-# UNPACK #-} !Float {-# UNPACK #-} !Float |
108 | 98 | ||
109 | |||
110 | instance Storable TexCoord where | 99 | instance 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. |
125 | data CTriangle = CTriangle | 113 | data 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 | |||
135 | instance Storable CTriangle where | 122 | instance 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. |
161 | data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3 | 147 | data Box = Box {-# UNPACK #-} !Vec3 {-# UNPACK #-} !Vec3 |
162 | 148 | ||
163 | |||
164 | instance Storable Box where | 149 | instance 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. |
187 | newtype Skin = Skin { skinName :: B.ByteString } | 171 | newtype Skin = Skin { skinName :: B.ByteString } |
188 | 172 | ||
189 | |||
190 | instance Storable Skin where | 173 | instance 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 | |||
212 | instance Storable Animation where | 193 | instance 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. |
229 | data Model = Model | 209 | data 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 | |||
245 | instance Storable Model where | 224 | instance 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 | |||
311 | instance Storable Triangle where | 288 | instance 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 | |||
339 | foreign import ccall "Model.h model_free" | 315 | foreign import ccall "Model.h model_free" |
340 | model_free :: Ptr Model -> IO () | 316 | model_free :: Ptr Model -> IO () |
341 | 317 | ||
342 | |||
343 | foreign import ccall "MD2_load.h MD2_load" | 318 | foreign 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 | |||
347 | foreign import ccall "OBJ_load.h OBJ_load" | 321 | foreign 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 | |||
351 | md2_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode | 324 | md2_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode |
352 | md2_load file clockwise leftHanded model = | 325 | md2_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 | |||
356 | obj_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode | 328 | obj_load :: Ptr CChar -> CChar -> CChar -> Ptr Model -> IO ModelErrorCode |
357 | obj_load file clockwise leftHanded model = | 329 | obj_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. |
362 | loadModel :: FilePath -> Setup Model | 333 | loadModel :: FilePath -> Game s Model |
363 | loadModel file = do | 334 | loadModel 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. |
394 | animated :: Model -> Bool | 364 | animated :: Model -> Bool |
395 | animated = (>1) . numFrames | 365 | animated = (>1) . numFrames |
396 | 366 | ||
397 | |||
398 | -- | Return the model's ith animation. | 367 | -- | Return the model's ith animation. |
399 | animation :: Model -> Int -> Animation | 368 | animation :: Model -> Int -> Animation |
400 | animation model i = animations model S.! i | 369 | animation 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. |
404 | animationByName :: Model -> String -> Maybe Animation | 372 | animationByName :: Model -> String -> Maybe Animation |
405 | animationByName model anim = | 373 | animationByName 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. |
410 | triangles' :: Model -> IO [Triangle] | 377 | triangles' :: Model -> IO [Triangle] |
411 | triangles' model = | 378 | triangles' 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 | |||
420 | foreign import ccall "Model.h model_copy_triangles" | 386 | foreign 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. |
425 | transformVerts :: Model -> (Vec3 -> Vec3) -> Model | 390 | transformVerts :: Model -> (Vec3 -> Vec3) -> Model |
426 | transformVerts model f = model { vertices = vertices' } | 391 | transformVerts 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. |
434 | transformNormals :: Model -> (Vec3 -> Vec3) -> Model | 398 | transformNormals :: Model -> (Vec3 -> Vec3) -> Model |
435 | transformNormals model f = model { normals = normals' } | 399 | transformNormals 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. |
443 | toGround :: Model -> IO Model | 406 | toGround :: Model -> IO Model |
444 | toGround model = | 407 | toGround 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 | |||
451 | foreign import ccall "Model.h model_to_ground" | 413 | foreign 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. |
456 | modelBoxes :: Model -> IO (V.Vector Box) | 417 | modelBoxes :: Model -> IO (V.Vector Box) |
457 | modelBoxes model = | 418 | modelBoxes 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 | ||
480 | foreign import ccall "Model.h model_compute_boxes" | 439 | foreign 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 | ) |
90 | where | 81 | where |
91 | 82 | ||
92 | |||
93 | import Spear.Assets.Image | 83 | import Spear.Assets.Image |
84 | import Spear.Game | ||
94 | import Spear.Math.Matrix3 (Matrix3) | 85 | import Spear.Math.Matrix3 (Matrix3) |
95 | import Spear.Math.Matrix4 (Matrix4) | 86 | import Spear.Math.Matrix4 (Matrix4) |
96 | import Spear.Math.Vector | 87 | import Spear.Math.Vector |
97 | import Spear.Setup | ||
98 | 88 | ||
99 | import Control.Monad | 89 | import Control.Monad |
100 | import Control.Monad.Trans.Class | 90 | import Control.Monad.Trans.Class |
@@ -114,47 +104,45 @@ import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory | |||
114 | import System.IO (hPutStrLn, stderr) | 104 | import System.IO (hPutStrLn, stderr) |
115 | import Unsafe.Coerce | 105 | import 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. |
124 | data GLSLShader = GLSLShader | 112 | data GLSLShader = GLSLShader |
125 | { getShader :: GLuint | 113 | { getShader :: GLuint |
126 | , getShaderKey :: Resource | 114 | , getShaderKey :: Resource |
127 | } | 115 | } |
128 | 116 | ||
117 | instance ResourceClass GLSLShader where | ||
118 | getResource = getShaderKey | ||
129 | 119 | ||
130 | -- | A GLSL program handle. | 120 | -- | A GLSL program handle. |
131 | data GLSLProgram = GLSLProgram | 121 | data GLSLProgram = GLSLProgram |
132 | { getProgram :: GLuint | 122 | { getProgram :: GLuint |
133 | , getProgramKey :: Resource | 123 | , getProgramKey :: Resource |
134 | } | 124 | } |
135 | 125 | ||
136 | 126 | instance ResourceClass GLSLProgram where | |
127 | getResource = getProgramKey | ||
128 | |||
137 | -- | Supported shader types. | 129 | -- | Supported shader types. |
138 | data ShaderType = VertexShader | FragmentShader deriving (Eq, Show) | 130 | data ShaderType = VertexShader | FragmentShader deriving (Eq, Show) |
139 | 131 | ||
140 | |||
141 | toGLShader :: ShaderType -> GLenum | 132 | toGLShader :: ShaderType -> GLenum |
142 | toGLShader VertexShader = gl_VERTEX_SHADER | 133 | toGLShader VertexShader = gl_VERTEX_SHADER |
143 | toGLShader FragmentShader = gl_FRAGMENT_SHADER | 134 | toGLShader 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. |
147 | withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a | 137 | withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a |
148 | withGLSLProgram prog f = f $ getProgram prog | 138 | withGLSLProgram 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. |
152 | uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint | 141 | uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint |
153 | uniformLocation prog var = makeGettableStateVar get | 142 | uniformLocation 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. |
159 | fragLocation :: GLSLProgram -> String -> StateVar GLint | 147 | fragLocation :: GLSLProgram -> String -> StateVar GLint |
160 | fragLocation prog var = makeStateVar get set | 148 | fragLocation 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. |
168 | attribLocation :: GLSLProgram -> String -> StateVar GLint | 155 | attribLocation :: GLSLProgram -> String -> StateVar GLint |
169 | attribLocation prog var = makeStateVar get set | 156 | attribLocation 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. |
177 | newProgram :: [GLSLShader] -> Setup GLSLProgram | 163 | newProgram :: [GLSLShader] -> Game s GLSLProgram |
178 | newProgram shaders = do | 164 | newProgram 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. | ||
191 | releaseProgram :: GLSLProgram -> Setup () | ||
192 | releaseProgram = release . getProgramKey | ||
193 | |||
194 | |||
195 | -- | Delete the program. | 175 | -- | Delete the program. |
196 | deleteProgram :: GLuint -> IO () | 176 | deleteProgram :: 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. |
204 | linkProgram :: GLSLProgram -> Setup () | 183 | linkProgram :: GLSLProgram -> Game s () |
205 | linkProgram prog = do | 184 | linkProgram 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. |
222 | useProgram :: GLSLProgram -> IO () | 200 | useProgram :: GLSLProgram -> IO () |
223 | useProgram prog = glUseProgram $ getProgram prog | 201 | useProgram 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. |
227 | attachShader :: GLSLProgram -> GLSLShader -> IO () | 204 | attachShader :: GLSLProgram -> GLSLShader -> IO () |
228 | attachShader prog shader = glAttachShader (getProgram prog) (getShader shader) | 205 | attachShader 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. |
232 | detachShader :: GLSLProgram -> GLSLShader -> IO () | 208 | detachShader :: GLSLProgram -> GLSLShader -> IO () |
233 | detachShader prog shader = glDetachShader (getProgram prog) (getShader shader) | 209 | detachShader 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'. |
240 | loadShader :: FilePath -> ShaderType -> Setup GLSLShader | 215 | loadShader :: FilePath -> ShaderType -> Game s GLSLShader |
241 | loadShader file shaderType = do | 216 | loadShader 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. |
249 | newShader :: ShaderType -> Setup GLSLShader | 223 | newShader :: ShaderType -> Game s GLSLShader |
250 | newShader shaderType = do | 224 | newShader 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. | ||
260 | releaseShader :: GLSLShader -> Setup () | ||
261 | releaseShader = release . getShaderKey | ||
262 | |||
263 | |||
264 | -- | Free the shader. | 232 | -- | Free the shader. |
265 | deleteShader :: GLuint -> IO () | 233 | deleteShader :: 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. |
274 | loadSource :: FilePath -> GLSLShader -> Setup () | 241 | loadSource :: FilePath -> GLSLShader -> Game s () |
275 | loadSource file h = do | 242 | loadSource 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. |
285 | shaderSource :: GLSLShader -> CString -> IO () | 251 | shaderSource :: GLSLShader -> CString -> IO () |
286 | shaderSource shader str = | 252 | shaderSource 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. |
292 | compile :: FilePath -> GLSLShader -> Setup () | 257 | compile :: FilePath -> GLSLShader -> Game s () |
293 | compile file shader = do | 258 | compile 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 | ||
312 | type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () | 276 | type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () |
313 | type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () | 277 | type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () |
314 | 278 | ||
315 | |||
316 | getStatus :: StatusCall -> LogCall -> GLuint -> IO String | 279 | getStatus :: StatusCall -> LogCall -> GLuint -> IO String |
317 | getStatus getStatus getLog h = do | 280 | getStatus 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 | |||
326 | getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String | 288 | getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String |
327 | getErrorString getLog h len str = do | 289 | getErrorString 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 | |||
337 | readSource :: FilePath -> IO String | 298 | readSource :: FilePath -> IO String |
338 | readSource = fmap B.unpack . readSource' | 299 | readSource = fmap B.unpack . readSource' |
339 | 300 | ||
340 | |||
341 | readSource' :: FilePath -> IO B.ByteString | 301 | readSource' :: FilePath -> IO B.ByteString |
342 | readSource' file = do | 302 | readSource' 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. |
370 | uniformVec2 :: GLint -> Vector2 -> IO () | 329 | uniformVec2 :: GLint -> Vector2 -> IO () |
371 | uniformVec2 loc v = glUniform2f loc x' y' | 330 | uniformVec2 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. |
377 | uniformVec3 :: GLint -> Vector3 -> IO () | 335 | uniformVec3 :: GLint -> Vector3 -> IO () |
378 | uniformVec3 loc v = glUniform3f loc x' y' z' | 336 | uniformVec3 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. |
385 | uniformVec4 :: GLint -> Vector4 -> IO () | 342 | uniformVec4 :: GLint -> Vector4 -> IO () |
386 | uniformVec4 loc v = glUniform4f loc x' y' z' w' | 343 | uniformVec4 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. |
394 | uniformMat3 :: GLint -> Matrix3 -> IO () | 350 | uniformMat3 :: GLint -> Matrix3 -> IO () |
395 | uniformMat3 loc mat = | 351 | uniformMat3 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. |
401 | uniformMat4 :: GLint -> Matrix4 -> IO () | 356 | uniformMat4 :: GLint -> Matrix4 -> IO () |
402 | uniformMat4 loc mat = | 357 | uniformMat4 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. |
408 | uniformfl :: GLint -> [GLfloat] -> IO () | 362 | uniformfl :: GLint -> [GLfloat] -> IO () |
409 | uniformfl loc vals = withArray vals $ \ptr -> | 363 | uniformfl 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. |
418 | uniformil :: GLint -> [GLint] -> IO () | 371 | uniformil :: GLint -> [GLint] -> IO () |
419 | uniformil loc vals = withArray vals $ \ptr -> | 372 | uniformil 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. |
437 | data VAO = VAO | 384 | data VAO = VAO |
438 | { getVAO :: GLuint | 385 | { getVAO :: GLuint |
439 | , vaoKey :: Resource | 386 | , vaoKey :: Resource |
440 | } | 387 | } |
441 | 388 | ||
389 | instance ResourceClass VAO where | ||
390 | getResource = vaoKey | ||
442 | 391 | ||
443 | instance Eq VAO where | 392 | instance Eq VAO where |
444 | vao1 == vao2 = getVAO vao1 == getVAO vao2 | 393 | vao1 == vao2 = getVAO vao1 == getVAO vao2 |
445 | 394 | ||
446 | |||
447 | instance Ord VAO where | 395 | instance 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. |
452 | newVAO :: Setup VAO | 399 | newVAO :: Game s VAO |
453 | newVAO = do | 400 | newVAO = 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. | ||
463 | releaseVAO :: VAO -> Setup () | ||
464 | releaseVAO = release . vaoKey | ||
465 | |||
466 | |||
467 | -- | Delete the vao. | 408 | -- | Delete the vao. |
468 | deleteVAO :: GLuint -> IO () | 409 | deleteVAO :: GLuint -> IO () |
469 | deleteVAO vao = Foreign.with vao $ glDeleteVertexArrays 1 | 410 | deleteVAO vao = Foreign.with vao $ glDeleteVertexArrays 1 |
470 | 411 | ||
471 | |||
472 | -- | Bind the vao. | 412 | -- | Bind the vao. |
473 | bindVAO :: VAO -> IO () | 413 | bindVAO :: VAO -> IO () |
474 | bindVAO = glBindVertexArray . getVAO | 414 | bindVAO = 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'. |
480 | enableVAOAttrib :: GLuint -- ^ Attribute index. | 419 | enableVAOAttrib :: GLuint -- ^ Attribute index. |
481 | -> IO () | 420 | -> IO () |
482 | enableVAOAttrib = glEnableVertexAttribArray | 421 | enableVAOAttrib = glEnableVertexAttribArray |
483 | 422 | ||
484 | |||
485 | -- | Bind the bound buffer to the given point. | 423 | -- | Bind the bound buffer to the given point. |
486 | attribVAOPointer | 424 | attribVAOPointer |
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 | |||
494 | attribVAOPointer idx ncomp dattype normalise stride off = | 432 | attribVAOPointer 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. |
499 | drawArrays | 436 | drawArrays |
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 () |
504 | drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count) | 441 | drawArrays 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. |
508 | drawElements | 444 | drawElements |
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 () |
514 | drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs | 450 | drawElements 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. |
527 | data GLBuffer = GLBuffer | 457 | data GLBuffer = GLBuffer |
528 | { getBuffer :: GLuint | 458 | { getBuffer :: GLuint |
529 | , rkey :: Resource | 459 | , rkey :: Resource |
530 | } | 460 | } |
531 | 461 | ||
462 | instance ResourceClass GLBuffer where | ||
463 | getResource = rkey | ||
532 | 464 | ||
533 | -- | The type of target buffer. | 465 | -- | The type of target buffer. |
534 | data TargetBuffer | 466 | data TargetBuffer |
@@ -538,14 +470,12 @@ data TargetBuffer | |||
538 | | PixelUnpackBuffer | 470 | | PixelUnpackBuffer |
539 | deriving (Eq, Show) | 471 | deriving (Eq, Show) |
540 | 472 | ||
541 | |||
542 | fromTarget :: TargetBuffer -> GLenum | 473 | fromTarget :: TargetBuffer -> GLenum |
543 | fromTarget ArrayBuffer = gl_ARRAY_BUFFER | 474 | fromTarget ArrayBuffer = gl_ARRAY_BUFFER |
544 | fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER | 475 | fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER |
545 | fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER | 476 | fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER |
546 | fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER | 477 | fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER |
547 | 478 | ||
548 | |||
549 | -- | A buffer usage. | 479 | -- | A buffer usage. |
550 | data BufferUsage | 480 | data 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 | |||
563 | fromUsage :: BufferUsage -> GLenum | 492 | fromUsage :: BufferUsage -> GLenum |
564 | fromUsage StreamDraw = gl_STREAM_DRAW | 493 | fromUsage StreamDraw = gl_STREAM_DRAW |
565 | fromUsage StreamRead = gl_STREAM_READ | 494 | fromUsage StreamRead = gl_STREAM_READ |
@@ -571,33 +500,24 @@ fromUsage DynamicDraw = gl_DYNAMIC_DRAW | |||
571 | fromUsage DynamicRead = gl_DYNAMIC_READ | 500 | fromUsage DynamicRead = gl_DYNAMIC_READ |
572 | fromUsage DynamicCopy = gl_DYNAMIC_COPY | 501 | fromUsage DynamicCopy = gl_DYNAMIC_COPY |
573 | 502 | ||
574 | |||
575 | -- | Create a new buffer. | 503 | -- | Create a new buffer. |
576 | newBuffer :: Setup GLBuffer | 504 | newBuffer :: Game s GLBuffer |
577 | newBuffer = do | 505 | newBuffer = 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. | ||
587 | releaseBuffer :: GLBuffer -> Setup () | ||
588 | releaseBuffer = release . rkey | ||
589 | |||
590 | |||
591 | -- | Delete the buffer. | 513 | -- | Delete the buffer. |
592 | deleteBuffer :: GLuint -> IO () | 514 | deleteBuffer :: GLuint -> IO () |
593 | deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1 | 515 | deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1 |
594 | 516 | ||
595 | |||
596 | -- | Bind the buffer. | 517 | -- | Bind the buffer. |
597 | bindBuffer :: GLBuffer -> TargetBuffer -> IO () | 518 | bindBuffer :: GLBuffer -> TargetBuffer -> IO () |
598 | bindBuffer buf target = glBindBuffer (fromTarget target) $ getBuffer buf | 519 | bindBuffer buf target = glBindBuffer (fromTarget target) $ getBuffer buf |
599 | 520 | ||
600 | |||
601 | -- | Set the buffer's data. | 521 | -- | Set the buffer's data. |
602 | bufferData :: TargetBuffer | 522 | bufferData :: TargetBuffer |
603 | -> Int -- ^ Buffer size in bytes. | 523 | -> Int -- ^ Buffer size in bytes. |
@@ -606,7 +526,6 @@ bufferData :: TargetBuffer | |||
606 | -> IO () | 526 | -> IO () |
607 | bufferData target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage) | 527 | bufferData 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. |
611 | bufferDatal :: Storable a | 530 | bufferDatal :: Storable a |
612 | => TargetBuffer | 531 | => TargetBuffer |
@@ -617,16 +536,10 @@ bufferDatal :: Storable a | |||
617 | bufferDatal target n bufData usage = withArray bufData $ | 536 | bufferDatal 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. |
622 | withGLBuffer :: GLBuffer -> (GLuint -> a) -> a | 540 | withGLBuffer :: GLBuffer -> (GLuint -> a) -> a |
623 | withGLBuffer buf f = f $ getBuffer buf | 541 | withGLBuffer 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 | |||
641 | instance Eq Texture where | 553 | instance Eq Texture where |
642 | t1 == t2 = getTex t1 == getTex t2 | 554 | t1 == t2 = getTex t1 == getTex t2 |
643 | 555 | ||
644 | |||
645 | instance Ord Texture where | 556 | instance Ord Texture where |
646 | t1 < t2 = getTex t1 < getTex t2 | 557 | t1 < t2 = getTex t1 < getTex t2 |
647 | 558 | ||
559 | instance ResourceClass Texture where | ||
560 | getResource = texKey | ||
648 | 561 | ||
649 | -- | Create a new texture. | 562 | -- | Create a new texture. |
650 | newTexture :: Setup Texture | 563 | newTexture :: Game s Texture |
651 | newTexture = do | 564 | newTexture = 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. | ||
661 | releaseTexture :: Texture -> Setup () | ||
662 | releaseTexture = release . texKey | ||
663 | |||
664 | |||
665 | -- | Delete the texture. | 572 | -- | Delete the texture. |
666 | deleteTexture :: GLuint -> IO () | 573 | deleteTexture :: 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. |
674 | loadTextureImage :: FilePath | 580 | loadTextureImage :: 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 |
678 | loadTextureImage file minFilter magFilter = do | 584 | loadTextureImage 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. |
696 | bindTexture :: Texture -> IO () | 601 | bindTexture :: Texture -> IO () |
697 | bindTexture = glBindTexture gl_TEXTURE_2D . getTex | 602 | bindTexture = 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. |
726 | texParami :: GLenum -> GLenum -> SettableStateVar GLenum | 629 | texParami :: GLenum -> GLenum -> SettableStateVar GLenum |
727 | texParami target param = makeSettableStateVar $ \val -> glTexParameteri target param $ fromIntegral . fromEnum $ val | 630 | texParami 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. |
731 | texParamf :: GLenum -> GLenum -> SettableStateVar Float | 633 | texParamf :: GLenum -> GLenum -> SettableStateVar Float |
732 | texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val) | 634 | texParamf target param = makeSettableStateVar $ \val -> glTexParameterf target param (unsafeCoerce val) |
733 | 635 | ||
734 | |||
735 | -- | Set the active texture unit. | 636 | -- | Set the active texture unit. |
736 | activeTexture :: SettableStateVar GLenum | 637 | activeTexture :: SettableStateVar GLenum |
737 | activeTexture = makeSettableStateVar glActiveTexture | 638 | activeTexture = 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. |
750 | getGLError :: IO (Maybe String) | 645 | getGLError :: IO (Maybe String) |
751 | getGLError = fmap translate glGetError | 646 | getGLError = 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. |
763 | printGLError :: IO () | 657 | printGLError :: IO () |
764 | printGLError = getGLError >>= \err -> case err of | 658 | printGLError = 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. |
773 | assertGL :: Setup a -> String -> Setup a | 666 | assertGL :: Game s a -> String -> Game s a |
774 | assertGL action err = do | 667 | assertGL 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 @@ | |||
1 | module Spear.Game | 1 | module 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 | ) |
10 | where | 22 | where |
11 | 23 | ||
12 | |||
13 | import Control.Monad.Trans.Class (lift) | 24 | import Control.Monad.Trans.Class (lift) |
14 | import Control.Monad.State.Strict | 25 | import Control.Monad.State.Strict |
26 | import Control.Monad.Error | ||
27 | import qualified Control.Monad.Trans.Resource as R | ||
15 | 28 | ||
29 | type Resource = R.ReleaseKey | ||
30 | type Game s = StateT s (R.ResourceT (ErrorT String IO)) | ||
16 | 31 | ||
17 | type Game s = StateT s IO | 32 | class 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 () |
21 | gameIO :: IO a -> Game s a | 36 | release = unregister . getResource |
22 | gameIO = lift | 37 | |
23 | 38 | clean :: a -> IO () | |
39 | clean = R.release . getResource | ||
24 | 40 | ||
25 | -- | Retrieve the game state. | 41 | -- | Retrieve the game state. |
26 | getGameState :: Game s s | 42 | getGameState :: Game s s |
27 | getGameState = get | 43 | getGameState = get |
28 | 44 | ||
29 | |||
30 | -- | Save the game state. | 45 | -- | Save the game state. |
31 | saveGameState :: s -> Game s () | 46 | saveGameState :: s -> Game s () |
32 | saveGameState = put | 47 | saveGameState = put |
33 | 48 | ||
34 | |||
35 | -- | Modify the game state. | 49 | -- | Modify the game state. |
36 | modifyGameState :: (s -> s) -> Game s () | 50 | modifyGameState :: (s -> s) -> Game s () |
37 | modifyGameState = modify | 51 | modifyGameState = modify |
38 | 52 | ||
53 | -- | Register the given cleaner. | ||
54 | register :: IO () -> Game s Resource | ||
55 | register = lift . R.register | ||
56 | |||
57 | -- | Release the given 'Resource'. | ||
58 | unregister :: Resource -> Game s () | ||
59 | unregister = lift . R.release | ||
60 | |||
61 | -- | Throw an error from the 'Game' monad. | ||
62 | gameError :: String -> Game s a | ||
63 | gameError = lift . lift . throwError | ||
64 | |||
65 | -- | Throw the given error string if given 'Nothing'. | ||
66 | assertMaybe :: Maybe a -> String -> Game s a | ||
67 | assertMaybe Nothing err = gameError err | ||
68 | assertMaybe (Just x) _ = return x | ||
69 | |||
70 | -- | Run the given game. | ||
71 | runGame :: Game s a -> s -> IO (Either String (a,s)) | ||
72 | runGame game state = runErrorT . R.runResourceT . runStateT game $ state | ||
39 | 73 | ||
40 | -- | Run the given game. | 74 | -- | Run the given game. |
41 | runGame :: Game s a -> s -> IO () | 75 | runGame' :: Game s a -> s -> IO () |
42 | runGame game state = runStateT game state >> return () | 76 | runGame' game state = runGame game state >> return () |
77 | |||
78 | -- | Run the given game and return its result. | ||
79 | evalSubGame :: Game s a -> s -> Game t a | ||
80 | evalSubGame g s = lift $ evalStateT g s | ||
81 | |||
82 | -- | Run the given game and return its state. | ||
83 | execSubGame :: Game s a -> s -> Game t s | ||
84 | execSubGame g s = lift $ execStateT g s | ||
85 | |||
86 | -- | Perform the given IO action in the 'Game' monad. | ||
87 | gameIO :: IO a -> Game s a | ||
88 | gameIO = 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. | |||
27 | perspective fovy r n f right up fwd pos = | 27 | perspective 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. | |||
47 | ortho l r b t n f right up fwd pos = | 47 | ortho 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 | ) |
29 | where | 28 | where |
30 | 29 | ||
31 | |||
32 | import Spear.Assets.Model | 30 | import Spear.Assets.Model |
33 | import Spear.Collision | 31 | import Spear.Collision |
32 | import Spear.Game | ||
34 | import Spear.GLSL | 33 | import Spear.GLSL |
35 | import Spear.Math.AABB | 34 | import Spear.Math.AABB |
36 | import Spear.Math.Matrix4 (Matrix4) | 35 | import Spear.Math.Matrix4 (Matrix4) |
@@ -38,17 +37,14 @@ import Spear.Math.Vector | |||
38 | import Spear.Render.Material | 37 | import Spear.Render.Material |
39 | import Spear.Render.Model | 38 | import Spear.Render.Model |
40 | import Spear.Render.Program | 39 | import Spear.Render.Program |
41 | import Spear.Setup as Setup | ||
42 | 40 | ||
43 | import Control.Applicative ((<$>), (<*>)) | 41 | import Control.Applicative ((<$>), (<*>)) |
44 | import qualified Data.Vector as V | 42 | import qualified Data.Vector as V |
45 | import Graphics.Rendering.OpenGL.Raw.Core31 | 43 | import Graphics.Rendering.OpenGL.Raw.Core31 |
46 | import Unsafe.Coerce (unsafeCoerce) | 44 | import Unsafe.Coerce (unsafeCoerce) |
47 | 45 | ||
48 | |||
49 | type AnimationSpeed = Float | 46 | type 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 | |||
67 | instance Eq AnimatedModelResource where | 62 | instance Eq AnimatedModelResource where |
68 | m1 == m2 = vao m1 == vao m2 | 63 | m1 == m2 = vao m1 == vao m2 |
69 | 64 | ||
70 | |||
71 | instance Ord AnimatedModelResource where | 65 | instance Ord AnimatedModelResource where |
72 | m1 < m2 = vao m1 < vao m2 | 66 | m1 < m2 = vao m1 < vao m2 |
73 | 67 | ||
68 | instance 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 | |||
96 | instance Eq AnimatedModelRenderer where | 91 | instance Eq AnimatedModelRenderer where |
97 | m1 == m2 = modelResource m1 == modelResource m2 | 92 | m1 == m2 = modelResource m1 == modelResource m2 |
98 | 93 | ||
99 | |||
100 | instance Ord AnimatedModelRenderer where | 94 | instance 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. |
105 | animatedModelResource :: AnimatedProgramChannels | 98 | animatedModelResource :: AnimatedProgramChannels |
106 | -> Material | 99 | -> Material |
107 | -> Texture | 100 | -> Texture |
108 | -> Model | 101 | -> Model |
109 | -> Setup AnimatedModelResource | 102 | -> Game s AnimatedModelResource |
110 | 103 | ||
111 | animatedModelResource | 104 | animatedModelResource |
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. | ||
153 | release :: AnimatedModelResource -> Setup () | ||
154 | release = Setup.release . rkey | ||
155 | |||
156 | |||
157 | -- | Create a renderer from the given model resource. | 144 | -- | Create a renderer from the given model resource. |
158 | animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer | 145 | animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer |
159 | animatedModelRenderer animSpeed modelResource = | 146 | animatedModelRenderer 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. |
164 | update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) = | 150 | update 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. |
176 | box :: Int -> AnimatedModelResource -> Box | 161 | box :: Int -> AnimatedModelResource -> Box |
177 | box i model = boxes model V.! i | 162 | box i model = boxes model V.! i |
178 | 163 | ||
179 | |||
180 | -- | Get the renderer's current animation. | 164 | -- | Get the renderer's current animation. |
181 | currentAnimation :: Enum a => AnimatedModelRenderer -> a | 165 | currentAnimation :: Enum a => AnimatedModelRenderer -> a |
182 | currentAnimation = toEnum . currentAnim | 166 | currentAnimation = toEnum . currentAnim |
183 | 167 | ||
184 | |||
185 | -- | Get the renderer's model resource. | 168 | -- | Get the renderer's model resource. |
186 | modelRes :: AnimatedModelRenderer -> AnimatedModelResource | 169 | modelRes :: AnimatedModelRenderer -> AnimatedModelResource |
187 | modelRes = modelResource | 170 | modelRes = modelResource |
188 | 171 | ||
189 | |||
190 | -- | Get the renderer's next frame. | 172 | -- | Get the renderer's next frame. |
191 | nextFrame :: AnimatedModelRenderer -> Int | 173 | nextFrame :: AnimatedModelRenderer -> Int |
192 | nextFrame rend = | 174 | nextFrame 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. |
201 | setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer | 182 | setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer |
202 | setAnimation anim modelRend = | 183 | setAnimation 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. |
210 | setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer | 190 | setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer |
211 | setAnimationSpeed s r = r { animationSpeed = s } | 191 | setAnimationSpeed 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. |
215 | bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () | 194 | bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () |
216 | bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend = | 195 | bind (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. |
226 | render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () | 204 | render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () |
227 | render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) = | 205 | render 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. |
240 | mkColsFromAnimated | 217 | mkColsFromAnimated |
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 | ) |
8 | where | 8 | where |
9 | 9 | ||
10 | |||
11 | import qualified Spear.Assets.Model as Assets | 10 | import qualified Spear.Assets.Model as Assets |
12 | import Spear.Setup | 11 | import Spear.Game |
13 | 12 | ||
14 | import Foreign.Ptr | 13 | import Foreign.Ptr |
15 | import Foreign.C.Types | 14 | import Foreign.C.Types |
@@ -18,22 +17,18 @@ import Foreign.Marshal.Array | |||
18 | import Foreign.Marshal.Utils (with) | 17 | import Foreign.Marshal.Utils (with) |
19 | import Foreign.Storable | 18 | import Foreign.Storable |
20 | 19 | ||
21 | |||
22 | #include "RenderModel.h" | 20 | #include "RenderModel.h" |
23 | 21 | ||
24 | |||
25 | data Vec3 = Vec3 !CFloat !CFloat !CFloat | 22 | data Vec3 = Vec3 !CFloat !CFloat !CFloat |
26 | 23 | ||
27 | data TexCoord = TexCoord !CFloat !CFloat | 24 | data TexCoord = TexCoord !CFloat !CFloat |
28 | 25 | ||
29 | |||
30 | data RenderModel = RenderModel | 26 | data 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 | |||
37 | instance Storable RenderModel where | 32 | instance 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 | |||
53 | foreign import ccall "RenderModel.h render_model_from_model_asset" | 47 | foreign 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. |
58 | renderModelFromModel :: Assets.Model -> IO RenderModel | 51 | renderModelFromModel :: Assets.Model -> IO RenderModel |
59 | renderModelFromModel m = with m $ \mPtr -> alloca $ \mdPtr -> do | 52 | renderModelFromModel 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 | ) |
19 | where | 18 | where |
20 | 19 | ||
21 | |||
22 | import Spear.Assets.Model | 20 | import Spear.Assets.Model |
23 | import Spear.Collision | 21 | import Spear.Collision |
22 | import Spear.Game | ||
24 | import Spear.GLSL | 23 | import Spear.GLSL |
25 | import Spear.Math.AABB | 24 | import Spear.Math.AABB |
26 | import Spear.Math.Matrix4 (Matrix4) | 25 | import Spear.Math.Matrix4 (Matrix4) |
@@ -28,13 +27,11 @@ import Spear.Math.Vector | |||
28 | import Spear.Render.Material | 27 | import Spear.Render.Material |
29 | import Spear.Render.Model | 28 | import Spear.Render.Model |
30 | import Spear.Render.Program | 29 | import Spear.Render.Program |
31 | import Spear.Setup as Setup | ||
32 | 30 | ||
33 | import qualified Data.Vector as V | 31 | import qualified Data.Vector as V |
34 | import Graphics.Rendering.OpenGL.Raw.Core31 | 32 | import Graphics.Rendering.OpenGL.Raw.Core31 |
35 | import Unsafe.Coerce (unsafeCoerce) | 33 | import Unsafe.Coerce (unsafeCoerce) |
36 | 34 | ||
37 | |||
38 | data StaticModelResource = StaticModelResource | 35 | data 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 | |||
48 | instance Eq StaticModelResource where | 44 | instance Eq StaticModelResource where |
49 | m1 == m2 = vao m1 == vao m2 | 45 | m1 == m2 = vao m1 == vao m2 |
50 | 46 | ||
51 | |||
52 | instance Ord StaticModelResource where | 47 | instance Ord StaticModelResource where |
53 | m1 < m2 = vao m1 < vao m2 | 48 | m1 < m2 = vao m1 < vao m2 |
54 | 49 | ||
50 | instance ResourceClass StaticModelResource where | ||
51 | getResource = rkey | ||
55 | 52 | ||
56 | data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource } | 53 | data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource } |
57 | 54 | ||
58 | |||
59 | instance Eq StaticModelRenderer where | 55 | instance Eq StaticModelRenderer where |
60 | m1 == m2 = model m1 == model m2 | 56 | m1 == m2 = model m1 == model m2 |
61 | 57 | ||
62 | |||
63 | instance Ord StaticModelRenderer where | 58 | instance 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. |
68 | staticModelResource :: StaticProgramChannels | 62 | staticModelResource :: StaticProgramChannels |
69 | -> Material | 63 | -> Material |
70 | -> Texture | 64 | -> Texture |
71 | -> Model | 65 | -> Model |
72 | -> Setup StaticModelResource | 66 | -> Game s StaticModelResource |
73 | 67 | ||
74 | staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do | 68 | staticModelResource (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. | ||
109 | release :: StaticModelResource -> Setup () | ||
110 | release = Setup.release . rkey | ||
111 | |||
112 | |||
113 | -- | Create a renderer from the given model resource. | 101 | -- | Create a renderer from the given model resource. |
114 | staticModelRenderer :: StaticModelResource -> StaticModelRenderer | 102 | staticModelRenderer :: StaticModelResource -> StaticModelRenderer |
115 | staticModelRenderer = StaticModelRenderer | 103 | staticModelRenderer = StaticModelRenderer |
116 | 104 | ||
117 | |||
118 | -- | Get the model's ith bounding box. | 105 | -- | Get the model's ith bounding box. |
119 | box :: Int -> StaticModelResource -> Box | 106 | box :: Int -> StaticModelResource -> Box |
120 | box i model = boxes model V.! i | 107 | box i model = boxes model V.! i |
121 | 108 | ||
122 | |||
123 | -- | Get the renderer's model resource. | 109 | -- | Get the renderer's model resource. |
124 | modelRes :: StaticModelRenderer -> StaticModelResource | 110 | modelRes :: StaticModelRenderer -> StaticModelResource |
125 | modelRes = model | 111 | modelRes = model |
126 | 112 | ||
127 | |||
128 | -- | Bind the given renderer to prepare it for rendering. | 113 | -- | Bind the given renderer to prepare it for rendering. |
129 | bind :: StaticProgramUniforms -> StaticModelRenderer -> IO () | 114 | bind :: StaticProgramUniforms -> StaticModelRenderer -> IO () |
130 | bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) = | 115 | bind (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. |
140 | render :: StaticProgramUniforms -> StaticModelRenderer -> IO () | 124 | render :: StaticProgramUniforms -> StaticModelRenderer -> IO () |
141 | render uniforms (StaticModelRenderer model) = | 125 | render 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. |
152 | mkColsFromStatic | 135 | mkColsFromStatic |
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 | ) |
18 | where | 18 | where |
19 | 19 | ||
20 | |||
21 | import Spear.Assets.Model as Model | 20 | import Spear.Assets.Model as Model |
22 | import Spear.Collision | 21 | import Spear.Collision |
22 | import Spear.Game | ||
23 | import qualified Spear.GLSL as GLSL | 23 | import qualified Spear.GLSL as GLSL |
24 | import Spear.Math.Matrix3 as M3 | 24 | import Spear.Math.Matrix3 as M3 |
25 | import Spear.Math.Matrix4 as M4 | 25 | import Spear.Math.Matrix4 as M4 |
@@ -33,7 +33,6 @@ import Spear.Scene.GameObject as GO | |||
33 | import Spear.Scene.Graph | 33 | import Spear.Scene.Graph |
34 | import Spear.Scene.Light | 34 | import Spear.Scene.Light |
35 | import Spear.Scene.SceneResources | 35 | import Spear.Scene.SceneResources |
36 | import Spear.Setup | ||
37 | 36 | ||
38 | import Control.Monad.State.Strict | 37 | import Control.Monad.State.Strict |
39 | import Control.Monad.Trans (lift) | 38 | import Control.Monad.Trans (lift) |
@@ -43,37 +42,27 @@ import qualified Data.StateVar as SV (get) | |||
43 | import Graphics.Rendering.OpenGL.Raw.Core31 | 42 | import Graphics.Rendering.OpenGL.Raw.Core31 |
44 | import Text.Printf (printf) | 43 | import Text.Printf (printf) |
45 | 44 | ||
46 | 45 | type Loader = Game SceneResources | |
47 | type Loader = StateT SceneResources Setup | ||
48 | |||
49 | |||
50 | loaderSetup = lift | ||
51 | loaderIO = loaderSetup . setupIO | ||
52 | loaderError = loaderSetup . setupError | ||
53 | |||
54 | 46 | ||
55 | -- | Load the scene specified by the given file. | 47 | -- | Load the scene specified by the given file. |
56 | loadScene :: FilePath -> Setup (SceneResources, SceneGraph) | 48 | loadScene :: FilePath -> Game s (SceneResources, SceneGraph) |
57 | loadScene file = do | 49 | loadScene 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. |
69 | validate :: SceneGraph -> Maybe String | 60 | validate :: SceneGraph -> Maybe String |
70 | validate _ = Nothing | 61 | validate _ = Nothing |
71 | 62 | ||
72 | |||
73 | -- | Load the scene described by the given 'SceneGraph'. | 63 | -- | Load the scene described by the given 'SceneGraph'. |
74 | resourceMap :: SceneGraph -> Setup SceneResources | 64 | resourceMap :: SceneGraph -> Game s SceneResources |
75 | resourceMap g = execStateT (resourceMap' g) emptySceneResources | 65 | resourceMap g = execSubGame (resourceMap' g) emptySceneResources |
76 | |||
77 | 66 | ||
78 | resourceMap' :: SceneGraph -> Loader () | 67 | resourceMap' :: SceneGraph -> Loader () |
79 | resourceMap' node@(SceneLeaf nid props) = do | 68 | resourceMap' node@(SceneLeaf nid props) = do |
@@ -86,63 +75,51 @@ resourceMap' node@(SceneLeaf nid props) = do | |||
86 | resourceMap' node@(SceneNode nid props children) = do | 75 | resourceMap' 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. |
91 | loadResource :: String -- ^ Resource name. | 79 | loadResource :: 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 |
96 | loadResource key field modifyResources load = do | 84 | loadResource 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 | |||
108 | addShader name shader = modify $ \sceneData -> | 95 | addShader 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 | |||
112 | addCustomProgram name prog = modify $ \sceneData -> | 98 | addCustomProgram 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 | |||
116 | addStaticProgram name prog = modify $ \sceneData -> | 101 | addStaticProgram 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 | |||
120 | addAnimatedProgram name prog = modify $ \sceneData -> | 104 | addAnimatedProgram 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 | |||
124 | addTexture name tex = modify $ \sceneData -> | 107 | addTexture 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 | |||
128 | addStaticModel name model = modify $ | 110 | addStaticModel 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 | |||
132 | addAnimatedModel name model = modify $ | 113 | addAnimatedModel 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. |
137 | getResource :: (SceneResources -> Map String a) -> String -> Loader a | 117 | getResource :: (SceneResources -> Map String a) -> String -> Loader a |
138 | getResource field key = do | 118 | getResource 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 | 171 | loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model | |
195 | loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Setup Model | ||
196 | loadModel' file rotation scale = do | 172 | loadModel' 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 | ||
210 | rotateModel :: Rotation -> Model -> Model | 185 | rotateModel :: Rotation -> Model -> Model |
211 | rotateModel (Rotation ax ay az order) model = | 186 | rotateModel (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 | |||
230 | loadTexture :: FilePath -> Loader GLSL.Texture | 204 | loadTexture :: FilePath -> Loader GLSL.Texture |
231 | loadTexture file = | 205 | loadTexture 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 | |||
236 | newShaderProgram :: SceneGraph -> Loader () | 209 | newShaderProgram :: SceneGraph -> Loader () |
237 | newShaderProgram (SceneLeaf _ props) = do | 210 | newShaderProgram (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 | |||
319 | loadShader :: GLSL.ShaderType -> [Property] -> Loader (String, GLSL.GLSLShader) | 288 | loadShader :: GLSL.ShaderType -> [Property] -> Loader (String, GLSL.GLSLShader) |
320 | loadShader _ [] = loaderSetup . setupError $ "Loader::vertexShader: empty list" | 289 | loadShader _ [] = gameError $ "Loader::vertexShader: empty list" |
321 | loadShader shaderType ((stype, file):xs) = | 290 | loadShader 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 | |||
329 | loadShader' :: String -> GLSL.ShaderType -> Loader GLSL.GLSLShader | 297 | loadShader' :: String -> GLSL.ShaderType -> Loader GLSL.GLSLShader |
330 | loadShader' file shaderType = loadResource file shaders addShader $ GLSL.loadShader file shaderType | 298 | loadShader' file shaderType = loadResource file shaders addShader $ GLSL.loadShader file shaderType |
331 | 299 | ||
332 | |||
333 | newLight :: SceneGraph -> Loader () | 300 | newLight :: SceneGraph -> Loader () |
334 | newLight _ = return () | 301 | newLight _ = return () |
335 | 302 | ||
336 | |||
337 | |||
338 | |||
339 | -------------------- | 303 | -------------------- |
340 | -- Object Loading -- | 304 | -- Object Loading -- |
341 | -------------------- | 305 | -------------------- |
342 | 306 | ||
343 | loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Setup GameObject | 307 | loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Game s GameObject |
344 | loadGO style sceneRes props transf = do | 308 | loadGO 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 | |||
362 | type CreateGameObject m a | 325 | type 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'. |
371 | loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a] | 333 | loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a] |
372 | loadObjects newGO sceneRes g = | 334 | loadObjects 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. |
379 | newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a] | 340 | newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a] |
380 | newObject newGO sceneRes (SceneNode nid props children) = | 341 | newObject newGO sceneRes (SceneNode nid props children) = |
@@ -383,7 +344,6 @@ newObject newGO sceneRes (SceneNode nid props children) = | |||
383 | 344 | ||
384 | newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props] | 345 | newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props] |
385 | 346 | ||
386 | |||
387 | newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a | 347 | newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a |
388 | newObject' newGO sceneRes nid props = do | 348 | newObject' 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 | |||
403 | vectors :: Maybe Vector2 -> (Vector2, Vector2) | 362 | vectors :: Maybe Vector2 -> (Vector2, Vector2) |
404 | vectors up = case up of | 363 | vectors 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 | |||
422 | unspecified :: Maybe a -> a -> a | 377 | unspecified :: Maybe a -> a -> a |
423 | unspecified (Just x) _ = x | 378 | unspecified (Just x) _ = x |
424 | unspecified Nothing x = x | 379 | unspecified Nothing x = x |
425 | 380 | ||
426 | 381 | mandatory :: String -> [Property] -> Game s [String] | |
427 | mandatory :: String -> [Property] -> Setup [String] | ||
428 | mandatory name props = case value name props of | 382 | mandatory 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 | |||
433 | mandatory' :: String -> [Property] -> Loader [String] | 386 | mandatory' :: String -> [Property] -> Loader [String] |
434 | mandatory' name props = loaderSetup $ mandatory name props | 387 | mandatory' name props = mandatory name props |
435 | |||
436 | 388 | ||
437 | asString :: Functor f => f [String] -> f String | 389 | asString :: Functor f => f [String] -> f String |
438 | asString = fmap concat | 390 | asString = fmap concat |
439 | 391 | ||
440 | |||
441 | asFloat :: Functor f => f [String] -> f Float | 392 | asFloat :: Functor f => f [String] -> f Float |
442 | asFloat = fmap (read . concat) | 393 | asFloat = fmap (read . concat) |
443 | 394 | ||
444 | |||
445 | asVec2 :: Functor f => f [String] -> f Vector2 | 395 | asVec2 :: Functor f => f [String] -> f Vector2 |
446 | asVec2 val = fmap toVec2 val | 396 | asVec2 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 | |||
451 | asVec3 :: Functor f => f [String] -> f Vector3 | 400 | asVec3 :: Functor f => f [String] -> f Vector3 |
452 | asVec3 val = fmap toVec3 val | 401 | asVec3 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 | |||
457 | asVec4 :: Functor f => f [String] -> f Vector4 | 405 | asVec4 :: Functor f => f [String] -> f Vector4 |
458 | asVec4 val = fmap toVec4 val | 406 | asVec4 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 | |||
463 | asRotation :: Functor f => f [String] -> f Rotation | 410 | asRotation :: Functor f => f [String] -> f Rotation |
464 | asRotation val = fmap parseRotation val | 411 | asRotation 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 | |||
468 | data Rotation = Rotation | 414 | data 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 | |||
476 | data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq | 421 | data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq |
477 | 422 | ||
478 | |||
479 | readOrder :: String -> RotationOrder | 423 | readOrder :: String -> RotationOrder |
480 | readOrder "xyz" = XYZ | 424 | readOrder "xyz" = XYZ |
481 | readOrder "xzy" = XZY | 425 | readOrder "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 @@ | |||
1 | module Spear.Setup | ||
2 | ( | ||
3 | Setup | ||
4 | , Resource | ||
5 | , register | ||
6 | , release | ||
7 | , runSetup | ||
8 | , runSetup_ | ||
9 | , setupError | ||
10 | , setupIO | ||
11 | , assertMaybe | ||
12 | ) | ||
13 | where | ||
14 | |||
15 | |||
16 | import Control.Monad.Error | ||
17 | import qualified Control.Monad.Trans.Resource as R | ||
18 | import qualified Control.Monad.Trans.Class as MT (lift) | ||
19 | |||
20 | |||
21 | type Setup = R.ResourceT (ErrorT String IO) | ||
22 | |||
23 | type Resource = R.ReleaseKey | ||
24 | |||
25 | |||
26 | -- | Register the given cleaner. | ||
27 | register :: IO () -> Setup Resource | ||
28 | register = R.register | ||
29 | |||
30 | |||
31 | -- | Release the given 'Resource'. | ||
32 | release :: Resource -> Setup () | ||
33 | release = R.release | ||
34 | |||
35 | |||
36 | -- | Run the given 'Setup', freeing all of its allocated resources. | ||
37 | runSetup :: Setup a -> IO (Either String a) | ||
38 | runSetup = runErrorT . R.runResourceT | ||
39 | |||
40 | |||
41 | -- | Run the given 'Setup', freeing all of its allocated resources. | ||
42 | runSetup_ :: Setup a -> IO () | ||
43 | runSetup_ s = (runErrorT . R.runResourceT) s >> return () | ||
44 | |||
45 | |||
46 | -- | Throw an error from the 'Setup' monad. | ||
47 | setupError :: String -> Setup a | ||
48 | setupError = MT.lift . throwError | ||
49 | |||
50 | |||
51 | -- | Lift the given IO action into the 'Setup' monad. | ||
52 | setupIO :: IO a -> Setup a | ||
53 | setupIO = MT.lift . MT.lift | ||
54 | |||
55 | |||
56 | -- | Throw the given error string if given 'Nothing'. | ||
57 | assertMaybe :: Maybe a -> String -> Setup a | ||
58 | assertMaybe Nothing err = setupError err | ||
59 | assertMaybe (Just x) _ = return x | ||