import Scene
import Trace
import 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 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_depth scn ray infinity maxdepth
-- 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 -> Float
fc x = realToFrac x
-- 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 = map -- (parMap rnf)
(\(x,y) -> gen_pixel_list_packet 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 = 720 :: GLsizei
let sy = 480 :: 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"
]