{-# LANGUAGE DeriveAnyClass  #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.Line.Internal
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- \(d\)-dimensional lines.
--
--------------------------------------------------------------------------------
module Data.Geometry.Line.Internal where

import           Control.DeepSeq
import           Control.Lens
import qualified Data.Foldable as F
import           Data.Geometry.Point
import           Data.Geometry.Properties
import           Data.Geometry.Vector
import           Data.Ord (comparing)
import qualified Data.Traversable as T
import           Data.Vinyl
import           Data.Vinyl.CoRec
import           GHC.Generics (Generic)
import           Test.QuickCheck

--------------------------------------------------------------------------------
-- * d-dimensional Lines

-- | A line is given by an anchor point and a vector indicating the
-- direction.
data Line d r = Line { Line d r -> Point d r
_anchorPoint :: !(Point  d r)
                     , Line d r -> Vector d r
_direction   :: !(Vector d r)
                     } deriving (forall x. Line d r -> Rep (Line d r) x)
-> (forall x. Rep (Line d r) x -> Line d r) -> Generic (Line d r)
forall x. Rep (Line d r) x -> Line d r
forall x. Line d r -> Rep (Line d r) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (d :: Nat) r x. Rep (Line d r) x -> Line d r
forall (d :: Nat) r x. Line d r -> Rep (Line d r) x
$cto :: forall (d :: Nat) r x. Rep (Line d r) x -> Line d r
$cfrom :: forall (d :: Nat) r x. Line d r -> Rep (Line d r) x
Generic

-- | Line anchor point.
anchorPoint :: Lens' (Line d r) (Point d r)
anchorPoint :: (Point d r -> f (Point d r)) -> Line d r -> f (Line d r)
anchorPoint = (Line d r -> Point d r)
-> (Line d r -> Point d r -> Line d r)
-> Lens (Line d r) (Line d r) (Point d r) (Point d r)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Line d r -> Point d r
forall (d :: Nat) r. Line d r -> Point d r
_anchorPoint (\Line d r
line Point d r
pt -> Line d r
line{_anchorPoint :: Point d r
_anchorPoint=Point d r
pt})

-- | Line direction.
direction :: Lens' (Line d r) (Vector d r)
direction :: (Vector d r -> f (Vector d r)) -> Line d r -> f (Line d r)
direction = (Line d r -> Vector d r)
-> (Line d r -> Vector d r -> Line d r)
-> Lens (Line d r) (Line d r) (Vector d r) (Vector d r)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Line d r -> Vector d r
forall (d :: Nat) r. Line d r -> Vector d r
_direction (\Line d r
line Vector d r
dir -> Line d r
line{_direction :: Vector d r
_direction=Vector d r
dir})

instance (Show r, Arity d) => Show (Line d r) where
  show :: Line d r -> String
show (Line Point d r
p Vector d r
v) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"Line (", Point d r -> String
forall a. Show a => a -> String
show Point d r
p, String
") (", Vector d r -> String
forall a. Show a => a -> String
show Vector d r
v, String
")" ]

-- -- TODO:
-- instance (Read r, Arity d)   => Read (Line d r) where




deriving instance (NFData r, Arity d) => NFData        (Line d r)
deriving instance Arity d             => Functor       (Line d)
deriving instance Arity d             => F.Foldable    (Line d)
deriving instance Arity d             => T.Traversable (Line d)

instance (Arity d, Eq r, Fractional r) => Eq (Line d r) where
  l :: Line d r
l@(Line Point d r
p Vector d r
_) == :: Line d r -> Line d r -> Bool
== Line d r
m = Line d r
l Line d r -> Line d r -> Bool
forall r (d :: Nat).
(Eq r, Fractional r, Arity d) =>
Line d r -> Line d r -> Bool
`isParallelTo` Line d r
m Bool -> Bool -> Bool
&& Point d r
p Point d r -> Line d r -> Bool
forall r (d :: Nat).
(Eq r, Fractional r, Arity d) =>
Point d r -> Line d r -> Bool
`onLine` Line d r
m



instance (Arbitrary r, Arity d, Num r, Eq r) => Arbitrary (Line d r) where
  arbitrary :: Gen (Line d r)
arbitrary = do Point d r
p <- Gen (Point d r)
forall a. Arbitrary a => Gen a
arbitrary
                 Point d r
q <- Gen (Point d r) -> (Point d r -> Bool) -> Gen (Point d r)
forall a. Gen a -> (a -> Bool) -> Gen a
suchThat Gen (Point d r)
forall a. Arbitrary a => Gen a
arbitrary (Point d r -> Point d r -> Bool
forall a. Eq a => a -> a -> Bool
/= Point d r
p)
                 Line d r -> Gen (Line d r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Line d r -> Gen (Line d r)) -> Line d r -> Gen (Line d r)
forall a b. (a -> b) -> a -> b
$ Point d r -> Point d r -> Line d r
forall r (d :: Nat).
(Num r, Arity d) =>
Point d r -> Point d r -> Line d r
lineThrough Point d r
p Point d r
q

type instance Dimension (Line d r) = d
type instance NumType   (Line d r) = r

