From e15a9cc51e31b5deb973d8583298aa130dd82b17 Mon Sep 17 00:00:00 2001 From: Jeanne-Kamikaze Date: Sat, 10 Aug 2013 17:24:17 +0200 Subject: Added pong --- .gitignore | 3 + Spear.cabal | 11 +- Spear/App.hs | 10 -- Spear/App/Application.hs | 139 ------------------ Spear/App/Input.hs | 265 ---------------------------------- Spear/Game.hs | 7 + Spear/Math/AABB.hs | 4 +- Spear/Math/Entity.hs | 33 ----- Spear/Math/MatrixUtils.hs | 9 -- Spear/Math/Spatial2.hs | 210 ++++++++++++++++++--------- Spear/Math/Spatial3.hs | 270 ++++++++++++++++++----------------- Spear/Math/Vector/Vector2.hs | 28 ++-- Spear/Math/Vector/Vector3.hs | 2 +- Spear/Math/Vector/Vector4.hs | 34 ++--- Spear/Scene/GameObject.hs | 320 ------------------------------------------ Spear/Scene/Light.hs | 31 ---- Spear/Scene/Loader.hs | 73 ---------- Spear/Scene/SceneResources.hs | 4 +- Spear/Sys/Timer.hsc | 2 +- Spear/Window.hs | 311 ++++++++++++++++++++++++++++++++++++++++ demos/pong/LICENSE | 30 ++++ demos/pong/Main.hs | 86 ++++++++++++ demos/pong/Pong.hs | 174 +++++++++++++++++++++++ demos/pong/Setup.hs | 2 + demos/pong/pong.cabal | 21 +++ 25 files changed, 962 insertions(+), 1117 deletions(-) create mode 100644 .gitignore delete mode 100644 Spear/App.hs delete mode 100644 Spear/App/Application.hs delete mode 100644 Spear/App/Input.hs delete mode 100644 Spear/Math/Entity.hs delete mode 100644 Spear/Scene/GameObject.hs delete mode 100644 Spear/Scene/Light.hs create mode 100644 Spear/Window.hs create mode 100644 demos/pong/LICENSE create mode 100644 demos/pong/Main.hs create mode 100644 demos/pong/Pong.hs create mode 100644 demos/pong/Setup.hs create mode 100644 demos/pong/pong.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8d5c25e --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +demos/pong/dist/ +demos/pong/pong +dist/ diff --git a/Spear.cabal b/Spear.cabal index 0e52faf..ea5eafc 100644 --- a/Spear.cabal +++ b/Spear.cabal @@ -17,7 +17,7 @@ library OpenGLRaw -any, StateVar -any, base -any, - bytestring >= 0.10, + bytestring -any, directory -any, mtl -any, transformers -any, @@ -27,10 +27,7 @@ library vector -any, array -any - exposed-modules: Spear.App - Spear.App.Application - Spear.App.Input - Spear.Assets.Image + exposed-modules: Spear.Assets.Image Spear.Assets.Model Spear.Game Spear.GL @@ -38,7 +35,6 @@ library Spear.Math.Camera Spear.Math.Circle Spear.Math.Collision - Spear.Math.Entity Spear.Math.Frustum Spear.Math.Matrix3 Spear.Math.Matrix4 @@ -62,14 +58,13 @@ library Spear.Render.Model Spear.Render.Program Spear.Render.StaticModel - Spear.Scene.GameObject Spear.Scene.Graph - Spear.Scene.Light Spear.Scene.Loader Spear.Scene.SceneResources Spear.Sys.Store Spear.Sys.Store.ID Spear.Sys.Timer + Spear.Window exposed: True diff --git a/Spear/App.hs b/Spear/App.hs deleted file mode 100644 index 4057aa3..0000000 --- a/Spear/App.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Spear.App -( - module Spear.App.Application -, module Spear.App.Input -) -where - - -import Spear.App.Application -import Spear.App.Input diff --git a/Spear/App/Application.hs b/Spear/App/Application.hs deleted file mode 100644 index 5886502..0000000 --- a/Spear/App/Application.hs +++ /dev/null @@ -1,139 +0,0 @@ -module Spear.App.Application -( - -- * Setup - Dimensions -, Context -, WindowTitle -, SpearWindow -, Update -, Size(..) -, DisplayBits(..) -, WindowMode(..) -, WindowSizeCallback -, withWindow - -- * Main loop -, loop -, loopCapped - -- * Helpers -, swapBuffers -) -where - -import Spear.Game -import Spear.Sys.Timer as Timer - -import Control.Concurrent.MVar -import Control.Monad (when) -import Control.Monad.IO.Class -import Graphics.UI.GLFW as GLFW -import Graphics.Rendering.OpenGL as GL - --- | Window dimensions. -type Dimensions = (Int, Int) - --- | A tuple specifying the desired OpenGL context, of the form (Major, Minor). -type Context = (Int, Int) - -type WindowTitle = String - --- Whether the user has closed the window. -type CloseRequested = MVar Bool - --- | Represents a window. -data SpearWindow = SpearWindow - { closeRequest :: CloseRequested - } - -withWindow :: MonadIO m - => Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle - -> WindowSizeCallback -> (SpearWindow -> Game () a) -> m (Either String a) -withWindow dim@(w,h) displayBits windowMode glVersion windowTitle onResize game = do - result <- liftIO . flip runGame () $ do - glfwInit - window <- setup dim displayBits windowMode glVersion windowTitle onResize - result <- evalSubGame (game window) () - gameIO GLFW.closeWindow - gameIO GLFW.terminate - return result - case result of - Left err -> return $ Left err - Right (a,_) -> return $ Right a - --- Set up an application 'SpearWindow'. -setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle - -> WindowSizeCallback -> Game s SpearWindow -setup (w, h) displayBits windowMode (major, minor) wndTitle onResize = do - closeRequest <- gameIO $ newEmptyMVar - gameIO $ do - openWindowHint OpenGLVersionMajor major - openWindowHint OpenGLVersionMinor minor - openWindowHint OpenGLProfile OpenGLCompatProfile - disableSpecial AutoPollEvent - let dimensions = GL.Size (fromIntegral w) (fromIntegral h) - result <- openWindow dimensions displayBits windowMode - windowTitle $= case wndTitle of - Nothing -> "Spear Game Framework" - Just title -> title - GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) - windowSizeCallback $= onResize - windowCloseCallback $= (onWindowClose closeRequest) - onResize (Size (fromIntegral w) (fromIntegral h)) - return $ SpearWindow closeRequest - -glfwInit :: Game s () -glfwInit = do - result <- gameIO GLFW.initialize - case result of - False -> gameError "GLFW.initialize failed" - True -> return () - --- | Return true if the application should continue running, false otherwise. -type Update s = Float -> Game s (Bool) - --- | Run the application's main loop. -loop :: SpearWindow -> Update s -> Game s () -loop wnd update = do - gs <- getGameState - flip runSubGame gs $ do - timer <- gameIO $ start newTimer - run (closeRequest wnd) timer update - return () - -run :: CloseRequested -> Timer -> Update s -> Game s () -run closeRequest timer update = do - timer' <- gameIO $ tick timer - continue <- update $ getDelta timer' - close <- gameIO $ getRequest closeRequest - when (continue && (not close)) $ run closeRequest timer' update - --- | Run the application's main loop with a limit on the frame rate. -loopCapped :: SpearWindow -> Int -> Update s -> Game s () -loopCapped wnd maxFPS update = do - gs <- getGameState - flip runSubGame gs $ do - let ddt = 1.0 / (fromIntegral maxFPS) - closeReq = closeRequest wnd - frameTimer <- gameIO $ start newTimer - controlTimer <- gameIO $ start newTimer - runCapped closeReq ddt frameTimer controlTimer update - return () - -runCapped :: CloseRequested -> Float -> Timer -> Timer -> Update s -> Game s () -runCapped closeRequest ddt frameTimer controlTimer update = do - controlTimer' <- gameIO $ tick controlTimer - frameTimer' <- gameIO $ tick frameTimer - continue <- update $ getDelta frameTimer' - close <- gameIO $ getRequest closeRequest - controlTimer'' <- gameIO $ tick controlTimer' - let dt = getDelta controlTimer'' - when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) - when (continue && (not close)) $ - runCapped closeRequest ddt frameTimer' controlTimer'' update - -getRequest :: MVar Bool -> IO Bool -getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of - Nothing -> False - Just x -> x - -onWindowClose :: MVar Bool -> WindowCloseCallback -onWindowClose closeRequest = putMVar closeRequest True >> return False diff --git a/Spear/App/Input.hs b/Spear/App/Input.hs deleted file mode 100644 index 3a4fc99..0000000 --- a/Spear/App/Input.hs +++ /dev/null @@ -1,265 +0,0 @@ -module Spear.App.Input -( - -- * Data types - Key(..) -, MouseButton(..) -, MouseProp(..) -, Keyboard -, Mouse(..) -, Input(..) -, ButtonDelay -, DelayedMouse - -- * Input state querying -, newKeyboard -, getKeyboard -, newMouse -, getMouse -, newInput -, getInput -, pollInput - -- * Toggled input -, toggledMouse -, toggledKeyboard - -- * Delayed input -, newDM -, updateDM -, delayedMouse - -- * Input modifiers -, setMousePosition -, setMouseWheel -) -where - -import Data.Char (ord) -import qualified Data.Vector.Unboxed as V -import qualified Graphics.UI.GLFW as GLFW -import Graphics.Rendering.OpenGL.GL.CoordTrans -import Graphics.Rendering.OpenGL.GL.StateVar - -data Key - = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H - | KEY_I | KEY_J | KEY_K | KEY_L | KEY_M | KEY_N | KEY_O | KEY_P - | KEY_Q | KEY_R | KEY_S | KEY_T | KEY_U | KEY_V | KEY_W | KEY_X - | KEY_Y | KEY_Z | KEY_0 | KEY_1 | KEY_2 | KEY_3 | KEY_4 | KEY_5 - | KEY_6 | KEY_7 | KEY_8 | KEY_9 | KEY_F1 | KEY_F2 | KEY_F3 - | KEY_F4 | KEY_F5 | KEY_F6 | KEY_F7 | KEY_F8 | KEY_F9 | KEY_F10 - | KEY_F11 | KEY_F12 | KEY_ESC | KEY_SPACE | KEY_UP | KEY_DOWN - | KEY_LEFT | KEY_RIGHT - deriving (Enum, Bounded) - -type Keyboard = Key -> Bool - -data MouseButton = LMB | RMB | MMB - deriving (Enum, Bounded) - -data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta - deriving Enum - -data Mouse = Mouse - { button :: MouseButton -> Bool - , property :: MouseProp -> Float - } - -data Input = Input - { keyboard :: Keyboard - , mouse :: Mouse - } - --- | Return a new dummy keyboard. --- --- This function should be called to get an initial keyboard. --- --- The returned keyboard has all of its keys unpressed. --- --- For further keyboard updates, see 'getKeyboard'. -newKeyboard :: Keyboard -newKeyboard = const False - --- | Get the keyboard. -getKeyboard :: IO Keyboard -getKeyboard = - let keyboard' :: V.Vector Bool -> Keyboard - keyboard' keystate key = keystate V.! fromEnum key - keys = fmap toEnum [0..fromEnum (maxBound :: Key)] - in - (fmap (V.fromList . fmap ((==) GLFW.Press)) . mapM GLFW.getKey . fmap toGLFWkey $ keys) - >>= return . keyboard' - --- | Return a new dummy mouse. --- --- This function should be called to get an initial mouse. --- --- The returned mouse has all keys unpressed, position set to (0,0) and 0 deta values. --- --- For further mouse updates, see 'getMouse'. -newMouse :: Mouse -newMouse = Mouse (const False) (const 0) - --- | Get the mouse. --- --- The previous mouse state is required to compute position deltas. -getMouse :: Mouse -> IO Mouse -getMouse oldMouse = - let getButton :: V.Vector Bool -> MouseButton -> Bool - getButton mousestate button = mousestate V.! fromEnum button - - getProp :: V.Vector Float -> MouseProp -> Float - getProp props prop = props V.! fromEnum prop - - props xpos ypos wheel = V.fromList - [ xpos - , ypos - , xpos - property oldMouse MouseX - , ypos - property oldMouse MouseY - , wheel - , wheel - property oldMouse Wheel - ] - - getButtonState = - fmap (V.fromList . fmap ((==) GLFW.Press)) . - mapM GLFW.getMouseButton . - fmap toGLFWbutton $ buttons - - buttons = fmap toEnum [0..fromEnum (maxBound :: MouseButton)] - in do - Position xpos ypos <- get GLFW.mousePos - wheel <- get GLFW.mouseWheel - buttonState <- getButtonState - return $ Mouse - { button = getButton buttonState - , property = getProp $ props (fromIntegral xpos) (fromIntegral ypos) (fromIntegral wheel) - } - --- | Return a new dummy input. -newInput :: Input -newInput = Input newKeyboard newMouse - --- | Get input devices. -getInput :: Input -> IO Input -getInput (Input _ oldMouse) = do - keyboard <- getKeyboard - mouse <- getMouse oldMouse - return $ Input keyboard mouse - --- | Poll input devices. -pollInput :: IO () -pollInput = GLFW.pollEvents - --- | Return a mouse that reacts to button toggles. -toggledMouse :: Mouse -- ^ Previous mouse state. - -> Mouse -- ^ Current mouse state. - -> Mouse -- ^ Toggled mouse. - -toggledMouse prev cur = cur { button = \bt -> button cur bt && not (button prev bt) } - --- | Return a keyboard that reacts to key toggles. -toggledKeyboard :: Keyboard -- ^ Previous keyboard state. - -> Keyboard -- ^ Current keyboard state. - -> Keyboard -- ^ Toggled keyboard. - -toggledKeyboard prev cur key = cur key && not (prev key) - --- | Delay configuration for each mouse button. -type ButtonDelay = MouseButton -> Float - - --- | Accumulated delays for each mouse button. -data DelayedMouse = DelayedMouse - { delayedMouse :: Mouse - , delay :: ButtonDelay - , accum :: V.Vector Float - } - -newDM :: ButtonDelay -- ^ Delay configuration for each button. - -> DelayedMouse -newDM delay = DelayedMouse newMouse delay $ - V.replicate (fromEnum (maxBound :: MouseButton)) 0 - -updateDM :: DelayedMouse -- ^ Current mouse state. - -> Float -- ^ Time elapsed since last udpate. - -> DelayedMouse - -updateDM (DelayedMouse mouse delay accum) dt = - let - time b = dt + accum' V.! fromEnum b - active b = time b >= delay b - button' b = active b && button mouse b - accum' = accum V.// fmap newDelay [0 .. fromEnum (maxBound :: MouseButton)] - newDelay x = let b = toEnum x - in (x, if button' b then 0 else time b) - in - DelayedMouse mouse { button = button' } delay accum' - --- | Set the mouse position. -setMousePosition :: Integral a => (a,a) -> Mouse -> IO Mouse -setMousePosition (x,y) mouse = do - GLFW.mousePos $= Position (fromIntegral x) (fromIntegral y) - getMouse mouse - --- | Set the mouse wheel. -setMouseWheel :: Integral a => a -> Mouse -> IO Mouse -setMouseWheel w mouse = do - GLFW.mouseWheel $= (fromIntegral w) - getMouse mouse - -toGLFWkey :: Key -> Int -toGLFWkey KEY_A = ord 'A' -toGLFWkey KEY_B = ord 'B' -toGLFWkey KEY_C = ord 'C' -toGLFWkey KEY_D = ord 'D' -toGLFWkey KEY_E = ord 'E' -toGLFWkey KEY_F = ord 'F' -toGLFWkey KEY_G = ord 'G' -toGLFWkey KEY_H = ord 'H' -toGLFWkey KEY_I = ord 'I' -toGLFWkey KEY_J = ord 'J' -toGLFWkey KEY_K = ord 'K' -toGLFWkey KEY_L = ord 'L' -toGLFWkey KEY_M = ord 'M' -toGLFWkey KEY_N = ord 'N' -toGLFWkey KEY_O = ord 'O' -toGLFWkey KEY_P = ord 'P' -toGLFWkey KEY_Q = ord 'Q' -toGLFWkey KEY_R = ord 'R' -toGLFWkey KEY_S = ord 'S' -toGLFWkey KEY_T = ord 'T' -toGLFWkey KEY_U = ord 'U' -toGLFWkey KEY_V = ord 'V' -toGLFWkey KEY_W = ord 'W' -toGLFWkey KEY_X = ord 'X' -toGLFWkey KEY_Y = ord 'Y' -toGLFWkey KEY_Z = ord 'Z' -toGLFWkey KEY_0 = ord '0' -toGLFWkey KEY_1 = ord '1' -toGLFWkey KEY_2 = ord '2' -toGLFWkey KEY_3 = ord '3' -toGLFWkey KEY_4 = ord '4' -toGLFWkey KEY_5 = ord '5' -toGLFWkey KEY_6 = ord '6' -toGLFWkey KEY_7 = ord '7' -toGLFWkey KEY_8 = ord '8' -toGLFWkey KEY_9 = ord '9' -toGLFWkey KEY_F1 = fromEnum GLFW.F1 -toGLFWkey KEY_F2 = fromEnum GLFW.F2 -toGLFWkey KEY_F3 = fromEnum GLFW.F3 -toGLFWkey KEY_F4 = fromEnum GLFW.F4 -toGLFWkey KEY_F5 = fromEnum GLFW.F5 -toGLFWkey KEY_F6 = fromEnum GLFW.F6 -toGLFWkey KEY_F7 = fromEnum GLFW.F7 -toGLFWkey KEY_F8 = fromEnum GLFW.F8 -toGLFWkey KEY_F9 = fromEnum GLFW.F9 -toGLFWkey KEY_F10 = fromEnum GLFW.F10 -toGLFWkey KEY_F11 = fromEnum GLFW.F11 -toGLFWkey KEY_F12 = fromEnum GLFW.F12 -toGLFWkey KEY_ESC = fromEnum GLFW.ESC -toGLFWkey KEY_SPACE = ord ' ' -toGLFWkey KEY_UP = fromEnum GLFW.UP -toGLFWkey KEY_DOWN = fromEnum GLFW.DOWN -toGLFWkey KEY_LEFT = fromEnum GLFW.LEFT -toGLFWkey KEY_RIGHT = fromEnum GLFW.RIGHT - - -toGLFWbutton :: MouseButton -> GLFW.MouseButton -toGLFWbutton LMB = GLFW.ButtonLeft -toGLFWbutton RMB = GLFW.ButtonRight -toGLFWbutton MMB = GLFW.ButtonMiddle diff --git a/Spear/Game.hs b/Spear/Game.hs index 8d4d8bb..44cb13c 100644 --- a/Spear/Game.hs +++ b/Spear/Game.hs @@ -17,6 +17,7 @@ module Spear.Game , catchGameErrorFinally -- * Running and IO , runGame +, runGame' , runSubGame , runSubGame' , evalSubGame @@ -83,6 +84,12 @@ catchGameErrorFinally game finally = catchError game $ \err -> finally >> gameEr runGame :: Game s a -> s -> IO (Either String (a,s)) runGame game state = runErrorT . R.runResourceT . runStateT game $ state +-- | Run the given game and discard its state. +runGame' :: Game s a -> s -> IO (Either String a) +runGame' g s = runGame g s >>= \result -> return $ case result of + Right (a,s) -> Right a + Left err -> Left err + -- | Fully run the given sub game, unrolling the entire monad stack. runSubGame :: Game s a -> s -> Game t (a,s) runSubGame game state = gameIO (runGame game state) >>= \result -> case result of diff --git a/Spear/Math/AABB.hs b/Spear/Math/AABB.hs index 068a619..de3b1a4 100644 --- a/Spear/Math/AABB.hs +++ b/Spear/Math/AABB.hs @@ -14,10 +14,10 @@ import Spear.Math.Vector import Data.List (foldl') -- | An axis-aligned bounding box in 2D space. -data AABB2 = AABB2 {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 +data AABB2 = AABB2 {-# UNPACK #-} !Vector2 {-# UNPACK #-} !Vector2 deriving Show -- | An axis-aligned bounding box in 3D space. -data AABB3 = AABB3 {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 +data AABB3 = AABB3 {-# UNPACK #-} !Vector3 {-# UNPACK #-} !Vector3 deriving Show -- | Create a AABB from the given points. aabb2 :: [Vector2] -> AABB2 diff --git a/Spear/Math/Entity.hs b/Spear/Math/Entity.hs deleted file mode 100644 index 4d29a95..0000000 --- a/Spear/Math/Entity.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Spear.Math.Entity -( - Entity(..) -) -where - - -import qualified Spear.Math.Matrix3 as M -import qualified Spear.Math.Spatial2 as S -import qualified Spear.Math.Vector as V - - --- | An entity in 2D space. -newtype Entity = Entity { transform :: M.Matrix3 } - - -instance S.Spatial2 Entity where - move v ent = ent { transform = M.translv v * transform ent } - moveFwd f ent = ent { transform = M.translv (V.scale f $ S.fwd ent) * transform ent } - moveBack f ent = ent { transform = M.translv (V.scale (-f) $ S.fwd ent) * transform ent } - strafeLeft f ent = ent { transform = M.translv (V.scale (-f) $ S.right ent) * transform ent } - strafeRight f ent = ent { transform = M.translv (V.scale f $ S.right ent) * transform ent } - rotate a ent = ent { transform = transform ent * M.rot a } - setRotation a ent = - let t = transform ent - in ent { transform = M.translation t * M.rot a } - pos = M.position . transform - fwd = M.forward . transform - up = M.up . transform - right = M.right . transform - transform (Entity t) = t - setTransform t (Entity _) = Entity t - setPos pos (Entity t) = Entity $ M.transform (M.right t) (M.forward t) pos diff --git a/Spear/Math/MatrixUtils.hs b/Spear/Math/MatrixUtils.hs index 24d9778..567bee1 100644 --- a/Spear/Math/MatrixUtils.hs +++ b/Spear/Math/MatrixUtils.hs @@ -11,14 +11,12 @@ module Spear.Math.MatrixUtils ) where - import Spear.Math.Camera as Cam import Spear.Math.Matrix3 as M3 import Spear.Math.Matrix4 as M4 import Spear.Math.Spatial3 as S import Spear.Math.Vector as V - -- | Compute the normal matrix of the given matrix. fastNormalMatrix :: Matrix4 -> Matrix3 fastNormalMatrix m = @@ -28,7 +26,6 @@ fastNormalMatrix m = (M4.m01 m') (M4.m11 m') (M4.m21 m') (M4.m02 m') (M4.m12 m') (M4.m22 m') - -- | Transform the given point in window coordinates to object coordinates. unproject :: Matrix4 -- ^ Inverse projection matrix -> Matrix4 -- ^ Inverse modelview matrix. @@ -48,7 +45,6 @@ unproject projI modelviewI vpx vpy w h x y z = in (modelviewI * projI) `M4.mulp` vec3 xmouse ymouse zmouse - -- | Transform the given point in window coordinates to 2d coordinates. -- -- The line defined by the given point in window space is intersected with @@ -72,7 +68,6 @@ rpgUnproject projI viewI vpx vpy w h wx wy = in vec2 (x p') (-(z p')) - -- | Map an object's transform in view space to world space. rpgTransform :: Float -- ^ The height above the ground @@ -97,7 +92,6 @@ rpgTransform h a axis pos viewI = (z r) (z u) (z f) (z t) 0 0 0 1 - -- | Map an object's transform in view space to world space. pltTransform :: Matrix3 -> Matrix4 pltTransform mat = @@ -111,7 +105,6 @@ pltTransform mat = (z r) (z u) (z f) (z t) 0 0 0 1 - -- | Map an object's transform in world space to view space. -- -- The XY plane in 2D translates to the X(-Z) plane in 3D. @@ -127,7 +120,6 @@ rpgInverse rpgInverse h a axis pos viewI = M4.inverseTransform $ rpgTransform h a axis pos viewI - -- | Map an object's transform in world space to view space. -- -- This function maps an object's transform in 2D to the object's inverse in 3D. @@ -138,7 +130,6 @@ rpgInverse h a axis pos viewI = pltInverse :: Matrix3 -> Matrix4 pltInverse = M4.inverseTransform . pltTransform - -- | Transform an object from object to clip space coordinates. objToClip :: Camera -> Matrix4 -> Vector3 -> Vector2 objToClip cam model p = diff --git a/Spear/Math/Spatial2.hs b/Spear/Math/Spatial2.hs index b9dde44..b2399f8 100644 --- a/Spear/Math/Spatial2.hs +++ b/Spear/Math/Spatial2.hs @@ -1,75 +1,151 @@ module Spear.Math.Spatial2 +( + Spatial2(..) +, Obj2 +, Angle +, Radius +, move +, moveFwd +, moveBack +, moveUp +, moveDown +, moveLeft +, moveRight +, rotate +, setRotation +, pos +, fwd +, up +, right +, transform +, setTransform +, setPos +, lookAt +, Spear.Math.Spatial2.orbit +, obj2FromVectors +, obj2FromTransform +) where - import Spear.Math.Vector -import Spear.Math.Matrix3 as M +import qualified Spear.Math.Matrix3 as M +type Angle = Float +type Radius = Float -- | An entity that can be moved around in 2D space. class Spatial2 s where - - -- | Move the spatial. - move :: Vector2 -> s -> s - - -- | Move the spatial forwards. - moveFwd :: Float -> s -> s - - -- | Move the spatial backwards. - moveBack :: Float -> s -> s - - -- | Make the spatial strafe left. - strafeLeft :: Float -> s -> s - - -- | Make the spatial Strafe right. - strafeRight :: Float -> s -> s - - -- | Rotate the spatial. - rotate :: Float -> s -> s - - -- | Set the spatial's rotation. - setRotation :: Float -> s -> s - - -- | Get the spatial position. - pos :: s -> Vector2 - - -- | Get the spatial's forward vector. - fwd :: s -> Vector2 - - -- | Get the spatial's up vector. - up :: s -> Vector2 - - -- | Get the spatial's right vector. - right :: s -> Vector2 - - -- | Get the spatial's transform. - transform :: s -> Matrix3 - - -- | Set the spatial's transform. - setTransform :: Matrix3 -> s -> s - - -- | Set the spatial's position. - setPos :: Vector2 -> s -> s - - -- | Make the spatial look at the given point. - lookAt :: Vector2 -> s -> s - lookAt pt s = - let position = pos s - fwd = normalise $ pt - position - r = perp fwd - in - setTransform (M.transform r fwd position) s - - -- | Make the 'Spatial' orbit around the given point - orbit :: Vector2 -- ^ Target point - -> Float -- ^ Angle - -> Float -- ^ Orbit radius - -> s - -> s - - orbit pt angle radius s = - let a = angle * pi / 180 - px = (x pt) + radius * sin a - py = (y pt) + radius * cos a - in - setPos (vec2 px py) s + + -- | Gets the spatial's Obj2. + getObj2 :: s -> Obj2 + + -- | Set the spatial's Obj2. + setObj2 :: s -> Obj2 -> s + +-- | Move the spatial. +move :: Spatial2 s => Vector2 -> s -> s +move v s = let o = getObj2 s in setObj2 s $ o { p = p o + v } + +-- | Move the spatial forwards. +moveFwd :: Spatial2 s => Float -> s -> s +moveFwd a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale a (fwd o) } + +-- | Move the spatial backwards. +moveBack :: Spatial2 s => Float -> s -> s +moveBack a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale (-a) (fwd o) } + +-- | Move the spatial up. +moveUp :: Spatial2 s => Float -> s -> s +moveUp a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale a (fwd o) } + +-- | Move the spatial down. +moveDown :: Spatial2 s => Float -> s -> s +moveDown a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale (-a) (fwd o) } + +-- | Make the spatial strafe left. +moveLeft :: Spatial2 s => Float -> s -> s +moveLeft a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale (-a) (right o) } + +-- | Make the spatial Strafe right. +moveRight :: Spatial2 s => Float -> s -> s +moveRight a s = let o = getObj2 s in setObj2 s $ o { p = p o + scale a (right o) } + +-- | Rotate the spatial. +rotate :: Spatial2 s => Float -> s -> s +rotate angle s = let o = getObj2 s in setObj2 s $ o + { r = rotate' angle (r o) + , u = rotate' angle (u o) + } + +-- | Set the spatial's rotation. +setRotation :: Spatial2 s => Float -> s -> s +setRotation angle s = let o = getObj2 s in setObj2 s $ o + { r = rotate' angle unitx2 + , u = rotate' angle unity2 + } + +rotate' :: Float -> Vector2 -> Vector2 +rotate' a' (Vector2 x y) = vec2 (x * cos a) (y * sin a) where a = a'*pi/180 + +-- | Get the spatial's position. +pos :: Spatial2 s => s -> Vector2 +pos = p . getObj2 + +-- | Get the spatial's forward vector. +fwd :: Spatial2 s => s -> Vector2 +fwd = u . getObj2 + +-- | Get the spatial's up vector. +up :: Spatial2 s => s -> Vector2 +up = u . getObj2 + +-- | Get the spatial's right vector. +right :: Spatial2 s => s -> Vector2 +right = r . getObj2 + +-- | Get the spatial's transform. +transform :: Spatial2 s => s -> M.Matrix3 +transform s = let o = getObj2 s in M.transform (r o) (u o) (p o) + +-- | Set the spatial's transform. +setTransform :: Spatial2 s => M.Matrix3 -> s -> s +setTransform t s = + let o = Obj2 (M.right t) (M.up t) (M.position t) + in setObj2 s o + +-- | Set the spatial's position. +setPos :: Spatial2 s => Vector2 -> s -> s +setPos pos s = setObj2 s $ (getObj2 s) { p = pos } + +-- | Make the spatial look at the given point. +lookAt :: Spatial2 s => Vector2 -> s -> s +lookAt pt s = + let position = pos s + fwd = normalise $ pt - position + r = perp fwd + in setTransform (M.transform r fwd position) s + +-- | Make the 'Spatial' orbit around the given point +orbit :: Spatial2 s => Vector2 -> Angle -> Radius -> s -> s +orbit pt angle radius s = + let a = angle * pi / 180 + px = (x pt) + radius * sin a + py = (y pt) + radius * cos a + in setPos (vec2 px py) s + +-- | An object in 2D space. +data Obj2 = Obj2 + { r :: Vector2 + , u :: Vector2 + , p :: Vector2 + } deriving Show + +instance Spatial2 Obj2 where + getObj2 = id + setObj2 _ o' = o' + +obj2FromVectors :: Right2 -> Up2 -> Position2 -> Obj2 +obj2FromVectors = Obj2 + +obj2FromTransform :: M.Matrix3 -> Obj2 +obj2FromTransform m = Obj2 (M.right m) (M.up m) (M.position m) \ No newline at end of file diff --git a/Spear/Math/Spatial3.hs b/Spear/Math/Spatial3.hs index c9495eb..896d5ae 100644 --- a/Spear/Math/Spatial3.hs +++ b/Spear/Math/Spatial3.hs @@ -2,6 +2,24 @@ module Spear.Math.Spatial3 ( Spatial3(..) , Obj3 +, move +, moveFwd +, moveBack +, moveLeft +, moveRight +, rotate +, pitch +, yaw +, roll +, pos +, fwd +, up +, right +, transform +, setTransform +, setPos +, lookAt +, Spear.Math.Spatial3.orbit , fromVectors , fromTransform ) @@ -13,132 +31,132 @@ import qualified Spear.Math.Matrix4 as M type Matrix4 = M.Matrix4 class Spatial3 s where - -- | Gets the spatial's internal Obj3. - getObj3 :: s -> Obj3 - - -- | Set the spatial's internal Obj3. - setObj3 :: s -> Obj3 -> s - - -- | Move the spatial. - move :: Vector3 -> s -> s - move d s = let o = getObj3 s in setObj3 s $ o { p = p o + d } - - -- | Move the spatial forwards. - moveFwd :: Float -> s -> s - moveFwd a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (f o) } - - -- | Move the spatial backwards. - moveBack :: Float -> s -> s - moveBack a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (f o) } - - -- | Make the spatial strafe left. - strafeLeft :: Float -> s -> s - strafeLeft a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (r o) } - - -- | Make the spatial Strafe right. - strafeRight :: Float -> s -> s - strafeRight a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (r o) } - - -- | Rotate the spatial about the given axis. - rotate :: Vector3 -> Float -> s -> s - rotate axis a s = - let t = transform s - axis' = M.inverseTransform t `M.muld` axis - in setTransform (t * M.axisAngle axis' a) s - - -- | Rotate the spatial about its local X axis. - pitch :: Float -> s -> s - pitch a s = - let o = getObj3 s - a' = toRAD a - sa = sin a' - ca = cos a' - f' = normalise $ scale ca (f o) + scale sa (u o) - u' = normalise $ r o `cross` f' - in setObj3 s $ o { u = u', f = f' } - - -- | Rotate the spatial about its local Y axis. - yaw :: Float -> s -> s - yaw a s = - let o = getObj3 s - a' = toRAD a - sa = sin a' - ca = cos a' - r' = normalise $ scale ca (r o) + scale sa (f o) - f' = normalise $ u o `cross` r' - in setObj3 s $ o { r = r', f = f' } - - -- | Rotate the spatial about its local Z axis. - roll :: Float -> s -> s - roll a s = - let o = getObj3 s - a' = toRAD a - sa = sin a' - ca = cos a' - u' = normalise $ scale ca (u o) - scale sa (r o) - r' = normalise $ f o `cross` u' - in setObj3 s $ o { r = r', u = u' } - - -- | Get the spatial's position. - pos :: s -> Vector3 - pos = p . getObj3 - - -- | Get the spatial's forward vector. - fwd :: s -> Vector3 - fwd = f . getObj3 - - -- | Get the spatial's up vector. - up :: s -> Vector3 - up = u . getObj3 - - -- | Get the spatial's right vector. - right :: s -> Vector3 - right = r . getObj3 - - -- | Get the spatial's transform. - transform :: s -> Matrix4 - transform s = let o = getObj3 s in M.transform (r o) (u o) (scale (-1) $ f o) (p o) - - -- | Set the spatial's transform. - setTransform :: Matrix4 -> s -> s - setTransform t s = - let o = Obj3 (M.right t) (M.up t) (scale (-1) $ M.forward t) (M.position t) - in setObj3 s o - - -- | Set the spatial's position. - setPos :: Vector3 -> s -> s - setPos pos s = setObj3 s $ (getObj3 s) { p = pos } - - -- | Make the spatial look at the given point. - lookAt :: Vector3 -> s -> s - lookAt pt s = - let position = pos s - fwd = normalise $ pt - position - r = fwd `cross` unity3 - u = r `cross` fwd - in - setTransform (M.transform r u (-fwd) position) s - - -- | Make the spatial orbit around the given point - orbit :: Vector3 -- ^ Target point - -> Float -- ^ Horizontal angle - -> Float -- ^ Vertical angle - -> Float -- ^ Orbit radius. - -> s - -> s - - orbit pt anglex angley radius s = - let ax = anglex * pi / 180 - ay = angley * pi / 180 - sx = sin ax - sy = sin ay - cx = cos ax - cy = cos ay - px = (x pt) + radius*cy*sx - py = (y pt) + radius*sy - pz = (z pt) + radius*cx*cy - in - setPos (vec3 px py pz) s + + -- | Gets the spatial's Obj3. + getObj3 :: s -> Obj3 + + -- | Set the spatial's Obj3. + setObj3 :: s -> Obj3 -> s + +-- | Move the spatial. +move :: Spatial3 s => Vector3 -> s -> s +move d s = let o = getObj3 s in setObj3 s $ o { p = p o + d } + +-- | Move the spatial forwards. +moveFwd :: Spatial3 s => Float -> s -> s +moveFwd a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (f o) } + +-- | Move the spatial backwards. +moveBack :: Spatial3 s => Float -> s -> s +moveBack a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (f o) } + +-- | Make the spatial strafe left. +moveLeft :: Spatial3 s => Float -> s -> s +moveLeft a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale (-a) (r o) } + +-- | Make the spatial Strafe right. +moveRight :: Spatial3 s => Float -> s -> s +moveRight a s = let o = getObj3 s in setObj3 s $ o { p = p o + scale a (r o) } + +-- | Rotate the spatial about the given axis. +rotate :: Spatial3 s => Vector3 -> Float -> s -> s +rotate axis a s = + let t = transform s + axis' = M.inverseTransform t `M.muld` axis + in setTransform (t * M.axisAngle axis' a) s + +-- | Rotate the spatial about its local X axis. +pitch :: Spatial3 s => Float -> s -> s +pitch a s = + let o = getObj3 s + a' = toRAD a + sa = sin a' + ca = cos a' + f' = normalise $ scale ca (f o) + scale sa (u o) + u' = normalise $ r o `cross` f' + in setObj3 s $ o { u = u', f = f' } + +-- | Rotate the spatial about its local Y axis. +yaw :: Spatial3 s => Float -> s -> s +yaw a s = + let o = getObj3 s + a' = toRAD a + sa = sin a' + ca = cos a' + r' = normalise $ scale ca (r o) + scale sa (f o) + f' = normalise $ u o `cross` r' + in setObj3 s $ o { r = r', f = f' } + +-- | Rotate the spatial about its local Z axis. +roll :: Spatial3 s => Float -> s -> s +roll a s = + let o = getObj3 s + a' = toRAD a + sa = sin a' + ca = cos a' + u' = normalise $ scale ca (u o) - scale sa (r o) + r' = normalise $ f o `cross` u' + in setObj3 s $ o { r = r', u = u' } + +-- | Get the spatial's position. +pos :: Spatial3 s => s -> Vector3 +pos = p . getObj3 + +-- | Get the spatial's forward vector. +fwd :: Spatial3 s => s -> Vector3 +fwd = f . getObj3 + +-- | Get the spatial's up vector. +up :: Spatial3 s => s -> Vector3 +up = u . getObj3 + +-- | Get the spatial's right vector. +right :: Spatial3 s => s -> Vector3 +right = r . getObj3 + +-- | Get the spatial's transform. +transform :: Spatial3 s => s -> Matrix4 +transform s = let o = getObj3 s in M.transform (r o) (u o) (scale (-1) $ f o) (p o) + +-- | Set the spatial's transform. +setTransform :: Spatial3 s => Matrix4 -> s -> s +setTransform t s = + let o = Obj3 (M.right t) (M.up t) (scale (-1) $ M.forward t) (M.position t) + in setObj3 s o + +-- | Set the spatial's position. +setPos :: Spatial3 s => Vector3 -> s -> s +setPos pos s = setObj3 s $ (getObj3 s) { p = pos } + +-- | Make the spatial look at the given point. +lookAt :: Spatial3 s => Vector3 -> s -> s +lookAt pt s = + let position = pos s + fwd = normalise $ pt - position + r = fwd `cross` unity3 + u = r `cross` fwd + in setTransform (M.transform r u (-fwd) position) s + +-- | Make the spatial orbit around the given point +orbit :: Spatial3 s + => Vector3 -- ^ Target point + -> Float -- ^ Horizontal angle + -> Float -- ^ Vertical angle + -> Float -- ^ Orbit radius. + -> s + -> s + +orbit pt anglex angley radius s = + let ax = anglex * pi / 180 + ay = angley * pi / 180 + sx = sin ax + sy = sin ay + cx = cos ax + cy = cos ay + px = (x pt) + radius*cy*sx + py = (y pt) + radius*sy + pz = (z pt) + radius*cx*cy + in setPos (vec3 px py pz) s -- | An object in 3D space. data Obj3 = Obj3 diff --git a/Spear/Math/Vector/Vector2.hs b/Spear/Math/Vector/Vector2.hs index 0b29ec4..dfb4fb9 100644 --- a/Spear/Math/Vector/Vector2.hs +++ b/Spear/Math/Vector/Vector2.hs @@ -1,6 +1,9 @@ module Spear.Math.Vector.Vector2 ( - Vector2 + Vector2(..) +, Right2 +, Up2 +, Position2 -- * Construction , unitx2 , unity2 @@ -11,13 +14,14 @@ module Spear.Math.Vector.Vector2 ) where - import Spear.Math.Vector.Class - import Foreign.C.Types (CFloat) import Foreign.Storable +type Right2 = Vector2 +type Up2 = Vector2 +type Position2 = Vector2 -- | Represents a vector in 2D. data Vector2 = Vector2 {-# UNPACK #-} !Float {-# UNPACK #-} !Float deriving (Eq, Show) @@ -30,13 +34,13 @@ instance Num Vector2 where abs (Vector2 ax ay) = Vector2 (abs ax) (abs ay) signum (Vector2 ax ay) = Vector2 (signum ax) (signum ay) fromInteger i = Vector2 i' i' where i' = fromInteger i - - + + instance Fractional Vector2 where Vector2 ax ay / Vector2 bx by = Vector2 (ax / bx) (ay / by) fromRational r = Vector2 r' r' where r' = fromRational r - - + + instance Ord Vector2 where Vector2 ax ay <= Vector2 bx by = (ax <= bx) || (ax == bx && ay <= by) Vector2 ax ay >= Vector2 bx by = (ax >= bx) || (ax == bx && ay >= by) @@ -89,18 +93,18 @@ sizeFloat = sizeOf (undefined :: CFloat) instance Storable Vector2 where sizeOf _ = 2*sizeFloat alignment _ = alignment (undefined :: CFloat) - + peek ptr = do ax <- peekByteOff ptr 0 ay <- peekByteOff ptr $ sizeFloat return (Vector2 ax ay) - + poke ptr (Vector2 ax ay) = do pokeByteOff ptr 0 ax pokeByteOff ptr sizeFloat ay --- | Get the vector's x coordinate. +-- | Get the vector's x coordinate. @@ -122,9 +126,9 @@ vec2 ax ay = Vector2 ax ay -- | Compute a vector perpendicular to the given one, satisfying: --- +-- -- perp (Vector2 0 1) = Vector2 1 0 --- +-- -- perp (Vector2 1 0) = Vector2 0 (-1) perp :: Vector2 -> Vector2 perp (Vector2 x y) = Vector2 y (-x) diff --git a/Spear/Math/Vector/Vector3.hs b/Spear/Math/Vector/Vector3.hs index 70bd299..429df0f 100644 --- a/Spear/Math/Vector/Vector3.hs +++ b/Spear/Math/Vector/Vector3.hs @@ -1,6 +1,6 @@ module Spear.Math.Vector.Vector3 ( - Vector3 + Vector3(..) , Right3 , Up3 , Forward3 diff --git a/Spear/Math/Vector/Vector4.hs b/Spear/Math/Vector/Vector4.hs index 3b5ed95..4314b51 100644 --- a/Spear/Math/Vector/Vector4.hs +++ b/Spear/Math/Vector/Vector4.hs @@ -1,6 +1,6 @@ module Spear.Math.Vector.Vector4 ( - Vector4 + Vector4(..) -- * Construction , unitx4 , unity4 @@ -34,32 +34,32 @@ instance Num Vector4 where abs (Vector4 ax ay az aw) = Vector4 (abs ax) (abs ay) (abs az) (abs aw) signum (Vector4 ax ay az aw) = Vector4 (signum ax) (signum ay) (signum az) (signum aw) fromInteger i = Vector4 i' i' i' i' where i' = fromInteger i - - + + instance Fractional Vector4 where Vector4 ax ay az aw / Vector4 bx by bz bw = Vector4 (ax / bx) (ay / by) (az / bz) (aw / bw) fromRational r = Vector4 r' r' r' r' where r' = fromRational r - - + + instance Ord Vector4 where Vector4 ax ay az aw <= Vector4 bx by bz bw = (ax <= bx) || (az == bx && ay <= by) || (ax == bx && ay == by && az <= bz) || (ax == bx && ay == by && az == bz && aw <= bw) - + Vector4 ax ay az aw >= Vector4 bx by bz bw = (ax >= bx) || (ax == bx && ay >= by) || (ax == bx && ay == by && az >= bz) || (ax == bx && ay == by && az == bz && aw >= bw) - + Vector4 ax ay az aw < Vector4 bx by bz bw = (ax < bx) || (az == bx && ay < by) || (ax == bx && ay == by && az < bz) || (ax == bx && ay == by && az == bz && aw < bw) - + Vector4 ax ay az aw > Vector4 bx by bz bw = (ax > bx) || (ax == bx && ay > by) @@ -88,29 +88,29 @@ instance VectorClass Vector4 where {-# INLINABLE w #-} w (Vector4 _ _ _ aw) = aw - + {-# INLINABLE (!) #-} (Vector4 ax _ _ _) ! 0 = ax (Vector4 _ ay _ _) ! 1 = ay (Vector4 _ _ az _) ! 2 = az (Vector4 _ _ _ aw) ! 3 = aw _ ! _ = 0 - + {-# INLINABLE dot #-} Vector4 ax ay az aw `dot` Vector4 bx by bz bw = ax*bx + ay*by + az*bz + aw*bw - + {-# INLINABLE normSq #-} normSq (Vector4 ax ay az aw) = ax*ax + ay*ay + az*az + aw*aw - + {-# INLINABLE norm #-} norm = sqrt . normSq - + {-# INLINABLE scale #-} scale s (Vector4 ax ay az aw) = Vector4 (s*ax) (s*ay) (s*az) (s*aw) - + {-# INLINABLE neg #-} neg (Vector4 ax ay az aw) = Vector4 (-ax) (-ay) (-az) (-aw) - + {-# INLINABLE normalise #-} normalise v = let n' = norm v @@ -124,14 +124,14 @@ sizeFloat = sizeOf (undefined :: CFloat) instance Storable Vector4 where sizeOf _ = 4*sizeFloat alignment _ = alignment (undefined :: CFloat) - + peek ptr = do ax <- peekByteOff ptr 0 ay <- peekByteOff ptr $ 1 * sizeFloat az <- peekByteOff ptr $ 2 * sizeFloat aw <- peekByteOff ptr $ 3 * sizeFloat return (Vector4 ax ay az aw) - + poke ptr (Vector4 ax ay az aw) = do pokeByteOff ptr 0 ax pokeByteOff ptr (1 * sizeFloat) ay diff --git a/Spear/Scene/GameObject.hs b/Spear/Scene/GameObject.hs deleted file mode 100644 index 190d0a5..0000000 --- a/Spear/Scene/GameObject.hs +++ /dev/null @@ -1,320 +0,0 @@ -module Spear.Scene.GameObject -( - GameObject -, GameStyle(..) -, Window(..) -, AM.AnimationSpeed - -- * Construction -, goNew - -- * Accessors -, currentAnimation ---, goAABB ---, goAABBs -, collisioners -, goRPGtransform -, numCollisioners -, renderer -, window - -- * Manipulation -, goUpdate -, setAnimation -, setAnimationSpeed -, setAxis -, withCollisioners -, setCollisioners -, setWindow - -- * Rendering -, goRender - -- * Collision -, goCollide -) -where - - -import Spear.GL -import Spear.Math.AABB -import qualified Spear.Math.Camera as Cam -import Spear.Math.Collision as Col -import qualified Spear.Math.Matrix3 as M3 -import qualified Spear.Math.Matrix4 as M4 -import Spear.Math.MatrixUtils -import qualified Spear.Math.Spatial2 as S2 -import qualified Spear.Math.Spatial3 as S3 -import Spear.Math.Utils -import Spear.Math.Vector -import qualified Spear.Render.AnimatedModel as AM -import Spear.Render.Program -import Spear.Render.StaticModel as SM - -import Data.Fixed (mod') -import Data.List (foldl') - - --- | Game style. -data GameStyle - = RPG -- ^ RPG or RTS style game. - | PLT -- ^ Platformer or space invaders style game. - - -data Window = Window - { projInv :: !M4.Matrix4 - , viewInv :: !M4.Matrix4 - , vpx :: !Float - , vpy :: !Float - , width :: !Float - , height :: !Float - } - - -dummyWindow = Window M4.id M4.id 0 0 640 480 - - --- | An object in the game scene. -data GameObject = GameObject - { gameStyle :: !GameStyle - , renderer :: !(Either StaticModelRenderer AM.AnimatedModelRenderer) - , collisioners :: ![Collisioner2] - , transform :: !M3.Matrix3 - , axis :: !Vector3 - , angle :: !Float - , window :: !Window - } - - -instance S2.Spatial2 GameObject where - - move v go = go - { collisioners = fmap (Col.move v) $ collisioners go - , transform = M3.translv v * transform go - } - - moveFwd s go = - let m = transform go - v = scale s $ M3.forward m - in go - { collisioners = fmap (Col.move v) $ collisioners go - , transform = M3.translv v * m - } - - moveBack s go = - let m = transform go - v = scale (-s) $ M3.forward m - in go - { collisioners = fmap (Col.move v) $ collisioners go - , transform = M3.translv v * m - } - - strafeLeft s go = - let m = transform go - v = scale (-s) $ M3.right m - in go - { collisioners = fmap (Col.move v) $ collisioners go - , transform = M3.translv v * m - } - - strafeRight s go = - let m = transform go - v = scale s $ M3.right m - in go - { collisioners = fmap (Col.move v) $ collisioners go - , transform = M3.translv v * m - } - - rotate a go = - go - { transform = transform go * M3.rot a - , angle = (angle go + a) `mod'` 360 - } - - setRotation a go = - go - { transform = M3.translation (transform go) * M3.rot a - , angle = a - } - - pos go = M3.position . transform $ go - - fwd go = M3.forward . transform $ go - - up go = M3.up . transform $ go - - right go = M3.right . transform $ go - - transform go = Spear.Scene.GameObject.transform go - - setTransform mat go = go { transform = mat } - - setPos pos go = - let m = transform go - in go { transform = M3.transform (M3.right m) (M3.forward m) pos } - - lookAt p go = - let position = S2.pos go - fwd = normalise $ p - position - r = perp fwd - toDeg = (*(180/pi)) - viewI = viewInv . window $ go - p1 = viewToWorld2d position viewI - p2 = viewToWorld2d (position + fwd) viewI - f = normalise $ p2 - p1 - in - go - { transform = M3.transform r fwd position - , angle = 180 - - if x f > 0 - then toDeg . acos $ f `dot` unity2 - else (+180) . toDeg . acos $ f `dot` (-unity2) - } - - --- | Create a new game object. -goNew :: GameStyle - -> Either StaticModelResource AM.AnimatedModelResource - -> [Collisioner2] - -> M3.Matrix3 -- ^ Transform - -> Vector3 -- ^ Axis of rotation - -> GameObject - -goNew style (Left smr) cols transf axis = GameObject - style (Left $ SM.staticModelRenderer smr) cols transf axis 0 dummyWindow - -goNew style (Right amr) cols transf axis = GameObject - style (Right $ AM.animatedModelRenderer 1 amr) cols transf axis 0 dummyWindow - - -goUpdate :: Float -> GameObject -> GameObject -goUpdate dt go = - let rend = renderer go - rend' = case rend of - Left _ -> rend - Right amr -> Right $ AM.update dt amr - in go - { renderer = rend' - } - - --- | Get the game object's ith bounding box. ---goAABB :: Int -> GameObject -> AABB2 ---goAABB i = getAABB . flip (!!) i . collisioners - - --- | Get the game object's bounding boxes. ---goAABBs :: GameObject -> [AABB2] ---goAABBs = fmap getAABB . collisioners - - --- | Get the game object's 3D transform. -goRPGtransform :: GameObject -> M4.Matrix4 -goRPGtransform go = - let viewI = viewInv . window $ go - in rpgTransform 0 (angle go) (axis go) (S2.pos go) viewI - - --- | Get the game object's current animation. -currentAnimation :: Enum a => GameObject -> a -currentAnimation go = case renderer go of - Left _ -> toEnum 0 - Right amr -> AM.currentAnimation amr - - --- | Return the game object's number of collisioners. -numCollisioners :: GameObject -> Int -numCollisioners = length . collisioners - - --- | Set the game object's current animation. -setAnimation :: Enum a => a -> GameObject -> GameObject -setAnimation a go = case renderer go of - Left _ -> go - Right amr -> go { renderer = Right $ AM.setAnimation a amr } - - --- | Set the game object's animation speed. -setAnimationSpeed :: AM.AnimationSpeed -> GameObject -> GameObject -setAnimationSpeed s go = case renderer go of - Left _ -> go - Right amr -> go { renderer = Right $ AM.setAnimationSpeed s amr } - - --- | Set the game object's axis of rotation. -setAxis :: Vector3 -> GameObject -> GameObject -setAxis ax go = go { axis = ax } - - --- | Set the game object's collisioners. -setCollisioners :: [Collisioner2] -> GameObject -> GameObject -setCollisioners cols go = go { collisioners = cols } - - --- | Set the game object's window. -setWindow :: Window -> GameObject -> GameObject -setWindow wnd go = go { window = wnd } - - --- | Manipulate the game object's collisioners. -withCollisioners :: GameObject -> ([Collisioner2] -> [Collisioner2]) -> GameObject -withCollisioners go f = go { collisioners = f $ collisioners go } - - --- | Render the game object. -goRender :: StaticProgram -> AnimatedProgram -> Cam.Camera -> GameObject -> IO () -goRender sprog aprog cam go = - let spu = staticProgramUniforms sprog - apu = animatedProgramUniforms aprog - style = gameStyle go - axis' = axis go - a = angle go - proj = Cam.projection cam - view = M4.inverseTransform $ S3.transform cam - transf = S2.transform go - normal = fastNormalMatrix modelview - modelview = case style of - RPG -> view * goRPGtransform go - PLT -> view * pltTransform transf - in case renderer go of - Left smr -> - goRender' style a axis' sprog spu modelview proj normal - (SM.bind spu smr) (SM.render spu smr) - Right amr -> - goRender' style a axis' aprog apu modelview proj normal - (AM.bind apu amr) (AM.render apu amr) - - -type Bind = IO () - -type Render = IO () - - -goRender' :: (ProgramUniforms u, Program p) - => GameStyle - -> Float - -> Vector3 - -> p - -> u - -> M4.Matrix4 -- Modelview - -> M4.Matrix4 -- Projection - -> M3.Matrix3 -- Normal matrix - -> Bind - -> Render - -> IO () -goRender' style a axis prog uniforms modelview proj normal bindRenderer render = - let - in do - useProgram . program $ prog - uniform (projLoc uniforms) proj - uniform (modelviewLoc uniforms) modelview - uniform (normalmatLoc uniforms) normal - bindRenderer - render - - --- | Return 'True' if the given game objects collide, 'False' otherwise. -goCollide :: GameObject -> GameObject -> Bool -goCollide go1 go2 = - let cols1 = collisioners go1 - cols2 = collisioners go2 - c1 = cols1 !! 0 - c2 = cols2 !! 0 - in - if length cols1 == 0 || length cols2 == 0 then False - else c1 `collide` c2 /= NoCollision \ No newline at end of file diff --git a/Spear/Scene/Light.hs b/Spear/Scene/Light.hs deleted file mode 100644 index fb4225b..0000000 --- a/Spear/Scene/Light.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Spear.Scene.Light -( - Light(..) -) -where - - -import qualified Spear.Math.Matrix4 as M -import qualified Spear.Math.Spatial3 as S -import Spear.Math.Vector - - -data Light - = PointLight - { ambient :: Vector3 - , diffuse :: Vector3 - , specular :: Vector3 - , transform :: M.Matrix4 - } - | DirectionalLight - { ambient :: Vector3 - , diffuse :: Vector3 - , specular :: Vector3 - , direction :: Vector3 - } - | SpotLight - { ambient :: Vector3 - , diffuse :: Vector3 - , specular :: Vector3 - , transform :: M.Matrix4 - } diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs index 43ed404..7c072e8 100644 --- a/Spear/Scene/Loader.hs +++ b/Spear/Scene/Loader.hs @@ -1,12 +1,9 @@ module Spear.Scene.Loader ( SceneResources(..) -, CreateGameObject , loadScene , validate , resourceMap -, loadGO -, loadObjects , value , unspecified , mandatory @@ -29,9 +26,7 @@ import Spear.Render.AnimatedModel as AM import Spear.Render.Material import Spear.Render.Program import Spear.Render.StaticModel as SM -import Spear.Scene.GameObject as GO import Spear.Scene.Graph -import Spear.Scene.Light import Spear.Scene.SceneResources import Control.Monad.State.Strict @@ -68,7 +63,6 @@ resourceMap' node@(SceneLeaf nid props) = do case nid of "shader-program" -> newShaderProgram node "model" -> newModel node - "light" -> newLight node x -> return () resourceMap' node@(SceneNode nid props children) = do @@ -296,73 +290,6 @@ loadShader shaderType ((stype, file):xs) = loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShader shaderType file -newLight :: SceneGraph -> Loader () -newLight _ = return () - --------------------- --- Object Loading -- --------------------- - -loadGO :: GameStyle -> SceneResources -> [Property] -> Matrix3 -> Game s GameObject -loadGO style sceneRes props transf = do - modelName <- asString . mandatory "model" $ props - axis <- asVec3 . mandatory "axis" $ props - let animSpeed = asFloat . value "animation-speed" $ props - go <- case getAnimatedModel sceneRes modelName of - Just model -> - return $ goNew style (Right model) [] transf axis - Nothing -> - case getStaticModel sceneRes modelName of - Just model -> - return $ goNew style (Left model) [] transf axis - Nothing -> - gameError $ "model " ++ modelName ++ " not found" - return $ case animSpeed of - Nothing -> go - Just s -> GO.setAnimationSpeed s go - -type CreateGameObject m a - = String -- ^ The object's name. - -> SceneResources - -> [Property] - -> Matrix3 -- ^ The object's transform. - -> m a - --- | Load objects from the given 'SceneGraph'. -loadObjects :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> m [a] -loadObjects newGO sceneRes g = - case node "layout" g of - Nothing -> return [] - Just n -> sequence . concat . fmap (newObject newGO sceneRes) $ children n - --- to-do: use a strict accumulator and make loadObjects tail recursive. -newObject :: Monad m => CreateGameObject m a -> SceneResources -> SceneGraph -> [m a] -newObject newGO sceneRes (SceneNode nid props children) = - let o = newObject' newGO sceneRes nid props - in o : (concat $ fmap (newObject newGO sceneRes) children) - -newObject newGO sceneRes (SceneLeaf nid props) = [newObject' newGO sceneRes nid props] - -newObject' :: Monad m => CreateGameObject m a -> SceneResources -> String -> [Property] -> m a -newObject' newGO sceneRes nid props = do - -- Optional properties. - let goType = (asString $ value "type" props) `unspecified` "unknown" - position = (asVec2 $ value "position" props) `unspecified` vec2 0 0 - rotation = (asVec2 $ value "rotation" props) `unspecified` vec2 0 0 - right' = (asVec2 $ value "right" props) `unspecified` vec2 1 0 - up' = asVec2 $ value "up" props - scale = (asVec2 $ value "scale" props) `unspecified` vec2 1 1 - - -- Compute the object's vectors if an up/forward vector has been specified. - let (right, up) = vectors up' - - newGO goType sceneRes props (M3.transform right up position) - -vectors :: Maybe Vector2 -> (Vector2, Vector2) -vectors up = case up of - Nothing -> (unitx2, unity2) - Just u -> (perp u, u) - ---------------------- -- Helper functions -- ---------------------- diff --git a/Spear/Scene/SceneResources.hs b/Spear/Scene/SceneResources.hs index 3c7d204..de2fc80 100644 --- a/Spear/Scene/SceneResources.hs +++ b/Spear/Scene/SceneResources.hs @@ -24,7 +24,6 @@ import Spear.Render.AnimatedModel import Spear.Render.Material import Spear.Render.Program import Spear.Render.StaticModel -import Spear.Scene.Light import Data.Map as M @@ -36,12 +35,11 @@ data SceneResources = SceneResources , textures :: Map String Texture , staticModels :: Map String StaticModelResource , animatedModels :: Map String AnimatedModelResource - , lights :: [Light] } -- | Build an empty instance of 'SceneResources'. emptySceneResources = - SceneResources M.empty M.empty M.empty M.empty M.empty M.empty M.empty [] + SceneResources M.empty M.empty M.empty M.empty M.empty M.empty M.empty -- | Get the shader specified by the given string. getShader :: SceneResources -> String -> Maybe GLSLShader diff --git a/Spear/Sys/Timer.hsc b/Spear/Sys/Timer.hsc index 16f377e..60ae9d7 100644 --- a/Spear/Sys/Timer.hsc +++ b/Spear/Sys/Timer.hsc @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Spear.Sys.Timer ( Timer diff --git a/Spear/Window.hs b/Spear/Window.hs new file mode 100644 index 0000000..1762da0 --- /dev/null +++ b/Spear/Window.hs @@ -0,0 +1,311 @@ +module Spear.Window +( + -- * Setup + Dimensions +, Context +, WindowTitle +, FrameCap +, DisplayBits(..) +, WindowMode(..) + -- * Window +, Window +, Width +, Height +, Init +, withWindow +, events + -- * Animation +, Dt +, Step +, loop +, GLFW.swapBuffers + -- * Input +, InputEvent(..) +, Key(..) +, MouseButton(..) +, MouseProp(..) +, MousePos +, MouseDelta +) +where + +import Spear.Game +import Spear.Sys.Timer as Timer + +import Data.Char (ord) +import Control.Concurrent.MVar +import Control.Monad (when) +import Control.Monad.IO.Class +import qualified Graphics.UI.GLFW as GLFW +import Graphics.UI.GLFW (DisplayBits(..), WindowMode(..)) +import qualified Graphics.Rendering.OpenGL as GL + +type Width = Int +type Height = Int + +-- | Window dimensions. +type Dimensions = (Width, Height) + +-- | A tuple specifying the desired OpenGL context, of the form (Major, Minor). +type Context = (Int, Int) + +type WindowTitle = String + +type CloseRequest = MVar Bool + +-- | A window. +data Window = Window + { closeRequest :: CloseRequest + , inputEvents :: MVar [InputEvent] + } + +-- | Poll the window's events. +events :: MonadIO m => Window -> m [InputEvent] +events wnd = liftIO $ do + es <- tryTakeMVar (inputEvents wnd) >>= \xs -> case xs of + Nothing -> return [] + Just es -> return es + putMVar (inputEvents wnd) [] + return es + +-- | Game initialiser. +type Init s = Window -> Game () s + +withWindow :: MonadIO m + => Dimensions -> [DisplayBits] -> WindowMode -> Context + -> Maybe WindowTitle + -> Init s + -> (Window -> Game s a) + -> m (Either String a) +withWindow dim@(w,h) displayBits windowMode glVersion windowTitle init run = + liftIO $ flip runGame' () $ do + glfwInit + wnd <- setup dim displayBits windowMode glVersion windowTitle + gameState <- init wnd + result <- evalSubGame (run wnd) gameState + gameIO GLFW.closeWindow + gameIO GLFW.terminate + return result + +setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle + -> Game s Window +setup (w, h) displayBits windowMode (major, minor) wndTitle = do + closeRequest <- liftIO newEmptyMVar + inputEvents <- liftIO newEmptyMVar + let onResize' = onResize inputEvents + let dimensions = GL.Size (fromIntegral w) (fromIntegral h) + result <- liftIO $ do + GLFW.openWindowHint GLFW.OpenGLVersionMajor major + GLFW.openWindowHint GLFW.OpenGLVersionMinor minor + compat (major, minor) + GLFW.disableSpecial GLFW.AutoPollEvent + GLFW.openWindow dimensions (defaultBits displayBits) windowMode + when (not result) $ gameError "GLFW.openWindow failed" + liftIO $ do + GLFW.windowTitle GL.$= case wndTitle of + Nothing -> "Spear Game Framework" + Just title -> title + GLFW.windowCloseCallback GL.$= (onWindowClose closeRequest) + GLFW.windowSizeCallback GL.$= onResize' + GLFW.keyCallback GL.$= onKey inputEvents + GLFW.charCallback GL.$= onChar inputEvents + GLFW.mouseButtonCallback GL.$= onMouseButton inputEvents + onMouseMove inputEvents >>= (GLFW.mousePosCallback GL.$=) + onResize' (GL.Size (fromIntegral w) (fromIntegral h)) + return $ Spear.Window.Window closeRequest inputEvents + +defaultBits [] = [DisplayRGBBits 8 8 8] +defaultBits xs = xs + +compat (major, minor) + | major >= 3 = GLFW.openWindowHint GLFW.OpenGLProfile GLFW.OpenGLCompatProfile + | otherwise = return () + +glfwInit :: Game s () +glfwInit = do + result <- liftIO GLFW.initialize + case result of + False -> gameError "GLFW.initialize failed" + True -> return () + +-- | Time elapsed since the last frame. +type Dt = Float + +-- | Return true if the application should continue running, false otherwise. +type Step s = Dt -> Game s (Bool) + +-- | Maximum frame rate. +type FrameCap = Int + +-- | Run the application's main loop. +loop :: Maybe FrameCap -> Step s -> Window -> Game s () +loop (Just maxFPS) step wnd = loopCapped maxFPS step wnd +loop Nothing step wnd = do + timer <- gameIO $ start newTimer + run (closeRequest wnd) timer step + return () + +run :: CloseRequest -> Timer -> Step s -> Game s () +run closeRequest timer step = do + timer' <- gameIO $ tick timer + continue <- step $ getDelta timer' + close <- gameIO $ getRequest closeRequest + when (continue && (not close)) $ run closeRequest timer' step + +loopCapped :: Int -> Step s -> Window -> Game s () +loopCapped maxFPS step wnd = do + let ddt = 1.0 / (fromIntegral maxFPS) + closeReq = closeRequest wnd + frameTimer <- gameIO $ start newTimer + controlTimer <- gameIO $ start newTimer + runCapped closeReq ddt frameTimer controlTimer step + return () + +runCapped :: CloseRequest -> Float -> Timer -> Timer -> Step s -> Game s () +runCapped closeRequest ddt frameTimer controlTimer step = do + controlTimer' <- gameIO $ tick controlTimer + frameTimer' <- gameIO $ tick frameTimer + continue <- step $ getDelta frameTimer' + close <- gameIO $ getRequest closeRequest + controlTimer'' <- gameIO $ tick controlTimer' + let dt = getDelta controlTimer'' + when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) + when (continue && (not close)) $ + runCapped closeRequest ddt frameTimer' controlTimer'' step + +getRequest :: MVar Bool -> IO Bool +getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of + Nothing -> False + Just x -> x + +onWindowClose :: MVar Bool -> GLFW.WindowCloseCallback +onWindowClose closeRequest = putMVar closeRequest True >> return False + +onResize :: MVar [InputEvent] -> GLFW.WindowSizeCallback +onResize es (GL.Size w h) = addEvent es $ Resize (fromIntegral w) (fromIntegral h) + +onKey :: MVar [InputEvent] -> GLFW.KeyCallback +onKey es key GLFW.Press = addEvent es $ KeyDown (fromGLFWkey key) +onKey es key GLFW.Release = addEvent es $ KeyUp (fromGLFWkey key) + +onChar :: MVar [InputEvent] -> GLFW.CharCallback +onChar es c GLFW.Press = addEvent es $ KeyDown (fromGLFWkey (GLFW.CharKey c)) +onChar es c GLFW.Release = addEvent es $ KeyUp (fromGLFWkey (GLFW.CharKey c)) + +onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback +onMouseButton es bt GLFW.Press = addEvent es $ MouseDown (fromGLFWbutton bt) +onMouseButton es bt GLFW.Release = addEvent es $ MouseUp (fromGLFWbutton bt) + +onMouseMove :: MVar [InputEvent] -> IO GLFW.MousePosCallback +onMouseMove es = newEmptyMVar >>= return . flip onMouseMove' es + +onMouseMove' :: MVar MousePos -> MVar [InputEvent] -> GLFW.MousePosCallback +onMouseMove' oldPos es (GL.Position x y) = do + let (x',y') = (fromIntegral x, fromIntegral y) + (old_x, old_y) <- tryTakeMVar oldPos >>= \x -> case x of + Nothing -> return (x',y') + Just p -> return p + let delta = (x'-old_x, y'-old_y) + putMVar oldPos (x',y') + addEvent es $ MouseMove (x',y') delta + +replaceMVar :: MVar a -> a -> IO () +replaceMVar mvar val = tryTakeMVar mvar >> putMVar mvar val + +addEvent :: MVar [a] -> a -> IO () +addEvent mvar val = tryTakeMVar mvar >>= \xs -> case xs of + Nothing -> putMVar mvar [val] + Just es -> putMVar mvar (val:es) + +-- Input + +data InputEvent + = Resize Width Height + | KeyDown Key + | KeyUp Key + | MouseDown MouseButton + | MouseUp MouseButton + | MouseMove MousePos MouseDelta + deriving (Eq, Show) + +data Key + = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H + | KEY_I | KEY_J | KEY_K | KEY_L | KEY_M | KEY_N | KEY_O | KEY_P + | KEY_Q | KEY_R | KEY_S | KEY_T | KEY_U | KEY_V | KEY_W | KEY_X + | KEY_Y | KEY_Z | KEY_0 | KEY_1 | KEY_2 | KEY_3 | KEY_4 | KEY_5 + | KEY_6 | KEY_7 | KEY_8 | KEY_9 | KEY_F1 | KEY_F2 | KEY_F3 + | KEY_F4 | KEY_F5 | KEY_F6 | KEY_F7 | KEY_F8 | KEY_F9 | KEY_F10 + | KEY_F11 | KEY_F12 | KEY_ESC | KEY_SPACE | KEY_UP | KEY_DOWN + | KEY_LEFT | KEY_RIGHT | KEY_UNKNOWN + deriving (Eq, Enum, Bounded, Show) + +data MouseButton = LMB | RMB | MMB + deriving (Eq, Enum, Bounded, Show) + +data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta + deriving (Eq, Enum, Bounded, Show) + +type MousePos = (Int,Int) +type MouseDelta = (Int,Int) + +fromGLFWkey :: GLFW.Key -> Key +fromGLFWkey (GLFW.CharKey 'A') = KEY_A +fromGLFWkey (GLFW.CharKey 'B') = KEY_B +fromGLFWkey (GLFW.CharKey 'C') = KEY_C +fromGLFWkey (GLFW.CharKey 'D') = KEY_D +fromGLFWkey (GLFW.CharKey 'E') = KEY_E +fromGLFWkey (GLFW.CharKey 'F') = KEY_F +fromGLFWkey (GLFW.CharKey 'G') = KEY_G +fromGLFWkey (GLFW.CharKey 'H') = KEY_H +fromGLFWkey (GLFW.CharKey 'I') = KEY_I +fromGLFWkey (GLFW.CharKey 'J') = KEY_J +fromGLFWkey (GLFW.CharKey 'K') = KEY_K +fromGLFWkey (GLFW.CharKey 'L') = KEY_L +fromGLFWkey (GLFW.CharKey 'M') = KEY_M +fromGLFWkey (GLFW.CharKey 'N') = KEY_N +fromGLFWkey (GLFW.CharKey 'O') = KEY_O +fromGLFWkey (GLFW.CharKey 'P') = KEY_P +fromGLFWkey (GLFW.CharKey 'Q') = KEY_Q +fromGLFWkey (GLFW.CharKey 'R') = KEY_R +fromGLFWkey (GLFW.CharKey 'S') = KEY_S +fromGLFWkey (GLFW.CharKey 'T') = KEY_T +fromGLFWkey (GLFW.CharKey 'U') = KEY_U +fromGLFWkey (GLFW.CharKey 'V') = KEY_V +fromGLFWkey (GLFW.CharKey 'W') = KEY_W +fromGLFWkey (GLFW.CharKey 'X') = KEY_X +fromGLFWkey (GLFW.CharKey 'Y') = KEY_Y +fromGLFWkey (GLFW.CharKey 'Z') = KEY_Z +fromGLFWkey (GLFW.CharKey '0') = KEY_0 +fromGLFWkey (GLFW.CharKey '1') = KEY_1 +fromGLFWkey (GLFW.CharKey '2') = KEY_2 +fromGLFWkey (GLFW.CharKey '3') = KEY_3 +fromGLFWkey (GLFW.CharKey '4') = KEY_4 +fromGLFWkey (GLFW.CharKey '5') = KEY_5 +fromGLFWkey (GLFW.CharKey '6') = KEY_6 +fromGLFWkey (GLFW.CharKey '7') = KEY_7 +fromGLFWkey (GLFW.CharKey '8') = KEY_8 +fromGLFWkey (GLFW.CharKey '9') = KEY_9 +fromGLFWkey (GLFW.CharKey ' ') = KEY_SPACE +fromGLFWkey (GLFW.SpecialKey GLFW.F1) = KEY_F1 +fromGLFWkey (GLFW.SpecialKey GLFW.F2) = KEY_F2 +fromGLFWkey (GLFW.SpecialKey GLFW.F3) = KEY_F3 +fromGLFWkey (GLFW.SpecialKey GLFW.F4) = KEY_F4 +fromGLFWkey (GLFW.SpecialKey GLFW.F5) = KEY_F5 +fromGLFWkey (GLFW.SpecialKey GLFW.F6) = KEY_F6 +fromGLFWkey (GLFW.SpecialKey GLFW.F7) = KEY_F7 +fromGLFWkey (GLFW.SpecialKey GLFW.F8) = KEY_F8 +fromGLFWkey (GLFW.SpecialKey GLFW.F9) = KEY_F9 +fromGLFWkey (GLFW.SpecialKey GLFW.F10) = KEY_F10 +fromGLFWkey (GLFW.SpecialKey GLFW.F11) = KEY_F11 +fromGLFWkey (GLFW.SpecialKey GLFW.F12) = KEY_F12 +fromGLFWkey (GLFW.SpecialKey GLFW.ESC) = KEY_ESC +fromGLFWkey (GLFW.SpecialKey GLFW.UP) = KEY_UP +fromGLFWkey (GLFW.SpecialKey GLFW.DOWN) = KEY_DOWN +fromGLFWkey (GLFW.SpecialKey GLFW.LEFT) = KEY_LEFT +fromGLFWkey (GLFW.SpecialKey GLFW.RIGHT) = KEY_RIGHT +fromGLFWkey _ = KEY_UNKNOWN + +fromGLFWbutton :: GLFW.MouseButton -> MouseButton +fromGLFWbutton GLFW.ButtonLeft = LMB +fromGLFWbutton GLFW.ButtonRight = RMB +fromGLFWbutton GLFW.ButtonMiddle = MMB diff --git a/demos/pong/LICENSE b/demos/pong/LICENSE new file mode 100644 index 0000000..2ad9c8d --- /dev/null +++ b/demos/pong/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Marc Sunet + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Marc Sunet nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs new file mode 100644 index 0000000..8c379ec --- /dev/null +++ b/demos/pong/Main.hs @@ -0,0 +1,86 @@ +module Main where + +import Pong + +import Spear.Math.AABB +import Spear.Math.Spatial2 +import Spear.Math.Vector +import Spear.Game +import Spear.Window + +import Data.Maybe (mapMaybe) +import qualified Graphics.Rendering.OpenGL.GL as GL +import Graphics.Rendering.OpenGL.GL (($=)) + +data GameState = GameState + { wnd :: Window + , elapsed :: Double + , world :: [GameObject] + } + +main = do + result <- run + case result of + Left err -> putStrLn err + Right _ -> return () + +run = withWindow (640,480) [] Window (2,0) (Just "Pong") initGame + $ loop (Just 30) step + +initGame wnd = do + gameIO $ do + GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0 + GL.matrixMode $= GL.Modelview 0 + GL.loadIdentity + return $ GameState wnd 0 newWorld + +step :: Dt -> Game GameState Bool +step dt = do + gs <- getGameState + evts <- events (wnd gs) + gameIO . process $ evts + let evts' = translate evts + modifyGameState $ \ gs -> gs + { world = stepWorld (elapsed gs) dt evts' (world gs) + , elapsed = elapsed gs + realToFrac dt } + getGameState >>= \gs -> gameIO . render $ world gs + return (not $ exitRequested evts) + +render world = do + GL.clear [GL.ColorBuffer] + mapM_ renderGO world + swapBuffers + +renderGO :: GameObject -> IO () +renderGO go = do + let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go + (Vector2 xcenter ycenter) = pos go + (xmin,ymin,xmax,ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') + GL.preservingMatrix $ do + GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) + GL.renderPrimitive (GL.TriangleStrip) $ do + GL.vertex (GL.Vertex2 xmin ymax) + GL.vertex (GL.Vertex2 xmin ymin) + GL.vertex (GL.Vertex2 xmax ymax) + GL.vertex (GL.Vertex2 xmax ymin) + +process = mapM_ procEvent +procEvent (Resize w h) = do + GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) + GL.matrixMode $= GL.Projection + GL.loadIdentity + GL.ortho 0 1 0 1 (-1) 1 + GL.matrixMode $= GL.Modelview 0 +procEvent _ = return () + +translate = mapMaybe translate' +translate' (KeyDown KEY_LEFT) = Just MoveLeft +translate' (KeyDown KEY_RIGHT) = Just MoveRight +translate' (KeyUp KEY_LEFT) = Just StopLeft +translate' (KeyUp KEY_RIGHT) = Just StopRight +translate' _ = Nothing + +exitRequested = any (==(KeyDown KEY_ESC)) + +f2d :: Float -> GL.GLdouble +f2d = realToFrac \ No newline at end of file diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs new file mode 100644 index 0000000..9a3138b --- /dev/null +++ b/demos/pong/Pong.hs @@ -0,0 +1,174 @@ +module Pong +( + GameEvent(..) +, GameObject +, newWorld +, stepWorld +, aabb +) +where + +import Spear.Math.AABB +import Spear.Math.Spatial2 +import Spear.Math.Vector + +import Data.List (foldl') +import Data.Monoid +import GHC.Float (double2Float) + +type Elapsed = Double +type Dt = Float + +-- Step function + +data Step a b = Step { step :: Elapsed -> Dt -> a -> (b, Step a b) } + +sid :: Step a a +sid = Step $ \_ _ a -> (a, sid) + +spure :: (a -> b) -> Step a b +spure f = Step $ \_ _ x -> (f x, spure f) + +smap :: (a -> b) -> Step c a -> Step c b +smap f (Step s1) = Step $ \elapsed dt x -> + let (a, s') = s1 elapsed dt x + in (f a, smap f s') + +(.>) :: Step a b -> Step b c -> Step a c +(Step s1) .> (Step s2) = Step $ \elapsed dt a -> + let (b, s1') = s1 elapsed dt a + (c, s2') = s2 elapsed dt b + in (c, s1' .> s2') + +(.<) :: Step a b -> Step c a -> Step c b +(.<) = flip (.>) + +sfst :: Step (a,b) a +sfst = spure $ \(a,_) -> a + +ssnd :: Step (a,b) b +ssnd = spure $ \(_,b) -> b + +-- Game events + +data GameEvent + = MoveLeft + | MoveRight + | StopLeft + | StopRight + deriving Eq + +-- Game objects + +data GameObject = GameObject + { aabb :: AABB2 + , obj :: Obj2 + , gostep :: Step ([GameEvent], [GameObject], GameObject) GameObject + } + +instance Spatial2 GameObject where + getObj2 = obj + setObj2 s o = s { obj = o } + +stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] +stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos + +update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject +update elapsed dt evts gos go = + let (go', s') = step (gostep go) elapsed dt (evts, gos, go) + in go' { gostep = s' } + +ballBox :: AABB2 +ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01 + +padSize = vec2 0.05 0.02 + +padBox = AABB2 (-padSize) padSize + +obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) + +ballVelocity = Vector2 0.3 0.3 + +newWorld = + [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity + , GameObject padBox (obj2 0.5 0.9) stepEnemy + , GameObject padBox (obj2 0.5 0.1) stepPlayer + ] + +-- Generic steppers + +ignore :: Step ([GameEvent], [GameObject], GameObject) GameObject +ignore = spure $ \(_,_,go) -> go + +ignoreEvts :: Step ([GameEvent], [GameObject], GameObject) ([GameObject], GameObject) +ignoreEvts = spure $ \(_, world, go) -> (world, go) + +ignoreGOs :: Step ([GameEvent], [GameObject], GameObject) ([GameEvent], GameObject) +ignoreGOs = spure $ \(evts, _, go) -> (evts, go) + +-- Ball steppers + +stepBall vel = ignoreEvts .> collideBall vel .> moveBall + +collideBall :: Vector2 -> Step ([GameObject], GameObject) (Vector2, GameObject) +collideBall vel = Step $ \_ _ (gos, ball) -> + let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball + collideCol = x pmin < 0 || x pmax > 1 + collideRow = y pmin < 0 || y pmax > 1 + || any (collide ball) (tail gos) + negx v@(Vector2 x y) = if collideCol then vec2 (-x) y else v + negy v@(Vector2 x y) = if collideRow then vec2 x (-y) else v + vel' = negx . negy $ vel + in ((vel', ball), collideBall vel') + +collide go1 go2 = + let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) + = aabb go1 `aabbAdd` pos go1 + (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) + = aabb go2 `aabbAdd` pos go2 + in not $ xmax1 < xmin2 || xmin1 > xmax2 + || ymax1 < ymin2 || ymin1 > ymax2 + +aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) + +moveBall :: Step (Vector2, GameObject) GameObject +moveBall = Step $ \_ dt (vel,ball) -> (move (scale dt vel) ball, moveBall) + +-- Enemy stepper + +stepEnemy = ignore .> movePad + +movePad :: Step GameObject GameObject +movePad = Step $ \elapsed _ pad -> + let p = vec2 px 0.9 + px = double2Float (sin elapsed * 0.5 + 0.5) + * (1 - 2 * x padSize) + + x padSize + in (setPos p pad, movePad) + +-- Player stepper + +stepPlayer = ignoreGOs + .> moveGO False MoveLeft StopLeft + .> moveGO False MoveRight StopRight + .> ssnd + .> clamp + +moveGO :: Bool -> GameEvent -> GameEvent + -> Step ([GameEvent], GameObject) ([GameEvent], GameObject) +moveGO moving start stop = Step $ \_ dt (evts, go) -> + let moving' = (moving || any (==start) evts) && not (any (==stop) evts) + dir = scale dt $ toDir moving' start + in ((evts, move dir go), moveGO moving' start stop) + +clamp :: Step GameObject GameObject +clamp = spure $ \go -> + let p' = vec2 (clamp' x s (1 - s)) y + (Vector2 x y) = pos go + clamp' x a b = if x < a then a else if x > b then b else x + (Vector2 s _) = padSize + in setPos p' go + +toDir True MoveLeft = vec2 (-1) 0 +toDir True MoveRight = vec2 1 0 +toDir _ _ = vec2 0 0 \ No newline at end of file diff --git a/demos/pong/Setup.hs b/demos/pong/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/demos/pong/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/demos/pong/pong.cabal b/demos/pong/pong.cabal new file mode 100644 index 0000000..bebedb9 --- /dev/null +++ b/demos/pong/pong.cabal @@ -0,0 +1,21 @@ +-- Initial pong.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: pong +version: 0.1.0.0 +synopsis: A pong clone +-- description: +license: BSD3 +license-file: LICENSE +author: Marc Sunet +-- maintainer: +-- copyright: +category: Game +build-type: Simple +cabal-version: >=1.8 + +executable pong + -- hs-source-dirs: src + main-is: Main.hs + -- other-modules: + build-depends: base ==4.6.*, Spear, OpenGL -- cgit v1.2.3