{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Ball.CenterAndRadius
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Balls in d-dimensional space, represented by their center and squared radius.
--
--------------------------------------------------------------------------------
module HGeometry.Ball.CenterAndRadius
  ( Ball(Ball,Disk)
  , squaredRadius'
  , Disk


  , Sphere(Sphere,Circle,MkSphere)
  , Circle

  , _BallSphere
  , _DiskCircle

  , fromDiametralPair, fromCenterAndPoint
  , fromBoundaryPoints

  , IntersectionOf(..)
  ) where

import Control.Lens
import HGeometry.Ball.BoundaryPoints
import HGeometry.Boundary
import HGeometry.Ball.Class
import HGeometry.Ball.Diametral
import HGeometry.Ext
import HGeometry.HalfLine
import HGeometry.HyperPlane
import HGeometry.Intersection
import HGeometry.Line.PointAndVector
import HGeometry.LineSegment
import HGeometry.Number.Radical
import HGeometry.Point
import HGeometry.Properties (NumType, Dimension)
import HGeometry.Vector
import Prelude hiding (sqrt)

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

-- | d-dimensional ball, specified by center and squared radius.
data Ball point = Ball !point !(NumType point)

deriving stock instance (Show point, Show (NumType point)) => Show (Ball point)
deriving stock instance (Eq point, Eq (NumType point)) => Eq (Ball point)

type instance NumType   (Ball point) = NumType point
type instance Dimension (Ball point) = Dimension point

instance HasCenter (Ball point) point where
  center :: Lens' (Ball point) point
center = (Ball point -> point)
-> (Ball point -> point -> Ball point) -> Lens' (Ball point) point
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(Ball point
c NumType point
_) -> point
c) (\(Ball point
_ NumType point
r) point
c -> point -> NumType point -> Ball point
forall point. point -> NumType point -> Ball point
Ball point
c NumType point
r)

instance Point_ point (Dimension point) (NumType point) => Ball_ (Ball point) point where
  squaredRadius :: Getter (Ball point) (NumType (Ball point))
squaredRadius = (NumType point -> f (NumType point))
-> Ball point -> f (Ball point)
(NumType (Ball point) -> f (NumType (Ball point)))
-> Ball point -> f (Ball point)
forall point (f :: * -> *).
Functor f =>
(NumType point -> f (NumType point))
-> Ball point -> f (Ball point)
squaredRadius'

-- | Lens to access the squared radius of a ball
squaredRadius' :: Lens' (Ball point) (NumType point)
squaredRadius' :: forall point (f :: * -> *).
Functor f =>
(NumType point -> f (NumType point))
-> Ball point -> f (Ball point)
squaredRadius' = (Ball point -> NumType point)
-> (Ball point -> NumType point -> Ball point)
-> Lens (Ball point) (Ball point) (NumType point) (NumType point)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(Ball point
_ NumType point
r) -> NumType point
r) (\(Ball point
c NumType point
_) NumType point
r -> point -> NumType point -> Ball point
forall point. point -> NumType point -> Ball point
Ball point
c NumType point
r)


instance Point_ point (Dimension point) (NumType point)
         => ConstructableBall_ (Ball point) point where
  fromCenterAndSquaredRadius :: point -> NumType (Ball point) -> Ball point
fromCenterAndSquaredRadius = point -> NumType point -> Ball point
point -> NumType (Ball point) -> Ball point
forall point. point -> NumType point -> Ball point
Ball

--------------------------------------------------------------------------------
-- * Point in ball

instance ( Point_ point d r, Ord r, Num r, Has_ Metric_ d r
         ) => HasInBall (Ball point) where
  inBall :: forall point (d :: Nat) r.
(Point_ point d r, Ord r, Num r, NumType (Ball point) ~ r,
 Dimension (Ball point) ~ d) =>
point -> Ball point -> PointLocationResult
inBall point
q (Ball point
c NumType point
r) = case Point d r -> Point d r -> r
forall r point (d :: Nat) point'.
(Num r, Point_ point d r, Point_ point' d r,
 Metric_ (Vector d r) d r) =>
