glome-hs 0.5 → 0.51
raw patch · 15 files changed
+380/−122 lines, 15 filesdep −binary
Dependencies removed: binary
Files
- Bih.hs +50/−2
- Bound.hs +18/−1
- Csg.hs +8/−0
- Glome.hs +3/−3
- Scene.hs +4/−0
- Solid.hs +168/−31
- Sphere.hs +1/−1
- TestScene.hs +16/−12
- Tex.hs +8/−0
- Trace.hs +10/−0
- Triangle.hs +20/−0
- Vec.hs +69/−67
- glome-hs.cabal +2/−2
- make +2/−2
- run +1/−1
Bih.hs view
@@ -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
Bound.hs view
@@ -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
Csg.hs view
@@ -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
Glome.hs view
@@ -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
Scene.hs view
@@ -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)
Solid.hs view
@@ -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
Sphere.hs view
@@ -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 =
TestScene.hs view
@@ -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)
Tex.hs view
@@ -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
Trace.hs view
@@ -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 =
Triangle.hs view
@@ -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
Vec.hs view
@@ -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 --
glome-hs.cabal view
@@ -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
make view
@@ -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
run view
@@ -1,4 +1,4 @@ #!/bin/bash #./Glome +RTS -N2 -sstderr -RTS #./Glome +RTS-./dist/build/glome/glome +RTS -N2+./dist/build/glome/glome