GlomeTrace 0.1.2 → 0.2
raw patch · 11 files changed
+281/−100 lines, 11 filesdep ~base
Dependency ranges changed: base
Files
- Data/Glome/Bih.hs +85/−40
- Data/Glome/Box.hs +19/−10
- Data/Glome/Csg.hs +119/−0
- Data/Glome/Scene.hs +6/−3
- Data/Glome/Solid.hs +15/−11
- Data/Glome/Spd.hs +2/−2
- Data/Glome/Sphere.hs +6/−8
- Data/Glome/Trace.hs +15/−16
- Data/Glome/Triangle.hs +4/−1
- GlomeTrace.cabal +6/−4
- README.txt +4/−5
Data/Glome/Bih.hs view
@@ -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)
Data/Glome/Box.hs view
@@ -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 =
Data/Glome/Csg.hs view
@@ -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--
Data/Glome/Scene.hs view
@@ -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}
Data/Glome/Solid.hs view
@@ -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) =
Data/Glome/Spd.hs view
@@ -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
Data/Glome/Sphere.hs view
@@ -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 =
Data/Glome/Trace.hs view
@@ -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
Data/Glome/Triangle.hs view
@@ -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+
GlomeTrace.cabal view
@@ -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
README.txt view
@@ -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