{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.HyperPlane.Internal
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Canonical implementation for Hyperplanes as a vector of coefficients.
--
--------------------------------------------------------------------------------
module HGeometry.HyperPlane.Internal
  ( HyperPlane(..,HyperPlane2, HyperPlane3)
  , MkHyperPlaneConstraints
  , cmpInDirection
  ) where

import           Control.Lens hiding (cons)
import qualified Data.Foldable as F
import           Data.Functor.Classes
import           Data.Type.Ord
import           GHC.TypeNats
import           HGeometry.HyperPlane.Class
import           HGeometry.Point.Class
import           HGeometry.Properties
import           HGeometry.Vector
import           Text.Read (Read (..), readListPrecDefault)

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

-- 2 dimensional hyperplane representing the line: 2 + 1*x + (-1)* y = 0,
-- in other words, the line y = 1*x + 2

-- $setup
-- >>> let myHyperPlane2 = HyperPlane $ Vector3 2 1 (-1)

-- | A Hyperplane h in d-dimensions, described by a vector of
-- coefficients (a_0,..,a_d).
--
-- a \point \( (p_1,..,p_d) \) lies on \(h) iff:
-- \( a_0  + \sum_i=1^d a_i*p_i = 0 \)
newtype HyperPlane d r = HyperPlane (Vector (d+1) r)

-- | Construct a Hyperplane, i.e. a line in R^2
--
-- HyperPlane2 c a b represents the line ax + by + c = 0
pattern HyperPlane2       :: r -> r -> r -> HyperPlane 2 r
pattern $bHyperPlane2 :: forall r. r -> r -> r -> HyperPlane 2 r
$mHyperPlane2 :: forall {r} {r}.
HyperPlane 2 r -> (r -> r -> r -> r) -> ((# #) -> r) -> r
HyperPlane2 c a b = HyperPlane (Vector3 c a b)
{-# COMPLETE HyperPlane2 #-}

-- | Construct a plane in R^3
--
-- HyperPlane3 d a b c represnest the plane ax + by + cz + d = 0
pattern HyperPlane3         :: r -> r -> r -> r -> HyperPlane 3 r
pattern $bHyperPlane3 :: forall r. r -> r -> r -> r -> HyperPlane 3 r
$mHyperPlane3 :: forall {r} {r}.
HyperPlane 3 r -> (r -> r -> r -> r -> r) -> ((# #) -> r) -> r
HyperPlane3 d a b c = HyperPlane (Vector4 d a b c)
{-# COMPLETE HyperPlane3 #-}

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


deriving newtype instance Eq (Vector (d+1) r) => Eq (HyperPlane d r)

instance (Show r, Foldable (Vector (d+1))) => Show (HyperPlane d r) where
  showsPrec :: Int -> HyperPlane d r -> ShowS
showsPrec Int
k (HyperPlane Vector (d + 1) r
v) = Bool -> ShowS -> ShowS
showParen (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
app_prec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
                               String -> ShowS
showString String
"HyperPlane " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               Int -> [r] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (Vector (d + 1) r -> [r]
forall a. Vector (d + 1) a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Vector (d + 1) r
v)
    where
      app_prec :: Int
app_prec = Int
10

instance ( Read r, Has_ Vector_ (d+1) r) => Read (HyperPlane d r) where
  readPrec :: ReadPrec (HyperPlane d r)
readPrec = ReadPrec (HyperPlane d r) -> ReadPrec (HyperPlane d r)
forall a. ReadPrec a -> ReadPrec a
readData (ReadPrec (HyperPlane d r) -> ReadPrec (HyperPlane d r))
-> ReadPrec (HyperPlane d r) -> ReadPrec (HyperPlane d r)
forall a b. (a -> b) -> a -> b
$ ReadPrec (Vector (d + 1) r)
-> String
-> (Vector (d + 1) r -> HyperPlane d r)
-> ReadPrec (HyperPlane d r)
forall a t. ReadPrec a -> String -> (a -> t) -> ReadPrec t
readUnaryWith ReadPrec (Vector (d + 1) r)
parseVec String
"HyperPlane" Vector (d + 1) r -> HyperPlane d r
forall (d :: Natural) r. Vector (d + 1) r -> HyperPlane d r
HyperPlane
    where
      parseVec :: ReadPrec (Vector (d + 1) r)
parseVec = do lst <- ReadPrec [r]
forall a. Read a => ReadPrec a
readPrec
                    case vectorFromList @(Vector (d+1) r) lst of
                      Just Vector (d + 1) r
v -> Vector (d + 1) r -> ReadPrec (Vector (d + 1) r)
forall a. a -> ReadPrec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vector (d + 1) r
v
                      Maybe (Vector (d + 1) r)
_      -> String -> ReadPrec (Vector (d + 1) r)
forall a. String -> ReadPrec a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"HyperPlane.read expected d+1 reals"
  readListPrec :: ReadPrec [HyperPlane d r]
readListPrec = ReadPrec [HyperPlane d r]
forall a. Read a => ReadPrec [a]
readListPrecDefault

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

-- | Constraints on d needed to be able to construct hyperplanes; pretty much all of
-- these are satisfied by default, it is just that the typechecker does not realize that.
type MkHyperPlaneConstraints d r =
  ( d < d+1, KnownNat d
  , Has_ Metric_ d r, Has_ Metric_ (d+1) r
  , Has_ Vector_ d r, Has_ Vector_ (d+1) r
  , Has_ Vector_ (1+d) r
  , d <= d+1
  )

instance ( MkHyperPlaneConstraints d r
         ) => HyperPlane_ (HyperPlane d r) d r where
  -- >>> hyperPlaneEquation myHyperPlane2
  -- Vector3 2 1 (-1)
  hyperPlaneEquation :: Num r => HyperPlane d r -> Vector (d + 1) r
hyperPlaneEquation (HyperPlane Vector (d + 1) r
v) = Vector (d + 1) r
v

instance ( MkHyperPlaneConstraints d r
         ) => ConstructableHyperPlane_ (HyperPlane d r) d r where
  hyperPlaneFromEquation :: HyperPlaneFromEquationConstraint (HyperPlane d r) d r =>
Vector (d + 1) r -> HyperPlane d r
hyperPlaneFromEquation = Vector (d + 1) r -> HyperPlane d r
forall (d :: Natural) r. Vector (d + 1) r -> HyperPlane d r
HyperPlane

instance ( Eq r
         ) => HyperPlaneFromPoints (HyperPlane 2 r) where
  --
  --
  hyperPlaneThrough :: forall point (d :: Natural) r.
(Point_ point d r, HyperPlane_ (HyperPlane 2 r) d r, Num r) =>
Vector d point -> HyperPlane 2 r
hyperPlaneThrough (Vector2 (Point2_ r
px r
py) (Point2_ r
qx r
qy))
    | r
px r -> r -> Bool
forall a. Eq a => a -> a -> Bool
/= r
qx  = let a :: r
a = r
qy r -> r -> r
forall a. Num a => a -> a -> a
- r
py
                      b :: r
b = r
px r -> r -> r
forall a. Num a => a -> a -> a
- r
qx
                      c :: r
c = (r
qxr -> r -> r
forall a. Num a => a -> a -> a
-r
px)r -> r -> r
forall a. Num a => a -> a -> a
*r
py r -> r -> r
forall a. Num a => a -> a -> a
- r
pxr -> r -> r
forall a. Num a => a -> a -> a
*(r
qyr -> r -> r
forall a. Num a => a -> a -> a
-r
py)
                  in Vector (2 + 1) r -> HyperPlane 2 r
forall (d :: Natural) r. Vector (d + 1) r -> HyperPlane d r
HyperPlane (Vector (2 + 1) r -> HyperPlane 2 r)
-> Vector (2 + 1) r -> HyperPlane 2 r
forall a b. (a -> b) -> a -> b
$ r -> r -> r -> Vector 3 r
forall r. r -> r -> r -> Vector 3 r
Vector3 r
c r
a r
b
    | Bool
otherwise = Vector (2 + 1) r -> HyperPlane 2 r
forall (d :: Natural) r. Vector (d + 1) r -> HyperPlane d r
HyperPlane (Vector (2 + 1) r -> HyperPlane 2 r)
-> Vector (2 + 1) r -> HyperPlane 2 r
forall a b. (a -> b) -> a -> b
$ r -> r -> r -> Vector 3 r
forall r. r -> r -> r -> Vector 3 r
Vector3 r
px (-r
1) r
0

instance (Num r) => HyperPlaneFromPoints (HyperPlane 3 r) where
  hyperPlaneThrough :: forall point (d :: Natural) r.
(Point_ point d r, HyperPlane_ (HyperPlane 3 r) d r, Num r) =>
Vector d point -> HyperPlane 3 r
hyperPlaneThrough (Vector3 point
p point
q point
r) = let u :: Vector 3 r
u = point
q point -> point -> Vector 3 r
forall point (d :: Natural) r.
(Affine_ point d r, Num r) =>
point -> point -> Vector d r
.-. point
p
                                          v :: Vector 3 r
v = point
r point -> point -> Vector 3 r
forall point (d :: Natural) r.
(Affine_ point d r, Num r) =>
point -> point -> Vector d r
.-. point
p
                                      in point -> Vector 3 r -> HyperPlane 3 r
forall point.
(Point_ point 3 r, Num r) =>
point -> Vector 3 r -> HyperPlane 3 r
forall hyperPlane (d :: Natural) r point.
(ConstructableHyperPlane_ hyperPlane d r, Point_ point d r,
 Num r) =>
point -> Vector d r -> hyperPlane
fromPointAndNormal point
p (Vector 3 r
u Vector 3 r -> Vector 3 r -> Vector 3 r
forall r. Num r => Vector 3 r -> Vector 3 r -> Vector 3 r
`cross` Vector 3 r
v)


--  hyperPlaneTrough pts = fromPointAndNormal p0 n
--    where
--      p0 = pts^.component @0
--      -- (p0, pts') = uncons pts
--      -- vecs = (.-. p0) <$> pts'
--      n = error "hyperPlaneTrhough: undefined!"


-- | Compare points with respect to the direction given by the
-- vector, i.e. by taking planes whose normal is the given vector.

-- >>> cmpInDirection (Vector2 1 0) (Point2 5 0) (Point2 10 (0 :: Int))
-- LT
-- >>> cmpInDirection (Vector2 1 1) (Point2 5 0) (Point2 10 (0 :: Int))
-- LT
-- >>> cmpInDirection (Vector2 1 1) (Point2 5 0) (Point2 10 (10 :: Int))
-- LT
-- >>> cmpInDirection (Vector2 1 1) (Point2 15 15) (Point2 10 (10 :: Int))
-- GT
-- >>> cmpInDirection (Vector2 1 0) (Point2 15 15) (Point2 15 (10 :: Int))
-- EQ
cmpInDirection       :: forall point d r.
                        ( Ord r, Num r
                        , Has_ Metric_ (d+1) r
                        , Has_ Metric_ d r
                        , Point_ point d r
                        , d < d+1--, 0 < d
                        , Has_ Vector_ (1+d) r, d <= d+1
                        )
                     => Vector d r -> point -> point -> Ordering
cmpInDirection :: forall point (d :: Natural) r.
(Ord r, Num r, Has_ Metric_ (d + 1) r, Has_ Metric_ d r,
 Point_ point d r, d < (d + 1), Has_ Vector_ (1 + d) r,
 d <= (d + 1)) =>
Vector d r -> point -> point -> Ordering
cmpInDirection Vector d r
n point
p point
q = point
p point -> HyperPlane d r -> Ordering
forall point.
(Point_ point d r, Ord r, Num r) =>
point -> HyperPlane d r -> Ordering
forall hyperPlane (d :: Natural) r point.
(HyperPlane_ hyperPlane d r, Point_ point d r, Ord r, Num r) =>
point -> hyperPlane -> Ordering
`onSideTest` point
-> Vector (Dimension point) (NumType point)
-> HyperPlane (Dimension point) (NumType point)
forall {s}.
(Num (NumType s),
 Metric_
   (Vector (Dimension s) (NumType s)) (Dimension s) (NumType s),
 HasVector s s,
 Vector_
   (Vector (Dimension s + 1) (NumType s))
   (Dimension s + 1)
   (NumType s)) =>
s
-> Vector (Dimension s) (NumType s)
-> HyperPlane (Dimension s) (NumType s)
fromPointAndNormal' point
q Vector d r
Vector (Dimension point) (NumType point)
n
  where
    fromPointAndNormal' :: s
-> Vector (Dimension s) (NumType s)
-> HyperPlane (Dimension s) (NumType s)
fromPointAndNormal' s
q' Vector (Dimension s) (NumType s)
n' = Vector (Dimension s + 1) (NumType s)
-> HyperPlane (Dimension s) (NumType s)
forall (d :: Natural) r. Vector (d + 1) r -> HyperPlane d r
HyperPlane (Vector (Dimension s + 1) (NumType s)
 -> HyperPlane (Dimension s) (NumType s))
-> Vector (Dimension s + 1) (NumType s)
-> HyperPlane (Dimension s) (NumType s)
forall a b. (a -> b) -> a -> b
$ NumType s
-> Vector (Dimension s) (NumType s)
-> Vector (Dimension s + 1) (NumType s)
forall vector' vector (d :: Natural) r.
(Vector_ vector d r, Vector_ vector' (d + 1) r) =>
r -> vector -> vector'
cons NumType s
a0 Vector (Dimension s) (NumType s)
n'
      where
        a0 :: NumType s
a0 = NumType s -> NumType s
forall a. Num a => a -> a
negate (NumType s -> NumType s) -> NumType s -> NumType s
forall a b. (a -> b) -> a -> b
$ (s
q's
-> Getting
     (Vector (Dimension s) (NumType s))
     s
     (Vector (Dimension s) (NumType s))
-> Vector (Dimension s) (NumType s)
forall s a. s -> Getting a s a -> a
^.Getting
  (Vector (Dimension s) (NumType s))
  s
  (Vector (Dimension s) (NumType s))
forall (d :: Natural) r s.
(Dimension s ~ d, NumType s ~ r, Dimension s ~ d, NumType s ~ s) =>
Lens s s (Vector d r) (Vector d s)
forall point point' (d :: Natural) 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
  s
  s
  (Vector (Dimension s) (NumType s))
  (Vector (Dimension s) (NumType s))
vector) Vector (Dimension s) (NumType s)
-> Vector (Dimension s) (NumType s) -> NumType s
forall vector (d :: Natural) r.
(Metric_ vector d r, Num r) =>
vector -> vector -> r
`dot` Vector (Dimension s) (NumType s)
n'


-- TODO: not sure how to do this exactly het
-- {-# RULES
--   "cmpInDirection/cmpInDirection2
--      forall (u :: Vector 2 r)
--             (p :: point)
--             (q :: point). cmpInDirection u p q = cmpInDirection2 u p q
--   #-}