scenegraph 0.1.0.2 → 0.2.0.0
raw patch · 21 files changed
+1232/−2010 lines, 21 filesdep +QuickCheckdep +data-defaultdep +graphvizdep −GLUTdep −OpenGLdep −arraydep ~basedep ~fglsetup-changednew-uploader
Dependencies added: QuickCheck, data-default, graphviz, hspec, lens, linear, scenegraph, text
Dependencies removed: GLUT, OpenGL, array, containers, haskell98, hmatrix, old-time, process
Dependency ranges changed: base, fgl
Files
- LICENSE +26/−26
- Setup.hs +2/−0
- Setup.lhs +0/−3
- scenegraph.cabal +65/−30
- src/Graphics/SceneGraph.hs +13/−29
- src/Graphics/SceneGraph/Basic.hs +520/−736
- src/Graphics/SceneGraph/BoundingBox.hs +52/−0
- src/Graphics/SceneGraph/Dump.hs +0/−50
- src/Graphics/SceneGraph/GraphViz.hs +0/−26
- src/Graphics/SceneGraph/Library.hs +0/−256
- src/Graphics/SceneGraph/Matrix.hs +56/−0
- src/Graphics/SceneGraph/Render.hs +44/−248
- src/Graphics/SceneGraph/SimpleViewport.hs +0/−503
- src/Graphics/SceneGraph/Textures.hs +0/−57
- src/Graphics/SceneGraph/Types.hs +164/−0
- src/Graphics/SceneGraph/Vector.hs +0/−46
- src/Graphics/SceneGraph/Visualise.hs +95/−0
- test/Graphics/SceneGraph/BasicSpec.hs +44/−0
- test/Graphics/SceneGraph/BoundingBoxSpec.hs +116/−0
- test/Graphics/SceneGraph/VisualiseSpec.hs +34/−0
- test/testsuite.hs +1/−0
LICENSE view
@@ -1,26 +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. +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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
− Setup.lhs
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain
scenegraph.cabal view
@@ -1,30 +1,65 @@-Name: scenegraph -Version: 0.1.0.2 -Copyright: Mark Wassell 2009 -License: BSD3 -license-file: LICENSE -Author: Mark Wassell <mwassell@bigpond.net.au> -Maintainer: none -Stability: experimental -Homepage: http://www.haskell.org/haskellwiki/SceneGraph -Category: Graphics -Build-Depends: base>=3 && < 5,mtl,hmatrix,OpenGL>=2.2,GLUT>=2.1,haskell98,containers,fgl == 5.4.2.2,array,old-time,process -build-type: Simple -tested-with: GHC==6.10.1 -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 - - - +name: scenegraph+version: 0.2.0.0+cabal-version: >= 1.10+build-type: Simple+author: Mark Wassell <mwassell@bigpond.net.au>+license: BSD3+license-file: LICENSE+copyright: Mark Wassell 2009+category: Graphics+stability: Experimental+homepage: https://github.com/homectl/workspace+synopsis: Scene Graph+description:+ Scene Graph Library.+maintainer: Pippijn van Steenhoven++source-repository head+ type: git+ location: https://github.com/homectl/workspace+ subdir: scenegraph++library+ default-language: Haskell2010+ hs-source-dirs: src+ exposed-modules:+ Graphics.SceneGraph.Basic+ Graphics.SceneGraph.BoundingBox+ Graphics.SceneGraph.Matrix+ Graphics.SceneGraph.Render+ Graphics.SceneGraph.Types+ Graphics.SceneGraph.Visualise+ Graphics.SceneGraph+ build-depends:+ base+ , data-default+ , graphviz+ , fgl+ , lens+ , linear+ , mtl+ , text+ ghc-options:+ -Wall++test-suite testsuite+ default-language: Haskell2010+ hs-source-dirs: test+ type: exitcode-stdio-1.0+ main-is: testsuite.hs+ other-modules:+ Graphics.SceneGraph.BasicSpec+ Graphics.SceneGraph.BoundingBoxSpec+ Graphics.SceneGraph.VisualiseSpec+ ghc-options:+ -Wall+ -threaded+ build-tool-depends:+ hspec-discover:hspec-discover+ build-depends:+ base < 5+ , scenegraph+ , QuickCheck+ , hspec+ , lens+ , linear
src/Graphics/SceneGraph.hs view
@@ -1,29 +1,13 @@--- 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+module Graphics.SceneGraph+ ( module Graphics.SceneGraph.Basic+ , module Graphics.SceneGraph.BoundingBox+ , module Graphics.SceneGraph.Render+ , module Graphics.SceneGraph.Types+ , module Graphics.SceneGraph.Visualise+ ) where++import Graphics.SceneGraph.Basic+import Graphics.SceneGraph.BoundingBox+import Graphics.SceneGraph.Render+import Graphics.SceneGraph.Types+import Graphics.SceneGraph.Visualise
src/Graphics/SceneGraph/Basic.hs view
@@ -1,736 +1,520 @@-{-# 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,filter,zip) -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) - - - - - - +module Graphics.SceneGraph.Basic where++import Control.Lens ((^.))+import Control.Monad.Identity (Identity)+import Control.Monad.State (lift)+import qualified Control.Monad.State as ST+import Data.Default (Default (..))+import Data.Graph.Inductive (Node, (&))+import qualified Data.Graph.Inductive as G+import qualified Data.Text as T+import Graphics.SceneGraph.Matrix (rotateM, rotatePostM, scaleM,+ translateM, translatePostM)+import Graphics.SceneGraph.Types (ClickHandler, Color, DragHandler,+ KeyState (Down), Phong, Scene (..),+ SceneData (..), SceneEdge (..),+ SceneGraph, SceneNode (..),+ colorToPhong, llab, nullNode)+import Linear (M44, R1 (..), R3 (..), V3 (..),+ (!*!))+import qualified Linear as L+++-- | Holds state of graph as it is built.+data OSGState g = OSGState+ { graph :: SceneGraph g+ , context :: [SceneNode g]+ , startNode :: Int+ , root :: Int+ }+ deriving (Eq, Show)++instance Default (OSGState g) where+ def = OSGState emptyOSG [] 0 0++emptyState :: OSGState g+emptyState = def++-- | The OSG monad within which construction of scene graphs occur.+-- was 'type OSGT m = ErrorT Throwable (ST.StateT OSGState m)'+type OSGT m g = ST.StateT (OSGState g) m+type OSGSceneT m g = OSGT m g (SceneNode g)++type OSG g = OSGT Identity g++-- | Create and run a OSG monad to return a scene graph and root node.+runOSG :: Monad m => OSGState g -> OSGSceneT m g -> m (SceneNode g, OSGState g, Node)+runOSG state f = do+ (ret, state') <- ST.runStateT f state+ return (ret, state', root state')+++runOSGShow :: OSGSceneT IO g -> IO ()+runOSGShow f = do+ (ret, state, i) <- runOSG emptyState f+ print (ret, state, i)+++-- | Wrapper for running the OSG monad to return a scene graph and root node.+osg :: Monad m => OSGSceneT m g -> m (Scene g)+osg f = do+ (n, state, _) <- runOSG emptyState f+ return $ Scene (graph state) (idd n)+++idd :: SceneNode g -> Node+idd (SceneNode i _ _) = i+++-- | Basic add node+addNodeBasic :: Monad m => SceneNode g -> OSGSceneT m g+addNodeBasic nde = addNode nde []++-- | Add node with scene data+addBasicNode :: Monad m => SceneData g -> OSGSceneT m g+addBasicNode g = addNode (SceneNode 0 "" g) []++-- | Add node with scene data+addBasicNamedNode :: Monad m => String -> SceneData g -> OSGSceneT m g+addBasicNamedNode name g = addNode (SceneNode 0 name g) []++-- | Add empty node+addNullNode :: Monad m => OSGSceneT m g+addNullNode = addNodeBasic $ nullNode 0++-- | Add a node to a scene graph with supplied children+addNode :: Monad m => SceneNode g -> [(SceneEdge, Node)] -> OSGSceneT m g+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 g -> SceneNode g -> [(SceneEdge, Node)] -> (SceneNode g, OSGState g)+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) & graph s+ s' = s { graph = g', startNode = n, root = n }+ in (sn, s')++-- | Replace a Scene Node+replaceNode :: Monad m => SceneNode g -> OSGSceneT m g+replaceNode n = do+ s <- ST.get+ g' <- lift $ replaceNode' (graph s) n+ ST.put s{ graph = g' }+ return n++-- | Inner monad version of replace node+replaceNode' :: Monad md => SceneGraph g -> SceneNode g -> md (SceneGraph g)+replaceNode' gr nn = return $ replaceNode'' gr nn++-- | Actually does the job of replacing node in a scene graph+replaceNode'' :: SceneGraph g -> SceneNode g -> SceneGraph g+replaceNode'' gr nn =+ let (m, gr') = G.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 g -> OSGSceneT m g -> OSGT m g (SceneNode g, OSGState g, Node)+runOSGL s n = lift $ runOSG s n++-- | Run the monad but keep it in the family.+runOSGL' :: Monad m => OSGSceneT m g -> OSGT m g (SceneNode g, 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 => OSGSceneT m g -> (SceneNode g -> SceneNode g) -> OSGSceneT m g+doOnNode n f = do+ s <- ST.get+ (anode, s', _) <- runOSGL s n+ ST.put s'+ replaceNode (f anode)++-- | Create a light+light :: Monad m => OSGSceneT m g+light = addBasicNode Light++-- | Create a camera+camera :: Monad m => OSGSceneT m g+camera = addBasicNode Camera++-- | Create a camera+mesh :: Monad m => T.Text -> g -> OSGSceneT m g+mesh name geom = addBasicNode $ Geode name geom+++fi :: (Integral a, Integral b) => a -> b+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 -> OSGSceneT m g+-- 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 -> OSGSceneT m g+-- plane w = addBasicNode (Geode $ Mesh1 a b c) where (a,b,c) = planeq' w++-- planeQ :: Monad m => Int -> OSGSceneT m g+-- planeQ = plane+++-- -- | Create a node containing a torus.+-- torus :: Monad m => Float -> OSGSceneT m g+-- torus i = addBasicNode (Geode $ GLObj $ GL.Torus (realToFrac i) (realToFrac (r*2)) 50 50)++-- -- | Create a node containing a sphere+-- sphere :: Monad m => Float -> OSGSceneT m g+-- sphere r = addBasicNode (Geode $ GLObj $ GL.Sphere' (realToFrac r) 50 50)++-- -- | Create a node containing a tetrahedron+-- tetra :: Monad m => OSGSceneT m g+-- tetra = addBasicNode (Geode $ GLObj $ GL.Tetrahedron)++-- -- | Create a node containing a line+-- line :: Monad m => VectorD -> VectorD -> OSGSceneT m g+-- 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 -> OSGSceneT m g+-- 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 -> OSGSceneT m g+-- 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 => Float -> OSGSceneT m g -> OSGSceneT m g+scaleS f = scale (pure f)++-- | Scale a node+scale :: Monad m => V3 Float -> OSGSceneT m g -> OSGSceneT m g+scale v = transformSG (scaleM v) (scale v)++-- | Translate a node+translate :: Monad m => V3 Float -> OSGSceneT m g -> OSGSceneT m g+translate v = transformSG (translateM v) (translate v)++-- | Rotate a node by an angle around a vector.+rotate :: Monad m => (Float, V3 Float) -> OSGSceneT m g -> OSGSceneT m g+rotate a@(theta, v) = transformSG (rotateM theta v) (rotate a)++rad :: Float -> Float+rad x = x * pi / 180++-- | Rotate a node around X axis+rotateX :: Monad m => Float -> OSGSceneT m g -> OSGSceneT m g+rotateX theta = rotate (rad theta, V3 1 0 0 )++-- | Rotate a node around Y axis+rotateY :: Monad m => Float -> OSGSceneT m g -> OSGSceneT m g+rotateY theta = rotate (rad theta, V3 0 1 0)++-- | Rotate a node around Z axis+rotateZ :: Monad m => Float -> OSGSceneT m g -> OSGSceneT m g+rotateZ theta = rotate (rad theta, V3 0 0 1)++-- | Apply colour to the node+colourSG :: Monad m => OSGSceneT m g -> (Phong -> Phong) -> (OSGSceneT m g -> OSGSceneT m g) -> OSGSceneT m g+colourSG sn action self = do+ (n1, i) <- runOSGL' sn+ case n1 of+ SceneNode n lbl (Material p) -> do+ let p' = action p+ replaceNode (SceneNode n lbl (Material p'))+ _ -> do+ let n'' = addNode (SceneNode 0 "" (Material def)) [(DefaultEdge, i)]+ self n''++-- | Transform the node of a scene graph within the Monad with the supplied matrix transform+transformSG :: Monad m => (M44 Float -> M44 Float) -> (OSGSceneT m g -> OSGSceneT m g) -> OSGSceneT m g -> OSGSceneT m g+transformSG action self n = do+ (n1, i) <- runOSGL' n+ case n1 of+ SceneNode num lbl (MatrixTransform m) -> do+ let m' = action m+ replaceNode (SceneNode num lbl (MatrixTransform m'))+ _ -> do+ let n'' = addNode (SceneNode 0 "" (MatrixTransform L.identity)) [(DefaultEdge, i)]+ self n''++-- | Transform the node of a scene graph with the supplied matrix transform+transformSG' :: SceneGraph g -> Node -> (M44 Float -> M44 Float) -> SceneGraph g+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 g -> Node -> V3 Float -> SceneGraph g+translateSG' sg nde v = transformSG' sg nde (translateM v)++translatePostSG' :: SceneGraph g -> Node -> V3 Float -> SceneGraph g+translatePostSG' sg nde v = transformSG' sg nde (translatePostM v)++rotatePostSG' :: SceneGraph g -> Node -> V3 Float -> Float -> SceneGraph g+rotatePostSG' sg nde v theta = transformSG' sg nde (rotatePostM theta v)++-- | Add color to a node+color :: Monad m => Color -> OSGSceneT m g -> OSGSceneT m g+color c n = colourSG n (const $ colorToPhong c) (color c)++-- | Label a node+label :: Monad m => OSGSceneT m g -> String -> OSGSceneT m g+label anode lbl = do+ (SceneNode nde _ dte, _) <- runOSGL' anode+ replaceNode (SceneNode nde lbl dte)+++-- | Add texture+texture :: Monad m => OSGSceneT m g -> String -> OSGSceneT m g+texture n texName = do+ i <- snd <$> runOSGL' n+ addNode (SceneNode 0 "" (Texture texName)) [(DefaultEdge, i)]++-- -- | Add Text+text :: Monad m => T.Text -> OSGSceneT m g+text str = addBasicNode (Text str)++++infixr 5 <+>+infixl 9 <->+infixl 9 </>+++-- | Join two graphs together+(<+>) :: Monad m => OSGSceneT m g -> OSGSceneT m g -> OSGSceneT m g+(<+>) a b = do+ s <- ST.get+ (_, s', i) <- runOSGL s a+ (_, s'', j) <- runOSGL s' b+ ST.put s''+ addNode (SceneNode 0 "" Group) [(DefaultEdge, i), (DefaultEdge, j)]+++-- | Translate a node+(<->) :: Monad m => OSGSceneT m g -> V3 Float -> OSGSceneT m g+(<->) = flip translate++-- | Scale a node+(</>) :: Monad m => OSGSceneT m g -> V3 Float -> OSGSceneT m g+(</>) = flip scale+++doNothing :: Monad m => p -> m ()+doNothing _ = return ()++-- | Add an handler node+handler :: Monad m => OSGSceneT m g -> ClickHandler g -> OSGSceneT m g+handler n f = do+ (_, i) <- runOSGL' n+ addNode (SceneNode 0 "" (Handler (Just (f, doNothing)) Nothing)) [(DefaultEdge, i)]++handler2 :: Monad m => OSGSceneT m g -> (ClickHandler g, DragHandler g) -> OSGSceneT m g+handler2 n (f,g) = do+ (_, i) <- runOSGL' n+ addNode (SceneNode 0 "" (Handler (Just (f, doNothing)) (Just (g, doNothing)))) [(DefaultEdge, i)]++-- | Create a DragHandler+dragHandler :: DragHandler g+dragHandler (Scene sg nde) vec = do+ let tnde = head $ G.pre sg nde+ sg' = translateSG' sg tnde vec+ SceneNode _ _ (MatrixTransform m) = llab sg' tnde+ posx = m^.(_x._z)+ return (if abs posx < 1 then sg' else sg,posx)++-- | Create a ClickHandler+switchHandler :: ClickHandler g+switchHandler (Scene sg nde) ev = do+ let sn = head $ G.suc sg nde+ sn' = llab sg sn+ let sg' = switchNode sn' (if ev == Down then 1 else 0) sg+ return sg'++switchNode' :: Node -> Int -> SceneGraph g -> SceneGraph g+switchNode' nde n gr = replaceNode'' gr (SceneNode nde (show nde) (Switch n))+++switchNode :: SceneNode g -> Int -> SceneGraph g -> SceneGraph g+switchNode (SceneNode nde lbl (Switch _)) n gr =+ replaceNode'' gr newNode+ where newNode = SceneNode nde lbl (Switch n)+switchNode _ _ _ = error "no Switch"++-- | Create a switch node+switch :: Monad m => OSGSceneT m g -> OSGSceneT m g -> OSGSceneT m g+switch = switch' 0+++switch':: Monad m => Int -> OSGSceneT m g -> OSGSceneT m g -> OSGSceneT m g+switch' nde a b = do+ s <- ST.get+ (_, s', i) <- runOSGL s a+ (_, s'', j) <- runOSGL s' b+ ST.put s''+ addNode (SceneNode nde (show nde) (Switch 0)) [(DefaultEdge, i), (DefaultEdge, j)]+++-- -- | Get a strip mesh+-- strip :: Monad m => OSGSceneT m g+-- 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+group :: Monad m => [SceneNode g] -> OSGSceneT m g+group [] = error "empty"+group [n] = addNode n []+group (n:ns) =+ let n' = group ns in+ addNode n [] <+> n'++emptyScene :: Scene g+emptyScene = Scene G.empty 0+++getHitAction :: Scene g -> (Int -> IO ())+getHitAction = const $ const $ return ()++-- | Work up the tree from indicated no to find the first handler scene node.+findHandler :: SceneGraph g -> Int -> Maybe (SceneNode g)+findHandler gr num =+ let start = fromEnum num+ findUp num' =+ case llab gr num' of+ SceneNode n _ (Handler _ _) -> [llab gr n]+ _ -> concatMap findUp (G.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 g -> Int -> Int+findHandlerDown gr num =+ let findDown num' =+ case llab gr num' of+ SceneNode n _ (Handler _ _) -> [n]+ _ -> concatMap findDown (G.suc gr num')+ in+ case findDown num of+ [] -> error "findHandlerDown failed"+ (a:_) -> a+++findTextDown :: SceneGraph g -> Int -> Int+findTextDown gr num =+ let findDown num' =+ case llab gr num' of+ SceneNode n _ (Text _ ) -> [n]+ _ -> concatMap findDown (G.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 g -> Int -> KeyState -> IO (Scene g, Maybe (Scene g), Maybe (SceneGraph g -> SceneGraph g))+handleClickEvent (Scene gr start) n ks = do+ -- putStrLn $ "handle event" ++ show ks+ case findHandler gr n of+ Just (SceneNode nid _ (Handler (Just (fn, snk)) _ )) -> do+ sg <- fn (Scene gr nid) ks+ case ks of+ Down -> snk ()+ _ -> return ()+ return (Scene sg start, Just (Scene sg nid), Nothing)+ _ -> return (Scene gr start, Nothing, Nothing)++emptyOSG :: SceneGraph g+emptyOSG = G.empty++findCamera :: Scene g -> Int -> Node+findCamera (Scene gr _) _ = head . filter (\x ->+ case llab gr x of+ SceneNode _ _ Camera -> True+ _ -> False) . G.nodes $ gr++findCameraPath :: Scene g -> Int -> G.Path+findCameraPath (Scene gr nde) i =+ let nde2 = findCamera (Scene gr nde) i in+ G.esp nde nde2 gr+++-- | Return the matrix got by traversing down the Node+getTransformTo :: Scene g -> Node -> M44 Float+getTransformTo (Scene gr start) nde =+ foldr trans L.identity $ G.esp start nde gr+ where+ trans n mat1 =+ case llab gr n of+ SceneNode _ _ (MatrixTransform mat2) -> mat1 !*! mat2+ _ -> mat1+++getByLabel :: SceneGraph g -> String -> Node+getByLabel gr lbl =+ head+ . filter (\n -> let (SceneNode _ lbl' _) = llab gr n in lbl == lbl')+ . G.nodes+ $ gr
+ src/Graphics/SceneGraph/BoundingBox.hs view
@@ -0,0 +1,52 @@+module Graphics.SceneGraph.BoundingBox where++import Control.Applicative (liftA2)+import Control.Lens ((^.))+import Data.Graph.Inductive (Node)+import qualified Data.Graph.Inductive as G+import Data.Maybe (fromMaybe)+import Graphics.SceneGraph.Types+import Linear (R3 (..), V3 (..), (!*))+import qualified Linear as L+++-- | A box. Used for calculating bounds+type Box a = (V3 a, V3 a)++-- | Return the diagonal vector across the box corners.+boxSize :: Box Float -> V3 Float+boxSize (a, b) = b - a++-- | Bounds suitable for starting off with+smallBox :: Box Float+smallBox = (V3 (-0.1) (-0.1) (-0.1), V3 0.1 0.1 0.1)++-- | Create union of two boxes+union :: Box Float -> Box Float -> Box Float+union (v1,v2) (w1,w2) = (liftA2 min v1 w1, liftA2 max v2 w2)++bounds :: Scene g -> Box Float+bounds (Scene gr nde) =+ let sn = llab gr nde in+ boundsSceneNode gr sn++-- | Determine bounds of a @SceneNode@+boundsSceneNode :: SceneGraph g -> SceneNode g -> Box Float+boundsSceneNode gr (SceneNode nde _ (MatrixTransform mt)) =+ let (v1, v2) = boundsOfChildren gr nde in+ ((mt !* L.point v1) ^. _xyz, (mt !* L.point v2) ^. _xyz)++boundsSceneNode gr (SceneNode nde _ (Switch i)) =+ let nde' = G.suc gr nde !! i in+ bounds (Scene gr nde')++boundsSceneNode _ (SceneNode _ _ (Geode _ _)) = smallBox++boundsSceneNode gr (SceneNode nde _ _) = boundsOfChildren gr nde++boundsOfChildren :: SceneGraph g -> Node -> Box Float+boundsOfChildren gr =+ fromMaybe smallBox . foldr f Nothing . G.suc gr+ where+ f nde Nothing = Just $ bounds (Scene gr nde)+ f nde (Just b) = Just $ b `union` bounds (Scene gr nde)
− src/Graphics/SceneGraph/Dump.hs
@@ -1,50 +0,0 @@-{-- - 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"
− src/Graphics/SceneGraph/GraphViz.hs
@@ -1,26 +0,0 @@-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
− src/Graphics/SceneGraph/Library.hs
@@ -1,256 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, - TypeSynonymInstances, ScopedTypeVariables #-} - ----------------------------------------------------------------------- --- | --- 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 -
+ src/Graphics/SceneGraph/Matrix.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Graphics.SceneGraph.Matrix+ ( translateM+ , translatePostM+ , scaleM+ , rotateM+ , rotatePostM+ ) where++-- Warning: Because this matrix is going to get passed directly to GL we convert to GL space+-- here.++import Control.Lens ((^.))+import Linear (M44, R1 (..), R2 (..), R3 (..), V3 (..), V4 (..),+ (!*!))+++asMatrix :: V3 Float -> M44 Float+asMatrix (V3 x y z) = V4+ (V4 1 0 0 x)+ (V4 0 1 0 y)+ (V4 0 0 1 z)+ (V4 0 0 0 1)++translateM :: V3 Float -> M44 Float -> M44 Float+translateM v m = asMatrix v !*! m++translatePostM :: V3 Float -> M44 Float -> M44 Float+translatePostM v m = m !*! asMatrix v++scaleM :: V3 Float -> M44 Float -> M44 Float+scaleM v m = m !*! V4+ (V4 (v^._x) 0 0 0)+ (V4 0 (v^._y) 0 0)+ (V4 0 0 (v^._z) 0)+ (V4 0 0 0 1)++-- | Build rotational transform matrix for rotate of ''theta'' around a vector.+rotateM' :: Float -> V3 Float -> M44 Float+rotateM' theta (V3 x y z) = V4+ (V4 (t*x*x + c) (t*x*y-s*z) (t*x*z + s*y) 0)+ (V4 (t*x*y+s*z) (t*y*y + c) (t*y*z - s*x) 0)+ (V4 (t*x*z-s*y) (t*y*z + s*x) (t*z*z+c) 0)+ (V4 0 0 0 1)+ where+ t = 1 - cos theta+ c = cos theta+ s = sin theta++rotateM :: Float -> V3 Float -> M44 Float -> M44 Float+rotateM theta v m = rotateM' theta v !*! m++rotatePostM :: Float -> V3 Float -> M44 Float -> M44 Float+rotatePostM theta v m = m !*! rotateM' theta v
src/Graphics/SceneGraph/Render.hs view
@@ -1,248 +1,44 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, - TypeSynonymInstances, ScopedTypeVariables #-} - ----------------------------------------------------------------------- --- | --- 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)+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Graphics.SceneGraph.Render where++import qualified Data.Graph.Inductive as G+import Graphics.SceneGraph.Types (Color (White), Phong (..),+ Scene (..), SceneData (..),+ SceneGraph, SceneNode (..),+ colorToPhong, llab)+import Linear (M44, (!*!))+import qualified Linear as L+++-- | Draw a scene graph (or a scenegraph fragment)+drawScene :: Monad m => Scene g -> (M44 Float -> Phong -> g -> m ()) -> m ()+drawScene = drawScene' L.identity (colorToPhong White)++drawScene' :: Monad m => M44 Float -> Phong -> Scene g -> (M44 Float -> Phong -> g -> m ()) -> m ()+drawScene' curMat curPhong (Scene gr n) drawGeode = do+ case llab gr n of+ SceneNode _ _ (MatrixTransform m) -> do+ recurse (m !*! curMat) curPhong+ SceneNode _ _ (Material phong) -> do+ recurse curMat phong+ SceneNode _ _ (Geode _ g) -> do+ drawGeode curMat curPhong g+ recurse curMat curPhong+ _ -> do+ -- TODO: implement+ recurse curMat curPhong++ where+ recurse nextMat nextPhong =+ mapM_ (\next -> drawScene' nextMat nextPhong (Scene gr next) drawGeode) (G.suc gr n)+++mapSceneData :: (SceneData g1 -> SceneData g2) -> SceneGraph g1 -> SceneGraph g2+mapSceneData f =+ G.nmap (\(SceneNode nde lbl sd) -> SceneNode nde lbl (f sd))++foldSceneData :: (SceneData g -> a -> a) -> a -> SceneGraph g -> a+foldSceneData f =+ G.ufold (\(_, _, SceneNode _ _ sd, _) acc -> f sd acc)
− src/Graphics/SceneGraph/SimpleViewport.hs
@@ -1,503 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, - TypeSynonymInstances, ScopedTypeVariables #-} - ----------------------------------------------------------------------- --- | --- Module : Graphics.SceneGraph.SimpleViewport --- Copyright : (c) Mark Wassell 2008 --- License : LGPL --- --- Maintainer : mwassell@bigpond.net.au --- Stability : experimental --- Portability : portable --- --- Provide a view window onto a scenegraph. Handles basic navigation --- and interaction with widgets. ----------------------------------------------------------------------- - -module Graphics.SceneGraph.SimpleViewport - ( - setupGUI,GraphicsState(..),newState,drawCanvas,GSRef,runScene - ) where - - - -import Control.Concurrent -import Control.Concurrent.MVar - -import Data.Graph.Inductive.Graph -import qualified Data.Map as M -import Data.Graph.Inductive.Graph (pre) -import Data.IORef -import Data.List -import qualified Data.Packed.Matrix as PM - -import Graphics.Rendering.OpenGL hiding (Red, Green,Blue,scale,Texture) -import qualified Graphics.Rendering.OpenGL as GL -import Graphics.UI.GLUT hiding (Red, Green,Blue,scale,Texture) -import Graphics.UI.GLUT.Objects -import Graphics.UI.GLUT.Fonts - -import System.Exit ( exitWith, ExitCode(ExitSuccess) ) -import System.Time - -import Numeric.LinearAlgebra -- (inv, (><),toLists, ) - -import Graphics.SceneGraph.MySTM -import Graphics.SceneGraph.Vector -import Graphics.SceneGraph.Basic hiding (scale,translate,rotate) -import Graphics.SceneGraph.Render -import Graphics.SceneGraph.Textures -import qualified Graphics.SceneGraph.Matrix as M - - -initWindowSize = Size 700 700 -perseAngle = 90.0 -clrColor = Color4 0 0 0 1 - -type GSRef = TVar GraphicsState - -type HitSink = GSRef -> GLuint -> KeyState -> STM () - --- Holds state of viewport. Theta is angle around the vertical/y axes; Sigma is the angle around the x-axes -data GraphicsState = GraphicsState { gsR :: GLdouble, - gsSig :: GLdouble, - gsTheta :: GLdouble, - gsMPos::Maybe Position, - gsDisplayList :: Maybe DisplayList, - gsDrawFunc :: Maybe (IO ()), - gsHitSink :: Maybe HitSink, -- Handles hits onto the viewport - gsDrag::Bool, - gsScene :: Maybe Scene, -- The whole thing - gsFocus :: Maybe Scene, -- The portion of the scene that has focus, - -- mouse drag and keyboard events will be sent to this. - gsTexture :: M.Map String TextureObject, - gsDragPos :: Maybe (Vector GLdouble), - gsProjMatrix :: Maybe (GLmatrix GLdouble), - gsBlah :: Maybe (Int -> IO () ), - gsModelMatrix :: Maybe (GLmatrix GLdouble) -- The model matrix up to camera - } - -newState = GraphicsState { gsR = 50, gsSig = 0, gsTheta = 0, - gsMPos=Nothing,gsDrawFunc = Nothing, gsDrag=False, gsDisplayList=Nothing,gsBlah=Nothing, - gsScene = Nothing, gsTexture = M.empty, gsHitSink = Nothing, gsFocus=Nothing,gsProjMatrix = Nothing, - gsModelMatrix=Nothing,gsDragPos=Nothing } - -modifyTVar tvar f = do - x <- readTVar tvar - writeTVar tvar (f x) - - - - --- | Run a scene. Displays the Scene in a basic viewport permitting user interaction. -runScene :: Scene -> IO () -runScene scene = do - sem <- newMVar True - ref <- newTVar newState { gsScene = Just scene } - setupGUI sem ref - -getTextures :: Scene -> IO (M.Map String TextureObject) -getTextures (gs,_) = do - let textureNames = nub $ foldr (\x xs -> case (llab gs x) of - SceneNode _ (Texture s) -> (s:xs) - _ -> xs) [] (nodes gs) - tlist <- getAndCreateTextures $ map (\s -> "data/" ++ s) textureNames - - return $ M.fromList $ zip textureNames $ map (maybe (error "failed to load texture") id) tlist - - --- | Setup GUI and run it. -setupGUI :: MVar Bool -> GSRef -> IO () -setupGUI sem rGS = do - - (progName, _args) <- getArgsAndInitialize - initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] - initialWindowSize $= initWindowSize - initialWindowPosition $= (Position 100 100) - createWindow progName - - lighting $= Enabled - normalize $= Enabled - depthFunc $= Just Less - - matrixMode $= Projection - loadIdentity - perspective perseAngle 1.0 0.1 10000.0 - - (m::GLmatrix Double) <- get $ matrix Nothing - mc <- getMatrixComponents RowMajor m - - matrixMode $= Modelview 0 - loadIdentity - - shadeModel $= Smooth - clearColor $= clrColor - blend $= Enabled - blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - - gs <- readIORef rGS - texMap <- getTextures (maybe (error "no scene") id (gsScene gs)) - - (atomically sem) $ modifyTVar rGS (\gs -> gs { gsHitSink = Just findHitAction , gsProjMatrix = Just m, gsTexture = texMap}) - - displayCallback $= ( (atomically sem) $ drawCanvas rGS) - keyboardMouseCallback $= Just (\a b c d -> (atomically sem) $ handleKeyEvent rGS a b c d) - motionCallback $= Just (\p -> (atomically sem) $ handleDragEvent rGS p ) - passiveMotionCallback $= Just (\p -> (atomically sem) $ handleMotionEvent rGS p ) - mainLoop - -i2d :: GLint -> GLdouble -i2d = fromInteger . toInteger - -i2f :: GLint -> Float -i2f = fromInteger . toInteger - -handleMotionEvent _ _ = return () - -drawCanvasNull _ = return () - -handleDragEvent :: TVar GraphicsState -> Position -> STM () -handleDragEvent rGS pos = do - gs <- readTVar rGS - case (gsFocus gs) of - Just scene | (gsDrag gs) -> handleFocusedDrag rGS pos - Nothing | (gsDrag gs) -> handleTransformDrag rGS pos - _ -> return () - --- To calculate - --- Widget needs to supply a plane (lets start with z = 0 - then we include transform of object in unproject) --- Calculate 2 points on pick line (ie mouse z = 0, mouse z = 1) --- calculate intersection of pick line with the plane to get the point - - - -lineToYPlane p1 p2 = lineToYPlane' (fromVertex p1) (fromVertex p2) - -fromVertex :: Vertex3 GLdouble -> Vector Double -fromVertex (Vertex3 x y z) = fromList [x,z,(-y)] - -toVertex :: Vector Double -> Vertex3 GLdouble -toVertex vec = let [x,y,z] = toList vec - in Vertex3 x y z - -lineToYPlane' :: Vector GLdouble -> Vector GLdouble -> Vector GLdouble -lineToYPlane' p1 p2 = let n = fromList [ 0, 1, 0] - origin = fromList [ 0, 0, 0] - u = (n `dot` ( origin `sub` p1)) / n `dot` (p2 `sub` p1) - in p1 `add` ( u `scale` (p2 `sub` p1)) - -t1 = lineToYPlane (Vertex3 0 1 0) (Vertex3 0 (-1) 0 ) -t2 = lineToYPlane (Vertex3 3 1 0 ) (Vertex3 1 (-1) 0 ) - - - -constrainDrag :: Vector GLdouble -> Vector GLdouble -constrainDrag vec = vec `dot` (fromList [1,0,0]) `scale` (fromList [1,0,0]) - --- Assumes matrix transform is the parent ... -doDrag :: TVar GraphicsState -> Node -> Vector GLdouble -> IO () -doDrag rGS nde vec' = do - let vec = constrainDrag vec' - gs <- readTVar rGS - case (gsScene gs) of - Just (sg,start) -> do - case (llab sg nde) of - (SceneNode _ (Handler _ (Just (dragHandlerF,snk)))) -> do - (sg'',val) <- dragHandlerF (sg,nde) vec - snk val - writeTVar rGS $ gs { gsScene = Just $ (sg'',start) } - _ -> return () - _ -> return () - --- FIXME swap z and y and negate y - - - - -handleFocusedDrag :: TVar GraphicsState -> Position -> STM () -handleFocusedDrag rGS pos@(Position x y) = do - gs <- readTVar rGS - case gsFocus gs of - Just (gr,nde) -> do - vp <- unsafeIOToSTM $ get viewport - --should we move modelmatrix also to the positon of the nde? - let mm = maybe (error "No set") id (gsModelMatrix gs) - let pm = maybe (error "No set") id (gsProjMatrix gs) - pos1 <- unsafeIOToSTM $ unProject (Vertex3 (fromIntegral x) (fromIntegral y) 0) mm pm vp - pos2 <- unsafeIOToSTM $ unProject (Vertex3 (fromIntegral x) (fromIntegral y) 1) mm pm vp - let pos3 = lineToYPlane pos1 pos2 - - case (gsDragPos gs) of - Just lastPos -> do - let vec = pos3 `sub` lastPos - -- putStrLn $ "New pos = " ++ show vec - writeTVar rGS (gs { gsDragPos = Just pos3 }) - doDrag rGS nde vec - drawCanvas rGS - Nothing -> writeTVar rGS (gs { gsDragPos = Just pos3 }) - - return () - Nothing -> return () - - - -handleTransformDrag :: GSRef -> Position -> STM () -handleTransformDrag rGS pos = do - gs <- readTVar rGS - if (gsDrag gs) then rotateBy gs (gsMPos gs) pos else return () - where - rotateBy gs Nothing _ = writeTVar rGS (gs { gsMPos = (Just pos) }) - rotateBy gs (Just (Position x' y')) pos@(Position x y) = do - writeTVar rGS (gs { gsSig = (gsSig gs) - ((i2d (x'-x))/100), - gsTheta = (gsTheta gs) - ((i2d (y'-y))/100), - gsMPos = (Just pos)}) - rotateCamera rGS ((i2d (x'-x))/100) ((i2d (y'-y))/100) - drawCanvas rGS - -bufSize :: GLsizei -bufSize = 512 - -moveFactor = 1 - -resetDrag f x = x { gsMPos = Nothing, gsDrag=f ,gsDragPos=Nothing } - -handleKeyEvent :: GSRef -> Key -> KeyState -> Modifiers -> Position -> STM () -handleKeyEvent _ (Char '\27') _ _ _ = unsafeIOToSTM $ System.Exit.exitWith ExitSuccess - -handleKeyEvent gs (MouseButton btn) dir _ (Position x y) = do - modifyTVar gs (resetDrag (dir == Down)) - case btn of - LeftButton -> pickSceneNode gs dir x y - _ -> return () - - -handleKeyEvent gs (Char 'w') _ _ _= moveCamera gs (vector3 0 moveFactor 0) -handleKeyEvent gs (Char 'a') _ _ _= moveCamera gs (vector3 (-moveFactor) 0 0) -handleKeyEvent gs (Char 's') _ _ _= moveCamera gs (vector3 0 (-moveFactor) 0) -handleKeyEvent gs (Char 'd') _ _ _= moveCamera gs (vector3 moveFactor 0 0) -handleKeyEvent gs (Char 'z') _ _ _= moveCamera gs (vector3 0 0 (-moveFactor)) -handleKeyEvent gs (Char 'x') _ _ _= moveCamera gs (vector3 0 0 moveFactor) - --- FIXME. Doesn' work? --- handleKeyEvent gs (MouseButton WheelDown) _ _ _= moveCamera gs (Vector3 0 0 (-1)) --- handleKeyEvent gs (MouseButton WheelUp) _ _ _= moveCamera gs (Vector3 0 0 1) - -handleKeyEvent gs _ _ _ _ = return () - --- Note: Selection in OpenGL is basically a draw with names and then the system returns the names of --- visible in the viewing volume. The last step in setting up the view is to call pickMatrix to restrict --- the viewing volume to an NxN pixel square centred on the mouse hit. - -pickSceneNode :: GSRef -> KeyState -> GLint -> GLint -> STM () -pickSceneNode gsRef dir x y= do - gs <- readTVar gsRef - (_, maybeHitRecords) <- unsafeIOToSTM $ do - vp@(_, (Size _ height)) <- get viewport - getHitRecords bufSize $ - withName (Name 0) $ do - matrixMode $= Projection - preservingMatrix $ do - loadIdentity - pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp - -- This is the same as at start of code. FIXME - perspective perseAngle 1.0 0.1 10000.0 - drawCanvas'' gs Nothing - processHits gsRef dir maybeHitRecords - -processHits :: GSRef -> KeyState -> Maybe[HitRecord] -> STM () -processHits _ _ Nothing = error "selection buffer overflow" -processHits gs dir (Just ((HitRecord _ _ (Name n:_)):_)) = findHitAction gs n dir >> drawCanvas gs -processHits _ _ _ = return () - -drawCanvas :: GSRef -> STM () -drawCanvas rGS = drawCanvas' rGS Nothing - - -drawCanvas' :: GSRef -> Maybe (IO ()) -> STM () -drawCanvas' rGS pm = do - gs <- readTVar rGS - gs' <- unsafeIOToSTM $ drawCanvas'' gs pm - writeTVar rGS gs' - -drawCanvas'' :: GraphicsState -> Maybe (IO ()) -> IO GraphicsState -drawCanvas'' gs pm = do - clearColor $= clrColor - clear [ColorBuffer,DepthBuffer] - gs' <- setCamera gs - crMat (0.0, 0.7, 0)(0.4, 0.4, 0.4) 5 1.0 - --mapM_ (drawCircle 5 50) [Vertex3 0 0 1,Vertex3 0 1 0,Vertex3 1 0 0 ] - --mapM_ drawLetter [zPts,yPts,xPts] - maybe (return ()) id pm - - gs''<-case (gsDisplayList gs) of - Just dl -> callList dl >> return gs' - Nothing -> do - list <- defineNewList CompileAndExecute $ maybe (return ()) (drawSceneGraph (gsTexture gs)) (gsScene gs) - return $ gs' { gsDisplayList = Just list } - flush - swapBuffers - return gs'' - -cameraChange :: GSRef -> (SceneGraph -> Node -> SceneGraph) -> STM () -cameraChange rGS f = do - st <- readTVar rGS - case (gsScene st) of - Just sc@(sg,start) -> do - let - cam = findCameraPath sc 0 - tnde = (reverse cam) !! 1 - sg' = f sg tnde - st' = st { gsScene = Just $ (sg',start) } - writeTVar rGS st' - drawCanvas rGS - Nothing -> return () - -rotateCamera :: GSRef -> GLdouble -> GLdouble -> STM () -rotateCamera rGS s t = do - cameraChange rGS (\sg tnde -> rotatePostSG' (rotatePostSG' sg tnde (vector3 0.0 0.0 1.0) s) tnde (vector3 1.0 0.0 0.0) t) - - -moveCamera :: GSRef -> VectorD -> STM () -moveCamera rGS vec = do - st <- readTVar rGS - case (gsScene st) of - Just sc@(sg,start) -> do - let - cam = findCameraPath sc 0 - tnde = (reverse cam) !! 1 - sg' = translatePostSG' sg tnde vec - st' = st { gsScene = Just $ (sg',start) } - (SceneNode _ (MatrixTransform tr1)) = llab sg tnde - (SceneNode _ (MatrixTransform tr2)) = llab sg' tnde - writeTVar rGS st' - drawCanvas rGS - Nothing -> return () - - -setCamera :: GraphicsState -> IO GraphicsState -setCamera st = do - matrixMode $= Modelview 0 - loadIdentity - let r = gsR st - maybe (return ()) (applyCameraTransform 1) (gsScene st) - lookAt (Vertex3 0 0 0) (Vertex3 0.0 0 (-r)) (Vector3 0 1.0 0) - (m::GLmatrix Double) <- get $ matrix (Just $ Modelview 0 ) - return $ st { gsModelMatrix = Just m } - - - - --- | Traverse down to the camera for this viewport and apply the transforms along --- the way. -applyCameraTransform :: Int -> Scene -> IO () -applyCameraTransform cnum sc@(gr,start) = do - mapM_ applyTransform $ (map (llab gr) $ findCameraPath sc 0 ) - applyLA inv - - --- | Apply a unary function from HMatrix package to Modelview matrix -applyLA :: (PM.Matrix Double -> PM.Matrix Double) -> IO () -applyLA f = do - (m::GLmatrix Double) <- get $ matrix Nothing - mc <- getMatrixComponents RowMajor m - let mc' = concat $ toLists $ f ((4><4) mc) - (m'::GLmatrix Double) <- newMatrix RowMajor mc' - matrix (Just (Modelview 0)) $= m' - - - - -setCamera' rGS = do - gs <- readTVar rGS - -- Those in the know say that lookAt is done in Modelview. - unsafeIOToSTM $ do - matrixMode $= Modelview 0 - loadIdentity - let (t,s,r) = (gsTheta gs, gsSig gs, gsR gs) - z = l * sin s' - x = l * cos s' - l = (cos s') - s' = s -- or -s ?? - lookAt (Vertex3 0 0 r) (Vertex3 0.0 0 0) (Vector3 0 1.0 0) - rotate (s*180/pi) (Vector3 0 1 0) - rotate (t*180/pi) (Vector3 x 0 z) - -crMat (rd,gd,bd) (rs,gs,bs) exp a = do - materialDiffuse Front $= Color4 rd gd bd a - materialAmbient Front $= Color4 rd gd bd a - materialSpecular Front $= Color4 rs gs bs a - materialShininess Front $= exp - - materialDiffuse Back $= Color4 rd gd bd a - materialSpecular Back $= Color4 rs gs bs a - materialShininess Back $= exp - -drawCircle :: GLdouble-> Int -> Vertex3 GLdouble -> IO () -drawCircle r n a@(Vertex3 x y z) = preservingMatrix $ do - rotate (theta*180/pi) (Vector3 x' y' z') - renderPrimitive LineLoop $ mapM_ mapVertex ls - where mapVertex v = do - normal (Normal3 x y z) - vertex v - ls = [ (Vertex3 (r * cos (vt t)) (r*sin (vt t)) 0) | t <- [0 .. (n-1)] ] - vt t = 2*pi* (fromInteger (toInteger t))/(fromInteger (toInteger n)) - (Vertex3 x' y' z') = a `vCross` (Vertex3 0 0 1) - theta = a `ang` (Vertex3 0 0 1) - -vCross :: Num a => Vertex3 a -> Vertex3 a -> Vertex3 a -vCross (Vertex3 a1 a2 a3) (Vertex3 b1 b2 b3) = Vertex3 (a2*b3 -a3*b2) (a3*b1-a1*b3) (a1*b2-a2*b1) - -vDot :: Num a => Vertex3 a -> Vertex3 a -> a -vDot (Vertex3 a1 a2 a3) (Vertex3 b1 b2 b3) = a1*b1 + a2*b2 + a3*b3 - -vPlus :: Num a => Vertex3 a -> Vertex3 a -> Vertex3 a -vPlus (Vertex3 a1 a2 a3) (Vertex3 b1 b2 b3) = Vertex3 (a1+b1) (a2+b2) (a3+b3) - - -mag :: Vertex3 GLdouble -> GLdouble -mag (Vertex3 a1 a2 a3) = sqrt (a1*a1 + a2*a2 + a3*a3) - -ang :: Vertex3 GLdouble-> Vertex3 GLdouble -> GLdouble -ang v w = acos ((v `vDot` w) / ((mag v) * (mag w))) - - -drawLetter :: ([(GLdouble,GLdouble)],Vector3 GLdouble) -> IO () -drawLetter (pts,t) = preservingMatrix $ do - translate t - GL.scale 0.1 0.1 (0.1::GLdouble) - - renderPrimitive Quads $ mapM_ mapVertex pts - where mapVertex (x,y) = do - normal (Normal3 (0::GLdouble) 0 1) - vertex (Vertex3 x y 0 ) - -xPts = ([ (0,-1), (-4,-5),(-6,-5),(-1,0), - (-1,0),(-6,5),(-4,5),(0,1), - (0,1), (4,5), (6,5), (1,0), - (1,0),(6,-5), (4,-5),(0,-1), - (-1,0),(0,1),(1,0),(0,-1)],Vector3 (5::GLdouble) 0 0) - -zPts = ([ (-5,5), (-5,6), (5,6), (4,5), - (5,6), (6,6), (-5,-6),(-6,-6), - (-5,-6), (6,-6),(6,-5), (-4,-5)],Vector3 0 (5::GLdouble) 0) - -yPts = ([ (5,6), (6,6), (-5,-6),(-6,-6), - (-5,6), (-4,6), (0,0), (-1,-1)],Vector3 0 0 (5::GLdouble)) - --- | Find and perform hit action -findHitAction :: HitSink -findHitAction ref = f where - f 0 _ = return () - f name dir = do - gs <- readTVar ref - let scene@(_,start) = maybe (error "No scene") id (gsScene gs) - - ((gr,_), focused,f) <- unsafeIOToSTM $ handleClickEvent scene name dir - let focus = case dir of - Up -> Nothing - Down -> focused - case f of - Just f' -> writeTVar ref (gs { gsScene = Just $ (f' gr, start), gsFocus = focus }) - Nothing -> writeTVar ref (gs { gsScene = Just $ (gr, start), gsFocus = focus }) -
− src/Graphics/SceneGraph/Textures.hs
@@ -1,57 +0,0 @@-{- 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 -
+ src/Graphics/SceneGraph/Types.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Graphics.SceneGraph.Types where++import Data.Default (Default (..))+import Data.Graph.Inductive (Node, (&))+import qualified Data.Graph.Inductive as G+import qualified Data.Text as T+import Linear (M44, V2 (..), V3 (..), V4 (..))+++-- | Scene Graph based on a Graph+type SceneGraph g = G.Gr (SceneNode g) SceneEdge++-- | Empty edge label for scene graphs.+data SceneEdge = DefaultEdge+ deriving (Eq, Ord)++instance Show SceneEdge where+ show = const "()"++-- | Scene Node. Made up of data and maybe a widget+data SceneNode g = SceneNode+ { nodeId :: Node+ , nodeLabel :: String+ , nodeData :: SceneData g+ }+ deriving (Show)++-- | Creates an empty scene graph+nullNode :: Node -> SceneNode g+nullNode n = SceneNode n (show n) Group++-- | Creates a scene graph containing the supplied node+trivialGr :: SceneNode g -> SceneGraph g+trivialGr n = ([], 1, n, []) & G.empty++-- | Scene Graph with indicate root node+data Scene g = Scene+ { sceneGraph :: SceneGraph g+ , sceneRoot :: Node+ }++-- | View port refers to a camera node and has its own Scene which is drawn flattened+data Viewport g = Viewport+ { viewCamera :: Node+ , viewScene :: Scene g+ }++-- | A scene with a number of view ports looking onto it.+data World g = World+ { worldScene :: Scene g+ , worldViewports :: [Viewport g]+ }++instance Eq (SceneNode g) where+ (SceneNode id1 lbl1 _) == (SceneNode id2 lbl2 _) = id1 == id2 && lbl1 == lbl2++data KeyState+ = Up+ | Down+ deriving (Eq, Show)++type ClickHandler g = Scene g -> KeyState -> IO (SceneGraph g)+type DragHandler g = Scene g -> V3 Float -> IO (SceneGraph g, Float)++instance Show (ClickHandler g) where+ show _ = "<a ClickHandler>"++instance Show (DragHandler g) where+ show _ = "<a DragHandler>"++type Sink a = a -> IO ()++-- | Scene Node Data.+data SceneData g+ = Group+ | Geode T.Text g+ | LOD+ | MatrixTransform (M44 Float)+ | Switch Int+ | Material Phong+ | Handler (Maybe (ClickHandler g, Sink ())) (Maybe (DragHandler g, Sink Float))+ | Light+ | Camera+ | Texture FilePath+ | Text T.Text++instance Show (SceneData g) where+ show Group = "Group"+ show (Geode n _) = "Geode " ++ show n+ 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.unpack t++-- | Geometry. Either a basic GL object or a mesh.+--+data Geometry+ = Mesh2D [V2 Float]+ | Mesh3D [(V3 Float, V3 Float)]+ deriving (Eq, Show)++-- | Simple colors+data Color+ = Grey+ | JustWhite+ | Red+ | Green+ | Blue+ | Black+ | LightBlue+ | White+ | Yellow+ deriving (Show, Eq)++mapColor :: Color -> V4 Float+mapColor Red = V4 1 0 0 1+mapColor Green = V4 0 1 0 1+mapColor Blue = V4 0 0 1 1+mapColor Grey = V4 0.4 0.4 0.4 1+mapColor LightBlue = V4 0.3 0.3 1.0 1+mapColor Black = V4 0 0 0 1+mapColor White = V4 1 1 1 1+mapColor Yellow = V4 1 1 0 1+mapColor JustWhite = V4 0.9 0.9 0.9 1++-- | Phong lighting+data Phong = Phong+ { phEmission :: Maybe (V4 Float)+ , phAmbient :: Maybe (V4 Float)+ , phDiffuse :: Maybe (V4 Float)+ , phSpecular :: Maybe (V4 Float)+ , phShine :: Maybe Float+ , phReflective :: Maybe (V4 Float)+ , phReflectivity :: Maybe Float+ , phTransparent :: Maybe (V4 Float)+ , phTransparency :: Maybe Float+ }+ deriving (Eq, Show)++instance Default Phong where+ def = Phong Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++-- | Convert from simple color to Phong+colorToPhong :: Color -> Phong+colorToPhong c = def+ { phDiffuse = Just $ mapColor c+ , phAmbient = Just $ mapColor c+ , phSpecular = Just $ V4 0.4 0.4 0.4 1.0+ , phShine = Just 5.0+ }+++llab :: SceneGraph g -> Node -> SceneNode g+llab gr n =+ case G.lab gr n of+ Nothing -> error $ "Should not happen gr=" ++ show gr ++ "n = " ++ show n+ Just n' -> n'
− src/Graphics/SceneGraph/Vector.hs
@@ -1,46 +0,0 @@-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
+ src/Graphics/SceneGraph/Visualise.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE RecordWildCards #-}+module Graphics.SceneGraph.Visualise+ ( toDot+ , toSvg+ ) where++import qualified Data.GraphViz as GV+import qualified Data.GraphViz.Attributes.Colors as C+import qualified Data.GraphViz.Attributes.HTML as H+import Data.Maybe (catMaybes)+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Data.Word (Word8)+import Graphics.SceneGraph.Types+import Linear (M44, V4 (..))+++-------------------- Graph Visualisation --------------------++instance GV.Labellable (SceneNode g) where+ toLabelValue (SceneNode _ _ sd) = GV.toLabelValue sd++instance GV.Labellable SceneEdge where+ toLabelValue DefaultEdge = GV.toLabelValue ""++instance GV.Labellable (SceneData g) where+ toLabelValue Group = GV.toLabelValue "Group"+ toLabelValue (Geode n _) = GV.toLabelValue $ "Geode " ++ show n+ toLabelValue LOD = GV.toLabelValue "LOD"+ toLabelValue (MatrixTransform m) = GV.toLabelValue $ matrixToHtml m+ toLabelValue (Switch i) = GV.toLabelValue $ "Switch " ++ show i+ toLabelValue (Material m) = GV.toLabelValue $ materialToHtml m+ toLabelValue (Handler _ _) = GV.toLabelValue "Handler"+ toLabelValue Light = GV.toLabelValue "Light"+ toLabelValue Camera = GV.toLabelValue "Camera"+ toLabelValue (Texture _) = GV.toLabelValue "Texture"+ toLabelValue (Text t) = GV.toLabelValue $ "Text " ++ T.unpack t+++cell :: String -> H.Cell+cell text = H.LabelCell [] $ H.Text [H.Str $ LT.pack text]++colourCell :: V4 Float -> String -> H.Cell+colourCell col text = H.LabelCell [H.BGColor $ toRGB col] $ H.Text [H.Str $ LT.pack text]++toRGB :: V4 Float -> C.Color+toRGB (V4 r g b _) = C.RGB (w8 r) (w8 g) (w8 b)+ where+ w8 :: Float -> Word8+ w8 c = round $ c * 255++table :: [H.Row] -> H.Label+table rows = H.Table $ H.HTable+ { H.tableFontAttrs = Nothing+ , H.tableAttrs = []+ , H.tableRows = rows+ }++matrixToHtml :: M44 Float -> H.Label+matrixToHtml (V4 a b c d) = H.Table $ H.HTable+ { H.tableFontAttrs = Nothing+ , H.tableAttrs = []+ , H.tableRows = map (H.Cells . vectorToHtml) [a, b, c, d]+ }++vectorToHtml :: V4 Float -> [H.Cell]+vectorToHtml (V4 a b c d) = map tableCell [a, b, c, d]+ where+ tableCell v = cell $ show v++materialToHtml :: Phong -> H.Label+materialToHtml Phong{..} = table rows+ where+ colourToHtml name col = fmap (\v -> H.Cells [cell name, H.LabelCell [] $ table [H.Cells $ colourCell v "RGBA" : vectorToHtml v]]) col+ valueToHtml name val = fmap (\v -> H.Cells [cell name, cell $ show v]) val++ rows = catMaybes+ [ colourToHtml "Emission" phEmission+ , colourToHtml "Ambient" phAmbient+ , colourToHtml "Diffuse" phDiffuse+ , colourToHtml "Specular" phSpecular+ , valueToHtml "Shine" phShine+ , colourToHtml "Reflective" phReflective+ , valueToHtml "Reflectivity" phReflectivity+ , colourToHtml "Transparent" phTransparent+ , valueToHtml "Transparency" phTransparency+ ]+++toDot :: Scene g -> FilePath -> IO FilePath+toDot (Scene sg _) = GV.runGraphviz (GV.graphToDot GV.quickParams sg) GV.Canon++toSvg :: Scene g -> FilePath -> IO FilePath+toSvg (Scene sg _) = GV.runGraphviz (GV.graphToDot GV.quickParams sg) GV.Svg
+ test/Graphics/SceneGraph/BasicSpec.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+module Graphics.SceneGraph.BasicSpec where++import Test.Hspec (Spec, describe, it, shouldBe,+ shouldSatisfy)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary (arbitrary))++import Graphics.SceneGraph.Basic+import Graphics.SceneGraph.BoundingBox+import Linear (V3 (..))+++instance Arbitrary a => Arbitrary (V3 a) where+ arbitrary = V3 <$> arbitrary <*> arbitrary <*> arbitrary+++spec :: Spec+spec = do+ describe "union" $ do+ prop "should be idempotent" $ \(box :: Box Float) ->+ union box box `shouldBe` box++ it "should yield a superset of the two input boxes" $ do+ let a = (V3 (-2) (-2) (-2), V3 2 2 2)+ b = (V3 (-1) (-1) (-1), V3 3 3 3)+ union a b `shouldBe` (V3 (-2) (-2) (-2), V3 3 3 3)+++ describe "bounds" $ do+ it "should yield the a bounding box that's at least as large as the items within" $ do+ testScene <- osg $ do+ group =<< sequence+ [ translate (V3 2 0 0) camera+ , translate (V3 1 0 3) camera+ , translate (V3 0 (-4) 0) camera+ ]++ let sz = boxSize (bounds testScene)+ sz `shouldSatisfy` (> V3 2 4 3)+ sz `shouldSatisfy` (< V3 3 5 4)
+ test/Graphics/SceneGraph/BoundingBoxSpec.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+module Graphics.SceneGraph.BoundingBoxSpec where++import Test.Hspec (Expectation, Spec, describe,+ it, shouldBe, shouldSatisfy)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary (arbitrary))++import Control.Lens ((^.))+import Graphics.SceneGraph.Basic+import Graphics.SceneGraph.BoundingBox+import Linear (R1 (..), R2 (..), R3 (..),+ V3 (..), V4 (..), (!*))+import qualified Linear as L+import Linear.Vector ((^*))+++instance Arbitrary a => Arbitrary (V3 a) where+ arbitrary = V3 <$> arbitrary <*> arbitrary <*> arbitrary++infix 1 `shouldBeApproximately`++shouldBeApproximately :: V3 Float -> V3 Float -> Expectation+shouldBeApproximately a b = roundV a `shouldBe` roundV b+ where+ roundV :: V3 Float -> V3 Float+ roundV v = fmap ((/ 100.0) . fromIntegral . round) (v ^* 100)+++origin :: V4 Float+origin = L.point $ pure 0+++spec :: Spec+spec = do+ describe "union" $ do+ prop "should be idempotent" $ \(box :: Box Float) ->+ union box box `shouldBe` box++ it "should yield a superset of the two input boxes" $ do+ let a = (V3 (-2) (-2) (-2), V3 2 2 2)+ b = (V3 (-1) (-1) (-1), V3 3 3 3)+ union a b `shouldBe` (V3 (-2) (-2) (-2), V3 3 3 3)+++ describe "translate" $ do+ prop "should move a point linearly" $ \p -> do+ testScene <- osg $ do+ translate p camera+ let camNode = findCamera testScene 0+ getTransformTo testScene camNode !* origin `shouldBe` L.point p+++ describe "rotateX" $ do+ prop "should not modify the X coordinate" $ \p theta -> do+ testScene <- osg $ do+ rotateX theta (translate p camera)+ let camNode = findCamera testScene 0+ (getTransformTo testScene camNode !* origin) ^. _x+ `shouldBe` p ^. _x++ it "should turn a Y unit vector into a Z unit vector" $ do+ testScene <- osg $ do+ rotateX 90 (translate (V3 0 1 0) camera)+ let camNode = findCamera testScene 0+ (getTransformTo testScene camNode !* origin) ^. _xyz+ `shouldBeApproximately` V3 0 0 1+++ describe "rotateY" $ do+ prop "should not modify the Y coordinate" $ \p theta -> do+ testScene <- osg $ do+ rotateY theta (translate p camera)+ let camNode = findCamera testScene 0+ (getTransformTo testScene camNode !* origin) ^. _y+ `shouldBe` p ^. _y++ it "should turn an X unit vector into a Z unit vector" $ do+ testScene <- osg $ do+ rotateY 90 (translate (V3 1 0 0) camera)+ let camNode = findCamera testScene 0+ (getTransformTo testScene camNode !* origin) ^. _xyz+ `shouldBeApproximately` V3 0 0 (-1)+++ describe "rotateZ" $ do+ prop "should not modify the Z coordinate" $ \p theta -> do+ testScene <- osg $ do+ rotateZ theta (translate p camera)+ let camNode = findCamera testScene 0+ (getTransformTo testScene camNode !* origin) ^. _z+ `shouldBe` p ^. _z++ it "should turn an X unit vector into a Y unit vector" $ do+ testScene <- osg $ do+ rotateZ 90 (translate (V3 1 0 0) camera)+ let camNode = findCamera testScene 0+ (getTransformTo testScene camNode !* origin) ^. _xyz+ `shouldBeApproximately` V3 0 1 0+++ describe "bounds" $ do+ it "should yield the a bounding box that's at least as large as the items within" $ do+ testScene <- osg $ do+ group =<< sequence+ [ translate (V3 2 0 0) camera+ , translate (V3 1 0 3) camera+ , translate (V3 0 (-4) 0) camera+ ]++ let sz = boxSize (bounds testScene)+ sz `shouldSatisfy` (> V3 2 4 3)+ sz `shouldSatisfy` (< V3 3 5 4)
+ test/Graphics/SceneGraph/VisualiseSpec.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Graphics.SceneGraph.VisualiseSpec where++import Test.Hspec (Spec, describe, it, shouldBe)++import Graphics.SceneGraph.Basic+import Graphics.SceneGraph.Types+import qualified Graphics.SceneGraph.Visualise as GV+import Linear (V3 (..))+++spec :: Spec+spec = do+ describe "toSvg" $ do+ it "should match the golden test file" $ do+ testScene <- osg $ do+ let cam = translate (V3 4 0 (-2)) camera+ let lamp = rotateX 90 $ color Yellow $ translate (V3 0 5 3) light+ cam <+> lamp+ svgFile <- GV.toSvg testScene "test.svg"+ svgFile `shouldBe` "test.svg"+ dotFile <- GV.toDot testScene "test.dot"+ dotFile `shouldBe` "test.dot"++ it "should support cyclic graphs" $ do+ testScene <- osg $ do+ let cam = translate (V3 4 0 (-2)) camera+ let lamp = rotateX 90 $ color Yellow $ translate (V3 0 5 3) light+ cam <+> lamp+ svgFile <- GV.toSvg testScene "test.svg"+ svgFile `shouldBe` "test.svg"+ dotFile <- GV.toDot testScene "test.dot"+ dotFile `shouldBe` "test.dot"
+ test/testsuite.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}