point -> point' -> r
squaredEuclideanDist (point
qpoint -> Getting (Point d r) point (Point d r) -> Point d r
forall s a. s -> Getting a s a -> a
^.Getting (Point d r) point (Point d r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point d r)
asPoint) (point
cpoint -> Getting (Point d r) point (Point d r) -> Point d r
forall s a. s -> Getting a s a -> a
^.Getting (Point d r) point (Point d r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point d r)
asPoint) r -> r -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` r
NumType point
r of
    Ordering
LT -> PointLocationResult
Inside
    Ordering
EQ -> PointLocationResult
OnBoundary
    Ordering
GT -> PointLocationResult
Outside

type instance Intersection (Point d r) (Ball point) = Maybe (Point d r)

instance ( Point_ point d r, Ord r, Num r, Has_ Metric_ d r
         ) => (Point d r) `HasIntersectionWith` (Ball point) where
  intersects :: Point d r -> Ball point -> Bool
intersects Point d r
q Ball point
b = Point d r
q Point d r -> Ball point -> PointLocationResult
forall ball point (d :: Nat) r.
(HasInBall ball, Point_ point d r, Ord r, Num r, NumType ball ~ r,
 Dimension ball ~ d) =>
point -> ball -> PointLocationResult
forall point (d :: Nat) r.
(Point_ point d r, Ord r, Num r, NumType (Ball point) ~ r,
 Dimension (Ball point) ~ d) =>
point -> Ball point -> PointLocationResult
`inBall` Ball point
b PointLocationResult -> PointLocationResult -> Bool
forall a. Eq a => a -> a -> Bool
/= PointLocationResult
Outside

instance ( Point_ point d r
         , Ord r, Num r
         , Has_ Metric_ d r
         ) => (Point d r) `IsIntersectableWith` (Ball point) where
  intersect :: Point d r -> Ball point -> Intersection (Point d r) (Ball point)
intersect Point d r
q Ball point
b | Point d r
q Point d r -> Ball point -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
`intersects` Ball point
b = Point d r -> Maybe (Point d r)
forall a. a -> Maybe a
Just Point d r
q
                | Bool
otherwise        = Maybe (Point d r)
Intersection (Point d r) (Ball point)
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
-- * Testing if a line/ ray /linesegment intersects a ball

-- essentially this is all just computing  the squared euclidean distance
-- between the object and the center, and testing if it is at most r

instance ( Point_ point d r
         , Ord r, Fractional r
         , Has_ Metric_ d r
         ) => (LinePV d r) `HasIntersectionWith` (Ball point) where
  intersects :: LinePV d r -> Ball point -> Bool
intersects LinePV d r
l (Ball point
c NumType point
r) = point -> LinePV d r -> r
forall g r (d :: Nat) point.
(HasSquaredEuclideanDistance g, r ~ NumType g, d ~ Dimension g,
 Num r, Point_ point d r) =>
point -> g -> r
forall r (d :: Nat) point.
(r ~ NumType (LinePV d r), d ~ Dimension (LinePV d r), Num r,
 Point_ point d r) =>
point -> LinePV d r -> r
squaredEuclideanDistTo point
c LinePV d r
l r -> r -> Bool
forall a. Ord a => a -> a -> Bool
<= r
NumType point
r

instance ( Point_ point d r, Point_ point' d r
         , Ord r, Fractional r
         , Has_ Metric_ d r
         , HasSquaredEuclideanDistance point'
         , MkHyperPlaneConstraints d r
         ) => (ClosedLineSegment point') `HasIntersectionWith` (Ball point) where
  intersects :: ClosedLineSegment point' -> Ball point -> Bool
intersects ClosedLineSegment point'
s (Ball point
c NumType point
r) = point -> ClosedLineSegment point' -> r
forall g r (d :: Nat) point.
(HasSquaredEuclideanDistance g, r ~ NumType g, d ~ Dimension g,
 Num r, Point_ point d r) =>
point -> g -> r
forall r (d :: Nat) point.
(r ~ NumType (ClosedLineSegment point'),
 d ~ Dimension (ClosedLineSegment point'), Num r,
 Point_ point d r) =>
point -> ClosedLineSegment point' -> r
squaredEuclideanDistTo point
c ClosedLineSegment point'
s r -> r -> Bool
forall a. Ord a => a -> a -> Bool
<= r
NumType point
r

instance ( Point_ point d r, Point_ point' d r
         , Ord r, Fractional r
         , Has_ Metric_ d r
         , HasSquaredEuclideanDistance point'
         , MkHyperPlaneConstraints d r
         ) => (HalfLine point') `HasIntersectionWith` (Ball point) where
  intersects :: HalfLine point' -> Ball point -> Bool
intersects HalfLine point'
hl (Ball point
c NumType point
r) = point -> HalfLine point' -> r
forall g r (d :: Nat) point.
(HasSquaredEuclideanDistance g, r ~ NumType g, d ~ Dimension g,
 Num r, Point_ point d r) =>
point -> g -> r
forall r (d :: Nat) point.
(r ~ NumType (HalfLine point'), d ~ Dimension (HalfLine point'),
 Num r, Point_ point d r) =>
point -> HalfLine point' -> r
squaredEuclideanDistTo point
c HalfLine point'
hl r -> r -> Bool
forall a. Ord a => a -> a -> Bool
<= r
NumType point
r

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

type instance Intersection (LinePV d r) (Ball point) =
  Maybe (IntersectionOf (LinePV d r) (Ball point))

-- | The extra value is the parameter t, so that the intersection point
-- is line^.anchroPoint + t*line^.direction
data instance IntersectionOf (LinePV d r) (Ball point) =
    Line_x_Ball_Point   (Point d r :+ r)
  | Line_x_Ball_Segment (ClosedLineSegment (Point d r :+ r))
    -- ^ The line segement is oriented from the point closest to the anchor towards
    -- the point further away

deriving instance (Show r, Has_ Additive_ d r) => Show (IntersectionOf (LinePV d r) (Ball point))
deriving instance (Eq r, Eq (Vector d r))      => Eq   (IntersectionOf (LinePV d r) (Ball point))


instance ( Point_ point d r
         , Ord r, Fractional r, Radical r
         , Has_ Metric_ d r
         ) => (LinePV d r) `IsIntersectableWith` (Ball point) where
  intersect :: LinePV d r -> Ball point -> Intersection (LinePV d r) (Ball point)
intersect (LinePV Point d r
p Vector d r
v) (Ball point
c' NumType point
r) = case r
discr r -> r -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` r
0 of
      Ordering
