diff --git a/Data/BoundingBox/Dim2.hs b/Data/BoundingBox/Dim2.hs --- a/Data/BoundingBox/Dim2.hs +++ b/Data/BoundingBox/Dim2.hs @@ -12,9 +12,14 @@ ---------------------------------------------------------------------------- module Data.BoundingBox.Dim2 ( BoundingBox(..) + , inBoundingBox + , intersect + , enclose , _TLBR , _BLTR + , _Corners , Reference(..) + , sizePos , position , size ) where @@ -23,9 +28,33 @@ import Control.Lens import Data.Foldable import Data.Typeable +import Control.Applicative -data BoundingBox a = BoundingBox a a a a deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Read, Typeable) +data BoundingBox a = BoundingBox !a !a !a !a deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Read, Typeable) +instance Applicative BoundingBox where + pure a = BoundingBox a a a a + BoundingBox f0 g0 f1 g1 <*> BoundingBox x0 y0 x1 y1 = BoundingBox (f0 x0) (g0 y0) (f1 x1) (g1 y1) + +-- | Determine whether the given point is in the 'BoundingBox'. +inBoundingBox :: Ord a => V2 a -> BoundingBox a -> Bool +inBoundingBox (V2 x y) (BoundingBox x0 y0 x1 y1) = x0 <= x && x <= x1 && y0 <= y && y <= y1 + +-- | Intersection between two boundingboxes. +intersect :: Ord a => BoundingBox a -> BoundingBox a -> Maybe (BoundingBox a) +intersect (BoundingBox x0 y0 x1 y1) (BoundingBox x2 y2 x3 y3) + | x4 > x5 = Nothing + | y4 > y5 = Nothing + | otherwise = Just $ BoundingBox x4 y4 x5 y5 + where + x4 = max x0 x2 + y4 = max y0 y2 + x5 = min x1 x3 + y5 = min y1 y3 + +enclose :: (Num a, Ord a) => V2 a -> BoundingBox a -> BoundingBox a +enclose (V2 x y) (BoundingBox x0 y0 x1 y1) = BoundingBox (min x x0) (min y y0) (max x x1) (max y y1) + -- | The type of reference points. -- @ -- TL--T--TR @@ -37,7 +66,7 @@ data Reference = TL | T | TR | L | C | R | BL | B | BR - deriving (Show, Eq, Ord, Read) + deriving (Show, Eq, Ord, Read, Enum, Bounded) -- | -- @ @@ -57,45 +86,29 @@ _BLTR :: Iso' (BoundingBox a) (V2 a, V2 a) _BLTR = iso (\(BoundingBox x0 y0 x1 y1) -> (V2 x0 y1, V2 x1 y0)) (\(V2 x0 y1, V2 x1 y0) -> BoundingBox x0 y0 x1 y1) -position :: Fractional a => Reference -> Lens' (BoundingBox a) (V2 a) -position ref f (BoundingBox x0 y0 x1 y1) = f (V2 x0 y0 + offset) - <&> \v -> let V2 x y = v - offset in BoundingBox x y (x + w) (y + h) where - w = x1 - x0 - h = y1 - y0 - offset = case ref of +sizePos :: Fractional a => Reference -> Iso' (BoundingBox a) (V2 a, V2 a) +sizePos ref = iso f g where + f (BoundingBox x0 y0 x1 y1) = (V2 (x1 - x0) (y1 - y0), V2 x0 y0 * (1 - k) + V2 x1 y1 * k) + g (s@(V2 w h), p) = BoundingBox x0 y0 x1 y1 where + V2 x0 y0 = p - k * s + V2 x1 y1 = p + (1 - k) * s + k = case ref of TL -> V2 0 0 - T -> V2 (w / 2) 0 - TR -> V2 w 0 - L -> V2 0 (h / 2) - C -> V2 (w / 2) (h / 2) - R -> V2 w (h / 2) - BL -> V2 0 h - B -> V2 (w / 2) h - BR -> V2 w h + T -> V2 0.5 0 + TR -> V2 1 0 + L -> V2 0 0.5 + C -> V2 0.5 0.5 + R -> V2 1 0.5 + BL -> V2 0 1 + B -> V2 0.5 1 + BR -> V2 1 1 +_Corners :: Traversal' (BoundingBox a) (V2 a) +_Corners f (BoundingBox x0 y0 x1 y1) = go <$> f (V2 x0 y0) <*> f (V2 x1 y0) <*> f (V2 x1 y1) <*> f (V2 x0 y1) where + go (V2 x0' _) (V2 _ y1') (V2 x2' _) (V2 _ y3') = BoundingBox x0' y1' x2' y3' + +position :: Fractional a => Reference -> Lens' (BoundingBox a) (V2 a) +position ref = sizePos ref . _2 + size :: Fractional a => Reference -> Lens' (BoundingBox a) (V2 a) -size ref f (BoundingBox x0 y0 x1 y1) = f (V2 w h) - <&> \(V2 w' h') -> BoundingBox (x0 - p * (w' - w)) (y0 - q * (h' - h)) (x1 + (1 - p) * (w' - w)) (y1 + (1 - q) * (h' - h)) - where - w = x1 - x0 - h = y1 - y0 - p = case ref of - TL -> 0 - T -> 0.5 - TR -> 1 - L -> 0 - C -> 0.5 - R -> 1 - BL -> 0 - B -> 0.5 - BR -> 1 - q = case ref of - TL -> 0 - L -> 0.5 - BL -> 1 - T -> 0 - C -> 0.5 - B -> 1 - TR -> 0 - R -> 0.5 - BR -> 1 +size ref = sizePos ref . _1 diff --git a/boundingboxes.cabal b/boundingboxes.cabal --- a/boundingboxes.cabal +++ b/boundingboxes.cabal @@ -1,5 +1,5 @@ name: boundingboxes -version: 0.1 +version: 0.1.1 synopsis: The type for 2D bounding box -- description: homepage: https://github.com/fumieval/boundingboxes @@ -19,4 +19,19 @@ other-extensions: DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveDataTypeable, Rank2Types build-depends: base == 4.*, linear >= 1.0, lens >= 3.8 && < 5 -- hs-source-dirs: - default-language: Haskell2010 + default-language: Haskell2010 + +test-suite properties + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base + , linear + , lens + , QuickCheck >=2.4 + , test-framework-th >= 0.2 + , test-framework + , test-framework-quickcheck2 >= 0.2 + , random + , boundingboxes + main-is: properties.hs + hs-source-dirs: tests diff --git a/tests/properties.hs b/tests/properties.hs new file mode 100644 --- /dev/null +++ b/tests/properties.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell, ViewPatterns #-} +import Data.BoundingBox.Dim2 +import Test.QuickCheck +import Test.Framework.Providers.QuickCheck2 +import Test.Framework.TH +import Control.Lens +import Linear +import Control.Applicative +import System.Random + +instance (Num a, Random a) => Arbitrary (BoundingBox a) where + arbitrary = sized $ \n -> let k = fromIntegral n in do + x0 <- choose (-k, 0) + y0 <- choose (-k, 0) + x1 <- choose (0, k) + y1 <- choose (0, k) + return (BoundingBox x0 y0 x1 y1) + +instance Arbitrary Reference where + arbitrary = toEnum <$> choose (0, 8) + +instance Arbitrary a => Arbitrary (V2 a) where + arbitrary = V2 <$> arbitrary <*> arbitrary + +prop_resize bb ref sz = nearZero $ bb ^. position ref - bb' ^. position ref where + bb' = bb & size ref .~ getPositive sz :: BoundingBox Float + +prop_rearrange ref bb pos = nearZero $ bb ^. size C - bb' ^. size C where + bb' = bb & position ref .~ pos :: BoundingBox Float + +prop_construct ref pos (getPositive -> sz) = nearZero (bb ^. size C - sz) + .&&. nearZero (bb ^. position ref - pos) where + + bb = sizePos ref # (sz, pos) :: BoundingBox Float + +prop_enclosure xs = and [inBoundingBox p (foldr enclose (pure 0) ps) | p <- ps] where + ps = map (uncurry V2) xs :: [V2 Float] + +main = $(defaultMainGenerator)