content: {-# 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 )
  
  