diff --git a/HGE2D.cabal b/HGE2D.cabal new file mode 100644 --- /dev/null +++ b/HGE2D.cabal @@ -0,0 +1,76 @@ +-- Initial HGE2D.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: HGE2D +version: 0.1.6.0 +synopsis: 2D game engine written in Haskell +description: See README and examples/ for further information +license: MIT +license-file: LICENSE +author: Martin Buck +maintainer: Martin Buck +copyright: Martin Buck +homepage: https://github.com/I3ck/HGE2D +bug-reports: https://github.com/I3ck/HGE2D/issues +category: Game +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/I3ck/HGE2D.git + +library + exposed-modules: + HGE2D.Shapes + HGE2D.Render + HGE2D.Colors + HGE2D.Datas + HGE2D.Types + HGE2D.Classes + HGE2D.Instances + HGE2D.Engine + HGE2D.GlFunctions + HGE2D.Time + HGE2D.Math + HGE2D.Geometry + HGE2D.Collision + HGE2D.Physical + -- other-modules: + -- other-extensions: + build-depends: + base >= 4.8 && < 4.9, + OpenGL >=3.0 && < 3.1, + GLUT >= 2.7 && < 2.8, + time >= 1.5.0.1 && < 1.7 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -O2 -W -fwarn-incomplete-patterns + +executable example1 + default-language: Haskell2010 + main-is: Example1.hs + build-depends: base >= 4.8 && < 4.9, HGE2D + hs-source-dirs: src/examples + ghc-options: -O2 -W -fwarn-incomplete-patterns + +executable example2 + default-language: Haskell2010 + main-is: Example2.hs + build-depends: base >= 4.8 && < 4.9, HGE2D + hs-source-dirs: src/examples + ghc-options: -O2 -W -fwarn-incomplete-patterns + +executable example3 + default-language: Haskell2010 + main-is: Example3.hs + build-depends: base >= 4.8 && < 4.9, HGE2D + hs-source-dirs: src/examples + ghc-options: -O2 -W -fwarn-incomplete-patterns + +executable example4 + default-language: Haskell2010 + main-is: Example4.hs + build-depends: base >= 4.8 && < 4.9, HGE2D + hs-source-dirs: src/examples + ghc-options: -O2 -W -fwarn-incomplete-patterns diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Martin Buck + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/HGE2D/Classes.hs b/src/HGE2D/Classes.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Classes.hs @@ -0,0 +1,67 @@ +-- | +-- Module : HGE2D.Classes +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing class definitions used within HGE2D + +{-# LANGUAGE ConstraintKinds #-} + +module HGE2D.Classes where + +import HGE2D.Types +import HGE2D.Datas + +-------------------------------------------------------------------------------- + +-- | For types which are affected by time +class Dynamic a where + moveInTime :: Millisecond -> a -> a + +-------------------------------------------------------------------------------- + +-- | For types than can be directly rendered to GL (only required by the engine) +-- Use GlInstructable to define your rendereble types +class GlRender a where + glRender :: a -> IO () + +-------------------------------------------------------------------------------- + +-- | For types which can be turned into render instructions to be rendered by the engine +class GlInstructable a where + toGlInstruction :: a -> RenderInstruction + +-------------------------------------------------------------------------------- + +-- | For types which have a bounding box +class HasBoundingBox a where + getBB :: a -> BoundingBox + +-------------------------------------------------------------------------------- + +-- | For types which have / are a physical object +class IsPhysicalObject a where + getPhys :: a -> PhysicalObject + setPhys :: PhysicalObject -> a -> a + +-------------------------------------------------------------------------------- + +-- | For types which are positioned in space +class Positioned a where + getPos :: a -> RealPosition + getX :: a -> Double + getY :: a -> Double + +-------------------------------------------------------------------------------- + +-- | For types which can be moved in space +class Moveable a where + moveBy :: RealPosition -> a -> a + moveTo :: RealPosition -> a -> a + +-------------------------------------------------------------------------------- + +-- | For types which can be accelerated +class Acceleratable a where + accBy :: Velocity -> a -> a + accTo :: Velocity -> a -> a diff --git a/src/HGE2D/Collision.hs b/src/HGE2D/Collision.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Collision.hs @@ -0,0 +1,66 @@ +-- | +-- Module : HGE2D.Collision +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing functions for collision detection + +module HGE2D.Collision where + +import HGE2D.Types +import HGE2D.Datas +import HGE2D.Classes + +-------------------------------------------------------------------------------- + +-- | Tests whether two objects collide (overlap in any way) +doCollide :: (HasBoundingBox a, HasBoundingBox b) => a -> b -> Bool +doCollide hasBB1 hasBB2 = 2.0 * xcenterthis - xcenterother < (xsizethis + xsizeother) + && 2.0 * ycenterthis - ycenterother < (ysizethis + ysizeother) + where + (bb1, bb2) = (getBB hasBB1, getBB hasBB2) + (minthis, maxthis) = (bbMin bb1, bbMax bb1) + (minother, maxother) = (bbMin bb2, bbMax bb2) + (xsizethis, ysizethis) = (abs $ (fst minthis) - (fst maxthis), abs $ (snd minthis) - (snd maxthis)) + (xsizeother, ysizeother) = (abs $ (fst minother) - (fst maxother), abs $ (snd minother) - (snd maxother)) + (xcenterthis, ycenterthis) = ((fst minthis) + (fst maxthis) / 2.0, (snd minthis) + (snd maxthis) / 2.0) + (xcenterother, ycenterother) = ((fst minother) + (fst maxother) / 2.0, (snd minother) + (snd maxother) / 2.0) + +-------------------------------------------------------------------------------- + +-- | Tests whether either of the two objects fully contain the other +doContain :: (HasBoundingBox a, HasBoundingBox b) => a -> b -> Bool +doContain hasBB1 hasBB2 = (isInside hasBB1 hasBB2) + || (isInside hasBB2 hasBB1) + +-------------------------------------------------------------------------------- + +-- | Tests whether the first is fully in the second +isInside :: (HasBoundingBox a, HasBoundingBox b) => a -> b -> Bool +isInside hasBBIn hasBBOut = (fst minIn) > (fst minOut) + && (snd minIn) > (snd minOut) + && (fst maxIn) < (fst maxOut) + && (snd maxIn) < (snd maxOut) + where + (bbIn, bbOut) = (getBB hasBBIn, getBB hasBBOut) + (minIn, maxIn) = (bbMin bbIn, bbMax bbIn) + (minOut, maxOut) = (bbMin bbOut, bbMax bbOut) + +-------------------------------------------------------------------------------- + +---TODO use HasPosition? + +-- | Tests whether a position is within the bounding box +isInsideRP :: (HasBoundingBox a) => RealPosition -> a -> Bool +isInsideRP pos hasBB = (posX > bbLeft) + && (posX < bbRight) + && (posY > bbTop) + && (posY < bbBottom) + where + posX = fst pos + posY = snd pos + bbTop = snd $ bbMin bb + bbRight = fst $ bbMax bb + bbBottom = snd $ bbMax bb + bbLeft = fst $ bbMin bb + bb = getBB hasBB diff --git a/src/HGE2D/Colors.hs b/src/HGE2D/Colors.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Colors.hs @@ -0,0 +1,48 @@ +-- | +-- Module : HGE2D.Colors +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing color definitions to have easy access to basic colors + +module HGE2D.Colors where + +import HGE2D.Types + +-------------------------------------------------------------------------------- + +colorBlack :: GlColorRGB +colorBlack = (0, 0, 0) + +colorWhite :: GlColorRGB +colorWhite = (1, 1, 1) + +colorIce :: GlColorRGB +colorIce = (0.45, 0.73, 0.98) + +colorMetal :: GlColorRGB +colorMetal = (0.73, 0.73, 0.73) + +colorWater :: GlColorRGB +colorWater = (0, 0, 1) + +colorGrass :: GlColorRGB +colorGrass = (0.3, 0.74, 0.2) + +colorForest :: GlColorRGB +colorForest = (0.13, 0.55, 0.13) + +colorGreen :: GlColorRGB +colorGreen = (0, 1, 0) + +colorRed :: GlColorRGB +colorRed = (1, 0, 0) + +colorPath :: GlColorRGB +colorPath = (0.16, 0.17, 0.16) + +colorRock :: GlColorRGB +colorRock = (0.73, 0.73, 0.73) + +colorLaser :: GlColorRGB +colorLaser = (0, 1, 0) diff --git a/src/HGE2D/Datas.hs b/src/HGE2D/Datas.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Datas.hs @@ -0,0 +1,81 @@ +-- | +-- Module : HGE2D.Datas +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing data definitions used within HGE2D + +module HGE2D.Datas where + +import HGE2D.Types + +import qualified Graphics.Rendering.OpenGL as GL + +-- | A physical object with position, sizes, velocities, accelerations, mass, drag etc. +data PhysicalObject = PhysicalObject + { physicalPos :: RealPosition + , physicalVel :: Velocity + , physicalAcc :: Acceleration + , physicalBB :: BoundingBox + , physicalRot :: Radian + , physicalRotSpeed :: RotationSpeed ---TODO rename to ..Vel + , physicalRotAcceleration :: RotationAcceleration ---TODO rename to Acc + , physicalMass :: Mass + , physicalDrag :: Drag + , physicalRotDrag :: Drag ---TODO RotDrag? + } deriving (Show, Read) + +-- | A rigidbody defined by position, size and velocity +data RigidBody = RigidBody + { rigidPos :: RealPosition -- current position + , rigidVel :: Velocity -- current velocity + , rigidBB :: BoundingBox -- bounding box + } deriving (Show, Read) + +-- | A bounding box defined by two positions in space +data BoundingBox = BoundingBox + { bbMin :: RealPosition -- lower left corner of bb + , bbMax :: RealPosition -- upper right corner of bb + } deriving (Show, Read) + +-- | A position defined in number of tiles in x and y direction +data TilePosition = TilePosition + { tileX :: Int -- position in number of tiles from left starting with 0 + , tileY :: Int -- position in number of tiles from top starting with 0 + } deriving (Show, Read, Eq) + +-------------------------------------------------------------------------------- + +-- | The enginestate which defines multiple callbacks required by the engine to interact with the gamestate +data EngineState a = EngineState + { click :: PosX -> PosY -> a -> a -- how your game should change when clicked + , mUp :: PosX -> PosY -> a -> a -- how your game should change when mouse up happens + , hover :: PosX -> PosY -> a -> a -- how your game should change when hovered + , drag :: PosX -> PosY -> a -> a -- how your game should change when dragged + , kDown :: PosX -> PosY -> Char -> a -> a -- how your game should change when a keyDown happened + , kUp :: PosX -> PosY -> Char -> a -> a -- how your game should change when a keyUp happened + , resize :: (Width, Height) -> a -> a -- how to resize your game + , getSize :: a -> (Width, Height) -- how to get the size of your game + , moveTime :: Millisecond -> a -> a -- how your game should change over time + , getTime :: a -> Millisecond -- how to get the current time of your game + , setTime :: Millisecond -> a -> a -- how to set the time of your game + , getTitle :: a -> String -- how to get the title of your game + , toGlInstr :: a -> RenderInstruction -- how to receive a render instruction to display your game + } + +-------------------------------------------------------------------------------- + +-- | The instructions used to render the game +data RenderInstruction = RenderNothing -- do nothing + | RenderWithCamera GlPosX GlPosY GlScaleX GlScaleY RenderInstruction -- render with a given camera view + | RenderText String -- render a string + | RenderLineStrip GlShape GL.GLfloat -- render as line strip + | RenderTriangle GlShape -- render as triangles / faces + | RenderLineLoop GlShape GL.GLfloat -- render as line which connects first and last + | RenderScale GlScaleX GlScaleY -- change scale + | RenderTranslate GlPosX GlPosY -- translate / move following instructions + | RenderRotate Double -- rotate following instructions + | RenderColorize GlColorRGB -- colorize following instructions + | RenderColorizeAlpha GlColorRGBA -- colorize following instructions with alpha setting + | RenderPreserve RenderInstruction -- render instruction while preserving rotation / translation + | RenderMany [RenderInstruction] -- render multiple other instructions diff --git a/src/HGE2D/Engine.hs b/src/HGE2D/Engine.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Engine.hs @@ -0,0 +1,185 @@ +-- | +-- Module : HGE2D.Engine +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing functions for the engine, mostly to interact with GLUT and OpenGL + +module HGE2D.Engine where + +import HGE2D.Datas +import HGE2D.Classes +import HGE2D.Time +import HGE2D.Render () + +import Control.Concurrent (newMVar, readMVar, takeMVar, putMVar, MVar) +import Graphics.UI.GLUT + +-------------------------------------------------------------------------------- + +-- | Main function to run the engine +runEngine :: EngineState a -> a -> IO () +runEngine es impl = do + secs <- getSeconds + let ms = toMilliSeconds secs + + state <- newMVar $ setTime es ms impl + + (_progName, _args) <- getArgsAndInitialize + initialDisplayMode $= [DoubleBuffered] + initialWindowSize $= Size (round $ fst $ getSize es impl) (round $ snd $ getSize es impl) + _window <- createWindow $ getTitle es impl + keyboardMouseCallback $= Just (keyboardMouse es state) + motionCallback $= Just (mouseGrab es state) + passiveMotionCallback $= Just (mouseHover es state) + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + displayCallback $= display es state + reshapeCallback $= Just (reshape es state) + idleCallback $= Just (idle es state) + mainLoop + +-------------------------------------------------------------------------------- + +-- | Function to render the current state of the engine +display :: EngineState a -> MVar (a) -> IO () +display es mvarGs = do + clear [ColorBuffer] + gs <- readMVar mvarGs + glRender $ toGlInstr es gs + swapBuffers + +-------------------------------------------------------------------------------- + +-- | Function to react to changes of the window size +reshape :: EngineState a -> MVar (a) -> Size -> IO () +reshape es mvarGs (Size width height) = do + gs <- takeMVar mvarGs + + let newState = resize es (realToFrac width, realToFrac height) gs + + putMVar mvarGs newState + + viewport $= (Position 0 0, Size width height) + postRedisplay Nothing + + +-------------------------------------------------------------------------------- + +---TODO here named grab, but engine method named drag, name both the same + +-- | Mouse grab interactions with the engine +mouseGrab :: EngineState a -> MVar (a) -> Position -> IO () +mouseGrab es mvarGs (Position x y) = do + gs <- takeMVar mvarGs ---TODO rename + + let w = fst $ getSize es gs + h = snd $ getSize es gs + correctedX = (realToFrac x) * (fst $ getSize es gs) / w + correctedY = (realToFrac y) * (snd $ getSize es gs) / h + newState = drag es correctedX correctedY gs + + putMVar mvarGs newState + return () + +-- | Mouse hover interactions with the engine +mouseHover :: EngineState a -> MVar (a) -> Position -> IO () +mouseHover es mvarGs (Position x y) = do + gs <- takeMVar mvarGs ---TODO rename + + let w = fst $ getSize es gs + h = snd $ getSize es gs + correctedX = (realToFrac x) * (fst $ getSize es gs) / w + correctedY = (realToFrac y) * (snd $ getSize es gs) / h + newState = hover es correctedX correctedY gs + + putMVar mvarGs newState + return () + + +-- | Keyboard and mouse interactions with the engine +keyboardMouse :: EngineState a -> MVar (a) -> Key -> KeyState -> Modifiers -> Position -> IO () +keyboardMouse es mvarGs (MouseButton LeftButton) Down _modifiers (Position x y) = mouseDown es mvarGs x y +keyboardMouse es mvarGs (MouseButton LeftButton) Up _modifiers (Position x y) = mouseUp es mvarGs x y +keyboardMouse es mvarGs (Char c) Down _modifiers (Position x y) = keyDown es mvarGs x y c +keyboardMouse es mvarGs (Char c) Up _modifiers (Position x y) = keyUp es mvarGs x y c +keyboardMouse _ _ _ _ _ _ = return () + +-------------------------------------------------------------------------------- + +-- | MouseDown interaction with the engine +mouseDown :: EngineState a -> MVar (a) -> GLint -> GLint -> IO () +mouseDown es mvarGs x y = do + gs <- takeMVar mvarGs ---TODO rename + + ---TODO define method for corrections since used here and in hover + let w = fst $ getSize es gs + h = snd $ getSize es gs + correctedX = (realToFrac x) * (fst $ getSize es gs) / w + correctedY = (realToFrac y) * (snd $ getSize es gs) / h + newState = click es correctedX correctedY gs + + putMVar mvarGs newState + return () + +-- | MouseUp interaction with the engine +mouseUp :: EngineState a -> MVar (a) -> GLint -> GLint -> IO () +mouseUp es mvarGs x y = do + gs <- takeMVar mvarGs ---TODO rename + + ---TODO define method for corrections since used here and in hover + let w = fst $ getSize es gs + h = snd $ getSize es gs + correctedX = (realToFrac x) * (fst $ getSize es gs) / w + correctedY = (realToFrac y) * (snd $ getSize es gs) / h + newState = mUp es correctedX correctedY gs + + putMVar mvarGs newState + return () + +-------------------------------------------------------------------------------- + +-- | KeyPress interaction with the engine +keyDown :: EngineState a -> MVar (a) -> GLint -> GLint -> Char -> IO () +keyDown es mvarGs x y c = do + gs <- takeMVar mvarGs ---TODO rename + + ---TODO define method for corrections since used here and in hover + let w = fst $ getSize es gs + h = snd $ getSize es gs + correctedX = (realToFrac x) * (fst $ getSize es gs) / w + correctedY = (realToFrac y) * (snd $ getSize es gs) / h + newState = kDown es correctedX correctedY c gs + + putMVar mvarGs newState + return () + +-- | KeyRelease interaction with the engine +keyUp :: EngineState a -> MVar (a) -> GLint -> GLint -> Char -> IO () +keyUp es mvarGs x y c = do + gs <- takeMVar mvarGs ---TODO rename + + ---TODO define method for corrections since used here and in hover + let w = fst $ getSize es gs + h = snd $ getSize es gs + correctedX = (realToFrac x) * (fst $ getSize es gs) / w + correctedY = (realToFrac y) * (snd $ getSize es gs) / h + newState = kUp es correctedX correctedY c gs + + putMVar mvarGs newState + return () + +-------------------------------------------------------------------------------- + +-- | Idle function of the engine. Used to e.g. apply changes in time to the game state +idle :: EngineState a -> MVar (a) -> IdleCallback +idle es mvarGs = do + gs <- takeMVar mvarGs + secs <- getSeconds + + let ms = toMilliSeconds secs + deltaMs = ms - (getTime es gs) + newState = moveTime es deltaMs (setTime es ms gs) ---TODO currently bot setting the time AND transforming + + putMVar mvarGs newState + postRedisplay Nothing diff --git a/src/HGE2D/Geometry.hs b/src/HGE2D/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Geometry.hs @@ -0,0 +1,168 @@ +-- | +-- Module : HGE2D.Geometry +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing geometrical functions + +module HGE2D.Geometry where + +import Data.List + +import HGE2D.Math +import HGE2D.Types +import HGE2D.Datas +import HGE2D.Classes + +---TODO rewrite most / all functions to use classes +---TODO use typedefs + +-- | Transform an angle in radians to an angle in degrees +rad2deg :: Double -> Double +rad2deg rad = rad * 180 / pi + +-- | Transform an angle in degrees to an angle in radians +deg2rad :: Double -> Double +deg2rad deg = deg * pi / 180 + +-- | Calculate angle in radians between two positions in space, from the first to the secind +radRealPos :: RealPosition -> RealPosition -> Radian +radRealPos p1 p2 = atan2 dY dX + where + dX = (fst p2) - (fst p1) + dY = (snd p2) - (snd p1) + + +-- | Calculate angle of a velocity +velAngle :: Velocity -> Radian +velAngle v = atan2 (fst v) (snd v) + +-- | Distance between two positions +distance :: (Positioned a, Positioned b) => a -> b -> Double +distance x y = sqrt $ distanceSqr x y + +-- | Squared distance between two positions +-- Faster than calculating the distance. Can be used to e.g. compare distances cheaply +distanceSqr :: (Positioned a, Positioned b) => a -> b -> Double +distanceSqr x y = (fst p1 - fst p2)**2 + (snd p1 - snd p2)**2 + where + p1 = getPos x + p2 = getPos y + +-- | Calculate the direction vector between two positions +direction :: (Positioned a, Positioned b) => a -> b -> RealPosition +direction x y = (newX, newY) + where + newX = ((fst p2) - (fst p1)) / l + newY = ((snd p2) - (snd p1)) / l + l = distance x y + p1 = getPos x + p2 = getPos y + +-- | Find the closest in [b] to a +closest :: (Positioned a, Positioned b) => a -> [b] -> b +closest a bs = minimumBy ( \ x y -> compare (distanceSqr a x) (distanceSqr a y) ) bs + +-- | Find the furthest in [b] to a +furthest :: (Positioned a, Positioned b) => a -> [b] -> b +furthest a bs = maximumBy ( \ x y -> compare (distanceSqr a x) (distanceSqr a y) ) bs + +-- | Given a position and projectile speed of a gun / turret and an object defined by its current position and velocity +-- Calculates the position where both will intercept. (useful for pre-aiming) +interceptionPos :: (RealPosition, Double) -> (RealPosition, Velocity) -> RealPosition +interceptionPos (p1, v) (p2, v2) = (newX, newY) + where + tx = (fst p2) - (fst p1) + ty = (snd p2) - (snd p1) + tvx = fst v2 + tvy = snd v2 + + a = tvx*tvx + tvy*tvy - v*v :: Double + b = 2 * (tvx * tx + tvy * ty) :: Double + c = tx*tx + ty*ty :: Double + + ts = quadraticEquation a b c + t0 = fst ts + t1 = snd ts + temp = min t0 t1 + t | temp > 0 = temp + | otherwise = max t0 t1 + + newX = (fst p2) + (fst v2) * t + newY = (snd p2) + (snd v2) * t + +-- | Builder for a rigidbody +makeRB :: RealPosition -> Velocity -> Pixel -> Pixel -> RigidBody +makeRB center vel width height = RigidBody { rigidPos = center, rigidVel = vel, rigidBB = sizedBB center width height } + +-- | Builder to get a BoundingBox from its center position and sizes +sizedBB :: RealPosition -> Pixel -> Pixel -> BoundingBox +sizedBB center width height = BoundingBox posMin posMax + where + posMin = (minX, minY) + posMax = (maxX, maxY) + minX = (fst center) - width / 2 + minY = (snd center) - height / 2 + maxX = (fst center) + width / 2 + maxY = (snd center) + height / 2 + +-- | Calculates the size of a BoundingBox +sizeBB :: BoundingBox -> (Pixel, Pixel) +sizeBB bb = (width, height) + where + width = (fst $ bbMax bb) - (fst $ bbMin bb) + height = (snd $ bbMax bb) - (snd $ bbMin bb) + +-- | Calculates the center of a BoundingBox +centerBB :: BoundingBox -> RealPosition +centerBB bb = (newX, newY) + where + newX = (fst $ bbMin bb) + (width / 2) + newY = (snd $ bbMin bb) + (height / 2) + (width, height) = sizeBB bb + +---TODO make monoid + +-- | Merges two bounding boxes, creating a new one which wraps around the inputs +mergeBB :: BoundingBox -> BoundingBox -> BoundingBox +mergeBB bb1 bb2 = BoundingBox newMin newMax + where + newMin = mergeMin (bbMin bb1) (bbMin bb2) + newMax = mergeMax (bbMax bb1) (bbMax bb2) + + mergeMin :: RealPosition -> RealPosition -> RealPosition + mergeMin pos1 pos2 = (x, y) + where + x = min (fst pos1) (fst pos2) + y = min (snd pos1) (snd pos2) + + mergeMax :: RealPosition -> RealPosition -> RealPosition + mergeMax pos1 pos2 = (x, y) + where + x = max (fst pos1) (fst pos2) + y = max (snd pos1) (snd pos2) + +{- see above +tilePosToBB :: TilePosition -> BoundingBox +tilePosToBB pos = BoundingBox minPos maxPos + where + minPos = toRealPos $ pos + maxPos = RealPosition maxX maxY + maxX = (fst minPos) + tileSize + maxY = (snd minPos) + tileSize +-} + +---TODO sizedBB and makeBB are duplicates + +-- | Builds a BoundingBox +makeBB :: RealPosition -> Pixel -> Pixel -> BoundingBox +makeBB center width height = BoundingBox newMin newMax + where + newMin = ((fst center - width / 2), (snd center - height / 2)) + newMax = ((fst center + width / 2), (snd center + height / 2)) + +-- | Given a position, time and veilocty it calculates the position where the moving object would be +applyVelocity :: RealPosition -> Velocity -> Millisecond -> RealPosition +applyVelocity oldPos vel time = + (((fst oldPos) + (fromIntegral time) * (fst vel)), + ((snd oldPos) + (fromIntegral time) * (snd vel))) diff --git a/src/HGE2D/GlFunctions.hs b/src/HGE2D/GlFunctions.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/GlFunctions.hs @@ -0,0 +1,73 @@ +-- | +-- Module : HGE2D.GlFunctions +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing functions used to interact with OpenGL + +module HGE2D.GlFunctions where + +import HGE2D.Types +import HGE2D.Datas +import HGE2D.Geometry + +import qualified Graphics.Rendering.OpenGL as GL + +-------------------------------------------------------------------------------- + +-- | Renders a RGB color +colorRGB :: GlColorRGB -> IO () +colorRGB (r, g, b) = GL.color $ col3 r g b + where + col3 :: GL.GLfloat -> GL.GLfloat -> GL.GLfloat -> GL.Color3 GL.GLfloat + col3 f1 f2 f3 = GL.Color3 f1 f2 f3 + +-- | Renders a RGBA color +colorRGBA :: GlColorRGBA -> IO () +colorRGBA (r, g, b, a) = GL.color $ col4 r g b a + where + col4 :: GL.GLfloat -> GL.GLfloat -> GL.GLfloat -> GL.GLfloat -> GL.Color4 GL.GLfloat + col4 f1 f2 f3 f4 = GL.Color4 f1 f2 f3 f4 + +-- | Adds an alpha value to a RGB color, turning it into a RGBA color +addAlpha :: GL.GLfloat -> GlColorRGB -> GlColorRGBA +addAlpha a (r, g, b) = (r, g, b, a) + +-------------------------------------------------------------------------------- + +-- | Sends a translation instruction to OpenGL +translate2 :: GlPosX -> GlPosY -> IO () +translate2 x y = GL.translate $ point3 x y 0.0 + +-- | Sends a scale instruction to OpenGL +scale2 :: GlScaleX -> GlScaleY -> IO () +scale2 x y = GL.scale x y 1.0 + +-------------------------------------------------------------------------------- + +-- | Transforms a string to a RenderInstruction +text :: String -> RenderInstruction +text str = RenderText str + +-------------------------------------------------------------------------------- + +-- | Sends a rotation instruction to OpenGL +rotate2 :: Double -> IO () +rotate2 rad = rotTmp (realToFrac $ rad2deg rad) + where + rotTmp :: GL.GLfloat -> IO () + rotTmp deg = GL.rotate deg $ GL.Vector3 0 0 1 + +-------------------------------------------------------------------------------- + +-- | Builds a GLPoint2 +point2 :: GlPosX -> GlPosY -> GlPoint2 +point2 f1 f2 = GL.Vertex2 f1 f2 + +-- | Builds a GLPoint3 +point3 :: GlPosX -> GlPosY -> GlPosZ -> GlPoint3 +point3 f1 f2 f3 = GL.Vector3 f1 f2 f3 + +-- | Builds a GLVer3 +vertex3 :: GlPosX -> GlPosY -> GlPosZ -> GlVer3 +vertex3 f1 f2 f3 = GL.Vertex3 f1 f2 f3 diff --git a/src/HGE2D/Instances.hs b/src/HGE2D/Instances.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Instances.hs @@ -0,0 +1,117 @@ +-- | +-- Module : HGE2D.Instances +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing instance definitions for the classes / types of HGE2D + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module HGE2D.Instances where + +import HGE2D.Geometry +import HGE2D.Types +import HGE2D.Datas +import HGE2D.Classes + +-------------------------------------------------------------------------------- + +-- | Instance of HasBoundingBox for BoundingBox +instance HasBoundingBox BoundingBox where + getBB = id + +-- | Instance of HasBoundingBox for RigidBody +instance HasBoundingBox RigidBody where + getBB = rigidBB + +-- | Instance of HasBoundingBox for PhysicalObject +instance HasBoundingBox PhysicalObject where + getBB = physicalBB + +-------------------------------------------------------------------------------- + +-- | Instance of Positioned for RealPosition +instance Positioned RealPosition where + getPos = id + getX = fst + getY = snd + +-- | Instance of Positioned for RigidBody +instance Positioned RigidBody where + getPos = getPos . rigidPos + getX = getX . rigidPos + getY = getY . rigidPos + +-------------------------------------------------------------------------------- + +-- | Instance of Moveable for RealPosition +instance Moveable RealPosition where + moveBy by pos = (newX, newY) + where + newX = fst pos + fst by + newY = snd pos + snd by + moveTo to _ = ((fst to), (snd to)) + +-- | Instance of Moveable for BoundingBox +instance Moveable BoundingBox where + moveBy by bb = BoundingBox { bbMin = newMinPos, bbMax = newMaxPos } + where + newMinPos = moveBy by $ bbMin bb + newMaxPos = moveBy by $ bbMax bb + + moveTo by bb = BoundingBox { bbMin = newMinPos, bbMax = newMaxPos } + where + newMinPos = moveTo by $ bbMin bb + newMaxPos = moveTo by $ bbMax bb + +-- | Instance of Moveable for RigidBody +instance Moveable RigidBody where + moveBy by rb = rb { rigidPos = newPos , rigidBB = newBB } + where + newBB = moveBy by (rigidBB rb) + newPos = moveBy by (rigidPos rb) + moveTo to rb = rb { rigidPos = newPos, rigidBB = newBB } + where + newBB = moveTo to (rigidBB rb) + newPos = moveTo to $ rigidPos rb + +-- | Instance of Moveable for PhysicalObject +instance Moveable PhysicalObject where + moveBy by po = po { physicalPos = newPos, physicalBB = newBB } + where + newBB = moveBy by (physicalBB po) + newPos = moveBy by (physicalPos po) + moveTo to po = po { physicalPos = newPos, physicalBB = newBB } + where + newBB = moveTo to (physicalBB po) + newPos = moveTo to (physicalPos po) + +-------------------------------------------------------------------------------- + +-- | Instance of Acceleratable for RigidBody +instance Acceleratable RigidBody where + accBy by rb = rb { rigidVel = newVel } + where + newVel = ((fst oldVel) + (fst by) , (snd oldVel) + (snd by)) + oldVel = rigidVel rb + accTo to rb = rb { rigidVel = to } + +-- | Instance of Acceleratable for PhysicalObject +instance Acceleratable PhysicalObject where + accBy by po = po { physicalVel = newVel } + where + newVel = ((fst oldVel) + (fst by) , (snd oldVel) + (snd by)) + oldVel = physicalVel po + accTo to po = po { physicalVel = to } + +-------------------------------------------------------------------------------- + +-- | Instance of Dynamic for RigidBody +instance Dynamic RigidBody where + moveInTime time rb = rb { rigidPos = newPos , rigidBB = newBB } + where + newBB = (rigidBB rb) { bbMin = newMinPos, bbMax = newMaxPos} + newPos = applyVelocity (rigidPos rb) (rigidVel rb) time + newMinPos = applyVelocity (bbMin $ rigidBB rb) (rigidVel rb) time + newMaxPos = applyVelocity (bbMax $ rigidBB rb) (rigidVel rb) time diff --git a/src/HGE2D/Math.hs b/src/HGE2D/Math.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Math.hs @@ -0,0 +1,17 @@ +-- | +-- Module : HGE2D.Math +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing basic math functions + +module HGE2D.Math where + +-- | Calculate the two minima of the quadratic equation +quadraticEquation :: Double -> Double -> Double -> (Double, Double) +quadraticEquation a b c = if d < 0 then (0, 0) else (x, y) + where + x = e + sqrt d / (2 * a) + y = e - sqrt d / (2 * a) + d = b * b - 4 * a * c + e = - b / (2 * a) diff --git a/src/HGE2D/Physical.hs b/src/HGE2D/Physical.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Physical.hs @@ -0,0 +1,51 @@ +-- | +-- Module : HGE2D.Physical +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing functions for PhysicalObjects + +module HGE2D.Physical where + +import HGE2D.Types +import HGE2D.Datas +import HGE2D.Classes +import HGE2D.Instances + +-------------------------------------------------------------------------------- + +---TODO not fully implemented +---TODO rename +---TODO rename class to HasPhysicalObject + +-- | Applies physics to a physical object. E.g. velocity changing position, acceleration changing velocity ... +applyPhysics :: (IsPhysicalObject a) => Millisecond -> a -> a +applyPhysics ms x = setPhys newPo x + where + newPo = (applyVel . applyAcc . applyRotVel . applyRotAcc . applyDrag . applyRotDrag) (getPhys x) ---TODO more consistent order acc > vel > abs + + applyVel po = moveBy (dX, dY) po ---TODO define more general for reuse + where + dX = (fromIntegral ms) * (fst $ physicalVel po) + dY = (fromIntegral ms) * (snd $ physicalVel po) + + applyAcc po = po { physicalVel = (vX, vY) } ---TODO see above + where + vX = (fst $ physicalVel po) + (fromIntegral ms) * (fst $ physicalAcc po) + vY = (snd $ physicalVel po) + (fromIntegral ms) * (snd $ physicalAcc po) + + applyRotVel po = po { physicalRot = fixedRot } ---TODO see above + where + fixedRot | newRot > 2.0 * pi = newRot - 2.0 * pi + | newRot < 0 = newRot + 2.0 * pi + | otherwise = newRot + newRot = (physicalRot po) + dRot + dRot = (fromIntegral ms) * (physicalRotSpeed po) + + applyRotAcc po = po { physicalRotSpeed = newRotSpeed } ---TODO see above + where + newRotSpeed = (physicalRotAcceleration po) + dRotSpeed + dRotSpeed = (fromIntegral ms) * (physicalRotAcceleration po) + + applyDrag = id ---TODO + applyRotDrag = id ---TODO diff --git a/src/HGE2D/Render.hs b/src/HGE2D/Render.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Render.hs @@ -0,0 +1,49 @@ +-- | +-- Module : HGE2D.Render +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing the instance of GlRender for a RenderInstruction + +module HGE2D.Render where + +import HGE2D.Datas +import HGE2D.Classes +import HGE2D.GlFunctions + +import Graphics.Rendering.OpenGL as GL +import Graphics.UI.GLUT + +-------------------------------------------------------------------------------- + +-- | Instance of GLRender for a RenderInstruction +-- Makes it possible to render the RenderInstruction primitives +instance GlRender RenderInstruction where + glRender renderInstruction = case renderInstruction of + RenderNothing -> return () + RenderWithCamera w h sX sY instrs -> glRender $ RenderPreserve $ RenderMany ([RenderTranslate w h, RenderScale sX sY] ++ [instrs]) + RenderText text -> do currentRasterPosition $= Vertex4 0 0 0 1 + renderString TimesRoman24 text + + RenderLineStrip shape w -> do lineWidth $= w + (renderPrimitive LineStrip $ mapM_ vertex shape) + + RenderTriangle shape -> renderPrimitive Triangles $ mapM_ vertex shape + RenderLineLoop shape w -> do lineWidth $= w + (renderPrimitive LineLoop $ mapM_ vertex shape) + RenderScale sX sY -> scale2 sX sY + RenderTranslate w h -> translate2 w h + RenderRotate rad -> rotate2 rad + RenderColorize rgb -> colorRGB rgb + RenderColorizeAlpha rgba -> colorRGBA rgba + RenderPreserve instrs -> preservingMatrix $ glRender instrs + RenderMany instrs -> mapM_ glRender instrs + +-------------------------------------------------------------------------------- + +---TODO move definition somewhere else? +---TODO several version with different origin points + +-- | Adding a default camera instruction to a given RenderInstruction +withCamera :: EngineState a -> a -> RenderInstruction -> RenderInstruction +withCamera es impl = RenderWithCamera (-1.0) (1.0) (realToFrac $ 2.0 / (fst $ getSize es impl)) (negate $ realToFrac $ 2.0 / (snd $ getSize es impl)) diff --git a/src/HGE2D/Shapes.hs b/src/HGE2D/Shapes.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Shapes.hs @@ -0,0 +1,96 @@ +-- | +-- Module : HGE2D.Shapes +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing basic shapes which can be used to define more complex ones through combination + +module HGE2D.Shapes where + +import HGE2D.Settings +import HGE2D.Types +import HGE2D.Datas +import HGE2D.GlFunctions + +import qualified Graphics.Rendering.OpenGL as GL + +-------------------------------------------------------------------------------- + +-- | A bordered rectangle define by width, height, thickness and two colors +borderedRectangle :: GlWidth -> GlHeight -> GlThickness -> GlColorRGB -> GlColorRGBA -> RenderInstruction +borderedRectangle w h t colorInner colorBorder = RenderMany + [ RenderColorize colorInner + , rectangle w h + , RenderColorizeAlpha colorBorder + , wireFrame w h t + ] + +-- | A line defined by its start and end points and a thickness +line :: GlPoint2 -> GlPoint2 -> GlThickness -> RenderInstruction +line start end w = RenderLineStrip [start, end] w + +-- | A wireframe defined by width heigh and thickness (the borders of a box) +wireFrame :: GlWidth -> GlHeight -> GlThickness -> RenderInstruction +wireFrame w h t = RenderLineLoop [ll, lr, ur, ul] t + where + ll = point2 xMin yMin + lr = point2 xMax yMin + ur = point2 xMax yMax + ul = point2 xMin yMax + + xMin = - (w/2) + xMax = (w/2) + yMin = - (h/2) + yMax = (h/2) + +-- | A rectangle defined by width and height +rectangle :: GlWidth -> GlHeight -> RenderInstruction +rectangle w h = RenderTriangle [ll, lr, ur, ur, ul, ll] + where + ll = point2 xMin yMin + lr = point2 xMax yMin + ur = point2 xMax yMax + ul = point2 xMin yMax + + xMin = - (w/2) + xMax = (w/2) + yMin = - (h/2) + yMax = (h/2) + +-- | A ring defined by its radius and thickness +ring :: GlRadius -> GlThickness -> RenderInstruction +ring r w = RenderLineLoop (buildRing 0 []) w + where + buildRing :: Int -> GlShape -> GlShape + buildRing nVertex prevShape + | nVertex >= nFacesCircle = prevShape + | otherwise = buildRing (nVertex+1) (prevShape ++ [vertex]) + where + vertex = pointOnCircle nVertex + + pointOnCircle :: Int -> GlPoint2 ---TODO defined twice, move somewhere else + pointOnCircle i = GL.Vertex2 x y + where + x = r * cos phi + y = r * sin phi + phi = 2.0 * pi * (fromIntegral i / fromIntegral nFacesCircle) + +-- | A circle defined by its radius +circle :: GlRadius -> RenderInstruction +circle r = RenderTriangle (buildCircle 0 []) + where + buildCircle :: Int -> GlShape -> GlShape + buildCircle nFace prevShape + | nFace >= nFacesCircle = prevShape + | otherwise = buildCircle (nFace+1) (prevShape ++ face) + where + face = [(GL.Vertex2 0 0), first, second] + first = pointOnCircle nFace + second = pointOnCircle (nFace+1) + + pointOnCircle :: Int -> GlPoint2 + pointOnCircle i = GL.Vertex2 x y + where + x = r * cos phi + y = r * sin phi + phi = 2.0 * pi * (fromIntegral i / fromIntegral nFacesCircle) diff --git a/src/HGE2D/Time.hs b/src/HGE2D/Time.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Time.hs @@ -0,0 +1,24 @@ +-- | +-- Module : HGE2D.Time +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing functions to get the current time or transform times + +module HGE2D.Time where + +import HGE2D.Types + +import Data.Time.Clock + +-------------------------------------------------------------------------------- + +-- | Get the current time in seconds +getSeconds :: IO Double +getSeconds = getCurrentTime >>= return . fromRational . toRational . utctDayTime + +-------------------------------------------------------------------------------- + +-- | Transform seconds to milliseconds +toMilliSeconds :: Double -> Millisecond +toMilliSeconds secs = floor $ 1000 * secs diff --git a/src/HGE2D/Types.hs b/src/HGE2D/Types.hs new file mode 100644 --- /dev/null +++ b/src/HGE2D/Types.hs @@ -0,0 +1,122 @@ +-- | +-- Module : HGE2D.Types +-- Copyright : (c) 2016 Martin Buck +-- License : see LICENSE +-- +-- Containing type definitions used within HGE2D + +module HGE2D.Types where + +import qualified Graphics.Rendering.OpenGL as GL + +-------------------------------------------------------------------------------- + +-- | Time in seconds +type Second = Int + +-- | Time in milliseconds +type Millisecond = Int + +-------------------------------------------------------------------------------- + +-- | Angle in degrees +type Degree = Double + +-- | The drag of an object +type Drag = Double + +-- | The mass of an object in kg +type Mass = Double + +-- | Distance in meters +type Meter = Double + +-- | Velocity in meters per millisecond +type MeterPmsec = Double + +-- | Acceleration in meters per millisecond squared +type MeterPmsecSqr = Double + +-- | Distance or size in pixels +type Pixel = Double + +-- | Angle in radians +type Radian = Double + +-- | Rotation acceleration in radians per millisecond squared +type RotationAcceleration = Radian + +-- | Rotation speed in radians per millisecond +type RotationSpeed = Radian + +-------------------------------------------------------------------------------- + +-- | Width of an object +type Width = Double + +-- | Height of an object +type Height = Double + +-- | Position in x-direction of an oject +type PosX = Double + +-- | Position in y-direction of an object +type PosY = Double + +-------------------------------------------------------------------------------- + +-- | Acceleration split in x and y component +type Acceleration = (MeterPmsecSqr, MeterPmsecSqr) + +-- | Position of an object split in x and y component +type RealPosition = (Meter, Meter) + +-- | Velocity of an object split in x and y component +type Velocity = (MeterPmsec, MeterPmsec) + +-------------------------------------------------------------------------------- + +-- | Point in 2D defined by GLfloat values +type GlPoint2 = GL.Vertex2 GL.GLfloat + +-- | Point in 3D defined by GLfloat values +type GlPoint3 = GL.Vector3 GL.GLfloat + +-- | Vertex in 3D defined by GLfloat values +type GlVer3 = GL.Vertex3 GL.GLfloat + +-- | Position in x-direction defined by GLfloat value +type GlPosX = GL.GLfloat + +-- | Position in y-direction defined by GLfloat value +type GlPosY = GL.GLfloat + +-- | Position in z-direction defined by GLfloat value +type GlPosZ = GL.GLfloat + +-- | Width of an object defined by GLfloat value +type GlWidth = GL.GLfloat + +-- | Height of an object defined by GLfloat value +type GlHeight = GL.GLfloat + +-- | Scale in x-direction of an object defined by GLfloat value +type GlScaleX = GL.GLfloat + +-- | Scale in y-direction of an object defined by GLfloat value +type GlScaleY = GL.GLfloat + +-- | Thickness of e.g. a line defined by GLfloat value +type GlThickness = GL.GLfloat + +-- | Radius of e.g. a circle defined by GLfloat value +type GlRadius = GL.GLfloat + +-- | RGB color defined by 3 GLfloat values +type GlColorRGB = (GL.GLfloat, GL.GLfloat, GL.GLfloat) + +-- | RGBA color defined by 4 GLfloat values +type GlColorRGBA = (GL.GLfloat, GL.GLfloat, GL.GLfloat, GL.GLfloat) + +-- | A shape defined by several points in 2D space +type GlShape = [GlPoint2] diff --git a/src/examples/Example1.hs b/src/examples/Example1.hs new file mode 100644 --- /dev/null +++ b/src/examples/Example1.hs @@ -0,0 +1,57 @@ +module Main where + +import HGE2D.Types +import HGE2D.Datas +import HGE2D.Colors +import HGE2D.Shapes +import HGE2D.Engine + +{- Very basic example showing a "Hello World" -} +-------------------------------------------------------------------------------- + +--in here we are going to store all data of the game +data GameState = GameState + { gsSize :: (Double, Double) -- current size of the entire game in pixels + , time :: Millisecond -- current time of the game + } + +--define our initial state +gs1 = GameState { time = 0, gsSize = (0, 0) } + +--define all functions of the engine for usage of our state +es1 = EngineState + { getTitle = myGetTitle + , getTime = myGetTime + , setTime = mySetTime + , moveTime = myMoveTime + , click = myClick + , mUp = myMouseUp + , hover = myHover + , drag = myDrag + , kDown = myKeyDown + , kUp = myKeyUp + , resize = myResize + , getSize = myGetSize + , toGlInstr = myToGlInstr + } :: EngineState GameState + where + myGetTitle _ = "Welcome to Example1" --title of the games window + myGetTime = time -- how to retrieve the games time + mySetTime ms gs = gs { time = ms } -- how to set the games time + myMoveTime _ = id -- our game won't react to time changes + myClick _ _ = id -- nor clicks + myMouseUp _ _ = id --nor mouse up + myHover _ _ = id -- nor hovering + myDrag _ _ = id -- nor draging + myKeyDown _ _ _ = id -- nor key presses + myKeyUp _ _ _ = id --nor key releases + myResize (w, h) gs = gs { gsSize = (realToFrac w, realToFrac h) } -- how to resize our game + myGetSize = gsSize -- and get its size + myToGlInstr _ = RenderMany -- render our game by using multiple instructions + [ RenderColorize colorWhite -- rendering a white + , rectangle 0.3 0.3 -- rectangle + , RenderColorize colorRed -- and a red + , RenderText "Hello World" -- "Hello World" + ] +-------------------------------------------------------------------------------- +main = runEngine es1 gs1 diff --git a/src/examples/Example2.hs b/src/examples/Example2.hs new file mode 100644 --- /dev/null +++ b/src/examples/Example2.hs @@ -0,0 +1,70 @@ +module Main where + +import HGE2D.Types +import HGE2D.Datas +import HGE2D.Colors +import HGE2D.Classes +import HGE2D.Instances () +import HGE2D.Shapes +import HGE2D.Render +import HGE2D.Engine + +{- Example showing mouse interactions with the game state -} +-------------------------------------------------------------------------------- + +--in here we are going to store all data of the game +data GameState = GameState + { gsSize :: (Double, Double) -- current size of the entire game in pixels + , time :: Millisecond -- current time of the game + , isClicked :: Bool -- whether the rectangle has been clicked + , pos :: RealPosition -- the position of the rectangle + } + +--define our initial state +gs2 = GameState + { time = 0 + , gsSize = (0, 0) + , pos = (0, 0) + , isClicked = False + } + +--define all functions of the engine for usage of our state +es2 = EngineState + { getTitle = myGetTitle + , getTime = myGetTime + , setTime = mySetTime + , moveTime = myMoveTime + , click = myClick + , mUp = myMouseUp + , hover = myHover + , drag = myDrag + , kDown = myKeyDown + , kUp = myKeyUp + , resize = myResize + , getSize = myGetSize + , toGlInstr = myToGlInstr + } :: EngineState GameState + where + myGetTitle _ = "Welcome to Example2" --title of the games window + myGetTime = time -- how to retrieve the games time + mySetTime ms gs = gs { time = ms } -- how to set the games time + myMoveTime _ = id -- our game won't react to time changes + myClick _ _ gs = gs { isClicked = not $ isClicked gs } -- toggle the isClicked Bool on click + myMouseUp _ _ gs = gs { isClicked = not $ isClicked gs } --also toggle it on release again + myHover x y gs = gs { pos = (x, y) } -- store the hover position + myDrag _ _ gs = gs -- don't react to draging + myKeyDown _ _ _ gs = gs { isClicked = not $ isClicked gs } -- also toggle clicked with a key press + myKeyUp _ _ _ gs = gs { isClicked = not $ isClicked gs } --also toggle clicked with key release + myResize (w, h) gs = gs { gsSize = (realToFrac w, realToFrac h) } -- how to resize our game + myGetSize = gsSize -- and get its size + myToGlInstr gs = withCamera es2 gs $ RenderPreserve $ RenderMany -- render with a camera and while preserving changes + [ RenderColorize color -- a colored + , RenderTranslate (realToFrac $ getX $ pos gs) (realToFrac $ getY $ pos gs) -- moved to pos + , rectangle 30 30 -- rectangle of 30px with and height + ] + where -- the color of the rectangle depends on the click state + color | isClicked gs = colorWhite + | otherwise = colorGreen + +-------------------------------------------------------------------------------- +main = runEngine es2 gs2 diff --git a/src/examples/Example3.hs b/src/examples/Example3.hs new file mode 100644 --- /dev/null +++ b/src/examples/Example3.hs @@ -0,0 +1,81 @@ +module Main where + +import HGE2D.Types +import HGE2D.Datas +import HGE2D.Colors +import HGE2D.Classes +import HGE2D.Instances () +import HGE2D.Shapes +import HGE2D.Render +import HGE2D.Engine + +{- Example showing dynamic changes by moving the rectanlge -} +-------------------------------------------------------------------------------- + +--in here we are going to store all data of the game +data GameState = GameState + { gsSize :: (Double, Double) -- current size of the entire game in pixels + , time :: Millisecond -- current time of the game + , isClicked :: Bool -- whether the rectangle has been clicked + , moveUp :: Bool -- whether the rectangle is moving up + , pos :: RealPosition -- the position of the rectangle + } + +--define our initial state +gs3 = GameState + { time = 0 + , gsSize = (0, 0) + , pos = (0, 0) + , isClicked = False + , moveUp = False + } + +--define all functions of the engine for usage of our state +es3 = EngineState + { getTitle = myGetTitle + , getTime = myGetTime + , setTime = mySetTime + , moveTime = myMoveTime + , click = myClick + , mUp = myMouseUp + , hover = myHover + , drag = myDrag + , kDown = myKeyDown + , kUp = myKeyUp + , resize = myResize + , getSize = myGetSize + , toGlInstr = myToGlInstr + } :: EngineState GameState + where + myGetTitle _ = "Welcome to Example3" --title of the games window + myGetTime = time -- how to retrieve the games time + mySetTime ms gs = gs { time = ms } -- how to set the games time + myMoveTime ms gs = gs { pos = newPos, moveUp = newMoveUp } -- react to changes in time by moving the position + where + newMoveUp | snd oldPos < 1 && moveUp gs = False + | snd oldPos > (snd $ gsSize gs) && (not (moveUp gs)) = True + | otherwise = moveUp gs + + newPos | moveUp gs = ((fst oldPos), (snd oldPos - realToFrac ms / 30)) + | otherwise = ((fst oldPos), (snd oldPos + realToFrac ms / 10)) + + oldPos = pos gs + myClick _ _ gs = gs { isClicked = not $ isClicked gs } -- toggle the isClicked Bool on click + myMouseUp _ _ = id --nor mouse up + myHover x y gs = gs { pos = (x, y) } -- store the hover position + myDrag _ _ gs = gs -- don't react to draging + myKeyDown _ _ _ = id -- nor key presses + myKeyUp _ _ _ = id --nor key releases + myResize (w, h) gs = gs { gsSize = (realToFrac w, realToFrac h) } -- how to resize our game + myGetSize = gsSize -- and get its size + myToGlInstr gs = withCamera es3 gs $ RenderPreserve $ RenderMany -- render with a camera and while preserving changes + [ RenderColorize color -- a colored + , RenderTranslate (realToFrac $ getX $ pos gs) (realToFrac $ getY $ pos gs) -- moved to pos + , rectangle 30 30 -- rectangle of 30px with and height + ] + where -- the color of the rectangle depends on the click state + color | isClicked gs = colorWhite + | otherwise = colorGreen + +-------------------------------------------------------------------------------- +main = runEngine es3 gs3 diff --git a/src/examples/Example4.hs b/src/examples/Example4.hs new file mode 100644 --- /dev/null +++ b/src/examples/Example4.hs @@ -0,0 +1,80 @@ +module Main where + +import HGE2D.Types +import HGE2D.Datas +import HGE2D.Colors +import HGE2D.Shapes +import HGE2D.Engine +import HGE2D.Render + +{- Example showing more advanced rendering -} +-------------------------------------------------------------------------------- + +--in here we are going to store all data of the game +data GameState = GameState + { gsSize :: (Double, Double) -- current size of the entire game in pixels + , time :: Millisecond -- current time of the game + } + +--in here we are going to store all data of the game +gs4 = GameState { time = 0, gsSize = (0, 0) } + +--define our initial state +es4 = EngineState + { getTitle = myGetTitle + , getTime = myGetTime + , setTime = mySetTime + , moveTime = myMoveTime + , click = myClick + , mUp = myMouseUp + , hover = myHover + , drag = myDrag + , kDown = myKeyDown + , kUp = myKeyUp + , resize = myResize + , getSize = myGetSize + , toGlInstr = myToGlInstr + } :: EngineState GameState + where + myGetTitle _ = "Welcome to Example4" --title of the games window + myGetTime = time -- how to retrieve the games time + mySetTime ms gs = gs { time = ms } -- how to set the games time + myMoveTime _ = id -- our game won't react to time changes + myClick _ _ = id -- nor clicks + myMouseUp _ _ = id --nor mouse up + myHover _ _ = id -- nor hovering + myDrag _ _ = id -- nor draging + myKeyDown _ _ _ = id -- nor key presses + myKeyUp _ _ _ = id --nor key releases + myResize (w, h) gs = gs { gsSize = (realToFrac w, realToFrac h) } -- how to resize our game + myGetSize = gsSize -- and get its size + myToGlInstr gs = withCamera es4 gs $ RenderMany -- render with a camera and while preserving changes + [ circleNextToRectangle -- render our circle next to the rectangle + , whiteRectangle -- as well as the white rectangle + , allMoved -- and the moved group + ] + where + + -- move them all by 100px in x and y direction + allMoved :: RenderInstruction + allMoved = RenderPreserve $ RenderMany [RenderTranslate 100 100, circleNextToRectangle] + + -- group the moved circle and the white rectangle + circleNextToRectangle :: RenderInstruction + circleNextToRectangle = RenderMany [movedCircle, whiteRectangle] + + -- the circle moved + movedCircle :: RenderInstruction + movedCircle = RenderPreserve $ RenderMany [RenderTranslate 50 0, redCircle] + + -- a white rectangle + whiteRectangle :: RenderInstruction + whiteRectangle = RenderMany [RenderColorize colorWhite, rectangle 30 30] + + -- a red circle + redCircle :: RenderInstruction + redCircle = RenderMany [RenderColorize colorRed, circle 30] + +-------------------------------------------------------------------------------- + +main = runEngine es4 gs4