I can actually see something!

Graphics/Formats/Collada/Objects.hs

@@ -60,7 +60,7 @@ data InputSemantic
     | SemNormal
     | SemVertex
     | SemTexCoord
-    deriving Show
+    deriving (Eq,Show)
 
 data Primitive
     = PrimTriangles String [Input] [Int]  -- material inputs indices
@@ -116,10 +116,16 @@ mainA = mainScene &&& (Map.unions .< X.multi objects) <<< X.hasName "COLLADA"
 infixr 1 .<
 (.<) = flip (X.>.)
 
+refAttr :: String -> LA.LA X.XmlTree ID
+refAttr name = stripHash ^<< X.getAttrValue0 name
+    where
+    stripHash ('#':x) = x
+    stripHash x = x
+
 objects = asum [ float_array, source, vertices, geometry, image, newparam, effect, material, node, visual_scene ]
 
 mainScene :: LA.LA X.XmlTree ID
-mainScene = X.getAttrValue0 "url" <<< child (X.hasName "instance_visual_scene") <<< child (X.hasName "scene")
+mainScene = refAttr "url" <<< child (X.hasName "instance_visual_scene") <<< child (X.hasName "scene")
 
 asum = foldr1 (X.<+>)
 
@@ -135,7 +141,7 @@ float_array = object "float_array" $ toArray ^<< X.getText . X.getChildren
     toArray = OFloatArray . map read . words
 
 accessor :: LA.LA X.XmlTree Accessor
-accessor = massage ^<< X.getAttrValue0 "source" &&& X.getAttrValue0 "count" &&& X.getAttrValue "stride" &&& X.getAttrValue "offset" <<< X.hasName "accessor"
+accessor = massage ^<< refAttr "source" &&& X.getAttrValue0 "count" &&& X.getAttrValue "stride" &&& X.getAttrValue "offset" <<< X.hasName "accessor"
     where
     massage (source, (count, (stride, offset))) = Accessor source (read count) (readDef 1 stride) (readDef 0 offset)
 
@@ -148,7 +154,7 @@ source :: LA.LA X.XmlTree Dict
 source = object "source" $ OSource ^<< accessor <<< X.getChildren <<< child (X.hasName "technique_common")
 
 input :: LA.LA X.XmlTree Input
-input = massage ^<< X.getAttrValue "offset" &&& X.getAttrValue0 "semantic" &&& X.getAttrValue0 "source" <<< X.hasName "input"
+input = massage ^<< X.getAttrValue "offset" &&& X.getAttrValue0 "semantic" &&& refAttr "source" <<< X.hasName "input"
     where
     massage (offset, (semantic, source)) = Input (readDef (-1) offset) (massageSemantic semantic) source -- -1 hax!!  See vertices where this is fixedup.
     massageSemantic "POSITION" = SemPosition
@@ -206,7 +212,7 @@ effect :: LA.LA X.XmlTree Dict
 effect = object "effect" $ OEffect ^<< child technique <<< child (X.hasName "profile_COMMON")
 
 material :: LA.LA X.XmlTree Dict
-material = object "material" $ OMaterial ^<< X.getAttrValue0 "url" <<< child (X.hasName "instance_effect")
+material = object "material" $ OMaterial ^<< refAttr "url" <<< child (X.hasName "instance_effect")
 
 nodeRef :: LA.LA X.XmlTree NodeRef
 nodeRef = asum [inline, instance_node] 
@@ -217,13 +223,13 @@ nodeRef = asum [inline, instance_node]
     convid (x, _)    = Left x
 
 instance_node :: LA.LA X.XmlTree NodeRef
-instance_node = NRInstance ^<< X.getAttrValue0 "url" <<< X.hasName "instance_node"
+instance_node = NRInstance ^<< refAttr "url" <<< X.hasName "instance_node"
 
 nodeInstance :: LA.LA X.XmlTree NodeInstance
 nodeInstance = asum [NINode ^<< nodeRef, instance_geometry]
 
 instance_geometry :: LA.LA X.XmlTree NodeInstance
-instance_geometry = uncurry NIGeometry ^<< X.getAttrValue0 "url" &&& bindings <<< X.hasName "instance_geometry"
+instance_geometry = uncurry NIGeometry ^<< refAttr "url" &&& bindings <<< X.hasName "instance_geometry"
     where
     bindings = id .< (child instance_material <<< child (X.hasName "technique_common") <<< child (X.hasName "bind_material"))
 
@@ -240,7 +246,7 @@ instance_material :: LA.LA X.XmlTree MaterialBinding
 instance_material = conv ^<< myAttrs &&& bindAttrs <<< X.hasName "instance_material"
     where
     conv ((symbol, target), (semantic, input_semantic)) = MaterialBinding symbol target semantic input_semantic
