Skip to content

Commit

Permalink
ray: use Linear.V3
Browse files Browse the repository at this point in the history
  • Loading branch information
@tmcdonell
tmcdonell committed Dec 15, 2016
1 parent 9718b77 commit b5250fa
Show file tree
Hide file tree
Showing 11 changed files with 72 additions and 192 deletions.
4 changes: 3 additions & 1 deletion accelerate-examples.cabal
View file
Expand Up @@ -666,6 +666,7 @@ Executable accelerate-ray
hs-source-dirs: examples/ray
Main-is: Main.hs
other-modules:
Common.Type
Config
Gloss.Draw
Gloss.Event
Expand All @@ -675,7 +676,6 @@ Executable accelerate-ray
Scene.Object
Scene.State
Scene.World
Vec3

ghc-prof-options: -auto-all
ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-n2M -with-rtsopts=-A64M
Expand All @@ -695,6 +695,8 @@ Executable accelerate-ray
, gloss >= 1.8
, gloss-accelerate >= 0.2
, gloss-raster-accelerate >= 0.2
, lens-accelerate >= 0.1
, linear-accelerate >= 0.3


-- K-means
Expand Down
14 changes: 14 additions & 0 deletions examples/ray/Common/Type.hs
View file
@@ -0,0 +1,14 @@

module Common.Type (

V3(..),
module Common.Type,

) where

import Data.Array.Accelerate.Linear.V3

type Position = V3 Float
type Direction = V3 Float
type Noraml = (Position, Direction)

5 changes: 3 additions & 2 deletions examples/ray/Gloss/Draw.hs
View file
Expand Up @@ -3,7 +3,7 @@ module Gloss.Draw
where

-- friends
import Vec3
import Common.Type
import Scene.Light
import Scene.Object
import Scene.State
Expand All @@ -12,6 +12,7 @@ import Ray.Trace
-- frenemies
import Data.Array.Accelerate as A
import Data.Array.Accelerate.Data.Colour.RGB as RGB
import Data.Array.Accelerate.Linear.Metric
import qualified Data.Array.Accelerate.Data.Colour.RGBA as RGBA

import Graphics.Gloss.Accelerate.Data.Point
Expand Down Expand Up @@ -55,7 +56,7 @@ tracePixel sizeX sizeY fov bounces ambient state point

(x,y) = xyOfPoint point

