scenegraph (empty) → 0.1

raw patch · 53 files changed

+2673/−0 lines, 53 filesdep +GLUTdep +OpenGLdep +arraysetup-changedbinary-added

Dependencies added: GLUT, OpenGL, array, base, containers, fgl, haskell98, hmatrix, mtl, old-time, process

Files

• LICENSE +26/−0
• Setup.lhs +3/−0
• data/Snow.tga binary
• data/ankhlite_wht.tga binary
• data/ankhlite_ylw.blend.tga binary
• data/ankhlite_ylw.tga binary
• data/bounce_effects.tga binary
• data/font.tga binary
• data/gold_groove.tga binary
• data/gold_trim01.tga binary
• data/gold_trim02.tga binary
• data/gold_trim03.tga binary
• data/heiro_01.tga binary
• data/leaf.tga binary
• data/oldbrk_01.tga binary
• data/oldbrk_01broken13.tga binary
• data/oldbrk_03.tga binary
• data/oldbrk_03_bloody.tga binary
• data/oldstone2.tga binary
• data/oldstone2_bas01.tga binary
• data/oldstone2_bas03.tga binary
• data/oldstone2_bas04.tga binary
• data/oldstone2_bas05.tga binary
• data/oldstone2_bas06.tga binary
• data/oldstone2_bas07.tga binary
• data/oldstone2_step.tga binary
• data/oldstone2_trim01.tga binary
• data/oldstone2_trim02.tga binary
• data/oldstone2grooved.tga binary
• data/oldstone_ramses.tga binary
• data/plant_egy.tga binary
• data/sand_egy.tga binary
• data/stei_tele2.tga binary
• scenegraph.cabal +30/−0
• src/Calc.hs +37/−0
• src/Example.hs +29/−0
• src/ExampleReactive.hs +43/−0
• src/Graphics/SceneGraph.hs +29/−0
• src/Graphics/SceneGraph/Basic.hs +736/−0
• src/Graphics/SceneGraph/Dump.hs +50/−0
• src/Graphics/SceneGraph/GraphViz.hs +26/−0
• src/Graphics/SceneGraph/Library.hs +256/−0
• src/Graphics/SceneGraph/Matrix.hs +52/−0
• src/Graphics/SceneGraph/MySTM.hs +30/−0
• src/Graphics/SceneGraph/Reactive.hs +124/−0
• src/Graphics/SceneGraph/ReadImage.hs +68/−0
• src/Graphics/SceneGraph/Render.hs +248/−0
• src/Graphics/SceneGraph/SimpleViewPort.hs +503/−0
• src/Graphics/SceneGraph/TGA.hs +102/−0
• src/Graphics/SceneGraph/Textures.hs +57/−0
• src/Graphics/SceneGraph/Utils.hs +5/−0
• src/Graphics/SceneGraph/Vector.hs +46/−0
• src/Graphics/SceneGraph/VectorSpace.hs +173/−0

@@ -0,0 +1,26 @@+Copyright (c) 2008, Mark Wassell
+ All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification, are 
+permitted provided that the following conditions are met:
+
+Redistributions of source code must retain the above copyright notice, this list of 
+conditions and the following disclaimer.
+
+Redistributions in binary form must reproduce the above copyright notice, this list of 
+conditions and the following disclaimer in the documentation and/or other materials 
+provided with the distribution.
+
+Neither the name of Mark Peter Wassell nor the names of its contributors may be used 
+to endorse or promote products derived from this software without specific prior written 
+permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 
+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR 
+TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

binary file changed (absent → 1423654 bytes)

binary file changed (absent → 12306 bytes)

binary file changed (absent → 12306 bytes)

binary file changed (absent → 12306 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 262188 bytes)

binary file changed (absent → 98322 bytes)

binary file changed (absent → 49170 bytes)

binary file changed (absent → 49170 bytes)

binary file changed (absent → 6162 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 49170 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 12306 bytes)

binary file changed (absent → 49170 bytes)

binary file changed (absent → 98322 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 49170 bytes)

binary file changed (absent → 196626 bytes)

binary file changed (absent → 196626 bytes)

@@ -0,0 +1,30 @@+Name:           scenegraph
+Version:        0.1
+Copyright:      Mark Wassell 2008
+License:        BSD3
+license-file:	LICENSE
+Author:         Mark Wassell <mwassell@bigpond.net.au>
+Maintainer:     Mark Wassell <mwassell@bigpond.net.au>
+Stability:	experimental
+Homepage:       http://www.haskell.org/haskellwiki/SceneGraph
+Category:       Graphics
+Build-Depends:  base,mtl,hmatrix,OpenGL>=2.2,GLUT>=2.1,haskell98,containers,fgl,array,old-time,process
+build-type:	Simple
+tested-with:	GHC==6.8.2
+Synopsis:       Scene Graph
+Description:
+	Scene Graph Library
+Extensions: OverlappingInstances,UndecidableInstances
+Hs-Source-Dirs:	src
+Exposed-Modules: Graphics.SceneGraph,
+	Graphics.SceneGraph.Basic,
+        Graphics.SceneGraph.Vector,
+        Graphics.SceneGraph.Render,
+        Graphics.SceneGraph.SimpleViewport,
+	Graphics.SceneGraph.GraphViz,
+        Graphics.SceneGraph.Library,
+        Graphics.SceneGraph.Dump,
+        Graphics.SceneGraph.Textures
+
+
+

@@ -0,0 +1,37 @@+module Calc where
+
+
+data Calculator = Calculator { replace :: Bool,
+                               operand :: Maybe String,
+                               operator :: Maybe String,
+                               register :: String } deriving Show
+                               
+newCalculator = Calculator True Nothing Nothing "0"
+
+
+applyCalc :: Calculator -> String -> Calculator
+applyCalc calc "+" = calc { replace=True,
+                        operand = Just (register calc),
+                        operator = Just "+" }
+applyCalc calc "=" = doCalc calc
+applyCalc calc "c" = newCalculator
+applyCalc calc "ce" = calc { replace=True, register="0" }
+applyCalc calc str = if replace calc then
+                     calc { replace=False,register=str }
+                 else
+                     calc { register = (register calc) ++ str}
+                     
+doCalc calc = let x = read $ maybe "0" id (operand calc ) 
+                  y = read $ register calc
+              in case (operator calc) of
+                    Just "+" -> calc { replace=True,register = show $ x + y,operand= Just $ show y }
+                    _ -> calc
+                        
+                        
+calcString = foldl applyCalc newCalculator 
+
+t1 = calcString [ "1", "+", "1", "=", "=", "="]
+
+t2 = calcString [ "2", "+", "5", "=","="]
+
+          