-- ** Functions on lines

-- | A line may be constructed from two points.
lineThrough     :: (Num r, Arity d) => Point d r -> Point d r -> Line d r
lineThrough :: Point d r -> Point d r -> Line d r
lineThrough Point d r
p Point d r
q = Point d r -> Vector d r -> Line d r
forall (d :: Nat) r. Point d r -> Vector d r -> Line d r
Line Point d r
p (Point d r
q Point d r -> Point d r -> Diff (Point d) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point d r
p)

-- | Vertical line with a given X-coordinate.
verticalLine   :: Num r => r -> Line 2 r
verticalLine :: r -> Line 2 r
verticalLine r
x = Point 2 r -> Vector 2 r -> Line 2 r
forall (d :: Nat) r. Point d r -> Vector d r -> Line d r
Line (r -> r -> Point 2 r
forall r. r -> r -> Point 2 r
Point2 r
x r
0) (r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
0 r
1)

-- | Horizontal line with a given Y-coordinate.
horizontalLine   :: Num r => r -> Line 2 r
horizontalLine :: r -> Line 2 r
horizontalLine r
y = Point 2 r -> Vector 2 r -> Line 2 r
forall (d :: Nat) r. Point d r -> Vector d r -> Line d r
Line (r -> r -> Point 2 r
forall r. r -> r -> Point 2 r
Point2 r
0 r
y) (r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
1 r
0)

-- | Given a line l with anchor point p and vector v, get the line
-- perpendicular to l that also goes through p. The resulting line m is
-- oriented such that v points into the left halfplane of m.
--
-- >>> perpendicularTo $ Line (Point2 3 4) (Vector2 (-1) 2)
-- Line (Point2 3 4) (Vector2 (-2) (-1))
perpendicularTo                           :: Num r => Line 2 r -> Line 2 r
perpendicularTo :: Line 2 r -> Line 2 r
perpendicularTo (Line Point 2 r
p ~(Vector2 r
vx r
vy)) = Point 2 r -> Vector 2 r -> Line 2 r
forall (d :: Nat) r. Point d r -> Vector d r -> Line d r
Line Point 2 r
p (r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 (-r
vy) r
vx)

-- | Test if a vector is perpendicular to the line.
isPerpendicularTo :: (Num r, Eq r) => Vector 2 r -> Line 2 r -> Bool
Vector 2 r
v isPerpendicularTo :: Vector 2 r -> Line 2 r -> Bool
`isPerpendicularTo` (Line Point 2 r
_ Vector 2 r
u) = Vector 2 r
v Vector 2 r -> Vector 2 r -> r
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Vector 2 r
u r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
0

-- | Test if two lines are identical, meaning; if they have exactly the same
-- anchor point and directional vector.
isIdenticalTo                         :: (Eq r, Arity d) => Line d r -> Line d r -> Bool
(Line Point d r
p Vector d r
u) isIdenticalTo :: Line d r -> Line d r -> Bool
`isIdenticalTo` (Line Point d r
q Vector d r
v) = (Point d r
p,Vector d r
u) (Point d r, Vector d r) -> (Point d r, Vector d r) -> Bool
forall a. Eq a => a -> a -> Bool
== (Point d r
q,Vector d r
v)


-- | Test if the two lines are parallel.
--
-- >>> lineThrough origin (Point2 1 0) `isParallelTo` lineThrough (Point2 1 1) (Point2 2 1)
-- True
-- >>> lineThrough origin (Point2 1 0) `isParallelTo` lineThrough (Point2 1 1) (Point2 2 2)
-- False
isParallelTo                         :: (Eq r, Fractional r, Arity d)
                                     => Line d r -> Line d r -> Bool
(Line Point d r
_ Vector d r
u) isParallelTo :: Line d r -> Line d r -> Bool
`isParallelTo` (Line Point d r
_ Vector d r
v) = Vector d r
u Vector d r -> Vector d r -> Bool
forall r (d :: Nat).
(Eq r, Fractional r, Arity d) =>
Vector d r -> Vector d r -> Bool
`isScalarMultipleOf` Vector d r
v
  -- TODO: Maybe use a specialize pragma for 2D (see intersect instance for two lines.)


-- | Test if point p lies on line l
--
-- >>> origin `onLine` lineThrough origin (Point2 1 0)
-- True
-- >>> Point2 10 10 `onLine` lineThrough origin (Point2 2 2)
-- True
-- >>> Point2 10 5 `onLine` lineThrough origin (Point2 2 2)
-- False
onLine                :: (Eq r, Fractional r, Arity d) => Point d r -> Line d r -> Bool
Point d r
p onLine :: Point d r -> Line d r -> Bool
`onLine` (Line Point d r
q Vector d r
v) = Point d r
p Point d r -> Point d r -> Bool
forall a. Eq a => a -> a -> Bool
== Point d r
q Bool -> Bool -> Bool
|| (Point d r
p Point d r -> Point d r -> Diff (Point d) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point d r
q) Vector d r -> Vector d r -> Bool
forall r (d :: Nat).
(Eq r, Fractional r, Arity d) =>
Vector d r -> Vector d r -> Bool
`isScalarMultipleOf` Vector d r
v

