diff --git a/HGE2D.cabal b/HGE2D.cabal --- a/HGE2D.cabal +++ b/HGE2D.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: HGE2D -version: 0.1.9.0 +version: 0.1.9.2 synopsis: 2D game engine written in Haskell description: See README and examples/ for further information license: MIT @@ -50,6 +50,15 @@ hs-source-dirs: src default-language: Haskell2010 ghc-options: -O2 -W -fwarn-incomplete-patterns + +test-suite test1 + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: Test.hs + build-depends: base >= 4.8.2.0 && < 5.0, HGE2D, hspec, QuickCheck + hs-source-dirs: src/tests + ghc-options: -W -fwarn-incomplete-patterns + executable example1 default-language: Haskell2010 diff --git a/src/HGE2D/Collision.hs b/src/HGE2D/Collision.hs --- a/src/HGE2D/Collision.hs +++ b/src/HGE2D/Collision.hs @@ -17,8 +17,11 @@ -- | Tests whether two objects collide (overlap in any way) doCollide :: (HasBoundingBox a, HasBoundingBox b) => a -> b -> Bool -doCollide hasBB1 hasBB2 = abs (xcenterthis - xcenterother) < 0.5 * (xsizethis + xsizeother) && - abs (ycenterthis - ycenterother) < 0.5 * (ysizethis + ysizeother) +doCollide hasBB1 hasBB2 | bb1 == BBEmpty = False + | bb2 == BBEmpty = False + | bb1 == bb2 = True + | otherwise = abs (xcenterthis - xcenterother) < 0.5 * (xsizethis + xsizeother) && + abs (ycenterthis - ycenterother) < 0.5 * (ysizethis + ysizeother) where (bb1, bb2) = (getBB hasBB1, getBB hasBB2) (xsizethis, ysizethis) = (fst $ sizeBB bb1, snd $ sizeBB bb1) @@ -37,10 +40,13 @@ -- | 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) +isInside hasBBIn hasBBOut | bbIn == BBEmpty = False + | bbOut == BBEmpty = False + | bbIn == bbOut = True + | otherwise = (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) @@ -50,10 +56,11 @@ -- | Tests whether a position is within the bounding box isInsideRP :: (Positioned a, HasBoundingBox b) => a -> b -> Bool -isInsideRP pos hasBB = (posX > bbLeft) - && (posX < bbRight) - && (posY > bbTop) - && (posY < bbBottom) +isInsideRP pos hasBB | bb == BBEmpty = False + | otherwise = (posX > bbLeft) + && (posX < bbRight) + && (posY > bbTop) + && (posY < bbBottom) where posX = fst $ getPos pos posY = snd $ getPos pos diff --git a/src/HGE2D/Geometry.hs b/src/HGE2D/Geometry.hs --- a/src/HGE2D/Geometry.hs +++ b/src/HGE2D/Geometry.hs @@ -84,7 +84,7 @@ -- | Find the furthest in [b] to a furthest :: (Positioned a, Positioned b) => a -> [b] -> Maybe b -furthest a bs = minimumByMay ( \ x y -> compare (distanceSqr a x) (distanceSqr a y) ) bs +furthest a bs = maximumByMay ( \ 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) diff --git a/src/tests/Test.hs b/src/tests/Test.hs new file mode 100644 --- /dev/null +++ b/src/tests/Test.hs @@ -0,0 +1,142 @@ +---TODO copy +---TODO module + +import HGE2D.Types +import HGE2D.Datas +import HGE2D.Classes +import HGE2D.Instances +import HGE2D.Geometry +import HGE2D.Time +import HGE2D.Collision + +import Test.Hspec +import Test.QuickCheck +import Control.Exception (evaluate) + +main :: IO () +main = hspec $ do + describe "Time.hs" $ do + it "toMilliSeconds" $ do + toMilliSeconds 0.73 `shouldBe` (730 :: Int) + toMilliSeconds 0.0 `shouldBe` (0 :: Int) + toMilliSeconds (-10.0) `shouldBe` (-10000 :: Int) + + describe "Geometry.hs" $ do + it "rad2deg" $ + property $ \ x -> x * 180.0 / pi == rad2deg ( x :: Double) + it "deg2rad" $ + property $ \x -> x * pi / 180.0 == deg2rad ( x :: Double) + + it "radRealPos" $ do + radRealPos (0.0, 0.0) (1.0, 0.0) `shouldBe` (0.0 * pi) + radRealPos (0.0, 0.0) (0.0, 1.0) `shouldBe` (0.5 * pi) + radRealPos (0.0, 0.0) (-1.0, 0.0) `shouldBe` (1.0 * pi) + radRealPos (0.0, 0.0) (0.0, -1.0) `shouldBe` (-0.5 * pi) + + --it "velAngle" $ ---TODO not working + -- property $ \ x1 y1 x2 y2 -> abs ((radRealPos (x1, y1) (x2, y2)) - (velAngle (x2 - x1, y2 - y1))) < 0.0001 + + it "sqrDistance" $ + property $ \ x1 y1 x2 y2 -> distanceSqr (x1,y1) (x2,y2) == (x2 - x1)**2 + (y2 - y1)**2 + + it "distance" $ + property $ \ x1 y1 x2 y2 -> (distance (x1,y1) (x2, y2)) == (sqrt $ distanceSqr (x1 :: Double, y1 :: Double) (x2 :: Double, y2 :: Double)) + + it "distanceBB" $ --- TODO must also test distance function itself + property $ \ x y -> distanceBB (x,y) (BoundingBox (0, 0) (10, 10)) == (sqrt $ distanceBBSqr (x :: Double, y :: Double) (BoundingBox (0, 0) (10, 10))) + + it "direction" $ do + direction ((0.0, 0.0) :: RealPosition) ((1.0, 0.0) :: RealPosition) `shouldBe` ((1.0, 0.0) :: RealPosition) + direction ((0.0, 0.0) :: RealPosition) ((2.0, 0.0) :: RealPosition) `shouldBe` ((1.0, 0.0) :: RealPosition) + direction ((0.0, 0.0) :: RealPosition) ((0.0, 2.0) :: RealPosition) `shouldBe` ((0.0, 1.0) :: RealPosition) + + it "closest" $ do + closest ((0.0, 0.0) :: RealPosition) ([] :: [RealPosition]) `shouldBe` Nothing + closest ((0.0, 0.0) :: RealPosition) ([(5.0, 5.0)] :: [RealPosition]) `shouldBe` Just (5.0, 5.0) + closest ((0.0, 0.0) :: RealPosition) ([(1.0, 1.0), (5.0, 5.0)] :: [RealPosition]) `shouldBe` Just (1.0, 1.0) + + it "furthest" $ do + furthest ((0.0, 0.0) :: RealPosition) ([] :: [RealPosition]) `shouldBe` Nothing + furthest ((0.0, 0.0) :: RealPosition) ([(5.0, 5.0)] :: [RealPosition]) `shouldBe` Just (5.0, 5.0) + furthest ((0.0, 0.0) :: RealPosition) ([(1.0, 1.0), (5.0, 5.0)] :: [RealPosition]) `shouldBe` Just (5.0, 5.0) + + --- TODO interceptionPos + + it "makeRB" $ + property $ \ center vel width height -> makeRB center vel width height == RigidBody { rigidPos = center, rigidVel = vel, rigidBB = sizedBB center width height } + + it "sizedBB" $ + sizedBB (0.0, 0.0) 10 20 `shouldBe` BoundingBox (-5.0, -10.0) (5.0, 10.0) + + it "sizeBBW" $ + property $ \ center width height -> (abs $ (fst $ sizeBB $ sizedBB center width height) - width) < 0.001 + + it "sizeBBH" $ + property $ \ center width height -> (abs $ (snd $ sizeBB $ sizedBB center width height) - height) < 0.001 + + it "centerBB" $ + property $ \ center width height -> distance center (centerBB (sizedBB center width height)) < 0.001 + + it "bbFromList" $ do + bbFromList ([] :: [RealPosition]) `shouldBe` BBEmpty + bbFromList ([(0.0, 0.0)] :: [RealPosition]) `shouldBe` BBEmpty + bbFromList ([(0.0, 0.0), (1.0, 1.0)] :: [RealPosition]) `shouldBe` BoundingBox (0.0, 0.0) (1.0, 1.0) + bbFromList ([(0.0, 0.0), (1.0, 1.0), (1.5, 0.8)] :: [RealPosition]) `shouldBe` BoundingBox (0.0, 0.0) (1.5, 1.0) + + it "mergeBBEmpty" $ + property $ \ minPos maxPos -> mergeBB (BoundingBox minPos maxPos) BBEmpty == (BoundingBox minPos maxPos) + + it "mergeBB" $ do + mergeBB (BoundingBox (0.0, 5.0) (1.0, 6.0)) (BoundingBox (-5.0, 2.0) (2.0, 12.0)) `shouldBe` (BoundingBox (-5.0, 2.0) (2.0, 12.0)) + + it "makeBB" $ ---TODO same as sizedBB (drop one of the functions) + property $ \ center width height -> makeBB center width height == sizedBB center width height + + it "applyVelocity" $ + property $ \ pos vel time -> applyVelocity pos vel time == (((fst pos) + (fromIntegral time * (fst vel))), ((snd pos) + (fromIntegral time * (snd vel)))) + + describe "Collision.hs" $ do + it "doCollideNull1" $ + property $ \ pMin pMax -> doCollide (BBEmpty) (BoundingBox pMin pMax) == False + it "doCollideNull2" $ + property $ \ pMin pMax -> doCollide (BoundingBox pMin pMax) (BBEmpty) == False + it "doCollideSelf" $ + property $ \pMin pMax -> doCollide (BoundingBox pMin pMax) (BoundingBox pMin pMax) == True + it "doCollide" $ do + doCollide (BoundingBox (0.0, 0.0) (1.0, 1.0)) (BoundingBox (1.1, 1.1) (2.0, 2.0)) `shouldBe` False + doCollide (BoundingBox (0.0, 0.0) (1.0, 1.0)) (BoundingBox (0.99, 0.99) (2.0, 2.0)) `shouldBe` True + it "isInsideNull1" $ + property $ \ pMin pMax -> isInside (BBEmpty) (BoundingBox pMin pMax) == False + it "isInsideNull2" $ + property $ \ pMin pMax -> isInside (BoundingBox pMin pMax) (BBEmpty) == False + it "isInside" $ do + isInside (BoundingBox (0.0, 0.0) (1.0, 1.0)) (BoundingBox (1.1, 1.1) (2.0, 2.0)) `shouldBe` False + isInside (BoundingBox (0.0, 0.0) (1.0, 1.0)) (BoundingBox (0.99, 0.99) (2.0, 2.0)) `shouldBe` False + isInside (BoundingBox (0.5, 0.5) (1.0, 1.0)) (BoundingBox (0.0, 0.0) (2.0, 2.0)) `shouldBe` True + it "isInsideRPNull1" $ + property $ \ p -> isInsideRP (p :: RealPosition) BBEmpty == False + it "isInsideRP" $ do + isInsideRP ((0.0, 0.0) :: RealPosition) (BoundingBox (0.5, 0.5) (1.0, 1.0)) `shouldBe` False + isInsideRP ((0.7, 0.0) :: RealPosition) (BoundingBox (0.5, 0.5) (1.0, 1.0)) `shouldBe` False + isInsideRP ((0.7, 0.7) :: RealPosition) (BoundingBox (0.5, 0.5) (1.0, 1.0)) `shouldBe` True + it "doContainNull1" $ + property $ \ pMin pMax -> doContain (BBEmpty) (BoundingBox pMin pMax) == False + it "doContainNull2" $ + property $ \ pMin pMax -> doContain (BoundingBox pMin pMax) (BBEmpty) == False + it "doContain" $ do + doContain (BoundingBox (0.0, 0.0) (1.0, 1.0)) (BoundingBox (1.1, 1.1) (2.0, 2.0)) `shouldBe` False + doContain (BoundingBox (0.0, 0.0) (1.0, 1.0)) (BoundingBox (0.99, 0.99) (2.0, 2.0)) `shouldBe` False + doContain (BoundingBox (0.5, 0.5) (1.0, 1.0)) (BoundingBox (0.0, 0.0) (2.0, 2.0)) `shouldBe` True + doContain (BoundingBox (0.0, 0.0) (2.0, 2.0)) (BoundingBox (0.5, 0.5) (1.0, 1.0)) `shouldBe` True + + describe "RealPosition" $ do + it "Positioned getX" $ + property $ \ x y -> fst (x,y) == getX ( (x,y) :: RealPosition ) + it "Positioned getY" $ + property $ \ x y -> snd (x,y) == getY ( (x,y) :: RealPosition ) + it "Positioned getPos" $ + property $ \ x y -> (x,y) == getPos ( (x,y) :: RealPosition ) + + ---TODO AABBTree + ---TODO QuadTree + ---TODO instances