@@ -0,0 +1,29 @@+----------------------------------------------------------------------
+-- |
+-- Module      :  Main
+-- Copyright   :  (c) Mark Wassell 2008
+-- License     :  LGPL
+-- 
+-- Maintainer  :  mwassell@bigpond.net.au
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- Example scenegraphs. See SimpleViewPort.hs for how to navigate around the
+-- scene. See Library.hs for the construction of the examples
+----------------------------------------------------------------------
+module Main where
+
+import Graphics.SceneGraph
+
+-- Button and 'Hello World' text.
+ex1 = runScene sceneButton 
+
+ex2 = runScene $ osgt $ cube 0.5 `colour` Green `scale` v1x 40 `translate` vy 2 <+> camera `translate` vy (-10) <+> light `translate` vz 10 
+
+-- An Ancient Egyptian Calculator
+ex3 = runScene calculator
+
+-- Tux the penguin
+ex4 = runScene tuxAndToys
+
+

@@ -0,0 +1,43 @@+module Main where
+
+import Graphics.SceneGraph
+import Graphics.SceneGraph.Reactive
+
+import Control.Concurrent.MVar
+import Control.Monad.State
+import Control.Applicative hiding ( (<*>) )
+import Control.Concurrent (yield, forkIO, killThread, threadDelay, ThreadId,forkOS)
+
+import Data.Reactive
+import Data.IORef
+import Data.Monoid
+
+import Calc
+
+calc = runSceneReactive calculator sceneButtonReactive
+
+--
+-- To get at the string to display we fmap register to the calculator
+--
+sceneButtonReactive :: SGM (Event Action)
+sceneButtonReactive = do
+        snk <- getNodeByLabel "txt" >>= mkText
+        ce <- calcEvent
+        return $ snk <$> (fmap register ce )
+  
+-- Build a Calculator event. Build up the button events and 
+-- append these events together.
+calcEvent :: SGM (Event Calculator)
+calcEvent = do 
+        btnList <- mapM mkCalcBtn ["0","1","2","3","4","5","6","7","8","9","c", "+","=" ]
+        return $ scanlE applyCalc newCalculator $ foldr mappend mempty btnList 
+
+
+-- Turn passive button in the scene graph into an active one that 
+-- provides an event that returns 'lbl'   
+mkCalcBtn :: [Char] -> SGM (Event String)   
+mkCalcBtn lbl = do
+          ev <- getNodeByLabel ("btn" ++ lbl) >>= mkButton
+          return $ fmap (const lbl) ev
+            
+

@@ -0,0 +1,29 @@+-- Copyright   :  (c) Mark Wassell 2008
+-- License     :  LGPL
+-- 
+-- Maintainer  :  mwassell@bigpond.net.au
+-- Stability   :  experimental
+-- 
+-- SceneGraph library for OpenGL
+--
+
+module Graphics.SceneGraph (
+         module Graphics.SceneGraph.Basic ,
+         module Graphics.SceneGraph.Vector,
+         module Graphics.SceneGraph.Render,
+         module Graphics.SceneGraph.SimpleViewport,
+         module Graphics.SceneGraph.GraphViz,
+         module Graphics.SceneGraph.Library,
+         module Graphics.SceneGraph.Dump,
+         module Graphics.SceneGraph.Textures
+
+)  where
+
+import Graphics.SceneGraph.SimpleViewport
+import Graphics.SceneGraph.GraphViz
+import Graphics.SceneGraph.Library
+import Graphics.SceneGraph.Basic 
+import Graphics.SceneGraph.Dump
+import Graphics.SceneGraph.Render
+import Graphics.SceneGraph.Textures
+import Graphics.SceneGraph.Vector

