{-# LANGUAGE ScopedTypeVariables #-}
module Ray.Trace
where
-- friends
import Common.Type
import Scene.Object
import Scene.Light
import Ray.Intersect
-- frenemies
import Data.Array.Accelerate as A hiding ( V3 )
import Data.Array.Accelerate.Data.Colour.RGB as RGB
import Data.Array.Accelerate.Data.Colour.Names
import Data.Array.Accelerate.Linear.Metric
import Data.Array.Accelerate.Linear.Vector
import Graphics.Gloss.Accelerate.Data.Point
-- standard library
import qualified Prelude as P
-- | Generate all of the rays that will be cast from the given eye position to
-- cover the entire field of view.
--
castViewRays
:: Int -- width of the display
-> Int -- height
-> Int -- field of view
-> Exp Position -- eye position
-> Acc (Array DIM2 Direction) -- all rays originating from the eye position
castViewRays sizeX sizeY fov eyePos
= let
sizeX' = P.fromIntegral sizeX
sizeY' = P.fromIntegral sizeY
aspect = sizeX' / sizeY'
fov' = P.fromIntegral fov
fovX = fov' * aspect
fovY = fov'
in
A.generate (constant (Z :. sizeY :. sizeX))
(\ix -> let (x, y) = xyOfPoint $ pointOfIndex sizeX sizeY ix
in normalize $ lift (V3 (x * fovX) (y * fovY) 0) - eyePos)
-- | Cast a single ray into the scene
--
traceRay
:: Int -- ^ Maximum reflection count
-> Acc Objects -- ^ Objects in the scene
-> Acc Lights -- ^ Direct lighting in the scene
-> Exp Colour -- ^ Ambient light in the scene
-> Exp Position -- ^ Origin of the ray
-> Exp Direction -- ^ Direction of the ray
-> Exp Colour
traceRay limit objects lights ambient = go limit
where
(spheres, planes) = unlift objects
dummySphere = constant (Sphere_ (V3 0 0 0) 0 (RGB 0 0 0) 0)
dummyPlane = constant (Plane_ (V3 0 0 0) (V3 0 0 1) (RGB 0 0 0) 0)
-- Stop once there are too many reflections, in case we've found two
-- parallel mirrors.
--
go :: Int -> Exp Position -> Exp Direction -> Exp Colour
go 0 _ _
= constant black
go bounces orig dir
= let
-- See which objects the ray intersects. Since we have no sum
-- types, we need to do this separately for each object type,
-- and determine the closest separately.
--
(hit_s, dist_s, s) = unlift $ castRay distanceToSphere dummySphere spheres orig dir
(hit_p, dist_p, p) = unlift $ castRay distanceToPlane dummyPlane planes orig dir
in
A.not (hit_s || hit_p) ?
-- ray didn't intersect any objects
( constant black
-- ray hit an object
, let
-- Determine the intersection point, and surface properties that
-- will contribute to the colour
next_s = hitSphere s dist_s orig dir
next_p = hitPlaneCheck p dist_p orig dir
(point, normal, colour, shine)
= unlift (dist_s < dist_p ? ( next_s, next_p ))
-- result angle of ray after reflection
newdir = dir - (2.0 * (normal `dot` dir)) *^ normal
-- determine the direct lighting at this point
direct = applyLights objects lights point normal
-- see if the ray hits anything else
refl = go (bounces - 1) point newdir
-- total lighting is the direct lighting plus ambient
lighting = direct + ambient
-- total incoming light is direct lighting plus reflections
light_in = scaleColour shine refl
+ scaleColour (1.0 - shine) lighting
-- outgoing light is incoming light modified by surface colour. We
-- also need to clip it in case the sum of all incoming lights is
-- too bright to display.
light_out = RGB.clamp (light_in * colour)
in
light_out
)
scaleColour :: Exp Float -> Exp Colour -> Exp Colour
scaleColour s c = lift (RGB s s s) * c
hitSphere :: Exp Sphere -> Exp Float -> Exp Position -> Exp Direction -> Exp (Position, Direction, Colour, Float)
hitSphere sph dist orig dir
= let
point = orig + dist *^ dir
normal = sphereNormal sph point
colour = sphereColor sph
shine = sphereShine sph
in
lift (point, normal, colour, shine)
hitPlane :: Exp Plane -> Exp Float -> Exp Position -> Exp Direction -> Exp (Position, Direction, Colour, Float)
hitPlane pln dist orig dir
= let
point = orig + dist *^ dir
normal = planeNormal pln
colour = planeColor pln
shine = planeShine pln
in
lift (point, normal, colour, shine)
hitPlaneCheck :: Exp PlaneCheck -> Exp Float -> Exp Position -> Exp Direction -> Exp (Position, Direction, Colour, Float)
hitPlaneCheck pln dist orig dir
= let
point = orig + dist *^ dir
normal = planeCheckNormal pln
colour = checkers point
shine = planeCheckShine pln
in
lift (point, normal, colour, shine)