Point.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

#ifdef TH_LIFT
{-# LANGUAGE DeriveLift #-}
#endif

module Geomancy.Point
  ( Point(..)

  , Point2
  , Point3
  , Point3P
  , Point4

  , DPoint2
  , DPoint3
  , DPoint3P
  , DPoint4

  , AffineSpace
  , (AffineSpace..+^)
  , (AffineSpace..-^)
  , (AffineSpace..-.)

  , qd
  , distance
  , lerp
  ) where

import Control.DeepSeq (NFData)
import Data.AffineSpace (AffineSpace)
import Data.MonoTraversable (Element, MonoFunctor(..), MonoPointed(..))
import Foreign.Storable (Storable)
import GHC.Generics (Generic)
import GHC.Ix (Ix)
import GHC.Records (HasField(..))
import GHC.TypeNats (KnownNat)
import qualified Data.AffineSpace as AffineSpace

#ifdef TH_LIFT
import Language.Haskell.TH.Syntax (Lift)
#endif

#ifdef SERIALISE
import Codec.Serialise (Serialise)
#endif

import Geomancy.DVec2 (DVec2)
import Geomancy.DVec3 (DVec3)
import Geomancy.Elementwise (Elementwise(..))
import Graphics.Gl.Block (Block(..))
import Geomancy.Vec2 (Vec2)
import Geomancy.Vec3 (Vec3, Packed)
import Geomancy.Vec4 (Vec4)
import Geomancy.DVec4 (DVec4)
import Geomancy.Vector (VectorSpace(..))
import qualified Geomancy.DVec3 as DVec3
import qualified Geomancy.Vector as Vector

newtype Point v = Point v
  deriving (Generic)
  deriving stock (Eq, Ord, Show)
  deriving newtype (Ix, NFData, Num, Fractional, MonoFunctor, MonoPointed, Elementwise, Storable)
#ifdef TH_LIFT
  deriving Lift
#endif
#ifdef SERIALISE
  deriving newtype Serialise
#endif

deriving anyclass instance
  ( KnownNat (PackedSize v)
  , Block v
  ) => Block (Point v)

type instance Element (Point v) = Element v

instance HasField "x" v a => HasField "x" (Point v) a where
  {-# INLINE getField #-}
  getField (Point v) = getField @"x" v

instance HasField "y" v a => HasField "y" (Point v) a where
  {-# INLINE getField #-}
  getField (Point v) = getField @"y" v

instance HasField "z" v a => HasField "z" (Point v) a where
  {-# INLINE getField #-}
  getField (Point v) = getField @"z" v

instance HasField "w" v a => HasField "w" (Point v) a where
  {-# INLINE getField #-}
  getField (Point v) = getField @"w" v

type Point2 = Point Vec2
type Point3 = Point Vec3
type Point3P = Point Packed
type Point4 = Point Vec4

type DPoint2 = Point DVec2
type DPoint3 = Point DVec3
type DPoint3P = Point DVec3.Packed
type DPoint4 = Point DVec4

instance (Floating a, VectorSpace v a) => AffineSpace (Point v) v a where
  origin = Point zeroVector

  {-# INLINE (.+^) #-}
  Point p .+^ v = Point (p ^+^ v)

  {-# INLINE (.-^) #-}
  Point p .-^ v = Point (p ^-^ v)

  {-# INLINE (.-.) #-}
  Point a .-. Point b = a ^-^ b

{-# INLINE qd #-}
qd :: (Floating a, VectorSpace v a) => Point v -> Point v -> a
qd a b = Vector.quadrance (a AffineSpace..-. b)

{-# INLINE distance #-}
distance :: (Floating a, VectorSpace v a) => Point v -> Point v -> a
distance a b = sqrt (qd a b)

{-# INLINE lerp #-}
lerp :: (Num a, VectorSpace v a) => Point v -> Point v -> a -> Point v
lerp (Point a) (Point b) = Point . Vector.lerp a b