-    myAttrs = X.getAttrValue0 "symbol" &&& X.getAttrValue0 "target"
+    myAttrs = X.getAttrValue0 "symbol" &&& refAttr "target"
     bindAttrs = X.getAttrValue0 "semantic" &&& X.getAttrValue0 "input_semantic" <<< child (X.hasName "bind_vertex_input")
 
 visual_scene :: LA.LA X.XmlTree Dict

Graphics/Formats/Collada/Render.hs

@@ -1,6 +1,8 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, PatternGuards #-}
 
-module Graphics.Formats.Collada.Render where
+module Graphics.Formats.Collada.Render 
+    ( compile )
+where
 
 import qualified Graphics.Rendering.OpenGL.GL as GL
 import qualified Graphics.Formats.Collada.Objects as O
@@ -10,82 +12,105 @@ import Foreign.Ptr (Ptr)
 import Control.Applicative
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans
+import Control.Monad (when)
 
-newtype DrawM a = DrawM (IO a)
+newtype DrawM a = DrawM { runDrawM :: IO a }
     deriving (Functor, Applicative, Monad, MonadIO)
 
 preservingMatrix :: DrawM a -> DrawM a
 preservingMatrix (DrawM io) = DrawM (GL.preservingMatrix io)
 
-newtype CompileM a = CompileM (ReaderT O.Dict IO a)
+preservingClientState :: DrawM a -> DrawM a
+preservingClientState (DrawM io) = DrawM (GL.preservingClientAttrib [GL.AllClientAttributes] io)
+
+newtype CompileM a = CompileM { runCompileM :: ReaderT O.Dict IO a }
     deriving (Functor, Applicative, Monad, MonadIO)
 
+lookup' :: (Ord k, Show k) => k -> Map.Map k a -> a
+lookup' k mp | Just x <- Map.lookup k mp = x
+             | otherwise                 = error $ "Couldn't find object: " ++ show k
+
 findSymbol :: O.ID -> CompileM O.Object
-findSymbol ident = CompileM $ asks (Map.! ident)
+findSymbol = CompileM . asks . lookup'
 
