import Vec
import Clr
import Solid
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 Debug.Trace
-- import Data.ByteString
get_color :: Flt -> Flt -> Scene -> Clr.Color
--
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 2
--}
{--
-- for testing screen-draw overhead
get_color x y scn =
Clr.Color (1*x) (1*y) 0
--}
fc :: Flt -> Float
--fc x = if x == x then clamp 0 x 0.5 else error "nan"
fc x = realToFrac x
--fc x = x+delta
-- double nested for loop
-- for rendering a sub-box of the screen
gen_pixels curx cury stopx stopy maxx maxy scene =
let midx = maxx/2
midy = maxy/2
gp x y =
if y>=stopy then
return ()
else
if x>=stopx
then
gp curx (y+1)
else
do
let scx = (x-midx) / midx
let scy = (y-midy) / midy
-- let (Clr.Color r g b) = get_color scx (scy*(midy/midx)) scene
let (Clr.Color r g b) = get_color (scx*(midx/midy)) scy scene
currentColor $= Color4 (fc r) (fc g) (fc b) 1
vertex$Vertex3 scx scy 0
gp (x+1) y
in gp curx cury
-- same as above, but non-monadic, instead return list of pixels
gen_pixel_list :: Flt -> Flt -> Flt -> Flt -> Flt -> Flt -> Scene -> [(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
in
(scx,scy,r,g,b) : (gp (x+1) y)
in gp curx cury
-- split screen into little blocks for parallel rendering
{-
gen_blocks maxx maxy block_size scene =
let foo = 1
bar = 2
gb x y =
if y>=maxy then
return ()
else
if x>=maxx then
gb 0 (y+block_size)
else
do
gen_pixels x y (x+block_size-1) (y+block_size-1) maxx maxy scene
gb (x+block_size) y
in gb 0 0
-}
{-
-- this doesn't seem to parallelize
gen_blocks maxx maxy block_size scene =
let xblocks = maxx/block_size
yblocks = maxy/block_size
blocks = Prelude.map (\x -> Prelude.map (\y -> (x*block_size,y*block_size) ) [0..yblocks-1] ) [0..xblocks-1]
in
do
-- mapM_ (\(x,y) -> gen_pixels x y (x+block_size) (y+block_size) maxx maxy scene) (concat blocks)
-- sequence_ $ Prelude.map (\(x,y) -> gen_pixels x y (x+block_size) (y+block_size) maxx maxy scene) (concat blocks)
sequence_ $ (parMap rwhnf)
(\(x,y) -> gen_pixels x y (x+block_size) (y+block_size) maxx maxy scene)
(concat blocks)
-}
-- as above, but parallel code is pure
-- odd, this seems to be faster, even without multicore
-- rnf is faster than rwhnf
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 x y (x+block_size) (y+block_size) maxx maxy scene)
(blocks)
in
do
mapM_ (\pix -> mapM_ (\(x,y,r,g,b) -> do currentColor $= Color4 (fc r) (fc g) (fc b) 1
vertex$Vertex3 (fc x) (fc y) 0
) 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))
scene <- getscene flags
let sx = 720 :: GLsizei
let sy = 480 :: GLsizei
(name, _) <- getArgsAndInitialize
initialDisplayMode $= []
-- initialDisplayMode $= [DoubleBuffered]
createWindow name
windowSize $= Size sx sy
displayCallback $= display scene sx sy
keyboardMouseCallback $= Just (keyboard scene)
mainLoop
display scene sx sy = do
t1 <- getPOSIXTime
clearColor $= Color4 0 0 0 1
clear [ColorBuffer]
--(Size sx sy) <- GLUT.get windowSize
let sizex = fromIntegral sx
let sizey = fromIntegral sy
-- renderPrimitive Points $ gen_blocks_list 512 512 128 scene
-- renderPrimitive Points $ gen_blocks_list 720 480 80 scene
renderPrimitive Points $ gen_pixels 0 0 sizex sizey sizex sizey scene
swapBuffers
t2 <- getPOSIXTime
-- print ((fromInteger (t2-t1))/1000000000)
print (t2-t1)
keyboard _ (Char 'q') Down _ _ =
do
exitWith ExitSuccess
keyboard s (Char 's') Down _ _ =
do
print (show s)
keyboard _ _ _ _ _ = return ()
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
data Flag = Filename String | Res Int Int deriving Show
options :: [OptDescr Flag]
options =
[ Option ['n'] ["filename"] (ReqArg Filename "FILE") "input NFF scene"
]