glome-hs-0.4.1: TestScene.hs
module TestScene where
import Vec
import Solid
import Clr
import Data.List hiding (group)
import SolidTexture
import System.Random
{-
lits = [Light {litpos = Vec {x = -3.0, y = 1.7, z = 5.0},
litcol = Color 0.9 1 1 },
Light {litpos = Vec {x = 1.1, y = -4.2, z = 4.0},
litcol = Color 1 0.9 1 },
Light {litpos = Vec {x = 4.3, y = 3.0, z = 2.3},
litcol = Color 1 1 0.9}]
-}
lits = [ Light (Vec (-100) 70 (140)) (cscale (Color 1 0.8 0.8) 1500)
, Light (Vec (-3) 5 8) (Color 1.5 2 2)
]
icosahedron pos r =
let gr = ((1+(sqrt 5))/2) -- golden ratio, 1.618033988749895
n11 = [(-r),r]
ngrgr = [(-gr)*r,gr*r]
grrcp = [((-r)/gr),(r/gr)]
points = [Vec x y z | x <- n11,
y <- n11,
z <- n11 ] ++
[Vec 0 y z | y <- grrcp,
z <- ngrgr ] ++
[Vec x y 0 | x <- grrcp,
y <- ngrgr] ++
[Vec x 0 z | x <- ngrgr,
z <- grrcp]
pln x = (Plane (vnorm x) (r+(vdot (vnorm x) pos)))
in
Intersection ((sphere pos (1.26*r)):(map pln points))
dodecahedron pos r =
let gr = (1+(sqrt 5))/2 -- golden ratio, 1.618033988749895
n11 = [(-r),r]
ngrgr = [(-gr)*r,gr*r]
points = [Vec 0 y z | y <- n11, z <- ngrgr] ++
[Vec x 0 z | z <- n11, x <- ngrgr] ++
[Vec x y 0 | x <- n11, y <- ngrgr]
pln x = (Plane (vnorm x) (r+(vdot (vnorm x) pos)))
in
Intersection ((sphere pos (1.26*r)):(map pln points))
cust_cam = camera (vec (-2) (4.3) (15)) (vec 0 2 0) (vec 0 1 0) 45
spiral = [ ((Vec ((sin (rot n))*n)
((cos (rot n))*n)
(n-3)), (n/15)) | n <- [0, 0.01..6]]
coil = bih (zipWith (\ (p1,r1) (p2,r2) -> (Solid.group [(cone p1 r1 p2 r2),
(sphere p1 r1)] ))
spiral
(tail spiral))
-- we branch once per year
-- not really a plausible oak, but it's getting there
oak :: Flt -> StdGen -> Solid
oak age rng =
if age < 0
then Solid.Nothing
else
let year :: Int = floor age
season = age-(fromIntegral year)
thickness = 0.03
minbranch = deg 10
maxbranch = deg 25
tree 0 r = Solid.Nothing
tree 1 r = -- cone (Vec 0 0 0) thickness (Vec 0 season 0) 0
Tex (sphere (Vec 0 0 0) season) (t_matte (Color 0.2 1 0.4))
tree n r = let nf = fromIntegral n
height = nf
(rng1,rng2) = split r
(rng3,rng4) = split rng1
(r1,rng5) = randomR (0,0.5) rng4
(r2,rng6) = randomR (minbranch,maxbranch) rng5
(r3,rng7) = randomR (0.8,0.95) rng6
seglen = 0.5 + r1
branchang = r2
scaling = r3
-- we make our own manual bounding heirarchy
-- (bih doesn't know what to do with heirachies
-- of transformed objects)
in Bound (sphere (Vec 0 (height/2) 0) (height/2))
(group [ cone (Vec 0 0 0) (thickness*nf) (Vec 0 seglen 0) (thickness*(nf-1)*scaling)
, transform (tree (n-1) rng2) [(scale (Vec scaling scaling scaling)),
(rotate (Vec 0 0 1) branchang),
(rotate (Vec 0 1 0) (deg 30)),
(translate (Vec 0 seglen 0))]
, transform (tree (n-1) rng3) [(scale (Vec scaling scaling scaling)),
(rotate (Vec 0 0 1) (-branchang)),
(rotate (Vec 0 1 0) (deg 30)),
(translate (Vec 0 seglen 0))]
])
in Tex (bih (flatten_transform (tree year rng))) (t_matte (Color 0.8 0.5 0.4))
sphereint = Intersection [ (sphere (Vec (-1) 0 0) 2),
(sphere (Vec 1 0 0) 2),
(sphere (Vec 0 (-1) 0) 2),
(sphere (Vec 0 1 0) 2) ]
-- scene with everything
-- can't have the plane inside a bih structure because it's infinite
geom = group [ Tex (plane (Vec 0 0 0) (Vec 0 1 0)) (t_matte (Color 0 0.8 0.3))
, bih [ Tex (dodecahedron (Vec (-6) 3 0) 1) t_stripe
, Tex (icosahedron (Vec 4 1.5 3) 1.5) t_mottled
--,(oak 11.6 (mkStdGen 42))
, transform (oak 11.6 (mkStdGen 42)) [ scale (Vec 1.5 1.5 1.5)]
, Tex (transform (coil) [ scale (Vec (1/3) (1/3) (1/3))
, rotate (Vec 0 1 0) (deg 65)
, translate (Vec (-3.5) 1 (5))
]) t_mirror --}
, cone (Vec (-6) 0 0) 1 (Vec (-6) 3 0) 0
, Tex (Difference (sphere (Vec 0 (-4) 5) 4.7) (sphere (Vec 1.5 (1.5) 5.2) 1.6)) t_mirror
, transform (Tex sphereint (t_matte (Color 0.5 0 1))) [ scale (Vec 0.6 0.6 0.6),
translate (Vec (-5.2) 1 5)]
]
]
geom1 = transform (oak 7.2 (mkStdGen 42)) [ scale (Vec 1.5 1.5 1.5)]
-- color reflect refract ior kd shine
m_shiny_white :: Material
m_shiny_white = (Material c_white 0.3 0 0 0.7 10)
t_shiny_white :: Texture
t_shiny_white ri = m_shiny_white
m_dull_gray :: Material
m_dull_gray = (Material (Color 0.4 0.3 0.35) 0 0 0 0.2 1)
t_mottled (RayHit _ pos norm _) =
--let scale = (stripe (Vec 1 1 1) sine_wave) pos
let scale = perlin (vscale pos 3)
in if scale < 0 then error "foo"
else if scale > 1
then error "bar"
else m_interp m_shiny_white m_dull_gray scale
--shouldn't happen
t_mottled RayMiss = m_shiny_white
t_stripe (RayHit _ pos norm _) =
let scale = (stripe (Vec 2 4 3) sine_wave) pos
in if scale < 0 then error "foo"
else if scale > 1
then error "bar"
else m_interp m_shiny_white m_dull_gray scale
--shouldn't happen
t_stripe RayMiss = m_shiny_white
t_matte c =
(\ri -> (Material c 0 0 0 1 2))
t_mirror =
(\ri -> (Material (Color 0.8 0.8 1) 1 0 0 0.2 100))
scn :: IO Scene
scn = return (Scene geom lits cust_cam (t_matte (Color 0.8 0.5 0.4)) (Color 0.4 0.5 0.8))