diff --git a/Data/Glome/Bih.hs b/Data/Glome/Bih.hs --- a/Data/Glome/Bih.hs +++ b/Data/Glome/Bih.hs @@ -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 diff --git a/Data/Glome/Bound.hs b/Data/Glome/Bound.hs --- a/Data/Glome/Bound.hs +++ b/Data/Glome/Bound.hs @@ -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 diff --git a/Data/Glome/Box.hs b/Data/Glome/Box.hs --- a/Data/Glome/Box.hs +++ b/Data/Glome/Box.hs @@ -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 diff --git a/Data/Glome/Clr.hs b/Data/Glome/Clr.hs --- a/Data/Glome/Clr.hs +++ b/Data/Glome/Clr.hs @@ -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 + + diff --git a/Data/Glome/Cone.hs b/Data/Glome/Cone.hs --- a/Data/Glome/Cone.hs +++ b/Data/Glome/Cone.hs @@ -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 diff --git a/Data/Glome/Csg.hs b/Data/Glome/Csg.hs --- a/Data/Glome/Csg.hs +++ b/Data/Glome/Csg.hs @@ -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 diff --git a/Data/Glome/Plane.hs b/Data/Glome/Plane.hs --- a/Data/Glome/Plane.hs +++ b/Data/Glome/Plane.hs @@ -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 diff --git a/Data/Glome/Scene.hs b/Data/Glome/Scene.hs --- a/Data/Glome/Scene.hs +++ b/Data/Glome/Scene.hs @@ -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) --} diff --git a/Data/Glome/Shader.hs b/Data/Glome/Shader.hs new file mode 100644 --- /dev/null +++ b/Data/Glome/Shader.hs @@ -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 +-} diff --git a/Data/Glome/Solid.hs b/Data/Glome/Solid.hs --- a/Data/Glome/Solid.hs +++ b/Data/Glome/Solid.hs @@ -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 diff --git a/Data/Glome/Spd.hs b/Data/Glome/Spd.hs --- a/Data/Glome/Spd.hs +++ b/Data/Glome/Spd.hs @@ -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 diff --git a/Data/Glome/Sphere.hs b/Data/Glome/Sphere.hs --- a/Data/Glome/Sphere.hs +++ b/Data/Glome/Sphere.hs @@ -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 diff --git a/Data/Glome/Tex.hs b/Data/Glome/Tex.hs --- a/Data/Glome/Tex.hs +++ b/Data/Glome/Tex.hs @@ -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) = "" -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 diff --git a/Data/Glome/Trace.hs b/Data/Glome/Trace.hs --- a/Data/Glome/Trace.hs +++ b/Data/Glome/Trace.hs @@ -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) + +-} diff --git a/Data/Glome/Triangle.hs b/Data/Glome/Triangle.hs --- a/Data/Glome/Triangle.hs +++ b/Data/Glome/Triangle.hs @@ -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 diff --git a/GlomeTrace.cabal b/GlomeTrace.cabal --- a/GlomeTrace.cabal +++ b/GlomeTrace.cabal @@ -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