GlomeView 0.2 → 0.3
raw patch · 3 files changed
+126/−59 lines, 3 filesdep ~GlomeTracedep ~GlomeVec
Dependency ranges changed: GlomeTrace, GlomeVec
Files
- Glome.hs +48/−20
- GlomeView.cabal +2/−2
- TestScene.hs +76/−37
Glome.hs view
@@ -21,20 +21,30 @@ maxdepth = 3 -- recursion depth for reflection/refraction --- compute ray, invoke trace function, return color-get_color :: Flt -> Flt -> Scene -> (Scene.Color,Flt)-get_color x y scn = - let (Scene sld lights (Camera pos fwd up right) dtex bgcolor) = scn+get_rayint :: Flt -> Flt -> Scene -> (Scene.ColorA, [Tag], Rayint Tag M)+get_rayint x y scn = + let (sld, lights, (Camera pos fwd up right), shader) = scn dir = vnorm $ vadd3 fwd (vscale right (-x)) (vscale up y) ray = (Ray pos dir) in- ((Trace.trace scn ray infinity maxdepth),0)+ Trace.trace lights shader sld ray infinity maxdepth -get_color' :: Flt -> Flt -> Scene -> (Scene.Color,Flt)++get_color x y scn =+ let (color, tags, ri) = get_rayint x y scn+ in (color, 0) ++get_color' :: Flt -> Flt -> Scene -> (Scene.ColorA,Flt) get_color' x y _ =- (Scene.Color x y (x+y), 0)+ (Scene.ColorA x y (x+y) 1, 0) ++get_tags x y scn =+ let (color, tags, ri) = get_rayint x y scn+ in tags+ -- compute a 2x2 packet of four rays from corners of box+{- get_packet :: Flt -> Flt -> Flt -> Flt -> Scene -> PacketColor get_packet x1 y1 x2 y2 scn = let (Scene sld lights (Camera pos fwd up right) dtex bgcolor) = scn@@ -47,6 +57,7 @@ ray3 = Ray pos dir3 ray4 = Ray pos dir4 in trace_packet scn ray1 ray2 ray3 ray4 infinity maxdepth+-} cap1 :: Flt -> Flt cap1 x@@ -76,10 +87,6 @@ else error "setPixel32 -- bad coordinate" where offset = y * (fromIntegral $ surfaceGetPitch surf `div` 4) + x -{--renderTile :: Rect -> Surface -> IO ()-renderTile (Rect xmin xmax width height) (surf = do- -} -- r g b debug index data Tile = Tile Rect (UV.Vector (Flt, Flt, Flt, Flt))@@ -90,6 +97,7 @@ -- We pass in the Rect for the whole image, and a sub-Rect for the tile -- we want to render.+-- We throw away the alpha value here. renderTile :: Rect -> Rect -> Scene -> Tile renderTile (Rect _ _ width height) t@(Rect xtmin ytmin twidth theight) scene = let widthf = fromIntegral width@@ -99,7 +107,7 @@ yf = fromIntegral $ ytmin + (div i twidth) xcoord = (((xf/widthf)*2)-1) * (widthf/heightf) ycoord = -(((yf/heightf)*2)-1)- (Scene.Color r g b, d) = get_color xcoord ycoord scene+ (ColorA r g b _, d) = get_color xcoord ycoord scene --(r,g,b,d) = (0.5, 0, 0, 0) in (r, g, b, d)@@ -156,19 +164,39 @@ heightf = fromIntegral height xcoord = (((xf/widthf)*2)-1) * (widthf/heightf) ycoord = -(((yf/heightf)*2)-1)- (Scene.Color r g b, d) = get_color xcoord ycoord scene+ (ColorA r g b _, d) = get_color xcoord ycoord scene in do _ <- fillRect surf (Just (Rect x y 1 1)) (rgbf r g b) return () ) ) -quitHandler :: IO ()-quitHandler = do- e <- waitEvent+getTags' x y scn =+ let xf = fromIntegral $ x+ yf = fromIntegral $ y+ widthf = fromIntegral xres+ heightf = fromIntegral yres+ xcoord = (((xf/widthf)*2)-1) * (widthf/heightf)+ ycoord = -(((yf/heightf)*2)-1)+ in + get_tags xcoord ycoord scn++runHandler :: Scene -> IO ()+runHandler scn = do+ e <- pollEvent+ --e <- waitEvent case e of Quit -> return ()- otherwise -> quitHandler+ MouseButtonUp x y ButtonLeft ->+ do let ts = getTags' x y scn+ print $ (show x) ++ " " ++ (show y) ++ ":"+ forM_ ts print+ runHandler scn+ NoEvent ->+ do delay 50+ runHandler scn+ otherwise -> + runHandler scn main = do SDL.init [InitVideo, InitTimer, InitJoystick]@@ -179,9 +207,9 @@ img <- createRGBSurface [HWSurface] xres yres 32 0 0 0 0 setupt1 <- getPOSIXTime- scene <- TestScene.scn+ scene@(geom, _, _, _) <- TestScene.scn - print $ "(primitives,transforms,bounding objects): " ++ (show (primcount_scene scene))+ print $ "(primitives,transforms,bounding objects): " ++ (show (primcount geom)) setupt2 <- getPOSIXTime print $ "scene setup: " ++ (show (setupt2-setupt1)) @@ -197,4 +225,4 @@ blitt2 <- getPOSIXTime print $ "blit: " ++ (show (blitt2-blitt1)) - quitHandler+ runHandler scene
GlomeView.cabal view
@@ -1,5 +1,5 @@ Name: GlomeView-Version: 0.2+Version: 0.3 Synopsis: SDL Frontend for Glome ray tracer Description: Ray Tracer capable of rendering a variety of primitives, with support for CSG (difference and intersection of solids),@@ -23,4 +23,4 @@ Main-Is: Glome.hs ghc-options: -O2 -threaded extensions: BangPatterns- Build-Depends: base >= 4 && < 5, time, monad-par, deepseq, random, vector, GlomeVec, GlomeTrace, SDL+ Build-Depends: base >= 4 && < 5, time, monad-par, deepseq, random, vector, GlomeVec >= 0.2, GlomeTrace >= 0.2, SDL
TestScene.hs view
@@ -1,11 +1,19 @@ {-# LANGUAGE ScopedTypeVariables #-} -module TestScene (scn) where+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) ] @@ -32,7 +40,7 @@ z <- grrcp] pln x = (plane_offset (vnorm x) (r+(vdot (vnorm x) pos))) in- intersection ((sphere pos (1.26*r)):(map pln points))+ tag (intersection ((sphere pos (1.26*r)):(map pln points))) "icosahedron" dodecahedron pos r = let gr = (1+(sqrt 5))/2 -- golden ratio, 1.618033988749895@@ -43,7 +51,7 @@ [Vec x y 0 | x <- n11, y <- ngrgr] pln x = (plane_offset (vnorm x) (r+(vdot (vnorm x) pos))) in- intersection ((sphere pos (1.26*r)):(map pln points))+ tag (intersection ((sphere pos (1.26*r)):(map pln points))) "dodecahedron" spiral = [ ((Vec ((sin (rot n))*n) ((cos (rot n))*n) @@ -55,10 +63,9 @@ spiral (tail spiral)) - -- we branch once per year -- not really a plausible oak, but it's getting there-oak :: Flt -> StdGen -> SolidItem+oak :: Flt -> StdGen -> SI oak age rng = if age < 0 then nothing@@ -100,7 +107,7 @@ (rotate (Vec 0 1 0) (deg 30)), (translate (Vec 0 seglen 0))] ])- in tex (bih (tolist (SolidItem (flatten_transform (tree year rng))))) (t_matte (Color 0.8 0.5 0.4)) + 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),@@ -133,7 +140,7 @@ chessboard = group [tex- (box (vec (x-(1/2)) (-1) (z-(1/2)))+ (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@@ -142,8 +149,39 @@ 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'' =- group+ 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)@@ -152,60 +190,61 @@ , 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) 17)) t_shiny_red+ 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 :: Material-m_shiny_white = (Material c_white 0.3 0 0 0.7 0.8 10)+m_shiny_white :: M+m_shiny_white = (Surface c_white 1 0.2 0.8 0.4 10 False) -m_shiny_red = (Material c_red 0.3 0 0 0.7 0.8 10)+m_shiny_red = (Surface c_red 1 0.2 0.8 0.4 10 False) -t_shiny_white :: Texture-t_shiny_white ri = m_shiny_white+t_shiny_white :: T+t_shiny_white _ _ = m_shiny_white -t_shiny_red _ = m_shiny_red+t_shiny_red _ _ = m_shiny_red -m_dull_gray :: Material-m_dull_gray = (Material (Color 0.4 0.3 0.35) 0 0 0 0.2 0 1)+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 _) =+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"+ in if scale < 0 then error "perlin under range" else if scale > 1 - then error "bar"- else m_interp m_mirror (m_matte (Color 0.15 0.3 0.5)) scale+ 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_mottled _ RayMiss = m_shiny_white -t_stripe (RayHit _ pos norm _) =+t_stripe :: T+t_stripe _ (RayHit _ pos norm _ _ _ _) = let scale = (stripe (Vec 4 8 5) triangle_wave) pos- in if scale < 0 then error "foo"+ in if scale < 0 then error "perlin under range" else if scale > 1 - then error "bar"- else m_interp m_shiny_white m_dull_gray scale+ then error "perlin over range"+ else Blend m_shiny_white m_dull_gray scale --shouldn't happen-t_stripe RayMiss = m_shiny_white +t_stripe _ RayMiss = m_shiny_white -m_matte :: Color -> Material-m_matte c = (Material c 0 0 0 1 0 2)+m_matte :: Color -> M+m_matte c = (Surface c 1 0.2 1 0 0 False) -t_matte :: Color -> Texture+t_matte :: Color -> T t_matte c = - (\ri -> (Material c 0 0 0 1 0 2)) + (\_ _ -> m_matte c) -m_mirror = (Material (Color 0.8 0.8 1) 1 0 0 0.2 0.8 1000)+m_mirror = (Reflect 0.8) t_mirror = - (\ri -> m_mirror)+ (\_ _ -> m_mirror) c_sky = (Color 0.4 0.5 0.8) scn :: IO Scene-scn = return (Scene geom''- lights cust_cam - (t_matte (Color 0.6 0.5 0.4)) - (Color 0.2 0.2 0.2))+scn = return (geom'', lights, cust_cam, materialShader)+