{-# LANGUAGE DeriveAnyClass  #-}
{-# LANGUAGE DeriveGeneric   #-}
{-# LANGUAGE PatternSynonyms #-}

module Scene.Object
  where

-- friends
import Common.Type

-- frenemies
import Data.Array.Accelerate                                    as A
import Data.Array.Accelerate.Control.Lens
import Data.Array.Accelerate.Data.Bits
import Data.Array.Accelerate.Data.Colour.RGB
import Data.Array.Accelerate.Linear.Metric
import Data.Array.Accelerate.Linear.V3
import Data.Array.Accelerate.Linear.Vector

-- standard library
import qualified Prelude                                        as P


-- | All objects in the scene
--
type Objects = (Vector Sphere, Vector Plane)

-- | Objects in the world. Accelerate does not have sum types, so define each
--   object separately (and hope this works out...)
--
data Sphere = Sphere_ Position Float Colour Float
  deriving (Show, Generic, Elt)

data Plane = Plane_ Position Direction Colour Float
  deriving (Show, Generic, Elt)

pattern Sphere :: Exp Position -> Exp Float -> Exp Colour -> Exp Float -> Exp Sphere
pattern Sphere { spherePos, sphereRadius, sphereColor, sphereShine } =
  Pattern ( spherePos, sphereRadius, sphereColor, sphereShine )
{-# COMPLETE Sphere #-}

pattern Plane :: Exp Position -> Exp Direction -> Exp Colour -> Exp Float -> Exp Plane
pattern Plane { planePos, planeNormal, planeColor, planeShine } =
  Pattern ( planePos, planeNormal, planeColor, planeShine )
{-# COMPLETE Plane #-}

type PlaneCheck = Plane

planeCheckPos    :: Exp PlaneCheck -> Exp Position
planeCheckNormal :: Exp PlaneCheck -> Exp Direction
planeCheckShine  :: Exp PlaneCheck -> Exp Float

planeCheckPos    = planePos
planeCheckNormal = planeNormal
planeCheckShine  = planeShine


-- | Compute the distance to the surface of a sphere
--
distanceToSphere
    :: Exp Sphere               -- ^ Object to intersect
    -> Exp Position             -- ^ Ray cast from this point...
    -> Exp Direction            -- ^ ...along this direction
    -> Exp (Bool, Float)        -- ^ Distance to intersection, if there is one
distanceToSphere sphere origin direction
  = let
        pos     = spherePos sphere
        radius  = sphereRadius sphere

        p       = origin + ((pos - origin) `dot` direction) *^ direction
        d_cp    = norm (p - pos)
        sep     = p - origin
        miss    = d_cp >= radius || sep `dot` direction <= 0
    in
    miss ? ( lift (False, infinity)
           , lift (True,  norm sep - sqrt (radius * radius - d_cp * d_cp)) )


-- | Compute the distance to the surface of a Plane
--
distanceToPlane
    :: Exp Plane                -- ^ Plane to intersect
    -> Exp Position             -- ^ Ray cast from this point
    -> Exp Direction            -- ^ ...along this direction
    -> Exp (Bool, Float)        -- ^ Distance to intersection, if there is one
distanceToPlane plane origin direction
  = let
        pos             = planePos plane
        normal          = planeNormal plane
        theta           = direction `dot` normal        -- TLM: name?
    in
    theta >= 0 ? ( lift (False, infinity)
                 , lift (True,  ((pos - origin) `dot` normal) / theta) )


-- | The maximum representable floating point value
--
infinity :: Exp Float
infinity = constant (P.encodeFloat m n)
  where
    a           = undefined :: Float
    b           = P.floatRadix a
    e           = P.floatDigits a
    (_, e')     = P.floatRange a
    m           = b P.^ e - 1
    n           = e' - e


-- | Compute the surface normal of a sphere at a point
--
sphereNormal
    :: Exp Sphere
    -> Exp Position             -- ^ A point on the surface of the sphere
    -> Exp Direction            -- ^ Normal at that point
sphereNormal sphere point
  = normalize (point - spherePos sphere)


-- | A checkerboard pattern along the x/z axis
--
checkers :: Exp Position -> Exp Colour
checkers pos
  = let
        x       = pos ^. _x
        z       = pos ^. _z
        v1      = (A.truncate (x / 100) :: Exp Int32) `mod` 2
        v2      = (A.truncate (z / 100) :: Exp Int32) `mod` 2
        v3      = A.fromIntegral . boolToInt $ x A.< 0.0
        v4      = A.fromIntegral . boolToInt $ z A.< 0.0
    in
    v1 `xor` v2 `xor` v3 `xor` v4 == 1 {- True -}
      ? ( rgb 1.0 1.0 1.0
        , rgb 0.4 0.4 0.4 )