{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.Point
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- \(d\)-dimensional points.
--
--------------------------------------------------------------------------------
module Data.Geometry.Point.Internal
  ( Point(..)
  , origin, vector
  , pointFromList

  , coord , unsafeCoord

  , projectPoint

  , pattern Point1
  , pattern Point2
  , pattern Point3
  , PointFunctor(..)

  , cmpByDistanceTo
  , cmpByDistanceTo'
  , squaredEuclideanDist, euclideanDist
  ) where

import           Control.DeepSeq
import           Control.Lens
import           Control.Monad
import           Data.Aeson
import           Data.Ext
import qualified Data.Foldable                   as F
import           Data.Functor.Classes
import           Data.Geometry.Properties
import           Data.Geometry.Vector
import qualified Data.Geometry.Vector            as Vec
import           Data.Hashable
import           Data.List                       (intersperse)
import           Data.Ord                        (comparing)
import           Data.Proxy
import           GHC.Generics                    (Generic)
import           GHC.TypeLits
import           System.Random                   (Random (..))
import           Test.QuickCheck                 (Arbitrary, Arbitrary1)
import           Text.Read                       (Read (..), readListPrecDefault)


--------------------------------------------------------------------------------
-- $setup
-- >>> :{
-- let myVector :: Vector 3 Int
--     myVector = Vector3 1 2 3
--     myPoint = Point myVector
-- :}


--------------------------------------------------------------------------------
-- * A d-dimensional Point

-- | A d-dimensional point.
--
-- There are convenience pattern synonyms for 1, 2 and 3 dimensional points.
--
-- >>> let f (Point1 x) = x in f (Point1 1)
-- 1
-- >>> let f (Point2 x y) = x in f (Point2 1 2)
-- 1
-- >>> let f (Point3 x y z) = z in f (Point3 1 2 3)
-- 3
-- >>> let f (Point3 x y z) = z in f (Point $ Vector3 1 2 3)
-- 3
newtype Point d r = Point { Point d r -> Vector d r
toVec :: Vector d r } deriving ((forall x. Point d r -> Rep (Point d r) x)
-> (forall x. Rep (Point d r) x -> Point d r)
-> Generic (Point d r)
forall x. Rep (Point d r) x -> Point d r
forall x. Point d r -> Rep (Point 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 (Point d r) x -> Point d r
forall (d :: Nat) r x. Point d r -> Rep (Point d r) x
$cto :: forall (d :: Nat) r x. Rep (Point d r) x -> Point d r
$cfrom :: forall (d :: Nat) r x. Point d r -> Rep (Point d r) x
Generic)

instance (Show r, Arity d) => Show (Point d r) where
  showsPrec :: Int -> Point d r -> ShowS
showsPrec = (Int -> r -> ShowS) -> ([r] -> ShowS) -> Int -> Point d r -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> r -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec [r] -> ShowS
forall a. Show a => [a] -> ShowS
showList

instance (Arity d) => Show1 (Point d) where
  liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Point d a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
_ Int
d (Point Vector d a
v) = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
constr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      [ShowS] -> ShowS
unwordsS ((a -> ShowS) -> [a] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> a -> ShowS
sp Int
11) (Vector d a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Vector d a
v))
    where
      constr :: String
constr = String
"Point" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show (Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy d -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal @d Proxy d
forall k (t :: k). Proxy t
Proxy))
      unwordsS :: [ShowS] -> ShowS
unwordsS = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id ([ShowS] -> ShowS) -> ([ShowS] -> [ShowS]) -> [ShowS] -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
' ')

instance (Read r, Arity d) => Read (Point d r) where
  readPrec :: ReadPrec (Point d r)
readPrec     = ReadPrec r -> ReadPrec [r] -> ReadPrec (Point d r)
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
liftReadPrec ReadPrec r
forall a. Read a => ReadPrec a
readPrec ReadPrec [r]
forall a. Read a => ReadPrec [a]
readListPrec
  readListPrec :: ReadPrec [Point d r]
readListPrec = ReadPrec [Point d r]
forall a. Read a => ReadPrec [a]
readListPrecDefault

