{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Triangle.Class
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- A class of types representing Triangles
--
--------------------------------------------------------------------------------
module HGeometry.Triangle.Class
  ( Triangle_(..), pattern Triangle_
  , ConstructableTriangle_(..)
  , toCounterClockwiseTriangle
  , triangleSignedArea2X
  , intersectingHalfPlanes
  , toBarricentric, fromBarricentric
  -- * Re-exports from Hiraffe
  , HasVertices(..), HasVertices'(..)
  ) where

import Data.Default
import HGeometry.Ext
import Control.Lens
import HGeometry.HalfSpace
import HGeometry.Line.PointAndVector
import HGeometry.Point
import HGeometry.Properties (NumType, Dimension)
import HGeometry.Vector
import Hiraffe.Graph.Class(HasVertices(..), HasVertices'(..))

--------------------------------------------------------------------------------

-- $setup
-- >>> import HGeometry.Triangle


-- | Class representing triangles
class ( Point_   point (Dimension point) (NumType point)
      , HasVertices triangle triangle
      , Vertex triangle ~ point
      )
     => Triangle_ triangle point | triangle -> point where
  -- | Lens to access the corners of the triangle.
  corners :: Lens' triangle (Vector 3 point)

-- | Class representing constructable triangles
class Triangle_ triangle point => ConstructableTriangle_ triangle point where
  -- | Construct a triangle from its three vertices.
  mkTriangle :: point -> point -> point -> triangle

--------------------------------------------------------------------------------
-- * Ext instances

instance Triangle_ triangle point => Triangle_ (triangle :+ extra) point where
  corners :: Lens' (triangle :+ extra) (Vector 3 point)
corners = (triangle -> f triangle)
-> (triangle :+ extra) -> f (triangle :+ extra)
forall core extra core' (f :: * -> *).
Functor f =>
(core -> f core') -> (core :+ extra) -> f (core' :+ extra)
core((triangle -> f triangle)
 -> (triangle :+ extra) -> f (triangle :+ extra))
-> ((Vector 3 point -> f (Vector 3 point))
    -> triangle -> f triangle)
-> (Vector 3 point -> f (Vector 3 point))
-> (triangle :+ extra)
-> f (triangle :+ extra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Vector 3 point -> f (Vector 3 point)) -> triangle -> f triangle
forall triangle point.
Triangle_ triangle point =>
Lens' triangle (Vector 3 point)
Lens' triangle (Vector 3 point)
corners

instance ( ConstructableTriangle_ triangle point
         , Default extra
         ) => ConstructableTriangle_ (triangle :+ extra) point where
  mkTriangle :: point -> point -> point -> triangle :+ extra
mkTriangle point
a point
b point
c = point -> point -> point -> triangle
forall triangle point.
ConstructableTriangle_ triangle point =>
point -> point -> point -> triangle
mkTriangle point
a point
b point
c triangle -> extra -> triangle :+ extra
forall core extra. core -> extra -> core :+ extra
:+ extra
forall a. Default a => a
def

--------------------------------------------------------------------------------

-- | Pattern match on a triangle
pattern Triangle_ :: Triangle_ triangle point => point -> point -> point -> triangle
pattern $mTriangle_ :: forall {r} {triangle} {point}.
Triangle_ triangle point =>
triangle -> (point -> point -> point -> r) -> ((# #) -> r) -> r
Triangle_ u v w <- (view corners -> Vector3 u v w)
{-# COMPLETE Triangle_ #-}
{-# INLINE Triangle_ #-}

--------------------------------------------------------------------------------
-- * Two dimensional convenience functions


-- | Computes the double-signed area of a triangle
triangleSignedArea2X                   :: ( Num r
                                          , Point_ point 2 r
                                          , Triangle_ triangle point
                                          ) => triangle -> r
triangleSignedArea2X :: forall r point triangle.
(Num r, Point_ point 2 r, Triangle_ triangle point) =>
triangle -> r
triangleSignedArea2X (Triangle_ point
a point
b point
c) = [r] -> r
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ point
ppoint -> Getting r point r -> r
forall s a. s -> Getting a s a -> a
^.Getting r point r
forall (d :: Nat) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
xCoord r -> r -> r
forall a. Num a => a -> a -> a
* point
qpoint -> Getting r point r -> r
forall s a. s -> Getting a s a -> a
^.Getting r point r
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
yCoord r -> r -> r
forall a. Num a => a -> a -> a
- point
qpoint -> Getting r point r -> r
forall s a. s -> Getting a s a -> a
^.Getting r point r
forall (d :: Nat) point r.
(1 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
xCoord r -> r -> r
forall a. Num a => a -> a -> a
* point
ppoint -> Getting r point r -> r
forall s a. s -> Getting a s a -> a
^.Getting r point r
forall (d :: Nat) point r.
(2 <= d, Point_ point d r) =>
IndexedLens' Int point r
IndexedLens' Int point r
yCoord
                                             | (point
p,point
q) <- [(point, point)]
edges
                                             ]
  where
    edges :: [(point, point)]
edges = [(point
a,point
b),(point
b,point
c),(point
c,point
a)]
{-# INLINE triangleSignedArea2X #-}

-- | Make sure that the triangles vertices are given in counter clockwise order
--
-- >>> let t = Triangle origin (Point2 0 (-1)) (Point2 (-1) 0) :: Triangle (Point 2 Int)
-- >>> toCounterClockwiseTriangle t
-- Triangle (Point2 0 0) (Point2 (-1) 0) (Point2 0 (-1))
toCounterClockwiseTriangle :: ( Num r, Eq r
                              , Point_ point 2 r
                              , Triangle_ triangle point
                              ) => triangle -> triangle
toCounterClockwiseTriangle :: forall r point triangle.
(Num r, Eq r, Point_ point 2 r, Triangle_ triangle point) =>
triangle -> triangle
toCounterClockwiseTriangle t :: triangle
t@(Triangle_ point
a point
b point
c)
    | triangle -> Bool
isCounterClockwise triangle
t = triangle
t
    | Bool
otherwise            = triangle
ttriangle -> (triangle -> triangle) -> triangle
forall a b. a -> (a -> b) -> b
&(Vector 3 point -> Identity (Vector 3 point))
-> triangle -> Identity triangle
forall triangle point.
Triangle_ triangle point =>
Lens' triangle (Vector 3 point)
Lens' triangle (Vector 3 point)
corners ((Vector 3 point -> Identity (Vector 3 point))
 -> triangle -> Identity triangle)
-> Vector 3 point -> triangle -> triangle
forall s t a b. ASetter s t a b -> b -> s -> t
.~ point -> point -> point -> Vector 3 point
forall r. r -> r -> r -> Vector 3 r
Vector3 point
a point
c point
b
  where
    isCounterClockwise :: triangle -> Bool
isCounterClockwise = (\NumType (Vertex triangle)
x -> NumType (Vertex triangle)
x NumType (Vertex triangle) -> NumType (Vertex triangle) -> Bool
forall a. Eq a => a -> a -> Bool
== NumType (Vertex triangle) -> NumType (Vertex triangle)
forall a. Num a => a -> a
abs NumType (Vertex triangle)
x) (NumType (Vertex triangle) -> Bool)
-> (triangle -> NumType (Vertex triangle)) -> triangle -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. triangle -> NumType (Vertex triangle)
forall r point triangle.
(Num r, Point_ point 2 r, Triangle_ triangle point) =>
triangle -> r
triangleSignedArea2X

-- | Get the three halfplanes such that the triangle is the intersection of those
-- halfspaces.
--
-- >>> let t = Triangle origin (Point2 0 (-1)) (Point2 (-1) 0) :: Triangle (Point 2 Int)
-- >>> mapM_ print $ intersectingHalfPlanes t
-- HalfSpace Positive (LinePV (Point2 0 0) (Vector2 (-1) 0))
-- HalfSpace Positive (LinePV (Point2 (-1) 0) (Vector2 1 (-1)))
-- HalfSpace Positive (LinePV (Point2 0 (-1)) (Vector2 0 1))
intersectingHalfPlanes :: ( Triangle_ triangle point
                          , Point_ point 2 r
                          , Num r, Ord r
                          )
                       => triangle
                       -> Vector 3 (HalfSpaceF (LinePV 2 r))
intersectingHalfPlanes :: forall triangle point r.
(Triangle_ triangle point, Point_ point 2 r, Num r, Ord r) =>
triangle -> Vector 3 (HalfSpaceF (LinePV 2 r))
intersectingHalfPlanes (triangle -> triangle
forall r point triangle.
(Num r, Eq r, Point_ point 2 r, Triangle_ triangle point) =>
triangle -> triangle
toCounterClockwiseTriangle -> Triangle_ point
u point
v point
w) =
    HalfSpaceF (LinePV 2 r)
-> HalfSpaceF (LinePV 2 r)
-> HalfSpaceF (LinePV 2 r)
-> Vector 3 (HalfSpaceF (LinePV 2 r))
forall r. r -> r -> r -> Vector 3 r
Vector3 (point -> point -> HalfSpaceF (LinePV 2 (NumType point))
forall {point}.
(Dimension point ~ 2, Num (NumType point), Ord (NumType point),
 Point_ point 2 (NumType point)) =>
point -> point -> HalfSpaceF (LinePV 2 (NumType point))
leftPlane point
u point
v) (point -> point -> HalfSpaceF (LinePV 2 (NumType point))
forall {point}.
(Dimension point ~ 2, Num (NumType point), Ord (NumType point),
 Point_ point 2 (NumType point)) =>
point -> point -> HalfSpaceF (LinePV 2 (NumType point))
leftPlane point
v point
w) (point -> point -> HalfSpaceF (LinePV 2 (NumType point))
forall {point}.
(Dimension point ~ 2, Num (NumType point), Ord (NumType point),
 Point_ point 2 (NumType point)) =>
point -> point -> HalfSpaceF (LinePV 2 (NumType point))
leftPlane point
w point
u)
  where
    leftPlane :: point -> point -> HalfSpaceF (LinePV 2 (NumType point))
leftPlane point
p point
q = LinePV 2 (NumType point) -> HalfSpaceF (LinePV 2 (NumType point))
forall r. (Num r, Ord r) => LinePV 2 r -> HalfSpaceF (LinePV 2 r)
leftHalfPlane (LinePV 2 (NumType point) -> HalfSpaceF (LinePV 2 (NumType point)))
-> LinePV 2 (NumType point)
-> HalfSpaceF (LinePV 2 (NumType point))
forall a b. (a -> b) -> a -> b
$ Point 2 (NumType point)
-> Vector 2 (NumType point) -> LinePV 2 (NumType point)
forall (d :: Nat) r. Point d r -> Vector d r -> LinePV d r
LinePV (point
ppoint
-> Getting
     (Point 2 (NumType point)) point (Point 2 (NumType point))
-> Point 2 (NumType point)
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 (NumType point)) point (Point 2 (NumType point))
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 (NumType point))
asPoint) (point
q point -> point -> Vector 2 (NumType point)
forall point (d :: Nat) r.
(Affine_ point d r, Num r) =>
point -> point -> Vector d r
.-. point
p)


-- | Given a point q and a triangle, q inside the triangle, get the baricentric
-- cordinates of q
toBarricentric                                   :: ( Fractional r
                                                    , Point_ point 2 r
                                                    , Triangle_ triangle point
                                                    )
                                                 => point -> triangle
                                                 -> Vector 3 r
toBarricentric :: forall r point triangle.
(Fractional r, Point_ point 2 r, Triangle_ triangle point) =>
point -> triangle -> Vector 3 r
toBarricentric (Point2_ r
qx r
qy) (Triangle_ point
a point
b point
c) = r -> r -> r -> Vector 3 r
forall r. r -> r -> r -> Vector 3 r
Vector3 r
alpha r
beta r
gamma
  where
    Point2_ r
ax r
ay = point
a
    Point2_ r
bx r
by = point
b
    Point2_ r
cx r
cy = point
c

    dett :: r
dett  = (r
by r -> r -> r
forall a. Num a => a -> a -> a
- r
cy)r -> r -> r
forall a. Num a => a -> a -> a
*(r
ax r -> r -> r
forall a. Num a => a -> a -> a
- r
cx) r -> r -> r
forall a. Num a => a -> a -> a
+ (r
cx r -> r -> r
forall a. Num a => a -> a -> a
- r
bx)r -> r -> r
forall a. Num a => a -> a -> a
*(r
ay r -> r -> r
forall a. Num a => a -> a -> a
- r
cy)

    alpha :: r
alpha = ((r
by r -> r -> r
forall a. Num a => a -> a -> a
- r
cy)r -> r -> r
forall a. Num a => a -> a -> a
*(r
qx r -> r -> r
forall a. Num a => a -> a -> a
- r
cx) r -> r -> r
forall a. Num a => a -> a -> a
+ (r
cx r -> r -> r
forall a. Num a => a -> a -> a
- r
bx)r -> r -> r
forall a. Num a => a -> a -> a
*(r
qy r -> r -> r
forall a. Num a => a -> a -> a
- r
cy)) r -> r -> r
forall a. Fractional a => a -> a -> a
/ r
dett
    beta :: r
beta  = ((r
cy r -> r -> r
forall a. Num a => a -> a -> a
- r
ay)r -> r -> r
forall a. Num a => a -> a -> a
*(r
qx r -> r -> r
forall a. Num a => a -> a -> a
- r
cx) r -> r -> r
forall a. Num a => a -> a -> a
+ (r
ax r -> r -> r
forall a. Num a => a -> a -> a
- r
cx)r -> r -> r
forall a. Num a => a -> a -> a
*(r
qy r -> r -> r
forall a. Num a => a -> a -> a
- r
cy)) r -> r -> r
forall a. Fractional a => a -> a -> a
/ r
dett
    gamma :: r
gamma = r
1 r -> r -> r
forall a. Num a => a -> a -> a
- r
alpha r -> r -> r
forall a. Num a => a -> a -> a
- r
beta
    -- see https://en.wikipedia.org/wiki/Barycentric_coordinate_system#Conversion_between_barycentric_and_Cartesian_coordinates

-- | Given a vector of barricentric coordinates and a triangle, get the
-- corresponding point in the same coordinate sytsem as the vertices of the
-- triangle.
fromBarricentric                                   :: ( Triangle_ triangle point
                                                      , Point_ point d r
                                                      , Num r
                                                      )
                                                   => Vector 3 r
                                                   -> triangle
                                                   -> Point d r
fromBarricentric :: forall triangle point (d :: Nat) r.
(Triangle_ triangle point, Point_ point d r, Num r) =>
Vector 3 r -> triangle -> Point d r
fromBarricentric (Vector3 r
a r
b r
c) (Triangle_ point
p point
q point
r) = let f :: point -> Vector (Dimension point) (NumType point)
f = Getting
  (Vector (Dimension point) (NumType point))
  point
  (Vector (Dimension point) (NumType point))
-> point -> Vector (Dimension point) (NumType point)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Vector (Dimension point) (NumType point))
  point
  (Vector (Dimension point) (NumType point))
forall (d :: Nat) r s.
(Dimension point ~ d, NumType point ~ r, Dimension point ~ d,
 NumType point ~ s) =>
Lens point point (Vector d r) (Vector d s)
forall point point' (d :: Nat) r s.
(HasVector point point', Dimension point ~ d, NumType point ~ r,
 Dimension point' ~ d, NumType point' ~ s) =>
Lens point point' (Vector d r) (Vector d s)
Lens
  point
  point
  (Vector (Dimension point) (NumType point))
  (Vector (Dimension point) (NumType point))
vector in
                                                       Vector d r -> PointF (Vector d r)
forall v. v -> PointF v
Point (Vector d r -> PointF (Vector d r))
-> Vector d r -> PointF (Vector d r)
forall a b. (a -> b) -> a -> b
$ r
a r -> Vector d r -> Vector d r
forall r vector (d :: Nat).
(Num r, Vector_ vector d r) =>
r -> vector -> vector
*^ point -> Vector d r
point -> Vector (Dimension point) (NumType point)
f point
p Vector d r -> Vector d r -> Vector d r
forall r vector (d :: Nat).
(Num r, Additive_ vector d r) =>
vector -> vector -> vector
^+^ r
b r -> Vector d r -> Vector d r
forall r vector (d :: Nat).
(Num r, Vector_ vector d r) =>
r -> vector -> vector
*^ point -> Vector d r
point -> Vector (Dimension point) (NumType point)
f point
q Vector d r -> Vector d r -> Vector d r
forall r vector (d :: Nat).
(Num r, Additive_ vector d r) =>
vector -> vector -> vector
^+^ r
c r -> Vector d r -> Vector d r
forall r vector (d :: Nat).
(Num r, Vector_ vector d r) =>
r -> vector -> vector
*^ point -> Vector d r
point -> Vector (Dimension point) (NumType point)
f point
r