-- | Specific 2d version of testing if apoint lies on a line.
onLine2 :: (Ord r, Num r) => Point 2 r -> Line 2 r -> Bool
Point 2 r
p onLine2 :: Point 2 r -> Line 2 r -> Bool
`onLine2` (Line Point 2 r
q Vector 2 r
v) = Point 2 r -> Point 2 r -> Point 2 r -> CCW
forall r.
(Ord r, Num r) =>
Point 2 r -> Point 2 r -> Point 2 r -> CCW
ccw Point 2 r
p Point 2 r
q (Point 2 r
q Point 2 r -> Diff (Point 2) r -> Point 2 r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ Diff (Point 2) r
Vector 2 r
v) CCW -> CCW -> Bool
forall a. Eq a => a -> a -> Bool
== CCW
CoLinear





-- | Get the point at the given position along line, where 0 corresponds to the
-- anchorPoint of the line, and 1 to the point anchorPoint .+^ directionVector
pointAt              :: (Num r, Arity d) => r -> Line d r -> Point d r
pointAt :: r -> Line d r -> Point d r
pointAt r
a (Line Point d r
p Vector d r
v) = Point d r
p Point d r -> Diff (Point d) r -> Point d r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (r
a r -> Vector d r -> Vector d r
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ Vector d r
v)


-- | Given point p and a line (Line q v), Get the scalar lambda s.t.
-- p = q + lambda v. If p does not lie on the line this returns a Nothing.
toOffset              :: (Eq r, Fractional r, Arity d) => Point d r -> Line d r -> Maybe r
toOffset :: Point d r -> Line d r -> Maybe r
toOffset Point d r
p (Line Point d r
q Vector d r
v) = Vector d r -> Vector d r -> Maybe r
forall r (d :: Nat).
(Eq r, Fractional r, Arity d) =>
Vector d r -> Vector d r -> Maybe r
scalarMultiple (Point d r
p Point d r -> Point d r -> Diff (Point d) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point d r
q) Vector d r
v


-- | Given point p near a line (Line q v), get the scalar lambda s.t.
-- the distance between 'p' and 'q + lambda v' is minimized.
--
-- >>> toOffset' (Point2 1 1) (lineThrough origin $ Point2 10 10)
-- 0.1
--
-- >>> toOffset' (Point2 5 5) (lineThrough origin $ Point2 10 10)
-- 0.5
--
-- \<6,4\> is not on the line but we can still point closest to it.
-- >>> toOffset' (Point2 6 4) (lineThrough origin $ Point2 10 10)
-- 0.5
toOffset'             :: (Eq r, Fractional r, Arity d) => Point d r -> Line d r -> r
toOffset' :: Point d r -> Line d r -> r
toOffset' Point d r
p (Line Point d r
q Vector d r
v) = Vector d r -> Vector d r -> r
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
dot (Point d r
p Point d r -> Point d r -> Diff (Point d) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point d r
q) Vector d r
v r -> r -> r
forall a. Fractional a => a -> a -> a
/ Vector d r -> r
forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance Vector d r
v
-- toOffset' p = fromJust' . toOffset p
--   where
--     fromJust' (Just x) = x
--     fromJust' _        = error "toOffset: Nothing"


-- | The intersection of two lines is either: NoIntersection, a point or a line.
type instance IntersectionOf (Line 2 r) (Line 2 r) = [ NoIntersection
                                                     , Point 2 r
                                                     , Line 2 r
                                                     ]

instance (Eq r, Fractional r) => Line 2 r `IsIntersectableWith` Line 2 r where


  nonEmptyIntersection :: proxy (Line 2 r)
-> proxy (Line 2 r) -> Intersection (Line 2 r) (Line 2 r) -> Bool
nonEmptyIntersection = proxy (Line 2 r)
-> proxy (Line 2 r) -> Intersection (Line 2 r) (Line 2 r) -> Bool
forall g h (proxy :: * -> *).
(NoIntersection ∈ IntersectionOf g h,
 RecApplicative (IntersectionOf g h)) =>
proxy g -> proxy h -> Intersection g h -> Bool
defaultNonEmptyIntersection

  l :: Line 2 r
l@(Line Point 2 r
p ~(Vector2 r
ux r
uy)) intersect :: Line 2 r -> Line 2 r -> Intersection (Line 2 r) (Line 2 r)
`intersect` (Line Point 2 r
q ~v :: Vector 2 r
v@(Vector2 r
vx r
vy))
      | Bool
areParallel = if Point 2 r
q Point 2 r -> Line 2 r -> Bool
forall r (d :: Nat).
(Eq r, Fractional r, Arity d) =>
Point d r -> Line d r -> Bool
`onLine` Line 2 r
l then Line 2 r -> CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
forall a (as :: [*]). (a ∈ as) => a -> CoRec Identity as
coRec Line 2 r
l
                                      else NoIntersection
-> CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
forall a (as :: [*]). (a ∈ as) => a -> CoRec Identity as
coRec NoIntersection
NoIntersection
      | Bool