LT -> Maybe (IntersectionOf (LinePV d r) (Ball point))
Intersection (LinePV d r) (Ball point)
forall a. Maybe a
Nothing
      Ordering
EQ -> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a. a -> Maybe a
Just (IntersectionOf (LinePV d r) (Ball point)
 -> Maybe (IntersectionOf (LinePV d r) (Ball point)))
-> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a b. (a -> b) -> a -> b
$ (Point d r :+ r) -> IntersectionOf (LinePV d r) (Ball point)
forall (d :: Nat) r point.
(Point d r :+ r) -> IntersectionOf (LinePV d r) (Ball point)
Line_x_Ball_Point Point d r :+ r
q0 -- line touches in q
      Ordering
GT -> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a. a -> Maybe a
Just (IntersectionOf (LinePV d r) (Ball point)
 -> Maybe (IntersectionOf (LinePV d r) (Ball point)))
-> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a b. (a -> b) -> a -> b
$ ClosedLineSegment (Point d r :+ r)
-> IntersectionOf (LinePV d r) (Ball point)
forall (d :: Nat) r point.
ClosedLineSegment (Point d r :+ r)
-> IntersectionOf (LinePV d r) (Ball point)
Line_x_Ball_Segment ((Point d r :+ r)
-> (Point d r :+ r) -> ClosedLineSegment (Point d r :+ r)
forall point. point -> point -> ClosedLineSegment point
ClosedLineSegment Point d r :+ r
q1 Point d r :+ r
q2)
    where
      -- main idea: let q = p + \lambda v be an intersection point, we also have
      -- squaredEuclideanDist q c' == squaredRadius (=r) this yields some quadratic
      -- equation in \lambda, which we just solve using the ABC formula. In particular, we have
      --
      -- (sum_i=1^d (p+\lambda v_i - c'_i)^2 = r)
      -- (sum_i=1^d (\lambda v_i + (p_i- c'_i))^2  - r = 0 )
      -- (sum_i=1^d ((\lambda v_i)^2 + 2\lambda v_i(p_i- c'_i) + (p_i- c'_i)^2)  - r = 0 )
      -- (sum_i=1^d (v_i^2\lambda^2 + 2v_i(p_i- c'_i)\lambda  + (p_i- c'_i)^2)  - r = 0 )
      -- (lambda^2 sum_i=1^d v_i^2\ + \lambda sum_i=1^d 2v_i(p_i- c'_i)  + sum_i=1^d (p_i- c'_i)^2)  - r = 0 )


      a :: r
a = Vector d r
v Vector d r -> Vector d r -> r
forall vector (d :: Nat) r.
(Metric_ vector d r, Num r) =>
vector -> vector -> r
`dot` Vector d r
v -- sum_i v_i^2
      b :: r
b = r
2 r -> r -> r
forall a. Num a => a -> a -> a
* (Vector d r
v Vector d r -> Vector d r -> r
forall vector (d :: Nat) r.
(Metric_ vector d r, Num r) =>
vector -> vector -> r
`dot` Vector d r
u) -- sum_i v_i(p_i-c_i)
      c :: r
c = (Vector d r
u Vector d r -> Vector d r -> r
forall vector (d :: Nat) r.
(Metric_ vector d r, Num r) =>
vector -> vector -> r
`dot` Vector d r
u) r -> r -> r
forall a. Num a => a -> a -> a
- r
NumType point
r -- sum_i (p_i-c_i)^2  - radius^2

      u :: Vector d r
u = Point d r
p Point d r -> Point d r -> Vector d r
forall point (d :: Nat) r.
(Affine_ point d r, Num r) =>
point -> point -> Vector d r
.-. (point
c'point -> Getting (Point d r) point (Point d r) -> Point d r
forall s a. s -> Getting a s a -> a
^.Getting (Point d r) point (Point d r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point d r)
asPoint) -- helper

      discr :: r
discr  = r
br -> Integer -> r
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2 r -> r -> r
forall a. Num a => a -> a -> a
- r
4r -> r -> r
forall a. Num a => a -> a -> a
*r
ar -> r -> r
forall a. Num a => a -> a -> a
*r
c
      discr' :: r
discr' = r -> r
forall r. Radical r => r -> r
sqrt r
discr
      da :: r
da = r
2r -> r -> r
forall a. Num a => a -> a -> a
*r
a

      lambda1' :: r
lambda1' = ((r -> r
forall a. Num a => a -> a
negate r
discr') r -> r -> r
forall a. Num a => a -> a -> a
- r
b) r -> r -> r
forall a. Fractional a => a -> a -> a
/ r
da -- the two solutions
      lambda2' :: r
lambda2' = (r
discr'          r -> r -> r
forall a. Num a => a -> a -> a
- r
b) r -> r -> r
forall a. Fractional a => a -> a -> a
/ r
da --
      -- note: v must have non-zero length; and thus a (and therefore da) are non-zero.
      -- note2: if discr is nonzero then lambda1' and laambda2' are distinct

      -- make sure lambda1 is the smaller one. (since they are distinct we can use <
      -- rather than <=).
      (r
lambda1,r
lambda2) = if r
lambda1' r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< r
lambda2' then (r
lambda1',r
lambda2')
                                                 else (r
lambda2',r
lambda1')

      q1 :: Point d r :+ r
q1 = Point d r
p Point d r -> Vector d r -> Point d r
forall point (d :: Nat) r.
(Affine_ point d r, Num r) =>
point -> Vector d r -> point
.+^ (r
lambda1 r -> Vector d r -> Vector d r
forall r vector (d :: Nat).
(Num r, Vector_ vector d r) =>
r -> vector -> vector
*^ Vector d r
v) Point d r -> r -> Point d r :+ r
forall core extra. core -> extra -> core :+ extra
:+ r
lambda1
      q2 :: Point d r :+ r
q2 = Point d r
p Point d r -> Vector d r -> Point d r
forall point (d :: Nat) r.
(Affine_ point d r, Num r) =>
point -> Vector d r -> point
.+^ (r
lambda2 r -> Vector d r -> Vector d r
forall r vector (d :: Nat).
(Num r, Vector_ vector d r) =>
r -> vector -> vector
*^ Vector d r
v) Point d r -> r -> Point d r :+ r
forall core extra. core -> extra -> core :+ extra
:+ r
lambda2

      -- if the discr is zero there is only one solution:
      lambda0 :: r
lambda0 = (r -> r
forall a. Num a => a -> a
negate r
b) r -> r -> r
forall a. Fractional a => a -> a -> a
/ r
da
      q0 :: Point d r :+ r
q0 = Point d r
p Point d r -> Vector d r -> Point d r
forall point (d :: Nat) r.
(Affine_ point d r, Num r) =>
point -> Vector d r -> point
.+^ (r
lambda0 r -> Vector d r -> Vector d r
forall r vector (d :: Nat).
(Num r, Vector_ vector d r) =>
r -> vector -> vector
*^ Vector d r
v) Point d r -> r -> Point d r :+ r
forall core extra. core -> extra -> core :+ extra
:+ r
lambda0

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

type instance Intersection (HalfLine point') (Ball point) =
  Maybe (IntersectionOf (LinePV (Dimension point) (NumType point)) (Ball point))

instance ( Point_ point d r, Point_ point' d r
         , Ord r, Fractional r, Radical r
         , Has_ Metric_ d r
         , MkHyperPlaneConstraints d r
         , HasSquaredEuclideanDistance point'
         ) => (HalfLine point') `IsIntersectableWith` (Ball point) where
  intersect :: HalfLine point'
-> Ball point -> Intersection (HalfLine point') (Ball point)
intersect (HalfLine point'
p Vector (Dimension point') (NumType point')
v) Ball point
b = LinePV d r -> Ball point -> Intersection (LinePV d r) (Ball point)
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
intersect (Point d r -> Vector d r -> LinePV d r
forall (d :: Nat) r. Point d r -> Vector d r -> LinePV d r
LinePV Point d r
p' Vector d r
Vector (Dimension point') (NumType point')
v) Ball point
b Maybe (IntersectionOf (LinePV d r) (Ball point))
-> (IntersectionOf (LinePV d r) (Ball point)
    -> Maybe (IntersectionOf (LinePV d r) (Ball point)))
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Line_x_Ball_Point Point d r :+ r
q
        | Point d r :+ r
q(Point d r :+ r) -> Getting r (Point d r :+ r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point d r :+ r) r
forall core extra extra' (f :: * -> *).
Functor f =>
(extra -> f extra') -> (core :+ extra) -> f (core :+ extra')
extra r -> r -> Bool
forall a. Ord a => a -> a -> Bool
>= r
0 -> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a. a -> Maybe a
Just (IntersectionOf (LinePV d r) (Ball point)
 -> Maybe (IntersectionOf (LinePV d r) (Ball point)))
-> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a b. (a -> b) -> a -> b
$ (Point d r :+ r) -> IntersectionOf (LinePV d r) (Ball point)
forall (d :: Nat) r point.
(Point d r :+ r) -> IntersectionOf (LinePV d r) (Ball point)
Line_x_Ball_Point Point d r :+ r
q
        | Bool
otherwise     -> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a. Maybe a
Nothing
      Line_x_Ball_Segment seg :: ClosedLineSegment (Point d r :+ r)
seg@(ClosedLineSegment Point d r :+ r
s Point d r :+ r
t) -> case r
0 r -> r -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (Point d r :+ r
t(Point d r :+ r) -> Getting r (Point d r :+ r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point d r :+ r) r
forall core extra extra' (f :: * -> *).
Functor f =>
(extra -> f extra') -> (core :+ extra) -> f (core :+ extra')
extra) of
        Ordering
GT -> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a. Maybe a
Nothing -- The oriented line intersects the ball before the ray starts
        Ordering
EQ -> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a. a -> Maybe a
Just (IntersectionOf (LinePV d r) (Ball point)
 -> Maybe (IntersectionOf (LinePV d r) (Ball point)))
-> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a b. (a -> b) -> a -> b
$ (Point d r :+ r) -> IntersectionOf (LinePV d r) (Ball point)
forall (d :: Nat) r point.
(Point d r :+ r) -> IntersectionOf (LinePV d r) (Ball point)
Line_x_Ball_Point Point d r :+ r
t
                             -- we only intersect at the start of the ray
        Ordering
LT | Point d r :+ r
s(Point d r :+ r) -> Getting r (Point d r :+ r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point d r :+ r) r
forall core extra extra' (f :: * -> *).
Functor f =>
(extra -> f extra') -> (core :+ extra) -> f (core :+ extra')
extra r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< r
0 -> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a. a -> Maybe a
Just (IntersectionOf (LinePV d r) (Ball point)
 -> Maybe (IntersectionOf (LinePV d r) (Ball point)))
-> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a b. (a -> b) -> a -> b
$ ClosedLineSegment (Point d r :+ r)
-> IntersectionOf (LinePV d r) (Ball point)
forall (d :: Nat) r point.
ClosedLineSegment (Point d r :+ r)
-> IntersectionOf (LinePV d r) (Ball point)
Line_x_Ball_Segment ((Point d r :+ r)
-> (Point d r :+ r) -> ClosedLineSegment (Point d r :+ r)
forall point. point -> point -> ClosedLineSegment point
ClosedLineSegment (Point d r
p' Point d r -> r -> Point d r :+ r
forall core extra. core -> extra -> core :+ extra
:+ r
0) Point d r :+ r
t)
           | Bool
otherwise    -> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a. a -> Maybe a
Just (IntersectionOf (LinePV d r) (Ball point)
 -> Maybe (IntersectionOf (LinePV d r) (Ball point)))
-> IntersectionOf (LinePV d r) (Ball point)
-> Maybe (IntersectionOf (LinePV d r) (Ball point))
forall a b. (a -> b) -> a -> b
$ ClosedLineSegment (Point d r :+ r)
-> IntersectionOf (LinePV d r) (Ball point)
forall (d :: Nat) r point.
ClosedLineSegment (Point d r :+ r)
-> IntersectionOf (LinePV d r) (Ball point)
Line_x_Ball_Segment ClosedLineSegment (Point d r :+ r)
seg
    where
      p' :: Point d r
p'  = point'
ppoint' -> Getting (Point d r) point' (Point d r) -> Point d r
forall s a. s -> Getting a s a -> a
^.Getting (Point d r) point' (Point d r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point' (Point d r)
asPoint

    --       -> _


    --     -> case (0 <= s^.extra, 0 <= t^.extra) of
    --     (False,False) -> Nothing
    --     ()

    --     case (a `intersects` h, c `intersects` h) of
    --       (False,False) -> Nothing
    --       (False,True)  -> Just $ Line_x_Ball_Segment (ClosedLineSegment p'' c)
    --       (True,False)  -> Just $ Line_x_Ball_Segment (ClosedLineSegment a  p'')
    --       (True,True)   -> Just $ Line_x_Ball_Segment seg
    -- where
    --   h :: HalfSpace d r
    --   h   = HalfSpace Positive (fromPointAndNormal p' v)
      -- p'' = p' :+ 0

type instance Intersection (ClosedLineSegment point') (Ball point) =
  Maybe (IntersectionOf (LinePV (Dimension point) (NumType point)) (Ball point))

-- data instance IntersectionOf (ClosedLineSegment point) (Ball point) =
--     LineSegment_x_Ball_Point   point
--   | LineSegment_x_Ball_Segment (ClosedLineSegment point)

-- deriving instance (Show point, Show (ClosedLineSegment point))
--                => Show (IntersectionOf (ClosedLineSegment point) (Ball point))
-- deriving instance (Eq point, Eq (ClosedLineSegment point))
--                => Eq (IntersectionOf (ClosedLineSegment point) (Ball point))










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



instance Point_ point 2 (NumType point) => Disk_ (Ball point) point where

-- | Balls in 2D are also known as Disks
type Disk = Ball

-- | Construct a disk
pattern Disk     :: point -> NumType point -> Disk point
pattern $bDisk :: forall point. point -> NumType point -> Ball point
$mDisk :: forall {r} {point}.
Disk point -> (point -> NumType point -> r) -> ((# #) -> r) -> r
Disk c r = Ball c r
{-# COMPLETE Disk #-}

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

-- | A sphere, i.e. the boudary of a Ball.
newtype Sphere point = MkSphere (Ball point)

-- | Construct a Sphere; the boundary of a ball
pattern Sphere     :: point -> NumType point -> Sphere point
pattern $bSphere :: forall point. point -> NumType point -> Sphere point
$mSphere :: forall {r} {point}.
Sphere point -> (point -> NumType point -> r) -> ((# #) -> r) -> r
Sphere c r = MkSphere (Ball c r)
{-# COMPLETE Sphere #-}

-- | A circle, i.e. the boundary of a Disk
type Circle = Sphere

-- | Construct a Circle
pattern Circle     :: point -> NumType point -> Circle point
pattern $bCircle :: forall point. point -> NumType point -> Sphere point
$mCircle :: forall {r} {point}.
Sphere point -> (point -> NumType point -> r) -> ((# #) -> r) -> r
Circle c r = Sphere c r
{-# COMPLETE Circle #-}


deriving stock instance (Show point, Show (NumType point)) => Show (Sphere point)
deriving stock instance (Eq point, Eq (NumType point)) => Eq (Sphere point)

type instance NumType   (Sphere point) = NumType point
type instance Dimension (Sphere point) = Dimension point

instance HasCenter (Sphere point) point where
  center :: Lens' (Sphere point) point
center = (Sphere point -> point)
-> (Sphere point -> point -> Sphere point)
-> Lens' (Sphere point) point
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(Sphere point
c NumType point
_) -> point
c) (\(Sphere point
_ NumType point
r) point
c -> point -> NumType point -> Sphere point
forall point. point -> NumType point -> Sphere point
Sphere point
c NumType point
r)

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

-- | Iso to convert between a ball and a sphere.
_BallSphere :: Iso (Ball point) (Ball point') (Sphere point) (Sphere point')
_BallSphere :: forall point point' (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (Sphere point) (f (Sphere point'))
-> p (Ball point) (f (Ball point'))
_BallSphere = p (Sphere point) (f (Sphere point'))
-> p (Ball point) (f (Ball point'))
forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b
Iso (Ball point) (Ball point') (Sphere point) (Sphere point')
coerced
{-# INLINE _BallSphere #-}

-- | Iso to convert between a Disk and a Circle
_DiskCircle :: Iso (Disk point) (Disk point') (Circle point) (Circle point')
_DiskCircle :: forall point point' (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (Sphere point) (f (Sphere point'))
-> p (Ball point) (f (Ball point'))
_DiskCircle = p (Sphere point) (f (Sphere point'))
-> p (Ball point) (f (Ball point'))
forall point point' (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (Sphere point) (f (Sphere point'))
-> p (Ball point) (f (Ball point'))
_BallSphere
{-# INLINE _DiskCircle #-}

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

type instance Intersection (Point d r) (Sphere point) = Maybe (Point d r)

instance ( Point_ point d r
         , Eq r, Num r
         , Has_ Metric_ d r
         ) => (Point d r) `HasIntersectionWith` (Sphere point) where
  intersects :: Point d r -> Sphere point -> Bool
intersects Point d r
q (Sphere point
c NumType point
r) = Point d r -> Point d r -> r
forall r point (d :: Nat) point'.
(Num r, Point_ point d r, Point_ point' d r,
 Metric_ (Vector d r) d r) =>
point -> point' -> r
squaredEuclideanDist Point d r
q (point
cpoint -> Getting (Point d r) point (Point d r) -> Point d r
forall s a. s -> Getting a s a -> a
^.Getting (Point d r) point (Point d r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point d r)
asPoint) r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
NumType point
r

instance ( Point_ point d r
         , Eq r, Num r
         , Has_ Metric_ d r
         -- , OptVector_ d r, OptMetric_ d r
         ) => (Point d r) `IsIntersectableWith` (Sphere point) where
  intersect :: Point d r
-> Sphere point -> Intersection (Point d r) (Sphere point)
intersect Point d r
q Sphere point
b | Point d r
q Point d r -> Sphere point -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
`intersects` Sphere point
b = Point d r -> Maybe (Point d r)
forall a. a -> Maybe a
Just Point d r
q
                | Bool
otherwise        = Maybe (Point d r)
Intersection (Point d r) (Sphere point)
forall a. Maybe a
Nothing

instance ( Point_ point d r, Point_ point' d r
         , Ord r, Fractional r
         , Has_ Metric_ d r
         , HasSquaredEuclideanDistance point'
         ) => (ClosedLineSegment point') `HasIntersectionWith` (Sphere point) where
  intersects :: ClosedLineSegment point' -> Sphere point -> Bool
intersects ClosedLineSegment point'
s (Sphere point
c NumType point
r) = point -> ClosedLineSegment point' -> r
forall g r (d :: Nat) point.
(HasSquaredEuclideanDistance g, r ~ NumType g, d ~ Dimension g,
 Num r, Point_ point d r) =>
point -> g -> r
forall r (d :: Nat) point.
(r ~ NumType (ClosedLineSegment point'),
 d ~ Dimension (ClosedLineSegment point'), Num r,
 Point_ point d r) =>
point -> ClosedLineSegment point' -> r
squaredEuclideanDistTo point
c ClosedLineSegment point'
s r -> r -> Bool
forall a. Ord a => a -> a -> Bool
<= r
NumType point
r


-- | Given two points on the diameter of the ball, construct a ball.
fromDiametralPair     :: (Fractional r, Point_ point d r, Has_ Metric_ d r)
                      => point -> point -> Ball (Point d r)
fromDiametralPair :: forall r point (d :: Nat).
(Fractional r, Point_ point d r, Has_ Metric_ d r) =>
point -> point -> Ball (Point d r)
fromDiametralPair point
p point
q = let disk :: DiametralBall point
disk = point -> point -> DiametralBall point
forall point. point -> point -> DiametralBall point
DiametralPoints point
p point
q
                        in Point d r -> point -> Ball (Point d r)
forall r point (d :: Nat) center.
(Num r, Point_ point d r, Point_ center d r, Has_ Metric_ d r) =>
center -> point -> Ball center
fromCenterAndPoint (DiametralBall point
diskDiametralBall point
-> Getting (Point d r) (DiametralBall point) (Point d r)
-> Point d r
forall s a. s -> Getting a s a -> a
^.Getting (Point d r) (DiametralBall point) (Point d r)
forall geom point. HasCenter geom point => Lens' geom point
Lens' (DiametralBall point) (Point d r)
center) point
p

-- | Construct a ball given the center point and a point p on the boundary.
fromCenterAndPoint     :: ( Num r, Point_ point d r, Point_ center d r
                          , Has_ Metric_ d r
                          )
                       => center -> point -> Ball center
fromCenterAndPoint :: forall r point (d :: Nat) center.
(Num r, Point_ point d r, Point_ center d r, Has_ Metric_ d r) =>
center -> point -> Ball center
fromCenterAndPoint center
c point
p = center -> NumType (Ball center) -> Ball center
forall ball point.
ConstructableBall_ ball point =>
point -> NumType ball -> ball
fromCenterAndSquaredRadius center
c (center -> point -> r
forall r point (d :: Nat) point'.
(Num r, Point_ point d r, Point_ point' d r,
 Metric_ (Vector d r) d r) =>
point -> point' -> r
squaredEuclideanDist center
c point
p)

-- | Tries to create a disk from three points on the boundary.
fromBoundaryPoints                 :: ( Point_ point 2 r, Fractional r, Ord r)
                                   => Vector 3 point -> Maybe (Disk (Point 2 r))
fromBoundaryPoints :: forall point r.
(Point_ point 2 r, Fractional r, Ord r) =>
Vector 3 point -> Maybe (Disk (Point 2 r))
fromBoundaryPoints (Vector3 point
a point
b point
d) = point -> point -> point -> Maybe (BallByPoints point)
forall point r.
(Point_ point 2 r, Ord r, Num r) =>
point -> point -> point -> Maybe (BallByPoints point)
diskFromPoints point
a point
b point
d Maybe (BallByPoints' 3 point)
-> (BallByPoints' 3 point -> Disk (Point 2 r))
-> Maybe (Disk (Point 2 r))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
  BallByPoints' 3 point
disk -> let c :: Point 2 r
c = BallByPoints' 3 point
diskBallByPoints' 3 point
-> Getting (Point 2 r) (BallByPoints' 3 point) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (BallByPoints' 3 point) (Point 2 r)
forall geom point. HasCenter geom point => Lens' geom point
Lens' (BallByPoints' 3 point) (Point 2 r)
center
          in Point 2 r -> NumType (Point 2 r) -> Disk (Point 2 r)
forall point. point -> NumType point -> Ball point
Ball Point 2 r
c (Point 2 r -> point -> r
forall r point (d :: Nat) point'.
(Num r, Point_ point d r, Point_ point' d r,
 Metric_ (Vector d r) d r) =>
point -> point' -> r
squaredEuclideanDist Point 2 r
c point
a)