module SimpleSceneGraph (
findNodeByID,
updateSceneGraph,
GraphChange(DeleteNode, AddNode, RotateNode, TranslateNode),
Model(ClassicModel, ModernModel, GluShape),
Translate(Translate),
Rotate(Rotate),
CameraPos(CameraPos),
LookAt(LookAt),
UpVector(UpVector),
Vert(Vert),
vertexTupleListToVertexList,
initModelVBO,
getChanges,
identityMatrix,
DrawSceneGraph,
SimpleSceneGraph(SimpleRootNode,SimpleCameraNode, SimpleLightNode,
ModelNode, TransformNode, OrbitalTransformNode),
render,
getColorAtPixel,
pngToArray
)
where
import Graphics.Rendering.OpenGL
import Data.IORef
import Graphics.UI.GLUT
import Foreign.Storable
import Control.Monad.ST.Strict
import Data.Array.MArray
import Data.Array.Storable
import Foreign.Ptr
import qualified Data.Map as Map
import qualified Data.HashTable as Hashtable
import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
import Graphics.Rendering.GLU.Raw
import Graphics.Rendering.OpenGL.GLU
import Data.Int
import Prelude
import Codec.Image.PNG
data OpenGLType = ClassicGL
| ModernGL
openGLType = ModernGL
class DrawSceneGraph a where
process:: a→ IO Bool
data Translate = Translate {
tx::GLfloat,
ty::GLfloat,
tz::GLfloat
}
data Rotate = Rotate{
angleX::GLfloat,
angleY::GLfloat,
angleZ::GLfloat}
data CameraPos = CameraPos { cpx::GLdouble,
cpy::GLdouble,
cpz::GLdouble}
data LookAt = LookAt { lx::GLdouble,
ly::GLdouble,
lz::GLdouble}
data UpVector = UpVector { uvx::GLdouble,
uvy::GLdouble,
uvz::GLdouble}
data SimpleSceneGraph = SimpleRootNode { nid::String,
children::[SimpleSceneGraph]}
|TransformNode {
nid::String,
rotation::Rotate,
translation::Translate,
children::[SimpleSceneGraph]}
|OrbitalTransformNode
{
nid::String,
rotation::Rotate,
translation::Translate,
children::[SimpleSceneGraph]
}
| ModelNode {
nid::String,
model::(Maybe Model)
}
-- | SimpleNode {
-- nid::String,
-- model::(Maybe Model),
-- rotation::Rotate,
-- translation::Translate,
-- children::[SimpleSceneGraph]}
| SimpleLightNode {
nid::String,
rotation::Rotate,
translation::Translate,
amb::Color4 GLfloat,
diff::Color4 GLfloat,
spec::Color4 GLfloat,
children::[SimpleSceneGraph]}
-- | OrbitalNode {
-- nid::String,
-- model::(Maybe Model),
-- rotation::Rotate,
-- translation::Translate,
-- children::[SimpleSceneGraph]}
| SimpleCameraNode {
nid::String,
cameraPos::CameraPos,
lookAT:: LookAt,
upVector::UpVector,
children::[SimpleSceneGraph]}
class RenderSimpleSceneGraph a where
render :: Matrix4x4 → a → IO ()
data Matrix4x4 = Matrix4x4 {
i1j1 ::GLfloat,
i1j2 ::GLfloat,
i1j3 ::GLfloat,
i1j4 ::GLfloat,
i2j1 ::GLfloat,
i2j2 ::GLfloat,
i2j3 ::GLfloat,
i2j4 ::GLfloat,
i3j1 ::GLfloat,
i3j2 ::GLfloat,
i3j3 ::GLfloat,
i3j4 ::GLfloat,
i4j1 ::GLfloat,
i4j2 ::GLfloat,
i4j3 ::GLfloat,
i4j4 ::GLfloat
} deriving (Show)
identityMatrix =
Matrix4x4 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1
rotateX θ =
if θ ≠ 0
then Matrix4x4 1 0 0 0 0 (cos rad) (-(sin rad)) 0 0 (sin rad) (cos rad) 0 0 0 0 1
else identityMatrix
where
rad = θ * pi / 180
rotateY θ =
if θ ≠ 0
then Matrix4x4 (cos rad) 0 (sin rad) 0 0 1 0 0 (-(sin rad)) 0 (cos rad) 0 0 0 0 1
else identityMatrix
where
rad = θ * pi / 180
rotateZ θ =
if θ ≠ 0
then Matrix4x4 (cos rad) (-(sin rad)) 0 0 (sin rad) (cos rad) 0 0 0 0 1 0 0 0 0 1
else identityMatrix
where
rad = θ * pi / 180
trans (Vector3 x y z) =
Matrix4x4 1 0 0 x 0 1 0 y 0 0 1 z 0 0 0 1
mult:: Matrix4x4 → Matrix4x4 → Matrix4x4
mult mL mR =
Matrix4x4 x1y1 x1y2 x1y3 x1y4 x2y1 x2y2 x2y3 x2y4 x3y1 x3y2 x3y3 x3y4 x4y1 x4y2 x4y3 x4y4
where
x1y1 = (i1j1 mL) * (i1j1 mR) + (i1j2 mL) * (i2j1 mR) + (i1j3 mL) * (i3j1 mR) + (i1j4 mL) * (i4j1 mR)
x1y2 = (i1j1 mL) * (i1j2 mR) + (i1j2 mL) * (i2j2 mR) + (i1j3 mL) * (i3j2 mR) + (i1j4 mL) * (i4j2 mR)
x1y3 = (i1j1 mL) * (i1j3 mR) + (i1j2 mL) * (i2j3 mR) + (i1j3 mL) * (i3j3 mR) + (i1j4 mL) * (i4j3 mR)
x1y4 = (i1j1 mL) * (i1j4 mR) + (i1j2 mL) * (i2j4 mR) + (i1j3 mL) * (i3j4 mR) + (i1j4 mL) * (i4j4 mR)
x2y1 = (i2j1 mL) * (i1j1 mR) + (i2j2 mL) * (i2j1 mR) + (i2j3 mL) * (i3j1 mR) + (i2j4 mL) * (i4j1 mR)
x2y2 = (i2j1 mL) * (i1j2 mR) + (i2j2 mL) * (i2j2 mR) + (i2j3 mL) * (i3j2 mR) + (i2j4 mL) * (i4j2 mR)
x2y3 = (i2j1 mL) * (i1j3 mR) + (i2j2 mL) * (i2j3 mR) + (i2j3 mL) * (i3j3 mR) + (i2j4 mL) * (i4j3 mR)
x2y4 = (i2j1 mL) * (i1j4 mR) + (i2j2 mL) * (i2j4 mR) + (i2j3 mL) * (i3j4 mR) + (i2j4 mL) * (i4j4 mR)
x3y1 = (i3j1 mL) * (i1j1 mR) + (i3j2 mL) * (i2j1 mR) + (i3j3 mL) * (i3j1 mR) + (i3j4 mL) * (i4j1 mR)
x3y2 = (i3j1 mL) * (i1j2 mR) + (i3j2 mL) * (i2j2 mR) + (i3j3 mL) * (i3j2 mR) + (i3j4 mL) * (i4j2 mR)
x3y3 = (i3j1 mL) * (i1j3 mR) + (i3j2 mL) * (i2j3 mR) + (i3j3 mL) * (i3j3 mR) + (i3j4 mL) * (i4j3 mR)
x3y4 = (i3j1 mL) * (i1j4 mR) + (i3j2 mL) * (i2j4 mR) + (i3j3 mL) * (i3j4 mR) + (i3j4 mL) * (i4j4 mR)
x4y1 = (i4j1 mL) * (i1j1 mR) + (i4j2 mL) * (i2j1 mR) + (i4j3 mL) * (i3j1 mR) + (i4j4 mL) * (i4j1 mR)
x4y2 = (i4j1 mL) * (i1j2 mR) + (i4j2 mL) * (i2j2 mR) + (i4j3 mL) * (i3j2 mR) + (i4j4 mL) * (i4j2 mR)
x4y3 = (i4j1 mL) * (i1j3 mR) + (i4j2 mL) * (i2j3 mR) + (i4j3 mL) * (i3j3 mR) + (i4j4 mL) * (i4j3 mR)
x4y4 = (i4j1 mL) * (i1j4 mR) + (i4j2 mL) * (i2j4 mR) + (i4j3 mL) * (i3j4 mR) + (i4j4 mL) * (i4j4 mR)
matrix4x4toList (Matrix4x4 i1j1 i1j2 i1j3 i1j4 i2j1 i2j2 i2j3 i2j4
i3j1 i3j2 i3j3 i3j4 i4j1 i4j2 i4j3 i4j4)
= [i1j1, i1j2,i1j3,i1j4,i2j1,i2j2,i2j3,i2j4,i3j1,i3j2,i3j3,i3j4,i4j1,i4j2,i4j3,i4j4]
matrix4x4toGLMatrix (Matrix4x4 i1j1 i1j2 i1j3 i1j4 i2j1 i2j2 i2j3 i2j4
i3j1 i3j2 i3j3 i3j4 i4j1 i4j2 i4j3 i4j4)=
newMatrix RowMajor matList :: IO (GLmatrix GLfloat)
where
matList = [i1j1, i1j2,i1j3,i1j4,i2j1,i2j2,i2j3,i2j4,i3j1,i3j2,i3j3,i3j4,i4j1,i4j2,i4j3,i4j4]
classicTransform matrix = do
matrixMode $= Modelview 0
loadIdentity
print "classic matrix operation"
m ← newMatrix RowMajor (matrix4x4toList matrix) :: IO (GLmatrix GLfloat)
multMatrix m
return ()
data GraphChange = DeleteNode {
cid ::String}
| RotateNode {
cid ::String,
cx ::GLfloat,
cy ::GLfloat,
cz ::GLfloat}
| TranslateNode {
cid ::String,
cx ::GLfloat,
cy ::GLfloat,
cz ::GLfloat}
| AddNode {
parentid::String,
newNode::SimpleSceneGraph}
data Vert = Vert {
vertX::GLfloat,
vertY::GLfloat,
vertZ::GLfloat,
colorR::GLfloat,
colorG::GLfloat,
colorB::GLfloat,
specR::GLfloat,
specG::GLfloat,
specB::GLfloat,
shiny::GLfloat}
deriving (Show)
data Model = ClassicModel{
colorID::(GLubyte,GLubyte,GLubyte),
verts::[Vert]}
| GluShape{
colorID::(GLubyte,GLubyte,GLubyte),
shapeR::GLfloat,
shapeG::GLfloat,
shapeB::GLfloat,
shapeSpecR::GLfloat,
shapeSpecG::GLfloat,
shapeSpecB::GLfloat,
shapeShiny::GLfloat,
shape ::(QuadricPrimitive),
style :: QuadricStyle}
| ModernModel{
vboData:: IO BufferObject,
vertCount:: Int
}
instance RenderSimpleSceneGraph Model where
render matrix (ClassicModel (r,g,b) verts ) = do
print "a model"
classicTransform matrix
--color $ Color3 r g b
renderPrimitive Triangles $ mapM_ renderVert verts
render matrix (GluShape (r, g ,b) r1 g1 b1 sR sG sB shiny shape style) = do
color $ Color3 r1 g1 b1
materialAmbientAndDiffuse FrontAndBack $= (Color4 r1 g1 b1 1)
materialSpecular FrontAndBack $= (Color4 sR sG sB 1)
materialShininess FrontAndBack $= shiny
renderQuadric style shape
renderVert (Vert x y z r g b sR sG sB shiny) = do
color $ Color3 r g b
materialAmbientAndDiffuse FrontAndBack $= (Color4 r g b 1)
materialSpecular FrontAndBack $= (Color4 sR sG sB 1)
materialShininess FrontAndBack $= shiny
vertex $ Vertex3 x y z
instance RenderSimpleSceneGraph SimpleSceneGraph where
render matrix (SimpleRootNode id children) = do
--matrixMode $= Projection
--loadIdentity
--depthFunc $= Just Less
--viewport $= (Position 0 0, Size 800 600)
--perspective 60 1.333 1 120
clear [ColorBuffer, DepthBuffer]
lighting $= Enabled
light (Light 0) $= Enabled
matrixMode $= Modelview 0
loadIdentity
traverseChildren matrix children
flush
swapBuffers
return ()
render matrix (ModelNode id model) = do
--print $ "drawing" ⊕ id
--show matrix
case model of
Nothing → return()
Just model1 → render matrix model1
render matrix (OrbitalTransformNode id (Rotate aX aY aZ) (Translate x y z) children) = do
print $ "drawing" ⊕ id
print translatedMat
traverseChildren translatedMat children
return ()
where
rotatedXMat = (rotateX aX) `mult` matrix
rotatedYMat = (rotateY aY) `mult`rotatedXMat
rotatedZMat = (rotateZ aZ) `mult`rotatedYMat
translatedMat = (trans (Vector3 x y z)) `mult` rotatedZMat
render matrix (TransformNode id (Rotate aX aY aZ) (Translate x y z) children) = do
print $ "drawing" ⊕ id
print rotatedZMat
traverseChildren rotatedZMat children
return ()
where
translatedMat = (trans (Vector3 x y z)) `mult` matrix
rotatedXMat = (rotateX aX) `mult` translatedMat
rotatedYMat = (rotateY aY) `mult` rotatedXMat
rotatedZMat = (rotateZ aZ) `mult` rotatedYMat
render matrix (SimpleLightNode nid rotation translation amb diff spec children) = do
ambient (Light 0) $= amb
diffuse (Light 0) $= diff
specular (Light 0) $= spec
position (Light 0) $= (Vertex4 1 1 1 0)
where
transX = tx translation
transY = ty translation
transZ = tz translation
--angleRot = rangle rotation
--rotX = rx rotation
--rotY = ry rotation
--rotZ = rz rotation
translateRotateDraw = do
--translate (Vector3 transX transY transZ)
--rotate angleRot (Vector3 rotX rotY rotZ)
traverseChildren matrix children
--render matrix (SimpleNode id model rotation translation children) = do
-- print $ "drawing" ⊕ id
-- preservingMatrix translateRotateDraw
-- return ()
-- where
-- transX = tx translation
-- transY = ty translation
-- transZ = tz translation
-- angleRot = rangle rotation
-- rotX = rx rotation
-- rotY = ry rotation
-- rotZ = rz rotation
-- translateRotateDraw = do
--
-- translate (Vector3 transX transY transZ)
-- rotate angleRot (Vector3 rotX rotY rotZ)
-- traverseChildren matrix children
-- case model of
-- Nothing → return ()
-- Just m1 → render matrix m1
--render matrix (OrbitalNode id model rotation translation children) = do
-- print $ "drawing" ⊕ id
-- preservingMatrix translateRotateDraw
-- return ()
-- where
-- transX = tx translation
-- transY = ty translation
-- transZ = tz translation
-- angleRot = rangle rotation
-- rotX = rx rotation
-- rotY = ry rotation
-- rotZ = rz rotation
-- translateRotateDraw = do
-- rotate angleRot (Vector3 rotX rotY rotZ)
-- translate (Vector3 transX transY transZ)
-- traverseChildren matrix children
-- case model of
-- Nothing → return ()
-- Just m1 → render matrix m1
render matrix (SimpleCameraNode id (CameraPos posX posY posZ) (LookAt lookX lookY lookZ)
(UpVector upX upY upZ) children) = do
print $ "drawing" ⊕ id
gluLookAt posX posY posZ lookX lookY lookZ upX upY upZ
traverseChildren matrix children
return ()
traverseChildren:: Matrix4x4 → [SimpleSceneGraph]→ IO ()
traverseChildren matrix (x:xs) = do
render matrix x
traverseChildren matrix xs
traverseChildren _ [] = do
return ()
initModelVBO :: [GLfloat] → IO BufferObject
initModelVBO vertexList = do
[models]← genObjectNames 1 :: IO [BufferObject]
bindBuffer ArrayBuffer $= Just models
tempArray ← newListArray (0, listLen - 1) vertexList :: IO(StorableArray Int GLfloat)
withStorableArray tempArray (λptr ->
bufferData ArrayBuffer $= (sizeOfList, ptr, StaticDraw))
bindBuffer ArrayBuffer $= Nothing
return models
where
listLen = length vertexList
elementSize = sizeOf $ head vertexList
sizeOfList = toEnum $ listLen * elementSize
vertexTupleListToVertexList::[(GLfloat,GLfloat,GLfloat)]→ [GLfloat]
vertexTupleListToVertexList [] = []
vertexTupleListToVertexList ((x,y,z):verts) = x:y:z:vertexTupleListToVertexList verts
--Takes a list of changes, should be hashtable though, and a SceneGraph
--It then recursivly rebuild the graph making any change in the changes
--data structure
updateSceneGraph :: Map.Map String [GraphChange]→ SimpleSceneGraph → SimpleSceneGraph
-- A root node can ¬ be changed or deleted and can only apear once as the ROOT
--failing to follow these rules will result in undefined behaviors
updateSceneGraph changes (SimpleRootNode id children) =
SimpleRootNode id (updateChildren children changes)
updateSceneGraph changes graph =
graph
findNodeByID id graph =
if graphID ≡ id
then Just graph
else findNodeByIDChildren Nothing id (children graph)
where
graphID = nid graph
findNodeByIDChildren (Just graph) _ _ = Just graph
findNodeByIDChildren accum id (c:cs) =
findNodeByIDChildren (findNodeByID id c) id cs
findNodeByIDChildren accum _ [] = accum
updateChildren :: [SimpleSceneGraph] → Map.Map String [GraphChange] → [SimpleSceneGraph]
updateChildren [] changes = []
updateChildren (n:ns) changes =
case newN of
Nothing → (updateChildren ns changes)
Just node → node:(updateChildren ns changes)
where
nodeID = nid n
newN = applyAllChanges (Just n) applicableChanges changes
applicableChanges = getChanges nodeID changes
--Takes a String node id and returns all changes that apply to it
getChanges::String→ Map.Map String [GraphChange]→ [GraphChange]
getChanges id map =
case changes of
Nothing → []
Just cs → cs
where
changes = Map.lookup id map
--Applies all changes for a node to that node
applyAllChanges::(Maybe SimpleSceneGraph) → [GraphChange] → Map.Map String [GraphChange] → (Maybe SimpleSceneGraph)
applyAllChanges Nothing _ _ =
Nothing
applyAllChanges (Just node) (c:cs) allChanges =
applyAllChanges (updateNode node c ) cs allChanges
applyAllChanges (Just (TransformNode id rotation trans children)) [] allChanges =
Just (TransformNode id rotation trans (updateChildren children allChanges))
applyAllChanges (Just (OrbitalTransformNode id rotation trans children)) [] allChanges =
Just (OrbitalTransformNode id rotation trans (updateChildren children allChanges))
applyAllChanges (Just (ModelNode id model)) [] allChanges =
Just (ModelNode id model)
applyAllChanges (Just (SimpleCameraNode id pos look up children)) [] allChanges =
Just (SimpleCameraNode id pos look up (updateChildren children allChanges))
applyAllChanges ( Just(SimpleLightNode id rot trans amb diff spec children)) [] allChanges =
Just (SimpleLightNode id rot trans amb diff spec (updateChildren children allChanges))
--Updates a single node with a single Change
--Returns Just Node or Nothing if a delete change was requested
updateNode:: SimpleSceneGraph→ GraphChange→ (Maybe SimpleSceneGraph)
updateNode (SimpleCameraNode id pos lookat up children) (TranslateNode tId x y z)=
Just (SimpleCameraNode id (CameraPos (realToFrac x) (realToFrac y) (realToFrac z)) lookat up children)
updateNode (TransformNode id rotation translation children) (TranslateNode tId x y z)=
Just (TransformNode id rotation (Translate x y z) children)
updateNode (TransformNode id rotation translation children) (RotateNode tId x y z)=
Just (TransformNode id (Rotate x y z) translation children)
updateNode (TransformNode id rotation translation children) _=
Just (TransformNode id rotation translation children)
--updateNode (OrbitalNode id model rotation translation children) (TranslateNode tId x y z)=
-- Just (OrbitalNode id model rotation (Translate x y z) children)
--updateNode (OrbitalNode id model rotation translation children) (RotateNode tId r x y z)=
--Just (OrbitalNode id model (Rotate r x y z) translation children)
updateNode (OrbitalTransformNode id rotation translation children) _=
Just (OrbitalTransformNode id rotation translation children)
updateNode (ModelNode id model) _ =
Just(ModelNode id model)
updateNode _ (DeleteNode id) = Nothing
pngToArray (Right png) = do
Just (imageData png)
pngToArray (Left error) = do
Nothing
getColorAtPixel x y = do
colorArray ← newArray (0, 2) 0 :: IO(StorableArray Int Int)
vp ← get viewport
adjustedY ← return $ adjustY vp
withStorableArray colorArray (λptr ->
readPixels (Position x (fromIntegral adjustedY)) (Size 1 1 ) (PixelData RGB UnsignedByte ptr))
touchStorableArray colorArray
colors ← getElems colorArray
return $ head colors
where
adjustY vp = (extractSizeY vp) - y
extractSizeY (_, (Size x y)) = fromIntegral y :: GLint