GlomeView (empty) → 0.2
raw patch · 6 files changed
+469/−0 lines, 6 filesdep +GlomeTracedep +GlomeVecdep +SDLsetup-changed
Dependencies added: GlomeTrace, GlomeVec, SDL, base, deepseq, monad-par, random, time, vector
Files
- Glome.hs +200/−0
- GlomeView.cabal +26/−0
- LICENSE +14/−0
- README.txt +12/−0
- Setup.hs +6/−0
- TestScene.hs +211/−0
+ Glome.hs view
@@ -0,0 +1,200 @@++import Control.DeepSeq(NFData, rnf)+import Control.Monad.Par+import Graphics.UI.SDL as SDL+import Control.Monad(forM_)+import Foreign.Storable+import Foreign.Ptr+import Data.Word+import Data.Time.Clock.POSIX++import Data.Vector.Generic.Base+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as UV+import qualified Data.Vector.Generic as GV++import Data.Glome.Scene as Scene+import Data.Glome.Trace as Trace+import Data.Glome.Spd as Spd+import TestScene+++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+ dir = vnorm $ vadd3 fwd (vscale right (-x)) (vscale up y)+ ray = (Ray pos dir) + in+ ((Trace.trace scn ray infinity maxdepth),0)++get_color' :: Flt -> Flt -> Scene -> (Scene.Color,Flt)+get_color' x y _ =+ (Scene.Color x y (x+y), 0)++-- 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+ dir1 = vnorm $ vadd3 fwd (vscale right (-x1)) (vscale up y1)+ dir2 = vnorm $ vadd3 fwd (vscale right (-x2)) (vscale up y1)+ dir3 = vnorm $ vadd3 fwd (vscale right (-x1)) (vscale up y2)+ dir4 = vnorm $ vadd3 fwd (vscale right (-x2)) (vscale up y2)+ ray1 = Ray pos dir1+ ray2 = Ray pos dir2+ ray3 = Ray pos dir3+ ray4 = Ray pos dir4+ in trace_packet scn ray1 ray2 ray3 ray4 infinity maxdepth++cap1 :: Flt -> Flt+cap1 x+ | x >= 1 = 1-delta+ | otherwise = x ++-- mapRGB does this, but we need a pixel format...+rgb :: Int -> Int -> Int -> Pixel+rgb r g b = Pixel $ (fromIntegral r)*(256*256) + (fromIntegral g)*256 + (fromIntegral b)++rgbf :: Flt -> Flt -> Flt -> Pixel+rgbf r g b = Pixel $ (floor ((cap1 r)*256))*(256*256) ++ (floor ((cap1 g)*256))*256 ++ (floor ((cap1 b)*256))++xres = 720+yres = 480+blocksize = 64+++-- from http://stackoverflow.com/questions/5443259/loading-a-opengl-image-with-sdl-image+setPixel32 :: Surface -> Int -> Int -> Pixel -> IO ()+setPixel32 surf x y (Pixel pixel) = do+ ps <- surfaceGetPixels surf+ if x >= 0 && x < surfaceGetWidth surf && y >= 0 && y < surfaceGetHeight surf+ then pokeElemOff (castPtr ps :: Ptr Word32) offset pixel+ 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))++instance NFData Tile where+ rnf (Tile r v) = rnf v+++-- We pass in the Rect for the whole image, and a sub-Rect for the tile+-- we want to render.+renderTile :: Rect -> Rect -> Scene -> Tile+renderTile (Rect _ _ width height) t@(Rect xtmin ytmin twidth theight) scene =+ let widthf = fromIntegral width+ heightf = fromIntegral height+ gen i =+ let xf = fromIntegral $ xtmin + (mod i twidth)+ 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+ --(r,g,b,d) = (0.5, 0, 0, 0)+ in+ (r, g, b, d)+ + in Tile t (UV.generate (twidth * theight) gen)++blitTile :: Surface -> Tile -> IO ()+blitTile surf (Tile (Rect xtmin ytmin twidth theight) pixels) =+ UV.zipWithM_ drawf (UV.fromList [0..((twidth*theight)-1)]) pixels+ where+ drawf i (r, g, b, d) = + setPixel32 surf (xtmin + (mod i twidth)) (ytmin + (div i twidth)) (rgbf r g b)+++ {- do+ _ <- fillRect+ surf+ (Just (Rect (xtmin + (mod i twidth)) + (ytmin + (div i twidth)) 1 1))+ (rgbf r g b)+ return () -}++-- Given an Int, return a list of Ints broken down into blocksize chunks.+-- Each chunk is an (offset,size) tuple.+chunk size blocksize =+ go 0+ where+ go pos =+ if pos + blocksize >= size+ then [(pos, (size-pos))]+ else (pos, blocksize) : (go (pos+blocksize))++renderTiles :: Surface -> Scene -> Int -> IO ()+renderTiles surf scene blocksize = do+ srect@(Rect _ _ width height) <- getClipRect surf+ let xchunks = chunk width blocksize+ let ychunks = chunk height blocksize+ let blocks = [Rect xpos ypos width height | (xpos, width) <- xchunks, (ypos, height) <- ychunks]+ let tiles = runPar $ parMap (\block -> renderTile srect block scene) blocks+ forM_ tiles (blitTile surf)+ ++-- Simple version, not amenable to parallelization.+render :: Surface -> Scene -> IO ()+render surf scene = do+ Rect xmin ymin width height <- getClipRect surf+ let xmax = xmin+width+ let ymax = ymin+height+ forM_ [xmin..xmax] (\x ->+ forM_ [ymin..ymax] (\y ->+ let xf = fromIntegral x+ yf = fromIntegral y+ widthf = fromIntegral width+ 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+ in+ do _ <- fillRect surf (Just (Rect x y 1 1)) (rgbf r g b)+ return ()+ )+ )++quitHandler :: IO ()+quitHandler = do+ e <- waitEvent+ case e of+ Quit -> return ()+ otherwise -> quitHandler++main = do+ SDL.init [InitVideo, InitTimer, InitJoystick]+ setVideoMode xres yres 32 []+ screen <- getVideoSurface++ -- HWSurface seems to be slightly faster.+ img <- createRGBSurface [HWSurface] xres yres 32 0 0 0 0++ setupt1 <- getPOSIXTime+ scene <- TestScene.scn++ print $ "(primitives,transforms,bounding objects): " ++ (show (primcount_scene scene))+ setupt2 <- getPOSIXTime+ print $ "scene setup: " ++ (show (setupt2-setupt1))++ forM_ [1..1] (\_ ->+ do rendert1 <- getPOSIXTime+ renderTiles img scene blocksize+ rendert2 <- getPOSIXTime+ print $ "render: " ++ (show (rendert2-rendert1)))++ blitt1 <- getPOSIXTime+ blitSurface img Nothing screen Nothing+ SDL.flip screen+ blitt2 <- getPOSIXTime+ print $ "blit: " ++ (show (blitt2-blitt1))++ quitHandler
+ GlomeView.cabal view
@@ -0,0 +1,26 @@+Name: GlomeView+Version: 0.2+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),+ BIH-based acceleration structure, and ability to load NFF+ format files. The rendering algorithms have been abstracted+ to an external library, GlomeTrace. This is just a front-end+ to the library that renders scenes into an SDL window.+License: GPL+License-file: LICENSE+Author: Jim Snow+Maintainer: Jim Snow <jsnow@cs.pdx.edu>+Copyright: Copyright 2008,2010 Jim Snow+Homepage: http://haskell.org/haskellwiki/Glome+Stability: experimental+Category: graphics+build-type: Simple+Cabal-Version: >= 1.2.3+extra-source-files: README.txt,TestScene.hs++Executable Glome+ Main-Is: Glome.hs+ ghc-options: -O2 -threaded+ extensions: BangPatterns+ Build-Depends: base >= 4 && < 5, time, monad-par, deepseq, random, vector, GlomeVec, GlomeTrace, SDL
+ LICENSE view
@@ -0,0 +1,14 @@+ This library, GlomeVec, is copyright 2008 Jim Snow++ This program is free software; you can redistribute it and/or modify+ it under the terms of version 2 of the GNU General Public License as + published by the Free Software Foundation;++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ README.txt view
@@ -0,0 +1,12 @@++This is GlomeView, a graphical frontend to Glome, my raytracer. Originally, Glome was a monolithic program, but I have now moved most of the internals to a couple of libraries, GlomeVec and GlomeTrace.++GlomeView requires HOpenGL.++This was one of the first things I wrote in Haskell. As such, it has a few rough edges.++http://www.haskell.org/haskellwiki/Glome++Direct all questions to:+Jim Snow+jsnow@cs.pdx.edu
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ TestScene.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE ScopedTypeVariables #-}++module TestScene (scn) where+import Data.Glome.Scene+import Data.List hiding (group)+import Data.Glome.Texture+import System.Random++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+ 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_offset (vnorm x) (r+(vdot (vnorm x) pos)))+ in+ intersection ((sphere pos (1.26*r)):(map pln points))++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 -> SolidItem+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 tex (bih (tolist (SolidItem (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) ]++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)) (-1) (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++geom'' =+ group+ [ 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) 17)) t_shiny_red+ ]+++-- some textures+m_shiny_white :: Material+m_shiny_white = (Material c_white 0.3 0 0 0.7 0.8 10)++m_shiny_red = (Material c_red 0.3 0 0 0.7 0.8 10)++t_shiny_white :: Texture+t_shiny_white ri = m_shiny_white++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)++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_mirror (m_matte (Color 0.15 0.3 0.5)) scale++--shouldn't happen+t_mottled RayMiss = m_shiny_white++t_stripe (RayHit _ pos norm _) =+ let scale = (stripe (Vec 4 8 5) triangle_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 ++m_matte :: Color -> Material+m_matte c = (Material c 0 0 0 1 0 2)++t_matte :: Color -> Texture+t_matte c = + (\ri -> (Material c 0 0 0 1 0 2)) ++m_mirror = (Material (Color 0.8 0.8 1) 1 0 0 0.2 0.8 1000)+t_mirror = + (\ri -> 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))