{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Geom2d.Shape.Internal
    ( Circle (..)
    , mkCircleInt
    , radius
    , center
    , Polygon (..)
    , convexHull'
    , rectangleInt
    , Shape (..)
    )

       where

import Data.Function
import Data.List hiding (intersect)
import Data.Maybe
import Geom2d.Distance
import Geom2d.Intersect
import Geom2d.Line.Internal
import Geom2d.Point
import Geom2d.Point.Internal
import Geom2d.Rotation
import Geom2d.Translate
import Test.QuickCheck

data Circle p a = Circle (p a) a deriving (Show,Read,Eq)

instance (Point p, Distance p p) => Distance (Circle p) p where
  distance (Circle m r) p =
    max (distance m p - r) 0

instance (Point p, Distance p p) => Distance p (Circle p) where
  distance = flip distance

instance (Floating a, Ord a, Distance p p) =>
         Intersect (Circle p a) (p a) where
  intersect (Circle m r) p
    | distance m p <= r = True
    | otherwise = False

instance (Floating a, Ord a, Distance p p) =>
         Intersect (p a) (Circle p a) where
  intersect = flip intersect

instance (Floating a, Ord a, Distance p p) =>
         Intersect (Circle p a) (Circle p a) where
  intersect (Circle m1 r1) (Circle m2 r2) =
    distance m1 m2 <= r1 + r2

instance (Arbitrary a, Arbitrary (p a), Ord a, Num a) =>
         Arbitrary (Circle p a) where
  arbitrary = Circle <$> arbitrary <*>
              (arbitrary `suchThat`(>0))

instance (Rotation p, Point p) => Rotation (Circle p) where
  angle (Circle m _) = angle m
  rotate ang (Circle m r) = Circle (rotate ang m) r

mkCircleInt :: (Num a) => p a -> a -> Circle p a
mkCircleInt m r' = Circle m (abs r')

radius :: Circle p a -> a
radius (Circle _ r) = r

center :: Circle p a -> p a
center (Circle m _) = m

-- | A Polygon is meant to describe a convex 2-dimensional shape.
data Polygon p a =  -- | The point (first argument) should be inside
                    -- the polygon, otherwise weird stuff will happen.
                    -- Also you must not specify the same vector
                    -- (second argument) twice.
                   Polygon (p a) [p a]
                   deriving (Show,Read,Eq)

instance (Point p, Fractional a, Num (p a), Eq (p a), Ord a) =>
         Intersect (p a) (Polygon p a) where
  intersect p (Polygon m vs) =
    any (`pointInTriangle` p) triangles
    where triangles = map (\(a,b) -> (m,a,b))
                      ( zip verteces (tail verteces ++ [head verteces]))
          verteces = map (+ m) vs

instance (Point p, Fractional a, Num (p a), Eq (p a), Ord a) =>
         Intersect (Polygon p a) (p a) where
  intersect = flip intersect

