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

-- This module provides basic algebra with 2d-vectors and geomtric shapes
-- Copyright (C) 2015, Sebastian Jordan

-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.

-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.

-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

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

       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 hiding (scale)

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 (Distance p (FinLine p), Floating a, Ord a) =>
         Intersect (Circle p a) (FinLine p a) where
  intersect (Circle m r) l =
    distance m l <= r

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

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

instance Translate p => Translate (Circle p) where
  translate v (Circle m r) = Circle (translate v 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, Ord a, Eq (p a), Floating 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, Floating 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 :: [p a]
        verts1 = map (p1+) vs1
        edges1 :: [FinLine p a]
        edges1 = zipWith FinLine verts1 (tail verts1 ++ [head verts1])
        verts2 :: [p a]
        verts2 = map (p2+) vs2
        edges2 :: [FinLine p a]
        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 (RealFloat a, Eq a, Eq (p a), Point p) =>
         Intersect (Polygon p a) (FinLine p a) where
  intersect poly@(Polygon m vs) line@(FinLine a b) =
    a `intersect` poly ||
    b `intersect` poly ||
    any (intersect line) edges
    where edges = zipWith FinLine verts (tail verts ++ [head verts])
          verts = map (+m) vs

instance (RealFloat a, Eq a, Eq (p a), Point p) =>
         Intersect (FinLine 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

instance Translate p => Translate (Polygon p) where
  translate v (Polygon m vs) = Polygon (translate v m) vs

-- | 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)
      | not (spatialBox c `intersect` spatialBox p) = False
      | otherwise = c `intersect` p
  intersect (ShapePolygon p) (ShapeCircle c)
      | not (spatialBox c `intersect` spatialBox p) = False
      | otherwise = c `intersect` p
  intersect (ShapeCircle a) (ShapeCircle b)
      | not (spatialBox a `intersect` spatialBox b) = False
      | otherwise = a `intersect` b
  intersect (ShapePolygon a) (ShapePolygon b)
      | not (spatialBox a `intersect` spatialBox b) = False
      | otherwise = 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 (Point p, RealFloat a, Ord a, Eq (p a)) =>
         Intersect (Shape p a) (FinLine p a) where
  intersect (ShapeCircle c) = intersect c
  intersect (ShapePolygon p) = intersect p

instance (Point p, RealFloat a, Ord a, Eq (p a)) =>
         Intersect (FinLine 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

instance ( Eq (p a), RealFloat a, Num (p a), Point p, Arbitrary a
         , Arbitrary (p a), Scale p) =>
         Arbitrary (Shape p a) where
  arbitrary = oneof [ ShapeCircle <$> arbitrary
                    , ShapePolygon <$> arbitrary
                    ]

instance Translate p => Translate (Shape p) where
  translate v (ShapeCircle c) = ShapeCircle (translate v c)
  translate v (ShapePolygon c) = ShapePolygon (translate v c)

class Spatial s where
  area :: (Floating a, Ord a) => s a -> a
  minX :: (Floating a, Ord a) => s a -> a
  maxX :: (Floating a, Ord a) => s a -> a
  minY :: (Floating a, Ord a) => s a -> a
  maxY :: (Floating a, Ord a) => s a -> a

instance (Point p) => Spatial (Circle p) where
  area (Circle _ r) = r^(2::Int) * pi
  minX (Circle m r) = x m - r
  maxX (Circle m r) = x m + r
  minY (Circle m r) = y m - r
  maxY (Circle m r) = y m + r

instance (Point p) => Spatial (Polygon p) where
  area (Polygon _ vs) =
    (sum.map (triArea.(\(a,b) -> (a,b,fromCoords 0 0)))) edges
    where edges = zip vs (tail vs ++ [head vs])
  minX (Polygon m vs) = x m + (minimum.map x) vs
  maxX (Polygon m vs) = x m + (maximum.map x) vs
  minY (Polygon m vs) = y m + (minimum.map y) vs
  maxY (Polygon m vs) = y m + (maximum.map y) vs

instance (Point p) => Spatial (Shape p) where
  area (ShapeCircle c) = area c
  area (ShapePolygon p) = area p
  minX (ShapeCircle c) = minX c
  minX (ShapePolygon p) = minX p
  maxX (ShapeCircle c) = maxX c
  maxX (ShapePolygon p) = maxX p
  minY (ShapeCircle c) = minY c
  minY (ShapePolygon p) = minY p
  maxY (ShapeCircle c) = maxY c
  maxY (ShapePolygon p) = maxY p

data Box a = Box (a,a) (a,a)

instance (Ord a) => Intersect (Box a) (Box a) where
  intersect (Box (a1x,a1y) (a2x,a2y)) (Box (b1x,b1y) (b2x,b2y)) =
    max a1x b1x <= min a2x b2x && max a1y b1y <= min a2y b2y

spatialBox :: (Floating a, Ord a, Spatial s) => s a -> Box a
spatialBox o = Box (minX o, minY o) (maxX o, maxY o)