diff --git a/Data/Glome/Bih.hs b/Data/Glome/Bih.hs --- a/Data/Glome/Bih.hs +++ b/Data/Glome/Bih.hs @@ -159,16 +159,16 @@ SolidItem (Bih bb root) -- Standard ray traversal. -rayint_bih :: Bih -> Ray -> Flt -> Texture -> Rayint -rayint_bih (Bih bb root) !r@(Ray orig dir) !d t = - let dir_rcp = vrcp dir - Interval near far = bbclip r bb - traverse (BihLeaf s) near far = rayint s r (fmin d far) t - traverse (BihBranch lsplit rsplit axis l r) near far = - let dirr = va dir_rcp axis - o = va orig axis - dl = (lsplit - o) * dirr - dr = (rsplit - o) * dirr +rayint_bih' :: Bih -> Ray -> Flt -> Texture -> Rayint +rayint_bih' (Bih bb root) !r@(Ray orig dir) !d t = + let !dir_rcp = vrcp dir + Interval !near !far = bbclip r bb + traverse (BihLeaf !s) !near !far = rayint s r (fmin d far) t + traverse (BihBranch !lsplit !rsplit !axis !l !r) near far = + let !dirr = va dir_rcp axis + !o = va orig axis + !dl = (lsplit - o) * dirr + !dr = (rsplit - o) * dirr in if near > far then RayMiss @@ -193,14 +193,57 @@ in traverse root near far +miss :: Rayint +miss = RayMiss + +-- Optimized traversal. There's an allocation happening somewhere in here +-- that I haven't been able to eradicate. +rayint_bih :: Bih -> Ray -> Flt -> Texture -> Rayint +rayint_bih (Bih !bb !root) !r !d t = + let (# near, far #) = {-# SCC bih_rayint_clip #-} bbclip_ub r bb + (# ox, oy, oz, dx, dy, dz #) = {-# SCC bih_rayint_ray #-} ray_ub r + traverse (BihLeaf !s) !near !far = {-# SCC bih_rayint_leaf #-} rayint s r far t + traverse (BihBranch !lsplit !rsplit !axis l r) !near !far = + {-# SCC bih_rayint_branch #-} + let (# !dirr, !o #) = {-# SCC bih_rayint_case #-} (case axis of 0 -> (# 1/dx, ox #) + 1 -> (# 1/dy, oy #) + 2 -> (# 1/dz, oz #)) + !dl = (lsplit - o) * dirr + !dr = (rsplit - o) * dirr + in + if near > far + then miss + else + if dirr > 0 + then + {-# SCC bih_rayint_pos #-} + nearest + (if near < dl + then (case fmin dl far of far' -> traverse l near far') + else miss) + (if dr < far + then (case fmax dr near of near' -> traverse r near' far) + else miss) + else + {-# SCC bih_rayint_neg #-} + nearest + (if near < dr + then (case fmin dr far of far' -> traverse r near far') + else miss) + (if dl < far + then (case fmax dl near of near' -> traverse l near' far) + else miss) + in + traverse root near (fmin d far) + -- Ray traversal with debug counter. The counter gets incremented -- when we hit a box. rayint_debug_bih :: Bih -> Ray -> Flt -> Texture -> (Rayint,Int) rayint_debug_bih (Bih bb root) r@(Ray orig dir) d t = - let dir_rcp = vrcp dir - Interval near far = bbclip r bb - traverse (BihLeaf s) near far = rayint_debug s r (fmin d far) t - traverse (BihBranch lsplit rsplit axis l r) near far = + let !dir_rcp = vrcp dir + Interval !near !far = bbclip r bb + traverse (BihLeaf !s) !near !far = rayint_debug s r (fmin d far) t + traverse (BihBranch !lsplit !rsplit !axis !l !r) near far = let dirr = va dir_rcp axis o = va orig axis dl = (lsplit - o) * dirr @@ -251,10 +294,10 @@ !r2@(Ray orig2 dir2) !r3@(Ray orig3 dir3) !r4@(Ray orig4 dir4) !d t = - let dir_rcp1 = vrcp dir1 - dir_rcp2 = vrcp dir2 - dir_rcp3 = vrcp dir3 - dir_rcp4 = vrcp dir4 + let !dir_rcp1 = vrcp dir1 + !dir_rcp2 = vrcp dir2 + !dir_rcp3 = vrcp dir3 + !dir_rcp4 = vrcp dir4 in -- We want all the ray components to have -- at least the same sign. @@ -267,16 +310,16 @@ (rayint bih r3 d t) (rayint bih r4 d t) else - let Interval near1 far1 = bbclip r1 bb - Interval near2 far2 = bbclip r2 bb - Interval near3 far3 = bbclip r3 bb - Interval near4 far4 = bbclip r4 bb + let Interval !near1 !far1 = bbclip r1 bb + Interval !near2 !far2 = bbclip r2 bb + Interval !near3 !far3 = bbclip r3 bb + Interval !near4 !far4 = bbclip r4 bb - near = fmin4 near1 near2 near3 near4 - far = fmax4 far1 far2 far3 far4 + !near = fmin4 near1 near2 near3 near4 + !far = fmax4 far1 far2 far3 far4 - traverse (BihLeaf s) near far = packetint s r1 r2 r3 r4 (fmin d far) t - traverse (BihBranch lsplit rsplit axis l r) near far = + traverse (BihLeaf !s) !near !far = packetint s r1 r2 r3 r4 (fmin d far) t + traverse (BihBranch !lsplit !rsplit !axis !l !r) !near !far = if near > far then packetmiss else @@ -328,15 +371,17 @@ traverse root near far shadow_bih :: Bih -> Ray -> Flt -> Bool -shadow_bih (Bih bb root) r@(Ray orig dir) d = - let dir_rcp = vrcp dir - Interval near far = bbclip r bb - traverse (BihLeaf s) near far = shadow s r (fmin d far) - traverse (BihBranch lsplit rsplit axis l r) near far = - let dirr = va dir_rcp axis - o = va orig axis - dl = (lsplit - o) * dirr - dr = (rsplit - o) * dirr +shadow_bih (Bih bb root) r@(Ray orig@(Vec ox oy oz) dir@(Vec dx dy dz)) d = + let -- !dir_rcp = vrcp dir + (# near, far' #) = bbclip_ub r bb + !far = fmin d far' + traverse (BihLeaf !s) !near !far = shadow s r (fmin d far) + traverse (BihBranch !lsplit !rsplit !axis l r) !near !far = + let (# !dirr, !o #) = {-# SCC bih_shadow_case #-} (case axis of 0 -> (# 1/dx, ox #) + 1 -> (# 1/dy, oy #) + 2 -> (# 1/dz, oz #)) + !dl = (lsplit - o) * dirr + !dr = (rsplit - o) * dirr in if near > far then False @@ -344,7 +389,7 @@ if dirr > 0 then ((if near < dl - then traverse l near (fmin dl far) + then traverse l near $! (fmin dl far) else False) || (if dr < far @@ -352,7 +397,7 @@ else False)) else ((if near < dr - then traverse r near (fmin dr far) + then traverse r near $! (fmin dr far) else False) || (if dl < far @@ -366,9 +411,9 @@ -- the bih. inside_bih :: Bih -> Vec -> Bool -inside_bih (Bih (Bbox (Vec x1 y1 z1) (Vec x2 y2 z2)) root) pt@(Vec x y z) = - let traverse (BihLeaf s) = inside s pt - traverse (BihBranch lsplit rsplit axis l r) = +inside_bih (Bih (Bbox (Vec !x1 !y1 !z1) (Vec !x2 !y2 !z2)) root) pt@(Vec !x !y !z) = + let traverse (BihLeaf !s) = inside s pt + traverse (BihBranch !lsplit !rsplit !axis !l !r) = let o = va pt axis in (if o < lsplit then (traverse l) diff --git a/Data/Glome/Box.hs b/Data/Glome/Box.hs --- a/Data/Glome/Box.hs +++ b/Data/Glome/Box.hs @@ -30,16 +30,25 @@ firstout = (fmin3 outx outy outz) in if lastin > firstout || firstout < 0 || lastin > d then RayMiss - else - let n = if inx == lastin - then if dx > 0 then nvx else vx - else if iny == lastin - then if dy > 0 then nvy else vy - else if dz > 0 then nvz else vz - norm = if lastin > 0 then n else vinvert n - hitdepth = fmax 0 lastin - in - RayHit hitdepth (vscaleadd orig dir hitdepth) norm t + else + if lastin < 0 + then -- origin is inside + let n = if outx == firstout + then if dx > 0 then vx else nvx + else if outy == firstout + then if dy > 0 then vy else nvy + else if dz > 0 then vz else nvz + in + RayHit firstout (vscaleadd orig dir firstout) n t + + else -- origin is outside + let n = if inx == lastin + then if dx > 0 then nvx else vx + else if iny == lastin + then if dy > 0 then nvy else vy + else if dz > 0 then nvz else vz + in + RayHit lastin (vscaleadd orig dir lastin) n t shadow_box :: Box -> Ray -> Flt -> Bool shadow_box (Box box) r d = diff --git a/Data/Glome/Csg.hs b/Data/Glome/Csg.hs --- a/Data/Glome/Csg.hs +++ b/Data/Glome/Csg.hs @@ -19,6 +19,7 @@ difference :: SolidItem -> SolidItem -> SolidItem difference a b = SolidItem $ Difference a b +{- rayint_difference :: Difference -> Ray -> Flt -> Texture -> Rayint rayint_difference dif@(Difference sa sb) r@(Ray orig dir) d t = let ria = rayint sa r d t @@ -40,7 +41,125 @@ if inside sb ap then rayint_advance (SolidItem dif) r d t ad else RayHit ad ap an at +-} +{- +allints :: SolidItem -> Ray -> Flt -> Texture -> [Rayint] +allints s r d t = + case int of + RayHit d p n t -> + + _ -> [] + where + int = rayint s r d tt + +rayint_difference :: Difference -> Ray -> Flt -> Texture -> Rayint +rayint_difference (Difference sa sb) r@(Ray orig dir) d t = + where + + inta = + intb = + + +rayint_difference :: Difference -> Ray -> Flt -> Texture -> Rayint +rayint_difference (Difference sa sb) r@(Ray orig dir) d t + | (fabs $ (vlen dir)-1) > delta = error $ "bad direction vector " ++ (show r) + | otherwise = go r d t + where + go r@(Ray orig dir) = + if inside sb (vscaleadd orig dir (delta*0.5)) + then go_insideb r + else go_outsideb r + + go_outsideb r d t = + let ria = rayint sa r d t + in case ria of + RayHit ad ap an at -> + + miss -> miss + +rayint_difference :: Difference -> Ray -> Flt -> Texture -> Rayint +rayint_difference dif@(Difference sa sb) r@(Ray orig dir) d t + | (fabs $ (vlen dir)-1) > delta = error $ "bad direction vector " ++ (show r) + | otherwise = go r d t + where + go r@(Ray orig dir) d t = + if inside sb (vscaleadd orig dir delta) + then go_insideb r d t + else go_outsideb r d t + + go_insideb r d t = + let rib = rayint sb r d t + in + case rib of + RayHit bd bp bn bt -> + if inside sa bp && (not (inside sb (vscaleadd bp dir delta))) + then RayHit bd bp (vinvert bn) bt + else + case go (ray_move r (bd+delta)) (d-(bd+delta)) t of + RayHit d' p' n' t' -> RayHit (d'+(bd+delta)) p' n' t' + miss -> miss + miss -> miss + + go_outsideb r d t = + let ria = rayint sa r d t + in + case ria of + RayHit ad ap an at -> + if inside sb ap + then + case go (ray_move r (ad+delta)) (d-(ad+delta)) t of + RayHit d' p' n' t' -> RayHit (d'+(ad+delta)) p' n' t' + miss -> miss + else ria + miss -> miss +-} + +rayint_difference :: Difference -> Ray -> Flt -> Texture -> Rayint +rayint_difference dif@(Difference sa sb) r@(Ray orig dir) d t + | inside sb orig = + case rayint sb r d t of + rib@(RayHit bd bp bn bt) -> + if inside sa bp && (not (inside sb (vscaleadd bp dir delta))) + then RayHit bd bp (vinvert bn) bt + else rayint_advance (SolidItem dif) r d t bd + miss -> miss + | otherwise = + case rayint sa r d t of + ria@(RayHit ad ap an at) -> + case rayint sb r d t of + rib@(RayHit bd bp bn bt) -> + if (ad < bd) + then ria + else rayint_advance (SolidItem dif) r d t bd + RayMiss -> ria + miss -> miss + + +{- + +rayint_difference :: Difference -> Ray -> Flt -> Texture -> Rayint +rayint_difference dif@(Difference sa sb) r@(Ray orig dir) d t = + let ria = rayint sa r d t + in + case ria of + RayMiss -> RayMiss + RayHit ad ap an at -> + if inside sb orig + then + case rayint sb r d t of + RayMiss -> RayMiss + RayHit bd bp bn bt -> + if bd < ad + then if inside sa bp + then RayHit bd bp (vinvert bn) t + else rayint_advance (SolidItem dif) r d t bd + else rayint_advance (SolidItem dif) r d t bd + else + if inside sb ap + then rayint_advance (SolidItem dif) r d t ad + else RayHit ad ap an at +-} --Intersection-- diff --git a/Data/Glome/Scene.hs b/Data/Glome/Scene.hs --- a/Data/Glome/Scene.hs +++ b/Data/Glome/Scene.hs @@ -33,13 +33,16 @@ -- defininition code. --LIGHTS-- -data Light = Light {litpos :: !Vec, - litcol :: !Color} deriving Show +data Light = Light {litpos :: !Vec, + litcol :: !Color, + litexp :: !Flt, + litrad :: !Flt, + litshadow :: !Bool } deriving Show -- | Construct a light given a center location and a color. light :: Vec -> Color -> Light -light pos clr = Light pos clr +light pos clr = Light pos clr (-2) infinity True -- CAMERA -- data Camera = Camera {campos, fwd, up, right :: !Vec} diff --git a/Data/Glome/Solid.hs b/Data/Glome/Solid.hs --- a/Data/Glome/Solid.hs +++ b/Data/Glome/Solid.hs @@ -21,23 +21,27 @@ texture :: Texture } | RayMiss deriving Show +raymiss :: Rayint +raymiss = RayMiss + -- | Pick the closest of two Rayints nearest :: Rayint -> Rayint -> Rayint -nearest a RayMiss = a -nearest RayMiss b = b -nearest !rha@(RayHit da _ _ _) !rhb@(RayHit db _ _ _) = +nearest a RayMiss = {-# SCC nearest_miss_a #-} a +nearest RayMiss b = {-# SCC nearest_miss_b #-} b +nearest a@(RayHit !da _ _ _) b@(RayHit !db _ _ _) = + {-# SCC nearest_cmp #-} if da < db - then rha - else rhb + then a + else b -- | Pick the furthest of two Rayints furthest :: Rayint -> Rayint -> Rayint -furthest !a !RayMiss = RayMiss -furthest !RayMiss !b = RayMiss -furthest !(RayHit da pa na ta) !(RayHit db pb nb tb) = +furthest _ RayMiss = RayMiss +furthest RayMiss _ = RayMiss +furthest a@(RayHit !da _ _ _) b@(RayHit !db _ _ _) = if da > db - then RayHit da pa na ta - else RayHit db pb nb tb + then a + else b -- | Test if a Rayint is a hit or a miss hit :: Rayint -> Bool @@ -497,7 +501,7 @@ inside_instance :: Instance -> Vec -> Bool inside_instance (Instance s xfm) pt = - inside s (xfm_point xfm pt) + inside s (invxfm_point xfm pt) bound_instance :: Instance -> Bbox bound_instance (Instance sld xfm) = diff --git a/Data/Glome/Spd.hs b/Data/Glome/Spd.hs --- a/Data/Glome/Spd.hs +++ b/Data/Glome/Spd.hs @@ -121,11 +121,11 @@ -- "l" X Y Z [R G B] readsSpdLight :: ReadS Light -readsSpdLight s = [((Light pos clr),s3) | ("l", s1) <- lexcr s, +readsSpdLight s = [((light pos clr),s3) | ("l", s1) <- lexcr s, (pos, s2) <- reads s1 :: [(Vec,String)], (clr, s3) <- reads s2 :: [(Color,String)] ] ++ - [((Light pos (Color 1 1 1)),s2) | ("l", s1) <- lexcr s, + [((light pos (Color 1 1 1)),s2) | ("l", s1) <- lexcr s, (pos, s2) <- reads s1 :: [(Vec,String)] ] instance Read Light where readsPrec _ = readsSpdLight diff --git a/Data/Glome/Sphere.hs b/Data/Glome/Sphere.hs --- a/Data/Glome/Sphere.hs +++ b/Data/Glome/Sphere.hs @@ -5,6 +5,7 @@ import Data.Glome.Vec import Data.Glome.Solid +-- | center, radius, 1/radius data Sphere = Sphere !Vec !Flt !Flt deriving Show @@ -18,13 +19,11 @@ rayint_sphere (Sphere center r invr) (Ray e dir) dist t = let eo = vsub center e v = vdot eo dir + vsqr = v*v + csqr = vdot eo eo + rsqr = r*r + disc = rsqr - (csqr - vsqr) in - if (dist >= (v - r)) && (v > 0.0) - then - let vsqr = v*v - csqr = vdot eo eo - rsqr = r*r - disc = rsqr - (csqr - vsqr) in if disc < 0.0 then RayMiss else @@ -38,8 +37,7 @@ -- n = vsub (vscale p invr) (vscale center invr) in n = vnorm (vsub p center) in RayHit hitdist p n t - else - RayMiss + packetint_sphere :: Sphere -> Ray -> Ray -> Ray -> Ray -> Flt -> Texture -> PacketResult packetint_sphere s !r1 !r2 !r3 !r4 !d t = diff --git a/Data/Glome/Trace.hs b/Data/Glome/Trace.hs --- a/Data/Glome/Trace.hs +++ b/Data/Glome/Trace.hs @@ -73,34 +73,33 @@ s = sld scn lights = lits scn direct = foldl' cadd c_black - (map (\ (Light lp lc) -> + (map (\ (Light lp lc lexp lrad lshadow) -> let eyedir = vinvert indir lvec = vsub lp p llen = vlen lvec ldir = vscale lvec (1.0/llen) halfangle = bisect ldir eyedir ldotn = fmax 0 $ vdot ldir n - -- blinn = fmax 0 ((vdot halfangle n)**(shine*3)) - blinn = fmax 0 $ ((vdot halfangle n) ** shine) * ldotn - blinn_correct = if isNaN blinn then 0 else blinn + blinn = if ks <= delta + then 0 + else let b = fmax 0 $ ((vdot halfangle n) ** shine) * ldotn + in if isNaN b then 0 else b -- indotn = fmax 0 $ vdot eyedir n - intensity = 5.0 / (llen*llen) + intensity = llen ** lexp --intensity = 0.2 in if vdot n lvec < 0 then c_black else - if not $ shadow s (Ray (vscaleadd p n delta) ldir) (llen-(2*delta)) - then - cadd - -- diffuse - --c_black - (cmul clr $ cscale lc $ ldotn * intensity) - -- blinn/torrance-sparrow highlight (pbrt p 440) - (cscale lc $ blinn_correct * intensity * ks) - -- c_black - else - c_black) lights) + if llen > lrad || (lshadow && shadow s (Ray (vscaleadd p n delta) ldir) (llen-(2*delta))) + then c_black + else + (cadd + -- diffuse + (cmul clr (cscale lc (ldotn * intensity * kd))) + -- blinn/torrance-sparrow highlight (pbrt p 440) + (cscale lc (blinn * intensity * ks)) )) + lights) reflect_ = if (refl_ > delta) && (recurs > 0) then let outdir = reflect indir n diff --git a/Data/Glome/Triangle.hs b/Data/Glome/Triangle.hs --- a/Data/Glome/Triangle.hs +++ b/Data/Glome/Triangle.hs @@ -1,7 +1,9 @@ -module Data.Glome.Triangle where +module Data.Glome.Triangle (triangle, triangles, trianglenorm, trianglesnorms) where import Data.Glome.Vec import Data.Glome.Solid +import Data.List(foldl1') + -- Simple triangles, and triangles with normal vectors -- specified at each vertex. @@ -139,3 +141,4 @@ inside _ _ = False bound = bound_trianglenorm transform = transform_trianglenorm + diff --git a/GlomeTrace.cabal b/GlomeTrace.cabal --- a/GlomeTrace.cabal +++ b/GlomeTrace.cabal @@ -1,5 +1,5 @@ Name: GlomeTrace -Version: 0.1.2 +Version: 0.2 Synopsis: Ray Tracing Library Description: A ray tracing library with acceleration structure and many supported primitives. License: GPL @@ -11,11 +11,13 @@ Stability: experimental Category: graphics build-type: Simple -Cabal-Version: >= 1.2 +Cabal-Version: >= 1.2.3 extra-source-files: README.txt - library + ghc-options: -fllvm -O2 -funbox-strict-fields + ghc-prof-options: -prof -auto-all + extensions: UnboxedTuples exposed-modules: Data.Glome.Trace Data.Glome.Scene Data.Glome.Clr @@ -31,4 +33,4 @@ Data.Glome.Tex Data.Glome.Triangle - Build-Depends: base >= 3 && < 4, array, GlomeVec >= 0.1.2 + Build-Depends: base >= 4 && < 5, array, GlomeVec >= 0.1.2 diff --git a/README.txt b/README.txt --- a/README.txt +++ b/README.txt @@ -1,12 +1,11 @@ This is GlomeTrace, a ray tracing library. Originally, it was part of Glome-hs, my haskell ray tracer. I decided to pull out the code to trace rays against objects and distribute it as a stand-alone library so that other projects can use it. -Glome-hs required HOpenGL, but only for display. Since this library is separated from any notion of display, it does not require HOpenGL, so it should run on more platforms than Glome-hs did. - -A good source of documentation is the Haskell wiki. In particular, take a look at the tutorial I wrote for Glome-hs. A few things have changed, but most of the descriptions there are still valid. +A good source of documentation is the Haskell wiki. In particular, take a look at the tutorial I wrote for Glome-hs. A few things have changed, but most of the descriptions there are still mostly valid. -I have begun to add haddock documentation to the actual code. +If you're installing from a tarball, the usual commands will suffice: +runhaskell Setup configure; runhaskell Setup build; runhaskell Setup install -You will need to install GlomeVec first (or have cabal fetch it automatically). +Note that GlomeTrace requires GlomeVec, a vector math library. http://www.haskell.org/haskellwiki/Glome