{-# LANGUAGE  MultiParamTypeClasses, FunctionalDependencies, 
    TypeSynonymInstances, ScopedTypeVariables #-}
    
----------------------------------------------------------------------
-- |
-- Module      :  Graphics.SceneGraph.SimpleViewport
-- Copyright   :  (c) Mark Wassell 2008
-- License     :  LGPL
-- 
-- Maintainer  :  mwassell@bigpond.net.au
-- Stability   :  experimental
-- Portability :  portable
-- 
-- Provide a view window onto a scenegraph. Handles basic navigation
-- and interaction with widgets.
----------------------------------------------------------------------    
    
module Graphics.SceneGraph.SimpleViewport
    (
     setupGUI,GraphicsState(..),newState,drawCanvas,GSRef,runScene
    ) where



import Control.Concurrent
import Control.Concurrent.MVar

import Data.Graph.Inductive.Graph
import qualified Data.Map as M
import Data.Graph.Inductive.Graph (pre)
import Data.IORef
import Data.List
import qualified Data.Packed.Matrix as PM

import Graphics.Rendering.OpenGL  hiding (Red, Green,Blue,scale,Texture) 
import qualified Graphics.Rendering.OpenGL  as GL
import Graphics.UI.GLUT  hiding (Red, Green,Blue,scale,Texture)
import Graphics.UI.GLUT.Objects
import Graphics.UI.GLUT.Fonts

import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import System.Time

import Numeric.LinearAlgebra  -- (inv, (><),toLists, )

import Graphics.SceneGraph.MySTM
import Graphics.SceneGraph.Vector
import Graphics.SceneGraph.Basic hiding (scale,translate,rotate)
import Graphics.SceneGraph.Render
import Graphics.SceneGraph.Textures
import qualified Graphics.SceneGraph.Matrix as M


initWindowSize =  Size 700 700
perseAngle = 90.0
clrColor = Color4 0 0 0 1

type GSRef = TVar GraphicsState

type HitSink = GSRef -> GLuint -> KeyState -> STM ()

-- Holds state of viewport. Theta is angle around the vertical/y axes; Sigma is the angle around the x-axes
data GraphicsState = GraphicsState { gsR :: GLdouble, 
                                     gsSig :: GLdouble, 
                                     gsTheta :: GLdouble,
                                     gsMPos::Maybe Position, 
                                     gsDisplayList :: Maybe DisplayList,
                                     gsDrawFunc :: Maybe (IO ()),
                                     gsHitSink :: Maybe HitSink, -- Handles hits onto the viewport 
                                     gsDrag::Bool,
                                     gsScene :: Maybe Scene, -- The whole thing
                                     gsFocus :: Maybe Scene, -- The portion of the scene that has focus, 
                                                             -- mouse drag and keyboard events will be sent to this.
                                     gsTexture :: M.Map String TextureObject,
                                     gsDragPos :: Maybe (Vector GLdouble),
                                     gsProjMatrix :: Maybe (GLmatrix GLdouble),
                                     gsBlah :: Maybe (Int -> IO () ),
                                     gsModelMatrix :: Maybe (GLmatrix GLdouble) -- The model matrix up to camera
 }

newState = GraphicsState { gsR = 50, gsSig = 0, gsTheta = 0, 
                           gsMPos=Nothing,gsDrawFunc = Nothing, gsDrag=False, gsDisplayList=Nothing,gsBlah=Nothing,
                           gsScene = Nothing, gsTexture = M.empty, gsHitSink = Nothing, gsFocus=Nothing,gsProjMatrix = Nothing,
                                     gsModelMatrix=Nothing,gsDragPos=Nothing }

modifyTVar tvar f =  do
                                     x <- readTVar tvar
                                     writeTVar tvar (f x)




-- | Run a scene. Displays the Scene in a basic viewport permitting user interaction.
runScene :: Scene -> IO ()
runScene scene   = do
           sem <- newMVar True
           ref <- newTVar newState { gsScene = Just scene }
           setupGUI sem ref

getTextures :: Scene -> IO (M.Map String TextureObject)
getTextures (gs,_) = do
                    let textureNames = nub $ foldr (\x xs -> case (llab gs x) of
                                          SceneNode _ (Texture s) ->  (s:xs)
                                          _ -> xs) [] (nodes gs)
                    tlist <- getAndCreateTextures $ map (\s -> "data/" ++ s) textureNames 
                                                  
                    return $ M.fromList $ zip textureNames $ map (maybe (error "failed to load texture") id) tlist
                                          
                                       
-- | Setup GUI and run it.
setupGUI ::  MVar Bool -> GSRef  -> IO ()
setupGUI sem rGS = do 
   
   (progName, _args) <- getArgsAndInitialize
   initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]
   initialWindowSize $= initWindowSize
   initialWindowPosition $= (Position 100 100)
   createWindow progName

   lighting  $= Enabled
   normalize $= Enabled
   depthFunc $= Just Less

   matrixMode		  $= Projection
   loadIdentity
   perspective perseAngle 1.0 0.1 10000.0

   (m::GLmatrix Double) <- get $ matrix Nothing
   mc <- getMatrixComponents RowMajor m

   matrixMode		  $= Modelview 0
   loadIdentity

   shadeModel $= Smooth
   clearColor $= clrColor
   blend $= Enabled
   blendFunc $= (SrcAlpha,OneMinusSrcAlpha)

   gs <- readIORef rGS
   texMap <- getTextures (maybe (error "no scene") id (gsScene gs))
   
   (atomically sem) $ modifyTVar rGS (\gs -> gs { gsHitSink = Just findHitAction , gsProjMatrix = Just m, gsTexture = texMap})

   displayCallback       $= ( (atomically sem) $ drawCanvas  rGS)
   keyboardMouseCallback $= Just (\a b c d -> (atomically sem) $ handleKeyEvent  rGS a b c d)
   motionCallback	 $= Just (\p -> (atomically sem) $ handleDragEvent  rGS p )
   passiveMotionCallback $= Just (\p -> (atomically sem) $ handleMotionEvent rGS p )
   mainLoop

