{-# LANGUAGE  MultiParamTypeClasses, FunctionalDependencies, 
    TypeSynonymInstances #-}
----------------------------------------------------------------------
-- |
-- Module      :  Graphics.SceneGraph.Basic
-- Copyright   :  (c) Mark Wassell 2008
-- License     :  LGPL
-- 
-- Maintainer  :  mwassell@bigpond.net.au
-- Stability   :  experimental
-- Portability :  portable
-- 
-- Definition of types and combinators.
--
-- Construction of the graph is done within a Monad ('OSGT'). 'osg' is then used
-- to extract the 'Scene'.
--
--
--
----------------------------------------------------------------------

module Graphics.SceneGraph.Basic
    (
       SceneNode(..),SceneGraph,OSG,Scene,Colour(..),SceneData(..),Phong(..),
       Geometry(..),emptyOSG,OSGState(..),emptyState,emptyStateWithRef,newPhong,
       nullNode,trivialGr,addNode',addNullNode,addNodeBasic,addBasicNode,addBasicNamedNode,
       addNode,replaceNode,findCamera,findCameraPath,rotateX,rotateY,rotateZ,
       torus,sphere,tetra,line,cube,switchHandler,light,camera,plane,texture,planeQ,text,
       scaleS, scale, translate, rotate,
       (<+>),(<*>),(</>),strip,switch,switch', switchNode',translateSG',rotatePostSG',translatePostSG',
       colour,cylinder,
       osg,runOSG,r,llab,getTransformTo,findHandlerDown,findTextDown,
       OSGT, replaceNode'',handler,handler2,handleClickEvent,label,getByLabel,
       getHitAction,findHandler,replaceNode',OSGStateRef(..),SinkValue(..),dragHandler
    ) where
    
import Data.Array hiding (bounds)
import Data.IORef
import Data.Graph.Inductive hiding (mkNode,context)
import Data.Sequence hiding (empty,fromList)
import Data.Tree
import Data.List hiding (group,union)
import qualified Data.Map as M

import Foreign.Storable

import Graphics.UI.GLUT.Objects as GL
import Graphics.Rendering.OpenGL.GL.BeginEnd
import Graphics.Rendering.OpenGL (Vector3)
import Graphics.UI.GLUT  hiding (Sink,Red, Green,Blue,Matrix,Error,get,scale,translate,rotate,Light,light,texture,Texture,Text,set,get)
import Graphics.UI.GLUT.Fonts

import Control.Monad.Identity
import Control.Monad.Error
import qualified Control.Monad.State as ST

import Numeric.LinearAlgebra (Vector,toList,fromList,Matrix,mul,fromLists,toLists)

import Graphics.SceneGraph.Matrix
import Graphics.SceneGraph.Vector
import Graphics.SceneGraph.Utils

-- | Scene Graph based on a Graph
type SceneGraph  = Gr SceneNode  ()

-- | Scene Node. Made up of data and maybe a widget
data SceneNode = SceneNode (Node,String) SceneData deriving Show

-- | Scene Graph with indicate root node
type Scene = (SceneGraph,Node)

type SceneRef = (IORef SceneGraph, Node)

-- | View port refers to a camera node and has its own Scene which is drawn flattened
data Viewport = Viewport Node Scene

-- | A scene with a number of view ports looking onto it.
type World = (Scene,[Viewport])

instance Eq SceneNode where
     (==) (SceneNode n _ ) (SceneNode m _ ) = (m == n)

type ClickHandler = Scene -> KeyState -> IO SceneGraph
type DragHandler = Scene -> Vector GLdouble -> IO (SceneGraph,GLdouble)

instance Show ClickHandler where
          show _ = "<a ClickHandler>"

instance Show DragHandler where
          show _ = "<a DragHandler>"


data SinkValue = SVD GLdouble | SVB Bool | SVT String

type Sink a = a -> IO ()

-- | Scene Node Data.
data SceneData  = Group 
                | Geode Geometry 
                | LOD 
                | MatrixTransform (MatrixD)
                | Switch Int
                | Material Phong
                | Handler (Maybe (ClickHandler, Sink ())) (Maybe (DragHandler, Sink GLdouble))
                | Light
                | Camera
                | Texture String
                | Text String


instance Show SceneData where
       show Group = "Group"
       show (Geode (GLObj o)) = "Geode" ++ (show o)
       show (Geode (BezierMesh _)) = "Geode BezierMesh" 
       show (Geode _) = "Geode" 
       show LOD = "LOD"
       show (MatrixTransform _) = "MatrixTransform"
       show (Switch i) = "Switch " ++ show i
       show (Material _) = "Material"
       show (Handler _ _) = "Handler"
       show Light = "Light"
       show Camera = "Camera"
       show (Texture _) = "Texture"
       show (Text t ) = "Text " ++ t


type Value = Either Int String

type PropMap = M.Map String Value

getRootNode :: SceneRef -> IO SceneNode
getRootNode (ref, nde) = do 
                           sg <- readIORef ref
                           return $ llab sg nde




-- | Geometry. Either a basic GL object or a mesh.
-- 
-- FIXME - Reduce number of mesh types - to whatever is easier to draw (I suppose)
data Geometry =  GLObj Object 
              | Mesh1 [(PrimitiveMode, Int, Int)] [VectorD] [VectorD] 
              | Mesh2 [(PrimitiveMode, Int, Int)] (Array Int (VectorD, VectorD, Maybe (VectorD)))
              | Mesh3 [VectorD] 
              | BezierMesh [[[Vertex3 GLfloat]]]
                deriving (Eq,Show)

instance Eq SceneGraph where
    (==) a b = equal a b

-- | Simple colours
data Colour = Grey |JustWhite |Red | Green | Blue | Black | LightBlue | White | Yellow deriving (Show,Eq)

-- | Phong colouring
data Phong = Phong { emissionPh :: Maybe (Color4 GLfloat),
                     ambientPh :: Maybe (Color4 GLfloat),
                     diffusePh :: Maybe (Color4 GLfloat),
                     specularPh :: Maybe (Color4 GLfloat),
                     shinePh :: Maybe (GLfloat),
                     reflectivePh :: Maybe (Color4 GLfloat),
                     reflectivityPh :: Maybe (GLfloat),
                     transparentPh :: Maybe (Color4 GLfloat),
                     tranparencyPh :: Maybe (GLfloat) }
	   deriving (Eq,Show)

newPhong = Phong Nothing Nothing Nothing Nothing Nothing Nothing  Nothing Nothing Nothing

-- | Convert from simple colour to Phong
colour2Phong :: Colour -> Phong
colour2Phong c = newPhong { diffusePh = Just $ mapColour c,
                            ambientPh = Just $ mapColour c,
                            specularPh = Just $ Color4  0.4 0.4 0.4 1.0,
                            shinePh = Just 5.0 }



-- | Creates an empty scene graph
nullNode n = SceneNode (n,show n) Group

-- | Creates a scene graph containing the supplied node
trivialGr :: SceneNode ->  SceneGraph
trivialGr n = ([],1,n,[]) & empty



data Throwable = ThrowError String deriving Show

instance Error Throwable where
   noMsg = ThrowError "An Error"
   strMsg s = ThrowError s


newtype OSGStateRef = OSGStateRef { getOSR :: IORef OSGState }

instance Show OSGStateRef where
    show x = "StateRef"

instance Eq OSGStateRef where
    (==) a b = True
    
-- | Holds state of graph as it is built.
data OSGState = OSGState { gr :: SceneGraph
                         , context :: [SceneNode]
                         , heap :: M.Map Int SceneNode
                         , startNode :: Int
                         , root::Int
                         , selfRef :: Maybe  OSGStateRef } deriving (Eq,Show)

-- | Empty state
emptyState = OSGState { gr = empty, context = [], heap = M.empty,startNode = 0,root=0, selfRef = Nothing }

-- | Empty state with the self reference set
emptyStateWithRef :: IO OSGState
emptyStateWithRef = do
                        r <- newIORef emptyState
                        let state = (emptyState { selfRef = Just $ OSGStateRef r })
                        writeIORef r state
                        return state


-- | The OSG monad within which construction of scene graphs occur.
-- was 'type OSGT m = ErrorT Throwable (ST.StateT OSGState m)'
type OSGT m = (ST.StateT OSGState m)

type OSG = OSGT Identity

-- | Basic add node
addNodeBasic :: Monad m => SceneNode -> OSGT m SceneNode
addNodeBasic nde = addNode nde []

-- | Add node with scene data
addBasicNode g = addNode (SceneNode (0,"") g ) []

-- | Add node with scene data
addBasicNamedNode name g = addNode (SceneNode (0,name) g ) []

-- | Add empty node
addNullNode :: Monad m => OSGT m SceneNode
addNullNode = addNodeBasic $ nullNode 0

-- | Add a node to a scene graph with supplied children
addNode :: Monad m => SceneNode -> [((),Node)] -> OSGT m SceneNode
addNode nde children = do
                s <- ST.get
                let (sn,s') = addNode' s nde children
                ST.put s'
                return sn

-- | Non-monadic form of addNode
addNode' :: OSGState -> SceneNode -> [((),Node)] -> (SceneNode,OSGState)
addNode' s (SceneNode (m,l) d  ) children = 
                let n = if m == 0 then (startNode s) + 2 else m 
                    sn = SceneNode (n,l) d
                    g' = ([],n,sn,children) & (gr s)
                    s' = s { gr = g', startNode = n,root=n }
                in (sn,s')

-- | Replace a Scene Node
replaceNode :: Monad m => SceneNode -> OSGT m SceneNode
replaceNode n = do
                    s <- ST.get
                    g' <- lift $ replaceNode' (gr s) n
                    ST.put (s { gr = g' })
                    return n

-- | Inner monad version of replace node
replaceNode' :: Monad md => SceneGraph -> SceneNode -> md SceneGraph
replaceNode' gr nn = return $ replaceNode'' gr nn

-- | Actually does the job of replacing node in a scene graph
replaceNode'' :: SceneGraph -> SceneNode -> SceneGraph
replaceNode'' gr nn =  
                        let (m,gr') = match (idd nn) gr
                        in case m of 
                           Nothing -> gr
                           Just (i,n,_,o) -> (i,n,nn,o) & gr'


-- | Run the monad but keep it in the family.
runOSGL ::  Monad m => OSGState -> OSGT m SceneNode -> OSGT m (SceneNode,OSGState,Node)
runOSGL s n = lift $ runOSG s n

-- | Run the monad but keep it in the family.
runOSGL' ::  Monad m => OSGT m SceneNode -> OSGT m (SceneNode,Node)
runOSGL' n = do
                  s <- ST.get
                  (n1,s',i) <- runOSGL s n
                  ST.put s'
                  return (n1,i)


-- | Perform a function on a scene node
doOnNode ::  Monad m => OSGT m SceneNode -> (SceneNode -> SceneNode ) -> OSGT m SceneNode
doOnNode n f = do
                 s <- ST.get
                 (anode,s',i) <- runOSGL s n
                 ST.put s'
                 replaceNode (f anode)

-- | Create a light
light :: Monad m => OSGT m SceneNode
light =  addBasicNode  Light

-- | Create a camera
camera ::  Monad m => OSGT m SceneNode
camera = addBasicNode Camera

fi = fromIntegral


plane' :: Int -> ([(PrimitiveMode, Int, Int)],[VectorD],[VectorD])
plane' w = foldr (\ (a1,a2,a3) (b1,b2,b3) -> (a1:b1,a2++b2,a3++b3))  ([],[],[])    [ up w xs | xs <- [0..(w-1)]]

up :: Int -> Int -> ( (PrimitiveMode,Int,Int), [VectorD],[VectorD])
up w xs = ( (TriangleStrip, (xs*(w*2+2))+1, w*2+2),  [ fromList [(fi x),(fi y),0] | y <- [0..w],x <-[xs..(xs+1)]], [ fromList [0,0,1] |  x <-[1..2], y <- [0..w]])


-- | Create a plane
planeT ::  Monad m => Int -> OSGT m SceneNode
planeT w = addBasicNode (Geode $ Mesh1 a b c) where (a,b,c) = plane' w 

-- | Create a quad mesh
quad :: (Int,Int) ->  ([(PrimitiveMode, Int, Int)],[VectorD],[VectorD])
quad (x,y) = ( [(Quads,1,100) ], [ fromList[x',y',0], fromList[(x'+1),y',0], fromList[(x'+1),(y'+1),0], 
                 fromList [x',(y'+1),0]], [fromList [0,0,1] | i <- [0..3]])
             where x' = fi x
                   y' = fi y

planeq' w = foldr (\ (a1,a2,a3) (b1,b2,b3) -> (a1,a2++b2,a3++b3))  ([],[],[])  [ quad (x,y) | x <- [0..(w-1)], y <- [0..(w-1)]]

plane ::  Monad m => Int -> OSGT m SceneNode
plane w = addBasicNode (Geode $ Mesh1 a b c) where (a,b,c) = planeq' w

planeQ ::  Monad m => Int -> OSGT m SceneNode
planeQ = plane


-- | Create a node containing a torus.
torus :: Monad m => Float -> OSGT m SceneNode
torus i =  addBasicNode  (Geode $ GLObj $ GL.Torus (realToFrac i) (realToFrac (r*2)) 50 50)

-- | Create a node containing a sphere
sphere :: Monad m => Float -> OSGT m SceneNode
sphere r =  addBasicNode  (Geode $ GLObj $ GL.Sphere' (realToFrac r) 50 50)

-- | Create a node containing a tetrahedron
tetra :: Monad m => OSGT m SceneNode 
tetra =  addBasicNode  (Geode $ GLObj $ GL.Tetrahedron)

-- | Create a node containing a line
line :: Monad m => VectorD -> VectorD -> OSGT m SceneNode
line p q = addBasicNode (Geode $ Mesh1 [(Lines,1,2)] [p,q] [v1,v1] )

-- | Create a node containing a cube.
-- Fixme: Faces are not orientated same way.
cube :: Monad m => GLdouble -> OSGT m SceneNode
cube i = addBasicNode (Geode $ Mesh1 [ (Quads,1,6) ] (map fromList [
	   [md,md,md], [d,md,md],  [d,d,md], [md,d,md], -- Z
	   [md,d,d], [d,d,d],  [d,md,d], [md,md,d],
	   [d,md,md], [d,d,md], [d,d,d],[d,md,d],       -- X
	   [md,md,d], [md,d,d], [md,d,md],[md,md,md],
	   [md,d,md], [d,d,md], [d,d,d], [md,d,d],      -- Y
	   [md,md,md], [d,md,md], [d,md,d], [md,md,d]
	])
	(map fromList [
	   [0,0,1],  [0,0,1],  [0,0,1],  [0,0,1],
	   [0,0,mu],  [0,0,mu],  [0,0,mu],  [0,0,mu],
	   [mu,0,0],  [mu,0,0],  [mu,0,0],  [mu,0,0],
	   [1,0,0],  [1,0,0],  [1,0,0],  [1,0,0],
	   [0,mu,0], [0,mu,0],[0,mu,0],[0,mu,0],
	   [0,1,0],[0,1,0],[0,1,0],[0,1,0]
	]))  where (d,md,mu) = (i/2,(-i/2),(-1))



-- | Create cylinder as a BezierMesh
cylinder :: Monad m => GLfloat -> GLfloat -> OSGT m SceneNode
cylinder r h = addBasicNode $ Geode $ BezierMesh $ [
  [ (let z=z'*h in [Vertex3 0 (-r) z, Vertex3 (-d) (-r)  z, Vertex3 (-r) (-d) z, Vertex3 (-r) 0 z ]) | z' <- [0..1]],
  [ (let z=z'*h in[Vertex3 (-r) 0 z, Vertex3 (-r) d z    , Vertex3 (-d) r z   , Vertex3 0 r z    ]) | z' <- [0..1]] ,
  [ (let z=z'*h in[Vertex3 0 r z   , Vertex3 d r z       , Vertex3 r d z      , Vertex3 r 0 z    ]) | z' <- [0..1]],
  [ (let z=z'*h in[Vertex3 r 0 z   , Vertex3 r (-d) z    , Vertex3 d (-r) z   , Vertex3 0 (-r) z ]) | z' <- [0..1]]]
 where d = 0.66 * r
      

-- | Scale a node by equal amounts in all directions
scaleS :: Monad m => OSGT m SceneNode -> GLdouble -> OSGT m SceneNode
scaleS n f = scale n (vector3 f f f)

-- | Scale a node
scale :: Monad m => OSGT m SceneNode -> VectorD -> OSGT m SceneNode
scale n v = transformSG n (\x -> scaleM v x)  (\x -> scale x v)


-- | Translate a node
translate ::  Monad m => OSGT m SceneNode -> VectorD -> OSGT m SceneNode
translate n v = transformSG n (translateM v) ((flip translate) v)

-- | Rotate a node by an angle around a vector.
rotate :: Monad m => OSGT m SceneNode -> (GLdouble,VectorD) -> OSGT m SceneNode
rotate n a@(theta,v) = transformSG n (\x -> rotateM theta v x) (\x -> rotate x a)

rad x = x * pi /180

-- | Rotate a node around X axis
rotateX :: Monad m => OSGT m SceneNode -> GLdouble -> OSGT m SceneNode
rotateX n theta= rotate n ( (rad theta),vector3 1 0 0 )

-- | Rotate a node around Y axis
rotateY :: Monad m => OSGT m SceneNode -> GLdouble -> OSGT m SceneNode
rotateY n theta= rotate n ( (rad theta),vector3 0 1 0 )

-- | Rotate a node around Z axis
rotateZ :: Monad m => OSGT m SceneNode -> GLdouble -> OSGT m SceneNode
rotateZ n theta= rotate n ( (rad theta),vector3 0 0 1 )

-- | Apply colour to the node
colourSG :: Monad m => OSGT m SceneNode -> (Phong -> Phong) -> (OSGT m SceneNode -> OSGT m SceneNode ) -> OSGT m SceneNode
colourSG n action self = do
                (n1,i) <- runOSGL' n
                case n1 of 
                        (SceneNode n (Material p)) -> do
                                                               let p' = action p
                                                               replaceNode (SceneNode n (Material p'))
                        sn -> do 
                               let n'' = addNode (SceneNode (0,"") (Material newPhong))  [((),i)] 
                               self n''

-- | Transform the node of a scene graph within the Monad with the supplied matrix transform
transformSG :: Monad m => OSGT m SceneNode -> (MatrixD -> MatrixD) -> (OSGT m SceneNode -> OSGT m SceneNode ) -> OSGT m SceneNode
transformSG n action self = do
                (n1,i) <- runOSGL' n
                case n1 of 
                        (SceneNode num (MatrixTransform m)) -> do
                                                               let m' = action m
                                                               replaceNode (SceneNode num (MatrixTransform m'))
                        sn -> do 
                               let n'' = addNode (SceneNode (0,"") (MatrixTransform identityMatrix))  [((),i)] 
                               self n''

-- | Transform the node of a scene graph with the supplied matrix transform
transformSG' :: SceneGraph -> Node -> (MatrixD ->MatrixD ) -> SceneGraph
transformSG' sg nde mf = case llab sg nde of 
                         (SceneNode _ (MatrixTransform m)) -> replaceNode'' sg (SceneNode (nde,show nde) (MatrixTransform (mf m)))
                         _ -> error "FIXME: Not a transform node"

translateSG' :: SceneGraph -> Node -> VectorD -> SceneGraph
translateSG' sg nde v = transformSG' sg nde (translateM v)

translatePostSG' :: SceneGraph -> Node -> VectorD -> SceneGraph
translatePostSG' sg nde v = transformSG' sg nde (translatePostM v)

rotatePostSG' :: SceneGraph -> Node -> VectorD -> GLdouble -> SceneGraph
rotatePostSG' sg nde v theta = transformSG' sg nde (rotatePostM theta v)

-- | Add colour to a node
colour ::  Monad m => OSGT m SceneNode -> Colour -> OSGT m SceneNode
colour n c = colourSG n (\ p -> colour2Phong c) ( (flip colour) c)

-- | Label a node
label :: Monad m =>  OSGT m SceneNode -> String -> OSGT m SceneNode
label anode lbl = do
                (SceneNode (nde,_) dte,_) <- runOSGL' anode
                replaceNode (SceneNode (nde,lbl) dte)
                                                             

-- | Add texture 
texture :: Monad m => OSGT m SceneNode -> String -> OSGT m SceneNode
texture n texName = do
                (n1,i) <- runOSGL' n
                addNode (SceneNode (0,"") (Texture texName ))  [((),i)] 

-- | Add Text
text  :: Monad m => String -> OSGT m SceneNode
text str =  addBasicNode  (Text str)



infixr 5 <+>
infixl 9 <*>
infixl 9 </>


-- | Join two graphs together
(<+>) ::  Monad m => OSGT m SceneNode -> OSGT m SceneNode -> OSGT m SceneNode
(<+>) a b  = do
                 s <- ST.get
                 (a', s',i) <- runOSGL s a
                 (b', s'',j) <- runOSGL s' b
                 ST.put s''
                 addNode (SceneNode (0,"") Group  ) [((),i),((),j)]
        

-- | Translate a node
(<*>) ::  Monad m => OSGT m SceneNode -> VectorD -> OSGT m SceneNode
(<*>) = translate

-- | Scale a node
(</>):: Monad m => OSGT m SceneNode -> VectorD -> OSGT m SceneNode
(</>) = scale
 

doNothing _ = return ()

-- | Add an handler node
handler :: Monad m =>  OSGT m SceneNode -> ClickHandler -> OSGT m SceneNode
handler n f = do
                (n1,i) <- runOSGL' n
                addNode (SceneNode (0,"") (Handler (Just (f,doNothing)) Nothing))  [((),i)] 

handler2 :: Monad m =>  OSGT m SceneNode -> (ClickHandler,DragHandler) -> OSGT m SceneNode
handler2 n (f,g) = do
                (n1,i) <- runOSGL' n
                addNode (SceneNode (0,"") (Handler (Just (f,doNothing)) (Just (g,doNothing))))  [((),i)] 

-- | Create a DragHandler
dragHandler :: DragHandler
dragHandler (sg,nde) vec = do
                let tnde = head' "dragHandler 1" $ pre sg nde
                    sg' = translateSG' sg tnde vec
                    SceneNode _ (MatrixTransform m) = llab sg' tnde
                    posx = (head' "dragHandler 2" (toLists m))!!3                                  
                return $ (if abs posx < 1 then sg' else sg,posx)

-- | Create a ClickHandler
switchHandler :: ClickHandler
switchHandler (sg,nde) ev = do
                                let sn = head' "switchHandler" $ suc sg nde
                                    sn' = llab sg sn
                                let sg' = switchNode sn' (if ev == Down then 1 else 0) sg
                                return sg'

switchNode' nde n = \gr -> let (SceneNode _ (Switch _)) = llab gr nde in  replaceNode'' gr (SceneNode (nde,show nde) (Switch n))
                                

switchNode ::  SceneNode -> Int -> SceneGraph -> SceneGraph
switchNode (SceneNode nde (Switch _)) n = \gr -> replaceNode'' gr newNode 
                                                           where newNode = SceneNode nde (Switch n)

-- | Create a switch node
switch ::  Monad m => OSGT m SceneNode -> OSGT m SceneNode -> OSGT m SceneNode
switch a b = switch' 0 a b


switch'::  Monad m => Int -> OSGT m SceneNode -> OSGT m SceneNode -> OSGT m SceneNode
switch' nde a b  = do
                    s <- ST.get
                    (a', s',i) <- runOSGL s a
                    (b', s'',j) <- runOSGL s' b
                    ST.put s''
                    n <- addNode (SceneNode (nde,show nde) (Switch 0)) [((),i),((),j)]
                    return n


-- | Wrapper for running the OSG monad to return a scene graph and root node.
osg :: Monad m => OSGT m SceneNode -> m Scene
osg f = do
           (n,state,_) <- runOSG emptyState f
           return (gr state,idd n)

-- | Create and run a OSG monad to return a scene graph and root node.
runOSG :: Monad m => OSGState -> OSGT m SceneNode -> m (SceneNode,OSGState,Node)
runOSG state f = do
              (ret, state') <- ST.runStateT  f state
              return (ret, state',root state')


runOSGShow f = do 
                  let (ret, state,i) = runOSG emptyState f
                  putStrLn $ show $ (ret,state,i)

idd (SceneNode (i,_)  _  ) = i


-- | Get a strip mesh
strip :: Monad m => OSGT m SceneNode
strip = do
           let n = SceneNode (0,"") (Geode $ Mesh1 [(TriangleStrip,0,3)] [
                                    vector3 (-2) 0 (-2),
                                    vector3 (2)  0 (-2),
                                    vector3 0 0 0 ] [
                                    vector3 0 (-1) 0,
                                    vector3 0 (-1) 0,
                                    vector3 0 (-1) 0 ] )
           addNode n []

-- | Make a group node from list of nodes
makeGroup :: Monad m => [SceneNode] -> OSGT m SceneNode
makeGroup (n:[]) = addNode n []
makeGroup (n:ns) = let n' = makeGroup ns
                   in (addNode n []) <+> n'

emptyScene :: Scene
emptyScene = (empty,0)


r :: GLdouble
r = 5.0

getHitAction :: Scene -> (GLuint -> IO ())
getHitAction _ = (\n -> return ())

-- | Work up the tree from indicated no to find the first handler scene node.
findHandler :: SceneGraph -> GLuint -> Maybe SceneNode
findHandler gr num = let start = fromEnum num
                         findUp num = case llab gr num of
                                           SceneNode (id,_) (Handler f _) -> [llab gr id]
                                           _ -> concatMap findUp (pre gr num)
                     in case (findUp start) of
                             [] -> Nothing
                             (a:_) -> Just a
                             
                             
-- | Work down the tree from indicated no to find the first handler scene node.
findHandlerDown :: SceneGraph -> Int -> Int 
findHandlerDown gr num = 
                         let findDown num = case llab gr num of
                                           SceneNode (id,_) (Handler f _) -> [id]
                                           _ -> concatMap findDown (suc gr num)
                         in case (findDown num) of
                             [] -> error "findHandlerDown failed"
                             (a:_) -> a 
                             
                         
findTextDown :: SceneGraph -> Int -> Int 
findTextDown gr num = 
                         let findDown num = case llab gr num of
                                           SceneNode (id,_) (Text _ ) -> [id]
                                           _ -> concatMap findDown (suc gr num)
                         in case (findDown num) of
                             [] -> error "findHandlerDown failed"
                             (a:_) -> a 

{--
-- Buttons are always switch nodes but selected geometry will not be so we need to search 
-- up to find the owning widget.
-- FIXME use switchNode?
--}

-- | Handle some event
handleClickEvent :: Scene -> GLuint -> KeyState ->  IO (Scene, Maybe Scene,Maybe ( SceneGraph -> SceneGraph ))
handleClickEvent (gr,start) n ks = do
                                -- putStrLn $ "handle event" ++ show ks
                                case (findHandler gr n) of
                                      Just (SceneNode (id,_) (Handler (Just (fn,snk)) _ )) -> do
                                                                              sg <-  fn (gr,id) ks
                                                                              case ks of 
                                                                                  Down -> snk ()
                                                                                  _ -> return ()
                                                                              return ((sg,start),Just (sg,id),Nothing)
                                      _ -> return ((gr,start),Nothing,Nothing)

llab gr n = case (lab gr n) of
                 Nothing -> error $ "Shouldnot happen gr=" ++ (show gr) ++ "n = " ++(show n)
                 Just n' -> n'

emptyOSG :: SceneGraph
emptyOSG = empty

mapColour :: Colour -> Color4 GLfloat
mapColour Red =   Color4 1 0 0 1
mapColour Green = Color4 0 1 0 1
mapColour Blue =  Color4 0 0 1 1
mapColour Grey =  Color4 0.4 0.4 0.4 1
mapColour LightBlue =  Color4 0.3 0.3 1.0 1
mapColour Black = Color4 0 0 0 1
mapColour White = Color4 1 1 1 1
mapColour Yellow  = Color4 1 1 0 1
mapColour JustWhite = Color4 0.9 0.9 0.9 1

findCamera :: Scene -> Int -> Node
findCamera (gr, nde) i = head' "findCamera" $ filter (\x -> case (llab gr x) of 
                                                             SceneNode _ Camera -> True
                                                             _ -> False) (nodes gr)
findCameraPath :: Scene -> Int -> Path
findCameraPath (gr, nde) i = let nde2 = findCamera (gr,nde) i
                             in esp nde nde2 gr


-- | Return the matrix got by traversing down the Node
getTransformTo :: Scene -> Node -> MatrixD
getTransformTo (gr,start) nde = foldr trans  identityMatrix $  esp start nde gr
                                where trans  n mat1 = case llab gr n of 
                                                        SceneNode _ (MatrixTransform mat2) -> mat1 `mul` mat2
                                                        _ -> mat1

                              
--asVec3 :: Vector GLdouble -> VectorD
--asVec3 v = let [x,y,z] = toList v in Vector3 (realToFrac x) (realToFrac y) (realToFrac z)

getByLabel :: SceneGraph -> String -> Node
getByLabel gr lbl = head' "getByLabel" $ filter (\n -> let (SceneNode (_,lbl') _) = llab gr n in lbl == lbl') (nodes gr)


-- | A box. Used for calculating bounds
type Box a = (Vector a, Vector a)

-- | Bounds suitable for starting off with
smallBox :: Box GLdouble
smallBox = (fromList [ (-0.1), (-0.1), (-0.1)], fromList [0.1,0.1,0.1])

-- | Create union of two boxes
union :: (Ord a,Storable a) => Box a -> Box a -> Box a
union (v1,v2) (w1,w2) = let v1' = toList v1
                            v2' = toList v2
                            w1' = toList w1
                            w2' = toList w2
                        in (fromList $ map (uncurry min) $ zip v1' w1',
                            fromList $ map (uncurry max) $ zip v2' w2')

-- | Determine bounds of the scene
bounds :: Scene -> Box GLdouble
bounds (gr,nde) = let sn = llab gr nde
                  in boundsSceneNode  gr sn

-- | Determine bounds of a @SceneNode@
boundsSceneNode gr (SceneNode (nde,_) (MatrixTransform mt)) = let (v1,v2) = boundsOfChildren gr nde
                                                              in (mt `mulV` v1, mt `mulV` v2)

boundsSceneNode gr (SceneNode (nde,_) (Switch i)) = let nde' = (suc gr nde)!!i
                                                    in bounds (gr,nde')

boundsSceneNode gr (SceneNode _  (Geode (GLObj o))) = smallBox

boundsSceneNode gr (SceneNode (nde,_) _) = boundsOfChildren gr nde

boundsOfChildren gr nde = maybe smallBox id $ foldr f  Nothing (suc gr nde) where
                                                    f nde Nothing = Just $ bounds (gr,nde)
                                                    f nde (Just b) = Just $ b `union` bounds (gr,nde)