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
}
light :: Vec -> Color -> Light
light pos clr = Light pos clr (\x -> 1/(x*x)) infinity True
--MATERIALS--
data Material t =
Surface Color Flt Flt Flt Flt Flt Bool |
Reflect Flt |
Refract Flt Flt |
Warp (SolidItem t (Material t))
(SolidItem t (Material t))
[Light]
(Ray -> Rayint t (Material t) -> Ray) |
AdditiveLayers [Material t] |
Blend (Material t) (Material t) Flt
t_uniform :: Material t -> Texture t (Material t)
t_uniform m = \_ _ -> m
--SHADER--
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
(recurs1))
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
(recurs1))
(wcolor, wtags, wint) =
(trace lights'
materialShader
scene'
(xfm ray rayint)
(ridepth fint)
(recurs1))
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