i2d :: GLint -> GLdouble
i2d = fromInteger . toInteger

i2f :: GLint -> Float
i2f = fromInteger . toInteger

handleMotionEvent _ _ = return ()

drawCanvasNull _ = return ()

handleDragEvent :: TVar GraphicsState -> Position -> STM ()
handleDragEvent rGS pos = do
                              gs <- readTVar rGS
                              case (gsFocus gs) of
                                     Just scene | (gsDrag gs) -> handleFocusedDrag rGS pos
                                     Nothing | (gsDrag gs)    -> handleTransformDrag rGS pos
                                     _ -> return ()

-- To calculate -
--    Widget needs to supply a plane (lets start with z = 0 - then we include transform of object in unproject)
--    Calculate 2 points on pick line (ie mouse z = 0, mouse z = 1)
--    calculate intersection of pick line with the plane to get the point



lineToYPlane p1 p2 = lineToYPlane' (fromVertex p1) (fromVertex p2)

fromVertex :: Vertex3 GLdouble -> Vector Double
fromVertex (Vertex3 x y z) = fromList [x,z,(-y)]

toVertex :: Vector Double -> Vertex3 GLdouble
toVertex vec  = let [x,y,z] = toList vec
                in Vertex3 x y z

lineToYPlane' :: Vector GLdouble -> Vector GLdouble  -> Vector GLdouble 
lineToYPlane' p1 p2 = let n = fromList [ 0, 1, 0]
                          origin = fromList [ 0, 0, 0]
                          u = (n `dot` ( origin  `sub` p1)) / n `dot` (p2 `sub` p1)
                      in p1 `add` ( u `scale` (p2 `sub` p1))

