{-# LANGUAGE  MultiParamTypeClasses, FunctionalDependencies, 
    TypeSynonymInstances, PatternSignatures #-}

----------------------------------------------------------------------
-- |
-- Module      :  Graphics.SceneGraph.Render
-- Copyright   :  (c) Mark Wassell 2008
-- License     :  LGPL
-- 
-- Maintainer  :  mwassell@bigpond.net.au
-- Stability   :  experimental
-- Portability :  portable
-- 
-- Scene Graph drawing
----------------------------------------------------------------------

module Graphics.SceneGraph.Render
    (
      drawSceneGraph,applyTransform
    ) where


import Graphics.Rendering.OpenGL  hiding (Red, Green,Blue,Light,light,Texture)
import qualified Graphics.Rendering.OpenGL  as GL
import Graphics.UI.GLUT  hiding (Red, Green,Blue,Light,light,Texture,Text)


import Graphics.UI.GLUT.Fonts

import Data.Graph.Inductive.Graph

import Data.Array
import qualified Data.Map as M 
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import System.Time
import Data.Word
import Data.List ( transpose )

import Graphics.SceneGraph.Basic
import Graphics.SceneGraph.Matrix
import Graphics.SceneGraph.Textures
import Graphics.SceneGraph.Vector as V

import Numeric.LinearAlgebra (toLists,toList)

import Foreign ( withArray )

import qualified Data.Foldable as F


-- | Draw a scene graph (or a scenegraph fragment)
drawSceneGraph :: M.Map String TextureObject -> (SceneGraph, Node) -> IO ()
drawSceneGraph texMap (gr,n)  = do
         let node = llab gr n
         case node of 
              (SceneNode _ (MatrixTransform tm)) -> do
                     preservingMatrix $ do
                           (m::GLmatrix GLdouble) <- newMatrix RowMajor (concat $ toLists tm)
                           multMatrix m
                           drawSceneGraphTheRest gr n
              (SceneNode _ (Switch sw) ) -> do
                       let children = suc gr n
                       drawSceneGraph texMap (gr, (children!!sw)) 
              (SceneNode _ (Material ph)) -> do
                       -- FIXME - need to restore ...
                       applyPhong ph
                       drawSceneGraphTheRest gr n
              (SceneNode _ (Texture texNameS) ) -> do
                       GL.texture Texture2D $= Enabled
                       textureFunction $= Decal
                       textureBinding Texture2D $= M.lookup texNameS texMap
                       drawSceneGraphTheRest gr n
                       GL.texture Texture2D $= Disabled
              (SceneNode _ (Text s)) -> do
                       preservingMatrix $ renderString Roman s
              _ -> do
                       drawSceneNode node
                       drawSceneGraphTheRest gr n
         where drawSceneGraphTheRest gr n = mapM_ ( (curry (drawSceneGraph texMap) ) gr) (suc gr n)



applyPhong (Phong e a d sp ss _ _ _ _) = do
  maybeIO e setMaterialEmission
  maybeIO a setMaterialAmbient
  maybeIO d setMaterialDiffuse
  maybeIO sp setMaterialSpecular
  maybeIO ss setMaterialShininess 
  where setMaterialEmission  c =  materialEmission  Front $= c 
        setMaterialAmbient c =  materialAmbient Front $= c
        setMaterialDiffuse  c= materialDiffuse  Front $= c 
        setMaterialSpecular c= materialSpecular Front $= c
        setMaterialShininess c= materialShininess  Front $= c


applyTransform  (SceneNode _ (MatrixTransform tm)) = do
                 (m::GLmatrix GLdouble) <- newMatrix RowMajor (concat $ toLists tm)
                 multMatrix m

applyTransform _ = return ()

{--
applyTransform (TM tm) = do
                      (m::GLmatrix Float) <- newMatrix RowMajor (asList tm)
                      multMatrix m
applyTransform (TEL _) = error "Not here"
--}

-- | Draw actual node
drawSceneNode :: SceneNode -> IO ()
drawSceneNode (SceneNode (n,_) d )  = do
                         loadName( Name $ toEnum  n)
                         drawSceneData d

-- | Draw Scene Node Data
drawSceneData (Geode geom) = drawGeometry geom
drawSceneData Light = do
  (m::GLmatrix GLfloat) <- get $ matrix Nothing
  mc <- getMatrixComponents ColumnMajor m
  let mc' = drop 12 mc
  lighting $= Enabled
  -- FIXME - Hardcoded position!!
  position (GL.Light 0) $= Vertex4 0 0 10 1 -- (mc'!!0) (mc'!!1) (mc'!!2) (mc'!!3)
  ambient (GL.Light 0) $= Color4 1 1 1 1
  diffuse (GL.Light 0) $= Color4 1 1 1 1
  specular (GL.Light 0) $= Color4 1 1 1 1
  GL.light (GL.Light 0) $= Enabled

drawSceneData _  = return ()

-- | Draw geometry
drawGeometry  (GLObj o) =   renderObject Solid o
drawGeometry  (Mesh1 primset vs ns) = mapM_ (drawMesh1 vs ns) primset
drawGeometry  (Mesh2 primset vs ) = mapM_ (drawMesh2 vs ) primset
drawGeometry  (BezierMesh patch) = mapM_ drawPatch patch


ctrlPoints :: [[Vertex3 GLfloat]]
ctrlPoints = [
   [ Vertex3 (-1.5) (-1.5)   4.0,  Vertex3 (-0.5) (-1.5)   2.0,
     Vertex3   0.5  (-1.5) (-1.0), Vertex3   1.5  (-1.5)   2.0 ],
   [ Vertex3 (-1.5) (-0.5)   1.0,  Vertex3 (-0.5) (-0.5)   3.0,
     Vertex3   0.5  (-0.5)   0.0,  Vertex3   1.5  (-0.5) (-1.0) ],
   [ Vertex3 (-1.5)   0.5    4.0,  Vertex3 (-0.5)   0.5    0.0,
     Vertex3   0.5    0.5    3.0,  Vertex3   1.5    0.5    4.0 ],
   [ Vertex3 (-1.5)   1.5  (-2.0), Vertex3 (-0.5)   1.5  (-2.0),
     Vertex3   0.5    1.5    0.0,  Vertex3   1.5    1.5  (-1.0) ]]

-- Hey mom, look, it's C!  ;-)
for :: GLfloat -> GLfloat -> (GLfloat -> IO ()) -> IO ()
for s e f = mapM_ f [ i | i <- [ s, if s <= e then s + 1 else s - 1 .. e ] ]

-- FIXME - Using GLdouble give rubbish; need to use GLfloat
drawPatch patch = do
   m <- newMap2 (0, 1) (0, 1) patch
   -- m <- newMap2 (0, 1) (0, 1) ( ctrlPoints)
   map2 $= Just (m :: GLmap2 Vertex3 GLfloat)
   t <- newMap2 (0, 1) (0, 1) ( texPts)
   map2 $= Just (t :: GLmap2 TexCoord2 GLfloat)
   autoNormal $= Enabled 
   mapGrid2 $= ((20, (0, 1)), (20, (0, 1 :: GLfloat)))
   textureFunction $= Decal
   textureWrapMode Texture2D S $= (Repeated, Repeat)
   textureWrapMode Texture2D T $= (Repeated, Repeat)
   textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
   GL.texture Texture2D $= Enabled
   depthFunc $= Just Less
   shadeModel $= Flat
   -- withImage $ texImage2D Nothing NoProxy 0 RGB' imageSize 0
   -- color (Color3 1 1 1 :: Color3 GLfloat)
   
   evalMesh2 Fill (0, 20) (0, 20)
   {--for 0 8 $ \j -> do
       renderPrimitive LineStrip $ do
           for 0 30 $ \i -> evalCoord2 (i/30, j/ 8)
       renderPrimitive LineStrip $ do
           for 0 30 $ \i -> evalCoord2 (j/ 8, i/30)
           --}
  where  
  (texPts :: [[TexCoord2 GLfloat]]) = [
   [ TexCoord2 0 0, TexCoord2 0 1 ],
   [ TexCoord2 1 0, TexCoord2 1 1 ]]
  withImage :: (PixelData (Color3 GLubyte) -> IO ()) -> IO ()
  withImage act =
   withArray [ Color3 (s (sin ti)) (s (cos (2 * tj))) (s (cos (ti + tj))) |
               i <- [ 0 .. fromIntegral w - 1 ],
               let ti = 2 * pi * i / fromIntegral w,
               j <- [ 0 .. fromIntegral h - 1 ],
               let tj = 2 * pi * j / fromIntegral h ] $ act . PixelData RGB UnsignedByte
  (TextureSize2D w h) = imageSize
  s :: Double -> GLubyte
  s x = truncate (127 * (1 + x))    
  imageSize = TextureSize2D 64 64                     

-- | Draw mesh type 1
drawMesh1 vs ns (pmode, start, length) = do
                          t <- timeGetTime
--                          putStrLnD $ "drawMesh1 " ++ (show length ) ++ " t = " ++ (show t)
--                          putStrLn $ show vs

                          unsafeRenderPrimitive pmode (F.mapM_ (\(v,n) -> do 
                                                                let (x'::Int) = round x 
                                                                    y' = round y 
                                                                    [x,y,z] = toList v
                                                                    [nx,ny,nz] = toList n
                                                                texCoord (TexCoord2 ((i2d $ x' `mod` 2)) ((i2d $ y' `mod` 2)))
                                                                vertex (Vertex3 x z (-y))
                                                                normal (Normal3 nx nz (-ny))) (zip vs ns)) 
                          t2 <- timeGetTime 
                          return ()


-- | Draw mesh type 2
drawMesh2 :: (Array Int (VectorD,VectorD,Maybe (VectorD))) -> (PrimitiveMode, Int,Int) -> IO ()
drawMesh2 vs (pmode, start, length) = do
                          t <- timeGetTime
                          unsafeRenderPrimitive pmode (F.mapM_ (\(v,n,t) -> do 
                                                                let  [x,y,z] = toList v
                                                                     [nx,ny,nz] = toList n
                                                                normal $ Normal3 nx nz (-ny)
                                                                vertex $ Vertex3 x z (-y)
                                                                -- texCoord (TexCoord3 (V.vector3X t) (V.vector3Y t) (V.vector3Z t))
                                                               ) vs)
                          t2 <- timeGetTime 
                          return ()



i2d :: Int -> Float
i2d = fromIntegral 

putStrLnD s = return ()

rootNode gr = llab gr 1

-- asList (MT m) = concat m


maybeIO :: Maybe a -> (a -> IO ()) -> IO ()
maybeIO x f = case x of
              Nothing -> return ()
              Just x' -> f x'

-- Returns microseconds
timeGetTime :: IO Word32
timeGetTime = do
  System.Time.TOD sec psec <- System.Time.getClockTime
  return (fromIntegral $ sec * 1000 + psec `div` 1000000000)