@@ -0,0 +1,736 @@+{-# 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)
+
+
+
+
+
+

@@ -0,0 +1,50 @@+{--
+  Dumps SceneGraph into Haskell. 
+--}
+module Graphics.SceneGraph.Dump where
+
+import System.IO
+import System.Process
+import Graphics.SceneGraph.Basic
+import Data.Graph.Inductive
+import Data.Graph.Inductive.Graphviz
+import  Graphics.SceneGraph.Library
+
+dump :: SceneGraph -> IO ()
+dump gr = withFile  "c:/Mark/MyDevelopments/haskell/SceneGraph/src/Graphics/SceneGraph/TestLoad.hs" WriteMode $ \fd -> do
+             preamble fd
+             mapM_ (dumpNode fd gr) (nodes gr)
+
+dumpNode fd gr nde = do
+                     let (SceneNode (n,l) dte) = llab gr nde
+                     hPutStrLn fd $ "n" ++ (show n) ++ " = SceneNode " ++ (show (n,l)) ++ "(" ++ (writeSceneData dte) ++ ")"
+
+
+writeSceneData Group = "Group"
+writeSceneData (Geode geom ) = "Geode $ " ++ (show  geom)
+writeSceneData LOD = "LOD"
+writeSceneData (MatrixTransform m) = "MatrixTransform $ " ++ show m
+-- writeSceneData (SimpleTransform a b c) = "SimpleTransform " ++ show a ++ " " ++ show b ++ " " ++ show c
+writeSceneData (Switch i) = "Switch " ++ show  i
+writeSceneData (Material mt) = "Material $ " ++ (show mt)
+writeSceneData (Handler _ _) = "Handler Nothing Nothing"  -- User will need to rebuild this part.
+writeSceneData Light = "Light"
+writeSceneData Camera = "Camera"
+writeSceneData (Texture _) = "Texture"
+writeSceneData (Text t ) = "Text " ++ "\"" ++ t ++ "\""
+             
+
+preamble fd = do
+            hPutStrLn fd "module Graphics.SceneGraph.TestLoad where"
+            hPutStrLn fd "import Graphics.SceneGraph.Basic"
+            hPutStrLn fd "import Graphics.SceneGraph.Matrix"
+            hPutStrLn fd "import Graphics.SceneGraph.Vector"
+            hPutStrLn fd "import Graphics.UI.GLUT.Objects as GL"
+            hPutStrLn fd "import Data.Graph.Inductive hiding (mkNode,context)"
+            hPutStrLn fd "import Data.Sequence hiding (empty)"
+            hPutStrLn fd "import Data.Reactive"
+            hPutStrLn fd "import Data.Array"
+            hPutStrLn fd "import Graphics.Rendering.OpenGL.GL.BeginEnd"
+            hPutStrLn fd "import Graphics.Rendering.OpenGL (Vector3)"
+            hPutStrLn fd "import Graphics.UI.GLUT  hiding (Sink,Red, Green,Blue,Matrix,Error,get,scale,translate,rotate,Light,light,texture,Texture,Text,set,get)"
+            hPutStrLn fd "import Graphics.UI.GLUT.Fonts"

@@ -0,0 +1,26 @@+module Graphics.SceneGraph.GraphViz where
+
+import System.IO
+import System.Process
+import Graphics.SceneGraph.Basic
+import Data.Graph.Inductive
+
+
+exportDot p = do 
+          f <- openDot "C:\\temp\\sg.dot"
+          exportSG f p
+          closeDot f
+          ph <- runProcess "C:\\Software\\01_Applications\\GraphViz\\GraphvizNOTUSED\\bin\\dot.exe" ["-Tpng", "-oC:\\temp\\g.png", "C:\\temp\\sg.dot"] Nothing Nothing Nothing Nothing Nothing
+          waitForProcess ph
+
+
+openDot fname = do
+	       fh <- openFile fname WriteMode
+               return fh
+
+exportSG :: Handle -> (SceneGraph,Node) -> IO ()
+exportSG f (p,_) = do
+               hPutStrLn f (graphviz' p)
+
+closeDot fh = do
+               hClose fh   

@@ -0,0 +1,256 @@+{-# LANGUAGE  MultiParamTypeClasses, FunctionalDependencies, 
+    TypeSynonymInstances, PatternSignatures #-}
+    
+----------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.SceneGraph.Library
+-- Copyright   :  (c) Mark Wassell 2008
+-- License     :  LGPL
+-- 
+-- Maintainer  :  mwassell@bigpond.net.au
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+--
+----------------------------------------------------------------------
+module Graphics.SceneGraph.Library where
+
+import Graphics.Rendering.OpenGL (GLdouble)
+import Data.Graph.Inductive.Graph
+import Control.Monad.Identity
+import Control.Monad
+
+import Graphics.SceneGraph.Basic
+import Graphics.SceneGraph.Vector
+
+
+-- | 
+osgt = runIdentity . osg
+
+simple1 :: (SceneGraph,Node)
+simple1 =  osgt $ torus 0.5 `colour` Red 
+
+
+simple :: (SceneGraph,Node)
+simple =  osgt d where 
+          d  = do 
+             let ring =  torus 0.5 `colour` Red 
+                 axial1 = cube 0.5 `scale` v1x 40 `colour` Green
+                 axial2 = cube 0.5 `scale` v1z 40 `colour` Green
+             ring `translate` vy 2 <+> ring `translate` vy (-2) <+> axial1 `translate` vy (-3) <+> axial2 `translate` vy 3
+          
+rr :: GLdouble
+rr = 5
+
+crossbeam :: GLdouble -> OSG SceneNode
+crossbeam t = cube 0.5 `colour` Red `scale` v1y 8 `translate` vector3 ((rr*2) * (sin t)) 0 ( (rr*2) * (cos t))
+
+crossbeams' (t:[]) = crossbeam t
+crossbeams' (t:ts) = let n' = crossbeams' ts
+                           in (crossbeam t) <+> n'
+
+crossbeams = crossbeams' [(2*pi*i/8) | i <- [0..7]  ]
+
+ferris :: GLdouble -> OSG SceneNode
+ferris theta = do 
+             let ring = torus 0.5 `colour` White --Blue
+                 axial1 = cube 0.5 `scale` v1x 40 `colour` Green
+                 axial2 = cube 0.5 `scale` v1z 40 `colour` Green
+                 axial = axial1 <+> axial2
+             root <- (strip <+> ring `translate` vy 2 <+> ring `translate` vy (-2) 
+                     <+> axial `translate` vy (-2) <+> axial `translate` vy 2 <+> crossbeams) `rotate` (theta , (vector3 0 1 0 ))
+             return root
+
+-- Blue is the bit the user clicks/drags
+-- Red is the 'border'
+-- Yellow/Green is the rest
+
+-- FIXME - The centre of the wheel also switchs to white ??
+wheel :: OSG SceneNode
+wheel = do 
+             let ring = torus 0.5 `colour` Red
+                 axial = cube 0.5 `scale` v1x 40 `colour` Green
+             ( simple_button 0.75 `colour` Blue <*> vz 10 <+> 
+               sphere 1 <+> ring <+> axial <+> axial `rotateY` 45 <+> axial `rotateY` 90 <+> 
+               axial `rotateY` 135) `scaleS` 0.1 
+
+buttons :: OSG SceneNode
+buttons =   do
+                let snum = 101
+                    switch2 = switch' snum
+                    btn1 = (sphere 1 `colour` Red) `switch`  (sphere 1 `colour` White)
+                    btn2 = (sphere 1 `colour` Green) `switch`  (sphere 1 `colour` White)
+                    b_blue  = btn1 `handler` switchHandler
+                    b_green = btn2 `handler` switchHandler
+                    b_colour = (sphere 1 `colour` Blue) `switch2` (sphere 1 `colour` Green)
+                b_blue <+> b_green <*> vz 10 <+> b_colour `translate` vz 20 <+> light <*> vz 15 <+> camera <*> (vy (-10))
+                
+
+simple_button s = (sphere s `colour` Blue) `switch`  (sphere s `colour` White)
+
+
+
+button = simple_button 0.5  `handler` switchHandler <*> vy (-0.15) 
+     <+> cube 0.5 `colour` Green </> (vector3 2.5 1.2 2.5) 
+     <+> torus 1 `scaleS` 0.05 `colour` Red <*> vy (-0.3)
+     
+sqButton = ((cube 0.4 `colour`) Blue `switch` (cube 0.4 `colour` White)) `handler` switchHandler <*> vy (-0.15) 
+       <+> cube 0.5 `colour` Green 
+
+textBox = text "Hello World" `scaleS` 0.02 `colour` White
+
+slider =  simple_button 0.17 `handler2` (switchHandler,dragHandler) </> vector3 1 1 1.2  <*> vy (-0.2) 
+      <+> cube  0.5 `colour` Green </> (vector3 8 1.2 2) 
+      <+> torus 2 </> (vector3 0.15 0.02 0.02) `colour` Red <*> vy (-0.3)
+
+tux :: OSG SceneNode
+tux =  let sphere' a x y z = sphere a  </> vector3 x y z
+           body = sphere' 1 0.95 1   0.8 `colour` Black
+                       <+> sphere' 1 0.8  0.9 0.7 `colour` White
+                           <*> vector3 0 0 0.17 
+           torso = body `scaleS` 0.9
+           (shoulders::OSG SceneNode)  = (leftArm <+> rightArm <+> body `scaleS` 0.72 ) 
+                        <*> vector3 0 0.4 0.05
+           neck = head <*> vector3 0 0.9 0.07
+                       <+> sphere' 0.8  0.45 0.5 0.45 `colour` Black `rotateY` 90 
+                       <+> sphere' 0.66 0.8 0.9 0.7 `colour` White
+                           <*> (vector3 0 (-0.08) 0.35)
+           (head::OSG SceneNode) = (beak <+> eyes 
+                          <+> sphere' 1 0.42 0.5 0.42 `colour` Black `rotateY` 90 ) 
+                               <*> (vector3 0 0.3 0.07)
+           beak = sphere' 0.8  0.23 0.12 0.4 `colour` Yellow `rotateX` 10 
+                              <*> (vector3 0 (-0.205) 0.3) 
+                       <+> sphere' 0.66  0.21 0.17 0.38 `colour` Yellow `rotateX` 10 
+                              <*> (vector3 0 (-0.23) 0.3)
+           eyes = leftEye <+> leftIris <+> rightEye <+> rightIris
+           leftEye = sphere' 0.66  0.1 0.13 0.03 `colour` White 
+                              <*> (vector3 0.13 (-0.03) 0.38)
+           leftIris = sphere' 0.66  0.055 0.07 0.03 `colour` Yellow 
+                              <*> (vector3  0.12 (-0.045) 0.4)
+           rightEye = leftEye <*> (vx (-0.26))
+           rightIris = leftIris <*> (vx (-0.26))
+           leftForeArm = leftHand <+> sphere' 0.66 0.3 0.07 0.15 `colour` Black 
+                              <*> vx (-0.23)
+           leftHand = sphere' 0.5 0.12 0.05 0.12
+           leftArm = (leftForeArm <+> sphere' 0.66 0.34 0.1 0.2 `colour` Black ) 
+                                `rotateX` 90 `rotateZ` 45 <*> vector3 (-0.56) 0.3 0 `rotateY` 180
+           rightArm = sphere 0.1
+           hipBall = sphere' 0.5 0.09 0.18 0.09 `colour` Black
+           calf = (foot <+> sphere' 1  0.06 0.18 0.06 `colour` Yellow) 
+                             `rotateY` 90 <*> (vector3  0 (-0.21) 0)
+           foot = (footBase <+> toe1 <+> toe2 ) `colour` Yellow </> (vector3 1.1 1.0 1.3)
+           footBase = sphere' 0.66  0.25 0.08 0.18
+           toe1 = sphere' 0.66 0.27  0.07 0.11 `rotateY` 30 <*> (vector3  (-0.07) 0 0.1)
+           toe2 = sphere' 0.66 0.27 0.07 0.11
+           (thigh::OSG SceneNode) = (hipBall <+> calf <+> sphere' 0.5 0.07 0.3 0.07 `colour` Yellow 
+                                <*> (vector3 0 (-0.1) 0) `rotateY` (-110) ) `rotateY` 110 
+                                <*> (vector3 (-0.28) (-0.8) 0) `rotateY` 180
+
+           (tail::OSG SceneNode) = sphere' 0.5  0.2 0.3 0.1 `colour` Black 
+                                <*> (vector3 0 0.15 0) `rotateX` (-60) 
+                                <*> (vector3  0 (-0.4) (-0.5))
+
+           in torso <+> shoulders <+> neck <+> thigh  <+> thigh <+> tail
+
+
+tuxAndToys :: Scene
+tuxAndToys =  osgt $ tux `rotateZ` (0) `rotateY` (0)  `rotateX` 90 <*> vz 1.1
+           <+> wheel  <*> vector3 2 0 1
+           <+> button <*> vector3 4 0 2.2
+           <+> button <*> vector3 4 0 1
+           <+> slider  <*> vector3 7 0 1
+           <+> textBox <*> vector3 2 0 3
+           <+> plane 10   `colour` LightBlue  <*> vector3 (-5) (-5) 0
+           <+> light <*> vz 20 
+           <+> camera <*> vector3 (-4) 0 3
+
+
+sliderScene =  osgt $  slider  <*> vector3 7 0 1  <+> plane 10   `colour` LightBlue  <*> vector3 (-5) (-5) 0
+           <+> light <*> vz 20 
+           <+> camera <*> vector3 (-4) 0 3
+
+{--
+scene3 = osgt $ addNodeBasic buttonMesh `colour` Blue `scaleS` 50 <*> vector3 (-125) (75) 0
+           <+>  addNodeBasic mesh1 `colour` Blue `scaleS` 1 <*> vector3 (-125) (75) 0
+           <+>  addNodeBasic mesh2 `colour` Blue `scaleS` 1 <*> vector3 (-125) (75) 0
+           <+>  addNodeBasic mesh3 `colour` Blue `scaleS` 1 <*> vector3 (-125) (75) 0
+           <+> light <*> vz 20 
+           <+> camera <*> vector3 (-4) 0 3
+--}
+emptyScene = osgt $ plane 10   `colour` LightBlue  `rotateX` 90 <*> vector3 (-5) (10) 0
+           <+> light <*> vz 20 
+           <+> camera <*> vector3 (-4) 0 3
+                 
+
+--scene3 = osgt $
+-- scene3 = osgt $ addNodeBasic  `colour` Blue `scaleS` 1 <*> vector3 (-125) (75) 0
+--           <+> light <*> vz 20 
+--           <+> camera <*> vector3 (-4) 0 3
+
+sceneSlider = osgt $ slider
+           <+> textBox <*>  vector3 2 0 3
+           <+> light <*> vz 20 
+           <+> camera <*> vector3 (-4) 0 3
+
+sceneButton = osgt $ button `label` "btn1"
+           <+> textBox `label` "txt" <*>  vector3 2 0 3
+           <+> light <*> vz 20 
+           <+> camera <*> vector3 0 (-10) 0
+
+calcButton :: [Char] -> OSGT Identity SceneNode
+calcButton txt = sqButton `label` ("btn" ++ txt) <+> (text txt `scaleS` 0.002 <*> vector3 (-0.1) (-0.4) (-0.2))
+
+
+room' tWall tFloor tCeiling size = let wall txt = plane 1 `texture` txt </> vector3 (size) (size) 1
+                                       hs = size/2
+               in    (wall tFloor <*> vector3 (-hs) hs  0
+                 <+> wall tCeiling <*> vector3 (-hs) hs size
+                 <+> wall tWall `rotateZ` 90 `rotateY` 90 <*> vector3 hs (-hs) size
+                 <+> wall tWall `rotateZ` 90 `rotateY` 90 <*> vector3 (-hs) (-hs) size 
+                 <+> wall tWall `rotateX` 90 <*> vector3 (-hs) hs size  )
+
+
+
+
+room :: OSGT Identity SceneNode
+room = room' "oldbrk_01" "oldstone2" "oldstone2grooved" 40
+
+calculator :: Scene
+calculator = osgt $ (calcButton "1"
+           <+> calcButton "2" <*> vector3 1 0 0
+           <+> calcButton "3" <*> vector3 2 0 0
+           <+> calcButton "4" <*> vector3 0 0 1
+           <+> calcButton "5" <*> vector3 1 0 1
+           <+> calcButton "6" <*> vector3 2 0 1
+           <+> calcButton "7" <*> vector3 0 0 2
+           <+> calcButton "8" <*> vector3 1 0 2
+           <+> calcButton "9" <*> vector3 2 0 2
+           <+> calcButton "0" <*> vector3 0 0 3
+           <+> calcButton "c" <*> vector3 1 0 3
+           <+> calcButton "+" <*> vector3 2 0 3
+           <+> calcButton "=" <*> vector3 3 0 3
+           <+> cube 1 </> vector3 5 1 5 <*> vector3 2 0.3 2 `colour` LightBlue
+           <+> cube 1 </> vector3 5 1 2 <*> vector3 2 0.3 5.5 `colour` Black
+           <+> textBox `label` "txt" `scaleS` 0.3 <*>  vector3 (0.0) (-0.4) 5) `rotateX` (-70) <*> vector3 0 0 8
+           <+> cylinder 4 5 `texture` "oldstone2_bas01" `rotateX` 90 <*> vector3 0 0 5
+           <+> room 
+           <+> light <*> vz 20 
+           <+> camera <*> vector3 0 (-10) 15
+         
+
+
+console = osgt $ button `label` "btn1" <*> vector3 0 0 0
+            <+>  button `label` "btn2" <*> vector3 2 0 0
+            <+>  button `label` "btn3" <*> vector3 4 0 0
+            <+>  button `label` "btn4" <*> vector3 6 0 0
+            <+>  button `label` "btn5" <*> vector3 8 0 0
+            <+>  slider `label` "RdSlider" <*> vector3 1.2 0 (-1.5)
+            <+>  slider `label` "GrSlider" <*> vector3 1.2 0 (-3.0)
+            <+>  slider `label` "BlSlider" <*> vector3 1.2 0 (-4.5)
+            <+>  slider `label` "ItSlider" <*> vector3 5.0 0 (-1.5)
+            <+>  slider `label` "BmSlider" <*> vector3 5.0 0 (-3.0)
+            <+>  slider `label` "XSlider" <*> vector3 5.0 0 (-4.5)
+            <+>  slider `label` "YSlider" `rotateY` 90 <*> vector3 8.0 0 (-3.5)
+            <+> light <*> vz 20 
+            <+> camera <*> vector3 (-4) 0 3
+                  

@@ -0,0 +1,52 @@+{-# LANGUAGE  MultiParamTypeClasses, FunctionalDependencies, 
+    TypeSynonymInstances #-}
+module Graphics.SceneGraph.Matrix where
+
+-- Warning: Because this matrix is going to get passed directly to GL we convert to GL space
+-- here. 
+
+import Graphics.Rendering.OpenGL hiding (Matrix)
+import Graphics.SceneGraph.Vector
+import Data.List
+import Numeric.LinearAlgebra -- (inv, (><),toLists,Matrix,Vector,mul,fromLists,toList,fromList )
+
+type MatrixD = Matrix GLdouble
+
+identityMatrix :: MatrixD
+identityMatrix = fromLists [ [1,0,0,0], [0,1,0,0], [0,0,1,0],[0,0,0,1]]
+
+asMatrix :: VectorD -> MatrixD
+asMatrix vec = let v = toList vec
+               in fromLists [ [1, 0, 0, v!!0],[ 0, 1, 0, v!!2],[ 0, 0, 1 , (-(v!!1))],[ 0, 0, 0, 1] ]
+
+translateM :: VectorD -> MatrixD -> MatrixD 
+translateM v m = (asMatrix v) `multiply` m
+
+
+translatePostM :: VectorD -> MatrixD -> MatrixD 
+translatePostM v m = m `multiply` (asMatrix v)
+
+scaleM :: VectorD -> MatrixD -> MatrixD
+scaleM vec m = let v = toList vec
+             in m `multiply` (fromLists  [ [ v!!0,0,0,0],[ 0, v!!2,0,0],[ 0, 0, (-(v!!1)),0],[ 0, 0, 0, 1] ])
+
+-- | Build rotational transform matrix for rotate of ''theta'' around a vector.
+rotateM' :: ((Element a)) => a -> Vector a -> Matrix a
+rotateM' theta v = fromLists [ [ t*x*x  + c, t*x*y-s*z, t*x*z + s*y, 0],
+                    [ t*x*y+s*z, t*y*y + c, t*y*z - s*x , 0], 
+                    [ t*x*z-s*y, t*y*z + s*x, t*z*z+c, 0],
+                    [0,0,0,1]]
+                  where t = 1 - cos theta
+                        c = cos theta
+                        s = sin theta
+                        [x',y',z'] = toList v
+                        [x,y,z] = [x',z',(-y')]
+           
+rotateM theta v m = (rotateM' theta v) `multiply` m 
+
+rotatePostM theta v m = m `multiply` (rotateM' theta v)
+                    
+
+mulV :: MatrixD  -> VectorD -> VectorD 
+mulV m v = head $ toColumns $ m `multiply` (asColumn v)
+

@@ -0,0 +1,30 @@+{-# LANGUAGE  MultiParamTypeClasses, FunctionalDependencies, 
+    TypeSynonymInstances, TypeOperators #-}
+{--
+  At some point I was going to use STM. Rather than change the code back, just use the 
+  primitive mappings to MVar.
+--}
+
+module Graphics.SceneGraph.MySTM where
+
+import Data.IORef
+import Control.Concurrent.MVar
+
+type STM a = IO a
+
+atomically :: MVar Bool -> STM a -> IO a
+atomically sem f = withMVar sem (\_ -> f)
+
+unsafeIOToSTM :: IO a -> STM a
+unsafeIOToSTM = id
+
+type TVar a = IORef a
+
+readTVar :: TVar a -> STM a
+readTVar = readIORef 
+
+writeTVar :: TVar a -> a -> STM ()
+writeTVar = writeIORef
+
+newTVar :: a -> STM (TVar a)
+newTVar = newIORef

@@ -0,0 +1,124 @@+   
+----------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.SceneGraph.Reactive
+-- Copyright   :  (c) Mark Wassell 2008
+-- License     :  LGPL
+-- 
+-- Maintainer  :  mwassell@bigpond.net.au
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- This module provides the ability to 'enliven' a scene with widgets
+-- which act as sources of events and are sinks. For example button widgets
+-- and text string display areas.
+--
+-- runSceneReactive takes a scene and an instance of SGM monad. The latter
+-- would have been built up to provide a series of actions to enliven
+-- the scene. The monad is run prior to passing the scene to the viewport 
+-- engine.
+----------------------------------------------------------------------
+
+module Graphics.SceneGraph.Reactive where
+
+import Data.Reactive
+import Graphics.SceneGraph.Basic
+import Control.Monad.State
+import Control.Concurrent.MVar
+import Graphics.SceneGraph.MySTM
+import Graphics.SceneGraph.SimpleViewport
+import Data.IORef
+import Graphics.Rendering.OpenGL.GL.BasicTypes (GLdouble)
+import Data.Graph.Inductive (Node)
+
+import Graphics.SceneGraph.SimpleViewport (GSRef,GraphicsState(..))
+
+data Widget = Button Scene | Slider Scene | Wheel Scene  | WText Scene
+
+
+{-- 
+   The widget building functions below assume the following structure in the 
+   scene graph for the following widgets:
+   
+        Simple Button:   Handler -> Switch -> Material -> Sphere
+                                           -> Material -> Sphere
+
+        Button -> Group -> Group -> Transform -> Material -> Transform -> Torus
+                                    Transform -> Material -> Cube
+                        -> Transform -> Simple Button
+
+        Slider == Same as button in structure BUT has a different output and the button can slide.
+ 
+        Text = Text 
+--}
+
+-- | This monad allows us to compose widget building actions on the scene.
+type SGM  = StateT (Scene,MVar Bool ,GSRef) IO
+
+
+getNodeByLabel :: String -> SGM Node
+getNodeByLabel lbl = do
+                       ((sg,_),_,_) <- get
+                       return $ getByLabel sg lbl
+
+-- | Turn the supplied node into an button style widget
+-- Int needs to reference a handler
+mkButton :: Int -> SGM (Event Bool)
+mkButton nde = do
+             ((sg,start),sem,ref) <- get
+             let nde' = findHandlerDown sg nde
+             -- lift $ putStrLn $ "handler " ++ show nde'
+             (ev,snk') <- lift $ mkEvent
+             let snk _ = snk' True
+             let (SceneNode ide (Handler (Just (f,_)) dh)) = llab sg nde'
+                 sg' = replaceNode'' sg (SceneNode ide (Handler (Just (f,snk)) dh ))
+             put ((sg',start),sem,ref)
+             return $ ev
+
+-- | Turn the referenced node into a slider style widget
+mkSlider :: Int -> SGM (Event GLdouble)
+mkSlider nde = do
+             ((sg,start),sem,ref) <- get
+             (ev,snk) <- lift $ mkEvent
+             let (SceneNode ide (Handler ch (Just (f,_)))) = llab sg nde
+                 sg' = replaceNode'' sg (SceneNode ide (Handler ch (Just (f,snk)) ))
+             put ((sg',start),sem,ref)
+             return $ ev
+
+
+doText ::  Int  -> MVar Bool -> GSRef ->  Sink String
+doText nde sem ref a = updateNode nde sem ref (Text $ a)
+
+updateNode :: Node -> MVar Bool -> IORef GraphicsState -> SceneData -> IO ()
+updateNode nde sem ref dte = atomically sem $ do 
+                          gs <- readIORef ref
+                          case gsScene gs of
+                                 Just (gr,start) -> do
+                                                let   (SceneNode lab _) = llab gr nde
+                                                      gr' = replaceNode'' gr (SceneNode lab dte)
+                                                writeIORef ref (gs { gsDisplayList=Nothing,gsScene = Just (gr',start)})
+                                                return ()
+                                 _ -> return ()
+
+-- | Turn the referenced node into a text sink widget
+mkText ::  Int -> SGM (Sink String)
+mkText nde = do
+             ((sg,_),sem,ref) <- get
+             let nde' = findTextDown sg nde
+             return $ doText nde' sem ref
+
+
+-- | Run a scene with supplied Event Action builder
+runSceneReactive :: Scene -> SGM (Event Action) -> IO ()
+runSceneReactive scene sr  = do
+           sem <- newMVar True
+           ref <- newTVar newState
+           
+           -- We have pass sem and ref as these are need when the widgets are 
+           -- doing something when we run the scene.
+           (x, (scene',sem,ref)) <- runStateT sr  (scene,sem,ref)
+           modifyIORef ref  (\s -> s { gsScene = Just scene' })
+           forkE x
+
+           setupGUI sem ref
+

@@ -0,0 +1,68 @@+{-+   ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.)+   Copyright (c) Sven Panne 2002-2004 <sven.panne@aedion.de>+   This file is part of HOpenGL and distributed under a BSD-style license+   See the file libraries/GLUT/LICENSE++   This module has been modified to read both color and alpha data necessary for transparent textures in OpenGL.++   Support for reading a file of raw RGB data:+      4 bytes big-endian width+      4 bytes big-endian height+      width * height RGBA byte quadruples (the original module reads width * height RGB byte triples)+-}++module Graphics.SceneGraph.ReadImage ( readImage ) where++import Data.Word ( Word8, Word32 )+import Control.Exception ( bracket )+import Control.Monad ( liftM, when )+import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose )+import System.IO.Error ( mkIOError, eofErrorType )+import Foreign ( Ptr, alloca, mallocBytes, Storable(..) )+import Graphics.UI.GLUT++-- This is probably overkill, but anyway...+newtype Word32BigEndian = Word32BigEndian Word32++word32BigEndianToGLsizei :: Word32BigEndian -> GLsizei+word32BigEndianToGLsizei (Word32BigEndian x) = fromIntegral x++instance Storable Word32BigEndian where+   sizeOf ~(Word32BigEndian x) = sizeOf x+   alignment ~(Word32BigEndian x) = alignment x+   peek ptr = do+      let numBytes = sizeOf (undefined :: Word32BigEndian)+      bytes <- mapM (peekByteOff ptr) [ 0 ..  numBytes - 1 ] :: IO [Word8]+      let value = foldl (\val byte -> val * 256 + fromIntegral byte) 0 bytes+      return $ Word32BigEndian value+   poke = error ""++-- This is the reason for all this stuff above...+readGLsizei :: Handle -> IO GLsizei+readGLsizei handle =+   alloca $ \buf -> do+      hGetBufFully handle buf (sizeOf (undefined :: Word32BigEndian))+      liftM word32BigEndianToGLsizei $ peek buf++-- A handy variant of hGetBuf with additional error checking+hGetBufFully :: Handle -> Ptr a -> Int -> IO ()+hGetBufFully handle ptr numBytes = do+   bytesRead <- hGetBuf handle ptr numBytes+   when (bytesRead /= numBytes) $+      ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing+++-- Closing a file is nice, even when an error occurs during reading.+withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a+withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose++readImage :: FilePath -> IO (Maybe (Size, PixelData a))+readImage filePath =+   withBinaryFile filePath $ \handle -> do+      width <- readGLsizei handle+      height <- readGLsizei handle+      let numBytes = fromIntegral (4 * width * height)  -- changed the 3 to a 4 to make space for our alpha data.+      buf <- mallocBytes numBytes+      hGetBufFully handle buf numBytes+      return $ Just (Size width height, PixelData RGBA UnsignedByte buf)  -- changed the PixelFormat constructor here from RGB to RGBA, to account for our alpha data.

@@ -0,0 +1,248 @@+{-# 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)

@@ -0,0 +1,503 @@+{-# LANGUAGE  MultiParamTypeClasses, FunctionalDependencies, 
+    TypeSynonymInstances, PatternSignatures #-}
+    
+----------------------------------------------------------------------
+-- |
+-- 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 })
+                                          

@@ -0,0 +1,102 @@+{- TGA.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+This module was based on lesson 24 from neon helium productions
+http://nehe.gamedev.net/data/lessons/lesson.asp?lesson=24
+
+The TGA format is a used bitmap image file format. They are
+quite easy to load compared to other formats and have
+good support in image editors. All that has to be done is
+read the header to determine the dimensions and pixel format.
+Then the bytes have to be swapped and can be used by OPenGL.
+
+If you see a texture that is upside down, just open it in your
+editor and flip it vertically. Somtimes the TGA file is stored
+with its pixels upside down.
+
+-}
+
+
+
+module Graphics.SceneGraph.TGA where
+
+import Data.Word ( Word8, Word32 )
+import Control.Exception ( bracket )
+import Control.Monad ( liftM, when )
+import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose )
+import System.IO.Error ( mkIOError, eofErrorType )
+import Foreign ( Ptr, alloca, mallocBytes, Storable(..) )
+import Foreign.Marshal.Array
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+import Graphics.UI.GLUT
+
+
+withBinaryFile' :: FilePath -> (Handle -> IO a) -> IO a
+withBinaryFile' filePath = bracket (openBinaryFile filePath ReadMode) hClose
+
+
+-- reads a *.tga file
+readTga :: FilePath -> IO (Maybe (Size, PixelData Word8))
+readTga filePath =
+   withBinaryFile' filePath $ \handle -> do
+   buf <- mallocBytes 6 :: IO(Ptr Word8)
+   --the first 12 bytes of the header aren't used
+   hGetBuf handle buf 6
+   hGetBuf handle buf 6
+   hGetBuf handle buf 6
+   header <- peekArray 6 buf
+   let w1       = (fromIntegral (header!!1))*256 :: Int
+   let width    = w1 + (fromIntegral (header!!0))
+   let h1       = (fromIntegral (header!!3))*256 :: Int
+   let height   = h1 + (fromIntegral (header!!2))
+   let bitspp   = (fromIntegral (header!!4))
+   let numBytes = (bitspp `div` 8) * width * height
+   --allocate memory for the image
+   image <- mallocBytes numBytes
+   hGetBuf handle image numBytes
+   --define whether the pixels are in RGB or RGBA format.
+   pixelFormat <- getFormat (fromIntegral bitspp)
+   free buf
+   --convert the pixels which are in BGR/BGRA to RGB/RGBA
+   swapBytes' image (bitspp `div` 8) (width * height)
+   print ("loaded "++filePath)
+   return $ Just (Size (fromIntegral width) (fromIntegral height),
+               PixelData pixelFormat UnsignedByte image)
+
+
+-- converts the image from bgr/bgra to rgb/rgba
+-- perhaps the opengl bgra extension could be
+-- used to avoid this
+swapBytes' :: Ptr Word8 -> Int -> Int -> IO()
+swapBytes' image bytespp size =
+   case bytespp of
+      3 -> do mapM_ (swapByteRGB.(plusPtr image).(bytespp*)) [0..(size-1)]
+      4 -> do mapM_ (swapByteRGBA.(plusPtr image).(bytespp*)) [0..(size-1)]
+
+
+-- converts from bgr to rgb
+swapByteRGB :: Ptr Word8 -> IO()
+swapByteRGB ptr = do
+   [b,g,r] <- peekArray 3 ptr
+   pokeArray ptr [r,g,b]
+
+
+-- converts from bgra to rgba
+swapByteRGBA :: Ptr Word8 -> IO()
+swapByteRGBA ptr = do
+   [b,g,r,a] <- peekArray 4 ptr
+   pokeArray ptr [r,g,b,a]
+
+
+-- returns the pixel format given the bits per pixel
+getFormat :: Int ->  IO(PixelFormat)
+getFormat bpp = do
+   case bpp of
+      (32) ->  return RGBA
+      (24) ->  return RGB
+
+
+
+
+
+

@@ -0,0 +1,57 @@+{- Textures.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005
+
+This module is for loading textures
+
+-}
+
+module Graphics.SceneGraph.Textures where
+
+import Graphics.UI.GLUT
+import Graphics.SceneGraph.ReadImage (readImage)
+import Monad (when)
+import Graphics.SceneGraph.TGA
+import Data.Word
+import Foreign.Marshal.Alloc
+
+
+-- read a list of images and returns a list of textures
+-- all images are assumed to be in the TGA image format
+getAndCreateTextures :: [String] -> IO [Maybe TextureObject]
+getAndCreateTextures fileNames = do
+   fileNamesExts <- return (map (++".tga") fileNames)
+   texData <- mapM readImageC fileNamesExts
+   texObjs <- mapM createTexture texData
+   return texObjs
+
+
+-- read a single texture
+getAndCreateTexture :: String -> IO (Maybe TextureObject)
+getAndCreateTexture fileName = do
+   texData <- readImageC (fileName++".tga")
+   texObj <- createTexture texData
+   return texObj
+
+
+-- read the image data
+readImageC :: String -> IO (Maybe (Size, PixelData Word8))
+readImageC path = catch (readTga path) (\err -> do
+   print ("missing texture: "++path)
+   return Nothing)
+
+
+-- creates the texture
+createTexture :: (Maybe (Size, PixelData a)) -> IO (Maybe TextureObject)
+createTexture (Just ((Size x y), pixels@(PixelData t1 t2 ptr))) = do
+   [texName] <- genObjectNames 1  -- generate our texture.
+   --rowAlignment  Unpack $= 1
+   textureBinding Texture2D $= Just texName  -- make our new texture the current texture.
+   --generateMipmap Texture2D $= Enabled
+   build2DMipmaps Texture2D RGBA' (fromIntegral x) (fromIntegral y) pixels
+   textureFilter  Texture2D $= ((Linear', Just Nearest), Linear')
+   --textureWrapMode Texture2D S $= (Repeated, Repeat)
+   --textureWrapMode Texture2D T $= (Repeated, Repeat)
+   textureFunction $= Modulate
+   free ptr
+   return (Just texName)
+createTexture Nothing = return Nothing
+

@@ -0,0 +1,5 @@+module Graphics.SceneGraph.Utils where
+
+
+head' s [] = error s
+head' s (x:_) = x

@@ -0,0 +1,46 @@+module Graphics.SceneGraph.Vector where
+
+
+import Graphics.Rendering.OpenGL
+
+import Numeric.LinearAlgebra (Vector,fromList)
+import Foreign.Storable
+
+type VectorD = Vector GLdouble
+
+betweenV3 :: (Storable a,Num a)  => Vertex3 a -> Vertex3 a -> Vector a
+betweenV3 (Vertex3 x y z) (Vertex3 x' y' z') = vector3 (x'-x) (y'-y) (z'-z)
+
+lengthV3 :: Floating a => Vector3 a -> a
+lengthV3 (Vector3 x y z) = sqrt (x*x + y*y + z*z)
+
+vector3X (Vector3 x _ _) = x
+vector3Y (Vector3 _ y _) = y
+vector3Z (Vector3 _ _ z) = z
+
+vector3 :: (Storable a,Num a) => a -> a -> a -> Vector a
+vector3 x y z = fromList [x,y,z]
+
+
+vx,vy :: (Storable a,Num a) => a -> Vector a 
+vx x = vector3 x 0 0 
+vy y = vector3 0 y 0
+
+vxy,vxz :: (Storable a,Num a) => a -> a -> Vector a
+vxy x y = vector3 x y 0
+vxz x z = vector3 x 0 z
+
+
+vz,v1z,v1y,v1x :: (Storable a,Num a) => a -> Vector a 
+vz    = vector3 0 0 
+v1z   = vector3 1 1
+v1y y = vector3 1 y 1
+v1x x = vector3 x 1 1
+
+v0,v1 :: VectorD
+v0 = vector3 0 0 0
+v1 = vector3  1 1 1
+
+
+vyz :: (Storable a,Num a) => a -> a  -> Vector a 
+vyz = vector3 0

@@ -0,0 +1,173 @@+{-
+******************************************************************************
+*                                  A F R P                                   *
+*                                                                            *
+*       Module:		AFRPVectorSpace					     *
+*       Purpose:	Vector space type relation and basic instances.	     *
+*	Authors:	Henrik Nilsson and Antony Courtney		     *
+*                                                                            *
+*             Copyright (c) Yale University, 2003                            *
+*                                                                            *
+******************************************************************************
+-}
+
+module Vinci.VectorSpace where
+
+import Graphics.Rendering.OpenGL (Vector3 (..), Vertex3 (..) )
+
+------------------------------------------------------------------------------
+-- Vector space type relation
+------------------------------------------------------------------------------
+
+infixr *^
+infixl ^/
+infix 7 `dot`
+infixl 6 ^+^, ^-^
+
+-- Maybe norm and normalize should not be class methods, in which case
+-- the constraint on the coefficient space (a) should (or, at least, could)
+-- be Fractional (roughly a Field) rather than Floating.
+
+-- Minimal instance: zeroVector, (*^), (^+^), dot
+class Floating a => VectorSpace v a | v -> a where
+    zeroVector   :: v
+    (*^)         :: a -> v -> v
+    (^/)         :: v -> a -> v
+    negateVector :: v -> v
+    (^+^)        :: v -> v -> v
+    (^-^)        :: v -> v -> v
+    dot          :: v -> v -> a
+    norm	 :: v -> a
+    normalize	 :: v -> v
+
+    v ^/ a = (1/a) *^ v
+
+    negateVector v = (-1) *^ v
+
+    v1 ^-^ v2 = v1 ^+^ negateVector v2
+
+    norm v = sqrt (v `dot` v)
+
+    normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector"
+        where
+	    nv = norm v
+
+------------------------------------------------------------------------------
+-- Vector space instances for Float and Double
+------------------------------------------------------------------------------
+
+instance VectorSpace Float Float where
+    zeroVector = 0
+
+    a *^ x = a * x
+
+    x ^/ a = x / a
+
+    negateVector x = (-x)
+
+    x1 ^+^ x2 = x1 + x2
+
+    x1 ^-^ x2 = x1 - x2
+
+    x1 `dot` x2 = x1 * x2
+
+
+instance VectorSpace Double Double where
+    zeroVector = 0
+
+    a *^ x = a * x
+
+    x ^/ a = x / a
+
+    negateVector x = (-x)
+
+    x1 ^+^ x2 = x1 + x2
+
+    x1 ^-^ x2 = x1 - x2
+
+    x1 `dot` x2 = x1 * x2
+
+
+------------------------------------------------------------------------------
+-- Vector space instances for small tuples of Floating
+------------------------------------------------------------------------------
+
+instance Floating a => VectorSpace (a,a) a where
+    zeroVector = (0,0)
+
+    a *^ (x,y) = (a * x, a * y)
+
+    (x,y) ^/ a = (x / a, y / a)
+
+    negateVector (x,y) = (-x, -y)
+
+    (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2)
+
+    (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2)
+
+    (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2
+
+
+instance Floating a => VectorSpace (a,a,a) a where
+    zeroVector = (0,0,0)
+
+    a *^ (x,y,z) = (a * x, a * y, a * z)
+
+    (x,y,z) ^/ a = (x / a, y / a, z / a)
+
+    negateVector (x,y,z) = (-x, -y, -z)
+
+    (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2)
+
+    (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2)
+
+    (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2
+
+
+instance Floating a => VectorSpace (a,a,a,a) a where
+    zeroVector = (0,0,0,0)
+
+    a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u)
+
+    (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a)
+
+    negateVector (x,y,z,u) = (-x, -y, -z, -u)
+
+    (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2)
+
+    (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2)
+
+    (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2
+
+
+instance Floating a => VectorSpace (a,a,a,a,a) a where
+    zeroVector = (0,0,0,0,0)
+
+    a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v)
+
+    (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a)
+
+    negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v)
+
+    (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2)
+
+    (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2)
+
+    (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) =
+        x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2
+
+
+
+instance Floating a => VectorSpace (Vector3 a) a where
+   zeroVector = Vector3 0 0 0
+   a *^ (Vector3 x y z) = Vector3 (a*x)  (a*y) (a*z)
+   (Vector3 x y z) ^/ a = Vector3 (x/a) (y/a) (z/a)
+
+   negateVector (Vector3 x y z) = Vector3 (-x) (-y) (-z)
+
+   (Vector3 x1 y1 z1) ^+^ (Vector3 x2 y2 z2) = Vector3 (x1+x2) (y1+y2) (z1+z2)
+   (Vector3 x1 y1 z1) ^-^ (Vector3 x2 y2 z2) = Vector3 (x1-x2) (y1-y2) (z1-z2)
+   (Vector3 x1 y1 z1) `dot` (Vector3 x2 y2 z2) =  x1 * x2 + y1 * y2 + z1 * z2
+
+
+asVec (Vertex3 x y z) = Vector3 x y z