t1 = lineToYPlane (Vertex3 0 1 0) (Vertex3 0 (-1) 0 )
t2 = lineToYPlane (Vertex3 3 1 0 ) (Vertex3 1 (-1) 0 )



constrainDrag :: Vector GLdouble -> Vector GLdouble
constrainDrag vec = vec `dot` (fromList [1,0,0]) `scale` (fromList [1,0,0])

-- Assumes matrix transform is the parent ...
doDrag :: TVar GraphicsState -> Node -> Vector GLdouble -> IO ()
doDrag rGS nde vec' = do
     let vec = constrainDrag vec'
     gs <- readTVar rGS
     case (gsScene gs) of
               Just (sg,start) -> do
                                    case (llab sg nde) of 
                                       (SceneNode _ (Handler _ (Just (dragHandlerF,snk)))) -> do
                                                          (sg'',val) <- dragHandlerF (sg,nde) vec
                                                          snk val
                                                          writeTVar rGS $ gs { gsScene = Just $ (sg'',start) }
                                       _ -> return ()
               _ -> return ()

-- FIXME swap z and y and negate y


                  

handleFocusedDrag :: TVar GraphicsState -> Position -> STM ()
handleFocusedDrag rGS pos@(Position x y) = do
                             gs <- readTVar rGS
                             case gsFocus gs of
                                  Just (gr,nde) -> do
                                                       vp  <- unsafeIOToSTM $ get viewport
                                                       --should we move modelmatrix also to the positon of  the nde?
                                                       let mm = maybe (error "No set") id (gsModelMatrix gs)
                                                       let pm = maybe (error "No set") id (gsProjMatrix gs)
                                                       pos1 <- unsafeIOToSTM $ unProject (Vertex3 (fromIntegral x) (fromIntegral y) 0) mm pm  vp
                                                       pos2 <- unsafeIOToSTM $ unProject (Vertex3 (fromIntegral x) (fromIntegral y) 1) mm pm  vp
                                                       let pos3 = lineToYPlane pos1 pos2

                                                       case (gsDragPos gs) of
                                                           Just lastPos -> do
                                                                             let vec = pos3 `sub` lastPos
                                                                             -- putStrLn $ "New pos = " ++ show vec
                                                                             writeTVar rGS (gs { gsDragPos = Just pos3 })
                                                                             doDrag rGS nde vec
                                                                             drawCanvas rGS
                                                           Nothing -> writeTVar rGS (gs { gsDragPos = Just pos3 })

                                                       return ()
                                  Nothing -> return ()



