{-# OPTIONS_GHC -fexcess-precision #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# LANGUAGE BangPatterns #-} import Data.Glome.Scene as Scene import Data.Glome.Trace as Trace import Data.Glome.Spd as Spd import TestScene import Graphics.Rendering.OpenGL import Graphics.UI.GLUT as GLUT import System.CPUTime import Control.Parallel.Strategies import Data.Time.Clock.POSIX import System.Exit import IO import System import System.Console.GetOpt import Data.Maybe( fromMaybe ) -- import OpenEXR -- work in progress import Unsafe.Coerce -- import Debug.Trace -- import Data.ByteString maxdepth = 2 -- 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) -- compute a 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 -- convert trace result to -- appropriate float type for OpenGL fc :: Flt -> GLfloat fc x = realToFrac x --fc :: Flt -> GLfloat --fc = unsafeCoerce -- given a block of screen coordinates, return list of pixels gen_pixel_list :: Flt -> Flt -> Flt -> Flt -> Flt -> Flt -> Scene -> [(Flt,Flt,Flt,Flt,Flt,Flt)] gen_pixel_list curx cury stopx stopy maxx maxy scene = let midx = maxx/2 midy = maxy/2 gp x y = if y >= stopy then [] else if x >= stopx then gp curx (y+1) else let scx = (x-midx) / midx scy = (y-midy) / midy --(Clr.Color r g b) = get_color scx (scy*(midy/midx)) scene --(Clr.Color r g b) = get_color (scx*(midx/midy)) scy scene ((Scene.Color r g b),d) = get_color (scx*(midx/midy)) scy scene in (scx,scy,r,g,b,0) : (gp (x+1) y) in gp curx cury -- same, but trace packets instead of mono-rays gen_pixel_list_packet :: Flt -> Flt -> Flt -> Flt -> Flt -> Flt -> Scene -> [(Flt,Flt,Flt,Flt,Flt,Flt)] gen_pixel_list_packet curx cury stopx stopy maxx maxy scene = let midx = maxx/2 midy = maxy/2 gp x y = if y >= stopy then [] else if x >= stopx then gp curx (y+2) else let scx1 = (x-midx) / midx scy1 = (y-midy) / midy scx2 = ((x+1)-midx) / midx scy2 = ((y+1)-midy) / midy PacketColor (Scene.Color r1 g1 b1) (Scene.Color r2 g2 b2) (Scene.Color r3 g3 b3) (Scene.Color r4 g4 b4) = get_packet (scx1*(midx/midy)) scy1 (scx2*(midx/midy)) scy2 scene in [(scx1,scy1,r1,g1,b1,0), (scx2,scy1,r2,g2,b2,0), (scx1,scy2,r3,g3,b3,0), (scx2,scy2,r4,g4,b4,0)] ++ (gp (x+2) y) in gp curx cury gen_blocks_list maxx maxy block_size scene = let xblocks = maxx/block_size yblocks = maxy/block_size blocks = Prelude.concat $ Prelude.map (\x -> Prelude.map (\y -> (x*block_size,y*block_size) ) [0..yblocks-1] ) [0..xblocks-1] pixels = (parMap rdeepseq) (\(x,y) -> gen_pixel_list x y (x+block_size) (y+block_size) maxx maxy scene) (blocks) in do mapM_ (\pix -> mapM_ (\(x,y,r,g,b,d) -> do currentColor $= Color4 (fc r) (fc g) (fc b) 1 vertex$Vertex3 (fc x) (fc y) (fc d) ) pix) pixels -- Haskell opengl tutorial: -- http://blog.mikael.johanssons.org/archive/2006/09/ -- opengl-programming-in-haskell-a-tutorial-part-1/ -- another tutorial: -- http://www.tfh-berlin.de/~panitz/hopengl/skript.html main :: IO () main = do -- parse arguments -- http://leiffrenzel.de/papers/commandline-options-in-haskell.html args <- getArgs let (flags, nonOpts, msgs) = getOpt RequireOrder options args print $ "recognized options: " ++ (show (length flags)) t1 <- getPOSIXTime scene <- getscene flags print $ "(primitives,transforms,bounding objects): " ++ (show (primcount_scene scene)) t2 <- getPOSIXTime print $ "scene setup: " ++ (show (t2-t1)) let sx = 1280 :: GLsizei let sy = 720 :: GLsizei let sizex = fromIntegral sx let sizey = fromIntegral sy (name, _) <- getArgsAndInitialize --initialDisplayMode $= [] initialDisplayMode $= [DoubleBuffered] pointSmooth $= Enabled -- create window createWindow name windowSize $= Size sx sy -- set up camera -- why is the z-value (-100 < z < 0)? -- I don't know, it just works this way for some reason {- matrixMode $= Projection loadIdentity ortho (-1) 1 (-1) 1 (-10000) 0 matrixMode $= Modelview 0 -} -- create display list t1 <- getPOSIXTime dlist <- defineNewList CompileAndExecute $ do renderPrimitive Points $ gen_blocks_list sizex sizey 32 scene t2 <- getPOSIXTime print $ "render: " ++ (show (t2-t1)) displayCallback $= display dlist keyboardMouseCallback $= Just (keyboard scene) mainLoop display dlist = do clear [ColorBuffer] callList dlist swapBuffers -- dodo: make this do some kind of antialiasing display_aa scene sx sy = do t1 <- getPOSIXTime -- clearColor $= Color4 0 0 0 1 clear [ColorBuffer] let sizex = fromIntegral sx let sizey = fromIntegral sy -- renderPrimitive Points $ gen_blocks_list 512 512 128 scene -- renderPrimitive Points $ gen_blocks_list sizex sizey 80 scene -- renderPrimitive Points $ gen_pixels 0 0 sizex sizey sizex sizey scene -- swapBuffers -- GLUT.rotate (fc (deg 1)) $Vector3 0 (1::GLfloat) 0 t2 <- getPOSIXTime print (t2-t1) keyboard _ (Char 'q') Down _ _ = do exitWith ExitSuccess -- for debugging, print a full scene dump keyboard s (Char 's') Down _ _ = do print (show s) keyboard _ _ _ _ _ = return () -- if a scene has been specified on the command line, render that; -- otherwise, render whatever we find in TestScene.hs getscene :: [Flag] -> IO Scene getscene flags = case flags of [] -> TestScene.scn (Filename s:xs) -> do filedes <- openFile s ReadMode filestring <- (IO.hGetContents filedes) (scene,s) <- return $ Prelude.head $ reads filestring return scene -- todo: add argument for screen resolution data Flag = Filename String | Res Int Int | Time Flt deriving Show options :: [OptDescr Flag] options = [ Option ['n'] ["filename"] (ReqArg Filename "FILE") "input NFF scene" --, Option ['t'] ["time"] (ReqArg Time 0) "time value for scene generation" ]