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 | ||
