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

get_rayint :: Flt -> Flt -> Scene -> (Scene.ColorA, [Tag], Rayint Tag M)
get_rayint x y scn = 
 let (sld, lights, (Camera pos fwd up right), shader) = scn
     dir = vnorm $ vadd3 fwd (vscale right (-x)) (vscale up y)
     ray = (Ray pos dir) 
 in
    Trace.trace lights shader sld ray infinity maxdepth


get_color x y scn =
  let (color, tags, ri) = get_rayint x y scn
  in (color, 0)                    

get_color' :: Flt -> Flt -> Scene -> (Scene.ColorA,Flt)
get_color' x y _ =
  (Scene.ColorA x y (x+y) 1, 0)


get_tags x y scn =
  let (color, tags, ri) = get_rayint x y scn
  in tags

-- 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


-- 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.
-- We throw away the alpha value here.
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)
            (ColorA 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)
          (ColorA r g b _, d) = get_color xcoord ycoord scene
      in
        do _ <- fillRect surf (Just (Rect x y 1 1)) (rgbf r g b)
           return ()
                       )
                     )

getTags' x y scn =
  let xf = fromIntegral $ x
      yf = fromIntegral $ y
      widthf = fromIntegral xres
      heightf = fromIntegral yres
      xcoord = (((xf/widthf)*2)-1) * (widthf/heightf)
      ycoord = -(((yf/heightf)*2)-1)
  in  
      get_tags xcoord ycoord scn

runHandler :: Scene -> IO ()
runHandler scn = do
  e <- pollEvent
  --e <- waitEvent
  case e of
    Quit -> return ()
    MouseButtonUp x y ButtonLeft ->
      do let ts = getTags' x y scn
         print $ (show x) ++ " " ++ (show y) ++ ":"
         forM_ ts print
         runHandler scn
    NoEvent ->
      do delay 50
         runHandler scn
    otherwise -> 
      runHandler scn

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@(geom, _, _, _) <- TestScene.scn

  print $ "(primitives,transforms,bounding objects): " ++ (show (primcount geom))
  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))

  runHandler scene