GlomeTrace 0.2 → 0.3
raw patch · 16 files changed
+777/−667 lines, 16 filesdep ~GlomeVec
Dependency ranges changed: GlomeVec
Files
- Data/Glome/Bih.hs +52/−29
- Data/Glome/Bound.hs +25/−15
- Data/Glome/Box.hs +13/−10
- Data/Glome/Clr.hs +78/−4
- Data/Glome/Cone.hs +33/−31
- Data/Glome/Csg.hs +62/−158
- Data/Glome/Plane.hs +12/−9
- Data/Glome/Scene.hs +4/−39
- Data/Glome/Shader.hs +165/−0
- Data/Glome/Solid.hs +150/−195
- Data/Glome/Spd.hs +34/−23
- Data/Glome/Sphere.hs +17/−15
- Data/Glome/Tex.hs +32/−26
- Data/Glome/Trace.hs +44/−94
- Data/Glome/Triangle.hs +53/−17
- GlomeTrace.cabal +3/−2
Data/Glome/Bih.hs view
@@ -28,6 +28,8 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Data.Glome.Bih (bih) where import Data.Glome.Vec@@ -38,15 +40,15 @@ -- Bounding Interval Heirarchy -- http://en.wikipedia.org/wiki/Bounding_interval_hierarchy -data Bih = Bih {bihbb :: Bbox, bihroot :: BihNode} deriving Show-data BihNode = BihLeaf !SolidItem +data Bih t m = Bih {bihbb :: Bbox, bihroot :: BihNode t m} deriving Show+data BihNode t m = BihLeaf !(SolidItem t m) | BihBranch {lmax :: !Flt, rmin :: !Flt, ax :: !Int, - l :: BihNode, r :: BihNode} deriving Show+ l :: BihNode t m, r :: BihNode t m} deriving Show -- bih construction -- create a leaf node from a list of objects -- we use "group" so we can treat a bunch of objects as a single object-build_leaf :: [(Bbox, SolidItem)] -> BihNode+build_leaf :: [(Bbox, SolidItem t m)] -> BihNode t m build_leaf objs = BihLeaf (group (map snd objs)) @@ -55,7 +57,7 @@ -- this doesn't seem to be much of a win -optimality :: [(Bbox, SolidItem)] -> Bbox -> Flt+optimality :: [(Bbox, SolidItem t m)] -> Bbox -> Flt optimality objs bb = let bbsurf = bbsa bb go [] accbb = accbb@@ -81,7 +83,7 @@ -- of small ones, we create one branch with big objects and the other with small -- objects, instead of sorting by location. -build_rec :: [(Bbox,SolidItem)] -> Bbox -> Bbox -> Int -> BihNode+build_rec :: [(Bbox, SolidItem t m)] -> Bbox -> Bbox -> Int -> BihNode t m build_rec objs nodebox@(Bbox nodeboxp1 nodeboxp2) splitbox@(Bbox splitboxp1 splitboxp2) depth = if (length (take 3 objs) < 2) -- && (optimality objs nodebox) > 0.2@@ -141,7 +143,7 @@ -- -- See http://en.wikipedia.org/wiki/Bounding_interval_hierarchy -bih :: [SolidItem] -> SolidItem+bih :: [SolidItem t m] -> SolidItem t m bih [] = SolidItem Void -- bih (sld:[]) = sld -- sometimes we'd like to be able to use a -- single object bih just for its aabb@@ -159,11 +161,11 @@ 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 =+rayint_bih' :: Bih tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_bih' (Bih bb root) !r@(Ray orig dir) !d t tags = let !dir_rcp = vrcp dir Interval !near !far = bbclip r bb- traverse (BihLeaf !s) !near !far = rayint s r (fmin d far) t+ traverse (BihLeaf !s) !near !far = rayint s r (fmin d far) t tags traverse (BihBranch !lsplit !rsplit !axis !l !r) near far = let !dirr = va dir_rcp axis !o = va orig axis@@ -193,16 +195,16 @@ in traverse root near far -miss :: Rayint+miss :: Rayint tag mat 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 =+rayint_bih :: Bih tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_bih (Bih !bb !root) !r !d t tags = 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 (BihLeaf !s) !near !far = {-# SCC bih_rayint_leaf #-} rayint s r far t tags 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 #)@@ -238,11 +240,11 @@ -- 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 =+rayint_debug_bih :: Bih tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> (Rayint tag mat, Int) +rayint_debug_bih (Bih bb root) r@(Ray orig dir) d t tags = 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 (BihLeaf !s) !near !far = rayint_debug s r (fmin d far) t tags traverse (BihBranch !lsplit !rsplit !axis !l !r) near far = let dirr = va dir_rcp axis o = va orig axis@@ -288,12 +290,12 @@ -- we act as though they all do. For that reason, -- this only works well with coherent rays. -packetint_bih :: Bih -> Ray -> Ray -> Ray -> Ray -> Flt -> Texture -> PacketResult+packetint_bih :: Bih tag mat -> Ray -> Ray -> Ray -> Ray -> Flt -> [Texture tag mat] -> [tag] -> PacketResult tag mat packetint_bih bih@(Bih bb root) !r1@(Ray orig1 dir1) !r2@(Ray orig2 dir2) !r3@(Ray orig3 dir3) - !r4@(Ray orig4 dir4) !d t =+ !r4@(Ray orig4 dir4) !d t tags = let !dir_rcp1 = vrcp dir1 !dir_rcp2 = vrcp dir2 !dir_rcp3 = vrcp dir3@@ -305,10 +307,10 @@ veqsign dir_rcp1 dir_rcp3 && veqsign dir_rcp1 dir_rcp4 then- PacketResult (rayint bih r1 d t)- (rayint bih r2 d t)- (rayint bih r3 d t)- (rayint bih r4 d t)+ PacketResult (rayint bih r1 d t tags)+ (rayint bih r2 d t tags)+ (rayint bih r3 d t tags)+ (rayint bih r4 d t tags) else let Interval !near1 !far1 = bbclip r1 bb Interval !near2 !far2 = bbclip r2 bb@@ -318,7 +320,7 @@ !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 (BihLeaf !s) !near !far = packetint s r1 r2 r3 r4 (fmin d far) t tags traverse (BihBranch !lsplit !rsplit !axis !l !r) !near !far = if near > far then packetmiss@@ -370,7 +372,7 @@ in traverse root near far -shadow_bih :: Bih -> Ray -> Flt -> Bool+shadow_bih :: Bih m t -> Ray -> Flt -> Bool 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@@ -410,7 +412,7 @@ -- We test if the point is inside any of the objects contained in -- the bih. -inside_bih :: Bih -> Vec -> Bool+inside_bih :: Bih t m -> 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) =@@ -427,17 +429,37 @@ (y > y1) && (y < y2) && (z > z1) && (z < z2) && (traverse root) +get_metainfo_bih (Bih (Bbox (Vec !x1 !y1 !z1) (Vec !x2 !y2 !z2)) root) pt@(Vec !x !y !z) =+ let traverse (BihLeaf !s) = get_metainfo s pt+ traverse (BihBranch !lsplit !rsplit !axis !l !r) =+ let o = va pt axis+ in (if o < lsplit+ then (traverse l)+ else ([],[])) + `paircat`+ (if o > rsplit + then (traverse r)+ else ([],[]))+ in+ if (x > x1) && (x < x2) && + (y > y1) && (y < y2) && + (z > z1) && (z < z2)+ then+ (traverse root)+ else+ ([],[])+ -- We already have a bounding box computed.-bound_bih :: Bih -> Bbox+bound_bih :: Bih t m -> Bbox bound_bih (Bih bb root) = bb -primcount_bih :: Bih -> Pcount+primcount_bih :: Bih t m -> 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+instance Solid (Bih t m) t m where rayint = rayint_bih rayint_debug = rayint_debug_bih packetint = packetint_bih@@ -445,3 +467,4 @@ inside = inside_bih bound = bound_bih primcount = primcount_bih+ get_metainfo = get_metainfo_bih
Data/Glome/Bound.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ module Data.Glome.Bound (bound_object) where import Data.Glome.Vec import Data.Glome.Solid@@ -14,7 +17,7 @@ -- The first SolidItem is the bounding object, the second -- is the bounded object.-data Bound = Bound SolidItem SolidItem deriving Show+data Bound t m = Bound (SolidItem t m) (SolidItem t m) deriving Show -- | Use the first object as a bounding volume for the second -- object. If a ray misses the first object, it is assumed to@@ -22,35 +25,41 @@ -- In general, bih will usually perform better than -- manually-constructed bounds, though. -bound_object :: SolidItem -> SolidItem -> SolidItem+bound_object :: SolidItem t m -> SolidItem t m -> SolidItem t m bound_object a b = SolidItem $ Bound a b -rayint_bound :: Bound -> Ray -> Flt -> Texture -> Rayint-rayint_bound (Bound sa sb) r d t =+rayint_bound :: Bound tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_bound (Bound sa sb) r d t tags = let (Ray orig _) = r in if inside sa orig || shadow sa r d- then rayint sb r d t+ then rayint sb r d t tags else RayMiss -rayint_debug_bound :: Bound -> Ray -> Flt -> Texture -> (Rayint,Int)-rayint_debug_bound (Bound sa sb) r d t =+rayint_debug_bound :: Bound tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> (Rayint tag mat, Int)+rayint_debug_bound (Bound sa sb) r d t tags = let (Ray orig _) = r in if inside sa orig || shadow sa r d- then (debug_wrap (rayint_debug sb r d t) 1)+ then (debug_wrap (rayint_debug sb r d t tags) 1) else (RayMiss,0) -shadow_bound :: Bound -> Ray -> Flt -> Bool+shadow_bound :: Bound t m -> Ray -> Flt -> Bool shadow_bound (Bound sa sb) r d = let (Ray orig _ ) = r in if inside sa orig || shadow sa r d then shadow sb r d else False -inside_bound :: Bound -> Vec -> Bool+inside_bound :: Bound t m -> Vec -> Bool inside_bound (Bound sa sb) pt = inside sa pt && inside sb pt +get_metainfo_bound :: Bound t m -> Vec -> ([Texture t m], [t])+get_metainfo_bound (Bound sa sb) v =+ if inside sa v+ then get_metainfo sb v+ else ([],[])+ -- if this is too slow, we could just take the bounding box for sa-bound_bound :: Bound -> Bbox+bound_bound :: Bound t m -> Bbox bound_bound (Bound sa sb) = bboverlap (bound sa) (bound sb) -- remove bounding objects when we flatten transformations@@ -58,17 +67,17 @@ -- build an automatic bounding hierarchy rather than -- a manual one) -transform_leaf_bound :: Bound -> [Xfm] -> SolidItem+transform_leaf_bound :: Bound t m -> [Xfm] -> SolidItem t m transform_leaf_bound (Bound sa sb) xfms = transform_leaf sb xfms -flatten_transform_bound :: Bound -> [SolidItem]+flatten_transform_bound :: Bound t m -> [SolidItem t m] flatten_transform_bound (Bound sa sb) = flatten_transform sb -primcount_bound :: Bound -> Pcount+primcount_bound :: Bound t m -> Pcount primcount_bound (Bound sa sb) = pcadd (asbound (primcount sa)) (primcount sb) -instance Solid Bound where+instance Solid (Bound t m) t m where rayint = rayint_bound rayint_debug = rayint_debug_bound shadow = shadow_bound@@ -77,3 +86,4 @@ flatten_transform = flatten_transform_bound transform_leaf = transform_leaf_bound primcount = primcount_bound+ get_metainfo = get_metainfo_bound
Data/Glome/Box.hs view
@@ -1,19 +1,22 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ module Data.Glome.Box (box) where import Data.Glome.Vec import Data.Glome.Solid -- Simple, axis-aligned bounding box defined with two points at opposing corners. -data Box = Box !Bbox deriving Show+data Box t m = Box !Bbox deriving Show -box :: Vec -> Vec -> SolidItem+box :: Vec -> Vec -> SolidItem t m box (Vec x1 y1 z1) (Vec x2 y2 z2) = SolidItem (Box (Bbox (Vec (fmin x1 x2) (fmin y1 y2) (fmin z1 z2)) (Vec (fmax x1 x2) (fmax y1 y2) (fmax z1 z2)))) -- this could be optimized a bit more-rayint_box :: Box -> Ray -> Flt -> Texture -> Rayint-rayint_box (Box (Bbox (Vec p1x p1y p1z) (Vec p2x p2y p2z))) r@(Ray orig@(Vec ox oy oz) dir@(Vec dx dy dz)) d t =+rayint_box :: Box tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_box (Box (Bbox (Vec p1x p1y p1z) (Vec p2x p2y p2z))) r@(Ray orig@(Vec ox oy oz) dir@(Vec dx dy dz)) d t tags = let dxrcp = 1/dx dyrcp = 1/dy dzrcp = 1/dz@@ -39,7 +42,7 @@ 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 + RayHit firstout (vscaleadd orig dir firstout) n r vzero t tags else -- origin is outside let n = if inx == lastin @@ -48,9 +51,9 @@ 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 + RayHit lastin (vscaleadd orig dir lastin) n r vzero t tags -shadow_box :: Box -> Ray -> Flt -> Bool+shadow_box :: Box t m -> Ray -> Flt -> Bool shadow_box (Box box) r d = let Interval near far = bbclip r box in@@ -58,16 +61,16 @@ then False else True -inside_box :: Box -> Vec -> Bool+inside_box :: Box t m -> Vec -> Bool inside_box (Box (Bbox (Vec x1 y1 z1) (Vec x2 y2 z2))) (Vec x y z) = x > x1 && x < x2 && y > y1 && y < y2 && z > z1 && z < z2 -bound_box :: Box -> Bbox+bound_box :: Box t m -> Bbox bound_box (Box box) = box -instance Solid Box where+instance Solid (Box t m) t m where rayint = rayint_box shadow = shadow_box inside = inside_box
Data/Glome/Clr.hs view
@@ -1,7 +1,10 @@ module Data.Glome.Clr where +import Data.List(foldl')+ type CFlt = Double-data Color = Color {r,g,b :: !CFlt} deriving Show+data Color = Color !CFlt !CFlt !CFlt deriving Show+data ColorA = ColorA !CFlt !CFlt !CFlt !CFlt c_black = Color 0 0 0 c_white = Color 1 1 1@@ -9,20 +12,43 @@ c_green = Color 0 1 0 c_blue = Color 0 0 1 +ca_black = ColorA 0 0 0 1+ca_white = ColorA 1 1 1 1+ca_red = ColorA 1 0 0 1+ca_green = ColorA 0 1 0 1+ca_blue = ColorA 0 0 1 1++ca_transparent = ColorA 0 0 0 0+ cadd :: Color -> Color -> Color cadd (Color r1 g1 b1) (Color r2 g2 b2) = Color (r1+r2) (g1+g2) (b1+b2) +caadd :: ColorA -> ColorA -> ColorA+caadd (ColorA r1 g1 b1 a1) (ColorA r2 g2 b2 a2) =+ ColorA (r1*a1 + r2*a2) (g1*a1 + g2*a2) (b1*a1 + b2*a2) (a1+a2)++canorm :: ColorA -> ColorA+canorm c@(ColorA r g b a)+ | a <= 1 = c+ | otherwise = ColorA (r/a) (g/a) (b/a) 1+ cdiv :: Color -> CFlt -> Color cdiv c1 div = cscale c1 (1/div) +cadiv :: ColorA -> CFlt -> ColorA+cadiv (ColorA r g b a) d =+ ColorA (r/d) (g/d) (b/d) (a/d)+ cscale :: Color -> CFlt -> Color cscale (Color r g b) mul =- Color (r * mul)- (g * mul)- (b * mul)+ Color (r * mul) (g * mul) (b * mul) +cascale :: ColorA -> CFlt -> ColorA+cascale (ColorA r g b a) mul =+ ColorA (r * mul) (g * mul) (b*mul) a+ cmul :: Color -> Color -> Color cmul (Color r1 g1 b1) (Color r2 g2 b2) = Color (r1*r2) (g1*g2) (b1*b2)@@ -39,3 +65,51 @@ Color (if r > 0.0 then r else 0.0) (if g > 0.0 then g else 0.0) (if b > 0.0 then b else 0.0)++color r g b = Color r g b+colora r g b a = ColorA r g b a++liftcolor :: Color -> ColorA+liftcolor (Color r g b) = ColorA r g b 1++aclamp :: CFlt -> CFlt+aclamp x+ | x > 1 = 1+ | x < 0 = 0+ | otherwise = x++-- return the final transparency after going through multiple alpha channels+alphas :: [ColorA] -> CFlt+alphas cs =+ let as = map (\(ColorA _ _ _ a) -> 1 - (aclamp a)) cs+ in 1 - (product as)++caweight :: ColorA -> ColorA -> CFlt -> ColorA+caweight (ColorA r1 g1 b1 a1) (ColorA r2 g2 b2 a2) weight =+ ColorA (w r1 r2) (w g1 g2) (w b1 b2) (w a1 a2)+ where+ w a b = (a * weight) + (b * (1-weight))++casum :: [ColorA] -> ColorA+casum cs =+ let Color r g b = foldl'+ (\(Color r1 g1 b1) (ColorA r2 g2 b2 a2) ->+ Color (r1 + r2*a2) (g1 + g2*a2) (b1 + b2*a2)+ )+ c_black+ cs+ a = alphas cs+ in+ ColorA r g b a++-- combine layered colors, where the top layer hides the lower layers+cafold :: ColorA -> ColorA -> ColorA+cafold (ColorA r1 g1 b1 a1) (ColorA r2 g2 b2 a2) =+ ColorA (r1 + (r2 * trans * a2))+ (g1 + (g2 * trans * a2))+ (b1 + (b2 * trans * a2))+ (a1 + (a2 * trans))+ where+ trans = 1-a1++
Data/Glome/Cone.hs view
@@ -1,5 +1,7 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Data.Glome.Cone (disc, cone, cylinder) where import Data.Glome.Vec@@ -16,26 +18,26 @@ -- Todo: cylinder shadow test -data Disc = Disc !Vec !Vec !Flt deriving Show -- position, normal, r*r-data Cylinder = Cylinder !Flt !Flt !Flt deriving Show -- radius height1 height2-data Cone = Cone !Flt !Flt !Flt !Flt deriving Show -- r clip1 clip2 height+data Disc t m = Disc !Vec !Vec !Flt deriving Show -- position, normal, r*r+data Cylinder t m = Cylinder !Flt !Flt !Flt deriving Show -- radius height1 height2+data Cone t m = Cone !Flt !Flt !Flt !Flt deriving Show -- r clip1 clip2 height -- CONSTRUCTORS -- -- | Create a disc. These are used as the end-caps on cones and cylinders, -- but they can be constructed by themselves as well.-disc :: Vec -> Vec -> Flt -> SolidItem+disc :: Vec -> Vec -> Flt -> SolidItem t m disc pos norm r = SolidItem $ Disc pos norm (r*r) -cylinder_z :: Flt -> Flt -> Flt -> SolidItem+cylinder_z :: Flt -> Flt -> Flt -> SolidItem t m cylinder_z r h1 h2 = SolidItem (Cylinder r h1 h2) -cone_z :: Flt -> Flt -> Flt -> Flt -> SolidItem+cone_z :: Flt -> Flt -> Flt -> Flt -> SolidItem t m cone_z r h1 h2 height = SolidItem (Cone r h1 h2 height) -- | Construct a general cylinder from p1 to p2 with radius r.-cylinder :: Vec -> Vec -> Flt -> SolidItem+cylinder :: Vec -> Vec -> Flt -> SolidItem t m cylinder p1 p2 r = let axis = vsub p2 p1 len = vlen axis@@ -47,7 +49,7 @@ -- | Construct a cone from p1 to p2. R1 and r2 are the radii at each -- end. A cone need not come to a point at either end.-cone :: Vec -> Flt -> Vec -> Flt -> SolidItem+cone :: Vec -> Flt -> Vec -> Flt -> SolidItem t m cone p1 r1 p2 r2 = if r1 < r2 then cone p2 r2 p1 r1@@ -64,8 +66,8 @@ [ (xyz_to_uvw ax2 ax3 ax1), (translate p1) ] -rayint_disc :: Disc -> Ray -> Flt -> Texture -> Rayint-rayint_disc (Disc point norm radius_sqr) r@(Ray orig dir) d t =+rayint_disc :: Disc tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_disc (Disc point norm radius_sqr) r@(Ray orig dir) d t tags = let dist = plane_int_dist r point norm in if dist < 0 || dist > d then RayMiss@@ -74,9 +76,9 @@ in if (vdot offset offset) > radius_sqr then RayMiss- else RayHit dist pos norm t+ else RayHit dist pos norm r vzero t tags -shadow_disc :: Disc -> Ray -> Flt -> Bool+shadow_disc :: Disc t m -> Ray -> Flt -> Bool shadow_disc (Disc point norm radius_sqr) !r@(Ray orig dir) !d = let dist = plane_int_dist r point norm in if dist < 0 || dist > d @@ -88,19 +90,19 @@ then False else True -bound_disc :: Disc -> Bbox+bound_disc :: Disc t m -> Bbox bound_disc (Disc pos norm rsqr) = bound (sphere pos (sqrt rsqr)) -instance Solid Disc where+instance Solid (Disc t m) t m where rayint = rayint_disc shadow = shadow_disc inside (Disc _ _ _) _ = False bound = bound_disc -rayint_cylinder :: Cylinder -> Ray -> Flt -> Texture -> Rayint-rayint_cylinder (Cylinder r h1 h2) ray@(Ray orig@(Vec ox oy oz) dir@(Vec dx dy dz)) d t =+rayint_cylinder :: Cylinder tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_cylinder (Cylinder r h1 h2) ray@(Ray orig@(Vec ox oy oz) dir@(Vec dx dy dz)) d t tags = let a = dx*dx + dy*dy b = 2*(dx*ox + dy*oy) c = ox*ox + oy*oy - r*r@@ -125,33 +127,33 @@ then RayMiss else let pos@(Vec posx posy posz) = vscaleadd orig dir dist in if posz > h1 && posz < h2- then RayHit dist pos (Vec (posx/r) (posy/r) 0) t+ then RayHit dist pos (Vec (posx/r) (posy/r) 0) ray vzero t tags else if dz > 0 -- ray pointing up from bottom then if oz < h1- then rayint_disc (Disc (Vec 0 0 h1) nvz (r*r)) ray d t+ then rayint_disc (Disc (Vec 0 0 h1) nvz (r*r)) ray d t tags --then rayint_aadisc h1 r ray d t else RayMiss else if oz > h2- then rayint_disc (Disc (Vec 0 0 h2) vz (r*r)) ray d t+ then rayint_disc (Disc (Vec 0 0 h2) vz (r*r)) ray d t tags --rayint_aadisc h2 r ray d t -- todo: fix normal else RayMiss -inside_cylinder :: Cylinder -> Vec -> Bool+inside_cylinder :: Cylinder t m -> Vec -> Bool inside_cylinder (Cylinder r h1 h2) (Vec x y z) = z > h1 && z < h2 && x*x + y*y < r*r -bound_cylinder :: Cylinder -> Bbox+bound_cylinder :: Cylinder t m -> Bbox bound_cylinder (Cylinder r h1 h2) = Bbox (Vec (-r) (-r) h1) (Vec r r h2) -instance Solid Cylinder where+instance Solid (Cylinder t m) t m where rayint = rayint_cylinder inside = inside_cylinder bound = bound_cylinder -rayint_cone :: Cone -> Ray -> Flt -> Texture -> Rayint-rayint_cone (Cone r clip1 clip2 height) ray@(Ray orig@(Vec ox oy oz) dir@(Vec dx dy dz)) d t =+rayint_cone :: Cone tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_cone (Cone r clip1 clip2 height) ray@(Ray orig@(Vec ox oy oz) dir@(Vec dx dy dz)) d t tags = let k' = (r/height) k = k'*k' a = dx*dx + dy*dy - k*dz*dz@@ -185,15 +187,15 @@ out = height * invhyp r_ = sqrt (posx*posx + posy*posy) correction = (out)/(r_)- in RayHit dist pos (Vec (posx*correction) (posy*correction) up) t+ in RayHit dist pos (Vec (posx*correction) (posy*correction) up) ray vzero t tags else if dz > 0 -- ray pointing up from bottom then if oz < clip1- then rayint_disc (Disc (Vec 0 0 clip1) nvz (r*r)) ray d t+ then rayint_disc (Disc (Vec 0 0 clip1) nvz (r*r)) ray d t tags else RayMiss else if oz > clip2 then let r2 = r*(1-((clip2-clip1)/(height)))- in rayint_disc (Disc (Vec 0 0 clip2) vz (r2*r2)) ray d t+ in rayint_disc (Disc (Vec 0 0 clip2) vz (r2*r2)) ray d t tags --rayint_aadisc clip2 r2 ray d t else RayMiss -- then rayint_aadisc clip1 r ray d t@@ -201,7 +203,7 @@ -- (r*((clip2-clip1)/height)) -- (Ray orig dir) d t -- todo: fix normal -shadow_cone :: Cone -> Ray -> Flt -> Bool+shadow_cone :: Cone t m -> Ray -> Flt -> Bool shadow_cone (Cone r clip1 clip2 height) ray@(Ray orig@(Vec ox oy oz) dir@(Vec dx dy dz)) d = let k' = (r/height) k = k'*k'@@ -243,16 +245,16 @@ else False -inside_cone :: Cone -> Vec -> Bool+inside_cone :: Cone t m -> Vec -> Bool inside_cone (Cone rbase h1 h2 height) (Vec x y z) = let r = rbase*(1-(((z-h1)/height))) in z > h1 && z < h2 && x*x + y*y < r*r -bound_cone :: Cone -> Bbox+bound_cone :: Cone t m -> Bbox bound_cone (Cone r h1 h2 height) = Bbox (Vec (-r) (-r) h1) (Vec r r h2) -instance Solid Cone where+instance Solid (Cone t m) t m where rayint = rayint_cone shadow = shadow_cone inside = inside_cone
Data/Glome/Csg.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ module Data.Glome.Csg (difference, intersection) where import Data.Glome.Vec import Data.Glome.Solid@@ -8,159 +11,48 @@ -- todo: implement shadow tests -data Difference = Difference SolidItem SolidItem deriving Show-data Intersection = Intersection [SolidItem] deriving Show+data Difference t m = Difference (SolidItem t m) (SolidItem t m) Bool deriving Show+data Intersection t m = Intersection [SolidItem t m] deriving Show --Difference-- -- | Create a new object based on the subtraction of the second item -- from the first. This only works if the items have a well-defined -- inside and outside. Triangles and discs, for instance, have no -- volume, so subtracting them from anything won't do anything.-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- 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) bt- 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--}--{--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+--+-- If you use the "retexture" constructor, the surface hollowed+-- out by B will be rendered with B's texture,+difference :: SolidItem t m -> SolidItem t m -> SolidItem t m+difference a b = SolidItem $ Difference a b True - inta = - intb =+difference_retexture :: SolidItem t m -> SolidItem t m -> SolidItem t m+difference_retexture a b = SolidItem $ Difference a b False -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+rayint_difference :: Difference tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_difference dif@(Difference sa sb useatex) r@(Ray orig dir) d t tags | inside sb orig =- case rayint sb r d t of- rib@(RayHit bd bp bn bt) ->+ case rayint sb r d t tags of+ rib@(RayHit bd bp bn ray uvw bt btags) -> 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+ then if useatex+ then let (atexs, atags) = get_metainfo sa bp+ in RayHit bd bp (vinvert bn) ray uvw atexs atags+ else RayHit bd bp (vinvert bn) ray uvw bt btags+ else rayint_advance (SolidItem dif) r d t tags 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) ->+ case rayint sa r d t tags of+ ria@(RayHit ad ap an aray auvw at atags) ->+ case rayint sb r d t tags of+ rib@(RayHit bd bp bn bray buvw bt btags) -> if (ad < bd) then ria- else rayint_advance (SolidItem dif) r d t bd+ else rayint_advance (SolidItem dif) r d t tags 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-- -- | Create a new item from the boolean intersection of a@@ -168,68 +60,80 @@ -- inside every primitive. We can construct polyhedra from -- intersections of planes, but this isn't the most efficient -- way to do that.-intersection :: [SolidItem] -> SolidItem+intersection :: [SolidItem tag mat] -> SolidItem tag mat intersection slds = SolidItem $ Intersection slds -- fixme: there's some numerical instability near edges-rayint_intersection :: Intersection -> Ray -> Flt -> Texture -> Rayint-rayint_intersection (Intersection slds) r@(Ray orig dir) d t =+rayint_intersection :: Intersection tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_intersection (Intersection slds) r@(Ray orig dir) d t tags = if null slds || d < 0 then RayMiss else let s = head slds in case tail slds of- [] -> rayint s r d t+ [] -> rayint s r d t tags ss -> if inside s orig- then case rayint s r d t of - RayMiss -> rayint (Intersection ss) r d t- RayHit sd sp sn st -> - case rayint (Intersection ss) r sd t of+ then case rayint s r d t tags of + RayMiss -> rayint (Intersection ss) r d t tags+ RayHit sd sp sn sray suvw st stags -> + case rayint (Intersection ss) r sd t tags of RayMiss -> rayint_advance (SolidItem (Intersection slds)) - r d t sd + r d t tags sd hit -> hit- else case rayint s r d t of+ else case rayint s r d t tags of RayMiss -> RayMiss- RayHit sd sp sn st ->+ RayHit sd sp sn sray suvw st stags -> if inside (Intersection ss) sp- then RayHit sd sp sn st+ then RayHit sd sp sn r vzero st stags else rayint_advance (SolidItem (Intersection slds))- r d t sd+ r d t tags sd -inside_difference :: Difference -> Vec -> Bool-inside_difference (Difference sa sb) pt =+inside_difference :: Difference tag mat -> Vec -> Bool+inside_difference (Difference sa sb useatex) pt = (inside sa pt) && (not $ inside sb pt) -- note: inside is True for an empty intersection. -- this is actually the preferred semantics in -- some cases, strange as it may seem.-inside_intersection :: Intersection -> Vec -> Bool+inside_intersection :: Intersection tag mat -> Vec -> Bool inside_intersection (Intersection slds) pt = foldl' (&&) True (map (\x -> inside x pt) slds) -bound_difference :: Difference -> Bbox-bound_difference (Difference sa sb) = bound sa+get_metainfo_difference (Difference sa sb useatex) pt =+ if (inside sa pt) && (not $ inside sb pt)+ then get_metainfo sa pt+ else ([],[]) -bound_intersection :: Intersection -> Bbox+get_metainfo_intersection (Intersection slds) pt =+ if foldl' (&&) True (map (\x -> inside x pt) slds)+ then foldl' paircat ([],[]) $ map (\s -> get_metainfo s pt) slds+ else ([],[]) ++bound_difference :: Difference tag mat -> Bbox+bound_difference (Difference sa _ _) = bound sa++bound_intersection :: Intersection tag mat -> Bbox bound_intersection (Intersection slds) = if null slds 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_difference :: Difference t m -> Pcount+primcount_difference (Difference sa sb _) = pcadd (primcount sa) (primcount sb) -primcount_intersection :: Intersection -> Pcount+primcount_intersection :: Intersection t m -> Pcount primcount_intersection (Intersection slds) = foldl (pcadd) pcnone (map primcount slds) -instance Solid Difference where+instance Solid (Difference t m) t m where rayint = rayint_difference inside = inside_difference bound = bound_difference primcount = primcount_difference+ get_metainfo = get_metainfo_difference -instance Solid Intersection where+instance Solid (Intersection t m) t m where rayint = rayint_intersection inside = inside_intersection bound = bound_intersection primcount = primcount_intersection+ get_metainfo = get_metainfo_intersection
Data/Glome/Plane.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ module Data.Glome.Plane (plane, plane_offset) where import Data.Glome.Vec import Data.Glome.Solid@@ -5,30 +8,30 @@ -- A plane is effectively a half-space; everything below the plane is -- "inside", everything above is "outside". -data Plane = Plane Vec Flt deriving Show -- normal, perpendicular offset from origin+data Plane t m = Plane Vec Flt deriving Show -- normal, perpendicular offset from origin -- | Construct a plane (or, more accurately, a half-space) -- by specifying a point on the plane and a normal. -- The normal points towards the outside of the plane. -- Planes are often useful within CSG objects.-plane :: Vec -> Vec -> SolidItem+plane :: Vec -> Vec -> SolidItem t m plane orig norm_ = SolidItem $ Plane norm d where norm = vnorm norm_ d = vdot orig norm -- we can also specify a point and a perpindicular offset: -plane_offset :: Vec -> Flt -> SolidItem+plane_offset :: Vec -> Flt -> SolidItem t m plane_offset pt off = SolidItem $ Plane pt off -rayint_plane :: Plane -> Ray -> Flt -> Texture -> Rayint-rayint_plane (Plane norm offset) (Ray orig dir) d t =+rayint_plane :: Plane tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_plane (Plane norm offset) ray@(Ray orig dir) d t tags = let hit = -(((vdot norm orig)-offset) / (vdot norm dir)) in if hit < 0 || hit > d then RayMiss- else RayHit hit (vscaleadd orig dir hit) norm t+ else RayHit hit (vscaleadd orig dir hit) norm ray vzero t tags -inside_plane :: Plane -> Vec -> Bool+inside_plane :: Plane tag mat -> Vec -> Bool inside_plane (Plane norm offset) pt = let onplane = (vscale norm offset) newvec = vsub onplane pt@@ -37,10 +40,10 @@ -- Note: attempting to use an infinite object (such as -- a plane) inside a bih will cause an exception. -bound_plane :: Plane -> Bbox+bound_plane :: Plane tag mat -> Bbox bound_plane (Plane norm offset) = everything_bbox -instance Solid Plane where+instance Solid (Plane t m) t m where rayint = rayint_plane inside = inside_plane bound = bound_plane
Data/Glome/Scene.hs view
@@ -1,8 +1,6 @@ module Data.Glome.Scene (- Scene(Scene), Light(Light), Camera(Camera),- scene, camera, light, - sld, lits, cam, dtex, bground,- primcount_scene,+ Camera(Camera),+ camera, module Data.Glome.Clr, module Data.Glome.Vec, module Data.Glome.Solid,@@ -28,22 +26,11 @@ import Data.Glome.Cone import Data.Glome.Tex --- This is the module to import if you want to have+-- This is the proper module to import if you want to have -- access to all the Solid constructors and scene -- defininition code. ---LIGHTS---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 (-2) infinity True- -- CAMERA -- data Camera = Camera {campos, fwd, up, right :: !Vec} deriving Show@@ -52,7 +39,7 @@ default_cam = (Camera (vec 0.0 0.0 (-3.0)) (vec 0.0 0.0 1.0) (vec 0.0 1.0 0.0) - (vec 1.0 0.0 0.0) )+ (vec 1.0 0.0 0.0)) -- | Construct a camera, given a position, a forward vector, -- a point that the camera should be pointed towards, an up vector,@@ -69,25 +56,3 @@ (vscale up_ cam_scale) (vscale right cam_scale) ---SCENE---data Scene = Scene {sld :: SolidItem,- lits :: [Light], - cam :: Camera, - dtex :: Texture, - bground :: Color} deriving Show---- | Create a scene from an item (which can be a composite item, such --- as a bih or group), a list of lights, a camera, a default texture,--- and a default background color.-scene :: SolidItem -> [Light] -> Camera -> Texture -> Color -> Scene-scene s l cam t clr = Scene s l cam t clr---- | Count the primitives in the scene. See docs for primcount --- in Solid.hs.-primcount_scene :: Scene -> Pcount-primcount_scene (Scene sld _ _ _ _) = primcount sld--{--default_scene = (Scene (sphere (vec 0.0 0.0 0.0) 1.0) - [] default_cam t_white c_white)--}
+ Data/Glome/Shader.hs view
@@ -0,0 +1,165 @@++module Data.Glome.Shader where++import Data.Maybe(mapMaybe)+import Data.List(foldl')++import Data.Glome.Vec+import Data.Glome.Clr+import Data.Glome.Solid+import Data.Glome.Trace++--LIGHTS--+data Light = Light {+ litpos :: !Vec,+ litcol :: !Color,+ litfalloff :: Flt -> Flt,+ litrad :: !Flt,+ litshadow :: !Bool+}++-- | Construct a light given a center location and a color.+light :: Vec -> Color -> Light+light pos clr = Light pos clr (\x -> 1/(x*x)) infinity True+++--MATERIALS--++-- | Surface properties at a point on an object's surface.+-- Much of this is standard whitted-style illumination.+-- Plain diffuse/specular suraces can be defined with+-- Surface.+--+-- Reflection and Refraction have their own constructors.+-- AdditiveLayers is a way of stacking textures such that+-- the colors are added together.+--+-- Blend takes two textures and returns the result of+-- cobining them.+--+-- Warp is a little stranger; it takes a ray and re-casts+-- into a separate scene (or the same one, if you so choose).++data Material t =+ Surface Color Flt Flt Flt Flt Flt Bool | -- color, alpha, ambient, diffuse, specular, shine, dielectric+ Reflect Flt | -- amount+ Refract Flt Flt | -- amount, ior+ Warp (SolidItem t (Material t))+ (SolidItem t (Material t))+ [Light]+ (Ray -> Rayint t (Material t) -> Ray) | -- frame, scene, ctx, xfm+ AdditiveLayers [Material t] |+ Blend (Material t) (Material t) Flt++-- | Uniform texture+t_uniform :: Material t -> Texture t (Material t)+t_uniform m = \_ _ -> m+++--SHADER--++-- | Calculate light intensity and direction at the current ray+-- intersection.+-- We do this up front so we don't have to re-do the shadow tests when we+-- evaluate multiple layered textures.+mpreshade :: [Light] -> Ray -> SolidItem t (Material t) -> Rayint t (Material t) -> [(Color, Vec)]+mpreshade _ _ _ RayMiss = []+mpreshade lights (Ray o dir) scene (RayHit _ hitpos norm _ _ _ _) =+ mapMaybe illuminate lights+ where+ illuminate (Light lpos color falloff rad do_shadow) =+ let lvec = vsub lpos hitpos+ in if vdot lvec norm < 0+ then Nothing+ else+ let llen = vlen lvec+ ldir = vscale lvec (1/llen)+ in+ if llen > rad || (do_shadow && shadow scene (Ray (vscaleadd hitpos norm delta) ldir) (llen - (2*delta)))+ then Nothing+ else Just (cscale color (falloff llen), ldir)++mpostshade :: [Light] -> [(Color, Vec)] -> Material t -> Ray -> SolidItem t (Material t) -> Rayint t (Material t) -> Int -> (ColorA, [t])+mpostshade ls lights mat ray@(Ray o dir) s rayint recurs =+ case rayint of+ RayMiss -> (ca_transparent, [])+ RayHit d p n xfmray uvw texs _ ->+ let eyedir = vinvert dir+ in+ case mat of+ Surface color alpha amb kd ks shine dielectric ->+ let ambient = cscale color amb+ direct = foldl' cadd c_black $ map illuminate lights+ illuminate (lcolor, ldir) =+ let halfangle = bisect ldir eyedir+ ldotn = fmax 0 $ vdot ldir n+ blinn = if ks <= delta+ then 0+ else let b = fmax 0 $ ((vdot halfangle n) ** shine) * ldotn+ in if isNaN b then 0 else b+ diffuse = vdot ldir n+ in cscale lcolor ((blinn*ks) + (diffuse*kd))+ (Color r g b) = cadd ambient direct+ resultcolora = ColorA r g b alpha+ in+ (resultcolora, []) ++ Reflect refl -> + if (refl > 0) && (recurs > 0)+ then let outdir = reflect dir n + (ColorA r g b a, refltags, _) =+ (trace ls+ materialShader+ s+ (Ray (vscaleadd p outdir delta) outdir) + infinity + (recurs-1))+ in (ColorA r g b (a*refl), refltags)+ else (ca_transparent, [])++ Refract _ _ -> (ca_transparent, [])++ Warp frame scene' lights' xfm ->+ let (fcolor, ftags, fint) =+ (trace ls+ materialShader+ frame+ xfmray + infinity+ (recurs-1))+ (wcolor, wtags, wint) =+ (trace lights'+ materialShader+ scene'+ (xfm ray rayint)+ (ridepth fint)+ (recurs-1))+ in+ if ridepth fint < ridepth wint+ then (fcolor, ftags)+ else (wcolor, wtags)++ AdditiveLayers ms ->+ let (cs, taglists) = unzip $ map (\m -> mpostshade ls lights m ray s rayint recurs) ms+ in (casum cs, (concat taglists))++ Blend ma mb weight ->+ let (ca, tagsa) = mpostshade ls lights ma ray s rayint recurs+ (cb, tagsb) = mpostshade ls lights mb ray s rayint recurs+ in (caweight ca cb weight, tagsa ++ tagsb)++mmissshade :: [Light] -> Ray -> SolidItem t (Material t) -> (ColorA, [t])+mmissshade _ _ _ = (ca_transparent, [])++materialShader = Shader mpreshade mpostshade mmissshade++{-+-- no shadows, reflection, or lighting+flat_shade :: Rayint t -> Ray -> Scene t -> Int -> Int -> ColorA+flat_shade ri (Ray o indir) scn recurs debug =+ case ri of+ RayMiss -> bground scn+ RayHit d p n t -> + let (Material clr refl refr ior kd ks shine) = t ri+ in liftcolor clr+-}
Data/Glome/Solid.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-} module Data.Glome.Solid where import Data.Glome.Vec@@ -11,47 +13,53 @@ import Data.List hiding (group) -- | Ray intersection type. If we hit, we store the distance from the ray--- origin, the position, the normal, and the texture attached to the object.--- We could just as easily have created a hit type and wrapped it in a Maybe.--data Rayint = RayHit {- depth :: !Flt,- pos :: !Vec,- norm :: !Vec,- texture :: Texture+-- origin, the position, the normal, the transformed ray, UV coordinates+-- (plus a 3rd coordinate we'll call W) and the texture +-- and tag stacks attached to the object.+data Rayint tag mat = RayHit {+ ridepth' :: !Flt,+ ripos :: !Vec,+ rinorm :: !Vec,+ riray :: !Ray,+ riuvw :: !Vec,+ ritex :: [Texture tag mat],+ ritag :: [tag] } | RayMiss deriving Show -raymiss :: Rayint+raymiss :: Rayint tag mat raymiss = RayMiss +ridepth RayMiss = infinity+ridepth ri = ridepth' ri+ -- | Pick the closest of two Rayints-nearest :: Rayint -> Rayint -> Rayint+nearest :: Rayint tag mat -> Rayint tag mat -> Rayint tag mat nearest a RayMiss = {-# SCC nearest_miss_a #-} a nearest RayMiss b = {-# SCC nearest_miss_b #-} b-nearest a@(RayHit !da _ _ _) b@(RayHit !db _ _ _) =+nearest a@(RayHit !da _ _ _ _ _ _) b@(RayHit !db _ _ _ _ _ _) = {-# SCC nearest_cmp #-} if da < db then a else b -- | Pick the furthest of two Rayints-furthest :: Rayint -> Rayint -> Rayint+furthest :: Rayint tag mat -> Rayint tag mat -> Rayint tag mat furthest _ RayMiss = RayMiss furthest RayMiss _ = RayMiss-furthest a@(RayHit !da _ _ _) b@(RayHit !db _ _ _) =+furthest a@(RayHit !da _ _ _ _ _ _) b@(RayHit !db _ _ _ _ _ _) = if da > db then a else b -- | Test if a Rayint is a hit or a miss-hit :: Rayint -> Bool-hit (RayHit _ _ _ _) = True+hit :: Rayint tag mat -> Bool+hit (RayHit _ _ _ _ _ _ _) = True hit RayMiss = False -- | Extract a distance from a Rayint, with infinity for a miss-dist :: Rayint -> Flt+dist :: Rayint tag mat -> Flt dist RayMiss = infinity-dist (RayHit d _ _ _) = d+dist (RayHit d _ _ _ _ _ _) = d --Packet Types-- @@ -59,11 +67,12 @@ -- acceleration structure at the same time, provided the rays are almost -- identical. A PacketResult is the result of tracing 4 rays at once. -data PacketResult = PacketResult !Rayint !Rayint !Rayint !Rayint+data PacketResult tag mat = PacketResult (Rayint tag mat) (Rayint tag mat) (Rayint tag mat) (Rayint tag mat)+ packetmiss = PacketResult RayMiss RayMiss RayMiss RayMiss -nearest_packetresult :: PacketResult -> PacketResult -> PacketResult+nearest_packetresult :: PacketResult tag mat -> PacketResult tag mat -> PacketResult tag mat nearest_packetresult !(PacketResult a1 a2 a3 a4) !(PacketResult b1 b2 b3 b4) = PacketResult (nearest a1 b1) (nearest a2 b2)@@ -72,65 +81,24 @@ -- | Move a ray forward and test the new ray against an object. -- Fix the depth of the result. Useful in CSG-rayint_advance :: SolidItem -> Ray -> Flt -> Texture -> Flt -> Rayint-rayint_advance s r d t adv =+rayint_advance :: SolidItem tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Flt -> Rayint tag mat+rayint_advance s r d t tags adv = let a = adv+delta in- case (rayint s (ray_move r a) (d-a) t) of+ case (rayint s (ray_move r a) (d-a) t tags) of RayMiss -> RayMiss- RayHit depth pos norm tex -> RayHit (depth+a) pos norm tex+ RayHit depth pos norm ray uvw tex tags -> RayHit (depth+a) pos norm ray uvw tex tags ---MATERIALS------ | Surface properties at a point on an object's surface. We have color, --- reflection amount, refraction amount index of refraction, kd, ks, and shine.--- These are parameters to a Whitted - style illumination model.--data Material = Material {clr :: !Color, - refl, refr, ior, - kd, ks, shine :: !Flt} deriving Show---- | A texture is a function that takes a Rayint and returns a Material.--- In other words, textures can vary based on location, normal, etc...--- in arbitrary ways.-type Texture = Rayint -> Material+-- | A texture is a function that takes a Rayint and returns a material.+-- A material will later be rendered by a shader (which in turn can+-- append more tags).+type Texture tag mat = Ray -> Rayint tag mat -> mat -- | This is sort of a no-op; textures are functions, and we don't have a -- good way to show an arbitrary function-showTexture :: Texture -> String-showTexture t = show $ t RayMiss--instance Show Texture where- show = showTexture---- | Uniform white material-m_white = (Material c_white 0 0 0 1 0 2)-t_white ri = m_white---- | Uniform texture-t_uniform :: Material -> Texture-t_uniform m = \x -> m--interp :: Flt -> Flt -> Flt -> Flt-interp scale a b =- scale*a + (1-scale)*b---- | Interpolate between textures. --- Not really correct, but we'll go with it for now.-m_interp :: Material -> Material -> Flt -> Material-m_interp m1 m2 scale =- let (Material m1c m1refl m1refr m1ior m1kd m1ks m1shine) = m1- (Material m2c m2refl m2refr m2ior m2kd m2ks m2shine) = m2- intp = interp scale- c = cadd (cscale m1c scale) (cscale m2c (1-scale))- refl = intp m1refl m2refl- refr = intp m1refr m2refr- ior = intp m1ior m2ior- kd = intp m1kd m2kd- ks = intp m1ks m2ks- shine = intp m1shine m2shine- in (Material c refl refr ior kd ks shine)+instance Show (Texture t m) where+ show t = "Texture" --utility functions for "primcount" newtype Pcount = Pcount (Int,Int,Int) deriving Show@@ -154,10 +122,10 @@ 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))+debug_wrap :: (Rayint tag mat, Int) -> Int -> (Rayint tag mat, Int)+debug_wrap (ri, a) b = (ri, (a+b)) -nearest_debug :: (Rayint,Int) -> (Rayint,Int) -> (Rayint,Int)+nearest_debug :: (Rayint tag mat, Int) -> (Rayint tag mat, Int) -> (Rayint tag mat, Int) nearest_debug (ari, an) (bri, bn) = ((nearest ari bri),(an+bn)) --SOLID CLASS--@@ -166,84 +134,89 @@ -- Some of these are simple solids like Sphere or Triangle, but others -- are composite solids than have other solids as children. -class (Show a) => Solid a where+class (Show s) => Solid s t m | s -> t, s -> m where -- | Test a ray against a solid, returning a ray intersection. -- The distance parameter is used to specify a max distance. -- If it's further away, we aren't interested in the intersection.- -- The texture parameter is a default texture we use, if it's not- -- overridden by a more specific texture.- rayint :: a -- ^ object to test against- -> Ray -- ^ ray- -> Flt -- ^ maximum distance we care about- -> Texture -- ^ default texture- -> Rayint -- ^ we return a Rayint describing the hit location+ -- The "b" parameter is a default tag, if it's not+ -- overridden by a more specific tag (which is useful if we need to be+ -- able to identify the thing that was hit).+ rayint :: s -- ^ object to test against+ -> Ray -- ^ ray+ -> Flt -- ^ maximum distance we care about+ -> [Texture t m] -- ^ current texture stack (Tex object pushes new textures)+ -> [t] -- ^ tag stack (Tag object pushes new tags)+ -> Rayint t m -- ^ we return a Rayint describing the hit location -- | Same as rayint, but return a count of the number of -- primitives checked. Useful for optimizing acceleration structures.- rayint_debug :: a -> Ray -> Flt -> Texture -> (Rayint, Int)+ rayint_debug :: s -> Ray -> Flt -> [Texture t m] -> [t] -> (Rayint t m, Int) -- | Trace four rays at once against a solid.- packetint :: a -> Ray -> Ray -> Ray -> Ray -> Flt -> Texture -> PacketResult + packetint :: s -> Ray -> Ray -> Ray -> Ray -> Flt -> [Texture t m] -> [t] -> PacketResult t m -- | Shadow test - we just return a Bool rather than return a -- a full Rayint.- shadow :: a -> Ray -> Flt -> Bool+ shadow :: s -> Ray -> Flt -> Bool -- | Test if a point is inside an object. Useful for CSG. -- Objects with no volume just return False.- inside :: a -> Vec -> Bool+ inside :: s -> Vec -> Bool -- | Generate an axis-aligned bounding box than completely encloses -- the object. For performance, it is important that this fits as -- tight as possible.- bound :: a -> Bbox+ bound :: s -> Bbox -- | Most simple objects just return themselves as a singleton list, -- but for composite objects, we flatten the structure out and -- return a list. We usually do this prior to re-building a -- composite object in a (hopefully) more efficient fashion.- tolist :: a -> [SolidItem]+ tolist :: s -> [SolidItem t m] -- | Create a new object transformed by some transformation. The -- reason this method exists is so we can override it for the -- Instance type - if we transform a transformation, we should -- combine the two matricies into one. -- Most objects can use the default implementation.- transform :: a -> [Xfm] -> SolidItem+ transform :: s -> [Xfm] -> SolidItem t m -- | Used by flatten_transform. I don't really remember how it works. - transform_leaf :: a -> [Xfm] -> SolidItem+ transform_leaf :: s -> [Xfm] -> SolidItem t m -- | Take a composite object inside a transform, and turn it into -- a group of individually-transformed objects. Most objects -- can use the defaut implementation.- flatten_transform :: a -> [SolidItem]+ flatten_transform :: s -> [SolidItem t m] -- | Count the number of primitives, transforms, and bounding -- objects in a scene. Simple objects can just use the default, -- which is to return a single primitive.- primcount :: a -> Pcount+ primcount :: s -> Pcount + -- | Get texture and tag data for a primitive, from a point.+ get_metainfo :: s -> Vec -> ([Texture t m], [t])+ -- | This is for counting bih split planes and the like, for -- performance tuning and debugging. Most objects can use -- the default implementation.- rayint_debug s !r !d t = ((rayint s r d t),0)+ rayint_debug s !r !d t tags = ((rayint s r d t tags), 0) -- | Sometimes, we can improve performance by -- intersecting 4 rays at once. This is -- especially true of acceleration structures. -- The default implementation is to fall back on mono-rays.- 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)+ packetint s !r1 !r2 !r3 !r4 !d t tags = + PacketResult (rayint s r1 d t tags)+ (rayint s r2 d t tags)+ (rayint s r3 d t tags)+ (rayint s r4 d t tags) -- if there is no shadow function, we fall back on rayint shadow s !r !d =- case (rayint s r d t_white) of- RayHit _ _ _ _ -> True+ case (rayint s r d undefined []) of+ RayHit _ _ _ _ _ _ _ -> True RayMiss -> False -- There's a name for what a bunch of these functions@@ -253,12 +226,12 @@ -- This is here so we can flatten a group of groups -- into a single group; the default is fine for everything -- but groups and Void and SolidItem.- tolist a = [SolidItem (a)]+ tolist s = [SolidItem s] -- Method to transform an object; the default works fine -- except for instances themselves, which will want to -- collapse the two transformations into a sigle transform.- transform a xfm = SolidItem $ Instance (SolidItem a) (compose xfm)+ transform s xfm = SolidItem $ Instance (SolidItem s) (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@@ -276,17 +249,20 @@ -- Also, it forces the full construction of acceleration structures. primcount s = pcsingleprim + -- Lookup texture and tag info at a point.+ get_metainfo s v = ([],[]) + -- | We create an existential type for solids so we can emded them -- in composite types without know what kind of solid it is. -- http://notes-on-haskell.blogspot.com/2007/01/proxies-and-delegation-vs-existential.html -data SolidItem = forall a. Solid a => SolidItem a+data SolidItem t m = forall s. Solid s t m => SolidItem s -instance Solid SolidItem where- 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+instance Solid (SolidItem t m) t m where+ rayint (SolidItem s) !r !d t tags = rayint s r d t tags+ packetint (SolidItem s) !r1 !r2 !r3 !r4 !d t tags = packetint s r1 r2 r3 r4 d t tags+ rayint_debug (SolidItem s) r d t tags = rayint_debug s r d t tags shadow (SolidItem s) !r !d = shadow s r d inside (SolidItem s) pt = inside s pt bound (SolidItem s) = bound s@@ -295,8 +271,9 @@ 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+ get_metainfo (SolidItem s) v = get_metainfo s v -instance Show SolidItem where+instance Show (SolidItem t m) where show (SolidItem s) = "SI " ++ show s -- we implement "group", "void", and "instance" here because they're@@ -312,7 +289,7 @@ -- constructing the leaves of acceleration structures. (See the bih -- module.) -group :: [SolidItem] -> SolidItem+group :: [SolidItem t m] -> SolidItem t m group [] = SolidItem Void group (sld:[]) = sld group slds = SolidItem (flatten_group slds)@@ -320,62 +297,26 @@ -- | Smash a group of groups into a single group, -- so we can build an efficient bounding heirarchy -flatten_group :: [SolidItem] -> [SolidItem]+flatten_group :: [SolidItem t m] -> [SolidItem t m] flatten_group slds = concat (map tolist slds) --- 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)--{-- this is not measurably faster-rayint_group slds r d t = go slds RayMiss- where go [] res = res- go (x:xs) res = go xs $ nearest (rayint x r d t) res---}--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 (x:xs) r d = (shadow x r d) || (shadow_group xs r d)--inside_group :: [SolidItem] -> Vec -> Bool-inside_group slds pt =- foldl' (||) False (map (\x -> inside x pt) slds)--bound_group :: [SolidItem] -> Bbox-bound_group slds = - foldl' bbjoin empty_bbox (map bound 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)+paircat :: ([a],[b]) -> ([a],[b]) -> ([a],[b])+paircat (a1,b1) (a2,b2) = (a1++a2, b1++b2) -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+instance Solid [SolidItem t m] t m where+ rayint xs r d t tags = foldl' nearest RayMiss (map (\s -> rayint s r d t tags) xs)+ packetint xs r1 r2 r3 r4 d t tags = foldl' nearest_packetresult packetmiss (map (\s -> packetint s r1 r2 r3 r4 d t tags) xs)+ rayint_debug xs r d t tags = foldl' nearest_debug (RayMiss,0) (map (\s -> rayint_debug s r d t tags) xs)+ shadow xs r d = foldl' (||) False (map (\s -> shadow s r d) xs)+ inside xs pt = foldl' (||) False (map (\x -> inside x pt) xs)+ bound xs = foldl' bbjoin empty_bbox (map bound xs)+ tolist a = concat $ map tolist a+ transform_leaf xs xfms = SolidItem $ map (\x -> transform_leaf x xfms) (tolist xs)+ flatten_transform a = concat $ map flatten_transform a+ primcount xs = foldl (pcadd) (Pcount (0,0,0)) (map primcount xs)+ get_metainfo xs v = foldl (\acc x -> if inside x v+ then paircat (get_metainfo x v) acc+ else acc) ([],[]) xs -- VOID -- @@ -384,13 +325,13 @@ -- (Originally I called this "Nothing", but that -- conflicted with the prelude maybe type, so I call -- it "Void" instead) -data Void = Void deriving Show+data Void t m = Void deriving Show nothing = SolidItem Void -instance Solid Void where- rayint Void _ _ _ = RayMiss- packetint Void _ _ _ _ _ _ = packetmiss+instance Solid (Void t m) t m where+ rayint Void _ _ _ _ = RayMiss+ packetint Void _ _ _ _ _ _ _ = packetmiss shadow Void _ _ = False inside Void _ = False bound Void = empty_bbox@@ -421,25 +362,28 @@ -- Another good reason to include Instance in Solid.hs -- is that it's referenced from Cone.hs -data Instance = Instance SolidItem Xfm deriving Show+data Instance t m = Instance (SolidItem t m) Xfm deriving Show -rayint_instance :: Instance -> Ray -> Flt -> Texture -> Rayint-rayint_instance !(Instance sld xfm) !(Ray orig dir) !d t =+rayint_instance :: Instance tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_instance !(Instance sld xfm) !(Ray orig dir) !d t tags = let newdir = invxfm_vec xfm dir neworig = invxfm_point xfm orig lenscale = vlen newdir invlenscale = 1/lenscale in- case (rayint sld (Ray neworig (vscale newdir invlenscale)) (d*lenscale) t) of+ case (rayint sld (Ray neworig (vscale newdir invlenscale)) (d*lenscale) t tags) of RayMiss -> RayMiss- RayHit depth pos n tex -> RayHit (depth*invlenscale) - (xfm_point xfm pos) - (vnorm (invxfm_norm xfm n)) - tex+ RayHit depth pos n ray uvw tex tags -> RayHit (depth*invlenscale) + (xfm_point xfm pos) + (vnorm (invxfm_norm xfm n)) + ray+ uvw+ tex+ tags -packetint_instance :: Instance -> Ray -> Ray -> Ray -> Ray -> Flt -> Texture -> PacketResult+packetint_instance :: Instance tag mat -> Ray -> Ray -> Ray -> Ray -> Flt -> [Texture tag mat] -> [tag] -> PacketResult tag mat packetint_instance !(Instance sld xfm) !(Ray orig1 dir1) !(Ray orig2 dir2) - !(Ray orig3 dir3) !(Ray orig4 dir4) d t =+ !(Ray orig3 dir3) !(Ray orig4 dir4) d t tags = let newdir1 = invxfm_vec xfm dir1 newdir2 = invxfm_vec xfm dir2 newdir3 = invxfm_vec xfm dir3@@ -461,36 +405,42 @@ (Ray neworig2 (vscale newdir2 invlenscale2)) (Ray neworig3 (vscale newdir3 invlenscale3)) (Ray neworig4 (vscale newdir4 invlenscale4)) - (d*lenscale1) t+ (d*lenscale1) t tags 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+ RayHit depth pos n ray uvw tex tags -> RayHit (depth*ils) + (xfm_point xfm pos) + (vnorm (invxfm_norm xfm n))+ ray+ uvw+ tex+ tags 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 =+rayint_debug_instance :: Instance tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag]-> (Rayint tag mat, Int)+rayint_debug_instance (Instance sld xfm) (Ray orig dir) d t tags = 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+ case rayint_debug sld (Ray neworig (vscale newdir invlenscale)) (d*lenscale) t tags 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)+ (RayHit depth pos n ray uvw tex tags, count) -> (RayHit (depth*invlenscale) + (xfm_point xfm pos) + (vnorm (invxfm_norm xfm n))+ ray+ uvw+ tex+ tags, count) -shadow_instance :: Instance -> Ray -> Flt -> Bool+shadow_instance :: Instance tag mat -> Ray -> Flt -> Bool shadow_instance !(Instance sld xfm) !(Ray orig dir) !d = let newdir = invxfm_vec xfm dir neworig = invxfm_point xfm orig@@ -499,11 +449,11 @@ in shadow sld (Ray neworig (vscale newdir invlenscale)) (d*lenscale) -inside_instance :: Instance -> Vec -> Bool+inside_instance :: Instance tag mat -> Vec -> Bool inside_instance (Instance s xfm) pt = inside s (invxfm_point xfm pt) -bound_instance :: Instance -> Bbox+bound_instance :: Instance tag mat -> Bbox bound_instance (Instance sld xfm) = let (Bbox (Vec p1x p1y p1z) (Vec p2x p2y p2z)) = bound sld pxfm = xfm_point xfm@@ -520,11 +470,11 @@ -- is really applying transforms in the -- correct order... -transform_instance :: Instance -> [Xfm] -> SolidItem+transform_instance :: Instance tag mat -> [Xfm] -> SolidItem tag mat transform_instance (Instance s xfm2) xfm1 = transform s [compose ([xfm2]++xfm1) ] -transform_leaf_instance :: Instance -> [Xfm] -> SolidItem+transform_leaf_instance :: Instance tag mat -> [Xfm] -> SolidItem tag mat transform_leaf_instance (Instance s xfm2) xfm1 = transform_leaf s [compose ([xfm2]++xfm1) ] @@ -535,15 +485,19 @@ -- 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 tag mat -> [SolidItem tag mat] flatten_transform_instance (Instance s xfm) = [SolidItem $ transform_leaf s [xfm]] -- group $ map (\x -> transform (flatten_transform x) [xfm]) (tolist s) -primcount_instance :: Instance -> Pcount+primcount_instance :: Instance tag mat -> Pcount primcount_instance (Instance s xfm) = pcadd (primcount s) pcsinglexfm -instance Solid Instance where+get_metainfo_instance :: Instance tag mat -> Vec -> ([Texture tag mat], [tag])+get_metainfo_instance (Instance s xfm) v =+ get_metainfo s (invxfm_point xfm v)++instance Solid (Instance t m) t m where rayint = rayint_instance packetint = packetint_instance rayint_debug = rayint_debug_instance@@ -554,3 +508,4 @@ transform_leaf = transform_leaf_instance flatten_transform = flatten_transform_instance primcount = primcount_instance+ get_metainfo = get_metainfo_instance
Data/Glome/Spd.hs view
@@ -2,6 +2,7 @@ module Data.Glome.Spd where import Data.Glome.Scene+import Data.Glome.Shader -- NFF file format description: -- http://tog.acm.org/resources/SPD/NFF.TXT@@ -25,6 +26,8 @@ [("#",s1)] -> lexignore s1 _ -> t +type SI = SolidItem () (Material ())+ data BgColor = BgColor(Color) readsSpdVec :: ReadS Vec@@ -131,17 +134,17 @@ readsPrec _ = readsSpdLight -- "f" red green blue Kd Ks Shine T index_of_refraction--- data Material = Material {clr :: Color, reflect, refract, ior, kd, ks, shine :: Flt}-readsSpdFill :: ReadS Texture-readsSpdFill s = [(\ri->Material clr ks (1-trans) ior kd 0.5 shine, s7) | ("f", s1) <- lexcr s,- (clr, s2) <- reads s1 :: [(Color,String)],- (kd, s3) <- reads s2 :: [(Flt,String)],- (ks, s4) <- reads s3 :: [(Flt,String)],- (shine, s5) <- reads s4 :: [(Flt,String)],- (trans, s6) <- reads s5 :: [(Flt,String)],- (ior, s7) <- reads s6 :: [(Flt,String)] ]+readsSpdFill :: ReadS (Texture () (Material ()))+readsSpdFill s = [(\ray ri -> Surface clr (1-trans) 0 kd ks shine False, s7)+ | ("f", s1) <- lexcr s,+ (clr, s2) <- reads s1 :: [(Color,String)],+ (kd, s3) <- reads s2 :: [(Flt,String)],+ (ks, s4) <- reads s3 :: [(Flt,String)],+ (shine, s5) <- reads s4 :: [(Flt,String)],+ (trans, s6) <- reads s5 :: [(Flt,String)],+ (ior, s7) <- reads s6 :: [(Flt,String)] ] -instance Read (Rayint -> Material) where+instance Read (Texture () (Material ())) where readsPrec _ = readsSpdFill @@ -155,7 +158,7 @@ -- vert1.x vert1.y vert1.z -- [etc. for total_vertices vertices] -readsSpdSolid :: ReadS SolidItem+readsSpdSolid :: ReadS SI readsSpdSolid s = [((sphere center radius),s3) | ("s", s1) <- lexcr s, (center,s2) <- reads s1 :: [(Vec,String)], (radius,s3) <- reads s2 :: [(Flt,String)] ]@@ -182,9 +185,9 @@ -- same as readSpdVecs, just different types-readsSpdPrims :: ReadS [SolidItem]+readsSpdPrims :: ReadS [SI] readsSpdPrims s =- let parses = readsSpdSolid s :: [(SolidItem,String)]+ let parses = readsSpdSolid s :: [(SI,String)] in if null parses then [([],s)]@@ -193,25 +196,26 @@ (vs,returns) = head (readsSpdPrims rest) in [((v:vs),returns)] -instance Read [SolidItem] where+instance Read [SI] where readsPrec _ = readsSpdPrims -readsSpdTextureGroup :: ReadS SolidItem+readsSpdTextureGroup :: ReadS SI readsSpdTextureGroup s =- [((tex (bih prims) t),s2) | (t,s1) <- reads s :: [(Texture,String)],- (prims,s2) <- readsSpdPrims s1 :: [([SolidItem],String)] ]+ [((tex (bih prims) t),s2)+ | (t,s1) <- reads s :: [(Texture () (Material ()),String)],+ (prims,s2) <- readsSpdPrims s1 :: [([SI],String)] ] -instance Read SolidItem where+instance Read SI where readsPrec _ = readsSpdTextureGroup -accum_rss :: [Camera] -> [Light] -> [SolidItem] -> [BgColor] -> String -> ([Camera],[Light],[SolidItem],[BgColor],String)+accum_rss :: [Camera] -> [Light] -> [SI] -> [BgColor] -> String -> ([Camera],[Light],[SI],[BgColor],String) accum_rss cams lights prims background s = if null s then (cams,lights,prims,background,s) else let cam = reads s :: [(Camera,String)]- sld = reads s :: [(SolidItem,String)]+ sld = reads s :: [(SI,String)] lit = reads s :: [(Light,String)] bgc = reads s :: [(BgColor,String)] in@@ -237,14 +241,21 @@ else (cams,lights,prims,background,s) -readsSpdScene :: ReadS Scene+data SPD = SPD {+ geom :: SI,+ lights :: [Light],+ cam :: Camera,+ bground :: Color+}++readsSpdScene :: ReadS SPD readsSpdScene s = let ((cam:cams),lights,prims,(BgColor(bgc):bgcs),s1) = accum_rss [] [] [] [] s- in [((scene (bih prims) lights cam t_white bgc),s1)]+ in [((SPD (bih prims) lights cam bgc),s1)] -- | Read instance for scenes described in the Neutral File Format -- (NFF) used by SPD, a collection of standard benchmark scenes put -- together by Eric Haines. We support most NFF features, but not -- all.-instance Read Scene where+instance Read SPD where readsPrec _ = readsSpdScene
Data/Glome/Sphere.hs view
@@ -1,22 +1,24 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Data.Glome.Sphere (sphere) where import Data.Glome.Vec import Data.Glome.Solid -- | center, radius, 1/radius-data Sphere = Sphere !Vec !Flt !Flt deriving Show+data Sphere t m = Sphere !Vec !Flt !Flt deriving Show -- | Construct a sphere given a center location and a radius.-sphere :: Vec -> Flt -> SolidItem+sphere :: Vec -> Flt -> SolidItem t m sphere c r = SolidItem (Sphere c r (1.0/r)) -- adapted from graphics gems volume 1-rayint_sphere :: Sphere -> Ray -> Flt -> Texture -> Rayint-rayint_sphere (Sphere center r invr) (Ray e dir) dist t = +rayint_sphere :: Sphere tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_sphere (Sphere center r invr) ray@(Ray e dir) dist t tags = let eo = vsub center e v = vdot eo dir vsqr = v*v@@ -36,17 +38,17 @@ -- n = vscale (vsub p center) invr in -- n = vsub (vscale p invr) (vscale center invr) in n = vnorm (vsub p center) - in RayHit hitdist p n t+ in RayHit hitdist p n ray vzero t tags -packetint_sphere :: Sphere -> Ray -> Ray -> Ray -> Ray -> Flt -> Texture -> PacketResult-packetint_sphere s !r1 !r2 !r3 !r4 !d t =- PacketResult (rayint_sphere s r1 d t)- (rayint_sphere s r2 d t)- (rayint_sphere s r3 d t)- (rayint_sphere s r4 d t)+packetint_sphere :: Sphere tag mat -> Ray -> Ray -> Ray -> Ray -> Flt -> [Texture tag mat] -> [tag] -> PacketResult tag mat+packetint_sphere s !r1 !r2 !r3 !r4 !d t tags =+ PacketResult (rayint_sphere s r1 d t tags)+ (rayint_sphere s r2 d t tags)+ (rayint_sphere s r3 d t tags)+ (rayint_sphere s r4 d t tags) -shadow_sphere :: Sphere -> Ray -> Flt -> Bool+shadow_sphere :: Sphere tag mat -> Ray -> Flt -> Bool shadow_sphere (Sphere center r invr) (Ray e dir) dist = let eo = vsub center e v = vdot eo dir@@ -68,17 +70,17 @@ else False -inside_sphere :: Sphere -> Vec -> Bool+inside_sphere :: Sphere tag mat -> Vec -> Bool inside_sphere (Sphere center r invr) pt = let offset = vsub center pt in (vdot offset offset) < r*r -bound_sphere :: Sphere -> Bbox+bound_sphere :: Sphere tag mat -> Bbox bound_sphere (Sphere center r invr) = let offset = (vec r r r) in (Bbox (vsub center offset) (vadd center offset)) -instance Solid Sphere where +instance Solid (Sphere t m) t m where rayint = rayint_sphere packetint = packetint_sphere shadow = shadow_sphere
Data/Glome/Tex.hs view
@@ -1,4 +1,7 @@-module Data.Glome.Tex (tex) where+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Data.Glome.Tex (tex, tag) where import Data.Glome.Vec import Data.Glome.Solid @@ -19,39 +22,42 @@ -- part of the RayHit record) but Tex overwrites the -- texture with its own. -data Tex = Tex SolidItem Texture deriving Show +data Tag tag mat = Tag (SolidItem tag mat) tag+data Tex tag mat = Tex (SolidItem tag mat) (Texture tag mat) deriving Show+ -- | Associate a texture with an object. For composite -- objects, the shader uses the innermost texture.-tex :: SolidItem -> Texture -> SolidItem+tex :: SolidItem tag mat -> Texture tag mat -> SolidItem tag mat tex s t = SolidItem $ Tex s t -rayint_tex :: Tex -> Ray -> Flt -> Texture -> Rayint-rayint_tex (Tex s tex) r d t = rayint s r d tex+tag :: SolidItem tag mat -> tag -> SolidItem tag mat+tag s t = SolidItem $ Tag s t -rayint_debug_tex :: Tex -> Ray -> Flt -> Texture -> (Rayint,Int)-rayint_debug_tex (Tex s tex) r d t = rayint_debug s r d tex+instance Show (Tag tag mat) where+ show (Tag s t) = "<Tag " ++ show s ++ ">" -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+instance Solid (Tag t m) t m where+ rayint (Tag s tag) r d texs tags = rayint s r d texs (tag:tags)+ rayint_debug (Tag s tag) r d texs tags = rayint_debug s r d texs (tag:tags)+ packetint (Tag s tag) r1 r2 r3 r4 d texs tags = packetint s r1 r2 r3 r4 d texs (tag:tags)+ shadow (Tag s _) = shadow s+ inside (Tag s _) = inside s+ bound (Tag s _) = bound s+ primcount (Tag s _) = primcount s+ get_metainfo (Tag s tag) v = let (texs, tags) = get_metainfo s v+ in (texs, tag:tags) -shadow_tex :: Tex -> Ray -> Flt -> Bool-shadow_tex (Tex s _) r d = shadow s r d -inside_tex :: Tex -> Vec -> Bool-inside_tex (Tex s _) pt = inside s pt+instance Solid (Tex t m) t m where+ rayint (Tex s tex) r d texs tags = rayint s r d (tex:texs) tags+ rayint_debug (Tex s tex) r d texs tags = rayint_debug s r d (tex:texs) tags+ packetint (Tex s tex) r1 r2 r3 r4 d texs tags = packetint s r1 r2 r3 r4 d (tex:texs) tags+ shadow (Tex s _) = shadow s+ inside (Tex s _) = inside s+ bound (Tex s _) = bound s+ primcount (Tex s _) = primcount s+ get_metainfo (Tex s tex) v = let (texs, tags) = get_metainfo s v+ in (tex:texs, tags) -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
Data/Glome/Trace.hs view
@@ -5,38 +5,23 @@ import Data.Glome.Scene import Data.List -{--We put lighting code in this file because it needs to be -mutually recursive with the trace function, for refraction-and reflection.- -}+-- The complex type here allows us to do some precomputation of values that we+-- might need in layered textures that we don't want to computer over again.+-- For instance, if we have multiple textures we probably don't want to+-- re-compute the lighting.+-- We need a separate shader for a miss because in that case there are no+-- materials. +data Shader t m ctxa ctxb = Shader {+ preshade :: ctxa -> Ray -> SolidItem t m -> Rayint t m -> ctxb,+ postshade :: ctxa -> ctxb -> m -> Ray -> SolidItem t m -> Rayint t m -> Int -> (ColorA, [t]),+ missshade :: ctxa -> Ray -> SolidItem t m -> (ColorA, [t])+}+ -- | Result of tracing a packet of 4 rays at once. data PacketColor = PacketColor !Color !Color !Color !Color {--class (Show a) => Shader a where- -- ray intersection, scene, recursion limit- shade :: Rayint -> Ray -> Scene -> Int -> Color- shadepacket :: PacketResult -> Ray -> Ray -> Ray -> Ray -> Scene -> Int -> PacketColor-- shadepacket (PacketResult ri1 ri2 ri3 ri4) r1 r2 r3 r4 scene recurs =- PacketColor (shade ri1 r1 scene recurs)- (shade ri2 r2 scene recurs)- (shade ri3 r3 scene recurs)- (shade ri4 r4 scene recurs)--}--{--simple_shade :: Rayint -> [Light] -> Solid -> Color -> Color-simple_shade ri lights s bg =- case ri of- (RayHit d p n t) ->- let (Material clr refl refr ior kd shine) = t ri- in cscale clr (vdot n (Vec 0.0 1.0 0.0))- (RayMiss) -> bg--}- -- set rgb to normal's xyz coordinates -- as a debugging aid debug_norm_shade :: Rayint -> Ray -> Scene -> Int -> Int -> Color@@ -53,80 +38,43 @@ RayHit d p n t -> let (Material clr refl refr ior kd ks shine) = t ri in clr---- | This is the lighting routine that handles diffuse light, shadows, --- specular highlights and reflection. Given a ray intersection, the ray,--- a scene, and a recursion limit, return a color. "Debug" is a parameter--- useful for debugging; sometimes we might want to tint the color by --- the number of bounding boxes tested or something similar.--- Todo: refraction-shade :: Rayint -- ^ ray intersection returned by rayint- -> Ray -- ^ ray that resuted in the ray intersection- -> Scene -- ^ scene we're rendering- -> Int -- ^ recursion limit- -> Int -- ^ debugging value (usualy not used)- -> Color -- ^ computed color-shade ri (Ray o indir) scn recurs !debug = - case ri of- (RayHit d p n t) ->- let (Material clr refl_ refr ior kd ks shine) = t ri- s = sld scn- lights = lits scn- direct = foldl' cadd c_black - (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 = 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 = llen ** lexp- --intensity = 0.2- in- if vdot n lvec < 0 - then c_black- else- 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 - in cscale (trace scn - (Ray (vscaleadd p outdir delta) outdir) - infinity (recurs-1) ) refl_- else c_black- refract = - if (refr > delta) && (recurs > 0)- then c_black- else c_black- in- cadd direct $ cadd reflect_ refract+-} - (RayMiss) -> bground scn+opaque :: ColorA -> Bool+opaque (ColorA _ _ _ a) = a+delta >= 1 --- | Given a scene, a ray, a maximum distance, and a maximum+-- | Given a scene, a shader, a ray, a maximum distance, and a maximum -- recursion depth, test the ray for intersection against -- the object within the scene, then pass the ray intersection -- to the shade routine (which may trace secondary rays of its -- own), which returns a color. For most applications, this is -- the entry point into the ray tracer.-trace :: Scene -> Ray -> Flt -> Int -> Color-trace scn ray depth recurs =- let (Scene sld lights cam dtex bgcolor) = scn - in shade (rayint sld ray depth dtex) ray scn recurs 0- +trace :: ctxa -> Shader t m ctxa ctxb -> SolidItem t m -> Ray -> Flt -> Int -> (ColorA, [t], Rayint t m)+trace _ _ _ _ _ 0 = (ca_transparent, [], RayMiss)+trace ctxa (Shader pre post miss) sld ray depth recurs =+ let ri = rayint sld ray depth [] []+ ctxb = pre ctxa ray sld ri+ in+ case ri of+ RayMiss -> let (c, ts) = miss ctxa ray sld in (c, ts, ri)+ RayHit _ _ _ _ _ texs tags ->+ let+ (c, ts) =+ foldl+ (\acc@(colora, tagsa) tex ->+ if opaque colora+ then acc+ else+ let (colorb, tagsb) = post ctxa ctxb (tex ray ri) ray sld ri recurs+ in+ (cafold colora colorb, tagsb ++ tagsa)+ )+ (ca_transparent, [])+ texs+ in+ (c, ts++tags, ri)++{- -- | Similar to trace, but return depth as well as color. -- We might want the depth for post-processing effects. trace_depth :: Scene -> Ray -> Flt -> Int -> (Color,Flt)@@ -171,3 +119,5 @@ (shade ri2 ray2 scn recurs 0) (shade ri3 ray3 scn recurs 0) (shade ri4 ray4 scn recurs 0)++-}
Data/Glome/Triangle.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ module Data.Glome.Triangle (triangle, triangles, trianglenorm, trianglesnorms) where import Data.Glome.Vec import Data.Glome.Solid@@ -7,17 +10,17 @@ -- 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+data Triangle t m = Triangle Vec Vec Vec deriving Show+data TriangleNorm t m = TriangleNorm Vec Vec Vec Vec Vec Vec deriving Show -- | Create a simple triangle from its 3 corners. -- The normals are computed automatically.-triangle :: Vec -> Vec -> Vec -> SolidItem+triangle :: Vec -> Vec -> Vec -> SolidItem t m triangle v1 v2 v3 = SolidItem (Triangle v1 v2 v3) -- | Create a triangle fan from a list of verticies.-triangles :: [Vec] -> [SolidItem]+triangles :: [Vec] -> [SolidItem t m] triangles (v1:vs) = zipWith (\v2 v3 -> triangle v1 v2 v3) vs (tail vs) @@ -27,15 +30,15 @@ SolidItem (TriangleNorm v1 v2 v3 n1 n2 n3) -- | Create a triangle fan from a list of verticies and normals.-trianglesnorms :: [(Vec,Vec)] -> [SolidItem]+trianglesnorms :: [(Vec,Vec)] -> [SolidItem t m] trianglesnorms (vn1:vns) = zipWith (\vn2 vn3 -> trianglenorm (fst vn1) (fst vn2) (fst vn3) (snd vn1) (snd vn2) (snd vn3)) vns (tail vns) -- adaptation of Moller and Trumbore from pbrt page 127-rayint_triangle :: Triangle -> Ray -> Flt -> Texture -> Rayint-rayint_triangle (Triangle p1 p2 p3) (Ray o dir) dist tex =+rayint_triangle :: Triangle tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_triangle (Triangle p1 p2 p3) ray@(Ray o dir) dist tex tags = let e1 = vsub p2 p1 e2 = vsub p3 p1 s1 = vcross dir e2@@ -62,16 +65,43 @@ if (t < 0) || (t > dist) then RayMiss else- RayHit t (vscaleadd o dir t) (vnorm (vcross e1 e2)) tex+ RayHit t (vscaleadd o dir t) (vnorm (vcross e1 e2)) ray vzero tex tags -rayint_trianglenorm :: TriangleNorm -> Ray -> Flt -> Texture -> Rayint-rayint_trianglenorm (TriangleNorm p1 p2 p3 n1 n2 n3) (Ray o dir) dist tex =+shadow_triangle :: Triangle tag mat -> Ray -> Flt -> Bool+shadow_triangle (Triangle p1 p2 p3) (Ray o dir) dist = let e1 = vsub p2 p1 e2 = vsub p3 p1 s1 = vcross dir e2 divisor = vdot s1 e1 in if (divisor == 0)+ then False+ else+ let invdivisor = 1.0 / divisor+ d = vsub o p1 + b1 = (vdot d s1) * invdivisor+ in+ if (b1 < 0) || (b1 > 1) + then False + else+ let s2 = vcross d e1+ b2 = (vdot dir s2) * invdivisor+ in+ if (b2 < 0) || (b1 + b2 > 1) + then False+ else+ let t = (vdot e2 s2) * invdivisor+ in+ (t >= 0) && (t <= dist)++rayint_trianglenorm :: TriangleNorm tag mat -> Ray -> Flt -> [Texture tag mat] -> [tag] -> Rayint tag mat+rayint_trianglenorm (TriangleNorm p1 p2 p3 n1 n2 n3) ray@(Ray o dir) dist tex tags =+ let e1 = vsub p2 p1+ e2 = vsub p3 p1+ s1 = vcross dir e2+ divisor = vdot s1 e1+ in + if (divisor == 0) then RayMiss else let invdivisor = 1.0 / divisor@@ -96,9 +126,13 @@ n2scaled = (vscale n2 b1) n3scaled = (vscale n3 b2) norm = vnorm $ vadd3 n1scaled n2scaled n3scaled- in RayHit t (vscaleadd o dir t) norm tex+ in RayHit t (vscaleadd o dir t) norm ray vzero tex tags -bound_triangle :: Triangle -> Bbox+shadow_trianglenorm :: TriangleNorm tag mat -> Ray -> Flt -> Bool+shadow_trianglenorm (TriangleNorm p1 p2 p3 n1 n2 n3) r d =+ shadow_triangle (Triangle p1 p2 p3) r d++bound_triangle :: Triangle t m -> Bbox bound_triangle (Triangle (Vec v1x v1y v1z) (Vec v2x v2y v2z) (Vec v3x v3y v3z)) =@@ -111,17 +145,17 @@ ((fmax (fmax v1y v2y) v3y) + delta) ((fmax (fmax v1z v2z) v3z) + delta) ) -bound_trianglenorm :: TriangleNorm -> Bbox+bound_trianglenorm :: TriangleNorm t m -> Bbox bound_trianglenorm (TriangleNorm v1 v2 v3 n1 n2 n3) = bound (Triangle v1 v2 v3) -transform_triangle :: Triangle -> [Xfm] -> SolidItem+transform_triangle :: Triangle t m -> [Xfm] -> SolidItem t m 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 t m -> [Xfm] -> SolidItem t m transform_trianglenorm (TriangleNorm p1 p2 p3 n1 n2 n3) xfms = SolidItem $ TriangleNorm (xfm_point (compose xfms) p1) (xfm_point (compose xfms) p2)@@ -130,14 +164,16 @@ (vnorm $ xfm_vec (compose xfms) n2) (vnorm $ xfm_vec (compose xfms) n3) -instance Solid Triangle where+instance Solid (Triangle t m) t m where rayint = rayint_triangle+ shadow = shadow_triangle inside _ _ = False bound = bound_triangle transform = transform_triangle -instance Solid TriangleNorm where+instance Solid (TriangleNorm t m) t m where rayint = rayint_trianglenorm+ shadow = shadow_trianglenorm inside _ _ = False bound = bound_trianglenorm transform = transform_trianglenorm
GlomeTrace.cabal view
@@ -1,5 +1,5 @@ Name: GlomeTrace-Version: 0.2+Version: 0.3 Synopsis: Ray Tracing Library Description: A ray tracing library with acceleration structure and many supported primitives. License: GPL@@ -32,5 +32,6 @@ Data.Glome.Sphere Data.Glome.Tex Data.Glome.Triangle+ Data.Glome.Shader - Build-Depends: base >= 4 && < 5, array, GlomeVec >= 0.1.2+ Build-Depends: base >= 4 && < 5, array, GlomeVec >= 0.2