+compile :: (O.ID, O.Dict) -> IO (IO ())
+compile (mainid, dict) = runDrawM <$> runReaderT (runCompileM (compileVisualScene (lookup' mainid dict))) dict
 
 compileArray :: O.Object -> CompileM (Ptr GL.GLfloat)
-compileArray (O.OFloatArray xs) = liftIO $ Array.newArray xs
+compileArray arr@(O.OFloatArray xs) = debug arr >> (liftIO $ Array.newArray xs)
 compileArray _ = error "Not an array"
 
-compileSource :: O.Object -> CompileM (GL.VertexArrayDescriptor GL.GLfloat)
-compileSource (O.OSource (O.Accessor arrayid count stride offset)) = do
+debug x = liftIO $ putStrLn ("\nCompiling: " ++ show x)
+
+compileAccessor :: O.Accessor -> CompileM (GL.VertexArrayDescriptor GL.GLfloat)
+compileAccessor acc@(O.Accessor arrayid count stride offset) = do
+    debug acc
     ptr <- compileArray =<< findSymbol arrayid
     let ptr' = Array.advancePtr ptr offset
-    -- XXX stride is wrong for NumComponents!
-    return $ GL.VertexArrayDescriptor (fromIntegral stride) GL.Float (fromIntegral stride) ptr'
-compileSource _ = error "Not a source"
+    -- XXX Sooo wrong
+    return $ GL.VertexArrayDescriptor 3 GL.Float 0 ptr'
 
 compileInput :: O.Input -> CompileM (DrawM ())
-compileInput (O.Input _ semantic source) = do
-    descriptor <- compileSource =<< findSymbol source
-    let sem = convertSem semantic
-    return . liftIO $ do
-        GL.arrayPointer sem GL.$= descriptor
-        GL.clientState sem GL.$= GL.Enabled
+compileInput inp@(O.Input _ semantic source) = do
+    debug inp
+    sym <- findSymbol source
+    case sym of
+        O.OVertices inputs -> sequence_ <$> mapM compileInput inputs
+        O.OSource acc -> do
+            descriptor <- compileAccessor acc
+            let sem = convertSem semantic
+            return . liftIO $ do
+                GL.arrayPointer sem GL.$= descriptor
+                GL.clientState sem GL.$= GL.Enabled
+        x -> error $ "Input can't use " ++ show x ++ " as a source"
     where
     convertSem O.SemPosition = GL.VertexArray
     convertSem O.SemNormal   = GL.NormalArray
     convertSem O.SemVertex   = GL.VertexArray  -- hmmm
     convertSem O.SemTexCoord = GL.TextureCoordArray
 
 compilePrimitive :: O.Primitive -> CompileM (DrawM ())
-compilePrimitive (O.PrimTriangles _material inputs indices) = do
+compilePrimitive prim@(O.PrimTriangles _material inputs indices) = do
+    debug prim
     case inputs of
         [inp] -> do
             inpinit <- compileInput inp 
             liftIO $ do
                 let numindices = fromIntegral (length indices)
-                ixarray :: Ptr GL.GLfloat <- liftIO . Array.newArray $ map fromIntegral indices
-                return $ do
+                ixarray :: Ptr GL.GLuint <- liftIO . Array.newArray $ map fromIntegral indices
+                return . preservingClientState $ do
                     inpinit
-                    liftIO $ GL.drawElements GL.Triangles numindices GL.Float ixarray
+                    liftIO $ GL.drawElements GL.Triangles numindices GL.UnsignedInt ixarray
 
         _ -> return (return ())  -- only handling one input for now
                                  -- more requires copying because OpenGL is not cool enough
 
 compileGeometry :: O.Object -> CompileM (DrawM ())
-compileGeometry (O.OGeometry (O.Mesh prims)) = do
+compileGeometry geom@(O.OGeometry (O.Mesh prims)) = do
+    debug geom
     cprims <- mapM compilePrimitive prims
     return $ sequence_ cprims
 
 compileNode :: O.Node -> CompileM (DrawM ())
-compileNode (O.Node (O.Matrix matrix) instances) = do
+compileNode node@(O.Node (O.Matrix matrix) instances) = do
+    debug node
     mat :: GL.GLmatrix GL.GLfloat <- liftIO $ GL.newMatrix GL.RowMajor matrix 
     instances' <- mapM compileNodeInstance instances
     return . preservingMatrix $ liftIO (GL.multMatrix mat) >> sequence_ instances'
 
 compileNodeInstance :: O.NodeInstance -> CompileM (DrawM ())
-compileNodeInstance (O.NINode ref) = compileNodeRef ref
-compileNodeInstance (O.NIGeometry geom _materials) = compileGeometry =<< findSymbol geom 
+compileNodeInstance ni@(O.NINode ref) = debug ni >> compileNodeRef ref
+compileNodeInstance ni@(O.NIGeometry geom _materials) = debug ni >> (compileGeometry =<< findSymbol geom)
 
 compileNodeRef :: O.NodeRef -> CompileM (DrawM ())
-compileNodeRef (O.NRNode node) = compileNode node
-compileNodeRef (O.NRInstance nodeid) = compileNodeObject =<< findSymbol nodeid
+compileNodeRef nr@(O.NRNode node) = debug nr >> compileNode node
+compileNodeRef nr@(O.NRInstance nodeid) = debug nr >> (compileNodeObject =<< findSymbol nodeid)
 
 compileNodeObject :: O.Object -> CompileM (DrawM ())
 compileNodeObject (O.ONode node) = compileNode node
 compileNodeObject _ = error "Not a node"
 
 compileVisualScene :: O.Object -> CompileM (DrawM ())
-compileVisualScene (O.OVisualScene noderefs) = return . sequence_ =<< mapM compileNodeRef noderefs
+compileVisualScene scene@(O.OVisualScene noderefs) = do
+    debug scene
+    sequence_ <$> mapM compileNodeRef noderefs

sample.hs

@@ -0,0 +1,31 @@
+import qualified Graphics.Formats.Collada.Render as Collada
+import qualified Graphics.Formats.Collada.Objects as Collada
+import qualified Graphics.UI.GLUT as GLUT
+import qualified Graphics.Rendering.OpenGL.GL as GL
+import qualified Graphics.Rendering.OpenGL.GLU as GLU
+import Control.Applicative
+
+main = do
+    GLUT.getArgsAndInitialize
+    GLUT.createWindow "Hello!"
+
+    Just model <- Collada.parseCollada <$> getContents
+    action <- Collada.compile model
+
+    GL.lighting GL.$= GL.Enabled
+    GL.light (GL.Light 0) GL.$= GL.Enabled
+    GL.position (GL.Light 0) GL.$= GL.Vertex4 0 0 0 1
+
+    GLUT.displayCallback GLUT.$= (do
+        GL.clearColor GL.$= GL.Color4 0.2 0 0 0
+        GL.clear [GL.ColorBuffer, GL.DepthBuffer]
+        GL.preservingMatrix $ do
+            GL.matrixMode GL.$= GL.Projection
+            GL.loadIdentity
+            GLU.perspective 45 1 1 10000
+            GL.matrixMode GL.$= GL.Modelview 0
+            GL.loadIdentity
+            GLU.lookAt (GL.Vertex3 0 200 0) (GL.Vertex3 120 0 0) (GL.Vector3 1 0 0)
+            action
+        GLUT.swapBuffers)
+    GLUT.mainLoop