{-# LANGUAGE TypeFamilies, StandaloneDeriving, RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Hoodle.BBox -- Copyright : (c) 2011, 2012 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim -- Stability : experimental -- Portability : GHC -- ----------------------------------------------------------------------------- module Data.Hoodle.BBox ( BBox (..) , BBoxable (..) , StrokeBBox (..) -- , strkbbx_strk -- , strkbbx_bbx , mkStrokeBBox , ImageBBox (..) -- , imgbbx_img -- , imgbbx_bbx , mkImageBBox , mkbbox , mkbboxF , bboxFromStroke , bboxFromImage , dimToBBox , bboxToDim , xformBBox , inflate , moveBBoxToOrigin , moveBBoxByOffset , moveBBoxULCornerTo , intersectBBox , unionBBox , ULMaybe (..) , IntersectBBox (..) , UnionBBox (..) , Maybeable (..) , bbox4All ) where import Control.Applicative import Control.Monad import qualified Data.Foldable as F import Data.Monoid import Data.Serialize import Data.Strict.Tuple -- from this package import Data.Hoodle.Simple import Data.Hoodle.Util -- import Prelude hiding (fst,snd) import qualified Prelude as Prelude (fst,snd) -- | bounding box type data BBox = BBox { bbox_upperleft :: (Double,Double) , bbox_lowerright :: (Double,Double) } deriving (Show,Eq,Ord) -- | instance Serialize BBox where put BBox{..} = put bbox_upperleft >> put bbox_lowerright get = liftM2 BBox get get class BBoxable a where getBBox :: a -> BBox -- | data StrokeBBox = StrokeBBox { strkbbx_strk :: Stroke , strkbbx_bbx :: BBox } deriving (Show,Eq,Ord) instance BBoxable StrokeBBox where getBBox = strkbbx_bbx -- | instance Serialize StrokeBBox where put StrokeBBox{..} = put strkbbx_strk >> put strkbbx_bbx get = liftM2 StrokeBBox get get -- | smart constructor for StrokeBBox mkStrokeBBox :: Stroke -> StrokeBBox mkStrokeBBox strk = StrokeBBox { strkbbx_strk = strk , strkbbx_bbx = bboxFromStroke strk } -- | data ImageBBox = ImageBBox { imgbbx_img :: Image , imgbbx_bbx :: BBox } deriving (Show,Eq,Ord) instance BBoxable ImageBBox where getBBox = imgbbx_bbx -- | instance Serialize ImageBBox where put ImageBBox{..} = put imgbbx_img >> put imgbbx_bbx get = ImageBBox <$> get <*> get -- | smart constructor for ImageBBox mkImageBBox :: Image -> ImageBBox mkImageBBox img = ImageBBox { imgbbx_img = img , imgbbx_bbx = bboxFromImage img } -- | mkbbox :: [Pair Double Double] -> BBox mkbbox lst = let xs = map fst lst ys = map snd lst in BBox { bbox_upperleft = (minimum xs, minimum ys) , bbox_lowerright = (maximum xs, maximum ys) } -- | mkbboxF :: (F.Foldable m, Functor m) => m (Double,Double) -> BBox mkbboxF lst = let xs = fmap Prelude.fst lst ys = fmap Prelude.snd lst in BBox{bbox_upperleft=(F.minimum xs, F.minimum ys) ,bbox_lowerright=(F.maximum xs, F.maximum ys)} -- | bboxFromStroke :: Stroke -> BBox bboxFromStroke (Stroke _ _ w dat) = inflate (mkbbox dat) w bboxFromStroke (VWStroke _ _ dat) = let dat' = map ((,) <$> fst3 <*> snd3) dat widthmax = F.maximum (map trd3 dat) in inflate (mkbboxF dat') widthmax -- | dimToBBox :: Dimension -> BBox dimToBBox (Dim w h) = BBox (0,0) (w,h) -- | -- | bboxToDim :: BBox -> Dimension bboxToDim (BBox (x1,y1) (x2,y2)) = Dim (x2-x1) (y2-y1) -- | bboxFromImage :: Image -> BBox bboxFromImage (Image _ (x,y) d) = moveBBoxULCornerTo (x,y) (dimToBBox d) -- | general transform BBox xformBBox :: ((Double,Double) -> (Double,Double)) -> BBox -> BBox xformBBox f (BBox c1 c2) = BBox (f c1) (f c2) -- | inflate bbox by amount r inflate :: BBox -> Double -> BBox inflate (BBox (x1,y1) (x2,y2)) r = BBox (x1-r,y1-r) (x2+r,y2+r) -- | moveBBoxToOrigin :: BBox -> BBox moveBBoxToOrigin (BBox (x0,y0) (x1,y1)) = BBox (0,0) (x1-x0,y1-y0) -- | moveBBoxByOffset :: (Double,Double) -> BBox -> BBox moveBBoxByOffset (xoff,yoff) (BBox (x0,y0) (x1,y1)) = BBox (x0+xoff,y0+yoff) (x1+xoff,y1+yoff) -- | moveBBoxULCornerTo :: (Double,Double) -> BBox -> BBox moveBBoxULCornerTo (x,y) b@(BBox (x0,y0) _) = moveBBoxByOffset (x-x0,y-y0) b -- | intersectBBox :: BBox -> BBox -> Maybe BBox intersectBBox (BBox (x1,y1) (x2,y2)) (BBox (x3,y3) (x4,y4)) = do guard $ (x1 <= x3 && x3 <= x2) || (x3 <= x1 && x1 <= x4 ) guard $ (y1 <= y3 && y3 <= y2) || (y3 <= y1 && y1 <= y4 ) let x5 = if x1 <= x3 then x3 else x1 y5 = if y1 <= y3 then y3 else y1 x6 = min x2 x4 y6 = min y2 y4 return (BBox (x5,y5) (x6,y6)) -- | unionBBox :: BBox -> BBox -> BBox unionBBox (BBox (x1,y1) (x2,y2)) (BBox (x3,y3) (x4,y4)) = let x5 = if x1 < x3 then x1 else x3 y5 = if y1 < y3 then y1 else y3 x6 = if x2 < x4 then x4 else x2 y6 = if y2 < y4 then y4 else y2 in BBox (x5,y5) (x6,y6) -- | data ULMaybe a = Bottom | Middle a | Top deriving instance Show a => Show (ULMaybe a) deriving instance Eq a => Eq (ULMaybe a) -- | newtype IntersectBBox = Intersect { unIntersect :: ULMaybe BBox } deriving (Show,Eq) -- | newtype UnionBBox = Union { unUnion :: ULMaybe BBox } deriving (Show,Eq) instance Monoid (IntersectBBox) where (Intersect Bottom) `mappend` _ = Intersect Bottom _ `mappend` (Intersect Bottom) = Intersect Bottom (Intersect Top) `mappend` x = x x `mappend` (Intersect Top) = x (Intersect (Middle x)) `mappend` (Intersect (Middle y)) = maybe (Intersect Bottom) (Intersect . Middle) (x `intersectBBox` y) mempty = Intersect Top instance Monoid (UnionBBox) where (Union Bottom) `mappend` x = x x `mappend` (Union Bottom) = x (Union Top) `mappend` _ = Union Top _ `mappend` (Union Top) = Union Top (Union (Middle x)) `mappend` (Union (Middle y)) = Union (Middle (x `unionBBox` y)) mempty = Union Bottom -- | class Maybeable a where type ElemType a :: * toMaybe :: a -> Maybe (ElemType a) fromMaybe :: Maybe (ElemType a) -> a instance Maybeable IntersectBBox where type ElemType IntersectBBox = BBox toMaybe (Intersect Bottom) = Nothing toMaybe (Intersect Top) = Nothing toMaybe (Intersect (Middle x)) = Just x fromMaybe Nothing = Intersect Top fromMaybe (Just x) = Intersect (Middle x) instance Maybeable UnionBBox where type ElemType UnionBBox = BBox toMaybe (Union Bottom) = Nothing toMaybe (Union Top) = Nothing toMaybe (Union (Middle x)) = Just x fromMaybe Nothing = Union Top fromMaybe (Just x) = Union (Middle x) -- | bbox4All :: (F.Foldable t, Functor t, BBoxable a) => t a -> ULMaybe BBox bbox4All = unUnion . F.fold . fmap (Union . Middle . getBBox)