instance ( Arbitrary (p a), Num (p a), RealFloat a, Point p, Scale p
         , Eq (p a)) =>
         Arbitrary (Polygon p a) where
  arbitrary = do
    vs' <- listOf1 (arbitrary `suchThat` (\a -> magnitude a > 0)) `suchThat`
           ((>= 4).length)
    (return.fromJust.convexHull') vs'

instance (Eq (p a), Floating a, Num (p a), Ord a, Point p) =>
         Intersect (Polygon p a) (Circle p a) where
  intersect poly@(Polygon p vs') (Circle m r)
    | m `intersect` poly = True
    | otherwise =
          any ((r >=). distance m)
          verteces
    where verteces = zipWith FinLine
                     vs
                     (tail vs ++ [head vs])
          vs = map (p+) vs'

instance (Eq (p a), Num (p a), RealFloat a, Point p) =>
         Intersect (Polygon p a) (Polygon p a) where
  intersect poly1@(Polygon p1 vs1) poly2@(Polygon p2 vs2) =
    let verts1 = map (p1+) vs1
        verts2 = map (p2+) vs2
        edges1 = zipWith FinLine verts1 (tail verts1 ++ [head verts1])
        edges2 = zipWith FinLine verts2 (tail verts2 ++ [head verts2])
    in any (uncurry intersect)
       [ (v1,v2) | v1 <- edges1, v2 <- edges2 ] ||
       any (intersect poly2) verts1 ||
       any (intersect poly1) verts2

instance (Eq (p a), Floating a, Num (p a), Ord a, Point p) =>
         Intersect (Circle p a) (Polygon p a) where
  intersect = flip intersect

instance (Rotation p) => Rotation (Polygon p) where
  rotate r (Polygon m vs) = Polygon (rotate r m) (map (rotate r) vs)
  angle (Polygon m _) = angle m

-- | Calculate the convex hull of an arbitrary number of points.
convexHull' :: forall p a.
               (Num (p a), Fractional a, Ord a, Scale p, Point p) =>
               [p a] -> Maybe (Polygon p a)
convexHull' [] = Nothing
convexHull' [_] = Nothing
convexHull' [_,_] = Nothing
convexHull' ps = Just $
    Polygon middle (map (subtract middle) hull)
    where middle :: p a
          middle = (1 / (fromIntegral.length) hull) `scale`
                   sum hull
          hull :: [p a]
          hull = chain sortedPs
          chain :: [p a] -> [p a]
          chain xs = lower ++ upper
              where lower = go [] xs
                    upper = go [] (reverse xs)
          go :: [p a] -> [p a] -> [p a]
          go acc@(r1:r2:rs) (x:xs)
              | clockwise r2 r1 x = go (r2:rs) (x:xs)
              | otherwise = go (x:acc) xs
          go acc (x:xs) = go (x:acc) xs
          go acc [] = reverse $ tail acc
          sortedPs :: [p a]
          sortedPs = sortBy
                     (\p q ->
                         case compare (x p) (x q) of
                           EQ -> compare (y p) (y q)
                           c -> c
                     ) ps
          clockwise :: p a -> p a -> p a -> Bool
          clockwise o a b = (a - o) `cross` (b - o) <= 0

rectangleInt :: forall p a. (Point p, RealFloat a, Eq a, Translate p
                            , Rotation p) =>
             p a
          -> a -- ^ length of one side
          -> a -- ^ length of the other side
          -> Maybe (Polygon p a)
rectangleInt m a b
  | a == 0 || b == 0 = Nothing
  | otherwise =
      Just $
        Polygon
        m
        ( sortBy
          (compare `on` angle)
          [ fromCoords (negate a/2) (negate b/2) :: p a
          , fromCoords (a/2) (negate b/2) :: p a
          , fromCoords (a/2) (b/2) :: p a
          , fromCoords (negate a/2) (b/2) :: p a
          ]
        )

-- | `Shape` describes geometric shapes in the euklidean plain.
data Shape p a = ShapeCircle (Circle p a)
               | ShapePolygon (Polygon p a)
               deriving (Show,Read,Eq)

instance ( Ord a, Distance p p, Eq (p a)
         , Num (p a), Point p, RealFloat a) =>
         Intersect (Shape p a) (Shape p a) where
  intersect (ShapeCircle c) (ShapePolygon p) = c `intersect` p
  intersect (ShapePolygon p) (ShapeCircle c) = c `intersect` p
  intersect (ShapeCircle a) (ShapeCircle b) = a `intersect` b
  intersect (ShapePolygon a) (ShapePolygon b) = a `intersect` b

instance ( Floating a, Eq (p a), Num (p a), Ord a, Point p, Distance p p ) =>
         Intersect (Shape p a) (p a) where
  intersect (ShapeCircle c) p = c `intersect` p
  intersect (ShapePolygon c) p = c `intersect` p

instance ( Floating a, Eq (p a), Num (p a), Ord a, Point p, Distance p p ) =>
         Intersect (p a) (Shape p a) where
  intersect = flip intersect

instance (Rotation p, Point p) => Rotation (Shape p) where
  rotate a (ShapeCircle s) = ShapeCircle (rotate a s)
  rotate a (ShapePolygon s) = ShapePolygon (rotate a s)
  angle (ShapeCircle s) = angle s
  angle (ShapePolygon s) = angle s