instance (Arity d) => Read1 (Point d) where
  liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Point d a)
liftReadPrec ReadPrec a
rp ReadPrec [a]
_rl = ReadPrec (Point d a) -> ReadPrec (Point d a)
forall a. ReadPrec a -> ReadPrec a
readData (ReadPrec (Point d a) -> ReadPrec (Point d a))
-> ReadPrec (Point d a) -> ReadPrec (Point d a)
forall a b. (a -> b) -> a -> b
$
      ReadPrec [a]
-> String -> ([a] -> Point d a) -> ReadPrec (Point d a)
forall a t. ReadPrec a -> String -> (a -> t) -> ReadPrec t
readUnaryWith (Int -> ReadPrec a -> ReadPrec [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
d ReadPrec a
rp) String
constr (([a] -> Point d a) -> ReadPrec (Point d a))
-> ([a] -> Point d a) -> ReadPrec (Point d a)
forall a b. (a -> b) -> a -> b
$ \[a]
rs ->
        case [a] -> Maybe (Point d a)
forall (d :: Nat) r. Arity d => [r] -> Maybe (Point d r)
pointFromList [a]
rs of
          Just Point d a
p -> Point d a
p
          Maybe (Point d a)
_      -> String -> Point d a
forall a. HasCallStack => String -> a
error String
"internal error in Data.Geometry.Point read instance."
    where
      d :: Int
d = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy d -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy d
forall k (t :: k). Proxy t
Proxy :: Proxy d))
      constr :: String
constr = String
"Point" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
d
  liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [Point d a]
liftReadListPrec = ReadPrec a -> ReadPrec [a] -> ReadPrec [Point d a]
forall (f :: * -> *) a.
Read1 f =>
ReadPrec a -> ReadPrec [a] -> ReadPrec [f a]
liftReadListPrecDefault

-- readPt :: forall d r. (Arity d, Read r) => ReadP (Point d r)
-- readPt = do let d = natVal (Proxy :: Proxy d)
--             _  <- string $ "Point" <> show d
--             rs <- if d > 3
--               then readPrec_to_P readPrec minPrec
--               else replicateM (fromIntegral d) (readPrec_to_P readPrec minPrec)
--             case pointFromList rs of
--               Just p -> pure p
--               _      -> pfail

deriving instance (Eq r, Arity d)        => Eq (Point d r)
deriving instance Arity d                => Eq1 (Point d)
deriving instance (Ord r, Arity d)       => Ord (Point d r)
deriving instance Arity d                => Functor (Point d)
deriving instance Arity d                => Applicative (Point d)
deriving instance Arity d                => Foldable (Point d)
deriving instance Arity d                => Traversable (Point d)
deriving instance (Arity d, NFData r)    => NFData (Point d r)
deriving instance (Arity d, Arbitrary r) => Arbitrary (Point d r)
deriving instance Arity d                => Arbitrary1 (Point d)
deriving instance (Arity d, Hashable r)  => Hashable (Point d r)
deriving instance (Arity d, Random r)    => Random (Point d r)


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

instance Arity d =>  Affine (Point d) where
  type Diff (Point d) = Vector d

  Point d a
p .-. :: Point d a -> Point d a -> Diff (Point d) a
.-. Point d a
q = Point d a -> Vector d a
forall (d :: Nat) r. Point d r -> Vector d r
toVec Point d a
p Vector d a -> Vector d a -> Vector d a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point d a -> Vector d a
forall (d :: Nat) r. Point d r -> Vector d r
toVec Point d a
q
  Point d a
p .+^ :: Point d a -> Diff (Point d) a -> Point d a
.+^ Diff (Point d) a
v = Vector d a -> Point d a
forall (d :: Nat) r. Vector d r -> Point d r
Point (Vector d a -> Point d a) -> Vector d a -> Point d a
forall a b. (a -> b) -> a -> b
$ Point d a -> Vector d a
forall (d :: Nat) r. Point d r -> Vector d r
toVec Point d a
p Vector d a -> Vector d a -> Vector d a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Diff (Point d) a
Vector d a
v

