diff --git a/Glome.hs b/Glome.hs new file mode 100644 --- /dev/null +++ b/Glome.hs @@ -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 diff --git a/GlomeView.cabal b/GlomeView.cabal new file mode 100644 --- /dev/null +++ b/GlomeView.cabal @@ -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 +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/README.txt b/README.txt new file mode 100644 --- /dev/null +++ b/README.txt @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/TestScene.hs b/TestScene.hs new file mode 100644 --- /dev/null +++ b/TestScene.hs @@ -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))