diff --git a/Bih.hs b/Bih.hs --- a/Bih.hs +++ b/Bih.hs @@ -3,6 +3,10 @@ import Solid import Data.List hiding (group) -- for "partition" +import Control.Concurrent.MVar +import System.IO.Unsafe + + -- Bounding Interval Heirarchy -- http://en.wikipedia.org/wiki/Bounding_interval_hierarchy @@ -122,13 +126,50 @@ (if dl < far then traverse l (fmax dl near) far else RayMiss)) + in + traverse root near far +rayint_debug_bih :: Bih -> Ray -> Flt -> Texture -> (Rayint,Int) +rayint_debug_bih (Bih bb root) r d t = + let Ray orig dir = r + 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 + dr = (rsplit - o) * dirr + in + debug_wrap + (if near > far + then (RayMiss,0) + else + if dirr > 0 + then + (nearest_debug + (if near < dl + then traverse l near (fmin dl far) + else (RayMiss,0)) + (if dr < far + then traverse r (fmax dr near) far + else (RayMiss,0))) + else + (nearest_debug + (if near < dr + then traverse r near (fmin dr far) + else (RayMiss,0)) + (if dl < far + then traverse l (fmax dl near) far + else (RayMiss,0)))) + 1 in traverse root near far -- This is unwieldy, but the performance gains -- make it worthwhile. By testing 4 rays against --- each cell, we do 1/4 the memory accesses. +-- each cell, we (theoretically) do ~1/4 the +-- memory accesses. -- One simplifying assumption we make that adds a -- little bit of overhead: If one ray hits a cell, @@ -136,7 +177,7 @@ -- this only works well with coherent rays. packetint_bih :: Bih -> Ray -> Ray -> Ray -> Ray -> Flt -> Texture -> PacketResult -packetint_bih (Bih bb root) r1 r2 r3 r4 d t = +packetint_bih (Bih bb root) !r1 !r2 !r3 !r4 !d t = let bih = Bih bb root Ray orig1 dir1 = r1 Ray orig2 dir2 = r2 @@ -276,9 +317,16 @@ bound_bih :: Bih -> Bbox bound_bih (Bih bb root) = bb +primcount_bih :: Bih -> Pcount +primcount_bih (Bih bb root) = pcadd (bihcount root) pcsinglebound + where bihcount (BihLeaf s) = primcount s + bihcount (BihBranch _ _ _ l r) = pcadd (pcadd (bihcount l) (bihcount r)) pcsinglebound + instance Solid Bih where rayint = rayint_bih + rayint_debug = rayint_debug_bih packetint = packetint_bih shadow = shadow_bih inside = inside_bih bound = bound_bih + primcount = primcount_bih diff --git a/Bound.hs b/Bound.hs --- a/Bound.hs +++ b/Bound.hs @@ -26,6 +26,13 @@ then rayint sb r d t else RayMiss +rayint_debug_bound :: Bound -> Ray -> Flt -> Texture -> (Rayint,Int) +rayint_debug_bound (Bound sa sb) r d t = + let (Ray orig _) = r + in if inside sa orig || shadow sa r d + then (debug_wrap (rayint_debug sb r d t) 1) + else (RayMiss,0) + shadow_bound :: Bound -> Ray -> Flt -> Bool shadow_bound (Bound sa sb) r d = let (Ray orig _ ) = r @@ -45,12 +52,22 @@ -- build an automatic bounding hierarchy rather than -- a manual one) -flatten_transform_bound :: Bound -> SolidItem +transform_leaf_bound :: Bound -> [Xfm] -> SolidItem +transform_leaf_bound (Bound sa sb) xfms = + transform_leaf sb xfms + +flatten_transform_bound :: Bound -> [SolidItem] flatten_transform_bound (Bound sa sb) = flatten_transform sb +primcount_bound :: Bound -> Pcount +primcount_bound (Bound sa sb) = pcadd (asbound (primcount sa)) (primcount sb) + instance Solid Bound where rayint = rayint_bound + rayint_debug = rayint_debug_bound shadow = shadow_bound inside = inside_bound bound = bound_bound flatten_transform = flatten_transform_bound + transform_leaf = transform_leaf_bound + primcount = primcount_bound diff --git a/Csg.hs b/Csg.hs --- a/Csg.hs +++ b/Csg.hs @@ -92,12 +92,20 @@ then empty_bbox else foldl' bboverlap everything_bbox (map bound slds) +primcount_difference :: Difference -> Pcount +primcount_difference (Difference sa sb) = pcadd (primcount sa) (primcount sb) + +primcount_intersection :: Intersection -> Pcount +primcount_intersection (Intersection slds) = foldl (pcadd) pcnone (map primcount slds) + instance Solid Difference where rayint = rayint_difference inside = inside_difference bound = bound_difference + primcount = primcount_difference instance Solid Intersection where rayint = rayint_intersection inside = inside_intersection bound = bound_intersection + primcount = primcount_intersection diff --git a/Glome.hs b/Glome.hs --- a/Glome.hs +++ b/Glome.hs @@ -26,7 +26,7 @@ dir = vnorm $ vadd3 fwd (vscale right (-x)) (vscale up y) ray = (Ray pos dir) in - Trace.trace_depth scn ray infinity maxdepth + ((Trace.trace scn ray infinity maxdepth),0) -- compute a packet of four rays from corners of box get_packet :: Flt -> Flt -> Flt -> Flt -> Scene -> PacketColor @@ -91,7 +91,7 @@ (Scene.Color r2 g2 b2) (Scene.Color r3 g3 b3) (Scene.Color r4 g4 b4) = get_packet (scx1*(midx/midy)) scy1 - (scx2*(midx/midy)) scy2 scene + (scx2*(midx/midy)) scy2 scene in [(scx1,scy1,r1,g1,b1,0), (scx2,scy1,r2,g2,b2,0), @@ -135,7 +135,7 @@ print $ "recognized options: " ++ (show (length flags)) t1 <- getPOSIXTime scene <- getscene flags - -- print $ "(primitives,transforms,bounding objects): " ++ (show (primcount_scene scene)) + print $ "(primitives,transforms,bounding objects): " ++ (show (primcount_scene scene)) t2 <- getPOSIXTime print $ "scene setup: " ++ (show (t2-t1)) let sx = 720 :: GLsizei diff --git a/Scene.hs b/Scene.hs --- a/Scene.hs +++ b/Scene.hs @@ -1,6 +1,7 @@ module Scene (Scene(Scene), Light(Light), Camera(Camera), scene, camera, light, sld, lits, cam, dtex, bground, + primcount_scene, module Clr, module Vec, module Solid, @@ -66,6 +67,9 @@ scene :: SolidItem -> [Light] -> Camera -> Texture -> Color -> Scene scene s l cam t clr = Scene s l cam t clr + +primcount_scene :: Scene -> Pcount +primcount_scene (Scene sld _ _ _ _) = primcount sld {- default_scene = (Scene (sphere (vec 0.0 0.0 0.0) 1.0) diff --git a/Solid.hs b/Solid.hs --- a/Solid.hs +++ b/Solid.hs @@ -88,21 +88,21 @@ depth :: !Flt, pos :: !Vec, norm :: !Vec, - texture :: !Texture + texture :: Texture } | RayMiss deriving Show nearest :: Rayint -> Rayint -> Rayint nearest a RayMiss = a nearest RayMiss b = b -nearest (RayHit da pa na ta) (RayHit db pb nb tb) = +nearest !(RayHit da pa na ta) !(RayHit db pb nb tb) = if da < db then RayHit da pa na ta else RayHit db pb nb tb furthest :: Rayint -> Rayint -> Rayint -furthest a RayMiss = RayMiss -furthest RayMiss b = RayMiss -furthest (RayHit da pa na ta) (RayHit db pb nb tb) = +furthest !a !RayMiss = RayMiss +furthest !RayMiss !b = RayMiss +furthest !(RayHit da pa na ta) !(RayHit db pb nb tb) = if da > db then RayHit da pa na ta else RayHit db pb nb tb @@ -116,12 +116,12 @@ dist (RayHit d _ _ _) = d --Packet Types-- -data PacketResult = PacketResult Rayint Rayint Rayint Rayint +data PacketResult = PacketResult !Rayint !Rayint !Rayint !Rayint packetmiss = PacketResult RayMiss RayMiss RayMiss RayMiss nearest_packetresult :: PacketResult -> PacketResult -> PacketResult -nearest_packetresult (PacketResult a1 a2 a3 a4) (PacketResult b1 b2 b3 b4) = +nearest_packetresult !(PacketResult a1 a2 a3 a4) !(PacketResult b1 b2 b3 b4) = PacketResult (nearest a1 b1) (nearest a2 b2) (nearest a3 b3) @@ -176,31 +176,66 @@ shine = intp m1shine m2shine in (Material c refl refr ior kd shine) +--utility functions for "primcount" +newtype Pcount = Pcount (Int,Int,Int) deriving Show + +pcadd :: Pcount -> Pcount -> Pcount +pcadd (Pcount (a1,a2,a3)) (Pcount (b1,b2,b3)) = Pcount (a1+b1, a2+b2, a3+b3) + +asbound :: Pcount -> Pcount +asbound (Pcount (a,b,c)) = Pcount (0,b,a+c) + +pcsinglexfm :: Pcount +pcsinglexfm = Pcount (0,1,0) + +pcsingleprim :: Pcount +pcsingleprim = Pcount (1,0,0) + +pcsinglebound :: Pcount +pcsinglebound = Pcount (0,0,1) + +pcnone :: Pcount +pcnone = Pcount (0,0,0) + +-- utility functions for rayint_debug +debug_wrap :: (Rayint,Int) -> Int -> (Rayint,Int) +debug_wrap (ri,a) b = (ri,(a+b)) + +nearest_debug :: (Rayint,Int) -> (Rayint,Int) -> (Rayint,Int) +nearest_debug (ari, an) (bri, bn) = ((nearest ari bri),(an+bn)) + --SOLID CLASS-- class (Show a) => Solid a where rayint :: a -> Ray -> Flt -> Texture -> Rayint + rayint_debug :: a -> Ray -> Flt -> Texture -> (Rayint, Int) packetint :: a -> Ray -> Ray -> Ray -> Ray -> Flt -> Texture -> PacketResult shadow :: a -> Ray -> Flt -> Bool inside :: a -> Vec -> Bool bound :: a -> Bbox tolist :: a -> [SolidItem] transform :: a -> [Xfm] -> SolidItem - flatten_transform :: a -> SolidItem + transform_leaf :: a -> [Xfm] -> SolidItem + flatten_transform :: a -> [SolidItem] + primcount :: a -> Pcount + -- This is for counting bih split planes ands the like. + -- We have to provide an implementation for most composite + -- primitives. + rayint_debug s !r !d t = ((rayint s r d t),0) + -- Sometimes, we can improve performance by -- intersecting 4 rays at once. This is -- especially true of acceleration structures. -- By default, we fall back on mono-rays. - - packetint s r1 r2 r3 r4 d t = + packetint s !r1 !r2 !r3 !r4 !d t = PacketResult (rayint s r1 d t) (rayint s r2 d t) (rayint s r3 d t) (rayint s r4 d t) -- if there is no shadow function, we fall back on rayint - shadow s r d = + shadow s !r !d = case (rayint s r d t_white) of RayHit _ _ _ _ -> True RayMiss -> False @@ -215,24 +250,40 @@ -- collapse the two transformations into a sigle transform. transform a xfm = SolidItem $ Instance (SolidItem a) (compose xfm) + -- This is used by flatten_transform below. For simple objects, it + -- works the same as transform, but for groups it transforms all the + -- objects individually. + transform_leaf = transform + -- This prepares a composite primitive to be fed into the bih constructor -- by pushing all the transformations out to the leaves and - -- throwing away manual bounding structures. - flatten_transform a = SolidItem a + -- throwing away manual bounding structures. For simple primitives, this + -- is a no-op. + flatten_transform = tolist ---Existential type so we can make a heterogeneous list of solids ---http://notes-on-haskell.blogspot.com/2007/01/proxies-and-delegation-vs-existential.html + -- Figure out how complicated the scene really is. + -- Returns (primitives, matricies, bounding objects/planes). + -- Also, it forces the full construction of acceleration structures. + primcount s = pcsingleprim +-- Existential type so we can make a heterogeneous list of solids, +-- and embed them in composite types. +-- http://notes-on-haskell.blogspot.com/2007/01/proxies-and-delegation-vs-existential.html + data SolidItem = forall a. Solid a => SolidItem a instance Solid SolidItem where - rayint (SolidItem s) r d t = rayint s r d t - shadow (SolidItem s) r d = shadow s r d + rayint (SolidItem s) !r !d t = rayint s r d t + packetint (SolidItem s) !r1 !r2 !r3 !r4 !d t = packetint s r1 r2 r3 r4 d t + rayint_debug (SolidItem s) r d t = rayint_debug s r d t + shadow (SolidItem s) !r !d = shadow s r d inside (SolidItem s) pt = inside s pt bound (SolidItem s) = bound s - tolist s = [s] -- don't wrap in a redundant SolidItem like everything else + tolist (SolidItem s) = tolist s -- don't wrap in a redundant SolidItem like everything else transform (SolidItem s) xfm = transform s xfm -- same here - flatten_transform (SolidItem s) = (SolidItem (flatten_transform s)) -- and here + transform_leaf (SolidItem s) xfm = transform_leaf s xfm -- and here + flatten_transform (SolidItem s) = [SolidItem (flatten_transform s)] -- and here + primcount (SolidItem s) = primcount s instance Show SolidItem where show (SolidItem s) = "SI " ++ show s @@ -255,10 +306,22 @@ -- this lets us treat lists of SolidItems as regular Solids rayint_group :: [SolidItem] -> Ray -> Flt -> Texture -> Rayint rayint_group [] _ _ _ = RayMiss -rayint_group (x:xs) r d t = nearest (rayint x r d t) (rayint_group xs r d t) +rayint_group (x:xs) !r !d t = nearest (rayint x r d t) (rayint_group xs r d t) +packetint_group :: [SolidItem] -> Ray -> Ray -> Ray -> Ray -> Flt -> Texture -> PacketResult +packetint_group [] !r1 !r2 !r3 !r4 !d t = packetmiss +packetint_group (x:xs) !r1 !r2 !r3 !r4 !d t = + nearest_packetresult (packetint x r1 r2 r3 r4 d t) + (packetint_group xs r1 r2 r3 r4 d t) + +rayint_debug_group :: [SolidItem] -> Ray -> Flt -> Texture -> (Rayint,Int) +rayint_debug_group [] _ _ _ = (RayMiss,0) +rayint_debug_group (x:xs) !r !d t = + nearest_debug (rayint_debug x r d t) + (rayint_debug_group xs r d t) + shadow_group :: [SolidItem] -> Ray -> Flt -> Bool -shadow_group [] r d = False +shadow_group [] !r !d = False shadow_group (x:xs) r d = (shadow x r d) || (shadow_group xs r d) inside_group :: [SolidItem] -> Vec -> Bool @@ -269,16 +332,24 @@ bound_group slds = foldl' bbjoin empty_bbox (map bound slds) -flatten_transform_group :: [SolidItem] -> SolidItem -flatten_transform_group slds = - SolidItem $ map flatten_transform slds +transform_leaf_group :: [SolidItem] -> [Xfm] -> SolidItem +transform_leaf_group slds xfms = + SolidItem $ map (\x -> transform_leaf x xfms) (tolist slds) +primcount_group :: [SolidItem] -> Pcount +primcount_group slds = foldl (pcadd) (Pcount (0,0,0)) (map primcount slds) + instance Solid [SolidItem] where rayint = rayint_group + packetint = packetint_group + rayint_debug = rayint_debug_group shadow = shadow_group inside = inside_group bound = bound_group tolist a = concat $ map tolist a + transform_leaf = transform_leaf_group + flatten_transform a = concat $ map flatten_transform a + primcount = primcount_group -- VOID -- -- non-object (originally called "Nothing", but that @@ -289,12 +360,13 @@ nothing = SolidItem Void instance Solid Void where - rayint Void r d t = RayMiss - shadow Void r d = False - inside Void pt = False + rayint Void _ _ _ = RayMiss + packetint Void _ _ _ _ _ _ = packetmiss + shadow Void _ _ = False + inside Void _ = False bound Void = empty_bbox - tolist Void = [] - + tolist Void = [] + transform Void xfms = SolidItem Void -- INSTANCE -- -- this would be better in its own module, but we need @@ -331,6 +403,59 @@ (vnorm (invxfm_norm xfm n)) tex +packetint_instance :: Instance -> Ray -> Ray -> Ray -> Ray -> Flt -> Texture -> PacketResult +packetint_instance (Instance sld xfm) !(Ray orig1 dir1) !(Ray orig2 dir2) + !(Ray orig3 dir3) !(Ray orig4 dir4) d t = + let newdir1 = invxfm_vec xfm dir1 + newdir2 = invxfm_vec xfm dir2 + newdir3 = invxfm_vec xfm dir3 + newdir4 = invxfm_vec xfm dir4 + neworig1 = invxfm_point xfm orig1 + neworig2 = invxfm_point xfm orig2 + neworig3 = invxfm_point xfm orig3 + neworig4 = invxfm_point xfm orig4 + lenscale1 = vlen newdir1 + lenscale2 = vlen newdir2 + lenscale3 = vlen newdir3 + lenscale4 = vlen newdir4 + invlenscale1 = 1/lenscale1 + invlenscale2 = 1/lenscale2 + invlenscale3 = 1/lenscale3 + invlenscale4 = 1/lenscale4 + in + let pr = packetint sld (Ray neworig1 (vscale newdir1 invlenscale1)) + (Ray neworig2 (vscale newdir2 invlenscale2)) + (Ray neworig3 (vscale newdir3 invlenscale3)) + (Ray neworig4 (vscale newdir4 invlenscale4)) + (d*lenscale1) t + PacketResult ri1 ri2 ri3 ri4 = pr + fix ri ils = + case ri of + RayMiss -> RayMiss + RayHit depth pos n tex -> RayHit (depth*ils) + (xfm_point xfm pos) + (vnorm (invxfm_norm xfm n)) + tex + in PacketResult (fix ri1 invlenscale1) + (fix ri2 invlenscale2) + (fix ri3 invlenscale3) + (fix ri4 invlenscale4) + +-- ugh, code duplication +rayint_debug_instance :: Instance -> Ray -> Flt -> Texture -> (Rayint,Int) +rayint_debug_instance (Instance sld xfm) (Ray orig dir) d t = + let newdir = invxfm_vec xfm dir + neworig = invxfm_point xfm orig + lenscale = vlen newdir + invlenscale = 1/lenscale + in + case (rayint_debug sld (Ray neworig (vscale newdir invlenscale)) (d*lenscale) t) of + (RayMiss, count) -> (RayMiss, count) + (RayHit depth pos n tex, count) -> (RayHit (depth*invlenscale) + (xfm_point xfm pos) + (vnorm (invxfm_norm xfm n)) + tex, count) + shadow_instance :: Instance -> Ray -> Flt -> Bool shadow_instance (Instance sld xfm) (Ray orig dir) d = let newdir = invxfm_vec xfm dir @@ -365,6 +490,10 @@ transform_instance (Instance s xfm2) xfm1 = transform s [compose ([xfm2]++xfm1) ] +transform_leaf_instance :: Instance -> [Xfm] -> SolidItem +transform_leaf_instance (Instance s xfm2) xfm1 = + transform_leaf s [compose ([xfm2]++xfm1) ] + -- Flatten_transform attempts to push all transformations -- in a heirarchy out to the leaf nodes. The case we're -- interested in here is an instance of a group, and we @@ -372,14 +501,22 @@ -- transformed instances. This could be construed as a -- waste of memory, but in some cases it's necessary. -flatten_transform_instance :: Instance -> SolidItem +flatten_transform_instance :: Instance -> [SolidItem] flatten_transform_instance (Instance s xfm) = - group $ map (\x -> transform (flatten_transform x) [xfm]) (tolist s) + [SolidItem $ transform_leaf s [xfm]] + -- group $ map (\x -> transform (flatten_transform x) [xfm]) (tolist s) +primcount_instance :: Instance -> Pcount +primcount_instance (Instance s xfm) = pcadd (primcount s) pcsinglexfm + instance Solid Instance where rayint = rayint_instance + packetint = packetint_instance + rayint_debug = rayint_debug_instance shadow = shadow_instance inside = inside_instance bound = bound_instance transform = transform_instance + transform_leaf = transform_leaf_instance flatten_transform = flatten_transform_instance + primcount = primcount_instance diff --git a/Sphere.hs b/Sphere.hs --- a/Sphere.hs +++ b/Sphere.hs @@ -2,7 +2,7 @@ import Vec import Solid -data Sphere = Sphere Vec Flt Flt deriving Show +data Sphere = Sphere !Vec !Flt !Flt deriving Show sphere :: Vec -> Flt -> SolidItem sphere c r = diff --git a/TestScene.hs b/TestScene.hs --- a/TestScene.hs +++ b/TestScene.hs @@ -63,9 +63,9 @@ else let year :: Int = floor age season = age-(fromIntegral year) - thickness = 0.025 - minbranch = deg 12 - maxbranch = deg 18 + thickness = 0.03 + minbranch = deg 10 + maxbranch = deg 25 tree 0 r = nothing tree 1 r = -- cone (Vec 0 0 0) thickness (Vec 0 season 0) 0 tex (sphere (Vec 0 0 0) season) (t_matte (Color 0.2 1 0.4)) @@ -75,7 +75,7 @@ (rng3,rng4) = split rng1 (r1,rng5) = randomR (0,0.5) rng4 (r2,rng6) = randomR (minbranch,maxbranch) rng5 - (r3,rng7) = randomR (0.75,0.95) rng6 + (r3,rng7) = randomR (0.8,0.95) rng6 (r4,rng8) = randomR (0.0,1.0) rng7 seglen = 0.5 + r1 branchang = r2 @@ -98,7 +98,7 @@ (rotate (Vec 0 1 0) (deg 30)), (translate (Vec 0 seglen 0))] ]) - in tex (bih (tolist (flatten_transform (tree year rng)))) (t_matte (Color 0.8 0.5 0.4)) + in tex (bih (tolist (SolidItem (flatten_transform (tree year rng))))) (t_matte (Color 0.8 0.5 0.4)) sphereint = intersection [ (sphere (Vec (-1) 0 0) 2), (sphere (Vec 1 0 0) 2), @@ -106,11 +106,10 @@ (sphere (Vec 0 1 0) 2) ] geom = group [ tex (plane (Vec 0 0 0) (Vec 0 1 0)) (t_matte (Color 0 0.8 0.3)) - , bih [ tex (dodecahedron (Vec (-6) 3 0) 1) t_stripe - , tex (transform (icosahedron (Vec 4 1.5 3) 1.5) [rotate vz (deg 11) - ,rotate vx (deg 7) ] ) t_mottled - - , transform (oak 4.6 (mkStdGen 42)) [ scale (Vec 1.5 1.5 1.5)] + , bih [tex (dodecahedron (Vec (-6) 3 0) 1) t_stripe + , tex (transform (icosahedron (Vec 4 1.5 3) 1.5) [ rotate vz (deg 11) + , rotate vx (deg 7) ] ) t_mottled + , transform (oak 11.6 (mkStdGen 42)) [ scale (Vec 1.5 1.5 1.5)] , tex (transform (coil) [ scale (Vec (1/3) (1/3) (1/3)) , rotate (Vec 0 1 0) (deg 65) , translate (Vec (-3.5) 1 (5)) @@ -122,8 +121,13 @@ ] ] -cust_cam = camera (vec (-2) (5.3) (20)) (vec 0 5 0) (vec 0 1 0) 45 - +geom1 = group [ (box (Vec (-1) (-1) (-1)) (Vec 1 1 1)), + (group [ (sphere (Vec 2 3 0) 1), + (sphere (Vec (-3) (4) 1) 0.8) ]) ] + +-- cust_cam = camera (vec (-2) (5.3) (20)) (vec 0 5 0) (vec 0 1 0) 45 +cust_cam = camera (vec (-2) (4.3) (15)) (vec 0 2 0) (vec 0 1 0) 45 + -- some textures m_shiny_white :: Material m_shiny_white = (Material c_white 0.3 0 0 0.7 10) diff --git a/Tex.hs b/Tex.hs --- a/Tex.hs +++ b/Tex.hs @@ -27,6 +27,9 @@ rayint_tex :: Tex -> Ray -> Flt -> Texture -> Rayint rayint_tex (Tex s tex) r d t = rayint s r d tex +rayint_debug_tex :: Tex -> Ray -> Flt -> Texture -> (Rayint,Int) +rayint_debug_tex (Tex s tex) r d t = rayint_debug s r d tex + packetint_tex :: Tex -> Ray -> Ray -> Ray -> Ray -> Flt -> Texture -> PacketResult packetint_tex (Tex s tx) r1 r2 r3 r4 d t = packetint s r1 r2 r3 r4 d tx @@ -39,9 +42,14 @@ bound_tex :: Tex -> Bbox bound_tex (Tex s _) = bound s +primcount_tex :: Tex -> Pcount +primcount_tex (Tex s _) = primcount s + instance Solid Tex where rayint = rayint_tex + rayint_debug = rayint_debug_tex packetint = packetint_tex shadow = shadow_tex inside = inside_tex bound = bound_tex + primcount = primcount_tex diff --git a/Trace.hs b/Trace.hs --- a/Trace.hs +++ b/Trace.hs @@ -122,6 +122,16 @@ clr = shade ri ray scn recurs 0 in (clr,p) +trace_debug :: Scene -> Ray -> Flt -> Int -> Color +trace_debug scn ray depth recurs = + let (Scene sld lights cam dtex bgcolor) = scn + (ri,n) = rayint_debug sld ray depth dtex + in + -- unsafePerformIO $ + -- do + -- print n + -- return $ + cadd (shade ri ray scn recurs 0) (Color 0 ((fromIntegral (Prelude.abs n)) * 0.01) 0) trace_packet :: Scene -> Ray -> Ray -> Ray -> Ray -> Flt -> Int -> PacketColor trace_packet scn ray1 ray2 ray3 ray4 depth recurs = diff --git a/Triangle.hs b/Triangle.hs --- a/Triangle.hs +++ b/Triangle.hs @@ -2,6 +2,9 @@ import Vec import Solid +-- Simple triangles, and triangles with normal vectors +-- specified at each vertex. + data Triangle = Triangle Vec Vec Vec deriving Show data TriangleNorm = TriangleNorm Vec Vec Vec Vec Vec Vec deriving Show @@ -104,12 +107,29 @@ bound_trianglenorm (TriangleNorm v1 v2 v3 n1 n2 n3) = bound (Triangle v1 v2 v3) +transform_triangle :: Triangle -> [Xfm] -> SolidItem +transform_triangle (Triangle p1 p2 p3) xfms = + SolidItem $ Triangle (xfm_point (compose xfms) p1) + (xfm_point (compose xfms) p2) + (xfm_point (compose xfms) p3) + +transform_trianglenorm :: TriangleNorm -> [Xfm] -> SolidItem +transform_trianglenorm (TriangleNorm p1 p2 p3 n1 n2 n3) xfms = + SolidItem $ TriangleNorm (xfm_point (compose xfms) p1) + (xfm_point (compose xfms) p2) + (xfm_point (compose xfms) p3) + (vnorm $ xfm_vec (compose xfms) n1) + (vnorm $ xfm_vec (compose xfms) n2) + (vnorm $ xfm_vec (compose xfms) n3) + instance Solid Triangle where rayint = rayint_triangle inside _ _ = False bound = bound_triangle + transform = transform_triangle instance Solid TriangleNorm where rayint = rayint_trianglenorm inside _ _ = False bound = bound_trianglenorm + transform = transform_trianglenorm diff --git a/Vec.hs b/Vec.hs --- a/Vec.hs +++ b/Vec.hs @@ -24,15 +24,15 @@ -- convert from degrees to native angle format (radians) deg :: Flt -> Flt -deg x = (x*3.1415926535897)/180 +deg !x = (x*3.1415926535897)/180 -- convert from radians (noop) rad :: Flt -> Flt -rad x = x +rad !x = x -- convert from rotations rot :: Flt -> Flt -rot x = x*3.1415926535897*2 +rot !x = x*3.1415926535897*2 {-abs_sub :: Flt -> Flt -> Flt abs_sub a b = @@ -83,10 +83,10 @@ else c fmin4 :: Flt -> Flt -> Flt -> Flt -> Flt -fmin4 a b c d = fmin (fmin a b) (fmin c d) +fmin4 !a !b !c !d = fmin (fmin a b) (fmin c d) fmax4 :: Flt -> Flt -> Flt -> Flt -> Flt -fmax4 a b c d = fmax (fmax a b) (fmax c d) +fmax4 !a !b !c !d = fmax (fmax a b) (fmax c d) fabs :: Flt -> Flt fabs !a = @@ -102,7 +102,7 @@ -- the (abs $ a-b) test doesn't work if -- a and b are large about_equal :: Flt -> Flt -> Bool -about_equal a b = +about_equal !a !b = if a > 1 then fabs (1 - (a/b)) < (delta*10) @@ -129,26 +129,28 @@ nvy = Vec 0 (-1) 0 nvz = Vec 0 0 (-1) +-- this actually accounts for a +-- noticeable amount of cpu time va :: Vec -> Int -> Flt -va (Vec x y z) !i = - case i of +va !(Vec x y z) !n = + case n of 0 -> x 1 -> y 2 -> z vset :: Vec -> Int -> Flt -> Vec -vset (Vec x y z) i f = +vset !(Vec x y z) !i !f = case i of 0 -> Vec f y z 1 -> Vec x f z 2 -> Vec x y f vdot :: Vec -> Vec -> Flt -vdot !(Vec !x1 !y1 !z1) !(Vec !x2 !y2 !z2) = +vdot !(Vec x1 y1 z1) !(Vec x2 y2 z2) = (x1*x2)+(y1*y2)+(z1*z2) vcross :: Vec -> Vec -> Vec -vcross !(Vec !x1 !y1 !z1) !(Vec !x2 !y2 !z2) = +vcross !(Vec x1 y1 z1) !(Vec x2 y2 z2) = Vec ((y1 * z2) - (z1 * y2)) ((z1 * x2) - (x1 * z2)) @@ -159,13 +161,13 @@ Vec (f (x v1)) (f (y v1)) (f (z v1)) vmap2 :: (Flt -> Flt -> Flt) -> Vec -> Vec -> Vec -vmap2 f v1 v2 = +vmap2 f !v1 !v2 = Vec (f (x v1) (x v2)) (f (y v1) (y v2)) (f (z v1) (z v2)) vinvert :: Vec -> Vec -vinvert (Vec !x1 !y1 !z1) = +vinvert !(Vec x1 y1 z1) = Vec (-x1) (-y1) (-z1) vlensqr :: Vec -> Flt @@ -175,55 +177,55 @@ vlen !v1 = sqrt (vdot v1 v1) vadd :: Vec -> Vec -> Vec -vadd !(Vec !x1 !y1 !z1) !(Vec !x2 !y2 !z2) = +vadd !(Vec x1 y1 z1) !(Vec x2 y2 z2) = Vec (x1 + x2) (y1 + y2) (z1 + z2) vadd3 :: Vec -> Vec -> Vec -> Vec -vadd3 !(Vec !x1 !y1 !z1) !(Vec !x2 !y2 !z2) !(Vec !x3 !y3 !z3) = +vadd3 !(Vec x1 y1 z1) !(Vec x2 y2 z2) !(Vec x3 y3 z3) = Vec (x1 + x2 + x3) (y1 + y2 + y3) (z1 + z2 + z3) vsub :: Vec -> Vec -> Vec -vsub !(Vec !x1 !y1 !z1) !(Vec !x2 !y2 !z2) = +vsub !(Vec x1 y1 z1) !(Vec x2 y2 z2) = Vec (x1 - x2) (y1 - y2) (z1 - z2) vmul :: Vec -> Vec -> Vec -vmul !(Vec !x1 !y1 !z1) !(Vec !x2 !y2 !z2) = +vmul !(Vec x1 y1 z1) !(Vec x2 y2 z2) = Vec (x1 * x2) (y1 * y2) (z1 * z2) vinc :: Vec -> Flt -> Vec -vinc v1 n = - Vec ((x v1) + n) - ((y v1) + n) - ((z v1) + n) +vinc !(Vec x y z) !n = + Vec (x + n) + (y + n) + (z + n) vdec :: Vec -> Flt -> Vec -vdec v1 n = - Vec ((x v1) - n) - ((y v1) - n) - ((z v1) - n) +vdec !(Vec x y z) !n = + Vec (x - n) + (y - n) + (z - n) vmax :: Vec -> Vec -> Vec -vmax (Vec x1 y1 z1) (Vec x2 y2 z2) = +vmax !(Vec x1 y1 z1) !(Vec x2 y2 z2) = Vec (fmax x1 x2) (fmax y1 y2) (fmax z1 z2) vmin :: Vec -> Vec -> Vec -vmin (Vec x1 y1 z1) (Vec x2 y2 z2) = +vmin !(Vec x1 y1 z1) !(Vec x2 y2 z2) = Vec (fmin x1 x2) (fmin y1 y2) (fmin z1 z2) vmaxaxis :: Vec -> Int -vmaxaxis !(Vec !x !y !z) = +vmaxaxis !(Vec x y z) = if (x > y) then if (x > z) then 0 @@ -233,19 +235,19 @@ else 2 vscale :: Vec -> Flt -> Vec -vscale !v1 !fac = - Vec ((x v1) * fac) - ((y v1) * fac) - ((z v1) * fac) +vscale !(Vec x y z) !fac = + Vec (x * fac) + (y * fac) + (z * fac) vscaleadd :: Vec -> Vec -> Flt -> Vec -vscaleadd !v1 !v2 fac = - Vec ((x v1) + ((x v2) * fac)) - ((y v1) + ((y v2) * fac)) - ((z v1) + ((z v2) * fac)) +vscaleadd !(Vec x1 y1 z1) !(Vec x2 y2 z2) fac = + Vec (x1 + (x2 * fac)) + (y1 + (y2 * fac)) + (z1 + (z2 * fac)) vnorm :: Vec -> Vec -vnorm (Vec x1 y1 z1) = +vnorm !(Vec x1 y1 z1) = let invlen = 1.0 / (sqrt ((x1*x1)+(y1*y1)+(z1*z1))) in Vec (x1*invlen) (y1*invlen) (z1*invlen) @@ -259,34 +261,34 @@ else v bisect :: Vec -> Vec -> Vec -bisect v1 v2 = vnorm (vadd v1 v2) +bisect !v1 !v2 = vnorm (vadd v1 v2) vdist :: Vec -> Vec -> Flt vdist v1 v2 = let d = vsub v2 v1 in vlen d reflect :: Vec -> Vec -> Vec -reflect v norm = +reflect !v !norm = -- vadd v $ vscale norm $ (-2) * (vdot v norm) vscaleadd v norm $ (-2) * (vdot v norm) vrcp :: Vec -> Vec -vrcp (Vec x y z) = +vrcp !(Vec x y z) = Vec (1/x) (1/y) (1/z) -- test for equality veq :: Vec -> Vec -> Bool -veq (Vec ax ay az) (Vec bx by bz) = +veq !(Vec ax ay az) !(Vec bx by bz) = (about_equal ax bx) && (about_equal ay by) && (about_equal az bz) --returns false on zero value veqsign :: Vec -> Vec -> Bool -veqsign (Vec ax ay az) (Vec bx by bz) = +veqsign !(Vec ax ay az) !(Vec bx by bz) = ax*bx > 0 && ay*by > 0 && az*bz > 0 -- translate a ray's origin in ray's direction by d amount ray_move :: Ray -> Flt -> Ray -ray_move (Ray orig dir) d = +ray_move !(Ray orig dir) !d = (Ray (vscaleadd orig dir d) dir) -- find orthogonal vectors @@ -308,13 +310,13 @@ -- defined by a point and a normal -- (ray need not be normalized) plane_int :: Ray -> Vec -> Vec -> Vec -plane_int (Ray orig dir) p norm = +plane_int !(Ray orig dir) !p !norm = let newo = vsub orig p dist = -(vdot norm newo) / (vdot norm dir) in vscaleadd orig dir dist plane_int_dist :: Ray -> Vec -> Vec -> Flt -plane_int_dist (Ray orig dir) p norm = +plane_int_dist !(Ray orig dir) !p !norm = let newo = vsub orig p in -(vdot norm newo) / (vdot norm dir) @@ -403,38 +405,38 @@ -- point is treated as (x y z 1) xfm_point :: Xfm -> Vec -> Vec -xfm_point (Xfm (Matrix m00 m01 m02 m03 - m10 m11 m12 m13 - m20 m21 m22 m23) inv) - (Vec x y z) = +xfm_point !(Xfm (Matrix m00 m01 m02 m03 + m10 m11 m12 m13 + m20 m21 m22 m23) inv) + !(Vec x y z) = Vec (m00*x + m01*y + m02*z + m03) (m10*x + m11*y + m12*z + m13) (m20*x + m21*y + m22*z + m23) invxfm_point :: Xfm -> Vec -> Vec -invxfm_point (Xfm fwd (Matrix i00 i01 i02 i03 - i10 i11 i12 i13 - i20 i21 i22 i23)) - (Vec x y z) = +invxfm_point !(Xfm fwd (Matrix i00 i01 i02 i03 + i10 i11 i12 i13 + i20 i21 i22 i23)) + !(Vec x y z) = Vec (i00*x + i01*y + i02*z + i03) (i10*x + i11*y + i12*z + i13) (i20*x + i21*y + i22*z + i23) -- vector is treated as (x y z 0) xfm_vec :: Xfm -> Vec -> Vec -xfm_vec (Xfm (Matrix m00 m01 m02 m03 - m10 m11 m12 m13 - m20 m21 m22 m23) inv) - (Vec x y z) = +xfm_vec !(Xfm (Matrix m00 m01 m02 m03 + m10 m11 m12 m13 + m20 m21 m22 m23) inv) + !(Vec x y z) = Vec (m00*x + m01*y + m02*z) (m10*x + m11*y + m12*z) (m20*x + m21*y + m22*z) invxfm_vec :: Xfm -> Vec -> Vec -invxfm_vec (Xfm fwd (Matrix i00 i01 i02 i03 - i10 i11 i12 i13 - i20 i21 i22 i23)) - (Vec x y z) = +invxfm_vec !(Xfm fwd (Matrix i00 i01 i02 i03 + i10 i11 i12 i13 + i20 i21 i22 i23)) + !(Vec x y z) = Vec (i00*x + i01*y + i02*z) (i10*x + i11*y + i12*z) (i20*x + i21*y + i22*z) @@ -442,19 +444,19 @@ -- this one is tricky -- we transform by the inverse transpose invxfm_norm :: Xfm -> Vec -> Vec -invxfm_norm (Xfm fwd (Matrix i00 i01 i02 i03 - i10 i11 i12 i13 - i20 i21 i22 i23)) - (Vec x y z) = +invxfm_norm !(Xfm fwd (Matrix i00 i01 i02 i03 + i10 i11 i12 i13 + i20 i21 i22 i23)) + !(Vec x y z) = Vec (i00*x + i10*y + i20*z) (i01*x + i11*y + i21*z) (i02*x + i12*y + i22*z) xfm_ray :: Xfm -> Ray -> Ray -xfm_ray xfm (Ray orig dir) = +xfm_ray !xfm !(Ray orig dir) = Ray (xfm_point xfm orig) (vnorm (xfm_vec xfm dir)) -invxfm_ray xfm (Ray orig dir) = +invxfm_ray !xfm !(Ray orig dir) = Ray (invxfm_point xfm orig) (vnorm (invxfm_vec xfm dir)) -- BASIC TRANSFORMS -- diff --git a/glome-hs.cabal b/glome-hs.cabal --- a/glome-hs.cabal +++ b/glome-hs.cabal @@ -1,5 +1,5 @@ Name: glome-hs -Version: 0.5 +Version: 0.51 Synopsis: ray tracer Description: Ray Tracer capable of rendering a variety of primitives, with support for CSG (difference and intersection of solids), @@ -13,7 +13,7 @@ Homepage: http://syn.cs.pdx.edu/~jsnow/glome Stability: experimental Category: graphics -Build-Depends: base,haskell98,time,parallel,GLUT,OpenGL,random,array,binary +Build-Depends: base,haskell98,time,parallel,GLUT,OpenGL,random,array build-type: Simple Executable: glome ghc-options: -fglasgow-exts -funbox-strict-fields -threaded diff --git a/make b/make --- a/make +++ b/make @@ -2,8 +2,8 @@ #rm *.o #ghc -O3 --make Glome.hs #ghc Glome.hs --make -O2 -threaded -fasm -optc-march=athlon64 -XFlexibleInstances -XTypeSynonymInstances -#ghc Glome.hs --make -O2 -fasm -fglasgow-exts -funbox-strict-fields -fbang-patterns -fexcess-precision -optc-ffast-math -optc-O2 -optc-mfpmath=sse -optc-msse2 -#ghc Glome.hs --make -fasm -fglasgow-exts -funbox-strict-fields -fbang-patterns -fexcess-precision -prof -auto-all +#ghc Glome.hs --make -O2 -fvia-c -fglasgow-exts -funbox-strict-fields -fbang-patterns -fexcess-precision -optc-ffast-math -optc-O2 -optc-mfpmath=sse -optc-msse2 +#ghc Glome.hs --make -O2 -fasm -fglasgow-exts -funbox-strict-fields -fbang-patterns -fexcess-precision -prof -auto-all runhaskell Setup.lhs configure --prefix=$HOME --user runhaskell Setup.lhs build diff --git a/run b/run --- a/run +++ b/run @@ -1,4 +1,4 @@ #!/bin/bash #./Glome +RTS -N2 -sstderr -RTS #./Glome +RTS -./dist/build/glome/glome +RTS -N2 +./dist/build/glome/glome