instance (FromJSON r, Arity d, KnownNat d) => FromJSON (Point d r) where
  parseJSON :: Value -> Parser (Point d r)
parseJSON = (Vector d r -> Point d r)
-> Parser (Vector d r) -> Parser (Point d r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector d r -> Point d r
forall (d :: Nat) r. Vector d r -> Point d r
Point (Parser (Vector d r) -> Parser (Point d r))
-> (Value -> Parser (Vector d r)) -> Value -> Parser (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser (Vector d r)
forall a. FromJSON a => Value -> Parser a
parseJSON

instance (ToJSON r, Arity d) => ToJSON (Point d r) where
  toJSON :: Point d r -> Value
toJSON     = Vector d r -> Value
forall a. ToJSON a => a -> Value
toJSON     (Vector d r -> Value)
-> (Point d r -> Vector d r) -> Point d r -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point d r -> Vector d r
forall (d :: Nat) r. Point d r -> Vector d r
toVec
  toEncoding :: Point d r -> Encoding
toEncoding = Vector d r -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Vector d r -> Encoding)
-> (Point d r -> Vector d r) -> Point d r -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point d r -> Vector d r
forall (d :: Nat) r. Point d r -> Vector d r
toVec

-- | Point representing the origin in d dimensions
--
-- >>> origin :: Point 4 Int
-- Point4 0 0 0 0
origin :: (Arity d, Num r) => Point d r
origin :: Point d r
origin = Vector d r -> Point d r
forall (d :: Nat) r. Vector d r -> Point d r
Point (Vector d r -> Point d r) -> Vector d r -> Point d r
forall a b. (a -> b) -> a -> b
$ r -> Vector d r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
0


-- ** Accessing points

-- | Lens to access the vector corresponding to this point.
--
-- >>> (Point3 1 2 3) ^. vector
-- Vector3 1 2 3
-- >>> origin & vector .~ Vector3 1 2 3
-- Point3 1 2 3
vector :: Lens (Point d r) (Point d r') (Vector d r) (Vector d r')
vector :: (Vector d r -> f (Vector d r')) -> Point d r -> f (Point d r')
vector = (Point d r -> Vector d r)
-> (Point d r -> Vector d r' -> Point d r')
-> Lens (Point d r) (Point d r') (Vector d r) (Vector d r')
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Point d r -> Vector d r
forall (d :: Nat) r. Point d r -> Vector d r
toVec ((Vector d r' -> Point d r')
-> Point d r -> Vector d r' -> Point d r'
forall a b. a -> b -> a
const Vector d r' -> Point d r'
forall (d :: Nat) r. Vector d r -> Point d r
Point)
{-# INLINABLE vector #-}

-- | Get the coordinate in a given dimension. This operation is unsafe in the
-- sense that no bounds are checked. Consider using `coord` instead.
--
--
-- >>> Point3 1 2 3 ^. unsafeCoord 2
-- 2
unsafeCoord   :: Arity d => Int -> Lens' (Point d r) r
unsafeCoord :: Int -> Lens' (Point d r) r
unsafeCoord Int
i = (Vector d r -> f (Vector d r)) -> Point d r -> f (Point d r)
forall (d :: Nat) r r'.
Lens (Point d r) (Point d r') (Vector d r) (Vector d r')
vector ((Vector d r -> f (Vector d r)) -> Point d r -> f (Point d r))
-> ((r -> f r) -> Vector d r -> f (Vector d r))
-> (r -> f r)
-> Point d r
-> f (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Traversing (->) f (Vector d r) (Vector d r) r r
-> (r -> f r) -> Vector d r -> f (Vector d r)
forall (p :: * -> * -> *) (f :: * -> *) s t a.
(HasCallStack, Conjoined p, Functor f) =>
Traversing p f s t a a -> Over p f s t a a
singular (Index (Vector d r)
-> Traversal' (Vector d r) (IxValue (Vector d r))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
                -- Points are 1 indexed, vectors are 0 indexed
{-# INLINABLE unsafeCoord #-}

-- | Get the coordinate in a given dimension
--
-- >>> Point3 1 2 3 ^. coord (C :: C 2)
-- 2
-- >>> Point3 1 2 3 & coord (C :: C 1) .~ 10
-- Point3 10 2 3
-- >>> Point3 1 2 3 & coord (C :: C 3) %~ (+1)
-- Point3 1 2 4
coord   :: forall proxy i d r. (1 <= i, i <= d, Arity d, KnownNat i)
        => proxy i -> Lens' (Point d r) r
coord :: proxy i -> Lens' (Point d r) r
coord proxy i
_ = Int -> Lens' (Point d r) r
forall (d :: Nat) r. Arity d => Int -> Lens' (Point d r) r
unsafeCoord (Int -> Lens' (Point d r) r) -> Int -> Lens' (Point d r) r
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (C i -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (C i -> Integer) -> C i -> Integer
forall a b. (a -> b) -> a -> b
$ C i
forall (n :: Nat). C n
C @i)
{-# INLINABLE coord #-}

 -- somehow these rules don't fire
-- {-# SPECIALIZE coord :: C 1 -> Lens' (Point 2 r) r#-}
-- {-# SPECIALIZE coord :: C 2 -> Lens' (Point 2 r) r#-}
-- {-# SPECIALIZE coord :: C 3 -> Lens' (Point 3 r) r#-}


-- | Constructs a point from a list of coordinates. The length of the
-- list has to match the dimension exactly.
--
-- >>> pointFromList [1,2,3] :: Maybe (Point 3 Int)
-- Just (Point3 1 2 3)
-- >>> pointFromList [1] :: Maybe (Point 3 Int)
-- Nothing
-- >>> pointFromList [1,2,3,4] :: Maybe (Point 3 Int)
-- Nothing
pointFromList :: Arity d => [r] -> Maybe (Point d r)
pointFromList :: [r] -> Maybe (Point d r)
pointFromList = (Vector d r -> Point d r)
-> Maybe (Vector d r) -> Maybe (Point d r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector d r -> Point d r
forall (d :: Nat) r. Vector d r -> Point d r
Point (Maybe (Vector d r) -> Maybe (Point d r))
-> ([r] -> Maybe (Vector d r)) -> [r] -> Maybe (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [r] -> Maybe (Vector d r)
forall (d :: Nat) r. Arity d => [r] -> Maybe (Vector d r)
Vec.vectorFromList


-- | Project a point down into a lower dimension.
projectPoint :: (Arity i, Arity d, i <= d) => Point d r -> Point i r
projectPoint :: Point d r -> Point i r
projectPoint = Vector i r -> Point i r
forall (d :: Nat) r. Vector d r -> Point d r
Point (Vector i r -> Point i r)
-> (Point d r -> Vector i r) -> Point d r -> Point i r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector d r -> Vector i r
forall (i :: Nat) (d :: Nat) r.
(Arity d, Arity i, i <= d) =>
Vector d r -> Vector i r
prefix (Vector d r -> Vector i r)
-> (Point d r -> Vector d r) -> Point d r -> Vector i r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point d r -> Vector d r
forall (d :: Nat) r. Point d r -> Vector d r
toVec

--------------------------------------------------------------------------------
-- * Convenience functions to construct 1, 2 and 3 dimensional points

-- | A bidirectional pattern synonym for 1 dimensional points.
pattern Point1   :: r -> Point 1 r
pattern $bPoint1 :: r -> Point 1 r
$mPoint1 :: forall r r. Point 1 r -> (r -> r) -> (Void# -> r) -> r
Point1 x = Point (Vector1 x)
{-# COMPLETE Point1 #-}


-- | A bidirectional pattern synonym for 2 dimensional points.
pattern Point2       :: r -> r -> Point 2 r
pattern $bPoint2 :: r -> r -> Point 2 r
$mPoint2 :: forall r r. Point 2 r -> (r -> r -> r) -> (Void# -> r) -> r
Point2 x y = Point (Vector2 x y)
{-# COMPLETE Point2 #-}

-- | A bidirectional pattern synonym for 3 dimensional points.
pattern Point3       :: r -> r -> r -> Point 3 r
pattern $bPoint3 :: r -> r -> r -> Point 3 r
$mPoint3 :: forall r r. Point 3 r -> (r -> r -> r -> r) -> (Void# -> r) -> r
Point3 x y z = (Point (Vector3 x y z))
{-# COMPLETE Point3 #-}

--------------------------------------------------------------------------------
-- * Point Functors

-- | Types that we can transform by mapping a function on each point in the structure
class PointFunctor g where
  pmap :: (Point (Dimension (g r)) r -> Point (Dimension (g s)) s) -> g r -> g s

  -- pemap :: (d ~ Dimension (g r)) => (Point d r :+ p -> Point d s :+ p) -> g r -> g s
  -- pemap =

instance PointFunctor (Point d) where
  pmap :: (Point (Dimension (Point d r)) r
 -> Point (Dimension (Point d s)) s)
-> Point d r -> Point d s
pmap Point (Dimension (Point d r)) r -> Point (Dimension (Point d s)) s
f = Point d r -> Point d s
Point (Dimension (Point d r)) r -> Point (Dimension (Point d s)) s
f


--------------------------------------------------------------------------------
-- * Functions specific to Two Dimensional points

-- | Compare by distance to the first argument
cmpByDistanceTo              :: (Ord r, Num r, Arity d)
                             => Point d r -> Point d r -> Point d r -> Ordering
cmpByDistanceTo :: Point d r -> Point d r -> Point d r -> Ordering
cmpByDistanceTo Point d r
c Point d r
p Point d r
q = (Point d r -> r) -> Point d r -> Point d r -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Point d r -> Point d r -> r
forall r (d :: Nat).
(Num r, Arity d) =>
Point d r -> Point d r -> r
squaredEuclideanDist Point d r
c) Point d r
p Point d r
q

-- | Compare by distance to the first argument
cmpByDistanceTo'  :: (Ord r, Num r, Arity d)
                  => Point d r :+ c -> Point d r :+ p -> Point d r :+ q -> Ordering
cmpByDistanceTo' :: (Point d r :+ c)
-> (Point d r :+ p) -> (Point d r :+ q) -> Ordering
cmpByDistanceTo' Point d r :+ c
c Point d r :+ p
p Point d r :+ q
q = Point d r -> Point d r -> Point d r -> Ordering
forall r (d :: Nat).
(Ord r, Num r, Arity d) =>
Point d r -> Point d r -> Point d r -> Ordering
cmpByDistanceTo (Point d r :+ c
c(Point d r :+ c)
-> Getting (Point d r) (Point d r :+ c) (Point d r) -> Point d r
forall s a. s -> Getting a s a -> a
^.Getting (Point d r) (Point d r :+ c) (Point d r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) (Point d r :+ p
p(Point d r :+ p)
-> Getting (Point d r) (Point d r :+ p) (Point d r) -> Point d r
forall s a. s -> Getting a s a -> a
^.Getting (Point d r) (Point d r :+ p) (Point d r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) (Point d r :+ q
q(Point d r :+ q)
-> Getting (Point d r) (Point d r :+ q) (Point d r) -> Point d r
forall s a. s -> Getting a s a -> a
^.Getting (Point d r) (Point d r :+ q) (Point d r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)



-- | Squared Euclidean distance between two points
squaredEuclideanDist :: (Num r, Arity d) => Point d r -> Point d r -> r
squaredEuclideanDist :: Point d r -> Point d r -> r
squaredEuclideanDist = Point d r -> Point d r -> r
forall (p :: * -> *) a.
(Affine p, Foldable (Diff p), Num a) =>
p a -> p a -> a
qdA

-- | Euclidean distance between two points
euclideanDist :: (Floating r, Arity d) => Point d r -> Point d r -> r
euclideanDist :: Point d r -> Point d r -> r
euclideanDist = Point d r -> Point d r -> r
forall a (p :: * -> *).
(Floating a, Foldable (Diff p), Affine p) =>
p a -> p a -> a
distanceA