module Data.Glome.Solid where
import Data.Glome.Vec
import Data.Glome.Clr
import Data.List hiding (group)
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 tag mat
raymiss = RayMiss
ridepth RayMiss = infinity
ridepth ri = ridepth' ri
nearest :: Rayint tag mat -> Rayint tag mat -> Rayint tag mat
nearest a RayMiss = a
nearest RayMiss b = b
nearest a@(RayHit !da _ _ _ _ _ _) b@(RayHit !db _ _ _ _ _ _) =
if da < db
then a
else b
furthest :: Rayint tag mat -> Rayint tag mat -> Rayint tag mat
furthest _ RayMiss = RayMiss
furthest RayMiss _ = RayMiss
furthest a@(RayHit !da _ _ _ _ _ _) b@(RayHit !db _ _ _ _ _ _) =
if da > db
then a
else b
hit :: Rayint tag mat -> Bool
hit (RayHit _ _ _ _ _ _ _) = True
hit RayMiss = False
dist :: Rayint tag mat -> Flt
dist RayMiss = infinity
dist (RayHit d _ _ _ _ _ _) = d
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 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)
(nearest a3 b3)
(nearest a4 b4)
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) (da) t tags) of
RayMiss -> RayMiss
RayHit depth pos norm ray uvw tex tags -> RayHit (depth+a) pos norm ray uvw tex tags
type Texture tag mat = Ray -> Rayint tag mat -> mat
instance Show (Texture t m) where
show t = "Texture"
newtype Pcount = Pcount (Int,Int,Int) deriving Show
pcadd :: Pcount -> Pcount -> Pcount
pcadd (Pcount (a1,a2,a3)) (Pcount (b1,b2,b3)) = Pcount (a1+b1, a2+b2, a3+b3)
asbound :: Pcount -> Pcount
asbound (Pcount (a,b,c)) = Pcount (0,b,a+c)
pcsinglexfm :: Pcount
pcsinglexfm = Pcount (0,1,0)
pcsingleprim :: Pcount
pcsingleprim = Pcount (1,0,0)
pcsinglebound :: Pcount
pcsinglebound = Pcount (0,0,1)
pcnone :: Pcount
pcnone = Pcount (0,0,0)
debug_wrap :: (Rayint tag mat, Int) -> Int -> (Rayint tag mat, Int)
debug_wrap (ri, a) b = (ri, (a+b))
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))
class (Show s) => Solid s t m | s -> t, s -> m where
rayint :: s
-> Ray
-> Flt
-> [Texture t m]
-> [t]
-> Rayint t m
rayint_debug :: s -> Ray -> Flt -> [Texture t m] -> [t] -> (Rayint t m, Int)
packetint :: s -> Ray -> Ray -> Ray -> Ray -> Flt -> [Texture t m] -> [t] -> PacketResult t m
shadow :: s -> Ray -> Flt -> Bool
inside :: s -> Vec -> Bool
bound :: s -> Bbox
tolist :: s -> [SolidItem t m]
transform :: s -> [Xfm] -> SolidItem t m
transform_leaf :: s -> [Xfm] -> SolidItem t m
flatten_transform :: s -> [SolidItem t m]
primcount :: s -> Pcount
get_metainfo :: s -> Vec -> ([Texture t m], [t])
rayint_debug s !r !d t tags = ((rayint s r d t tags), 0)
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)
shadow s !r !d =
case (rayint s r d undefined []) of
RayHit _ _ _ _ _ _ _ -> True
RayMiss -> False
tolist s = [SolidItem s]
transform s xfm = SolidItem $ Instance (SolidItem s) (compose xfm)
transform_leaf = transform
flatten_transform = tolist
primcount s = pcsingleprim
get_metainfo s v = ([],[])
data SolidItem t m = forall s. Solid s t m => SolidItem s
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
tolist (SolidItem s) = tolist s
transform (SolidItem s) xfm = transform s xfm
transform_leaf (SolidItem s) xfm = transform_leaf s xfm
flatten_transform (SolidItem s) = [SolidItem (flatten_transform s)]
primcount (SolidItem s) = primcount s
get_metainfo (SolidItem s) v = get_metainfo s v
instance Show (SolidItem t m) where
show (SolidItem s) = "SI " ++ show s
group :: [SolidItem t m] -> SolidItem t m
group [] = SolidItem Void
group (sld:[]) = sld
group slds = SolidItem (flatten_group slds)
flatten_group :: [SolidItem t m] -> [SolidItem t m]
flatten_group slds = concat (map tolist slds)
paircat :: ([a],[b]) -> ([a],[b]) -> ([a],[b])
paircat (a1,b1) (a2,b2) = (a1++a2, b1++b2)
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
data Void t m = Void deriving Show
nothing = SolidItem Void
instance Solid (Void t m) t m where
rayint Void _ _ _ _ = RayMiss
packetint Void _ _ _ _ _ _ _ = packetmiss
shadow Void _ _ = False
inside Void _ = False
bound Void = empty_bbox
tolist Void = []
transform Void xfms = SolidItem Void
data Instance t m = Instance (SolidItem t m) Xfm deriving Show
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 tags) of
RayMiss -> RayMiss
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 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 tags =
let newdir1 = invxfm_vec xfm dir1
newdir2 = invxfm_vec xfm dir2
newdir3 = invxfm_vec xfm dir3
newdir4 = invxfm_vec xfm dir4
neworig1 = invxfm_point xfm orig1
neworig2 = invxfm_point xfm orig2
neworig3 = invxfm_point xfm orig3
neworig4 = invxfm_point xfm orig4
lenscale1 = vlen newdir1
lenscale2 = vlen newdir2
lenscale3 = vlen newdir3
lenscale4 = vlen newdir4
invlenscale1 = 1/lenscale1
invlenscale2 = 1/lenscale2
invlenscale3 = 1/lenscale3
invlenscale4 = 1/lenscale4
in
let pr = packetint sld (Ray neworig1 (vscale newdir1 invlenscale1))
(Ray neworig2 (vscale newdir2 invlenscale2))
(Ray neworig3 (vscale newdir3 invlenscale3))
(Ray neworig4 (vscale newdir4 invlenscale4))
(d*lenscale1) t tags
PacketResult ri1 ri2 ri3 ri4 = pr
fix ri ils =
case ri of
RayMiss -> RayMiss
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)
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 tags of
(RayMiss, count) -> (RayMiss, 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 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
lenscale = vlen newdir
invlenscale = 1/lenscale
in
shadow sld (Ray neworig (vscale newdir invlenscale)) (d*lenscale)
inside_instance :: Instance tag mat -> Vec -> Bool
inside_instance (Instance s xfm) pt =
inside s (invxfm_point xfm pt)
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
in
bbpts [(pxfm (Vec x y z)) | x <- [p1x,p2x],
y <- [p1y,p2y],
z <- [p1z,p2z]]
transform_instance :: Instance tag mat -> [Xfm] -> SolidItem tag mat
transform_instance (Instance s xfm2) xfm1 =
transform s [compose ([xfm2]++xfm1) ]
transform_leaf_instance :: Instance tag mat -> [Xfm] -> SolidItem tag mat
transform_leaf_instance (Instance s xfm2) xfm1 =
transform_leaf s [compose ([xfm2]++xfm1) ]
flatten_transform_instance :: Instance tag mat -> [SolidItem tag mat]
flatten_transform_instance (Instance s xfm) =
[SolidItem $ transform_leaf s [xfm]]
primcount_instance :: Instance tag mat -> Pcount
primcount_instance (Instance s xfm) = pcadd (primcount s) pcsinglexfm
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
shadow = shadow_instance
inside = inside_instance
bound = bound_instance
transform = transform_instance
transform_leaf = transform_leaf_instance
flatten_transform = flatten_transform_instance
primcount = primcount_instance
get_metainfo = get_metainfo_instance