{-# LANGUAGE ScopedTypeVariables #-} module TestScene (scn, Scene, Tag, T, M, SI) where import Data.Glome.Scene import Data.List hiding (group) import Data.Glome.Texture import Data.Glome.Shader import Data.Glome.Trace import System.Random type Tag = String type T = Texture Tag M type M = Material Tag type SI = SolidItem Tag M type Scene = (SI, [Light], Camera, Shader Tag M [Light] [(Color, Vec)]) lights = [ light (Vec (-100) 70 (140)) (cscale (Color 1 0.8 0.8) 7000) , light (Vec (-3) 5 8) (cscale (Color 1.5 2 2) 10) ] lattice = let n = 10 :: Flt in bih [sphere (vec x y z) 0.2 | x <- [(-n)..n], y <- [(-n)..n], z <- [(-n)..n]] 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_offset (vnorm x) (r+(vdot (vnorm x) pos))) in tag (intersection ((sphere pos (1.26*r)):(map pln points))) "icosahedron" 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_offset (vnorm x) (r+(vdot (vnorm x) pos))) in tag (intersection ((sphere pos (1.26*r)):(map pln points))) "dodecahedron" 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) -> (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 -> SI oak age rng = if age < 0 then nothing else let year :: Int = floor age season = age-(fromIntegral year) thickness = 0.03 minbranch = deg 10 maxbranch = deg 25 tree 0 r = 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 (r4,rng8) = randomR (0.0,1.0) rng7 seglen = 0.5 + r1 branchang = r2 scaling = r3 (height,n) = if r4 > (1 :: Float) then ((height_/2),(ceiling (nf/2))) else (height_, n_) -- we make our own manual bounding heirarchy -- (bih doesn't know what to do with heirachies -- of transformed objects) in bound_object (sphere (Vec 0 (height/2) 0) (height/2)) (group [ cone (Vec 0 0 0) (thickness*height) (Vec 0 seglen 0) (thickness*(height-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 tag (tex (bih (tolist (SolidItem (flatten_transform (tree year rng))))) (t_matte (Color 0.8 0.5 0.4))) "tree" 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) ] 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 (transform (icosahedron (Vec 4 1.5 3) 1.5) [ rotate vz (deg 11) , rotate vx (deg 7) ] ) t_mottled , 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)] ] ] geom' = group [ (box (Vec (-1) (-1) (-1)) (Vec 1 1 1)), (group [ (sphere (Vec 2 3 0) 1), (sphere (Vec (-3) (4) 1) 0.8) ]) ] -- cust_cam = camera (vec (-2) (5.3) (20)) (vec 0 5 0) (vec 0 1 0) 45 cust_cam = camera (vec (-2) (4.3) (15)) (vec 0 2 0) (vec 0 1 0) 45 chessboard = group [tex (box (vec (x-(1/2)) (-3) (z-(1/2))) (vec (x+(1/2)) (f x z) (z+(1/2)))) (tf x z) | x <- [(-3.5)..3.5], z <- [(-3.5)..3.5]] where f x y = (x*y)/40 tf x y = if mod ((floor x) + (floor y)) 2 == 0 then t_shiny_white else t_mottled portal height width thickness = let frame = tag (tex (difference (box (vec (-width) 0 (-thickness)) (vec width height thickness)) (box (vec (thickness-width) (thickness) (-(thickness+delta))) (vec (width-thickness) (height-thickness) (thickness+delta)))) (t_matte (Color 0.4 0.4 0.8))) "door frame" surface = (box (vec (-width) 0 (-delta)) (vec (width) (height-delta) delta)) xfm ray@(Ray origin dir) (RayHit depth pos norm _ _ _ _) = xfm_ray (compose [ rotate vx (deg (-85)) , translate (vec (8) 40 (-4)) ]) (Ray pos (vnorm dir)) --Ray (vadd pos (vec 0 15 0)) (vrotate pos (Ray pos vx) (deg 90)) in group [frame, tex surface (t_uniform (Warp frame geom'' lights xfm))] geom'' = bih [ difference (transform chessboard [scale (vec 2 1.2 2)]) (tex (sphere (vec 4 1.5 3) 3.5) t_shiny_white) , tex (dodecahedron (vec (-6) 3 0) 1) t_stripe , tex (transform (icosahedron (Vec 4 1.5 3) 1.5) [ rotate vz (deg 11) , rotate vx (deg 7) ] ) t_mottled , cone (Vec (-6) (-1) 0) 0.7 (Vec (-6) 3 0) 0 , transform (oak 11.4 (mkStdGen 42)) [ scale (Vec 2 2 2), translate (vec 2 (-1) (-8))] , tex (difference (transform (lattice) [rotate vz (deg 23), rotate vx (deg 43), scale (vec 3 3 3) ]) (sphere (vec 0 0 0) 32)) t_shiny_red , transform (portal 5 2 (1/3)) [ rotate vy (deg 8) , translate (vec (-3) 0.5 (-5))] ] -- some textures m_shiny_white :: M m_shiny_white = (Surface c_white 1 0.2 0.8 0.4 10 False) m_shiny_red = (Surface c_red 1 0.2 0.8 0.4 10 False) t_shiny_white :: T t_shiny_white _ _ = m_shiny_white t_shiny_red _ _ = m_shiny_red m_dull_gray :: M m_dull_gray = (Surface (Color 0.4 0.3 0.35) 1 0.2 0.8 0 0 False) 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 "perlin under range" else if scale > 1 then error "perlin over range" else Blend m_mirror (m_matte (Color 0.15 0.3 0.5)) scale --shouldn't happen t_mottled _ RayMiss = m_shiny_white t_stripe :: T t_stripe _ (RayHit _ pos norm _ _ _ _) = let scale = (stripe (Vec 4 8 5) triangle_wave) pos in if scale < 0 then error "perlin under range" else if scale > 1 then error "perlin over range" else Blend m_shiny_white m_dull_gray scale --shouldn't happen t_stripe _ RayMiss = m_shiny_white m_matte :: Color -> M m_matte c = (Surface c 1 0.2 1 0 0 False) t_matte :: Color -> T t_matte c = (\_ _ -> m_matte c) m_mirror = (Reflect 0.8) t_mirror = (\_ _ -> m_mirror) c_sky = (Color 0.4 0.5 0.8) scn :: IO Scene scn = return (geom'', lights, cust_cam, materialShader)