Geometry.hs

module Data.Sifflet.Geometry
    (Position(..), 
     positionDelta, positionDistance,
     positionDistanceSquared, positionCloseEnough,
     Circle(..), pointInCircle,
     Size(..),
     BBox(..), 
     bbX, bbY, bbWidth, bbSetWidth, bbHeight, bbPosition, bbSize,
     bbToRect, bbFromRect, bbCenter, bbLeft, bbXCenter, bbRight,
     bbTop, bbYCenter, bbBottom,
     bbMerge, bbMergeList, pointInBB,
     Widen(widen),
     Translate(..)
    )

where

import Data.Tree as T
import Graphics.UI.Gtk(Rectangle(Rectangle))

-- A Position may be interpreted either absolutely, as a point (x, y);
-- or relatively, as an offset (dx, dy)

data Position = Position {posX :: Double, posY :: Double} -- x, y
              deriving (Eq, Read, Show)

positionDelta :: Position -> Position -> (Double, Double)
positionDelta (Position x1 y1) (Position x2 y2) = (x2 - x1, y2 - y1)

positionDistance :: Position -> Position -> Double
positionDistance p1 p2 = sqrt (positionDistanceSquared p1 p2)

positionDistanceSquared :: Position -> Position -> Double
positionDistanceSquared (Position x1 y1) (Position x2 y2) =
    (x1 - x2) ** 2 + (y1 - y2) ** 2

positionCloseEnough :: Position -> Position -> Double -> Bool
positionCloseEnough p1 p2 radius =
    -- Essentially asks if p1 and p2 are nearly intersecting,
    -- i.e., if p1 is within a circle with center p2 and the given radius
    positionDistanceSquared p1 p2 <= radius ** 2



data Circle = Circle {circleCenter :: Position,
                      circleRadius :: Double}
            deriving (Eq, Read, Show)

pointInCircle :: Position -> Circle -> Bool
pointInCircle point (Circle center radius) =
  positionCloseEnough point center radius

data Size = Size {sizeW :: Double, sizeH :: Double}    -- width, height
              deriving (Eq, Read, Show)

-- | BBox x y width height; (x, y) is the top left corner

data BBox = BBox Double Double Double Double
                   deriving (Eq, Read, Show)

-- | BBox accessors and utilities

bbX, bbY, bbWidth, bbHeight :: BBox -> Double
bbX (BBox x _y _w _h) = x

bbY (BBox _x y _w _h) = y
bbWidth (BBox _x _y w _h) = w
bbHeight (BBox _x _y _w h) = h

bbPosition :: BBox -> Position
bbPosition (BBox x y _w _h) = Position x y

bbSize :: BBox -> Size
bbSize (BBox _x _y w h) = Size w h

bbCenter :: BBox -> Position
bbCenter (BBox x y w h) = Position (x + w / 2) (y + h / 2)

bbSetWidth :: BBox -> Double -> BBox
bbSetWidth (BBox x y _w h) nwidth = BBox x y nwidth h

bbLeft, bbXCenter, bbRight :: BBox -> Double
bbLeft = bbX
bbXCenter (BBox x _y w _h) = x + w / 2
bbRight (BBox x _y w _h) = x + w

bbTop, bbYCenter, bbBottom :: BBox -> Double
bbTop = bbY
bbYCenter (BBox _x y _w h) = y + h / 2
bbBottom (BBox _x y _w h) = y + h

bbToRect :: BBox -> Rectangle
bbToRect (BBox x y w h) = 
    Rectangle (round x) (round y) (round w) (round h)

bbFromRect :: Rectangle -> BBox
bbFromRect (Rectangle x y w h) =
    BBox (fromIntegral x) (fromIntegral y)
                (fromIntegral w) (fromIntegral h)

-- | Form a new BBox which encloses two bboxes
bbMerge :: BBox -> BBox -> BBox
bbMerge bb1 bb2 =
    let f1 ! f2 = f1 (f2 bb1) (f2 bb2)
        bottom = max ! bbBottom -- i.e.,  max (bbBottom bb1) (bbBottom bb2)
        top = min ! bbTop
        left = min ! bbLeft
        right = max ! bbRight
    in BBox left top (right - left) (bottom - top)

bbMergeList :: [BBox] -> BBox
bbMergeList [] = error "bbMergeList: empty list"
bbMergeList (b:bs) = foldl bbMerge b bs
    
-- Test whether a point (e.g., from mouse click) is within a
-- bounding box
pointInBB :: Position -> BBox -> Bool
pointInBB (Position x y) (BBox x1 y1 w h) =
    x >= x1 &&
    x <= x1 + w &&
    y >= y1 &&
    y <= y1 + h

class Widen a where
  -- | Make an object have at least a specified minimum width;
  -- does nothing if it's already at least that wide
  widen :: a -> Double -> a

instance Widen BBox where
    widen bb@(BBox x y w h) minWidth =
        if w >= minWidth
        then bb
        else BBox x y minWidth h

-- | A Translate is a thing that can be repositioned by
-- delta x and delta y

class Translate a where
        translate :: Double -- ^ delta X
                  -> Double -- ^ delta Y
                  -> a -- ^ thing in old position
                  -> a -- ^ thing in new position

instance (Translate e) => Translate [e] where
    translate dx dy = map (translate dx dy)

instance (Translate e) => Translate (Tree e) where
    translate dx dy t = 
        T.Node (translate dx dy (rootLabel t))
               (translate dx dy (subForest t))


instance Translate BBox where
  translate dx dy (BBox x y w h) = BBox (x + dx) (y + dy) w h

instance Translate Position where
    translate dx dy (Position x y) = Position (x + dx) (y + dy)

instance Translate Circle where
    translate dx dy (Circle center radius) =
        Circle (translate dx dy center) radius