otherwise   = Point 2 r -> CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
forall a (as :: [*]). (a ∈ as) => a -> CoRec Identity as
coRec Point 2 r
r
    where
      r :: Point 2 r
r = Point 2 r
q Point 2 r -> Diff (Point 2) r -> Point 2 r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ r
alpha r -> Vector 2 r -> Vector 2 r
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ Vector 2 r
v

      denom :: r
denom       = r
vy r -> r -> r
forall a. Num a => a -> a -> a
* r
ux r -> r -> r
forall a. Num a => a -> a -> a
- r
vx r -> r -> r
forall a. Num a => a -> a -> a
* r
uy
      areParallel :: Bool
areParallel = r
denom r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
0
      -- Instead of using areParallel, we can also use the generic 'isParallelTo' function
      -- for lines of arbitrary dimension, but this is a bit more efficient.

      alpha :: r
alpha        = (r
ux r -> r -> r
forall a. Num a => a -> a -> a
* (r
py r -> r -> r
forall a. Num a => a -> a -> a
- r
qy) r -> r -> r
forall a. Num a => a -> a -> a
+ r
uy r -> r -> r
forall a. Num a => a -> a -> a
* (r
qx r -> r -> r
forall a. Num a => a -> a -> a
- r
px)) r -> r -> r
forall a. Fractional a => a -> a -> a
/ r
denom

      Point2 r
px r
py = Point 2 r
p
      Point2 r
qx r
qy = Point 2 r
q

-- | Squared distance from point p to line l
sqDistanceTo   :: (Fractional r, Arity d) => Point d r -> Line d r -> r
sqDistanceTo :: Point d r -> Line d r -> r
sqDistanceTo Point d r
p = (r, Point d r) -> r
forall a b. (a, b) -> a
fst ((r, Point d r) -> r)
-> (Line d r -> (r, Point d r)) -> Line d r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point d r -> Line d r -> (r, Point d r)
forall r (d :: Nat).
(Fractional r, Arity d) =>
Point d r -> Line d r -> (r, Point d r)
sqDistanceToArg Point d r
p


-- | The squared distance between the point p and the line l, and the point m
-- realizing this distance.
sqDistanceToArg              :: (Fractional r, Arity d)
                             => Point d r -> Line d r -> (r, Point d r)
sqDistanceToArg :: Point d r -> Line d r -> (r, Point d r)
sqDistanceToArg Point d r
p (Line Point d r
q Vector d r
v) = let u :: Diff (Point d) r
u = Point d r
q Point d r -> Point d r -> Diff (Point d) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point d r
p
                                   t :: r
t = (-r
1 r -> r -> r
forall a. Num a => a -> a -> a
* (Diff (Point d) r
Vector d r
u Vector d r -> Vector d r -> r
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Vector d r
v)) r -> r -> r
forall a. Fractional a => a -> a -> a
/ (Vector d r
v Vector d r -> Vector d r -> r
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Vector d r
v)
                                   m :: Point d r
m = Point d r
q Point d r -> Diff (Point d) r -> Point d r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (Vector d r
v Vector d r -> r -> Vector d r
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* r
t)
                               in (Point d r -> Point d r -> r
forall (p :: * -> *) a.
(Affine p, Foldable (Diff p), Num a) =>
p a -> p a -> a
qdA Point d r
m Point d r
p, Point d r
m)

--------------------------------------------------------------------------------
-- * Supporting Lines

-- | Types for which we can compute a supporting line, i.e. a line that contains the thing of type t.
class HasSupportingLine t where
  supportingLine :: t -> Line (Dimension t) (NumType t)

instance HasSupportingLine (Line d r) where
  supportingLine :: Line d r -> Line (Dimension (Line d r)) (NumType (Line d r))
supportingLine = Line d r -> Line (Dimension (Line d r)) (NumType (Line d r))
forall a. a -> a
id

--------------------------------------------------------------------------------
-- * Convenience functions on Two dimensional lines

-- | Create a line from the linear function ax + b
fromLinearFunction     :: Num r => r -> r -> Line 2 r
fromLinearFunction :: r -> r -> Line 2 r
fromLinearFunction r
a r
b = Point 2 r -> Vector 2 r -> Line 2 r
forall (d :: Nat) r. Point d r -> Vector d r -> Line d r
Line (r -> r -> Point 2 r
forall r. r -> r -> Point 2 r
Point2 r
0 r
b) (r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
1 r
a)

{- HLINT ignore toLinearFunction -}
-- | get values a,b s.t. the input line is described by y = ax + b.
-- returns Nothing if the line is vertical
toLinearFunction                             :: forall r. (Fractional r, Eq r)
                                             => Line 2 r -> Maybe (r,r)