eyeDir = normalise $ makeVec3 (x * fovX) ((-y) * fovY) 0 - eyePos
eyeDir = normalize $ lift (V3 (x * fovX) ((-y) * fovY) 0) - eyePos
eyePos = the eyePos'
(objects, lights, eyePos')
= unlift state
Expand Down
6 changes: 3 additions & 3 deletions examples/ray/Gloss/Event.hs
View file
Expand Up @@ -4,7 +4,7 @@ module Gloss.Event
where

-- friends
import Vec3
import Common.Type
import Scene.State

-- library
Expand Down Expand Up @@ -45,12 +45,12 @@ handleEvent event state

motion (x,y)
| Just (oX, oY) <- get stateLeftClick state
, XYZ eyeX eyeY eyeZ <- get stateEyeDelta state
, V3 eyeX eyeY eyeZ <- get stateEyeDelta state
= let eyeX' = eyeX + (x - oX)
eyeY' = eyeY
eyeZ' = eyeZ + (y - oY)
in
set stateEyeDelta (XYZ eyeX' eyeY' eyeZ')
set stateEyeDelta (V3 eyeX' eyeY' eyeZ')
$ set stateLeftClick (Just (x, y))
$ state

Expand Down
4 changes: 2 additions & 2 deletions examples/ray/Ray/Intersect.hs
View file
Expand Up @@ -6,7 +6,7 @@ module Ray.Intersect
where

-- friends
import Vec3
import Common.Type
import Scene.Object

-- frenemies
Expand Down Expand Up @@ -71,7 +71,7 @@ checkRay
-> Exp Bool
checkRay distanceTo objs orig dir dist
= fst $ while (\s -> let (hit, i) = unlift s in not hit && i < unindex1 (shape objs))
(\s -> let i = snd s
(\s -> let i = snd s
(hit, dist') = unlift $ distanceTo (objs ! index1 i) orig dir
in hit && dist' < dist ? (lift (True, i), lift (False, i+1)))
(constant (False, 0))
Expand Down
18 changes: 10 additions & 8 deletions examples/ray/Ray/Trace.hs
View file
Expand Up @@ -4,7 +4,7 @@ module Ray.Trace
where

-- friends
import Vec3
import Common.Type
import Scene.Object
import Scene.Light
import Ray.Intersect
Expand All @@ -13,6 +13,8 @@ import Ray.Intersect
import Data.Array.Accelerate as A
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
Expand All @@ -39,7 +41,7 @@ castViewRays sizeX sizeY fov eyePos
in
A.generate (constant (Z :. sizeY :. sizeX))
(\ix -> let (x, y) = xyOfPoint $ pointOfIndex sizeX sizeY ix
in normalise $ makeVec3 (x * fovX) ((-y) * fovY) 0 - eyePos)
in normalize $ lift (V3 (x * fovX) ((-y) * fovY) 0) - eyePos)


-- | Cast a single ray into the scene
Expand All @@ -56,8 +58,8 @@ traceRay limit objects lights ambient = go limit
where
(spheres, planes) = unlift objects

dummySphere = constant (Sphere (XYZ 0 0 0) 0 (RGB 0 0 0) 0)
dummyPlane = constant (Plane (XYZ 0 0 0) (XYZ 0 0 1) (RGB 0 0 0) 0)
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.
Expand Down Expand Up @@ -90,7 +92,7 @@ traceRay limit objects lights ambient = go limit
= unlift (dist_s < dist_p ? ( next_s, next_p ))

-- result angle of ray after reflection
newdir = dir - (2.0 * (normal `dot` dir)) .* normal
newdir = dir - (2.0 * (normal `dot` dir)) *^ normal

-- determine the direct lighting at this point
direct = applyLights objects lights point normal
Expand Down Expand Up @@ -120,7 +122,7 @@ 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
point = orig + dist *^ dir
normal = sphereNormal sph point
colour = sphereColor sph
shine = sphereShine sph
Expand All @@ -130,7 +132,7 @@ hitSphere sph dist orig dir
hitPlane :: Exp Plane -> Exp Float -> Exp Position -> Exp Direction -> Exp (Position, Direction, Colour, Float)
hitPlane pln dist orig dir
= let
point = orig + dist .* dir
point = orig + dist *^ dir
normal = planeNormal pln
colour = planeColor pln
shine = planeShine pln
Expand All @@ -140,7 +142,7 @@ hitPlane pln dist orig dir
hitPlaneCheck :: Exp PlaneCheck -> Exp Float -> Exp Position -> Exp Direction -> Exp (Position, Direction, Colour, Float)
hitPlaneCheck pln dist orig dir
= let
point = orig + dist .* dir
point = orig + dist *^ dir
normal = planeCheckNormal pln
colour = checkers point
shine = planeCheckShine pln
Expand Down
13 changes: 8 additions & 5 deletions examples/ray/Scene/Light.hs
View file
Expand Up @@ -8,15 +8,18 @@ module Scene.Light
where

-- friends
import Vec3
import Common.Type
import Ray.Intersect
import Scene.Object

-- frenemies
import Data.Array.Accelerate as A
import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, Tuple(..), fromTuple, toTuple )
import Data.Array.Accelerate.Data.Colour.RGB
import Data.Array.Accelerate.Data.Colour.Names
import Data.Array.Accelerate.Data.Colour.RGB
import Data.Array.Accelerate.Linear.Metric
import Data.Array.Accelerate.Linear.Vector

import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, Tuple(..), fromTuple, toTuple )
import Data.Array.Accelerate.Product
import Data.Array.Accelerate.Smart

Expand Down Expand Up @@ -74,8 +77,8 @@ applyLight objects point normal light
-- on the surface?
--
lp_p = lightPos light - point
dist = magnitude lp_p
dir = (1.0 / dist) .* lp_p
dist = norm lp_p
dir = (1.0 / dist) *^ lp_p

-- Calculate the magnitude of the reflected light, if there are no
-- occluding objects between the light and the surface point.
Expand Down
21 changes: 13 additions & 8 deletions examples/ray/Scene/Object.hs
View file
Expand Up @@ -8,12 +8,17 @@ module Scene.Object
where

-- friends
import Vec3
import Common.Type

-- frenemies
import Data.Array.Accelerate as A
import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, Tuple(..), fromTuple, toTuple )
import Data.Array.Accelerate.Control.Lens
import Data.Array.Accelerate.Data.Bits
import Data.Array.Accelerate.Linear.Metric
import Data.Array.Accelerate.Linear.V3
import Data.Array.Accelerate.Linear.Vector

import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, Tuple(..), fromTuple, toTuple )
import Data.Array.Accelerate.Product
import Data.Array.Accelerate.Smart

Expand Down Expand Up @@ -69,13 +74,13 @@ distanceToSphere sphere origin direction
pos = spherePos sphere
radius = sphereRadius sphere

p = origin + ((pos - origin) `dot` direction) .* direction
d_cp = magnitude (p - pos)
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, magnitude sep - sqrt (radius * radius - d_cp * d_cp)) )
, lift (True, norm sep - sqrt (radius * radius - d_cp * d_cp)) )