handleTransformDrag :: GSRef  -> Position -> STM ()
handleTransformDrag rGS pos = do
                             gs <- readTVar rGS
                             if (gsDrag gs) then rotateBy gs (gsMPos gs) pos else return ()
                          where
                             rotateBy gs Nothing _ = writeTVar rGS (gs { gsMPos = (Just pos) })
                             rotateBy gs (Just (Position x' y')) pos@(Position x y) = do
                                                        writeTVar rGS (gs { gsSig   = (gsSig gs)   - ((i2d (x'-x))/100), 
                                                                             gsTheta = (gsTheta gs) - ((i2d (y'-y))/100),
                                                                             gsMPos = (Just pos)})
                                                        rotateCamera rGS  ((i2d (x'-x))/100) ((i2d (y'-y))/100)
                                                        drawCanvas rGS

bufSize :: GLsizei
bufSize = 512

moveFactor = 1

resetDrag f x = x { gsMPos = Nothing, gsDrag=f ,gsDragPos=Nothing }

handleKeyEvent :: GSRef -> Key -> KeyState  -> Modifiers  -> Position -> STM ()
handleKeyEvent _  (Char '\27') _ _ _ = unsafeIOToSTM $ System.Exit.exitWith ExitSuccess 

handleKeyEvent gs (MouseButton btn) dir  _ (Position x y) = do 
                                     modifyTVar gs (resetDrag (dir == Down))
                                     case btn of 
                                       LeftButton -> pickSceneNode gs dir x y
                                       _ -> return ()


handleKeyEvent gs (Char 'w') _ _ _= moveCamera gs (vector3 0 moveFactor 0)
handleKeyEvent gs (Char 'a') _ _ _= moveCamera gs (vector3 (-moveFactor) 0 0)
handleKeyEvent gs (Char 's') _ _ _= moveCamera gs (vector3 0 (-moveFactor) 0)
handleKeyEvent gs (Char 'd') _ _ _= moveCamera gs (vector3 moveFactor 0 0)
handleKeyEvent gs (Char 'z') _ _ _= moveCamera gs (vector3 0 0 (-moveFactor))
handleKeyEvent gs (Char 'x') _ _ _= moveCamera gs (vector3 0 0 moveFactor)

-- FIXME. Doesn' work?
-- handleKeyEvent gs (MouseButton WheelDown) _ _ _= moveCamera gs (Vector3 0 0 (-1))
-- handleKeyEvent gs (MouseButton WheelUp) _ _ _= moveCamera gs (Vector3 0 0 1)

handleKeyEvent gs _ _ _ _ = return ()

-- Note: Selection in OpenGL is basically a draw with names and then the system returns the names of 
-- visible in the viewing volume. The last step in setting up the view is to call pickMatrix to restrict
-- the viewing volume to an NxN pixel square centred on the mouse hit.

pickSceneNode :: GSRef -> KeyState -> GLint -> GLint -> STM ()
pickSceneNode gsRef dir x y=  do
      gs <- readTVar gsRef
      (_, maybeHitRecords) <- unsafeIOToSTM $ do
        vp@(_, (Size _ height)) <-  get viewport
        getHitRecords bufSize $ 
           withName (Name 0) $ do
               matrixMode $= Projection
               preservingMatrix $ do
                       loadIdentity
                       pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp
                       -- This is the same as at start of code. FIXME
                       perspective perseAngle 1.0 0.1 10000.0
                       drawCanvas'' gs Nothing
      processHits gsRef dir maybeHitRecords

processHits :: GSRef  -> KeyState -> Maybe[HitRecord] -> STM ()
processHits _ _ Nothing = error  "selection buffer overflow"
processHits gs dir (Just ((HitRecord _ _ (Name n:_)):_)) =  findHitAction gs n dir >> drawCanvas gs
processHits _ _ _ = return ()

drawCanvas :: GSRef -> STM ()
drawCanvas rGS = drawCanvas' rGS Nothing


drawCanvas' :: GSRef  -> Maybe (IO ()) -> STM ()
drawCanvas' rGS pm = do
       gs <- readTVar rGS
       gs' <- unsafeIOToSTM  $ drawCanvas'' gs pm
       writeTVar rGS gs'

drawCanvas'' :: GraphicsState -> Maybe (IO ()) -> IO  GraphicsState
drawCanvas'' gs  pm = do
         clearColor $= clrColor
         clear [ColorBuffer,DepthBuffer] 
         gs' <- setCamera gs
         crMat (0.0, 0.7, 0)(0.4, 0.4, 0.4) 5 1.0
         --mapM_ (drawCircle 5 50) [Vertex3 0 0 1,Vertex3 0 1 0,Vertex3 1 0 0 ]
         --mapM_ drawLetter [zPts,yPts,xPts] 
         maybe (return ()) id pm
 
         gs''<-case (gsDisplayList gs) of
               Just dl -> callList dl >> return gs'
               Nothing -> do
                            list <- defineNewList CompileAndExecute  $ maybe (return ()) (drawSceneGraph  (gsTexture gs)) (gsScene gs)
                            return $ gs' { gsDisplayList = Just list }
         flush
         swapBuffers
         return gs''

cameraChange :: GSRef -> (SceneGraph -> Node -> SceneGraph) -> STM ()
cameraChange rGS f = do 
      st <- readTVar rGS
      case (gsScene st) of
            Just sc@(sg,start) -> do
                                let 
                                    cam = findCameraPath sc 0
                                    tnde = (reverse cam) !! 1
                                    sg' = f sg tnde
                                    st' = st { gsScene = Just $ (sg',start) }
                                writeTVar rGS st'
                                drawCanvas rGS
            Nothing -> return ()

rotateCamera :: GSRef -> GLdouble -> GLdouble -> STM ()
rotateCamera rGS s t = do
         cameraChange rGS (\sg tnde -> rotatePostSG' (rotatePostSG' sg tnde (vector3 0.0 0.0 1.0) s) tnde (vector3 1.0 0.0 0.0) t)
                                

moveCamera :: GSRef -> VectorD -> STM ()
moveCamera rGS vec = do
      st <- readTVar rGS
      case (gsScene st) of
            Just sc@(sg,start) -> do
                                let 
                                    cam = findCameraPath sc 0
                                    tnde = (reverse cam) !! 1
                                    sg' = translatePostSG' sg tnde vec
                                    st' = st { gsScene = Just $ (sg',start) }
                                    (SceneNode _ (MatrixTransform tr1)) = llab sg tnde
                                    (SceneNode _ (MatrixTransform tr2)) = llab sg' tnde
                                writeTVar rGS st'
                                drawCanvas rGS
            Nothing -> return ()
     
      
setCamera :: GraphicsState -> IO GraphicsState 
setCamera st = do
         matrixMode $= Modelview 0 
         loadIdentity
         let r = gsR st
         maybe (return ()) (applyCameraTransform 1) (gsScene st)
         lookAt (Vertex3 0 0 0) (Vertex3 0.0 0 (-r)) (Vector3 0 1.0 0)
         (m::GLmatrix Double) <- get $ matrix (Just $ Modelview 0 )
         return $ st { gsModelMatrix = Just m }




-- | Traverse down to the camera for this viewport and apply the transforms along
--   the way.
applyCameraTransform :: Int -> Scene -> IO ()
applyCameraTransform cnum sc@(gr,start) = do
       mapM_ applyTransform $ (map (llab gr) $ findCameraPath sc 0 )
       applyLA inv


-- | Apply a unary function from HMatrix package to Modelview matrix
applyLA :: (PM.Matrix Double  -> PM.Matrix Double) -> IO ()
applyLA f = do
       (m::GLmatrix Double) <- get $ matrix Nothing
       mc <- getMatrixComponents RowMajor m
       let mc' = concat $ toLists $ f ((4><4) mc)
       (m'::GLmatrix Double) <- newMatrix RowMajor mc'
       matrix (Just (Modelview 0)) $= m'
       
      


setCamera' rGS = do
       gs <- readTVar rGS
       -- Those in the know say that lookAt is done in Modelview.
       unsafeIOToSTM $ do
         matrixMode $= Modelview 0 
         loadIdentity
         let (t,s,r) = (gsTheta gs, gsSig gs, gsR gs)
             z = l * sin s'
             x = l * cos s'
             l = (cos s')
             s' = s  -- or -s ??
         lookAt (Vertex3 0 0 r) (Vertex3 0.0 0 0) (Vector3 0 1.0 0)
         rotate (s*180/pi) (Vector3 0 1 0) 
         rotate (t*180/pi) (Vector3 x 0 z) 

crMat (rd,gd,bd) (rs,gs,bs) exp a = do
  materialDiffuse   Front $= Color4 rd gd bd  a
  materialAmbient   Front $= Color4 rd gd bd  a
  materialSpecular  Front $= Color4 rs gs bs  a
  materialShininess Front $= exp

  materialDiffuse   Back $= Color4 rd gd bd  a
  materialSpecular  Back $= Color4 rs gs bs  a
  materialShininess Back $= exp

drawCircle :: GLdouble-> Int -> Vertex3 GLdouble -> IO ()
drawCircle r n a@(Vertex3 x y z) =  preservingMatrix $ do
                                         rotate (theta*180/pi) (Vector3 x' y' z')
                                         renderPrimitive LineLoop $ mapM_ mapVertex ls
                   where mapVertex v = do 
                                          normal (Normal3 x y z)
                                          vertex v
                         ls = [ (Vertex3 (r * cos (vt t)) (r*sin (vt t)) 0) | t <- [0 .. (n-1)] ]
                         vt t = 2*pi* (fromInteger (toInteger t))/(fromInteger (toInteger n))
                         (Vertex3 x' y' z') = a `vCross` (Vertex3 0 0 1)
                         theta = a `ang`  (Vertex3 0 0 1)

vCross :: Num a => Vertex3 a -> Vertex3 a -> Vertex3 a
vCross (Vertex3 a1 a2 a3) (Vertex3 b1 b2 b3) = Vertex3 (a2*b3 -a3*b2) (a3*b1-a1*b3) (a1*b2-a2*b1)

vDot :: Num a => Vertex3 a -> Vertex3 a -> a
vDot (Vertex3 a1 a2 a3) (Vertex3 b1 b2 b3) = a1*b1 + a2*b2 + a3*b3

vPlus :: Num a => Vertex3 a -> Vertex3 a -> Vertex3 a
vPlus (Vertex3 a1 a2 a3) (Vertex3 b1 b2 b3) = Vertex3 (a1+b1) (a2+b2) (a3+b3)


mag :: Vertex3 GLdouble -> GLdouble
mag (Vertex3 a1 a2 a3) = sqrt (a1*a1 + a2*a2 + a3*a3)

ang :: Vertex3 GLdouble-> Vertex3 GLdouble -> GLdouble
ang v w = acos ((v `vDot` w) / ((mag v) * (mag w)))


drawLetter :: ([(GLdouble,GLdouble)],Vector3 GLdouble) -> IO ()
drawLetter (pts,t) = preservingMatrix $ do
                                         translate t
                                         GL.scale 0.1 0.1 (0.1::GLdouble)

                                         renderPrimitive Quads $ mapM_ mapVertex pts
                 where mapVertex (x,y) = do
                                           normal (Normal3 (0::GLdouble) 0 1)
                                           vertex (Vertex3 x y 0   )

xPts = ([ (0,-1), (-4,-5),(-6,-5),(-1,0), 
         (-1,0),(-6,5),(-4,5),(0,1), 
         (0,1), (4,5), (6,5), (1,0),
         (1,0),(6,-5), (4,-5),(0,-1),
         (-1,0),(0,1),(1,0),(0,-1)],Vector3 (5::GLdouble) 0 0)

zPts = ([ (-5,5), (-5,6), (5,6), (4,5),
         (5,6), (6,6), (-5,-6),(-6,-6),
         (-5,-6), (6,-6),(6,-5), (-4,-5)],Vector3 0 (5::GLdouble) 0)

yPts = ([  (5,6), (6,6), (-5,-6),(-6,-6),
          (-5,6), (-4,6), (0,0), (-1,-1)],Vector3 0 0 (5::GLdouble))

-- | Find and perform hit action 
findHitAction :: HitSink
findHitAction ref = f where 
                            f 0 _ = return ()
                            f name dir = do
                                          gs <- readTVar ref 
                                          let scene@(_,start) = maybe (error "No scene") id (gsScene gs)
                                             
                                          ((gr,_), focused,f) <- unsafeIOToSTM $ handleClickEvent scene name dir
                                          let focus = case dir of 
                                                        Up -> Nothing
                                                        Down -> focused
                                          case f of
                                              Just f' -> writeTVar ref (gs { gsScene = Just $ (f' gr, start), gsFocus = focus })
                                              Nothing -> writeTVar ref (gs { gsScene = Just $ (gr, start), gsFocus = focus })