Shape.hs

-- SG library
-- Copyright (c) 2009, Neil Brown.
-- All rights reserved.
-- 
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--  * Redistributions of source code must retain the above copyright
--    notice, this list of conditions and the following disclaimer.
--  * Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
--  * The author's name may not be used to endorse or promote products derived
--    from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
-- THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


-- | This module has types and functions for dealing with collision detection on
-- simple 2D shapes.
module Data.SG.Shape (Shape'(..), moveShape, rotateShape, scaleShape, shapePoints,
  boundingBox, overlap, intersectLineShape) where

import Control.Arrow
import Data.List
import Data.Maybe

import Data.SG.Geometry
import Data.SG.Geometry.TwoDim
import Data.SG.Matrix
import Data.SG.Vector

-- | A type for simple 2D convex shapes.  It is expected that you will define a
-- synonym in your own application such as @type Shape = Shape' Double@, hence
-- the funny name.
data Shape' a
       = Rectangle {shapeCentre :: Point2' a, rectSize :: (a, a)}
         -- ^ A rectangle with a centre, and a width (distance from the centre
         -- to the left or right side of the rectangle) and a height (distance
         -- from the centre to the top or bottom side of the rectangle.  So the
         -- rectangle with corners (1,1) and (3,2) is @Rectangle (Point2 (2,1.5))
         -- (1, 0.5)@.  Technically a rectangle is a polygon, of course, but a
         -- rectangle (which is axis-aligned) can be processed faster by most algorithms.
       | Circle {shapeCentre :: Point2' a, circSize :: a}
         -- ^ A circle with a centre and a radius.
       | Polygon {shapeCentre :: Point2' a,
           -- Points are offsets from centre (and join in loop):
           polyPoints :: [Rel2' a]}
         -- ^ A polygon with a centre, and a list of points.  The points are relative
         -- vectors from the centre of the polygon, and are expected to be in clockwise
         -- order.  For example, the triangle with corners (1,1) (3,3) and (3,1)
         -- could be @Polygon (Point2 (2.5, 1.5)) [Rel2 (-1.5,-0.5), Rel2 (0.5,1.5),
         -- Rel2 (-1.5, 1.5)]@.
         --
         -- Note that whereabouts the centre is inside the polygon is up to you
         -- (it does not /have to be/ the geometric average of the points), but
         -- it should at least be inside the polygon, or else some algorithms will
         -- behave strangely with it.
         --
         -- The list of points should have at least 3 points in it, or else some
         -- algorithms will behave strangely.
         --
         -- If your points are not in clockwise order (with the X-Y axes being
         -- how they are in graphs, not on screens), funny things will happen with
         -- the collision detection.
       deriving (Show, Read, Eq, Ord)

-- | Moves a shape by a given vector (by moving the centre).
moveShape :: (Num a, Eq a, Show a) => Rel2' a -> Shape' a -> Shape' a
moveShape x s = s {shapeCentre = shapeCentre s `plusDir` x}

-- | Given an angle in /radians/, rotates the shape by that angle in an anti-clockwise
-- direction.  A circle will remain untouched, a polygon will have its points rotated,
-- and a rectangle will become a polygon and get rotated (even if you pass 0 as the angle).
rotateShape :: forall a. Floating a => a -> Shape' a -> Shape' a
rotateShape _ s@(Circle {}) = s
rotateShape a s@(Rectangle c _) = rotateShape a (Polygon c $ polygonPoints s)
rotateShape a (Polygon c ps) = Polygon c $ map (multMatrix mat) ps
  where
    mat :: Matrix22' a
    mat = rotateZaxis a

-- | Scales the size of the shape (for all edges, from the centre) by the given
-- factor.
scaleShape :: Num a => a -> Shape' a -> Shape' a
scaleShape a (Circle c r) = Circle c (r*a)
scaleShape a (Rectangle c (w, h)) = Rectangle c (w*a, h*a)
scaleShape a (Polygon c ps) = Polygon c $ map (scaleRel a) ps

pts :: Num a => Point2' a -> (a, a) -> (Point2' a, Point2' a)
pts (Point2 (x, y)) (adjX, adjY) = (Point2 (x - adjX, y - adjY), Point2 (x + adjX, y + adjY))

-- | Gives back the bounding box of a shape in terms of the minimum X-Y and
-- the maximum X-Y corners of the bounding box.
boundingBox :: (Num a, Ord a, Eq a, Show a) => Shape' a -> (Point2' a, Point2' a)
boundingBox (Circle c r) = pts c (r, r)
boundingBox (Rectangle c (w, h)) = pts c (w, h)
boundingBox (Polygon p ps)
  = (p `plusDir` foldl (fmapNum2 min) (simpleVec 0) ps
    ,p `plusDir` foldl (fmapNum2 max) (simpleVec 0) ps)

twoFromList :: [a] -> Maybe (a, a)
twoFromList [] = Nothing
twoFromList [x] = Just (x, x)
twoFromList (x:y:_) = Just (x, y)

between :: Ord a => (a, a) -> a -> Bool
between (l, h) x = l <= x && x <= h

-- | Given a line and a shape, finds all possible intersections of the line
-- with the shape.  Since the shapes are convex, continuous 2D shapes, there
-- will either be no intersections or two (which could be the same point).
-- The returned value is distance along the line in multiples of the direction
-- vector (the return value is the same idea as 'intersectLineCircle').
intersectLineShape :: forall a. (Floating a, Ord a, Eq a, Show a) => Line2' a -> Shape' a -> Maybe (a, a)
-- For circle, use existing function:
intersectLineShape l (Circle c r) = intersectLineCircle l (c, r)
-- For rectangle, use axis alignment:
intersectLineShape l (Rectangle (Point2 (x,y)) (w, h))
  = let leftE = fmap (flip alongLine l &&& id) $ valueAtX l (x-w)
        rightE = fmap (flip alongLine l &&& id) $ valueAtX l (x+w)
        topE = fmap (flip alongLine l &&& id) $ valueAtY l (y-h)
        bottomE = fmap (flip alongLine l &&& id) $ valueAtY l (y+h)
    in twoFromList $ map snd $
         (filter (between (y-h, y+h) . getY . fst) $ catMaybes [leftE, rightE])
         ++ (filter (between (x-w, x+w) . getX . fst) $ catMaybes [topE, bottomE])
-- For polygons, treat the line as a 0-length item in the perpendicular direction;
-- project all the polygon points onto that direction, and any that cross the 0-point
-- intersect.
intersectLineShape l (Polygon c ps)
  = twoFromList $ mapMaybe check $ pairsInLoop ps'
  where
    -- To translate points to the line, we must add the centre of the polygon,
    -- and subtract the start of the line:
    translate = (fmapNum2 (-) c (getLineStart l) `plusDir`)
    
    ps' = map (flip projectPointOnto2 $ id &&& perpendicular2 $ getLineDir l)
      $ map translate ps

    sc = mag $ getLineDir l

    check :: (Point2' a, Point2' a) -> Maybe a
    check (p@(Point2 (_, y)), p'@(Point2 (_, y')))
      = if signum y /= signum y'
          then fmap ((/ sc) . getX) $ pointAtY (p `lineTo` p') 0
          else Nothing

-- | Checks for overlap between the two shapes.  If they do not collide,
-- returns Nothing.  If they do collide, gives back suggested angles away from
-- each other.  These are not necessarily the shortest direction to separate
-- the two shapes, but should be decent for doing collision resolution (by using
-- them as surface normals, or push-away vectors)
--
-- The first vector returned is the direction in which the first shape should
-- head (or the surface normal to bounce the first shape off), whereas the
-- second vector returned is the direction in which the second shape should
-- head (or the surface normal to bounce the second shape off).
--
-- This function includes an initial quick test, followed by a more detailed test
-- if necessary.
overlap :: (Floating a, Ord a, Eq a, Show a) => Shape' a -> Shape' a -> Maybe (Rel2' a, Rel2' a)
overlap a b
  | not (possibleOverlap a b) = Nothing
  | otherwise = detailedOverlap a b

-- | A quick test for possible intersection.
--
-- If it returns False, there is definitely no overlap.  If it returns True, there
-- might be some overlap.  For two circles, radiuses are checked (and the answer is
-- always accurate), for any other combination of shapes it checks bounding boxes.
possibleOverlap :: (Floating a, Ord a, Eq a, Show a) => Shape' a -> Shape' a -> Bool
possibleOverlap (Circle ca ra) (Circle cb rb)
  = magSq (ca `fromPt` cb) <= ((ra+rb)*(ra+rb))
possibleOverlap a b
  = not $ don'tOverlap getX || don'tOverlap getY
  where
    (a1, a2) = boundingBox a
    (b1, b2) = boundingBox b
    don'tOverlap f = f a2 < f b1 || f a1 > f b2

-- Projects an already-moved shape onto that axis.  Returns a list of pairs where
-- each item of the pair also has an index for that point (for circles, this is
-- always -1).
projectShape :: (Ord a, Floating a) => Shape' a -> Rel2' a -> [(Int, a)]
projectShape (Circle c r) axis
  = let a = c `projectPointOnto` axis in [(-1,a - r), (-1, a + r)]
-- I am assuming (perhaps incorrectly) that projecting each point onto the axis
-- will be sufficient (rather than projecting each side)
projectShape (Polygon c ps) axis
  = zip [0..] $ map (((c `projectPointOnto` axis') +) . (`projectOnto` axis')) ps
  where axis' = unitVector axis
-- A rectangle has four points, all permutations of (+-w, +-h)
-- Projection is done using the dot product.  We can speed things up by calculating
-- the two components of the dot product once, then adding them in different ways
-- to achieve the projection.
projectShape (Rectangle c (w,h)) axis
  = zip [0..] $ map ((c `projectPointOnto` axis) +) [-dotx+doty,dotx+doty,dotx-doty,-dotx-doty]
  where
    dotx = w * getX (unitVector axis)
    doty = h * getY (unitVector axis)

-- All adjacent pairings, including last-first
pairsInLoop :: [a] -> [(a,a)]
pairsInLoop [] = []
pairsInLoop [_] = []
pairsInLoop xs = pairs' xs
  where
    -- all patterns are taken care of, despite what GHC thinks
    pairs' [x] = [(x, head xs)]
    pairs' (x:y:ys) = (x, y) : pairs' (y:ys)
    pairs' _ = error "Unreachable code in pairsInLoop in Shape module"

-- | Collects a list of (unit-vector) axes perpendicular to all the edges of the
-- polygon, pointed outwards.  The list will be empty for circles.
collectAxes :: (Floating a, Ord a, Eq a, Show a) => Shape' a -> [Rel2' a]
collectAxes (Circle {}) = []
collectAxes (Polygon _ ps) = map unitVector [perpendicular2 (a + b) | (a,b) <- pairsInLoop ps]
collectAxes (Rectangle {}) = map (flip Rel2 1) [(-1,0), (1,0), (0, -1), (0, 1)]

-- | Given a shape, gets a list of relative vectors from the centre of the shape
-- to the points of the shape.  For polygons, this is the points list (unmodified).
--  For rectangles, it will be vectors to the four corners, and for circles, the
-- list will be empty.
polygonPoints :: Num a => Shape' a -> [Rel2' a]
polygonPoints (Circle {}) = []
polygonPoints (Rectangle _ (w, h))
  = map (flip Rel2 $ w*w + h*h) [(-w,h), (w, h), (w, -h), (-w, -h)]
polygonPoints (Polygon _ ps) = ps

-- | Given a shape, gets a list of points that make up the vertices of the
-- shape.  For circles, this list will be empty.
shapePoints :: (Num a, Eq a, Show a) => Shape' a -> [Point2' a]
shapePoints s = map (shapeCentre s `plusDir`) (polygonPoints s)

-- | Gets a list of lines representing each side of the shape (headed clockwise).
--  For circles, the list will be empty.
polygonLines :: (Floating a, Eq a, Show a) => Shape' a -> [Line2' a]
polygonLines s
  = map (uncurry lineTo)
      . pairsInLoop . map (shapeCentre s `plusDir`)
        . polygonPoints $ s
        
-- Gives back the reflected unit vector for each shape's angle away from the other.
-- returns Nothing if there was no collision after all.  You should only call this
-- if quickOverlap returned True.
detailedOverlap :: forall a. (Num a, Ord a, Floating a, Eq a, Show a) => Shape' a -> Shape' a -> Maybe (Rel2' a, Rel2' a)
detailedOverlap (Circle pa _) (Circle pb _)
-- Rely on quickOverlap having been called:
  = let a_min_b = pa `fromPt` pb in Just (unitVector a_min_b, unitVector $ negate a_min_b)
-- We actually need to handle circle vs something, different than two polygons,
-- because a circle and polygon can intersect without points being contained inside
-- the other, which screws up our angle of incidence tests and so on.
--
-- We test which lines intersect the circle, and use those to form the angle of
-- incidence for the circle.  For the reverse, we just use the vector from the
-- centre of the circle to the average of the line intersections
detailedOverlap (Circle pa ra) pb
  | null intersections = Nothing
  | otherwise = Just ({- Angle from polygon -}
                 averageUnitVec $ map (perpendicular2 . getLineDir . fst) intersections
                ,{- Angle from circle -}
                 averageUnitVec $ map (`fromPt` pa)
                   $ map (uncurry $ flip alongLine) intersections
                )
  where
    intersections = filter (\(_,x) -> 0 <= x && x <= 1)
      $ concat [if a == b then [(l, a)] else [(l, a),(l, b)]
               | (l, Just (a,b)) <- map (id &&& flip intersectLineCircle (pa, ra))
          $ polygonLines pb]

detailedOverlap pa pb@(Circle {}) = fmap (\(x,y) -> (y,x)) $ detailedOverlap pb pa
-- Must be no circles now:
detailedOverlap pa pb
  = case foldl1 intersect' (map (uncurry getOverlaps) projected) of
      (aps, bps) | null aps && null bps -> Nothing
                 | otherwise ->
                    let aLines = getLineIndexes (length $ collectAxes pa) aps
                        bLines = getLineIndexes (length $ collectAxes pb) bps
                    in Just $ averageUnitVec *** averageUnitVec
                        $ unzip $ map (getPerpUnit *** getPerpUnit) $
                        map (fst *** fst) $ filter inBound $ findAllIntersections2
                          (map (polygonLines pb !!) bLines, map (polygonLines pa !!) aLines)
      
  where
    axes = collectAxes pa ++ collectAxes pb

    getPerpUnit = unitVector . perpendicular2 . (\(Line2 _ dir) -> dir)

    inBound ((_, ad), (_, bd)) = 0 <= ad && ad <= 1 && 0 <= bd && bd <= 1

    -- Given number of points, and some point indexes, gets the indexes of all
    -- the lines adjacent to those points.  If an empty list is given for the points,
    -- all line indexes are returned.
    getLineIndexes :: Int -> [Int] -> [Int]
    getLineIndexes total [] = [0 .. total - 1]
    getLineIndexes total ns = nub $ map (`mod` total) $ concatMap (\n -> [n-1,n]) ns

    projected :: [([(Int, a)], [(Int, a)])]
    projected = map (projectShape pa &&& projectShape pb) axes

    -- We can shortcut if any pair of lists involved is empty:
    intersect' :: ([Int], [Int]) -> ([Int], [Int]) -> ([Int], [Int])
    intersect' (as, bs) (cs, ds)
      | (null as && null bs) || (null cs && null ds) = ([], [])
      | otherwise = (as `intersect` cs, bs `intersect` ds)
    

    getOverlaps :: [(Int, a)] -> [(Int, a)] -> ([Int], [Int])
    getOverlaps as bs
      | maxa < minb || mina > maxb = ([], [])
      | otherwise = (map fst $ filter (overlapb . snd) as
                    ,map fst $ filter (overlapa . snd) bs)
      where
        getMinMax = minimum &&& maximum

        (mina, maxa) = getMinMax $ map snd as
        (minb, maxb) = getMinMax $ map snd bs
        overlapa x = mina <= x && x <= maxa
        overlapb x = minb <= x && x <= maxb