toLinearFunction :: Line 2 r -> Maybe (r, r)
toLinearFunction l :: Line 2 r
l@(Line Point 2 r
_ ~(Vector2 r
vx r
vy)) = CoRec Identity '[NoIntersection, Point 2 r, Line 2 r]
-> Handlers '[NoIntersection, Point 2 r, Line 2 r] (Maybe (r, r))
-> Maybe (r, r)
forall (ts :: [*]) b. CoRec Identity ts -> Handlers ts b -> b
match (Line 2 r
l Line 2 r -> Line 2 r -> Intersection (Line 2 r) (Line 2 r)
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` r -> Line 2 r
forall r. Num r => r -> Line 2 r
verticalLine (r
0 :: r)) (Handlers '[NoIntersection, Point 2 r, Line 2 r] (Maybe (r, r))
 -> Maybe (r, r))
-> Handlers '[NoIntersection, Point 2 r, Line 2 r] (Maybe (r, r))
-> Maybe (r, r)
forall a b. (a -> b) -> a -> b
$
       ((NoIntersection -> Maybe (r, r))
-> Handler (Maybe (r, r)) NoIntersection
forall b a. (a -> b) -> Handler b a
H ((NoIntersection -> Maybe (r, r))
 -> Handler (Maybe (r, r)) NoIntersection)
-> (NoIntersection -> Maybe (r, r))
-> Handler (Maybe (r, r)) NoIntersection
forall a b. (a -> b) -> a -> b
$ \NoIntersection
NoIntersection -> Maybe (r, r)
forall a. Maybe a
Nothing)    -- l is a vertical line
    Handler (Maybe (r, r)) NoIntersection
-> Rec (Handler (Maybe (r, r))) '[Point 2 r, Line 2 r]
-> Handlers '[NoIntersection, Point 2 r, Line 2 r] (Maybe (r, r))
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& ((Point 2 r -> Maybe (r, r)) -> Handler (Maybe (r, r)) (Point 2 r)
forall b a. (a -> b) -> Handler b a
H ((Point 2 r -> Maybe (r, r)) -> Handler (Maybe (r, r)) (Point 2 r))
-> (Point 2 r -> Maybe (r, r))
-> Handler (Maybe (r, r)) (Point 2 r)
forall a b. (a -> b) -> a -> b
$ \(Point2 r
_ r
b)   -> (r, r) -> Maybe (r, r)
forall a. a -> Maybe a
Just (r
vy r -> r -> r
forall a. Fractional a => a -> a -> a
/ r
vx,r
b))
    Handler (Maybe (r, r)) (Point 2 r)
-> Rec (Handler (Maybe (r, r))) '[Line 2 r]
-> Rec (Handler (Maybe (r, r))) '[Point 2 r, Line 2 r]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& ((Line 2 r -> Maybe (r, r)) -> Handler (Maybe (r, r)) (Line 2 r)
forall b a. (a -> b) -> Handler b a
H ((Line 2 r -> Maybe (r, r)) -> Handler (Maybe (r, r)) (Line 2 r))
-> (Line 2 r -> Maybe (r, r)) -> Handler (Maybe (r, r)) (Line 2 r)
forall a b. (a -> b) -> a -> b
$ \Line 2 r
_              -> Maybe (r, r)
forall a. Maybe a
Nothing)    -- l is a vertical line (through x=0)
    Handler (Maybe (r, r)) (Line 2 r)
-> Rec (Handler (Maybe (r, r))) '[]
-> Rec (Handler (Maybe (r, r))) '[Line 2 r]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec (Handler (Maybe (r, r))) '[]
forall u (a :: u -> *). Rec a '[]
RNil


-- | Result of a side test
data SideTestUpDown = Below | On | Above deriving (Int -> SideTestUpDown -> ShowS
[SideTestUpDown] -> ShowS
SideTestUpDown -> String
(Int -> SideTestUpDown -> ShowS)
-> (SideTestUpDown -> String)
-> ([SideTestUpDown] -> ShowS)
-> Show SideTestUpDown
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SideTestUpDown] -> ShowS
$cshowList :: [SideTestUpDown] -> ShowS
show :: SideTestUpDown -> String
$cshow :: SideTestUpDown -> String
showsPrec :: Int -> SideTestUpDown -> ShowS
$cshowsPrec :: Int -> SideTestUpDown -> ShowS
Show,ReadPrec [SideTestUpDown]
ReadPrec SideTestUpDown
Int -> ReadS SideTestUpDown
ReadS [SideTestUpDown]
(Int -> ReadS SideTestUpDown)
-> ReadS [SideTestUpDown]
-> ReadPrec SideTestUpDown
-> ReadPrec [SideTestUpDown]
-> Read SideTestUpDown
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SideTestUpDown]
$creadListPrec :: ReadPrec [SideTestUpDown]
readPrec :: ReadPrec SideTestUpDown
$creadPrec :: ReadPrec SideTestUpDown
readList :: ReadS [SideTestUpDown]
$creadList :: ReadS [SideTestUpDown]
readsPrec :: Int -> ReadS SideTestUpDown
$creadsPrec :: Int -> ReadS SideTestUpDown
Read,SideTestUpDown -> SideTestUpDown -> Bool
(SideTestUpDown -> SideTestUpDown -> Bool)
-> (SideTestUpDown -> SideTestUpDown -> Bool) -> Eq SideTestUpDown
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SideTestUpDown -> SideTestUpDown -> Bool
$c/= :: SideTestUpDown -> SideTestUpDown -> Bool
== :: SideTestUpDown -> SideTestUpDown -> Bool
$c== :: SideTestUpDown -> SideTestUpDown -> Bool
Eq,Eq SideTestUpDown
Eq SideTestUpDown
-> (SideTestUpDown -> SideTestUpDown -> Ordering)
-> (SideTestUpDown -> SideTestUpDown -> Bool)
-> (SideTestUpDown -> SideTestUpDown -> Bool)
-> (SideTestUpDown -> SideTestUpDown -> Bool)
-> (SideTestUpDown -> SideTestUpDown -> Bool)
-> (SideTestUpDown -> SideTestUpDown -> SideTestUpDown)
-> (SideTestUpDown -> SideTestUpDown -> SideTestUpDown)
-> Ord SideTestUpDown
SideTestUpDown -> SideTestUpDown -> Bool
SideTestUpDown -> SideTestUpDown -> Ordering
SideTestUpDown -> SideTestUpDown -> SideTestUpDown
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SideTestUpDown -> SideTestUpDown -> SideTestUpDown
$cmin :: SideTestUpDown -> SideTestUpDown -> SideTestUpDown
max :: SideTestUpDown -> SideTestUpDown -> SideTestUpDown
$cmax :: SideTestUpDown -> SideTestUpDown -> SideTestUpDown
>= :: SideTestUpDown -> SideTestUpDown -> Bool
$c>= :: SideTestUpDown -> SideTestUpDown -> Bool
> :: SideTestUpDown -> SideTestUpDown -> Bool
$c> :: SideTestUpDown -> SideTestUpDown -> Bool
<= :: SideTestUpDown -> SideTestUpDown -> Bool
$c<= :: SideTestUpDown -> SideTestUpDown -> Bool
< :: SideTestUpDown -> SideTestUpDown -> Bool
$c< :: SideTestUpDown -> SideTestUpDown -> Bool
compare :: SideTestUpDown -> SideTestUpDown -> Ordering
$ccompare :: SideTestUpDown -> SideTestUpDown -> Ordering
$cp1Ord :: Eq SideTestUpDown
Ord)

class OnSideUpDownTest t where
  onSideUpDown :: (d ~ Dimension t, r ~ NumType t, Ord r, Num r)
               => Point d r -> t -> SideTestUpDown

instance OnSideUpDownTest (Line 2 r) where
  -- | Given a point q and a line l, compute to which side of l q lies. For
  -- vertical lines the left side of the line is interpeted as below.
  --
  -- >>> Point2 10 10 `onSideUpDown` (lineThrough origin $ Point2 10 5)
  -- Above
  -- >>> Point2 10 10 `onSideUpDown` (lineThrough origin $ Point2 (-10) 5)
  -- Above
  -- >>> Point2 5 5 `onSideUpDown` (verticalLine 10)
  -- Below
  -- >>> Point2 5 5 `onSideUpDown` (lineThrough origin $ Point2 (-3) (-3))
  -- On
  Point d r
q onSideUpDown :: Point d r -> Line 2 r -> SideTestUpDown
`onSideUpDown` (Line Point 2 r
p Vector 2 r
v) = let r :: Point 2 r
r    =  Point 2 r
p Point 2 r -> Diff (Point 2) r -> Point 2 r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ Diff (Point 2) r
Vector 2 r
v
                                    f :: point d b -> (b, b)
f point d b
z         = (point d b
zpoint d b -> Getting b (point d b) b -> b
forall s a. s -> Getting a s a -> a
^.Getting b (point d b) b
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord, -point d b
zpoint d b -> Getting b (point d b) b -> b
forall s a. s -> Getting a s a -> a
^.Getting b (point d b) b
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord)
                                    minBy :: (b -> a) -> b -> b -> b
minBy b -> a
g b
a b
b = (b -> b -> Ordering) -> [b] -> b
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
F.minimumBy ((b -> a) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing b -> a
g) [b
a,b
b]
                                    maxBy :: (b -> a) -> b -> b -> b
maxBy b -> a
g b
a b
b = (b -> b -> Ordering) -> [b] -> b
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
F.maximumBy ((b -> a) -> b -> b -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing b -> a
g) [b
a,b
b]
                                in case Point 2 r -> Point 2 r -> Point 2 r -> CCW
forall r.
(Ord r, Num r) =>
Point 2 r -> Point 2 r -> Point 2 r -> CCW
ccw ((Point 2 r -> (r, r)) -> Point 2 r -> Point 2 r -> Point 2 r
forall a b. Ord a => (b -> a) -> b -> b -> b
minBy Point 2 r -> (r, r)
forall (d :: Nat) (point :: Nat -> * -> *) b.
(ImplicitPeano (Peano d), ArityPeano (Peano (FromPeano (Peano d))),
 KnownNat (FromPeano (Peano d)), KnownNat d, AsAPoint point, Num b,
 (2 <=? d) ~ 'True, (1 <=? d) ~ 'True,
 Peano (FromPeano (Peano d) + 1)
 ~ 'S (Peano (FromPeano (Peano d)))) =>
point d b -> (b, b)
f Point 2 r
p Point 2 r
r) ((Point 2 r -> (r, r)) -> Point 2 r -> Point 2 r -> Point 2 r
forall a b. Ord a => (b -> a) -> b -> b -> b
maxBy Point 2 r -> (r, r)
forall (d :: Nat) (point :: Nat -> * -> *) b.
(ImplicitPeano (Peano d), ArityPeano (Peano (FromPeano (Peano d))),
 KnownNat (FromPeano (Peano d)), KnownNat d, AsAPoint point, Num b,
 (2 <=? d) ~ 'True, (1 <=? d) ~ 'True,
 Peano (FromPeano (Peano d) + 1)
 ~ 'S (Peano (FromPeano (Peano d)))) =>
point d b -> (b, b)
f Point 2 r
p Point 2 r
r) Point d r
Point 2 r
q of
                                     CCW
CCW      -> SideTestUpDown
Above
                                     CCW
CW       -> SideTestUpDown
Below
                                     CCW
CoLinear -> SideTestUpDown
On

-- | Result of a side test
data SideTest = LeftSide | OnLine | RightSide deriving (Int -> SideTest -> ShowS
[SideTest] -> ShowS
SideTest -> String
(Int -> SideTest -> ShowS)
-> (SideTest -> String) -> ([SideTest] -> ShowS) -> Show SideTest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SideTest] -> ShowS
$cshowList :: [SideTest] -> ShowS
show :: SideTest -> String
$cshow :: SideTest -> String
showsPrec :: Int -> SideTest -> ShowS
$cshowsPrec :: Int -> SideTest -> ShowS
Show,ReadPrec [SideTest]
ReadPrec SideTest
Int -> ReadS SideTest
ReadS [SideTest]
(Int -> ReadS SideTest)
-> ReadS [SideTest]
-> ReadPrec SideTest
-> ReadPrec [SideTest]
-> Read SideTest
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SideTest]
$creadListPrec :: ReadPrec [SideTest]
readPrec :: ReadPrec SideTest
$creadPrec :: ReadPrec SideTest
readList :: ReadS [SideTest]
$creadList :: ReadS [SideTest]
readsPrec :: Int -> ReadS SideTest
$creadsPrec :: Int -> ReadS SideTest
Read,SideTest -> SideTest -> Bool
(SideTest -> SideTest -> Bool)
-> (SideTest -> SideTest -> Bool) -> Eq SideTest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SideTest -> SideTest -> Bool
$c/= :: SideTest -> SideTest -> Bool
== :: SideTest -> SideTest -> Bool
$c== :: SideTest -> SideTest -> Bool
Eq,Eq SideTest
Eq SideTest
-> (SideTest -> SideTest -> Ordering)
-> (SideTest -> SideTest -> Bool)
-> (SideTest -> SideTest -> Bool)
-> (SideTest -> SideTest -> Bool)
-> (SideTest -> SideTest -> Bool)
-> (SideTest -> SideTest -> SideTest)
-> (SideTest -> SideTest -> SideTest)
-> Ord SideTest
SideTest -> SideTest -> Bool
SideTest -> SideTest -> Ordering
SideTest -> SideTest -> SideTest
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SideTest -> SideTest -> SideTest
$cmin :: SideTest -> SideTest -> SideTest
max :: SideTest -> SideTest -> SideTest
$cmax :: SideTest -> SideTest -> SideTest
>= :: SideTest -> SideTest -> Bool
$c>= :: SideTest -> SideTest -> Bool
> :: SideTest -> SideTest -> Bool
$c> :: SideTest -> SideTest -> Bool
<= :: SideTest -> SideTest -> Bool
$c<= :: SideTest -> SideTest -> Bool
< :: SideTest -> SideTest -> Bool
$c< :: SideTest -> SideTest -> Bool
compare :: SideTest -> SideTest -> Ordering
$ccompare :: SideTest -> SideTest -> Ordering
$cp1Ord :: Eq SideTest
Ord)

-- | Given a point q and a line l, compute to which side of l q lies. For
-- vertical lines the left side of the line is interpeted as below.
--
-- >>> Point2 10 10 `onSide` (lineThrough origin $ Point2 10 5)
-- LeftSide
-- >>> Point2 10 10 `onSide` (lineThrough origin $ Point2 (-10) 5)
-- RightSide
-- >>> Point2 5 5 `onSide` (verticalLine 10)
-- LeftSide
-- >>> Point2 5 5 `onSide` (lineThrough origin $ Point2 (-3) (-3))
-- OnLine
onSide                :: (Ord r, Num r) => Point 2 r -> Line 2 r -> SideTest
Point 2 r
q onSide :: Point 2 r -> Line 2 r -> SideTest
`onSide` (Line Point 2 r
p Vector 2 r
v) = let r :: Point 2 r
r    =  Point 2 r
p Point 2 r -> Diff (Point 2) r -> Point 2 r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ Diff (Point 2) r
Vector 2 r
v
                            -- f z         = (z^.xCoord, -z^.yCoord)
                            -- minBy g a b = F.minimumBy (comparing g) [a,b]
                            -- maxBy g a b = F.maximumBy (comparing g) [a,b]
                        in case Point 2 r -> Point 2 r -> Point 2 r -> CCW
forall r.
(Ord r, Num r) =>
Point 2 r -> Point 2 r -> Point 2 r -> CCW
ccw Point 2 r
p Point 2 r
r Point 2 r
q of
                          CCW
CCW      -> SideTest
LeftSide
                          CCW
CW       -> SideTest
RightSide
                          CCW
CoLinear -> SideTest
OnLine

-- | Test if the query point q lies (strictly) above line l
liesAbove       :: (Ord r, Num r) => Point 2 r -> Line 2 r -> Bool
Point 2 r
q liesAbove :: Point 2 r -> Line 2 r -> Bool
`liesAbove` Line 2 r
l = Point 2 r
q Point 2 r -> Line 2 r -> SideTestUpDown
forall t (d :: Nat) r.
(OnSideUpDownTest t, d ~ Dimension t, r ~ NumType t, Ord r,
 Num r) =>
Point d r -> t -> SideTestUpDown
`onSideUpDown` Line 2 r
l SideTestUpDown -> SideTestUpDown -> Bool
forall a. Eq a => a -> a -> Bool
== SideTestUpDown
Above

-- | Test if the query point q lies (strictly) above line l
liesBelow      :: (Ord r, Num r) => Point 2 r -> Line 2 r -> Bool
Point 2 r
q liesBelow :: Point 2 r -> Line 2 r -> Bool
`liesBelow` Line 2 r
l = Point 2 r
q Point 2 r -> Line 2 r -> SideTestUpDown
forall t (d :: Nat) r.
(OnSideUpDownTest t, d ~ Dimension t, r ~ NumType t, Ord r,
 Num r) =>
Point d r -> t -> SideTestUpDown
`onSideUpDown` Line 2 r
l SideTestUpDown -> SideTestUpDown -> Bool
forall a. Eq a => a -> a -> Bool
== SideTestUpDown
Below

-- | Get the bisector between two points
bisector     :: Fractional r => Point 2 r -> Point 2 r -> Line 2 r
bisector :: Point 2 r -> Point 2 r -> Line 2 r
bisector Point 2 r
p Point 2 r
q = let v :: Diff (Point 2) r
v = Point 2 r
q Point 2 r -> Point 2 r -> Diff (Point 2) r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point 2 r
p
                   h :: Point 2 r
h = Point 2 r
p Point 2 r -> Diff (Point 2) r -> Point 2 r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (Diff (Point 2) r
Vector 2 r
v Vector 2 r -> r -> Vector 2 r
forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ r
2)
               in Line 2 r -> Line 2 r
forall r. Num r => Line 2 r -> Line 2 r
perpendicularTo (Point 2 r -> Vector 2 r -> Line 2 r
forall (d :: Nat) r. Point d r -> Vector d r -> Line d r
Line Point 2 r
h Diff (Point 2) r
Vector 2 r
v)


-- | Compares the lines on slope. Vertical lines are considered larger than
-- anything else.
--
-- >>> (Line origin (Vector2 5 1)) `cmpSlope` (Line origin (Vector2 3 3))
-- LT
-- >>> (Line origin (Vector2 5 1)) `cmpSlope` (Line origin (Vector2 (-3) 3))
-- GT
-- >>> (Line origin (Vector2 5 1)) `cmpSlope` (Line origin (Vector2 0 1))
-- LT
cmpSlope :: (Num r, Ord r) => Line 2 r -> Line 2 r -> Ordering
(Line Point 2 r
_ Vector 2 r
u) cmpSlope :: Line 2 r -> Line 2 r -> Ordering
`cmpSlope` (Line Point 2 r
_ Vector 2 r
v) = case Point 2 r -> Point 2 r -> Point 2 r -> CCW
forall r.
(Ord r, Num r) =>
Point 2 r -> Point 2 r -> Point 2 r -> CCW
ccw Point 2 r
forall (d :: Nat) r. (Arity d, Num r) => Point d r
origin (Vector 2 r -> Point 2 r
forall a. (Ord a, Num a) => Vector 2 a -> Point 2 a
f Vector 2 r
u) (Vector 2 r -> Point 2 r
forall a. (Ord a, Num a) => Vector 2 a -> Point 2 a
f Vector 2 r
v) of
                                     CCW
CCW      -> Ordering
LT
                                     CCW
CW       -> Ordering
GT
                                     CCW
CoLinear -> Ordering
EQ
  where
    f :: Vector 2 a -> Point 2 a
f w :: Vector 2 a
w@(Vector2 a
x a
y) = Vector 2 a -> Point 2 a
forall (d :: Nat) r. Vector d r -> Point d r
Point (Vector 2 a -> Point 2 a) -> Vector 2 a -> Point 2 a
forall a b. (a -> b) -> a -> b
$ case (a
x a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
0, a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0) of
                                  (Ordering
GT,Bool
_)    -> Vector 2 a
w
                                  (Ordering
EQ,Bool
True) -> Vector 2 a
w
                                  (Ordering, Bool)
_         -> (-a
1) a -> Vector 2 a -> Vector 2 a
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ Vector 2 a
w
                                  -- x < 0, or (x==0 and y <0 ; i.e. a vertical line)