packages feed

graphics-formats-collada (empty) → 0.1.0

raw patch · 7 files changed

+691/−0 lines, 7 filesdep +OpenGLdep +basedep +bitmap-openglsetup-changed

Dependencies added: OpenGL, base, bitmap-opengl, containers, ghc-prim, hxt, stb-image, transformers

Files

+ Graphics/Formats/Collada.hs view
@@ -0,0 +1,34 @@+module Graphics.Formats.Collada +    ( Config(..), load, defaultConfig, pathTextureLoader )+where++import qualified Graphics.Rendering.OpenGL.GL as GL+import Graphics.Formats.Collada.Objects+import Graphics.Formats.Collada.Render+import qualified Codec.Image.STB as Image+import qualified Data.Bitmap.OpenGL as Bitmap++data Config = Config {+    textureLoader :: String -> IO GL.TextureObject+}++load :: Config -> String -> IO (IO ())+load config contents = do+    case parseCollada contents of+        Nothing -> fail "Parse error"+        Just (mainid, dict) -> compile dict (textureLoader config) mainid++defaultConfig :: Config+defaultConfig = Config {+    textureLoader = pathTextureLoader "."+}++-- | Takes a prefix and returns a texture loader that prepends the prefix to the path+-- and loads from disk.+pathTextureLoader :: String -> String -> IO GL.TextureObject+pathTextureLoader prefix path = do+    let loc = prefix ++ "/" ++ path+    e <- Image.loadImage loc+    case e of+        Left err -> fail $ "Couldn't load " ++ loc ++ ": " ++ err+        Right bmp -> Bitmap.makeSimpleBitmapTexture bmp
+ Graphics/Formats/Collada/Objects.hs view
@@ -0,0 +1,251 @@+module Graphics.Formats.Collada.Objects+    ( Dict, ID+    , Object(..), Matrix(..)+    , Accessor(..), Input(..), InputSemantic(..), Primitive(..)+    , Mesh(..), Parameter(..), Technique(..)+    , ColorOrTexture(..), Node(..), NodeRef(..), NodeInstance(..)+    , MaterialBinding(..), parseCollada+    )+where++import Prelude hiding ((.), id)+import qualified Text.XML.HXT.Arrow as X+import qualified Text.XML.HXT.Arrow.ParserInterface as X+import qualified Control.Arrow.ListArrow as LA+import qualified Graphics.Rendering.OpenGL.GL as GL+import qualified Data.Map as Map+import Data.Maybe (listToMaybe)+import Control.Category+import Control.Arrow+import Foreign.Ptr+import Foreign.Marshal.Array+import Data.List++type Dict = Map.Map ID Object+type ID = String++data Object+    = OVisualScene [NodeRef]+    | OFloatArray [GL.GLfloat]+    | OSource Accessor+    | OVertices [Input]+    | OGeometry Mesh+    | OImage FilePath+    | OParam Parameter+    | OEffect Technique+    | OMaterial ID -- instance_effect+    | ONode Node+    deriving Show++data Matrix+    = Matrix [GL.GLfloat]+    deriving Show++identityMatrix :: Matrix+identityMatrix = Matrix [ 1, 0, 0, 0+                        , 0, 1, 0, 0+                        , 0, 0, 1, 0+                        , 0, 0, 0, 1 ]++data Accessor+    = Accessor ID Int Int Int Int -- array components count stride offset+    deriving Show++data Input+    = Input Int InputSemantic ID -- offset semantic source+    deriving Show++data InputSemantic+    = SemPosition+    | SemNormal+    | SemVertex+    | SemTexCoord+    deriving (Eq,Show)++data Primitive+    = PrimTriangles String [Input] [Int]  -- material inputs indices+    deriving Show++data Mesh = Mesh [Primitive]+    deriving Show++data Parameter+    = ParamSurface2D ID+    | ParamSampler2D ID+    deriving Show++data Technique+    = TechLambert ColorOrTexture -- diffuse+    | TechConstant ColorOrTexture GL.GLfloat -- transparent transparency+    deriving Show++data ColorOrTexture+    = COTColor GL.GLfloat GL.GLfloat GL.GLfloat GL.GLfloat+    | COTTexture ID String   -- source texcoord+    deriving Show++data Node+    = Node Matrix [NodeInstance]+    deriving Show++data NodeRef+    = NRNode Node+    | NRInstance ID+    deriving Show++data NodeInstance+    = NINode NodeRef+    | NIGeometry ID [MaterialBinding]+    deriving Show++data MaterialBinding+    = MaterialBinding String ID String String -- symbol target semantic input_semantic+    deriving Show++parseCollada :: String -> Maybe (ID, Dict)+parseCollada = listToMaybe . LA.runLA (mainA <<< X.parseXmlDoc <<^ (\x -> ("<stdin>", x)))++mainA :: LA.LA X.XmlTree (ID, Dict)+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 = refAttr "url" <<< child (X.hasName "instance_visual_scene") <<< child (X.hasName "scene")++asum = foldr1 (X.<+>)++objectWithIDAttr :: String -> String -> LA.LA X.XmlTree Object -> LA.LA X.XmlTree Dict+objectWithIDAttr attr name proc = uncurry Map.singleton ^<< (X.getAttrValue0 attr &&& proc) . X.hasName name++object :: String -> LA.LA X.XmlTree Object -> LA.LA X.XmlTree Dict+object = objectWithIDAttr "id"++float_array :: LA.LA X.XmlTree Dict+float_array = object "float_array" $ toArray ^<< X.getText . X.getChildren+    where+    toArray = OFloatArray . map read . words++accessor :: LA.LA X.XmlTree Accessor+accessor = massage ^<< (length .< child (X.hasName "param")) &&& refAttr "source" &&& X.getAttrValue0 "count" &&& X.getAttrValue "stride" &&& X.getAttrValue "offset" <<< X.hasName "accessor"+    where+    massage (len, (source, (count, (stride, offset)))) = Accessor source len (read count) (readDef len stride) (readDef 0 offset)++readDef d "" = d+readDef _ s  = read s++child n = n <<< X.getChildren++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" &&& 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+    massageSemantic "NORMAL"   = SemNormal+    massageSemantic "VERTEX"   = SemVertex+    massageSemantic "TEXCOORD" = SemTexCoord+    massageSemantic s = error $ "Unknown semantic: " ++ s++vertices :: LA.LA X.XmlTree Dict+vertices = object "vertices" $ OVertices . fixups .< child input+    where+    fixups = zipWith fixup [0..]+    fixup n (Input z sem source) | z == -1 = Input n sem source+                                 | otherwise = Input z sem source+++triangles :: LA.LA X.XmlTree Primitive+triangles = massage ^<< X.getAttrValue "material" &&& procBody <<< X.hasName "triangles"+    where+    procBody = (id .< child input) &&& (map read . words ^<< child X.getText <<< child (X.hasName "p"))+    massage (material, (inputs, p)) = PrimTriangles material inputs p++mesh :: LA.LA X.XmlTree Mesh+mesh = (Mesh .< child primitives) <<< X.hasName "mesh"+    where+    primitives = asum [ triangles ]++geometry :: LA.LA X.XmlTree Dict+geometry = object "geometry" $ OGeometry ^<< child mesh++image :: LA.LA X.XmlTree Dict+image = object "image" $ OImage ^<< child X.getText <<< child (X.hasName "init_from")++newparam :: LA.LA X.XmlTree Dict+newparam = objectWithIDAttr "sid" "newparam" $ OParam ^<< asum [surface, sampler2D] <<< X.getChildren+    where+    surface = ParamSurface2D ^<< child X.getText <<< child (X.hasName "init_from") <<< X.hasAttrValue "type" (== "2D") <<< X.hasName "surface"+    sampler2D = ParamSampler2D ^<< child X.getText <<< child (X.hasName "source") <<< X.hasName "sampler2D"++colorOrTexture :: LA.LA X.XmlTree ColorOrTexture+colorOrTexture = texture X.<+> color+    where+    texture = uncurry COTTexture ^<< X.getAttrValue0 "texture" &&& X.getAttrValue0 "texcoord" <<< X.hasName "texture"+    color = colorify . map read . words ^<< child X.getText <<< X.hasName "color"+    colorify [r,g,b,a] = COTColor r g b a+    colorify s = error "Malformed color"++lambert :: LA.LA X.XmlTree Technique+lambert = TechLambert ^<< child colorOrTexture <<< child (X.hasName "diffuse") <<< X.hasName "lambert"++constant :: LA.LA X.XmlTree Technique+constant = uncurry TechConstant ^<< (child colorOrTexture <<< child (X.hasName "transparent")) &&& (read ^<< child (X.getText) <<< child (X.hasName "float") <<< child (X.hasName "transparency")) <<< X.hasName "constant"++technique :: LA.LA X.XmlTree Technique+technique = asum [lambert, constant] <<< X.getChildren <<< X.hasName "technique"++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 ^<< refAttr "url" <<< child (X.hasName "instance_effect")++nodeRef :: LA.LA X.XmlTree NodeRef+nodeRef = asum [inline, instance_node] +    where+    inline = (arr NRInstance ||| (NRNode ^<< rawNode)) <<< switch <<< X.hasName "node"+    switch = convid ^<< X.getAttrValue "id" &&& id+    convid ("", xml) = Right xml+    convid (x, _)    = Left x++instance_node :: LA.LA X.XmlTree NodeRef+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 ^<< refAttr "url" &&& bindings <<< X.hasName "instance_geometry"+    where+    bindings = id .< (child instance_material <<< child (X.hasName "technique_common") <<< child (X.hasName "bind_material"))++matrix :: LA.LA X.XmlTree Matrix+matrix = Matrix . map read . words ^<< child X.getText <<< X.hasName "matrix"++rawNode :: LA.LA X.XmlTree Node+rawNode = uncurry Node ^<< (child matrix `X.withDefault` identityMatrix) &&& (id .< child nodeInstance) <<< X.hasName "node"++node :: LA.LA X.XmlTree Dict+node = object "node" $ ONode ^<< rawNode++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" &&& refAttr "target"+    bindAttrs = X.getAttrValue0 "semantic" &&& X.getAttrValue0 "input_semantic" <<< child (X.hasName "bind_vertex_input")++visual_scene :: LA.LA X.XmlTree Dict+visual_scene = object "visual_scene" $ OVisualScene ^<< id .< child nodeRef
+ Graphics/Formats/Collada/Render.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, PatternGuards, RecursiveDo #-}++module Graphics.Formats.Collada.Render +    ( compile )+where++import qualified Graphics.Rendering.OpenGL.GL as GL+import qualified Graphics.Formats.Collada.Objects as O+import qualified Data.Map as Map+import qualified Foreign.Marshal.Array as Array+import qualified Foreign.Storable as Storable+import Foreign.Ptr (Ptr)+import Data.Monoid (Monoid(..))+import Control.Arrow (second)+import Control.Applicative+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import Control.Monad.Trans+import Control.Monad (when, forM_, liftM2, liftM3)+import GHC.Prim (Any)+import Unsafe.Coerce (unsafeCoerce)++newtype DrawM a = DrawM { runDrawM :: IO a }+    deriving (Functor, Applicative, Monad, MonadIO)++wrapDrawM :: (IO a -> IO a) -> (DrawM a -> DrawM a)+wrapDrawM f = DrawM . f . runDrawM++type Bindings = Map.Map String (DrawM ())++type Cache = Map.Map O.ID Any++data CompileEnv = CompileEnv {+    envDict :: O.Dict,+    envBindings :: Bindings,+    envLoader :: String -> IO GL.TextureObject+}++newtype CompileM a = CompileM { runCompileM :: ReaderT CompileEnv (StateT Cache IO) a }+    deriving (Functor, Applicative, Monad, MonadIO)++cached :: (O.Object -> CompileM a) -> (O.ID -> CompileM a)+cached f ident = CompileM $ do+    cache <- lift get+    case Map.lookup ident cache of+        Nothing -> mdo+            lift . modify . Map.insert ident . unsafeCoerce $ result+            result <- runCompileM $ f =<< findSymbol ident+            return result+        Just result -> return (unsafeCoerce result)++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 sym = CompileM $ asks (lookup' sym . envDict)++findBinding :: String -> CompileM (DrawM ())+findBinding sym = CompileM $ asks (lookup' sym . envBindings)++addBindings :: Bindings -> CompileM a -> CompileM a+addBindings bindings = CompileM . local addBinding . runCompileM+    where+    addBinding env = env { envBindings = envBindings env `Map.union` bindings }++loadTexture :: String -> CompileM GL.TextureObject+loadTexture s = CompileM $ liftIO . ($ s) =<< asks envLoader++compile :: O.Dict -> (String -> IO (GL.TextureObject)) -> O.ID -> IO (IO ())+compile dict loader mainid = do+    runDrawM <$> evalStateT (runReaderT (runCompileM (compileVisualScene mainid)) initEnv) Map.empty+    where+    initEnv = CompileEnv { envDict = dict, envBindings = Map.empty, envLoader = loader }++compileArray :: O.ID -> CompileM (Ptr GL.GLfloat)+compileArray = cached go+    where+    go (O.OFloatArray xs) = liftIO $ Array.newArray xs+    go _ = error "Not an array"++floatSize = Storable.sizeOf (undefined :: GL.GLfloat)++compileAccessor :: O.Accessor -> CompileM (GL.VertexArrayDescriptor GL.GLfloat)+compileAccessor (O.Accessor arrayid components count stride offset) = do+    ptr <- compileArray arrayid+    let ptr' = Array.advancePtr ptr offset+    return $ GL.VertexArrayDescriptor (fromIntegral components) GL.Float byteStride ptr'+    where+    byteStride = fromIntegral $ Storable.sizeOf floatSize * (stride - components)+++indexDescriptor :: GL.VertexArrayDescriptor GL.GLfloat -> Int -> Int -> IO GL.GLfloat+indexDescriptor (GL.VertexArrayDescriptor components _ stride ptr) = \ix off ->+    Storable.peekByteOff ptr (step * ix + floatSize * off)+    where+    step = fromIntegral stride + floatSize * fromIntegral components++data CompiledInput = CompiledInput { ciSetupArrays :: DrawM (), ciIndex :: Int -> DrawM () }++instance Monoid CompiledInput where+    mempty = CompiledInput (return ()) (const (return ()))+    mappend a b = CompiledInput { ciSetupArrays = ciSetupArrays a >> ciSetupArrays b+                                , ciIndex = \z -> ciIndex a z >> ciIndex b z +                                }++compileInput :: O.Input -> CompileM CompiledInput+compileInput (O.Input _ semantic source) = do+    sym <- findSymbol source+    case sym of+        O.OVertices inputs -> mconcat <$> mapM compileInput inputs+        O.OSource acc -> do+            descriptor <- compileAccessor acc+            let sem = convertSem semantic+            let setupArrays = liftIO $ do+                    GL.arrayPointer sem GL.$= descriptor+                    GL.clientState sem GL.$= GL.Enabled+            let ind = indexDescriptor descriptor +            let index = case sem of+                            GL.VertexArray -> \z -> liftIO $ GL.vertex =<< liftM3 GL.Vertex3 (ind z 0) (ind z 1) (ind z 2)+                            GL.NormalArray -> \z -> liftIO $ GL.normal =<< liftM3 GL.Normal3 (ind z 0) (ind z 1) (ind z 2)+                            GL.TextureCoordArray -> \z -> liftIO $ GL.texCoord =<< liftM2 GL.TexCoord2 (ind z 0) (ind z 1)+                            x -> error $ "Don't know how to index a " ++ show x+            return $ CompiledInput setupArrays index+            +                    +        x -> error $ "Input can't use " ++ show x ++ " as a source"+    where+    convertSem O.SemPosition = GL.VertexArray+    convertSem O.SemNormal   = GL.NormalArray+    convertSem O.SemTexCoord = GL.TextureCoordArray+    conversion sem = error $ "Unknown semantic: " ++ show sem++compilePrimitive :: O.Primitive -> CompileM (DrawM ())+compilePrimitive (O.PrimTriangles material inputs indices) = do+    mat <- findBinding material+    case inputs of+        [inp] -> do  -- fast single-input+            compiled <- compileInput inp +            liftIO $ do+                let numindices = fromIntegral (length indices)+                ixarray :: Ptr GL.GLuint <- liftIO . Array.newArray $ map fromIntegral indices+                return . wrapDrawM (GL.preservingClientAttrib [GL.AllClientAttributes]) $ do+                    mat+                    ciSetupArrays compiled+                    liftIO $ GL.drawElements GL.Triangles numindices GL.UnsignedInt ixarray+        +        inps -> do   -- slow multi-input  (should copy to a new vertex array instead)+            compiled <- Map.fromListWith mappend <$> mapM (\inp@(O.Input i _ _) -> ((,) i) <$> compileInput inp) inps+            let (maxE,example) = Map.findMax compiled+            return . (mat >>) . wrapDrawM (GL.renderPrimitive GL.Triangles) . forM_ (zip (cycle [0..maxE]) indices) $ \(inpix,ix) -> do+                ciIndex (Map.findWithDefault mempty inpix compiled) ix+            ++compileGeometry :: O.ID -> CompileM (DrawM ())+compileGeometry = cached go+    where+    go (O.OGeometry (O.Mesh prims)) = do+        cprims <- mapM compilePrimitive prims+        return $ sequence_ cprims+    go _ = error "Not a geometry"++compileNode :: O.Node -> CompileM (DrawM ())+compileNode (O.Node (O.Matrix matrix) instances) = do+    mat :: GL.GLmatrix GL.GLfloat <- liftIO $ GL.newMatrix GL.RowMajor matrix +    instances' <- mapM compileNodeInstance instances+    return . wrapDrawM GL.preservingMatrix $ liftIO (GL.multMatrix mat) >> sequence_ instances'++compileNodeInstance :: O.NodeInstance -> CompileM (DrawM ())+compileNodeInstance (O.NINode ref) = compileNodeRef ref+compileNodeInstance (O.NIGeometry geom materials) = do+    materials' <- Map.unions <$> mapM compileMaterialBinding materials+    addBindings materials' $ compileGeometry geom++compileNodeRef :: O.NodeRef -> CompileM (DrawM ())+compileNodeRef (O.NRNode node) = compileNode node+compileNodeRef (O.NRInstance nodeid) = compileNodeObject nodeid++compileNodeObject :: O.ID -> CompileM (DrawM ())+compileNodeObject = cached go+    where+    go (O.ONode node) = compileNode node+    go _ = error "Not a node"++compileVisualScene :: O.ID -> CompileM (DrawM ())+compileVisualScene = cached go+    where+    go (O.OVisualScene noderefs) = do+        sequence_ <$> mapM compileNodeRef noderefs+    go _ = error "Not a visual scene"++compileImage :: O.ID -> CompileM GL.TextureObject+compileImage = cached go+    where+    go (O.OImage path) = loadTexture path+    go _ = error "not an image"++compileEffect :: O.ID -> CompileM (DrawM ())+compileEffect = cached go+    where+    go (O.OEffect (O.TechLambert cot)) = lambert cot+    go (O.OEffect (O.TechConstant cot alpha)) = go (O.OEffect (O.TechLambert cot)) -- XXX Hax+    go (O.OMaterial ident) = compileEffect ident+    go x = error $ "Not an effect: " ++ show x+    +    lambert (O.COTColor r g b a) = return . liftIO $ do+        GL.texture GL.Texture2D GL.$= GL.Disabled+        GL.colorMaterial GL.$= Just (GL.Front, GL.Diffuse)+        GL.color $ GL.Color4 r g b a+    lambert (O.COTTexture source _texcoord) = do+        texobj <- compileParameter source+        return . liftIO $ do+            GL.colorMaterial GL.$= Just (GL.Front, GL.Diffuse)+            GL.texture GL.Texture2D GL.$= GL.Enabled+            GL.textureBinding GL.Texture2D GL.$= Just texobj++compileParameter :: O.ID -> CompileM GL.TextureObject+compileParameter = cached go+    where+    go (O.OParam (O.ParamSurface2D img)) = compileImage img+    go (O.OParam (O.ParamSampler2D surf)) = compileParameter surf+    go _ = error "Not a param"++compileMaterialBinding :: O.MaterialBinding -> CompileM Bindings+compileMaterialBinding (O.MaterialBinding sym target _ _) = do+    targetE <- compileEffect target+    return $ Map.singleton sym targetE
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Luke Palmer++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 Luke Palmer nor the names of other+      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
+ graphics-formats-collada.cabal view
@@ -0,0 +1,74 @@+-- graphics-formats-collada.cabal auto-generated by cabal init. For+-- additional options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name:                graphics-formats-collada++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version:             0.1.0++-- A short (one-line) description of the package.+Synopsis:            Load 3D geometry in the COLLADA format++-- A longer description of the package.+Description:+    Early in development.  Should be able to load anything that Google SketchUp+    produces -- other than that, all bets are off.++-- URL for the project homepage or repository.+Homepage:            http://github.com/luqui/collada++-- The license under which the package is released.+License:             BSD3++-- The file containing the license text.+License-file:        LICENSE++-- The package author(s).+Author:              Luke Palmer++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer:          lrpalmer@gmail.com++-- A copyright notice.+-- Copyright:           ++Category:            Graphics++Build-type:          Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+Extra-source-files:  sample.hs++-- Constraint on the version of Cabal needed to build this package.+Cabal-version:       >=1.6+++Library+  -- Modules exported by the library.+  Exposed-modules:     +    Graphics.Formats.Collada+    Graphics.Formats.Collada.Objects+    Graphics.Formats.Collada.Render+  +  -- Packages needed in order to build this package.+  Build-depends: +    base == 4.*,+    containers,+    transformers == 0.1.*,+    ghc-prim == 0.1.*,+    hxt == 8.5.*,+    OpenGL == 2.4.*, +    stb-image == 0.2.*,+    bitmap-opengl == 0.0.*++  -- Modules not exported by this package.+  -- Other-modules:       +  +  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+  -- Build-tools:         +
+ sample.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TypeFamilies #-}++import qualified Graphics.Formats.Collada 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 System.IO+import Control.Applicative+import Data.VectorSpace+import Data.IORef++instance AdditiveGroup GL.GLdouble where+    zeroV = 0+    (^+^) = (+)+    negateV = negate++instance VectorSpace GL.GLdouble where+    type Scalar GL.GLdouble = GL.GLdouble+    (*^) = (*)++instance InnerSpace GL.GLdouble where+    (<.>) = (*)++main = do+    hSetBuffering stdout NoBuffering++    GLUT.initialDisplayMode GL.$= [GLUT.RGBAMode, GLUT.DoubleBuffered, GLUT.WithDepthBuffer]++    GLUT.getArgsAndInitialize+    GLUT.createWindow "Hello!"++    putStrLn "Loading"+    action <- Collada.load Collada.defaultConfig =<< getContents+    putStrLn "Done"++    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+    GL.depthFunc GL.$= Nothing+    GL.depthFunc GL.$= Just GL.Lequal+    GL.depthMask GL.$= GL.Enabled++    GLUT.displayCallback GLUT.$= (do+        GL.clearColor GL.$= GL.Color4 0 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 (uncurry3 GL.Vertex3 eye) (uncurry3 GL.Vertex3 object) (uncurry3 GL.Vector3 up)+            GL.renderPrimitive GL.Lines $ do+                vertex (-200) 0 0+                vertex 200 0 0+                vertex 0 (-200) 0+                vertex 0 200 0+                vertex 0 0 (-200)+                vertex 0 0 200+            action+        GLUT.swapBuffers)+    GLUT.mainLoop++    where+    eye = (200, 200, 200)+    object = (0, 0, 0)+    up = normalized $ (object ^-^ eye) `cross` ((object ^-^ eye) `cross` (0,0,-1))+    cross (bx,by,bz) (cx,cy,cz) = (by*cz - cy*bz, bz*cx - bx*cz, bx*cy - by*cx)++    uncurry3 f (x,y,z) = f x y z++    vertex :: GL.GLfloat -> GL.GLfloat -> GL.GLfloat -> IO ()+    vertex x y z = GL.vertex $ GL.Vertex3 x y z