-- | Compute the distance to the surface of a Plane
Expand Down Expand Up @@ -115,16 +120,16 @@ sphereNormal
-> Exp Position -- ^ A point on the surface of the sphere
-> Exp Direction -- ^ Normal at that point
sphereNormal sphere point
= normalise (point - spherePos sphere)
= normalize (point - spherePos sphere)


-- | A checkerboard pattern along the x/z axis
--
checkers :: Exp Position -> Exp Colour
checkers pos
= let
(x,_,z) = xyzOfVec pos

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
Expand Down
16 changes: 8 additions & 8 deletions examples/ray/Scene/State.hs
View file
Expand Up @@ -4,7 +4,7 @@ module Scene.State
where

-- friends
import Vec3
import Common.Type
import Scene.Light
import Scene.Object
import Scene.World
Expand Down Expand Up @@ -51,10 +51,10 @@ initState time
= advanceState 0
$ State
{ _stateTime = time
, _stateEyePos = XYZ 50 (-100) (-700)
, _stateEyePos = V3 50 (-100) (-700)

, _stateEyeDelta = XYZ (-50) 200 1296
, _stateLightDelta = XYZ 0 0 0
, _stateEyeDelta = V3 (-50) 200 1296
, _stateLightDelta = V3 0 0 0

, _stateLeftClick = Nothing

Expand Down Expand Up @@ -83,11 +83,11 @@ advanceState dt state
speed = get stateMoveSpeed state
move eye f d = case get f state of
Nothing -> id
Just Fwd -> modify eye (+ (set d ( speed * dt) (XYZ 0 0 0)))
Just Rev -> modify eye (+ (set d (-speed * dt) (XYZ 0 0 0)))
Just Fwd -> modify eye (+ (set d ( speed * dt) (V3 0 0 0)))
Just Rev -> modify eye (+ (set d (-speed * dt) (V3 0 0 0)))

zz = lens (\(XYZ _ _ z) -> z) (\f (XYZ x y z) -> XYZ x y (f z))
xx = lens (\(XYZ x _ _) -> x) (\f (XYZ x y z) -> XYZ (f x) y z)
zz = lens (\(V3 _ _ z) -> z) (\f (V3 x y z) -> V3 x y (f z))
xx = lens (\(V3 x _ _) -> x) (\f (V3 x y z) -> V3 (f x) y z)


-- | Set the time of the world
Expand Down
17 changes: 8 additions & 9 deletions examples/ray/Scene/World.hs
View file
@@ -1,8 +1,7 @@

module Scene.World where

-- friends
import Vec3
import Common.Type
import Scene.Light
import Scene.Object

Expand All @@ -13,38 +12,38 @@ import Data.Array.Accelerate.Data.Colour.RGB

makeLights :: Float -> Lights
makeLights _time
= A.fromList (Z :. 1) [ Light (XYZ 300 (-300) (-100))
= A.fromList (Z :. 1) [ Light (V3 300 (-300) (-100))
(RGB 150000 150000 150000)
]

makeObjects :: Float -> Objects
makeObjects time
= let
spheres = A.fromList (Z :. 4)
[ Sphere (XYZ (40 * sin time) 80 0.0)
[ Sphere (V3 (40 * sin time) 80 0.0)
20
(RGB 1.0 0.3 1.0)
0.4

, Sphere (XYZ (200 * sin time) (-40 * sin (time + pi/2)) (200 * cos time))
, Sphere (V3 (200 * sin time) (-40 * sin (time + pi/2)) (200 * cos time))
100.0
(RGB 0.4 0.4 1.0)
0.8

, Sphere (XYZ (-200.0 * sin time) (-40 * sin (time - pi/2)) (-200 * cos time))
, Sphere (V3 (-200.0 * sin time) (-40 * sin (time - pi/2)) (-200 * cos time))
100.0
(RGB 0.4 0.4 1.0)
0.5

, Sphere (XYZ 0.0 (-150.0) (-100.0))
, Sphere (V3 0.0 (-150.0) (-100.0))
50.0
(RGB 1.0 1.0 1.0)
0.8
]

planes = A.fromList (Z :. 1)
[ Plane (XYZ 0.0 100.0 0.0)
(XYZ 0.0 (-0.9805807) (-0.19611613))
[ Plane (V3 0.0 100.0 0.0)
(V3 0.0 (-0.9805807) (-0.19611613))
(RGB 1.0 1.0 1.0)
0.2
]
Expand Down

0 comments on commit b5250fa

Please sign in to comment.