collada-output (empty) → 0.1
raw patch · 8 files changed
+1031/−0 lines, 8 filesdep +SVGPathdep +Vecdep +basesetup-changed
Dependencies added: SVGPath, Vec, base, containers, haskell98, time, xml
Files
- LICENSE +11/−0
- Setup.hs +3/−0
- collada-output.cabal +31/−0
- src/Examples.hs +10/−0
- src/Graphics/Formats/Collada/Animations.hs +112/−0
- src/Graphics/Formats/Collada/ColladaTypes.hs +265/−0
- src/Graphics/Formats/Collada/GenerateCollada.hs +454/−0
- src/Graphics/Formats/Collada/GenerateObjects.hs +145/−0
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright (c) 2010, Tillmann Vogt +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. +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 HOLDER 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,3 @@+#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain
+ collada-output.cabal view
@@ -0,0 +1,31 @@+Name: collada-output +Version: 0.1 +Synopsis: Generate animated 3d objects in COLLADA +Description: Generate a COLLADA file with textures, materials, animations, ...+category: graphics +License: BSD3 +License-file: LICENSE +Author: Tillmann Vogt +Maintainer: Tillmann.Vogt@rwth-aachen.de +Build-Type: Simple +Cabal-Version: >=1.6 ++Library+ hs-source-dirs: src + build-depends: + haskell98, + base == 4.*, + xml == 1.3.*, + containers == 0.3.*, + Vec == 0.9.7, + time == 1.1.*, + SVGPath == 1.0.* + exposed-modules: + Graphics.Formats.Collada.ColladaTypes + Graphics.Formats.Collada.Animations + Graphics.Formats.Collada.GenerateCollada + Graphics.Formats.Collada.GenerateObjects ++Executable Examples+ hs-source-dirs: src+ Main-is: Examples.hs
+ src/Examples.hs view
@@ -0,0 +1,10 @@+module Main where + +import Graphics.Formats.Collada.ColladaTypes +import Graphics.Formats.Collada.GenerateCollada +import Graphics.Formats.Collada.GenerateObjects + +main :: IO () +main = genCollada (standardAsset " Haskell Programmer " " My Tool ") + animatedCubes + --animatedCube
+ src/Graphics/Formats/Collada/Animations.hs view
@@ -0,0 +1,112 @@+module Graphics.Formats.Collada.Animations (attr, library_animations, animations, collada_array) where +import Text.XML.Light +import Graphics.Formats.Collada.ColladaTypes + +attr :: String -> String -> (Element -> Element) +attr key value = add_attr (Attr (unqual key) value) + +library_animations :: [(SID, AnimChannel)] -> [Element] +library_animations anims | (length as) > 0 = [unode "library_animations" $ as] + | otherwise = [] + where as = map animations anims + +animations :: (SID, AnimChannel) -> Element +animations (sid,(Bezier (inID,inFloat,inAccessor) + (outID,outFloat,outAccessor) + (intangentID,intangentFloat,intangentAccessor) + (outtangentID,outtangentFloat,outtangentAccessor) + (interpID,interpString,interpAccessor) + targets )) = + attr "id" sid $ unode "animation" $ + [ anim_source_input (sid ++ "-" ++ inID) inFloat inAccessor, + anim_source_output (sid ++ "-" ++ outID) outFloat outAccessor, + anim_source_intangents (sid ++ "-" ++ intangentID) intangentFloat intangentAccessor, + anim_source_outtangents (sid ++ "-" ++ outtangentID) outtangentFloat outtangentAccessor, + anim_source_interpolations (sid ++ "-" ++ interpID) interpString interpAccessor, + anim_source_sampler sid inID outID intangentID outtangentID interpID + ] + ++ (map (anim_source_channel sid) targets) + +accessor acc = map (foldr (\(x,y) -> (attr x y)) (unode "param" "")) acc + +collada_array list = concat (map (++" ") (map show list)) + +anim_source_input str ar acc = + attr "id" str $ unode "source" + [ attr "id" (str ++ "-array") $ + attr "count" (show (length ar)) $ + unode "float_array" (collada_array ar), + unode "technique_common" $ + attr "source" ("#" ++ str ++ "-array") $ + attr "count" (show (length ar)) $ + attr "stride" "1" $ + unode "accessor" $ accessor acc + ] + +anim_source_output str ar acc = attr "id" str $ unode "source" + [ attr "id" (str ++ "-array") $ + attr "count" (show (length ar)) $ + unode "float_array" (collada_array ar), + unode "technique_common" $ + attr "source" ("#" ++ str ++ "-array") $ + attr "count" (show (length ar)) $ + attr "stride" "1" $ + unode "accessor" $ accessor acc + ] + +anim_source_intangents str ar acc = + attr "id" str $ unode "source" + [ attr "id" (str ++ "-array") $ + attr "count" (show (length ar)) $ + unode "float_array" (collada_array ar), + unode "technique_common" $ + attr "source" ("#" ++ str ++ "-array") $ + attr "count" (show ((length ar)`div`2)) $ + attr "stride" "2" $ + unode "accessor" $ accessor acc + ] + +anim_source_outtangents str ar acc = + attr "id" str $ unode "source" + [ attr "id" (str ++ "-array") $ + attr "count" (show (length ar)) $ + unode "float_array" (collada_array ar), + unode "technique_common" $ + attr "source" ("#" ++ str ++ "-array") $ + attr "count" (show ((length ar)`div`2)) $ + attr "stride" "2" $ + unode "accessor" $ accessor acc + ] + +anim_source_interpolations str ar acc = + attr "id" str $ unode "source" + [ attr "id" (str ++ "-array") $ + attr "count" (show (length ar)) $ + unode "Name_array" (concat ar), + unode "technique_common" $ + attr "source" ("#" ++ str ++ "-array") $ + attr "count" (show (length ar)) $ + attr "stride" "1" $ + unode "accessor" $ accessor acc + ] + +anim_source_sampler str inID outID intangentID outtangentID interpID = + attr "id" (str ++ "-sampler") $ + unode "sampler" + [ + attr "semantic" "INPUT" $ attr "source" ("#" ++ str ++ "-" ++ inID) $ + unode "input" (), + attr "semantic" "OUTPUT" $ attr "source" ("#" ++ str ++ "-" ++ outID) $ + unode "input" (), + attr "semantic" "IN_TANGENT" $ attr "source" ("#" ++ str ++ "-" ++ intangentID) $ + unode "input" (), + attr "semantic" "OUT_TANGENT" $ attr "source" ("#" ++ str ++ "-" ++ outtangentID) $ + unode "input" (), + attr "semantic" "INTERPOLATION" $ attr "source" ("#" ++ str ++ "-" ++ interpID) $ + unode "input" () + ] + +anim_source_channel s0 (targetID,accessorName) = + attr "source" ("#" ++ s0 ++ "-sampler") $ + attr "target" (targetID ++ "." ++ accessorName) $ + unode "channel" ()
+ src/Graphics/Formats/Collada/ColladaTypes.hs view
@@ -0,0 +1,265 @@+-- some of the Types are from http://hackage.haskell.org/package/GPipe-Collada +-- adopted for possible future combination + +module Graphics.Formats.Collada.ColladaTypes +( + Scene, + SceneNode(..), NodeType(..), + Transform(..), + Camera(..), + ViewSize(..), + Z(..), + + Light(..), + Attenuation(..), + Controller(..), + + Geometry(..), + Mesh(..), + Vertices(..), + LinePrimitive(..), Polygon(..), + -- Polylist(..), Spline(..), TriangleMesh(..), TriFan(..), TriStrip(..), + AnimChannel(..), + ID, SID, + Semantic, + Profile(..), NewParam(..), TechniqueCommon(..), Material, Effect, + C(..), Color(..), + Animations(..), + Fx_common_color_type(..), Fx_common_texture_type(..), Texture(..) +) +where + +import Data.Tree +import qualified Data.Vec as Vec +import Data.Vec (Vec2, Vec3, Mat44, Mat33, (:.)(..), ) + +type Scene = Tree SceneNode + +data SceneNode = SceneNode { + nodeId :: ID, + nodeType :: NodeType, + nodeLayers :: [String], + nodeTransformations :: [(SID, Transform)], + nodeCameras :: [Camera], + nodeController :: [Controller], + nodeGeometries :: [Geometry], + nodeLights :: [Light] + } +-- deriving (Show) + + +data NodeType = JOINT | NODE | NOTYPE deriving (Show) + +data Transform = LookAt { + lookAtEye:: Vec3 Float, + lookAtInterest :: Vec3 Float, + lookAtUp :: Vec3 Float + } + | Matrix (Mat44 Float) + | Rotate (Vec3 Float) Float (Vec3 Float) Float (Vec3 Float) Float + | Scale (Vec3 Float) + | Skew { + skewAngle :: Float, + skewRotation :: Vec3 Float, + skewTranslation :: Vec3 Float + } + | Translate (Vec3 Float) + deriving (Show, Eq) + +data Camera = Perspective { + perspectiveID :: ID, + perspectiveFov :: ViewSize, + perspectiveZ :: Z + } + | Orthographic { + orthographicID :: ID, + orthographicViewSize :: ViewSize, + orthographicZ :: Z + } + deriving (Show, Eq) + +data ViewSize = ViewSizeX Float + | ViewSizeY Float + | ViewSizeXY (Float,Float) + deriving (Show, Eq) + +data Z = Z { + zNear :: Float, + zFar :: Float + } + deriving (Show, Eq) + +data Light = Ambient { + ambientID :: ID, + ambientColor :: Color + } + | Directional { + directionalID :: ID, + directionalColor :: Color + } + | Point { + pointID :: ID, + pointColor :: Color, + pointAttenuation :: Attenuation + } + | Spot { + spotID :: ID, + spotColor :: Color, + spotAttenuation :: Attenuation, + spotFallOffAngle :: Float, + spotFallOffExponent :: Float + } + deriving (Show, Eq) + +data Attenuation = Attenuation { + attenuationConstant :: Float, + attenuationLinear :: Float, + attenuationQuadratic :: Float + } + deriving (Show, Eq) + +data Controller = Controller { + contrId :: ID, + skin :: [Skin], + morph :: [Morph] + } + deriving (Show) + +data Skin = Skin { + bindShapeMatrix :: [Mat44 Float], + source :: [String], + joint :: [Joint], + vertexWeights :: String + } + deriving (Show) + +data Morph = Morph { + geometrySource :: String, + method :: MorphMethod, + morphSource :: String, + morphTargets :: [Input] + } + deriving (Show) + +data MorphMethod = Normalized | Relative deriving (Show) + +data Joint = Joint { + jointID :: String, + prismatic :: Prismatic, + revolute :: Revolute + } + deriving (Show) + +type Prismatic = String +type Revolute = String + +data Input = Input { + offset :: Int, + semantic :: Semantic, + inputSource :: String, + set :: Int + } + deriving (Show) + +data Semantic = BINORMAL | COLOR | CONTINUITY | IMAGE | INPUT | IN_TANGENT | INTERPOLATION | + INV_BIND_MATRIX | ISJOINT | LINEAR_STEPS | MORPH_TARGET | MORPH_WEIGHT | + NORMAL | OUTPUT | OUT_TANGENT | POSITION | TANGENT | TEXBINORMAL | + TEXCOORD | TEXTANGENT | UV | VERTEX | WEIGHT + deriving (Show) + +data Geometry = Geometry { + meshID :: ID, +-- convexMesh :: [Mesh], + mesh :: [Mesh], + vertices :: Vertices +-- splines :: [Spline], +-- breps :: [Brep] + } +-- deriving (Show) + +instance Eq Geometry where + (Geometry mid1 _ _) == (Geometry mid2 _ _) = mid1 == mid2 + +data Mesh = LP LinePrimitive | LS LinePrimitive | P Polygon | PL LinePrimitive | + Tr LinePrimitive | Trf LinePrimitive | Trs LinePrimitive | S LinePrimitive + +data Vertices = Vertices { + name :: ID, + verts :: [(Float,Float,Float)], + normals :: [(Float,Float,Float)] + } + +data LinePrimitive = LinePrimitive { + lineP :: [[Int]], + lineN :: [[Int]], + ms :: [Material] + } + +data Polygon = Polygon { + poylgonP :: [[Int]], + poylgonN :: [[Int]], + polygonPh :: ([Int],[Int]), -- (indices, indices of a hole) + polygonMs :: [Material] + } + +type Material = (SID,Effect) + +type Effect = Profile -- (ID,Profile) + +type Animations = Tree (SID, AnimChannel) + +data AnimChannel = Bezier { + -- these 5 items are called sampler in Collada + -- we don't need the modularity to define everyone seperately + input :: (ID,[Float],Accessor) , -- Accessor: "TIME" + output :: (ID,[Float],Accessor), + intangent :: (ID,[Float],Accessor), -- for bezier curves: smooth values at the beginnig transition + outtangent :: (ID,[Float],Accessor), -- end + interpolation :: (ID,[String],Accessor), + -- target channels in Collada + targets :: [(TargetID,AccessorName)] -- transfer values to several objects + } + +type TargetID = String +type Accessor = [[(AccessorName, AccessorType)]] +type AccessorName = String +type AccessorType = String + +data Profile = BRIDGE Asset Extra | + CG Asset Code Include NewParam TechniqueCG Extra | + COMMON Asset NewParam TechniqueCommon String | + GLES Asset NewParam TechniqueCG Extra | + GLES2 Asset Code Include NewParam TechniqueCG Extra | + GLSL Asset Code Include NewParam TechniqueCG Extra + +type Asset = String +type Code = String +type Include = String +data NewParam = Annotate | Semantic | Modifier | NoParam +data TechniqueCommon = Constant | LambertCol [Fx_common_color_type] + | LambertTex [Fx_common_texture_type] + | PhongCol [Fx_common_color_type] + | PhongTex [Fx_common_texture_type] + | Blinn +data TechniqueCG = IsAsset | IsAnnotate | Pass | Extra +data Extra = String -- Asset | Technique +data Technique = Profile -- XML -- | Xmlns Schema +data Fx_common_color_type = CEmission C | CAmbient C | CDiffuse C | CSpecular C | + CShininess Float | CReflective C | CReflectivity Float | + CTransparent C | CTransparency Float | CIndex_of_refraction Float +data Fx_common_texture_type = TEmission Texture | TAmbient Texture | TDiffuse Texture | TSpecular Texture | + TShininess Float | TReflective Texture | TReflectivity Float | + TTransparent Texture | TTransparency Float | TIndex_of_refraction Float + +data C = Color (Float, Float, Float, Float) + +data Texture = Texture { + imageSID :: ID, + path :: String -- ToDo: better type, embedded images + } + + +type ID = String +type SID = String -- Maybe + +data Color = RGB Float Float Float deriving (Eq, Show)
+ src/Graphics/Formats/Collada/GenerateCollada.hs view
@@ -0,0 +1,454 @@+module Graphics.Formats.Collada.GenerateCollada where + +import Text.XML.Light +import System.IO +import System.IO.Unsafe +import Graphics.SVG.ReadPath(bSubCurve) +import Graphics.Formats.Collada.ColladaTypes +import Graphics.Formats.Collada.Animations (attr, library_animations, collada_array) +import Data.Time.Clock +import Data.Time.Calendar +import Data.Time.LocalTime +import Data.Char +import Data.Fixed (div') +import Data.Tree +import Data.List +import Data.Vec (Vec2, Vec3, Mat44, Mat33, (:.)(..), ) + +type Point = (Float,Float,Float) +type Normal = (Float,Float,Float) + +genCollada :: Element -> (Scene, Animations) -> IO () +genCollada asset (sc, anim) = writeFile "../Collada-File.dae" $ + ppTopElement (basicFrame asset (sc, anim)) +-- | the basic structure of a Collada file, contains library_... nodes, where library_s are for referencing +basicFrame :: Element -> (Scene, Animations) -> Element +basicFrame asset (sc, anim) = + attr "xmlns" "http://www.collada.org/2005/11/COLLADASchema" $ attr "version" "1.4.0" $ + unode "COLLADA" $ + [ asset ] ++ +-- , unode "library_animation_clips" $ + (library_animations (flatten anim)) ++ + [ unode "library_cameras"$ concat $ map cam extr_cam + , unode "library_lights" $ concat $ map light extr_light] ++ + (im extr_im) ++ + [ unode "library_materials" $ mat extr_mat + , unode "library_effects" $ eff extr_eff + , unode "library_geometries" $ geo extr_geo +-- , unode "library_controllers" + , unode "library_visual_scenes" (visual_scene sc) + , unode "scene" (scene "VisualSceneNode") +-- , unode "library_formulas" $ +-- , unode "library_nodes" $ +-- , unode "library_physics_materials" $ +-- , unode "library_force_fields" $ +-- , unode "library_physics_models" $ +-- , unode "library_physics_scenes" $ +-- , unode "library_rigid_bodies" $ +-- , unode "library_joints" $ +-- , unode "library_kinematics_models" $ +-- , unode "library_articulated_systems" $ +-- , unode "library_kinematics_scenes" $ + ] + where fs = flatten sc + extr_cam = extract_cameras fs + extr_light = extract_lights fs + extr_im = extr_eff -- images are always part of effects + extr_mat = extr_geo -- geometries have materials + extr_eff = extr_mat -- materials are always effects + extr_geo = extract_geometries fs + +-- | document information: author, time created ... +standardAsset :: String -> String -> Element +standardAsset author tool = unode "asset" + [ unode "contributor" + [ unode "author" author, + unode "authoring_tool" tool, + unode "comments" ""], + unode "created" (unsafePerformIO $ getCurrentTime >>= time8601), + unode "modified" (unsafePerformIO $ getCurrentTime >>= time8601), + attr "meter" "0.010000" $ + attr "name" "centimeter" $ + unode "unit" (), unode "up_axis" "Y_UP" + ] + +-- | time according to iso 8601 +time8601 :: UTCTime -> IO String +time8601 t = return $ (showGregorian (utctDay t)) ++ ("T" ++ h ++ ":" ++ m ++ ":00Z") + where + LocalTime day tod = utcToLocalTime utc t + TimeOfDay hours minutes seconds = tod + h = show2 hours + m = show2 minutes + show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)] + +---------------------------------------------------------- +-- Filtering of SeneNodes to remove duplicates +---------------------------------------------------------- + +-- | extract cameras from SceneNodes and remove duplicates +extract_cameras snodes = nubBy (\(SceneNode _ _ _ _ c0s _ _ _) (SceneNode _ _ _ _ c1s _ _ _) -> c0s == c1s) $ + filter (\(SceneNode _ _ _ _ cs _ _ _) -> (length cs)>0) snodes + +-- | extract lights from SceneNodes and remove duplicates +extract_lights snodes = nubBy (\(SceneNode _ _ _ _ _ _ _ l0s) (SceneNode _ _ _ _ _ _ _ l1s) -> l0s == l1s) $ + filter (\(SceneNode _ _ _ _ _ _ _ ls) -> (length ls)>0) snodes + +-- | extract geometries from SceneNodes and remove duplicates +extract_geometries snodes = nubBy (\(SceneNode _ _ _ _ _ _ g0s _) (SceneNode _ _ _ _ _ _ g1s _) -> g0s == g1s) $ + filter (\(SceneNode _ _ _ _ _ _ gs _) -> (length gs)>0) snodes + +--------------------------------------------------------- +-- | library_cameras +cam :: SceneNode -> [Element] +cam (SceneNode _ _ _ _ cs _ _ _) = map cam2 cs + +-- | Perpective projection: see <http://en.wikipedia.org/wiki/Viewing_frustum> +cam2 (Perspective sid (ViewSizeXY (xfov,yfov)) (Z znear zfar)) = + attr "id" (sid ++ "-lib") $ attr "name" sid $ + unode "camera" $ unode "optics" $ + unode "technique_common" $ + unode "perspective" + [ unode "xfov" (show xfov), unode "yfov" (show yfov), + unode "znear" (show znear), unode "zfar" (show zfar) ] + +---------------------------------------------------------- +-- | library_lights +light :: SceneNode -> [Element] +light (SceneNode _ _ _ _ _ _ _ l) = map light2 l + +light2 :: Light -> Element +light2 ((Point sid (RGB c0 c1 c2) (Attenuation c_att l_att q_att))) = + attr "id" (sid ++ "-lib") $ attr "name" sid $ + unode "light" $ + unode "technique_common" $ + unode "point" + [ unode "color" (show c0 ++ " " ++ show c1 ++ " " ++ show c2), + unode "constant_attenuation" (show c_att), + unode "linear_attenuation" (show l_att), + unode "quadratic_attenuation" (show q_att) + ] + +light2 ((Ambient sid (RGB c0 c1 c2))) = + attr "id" (sid ++ "-lib") $ attr "name" sid $ + unode "light" $ + unode "technique_common" $ + unode "ambient" + [ unode "color" (show c0 ++ " " ++ show c1 ++ " " ++ show c2) ] + +---------------------------------------------------------- +-- | library_images +im :: [SceneNode] -> [Element] +im fs | (length images) > 0 = [unode "library_images" $ images] + | otherwise = [] + where + images = map image $ nub $ concat $ + map getTextures $ concat $ + map getMaterials $ concat $ + map getMeshes $ concat $ + map getGeometries fs + + getTextures :: (SID,Profile) -> [(String,String)] + getTextures (_,(COMMON str _ (PhongTex textures) "")) = map extr_id_path (filter isTex textures) + getTextures (_,(COMMON str _ (PhongCol _) "")) = [] + extr_id_path :: Fx_common_texture_type -> (String,String) + extr_id_path (TEmission (Texture name path)) = (name,path) + extr_id_path (TAmbient (Texture name path)) = (name,path) + extr_id_path (TDiffuse (Texture name path)) = (name,path) + extr_id_path (TSpecular (Texture name path)) = (name,path) + extr_id_path (TReflective (Texture name path)) = (name,path) + extr_id_path (TTransparent (Texture name path)) = (name,path) + +isTex (TShininess _) = False +isTex (TReflectivity _) = False +isTex (TTransparency _) = False +isTex (TIndex_of_refraction _) = False +isTex _ = True + +image (name,path) = attr "id" (name ++ "-lib") $ attr "name" name $ + unode "image" $ + unode "init_from" path + +getGeometries :: SceneNode -> [Geometry] +getGeometries (SceneNode _ _ _ _ _ _ gs _) = gs +getMeshes :: Geometry -> [Mesh] +getMeshes (Geometry _ mes _) = mes +getMaterials :: Mesh -> [Material] +getMaterials (LP (LinePrimitive p n m)) = m +getMaterials (LS (LinePrimitive p n m)) = m +getMaterials (P (Polygon p n ph m)) = m +getMaterials (PL (LinePrimitive p n m)) = m + +---------------------------------------------------------- +-- | library_materials +mat :: [SceneNode] -> [Element] +mat fs = map (materialElement.fst) $ concat $ + map getMaterials $ concat $ + map getMeshes $ concat $ + map getGeometries fs + +materialElement str = attr "id" (str ++ "-lib") $ attr "name" str $ + unode "material" $ + attr "url" ("#" ++ str ++ "-fx") $ + unode "instance_effect" () + +---------------------------------------------------------- +-- | library_effects +eff :: [SceneNode] -> [Element] +eff fs = map effects $ concat $ + map getMaterials $ concat $ + map getMeshes $ concat $ + map getGeometries fs + +effects :: (SID,Effect) -> Element +effects (sid,(COMMON str _ (PhongCol colors) "")) = + attr "id" (sid ++ "-fx") $ + unode "effect" $ + unode "profile_COMMON" $ + attr "sid" "common" $ + unode "technique" $ + unode "phong" $ + map colorNodes colors + +effects (sid,(COMMON str _ (PhongTex texs) "")) = + attr "id" (sid ++ "-fx") $ + unode "effect" $ + unode "profile_COMMON" $ + concat $ map texNodes texs + +colorNodes :: Fx_common_color_type -> Element +colorNodes (CEmission (Color (e0,e1,e2,e3))) = cnodes "emission" $ collada_array [e0,e1,e2,e3] +colorNodes (CAmbient (Color (a0,a1,a2,a3))) = cnodes "ambient" $ collada_array [a0,a1,a2,a3] +colorNodes (CDiffuse (Color (d0,d1,d2,d3))) = cnodes "diffuse" $ collada_array [d0,d1,d2,d3] +colorNodes (CSpecular (Color (s0,s1,s2,s3))) = cnodes "specular" $ collada_array [s0,s1,s2,s3] +colorNodes (CShininess sh) = unode "shininess" $ unode "float" $ show sh +colorNodes (CReflective (Color (r0,r1,r2,r3))) = cnodes "reflective" $ collada_array [r0,r1,r2,r3] +colorNodes (CReflectivity r) = unode "reflectivity" $ unode "float" $ show r +colorNodes (CTransparent (Color (t0,t1,t2,t3))) = cnodes "transparent" $ collada_array [t0,t1,t2,t3] +colorNodes (CTransparency t) = unode "transparency" $ unode "float" $ show t +colorNodes (CIndex_of_refraction ind) = unode "index_of_refraction" $ unode "float" $ show ind + +texNodes (TEmission (Texture name path)) = tnodes "emission" "id1" "UVSet0" name +texNodes (TAmbient (Texture name path)) = tnodes "ambient" "id1" "UVSet0" name +texNodes (TDiffuse (Texture name path)) = tnodes "diffuse" "id1" "UVSet0" name +texNodes (TSpecular (Texture name path)) = tnodes "specular" "id1" "UVSet0" name +texNodes (TShininess sh) = [ unode "shininess" $ unode "float" $ show sh ] +texNodes (TReflective (Texture name path)) = tnodes "reflective" "id1" "UVSet0" name +texNodes (TReflectivity r) = [ unode "reflectivity" $ unode "float" $ show r ] +texNodes (TTransparent (Texture name path)) = tnodes "transparent" "id1" "UVSet0" name +texNodes (TTransparency t) = [ unode "transparency" $ unode "float" $ show t ] +texNodes (TIndex_of_refraction ind) = [ unode "index_of_refraction" $ unode "float" $ show ind ] + +cnodes str c = unode str $ -- "emission" + unode "color" c + +tnodes str0 str1 uv tex = + [ attr "sid" (tex ++ "-surface") $ + unode "newparam" $ + attr "type" "2D" $ + unode "surface" $ + unode "init_from" (tex ++ "-lib"), + + attr "sid" (tex ++ "-sampler") $ + unode "newparam" $ + unode "sampler2D" $ + unode "source" (tex ++ "-surface"), + + attr "sid" "common" $ + unode "technique" $ + unode "phong" $ + unode str0 $ + attr "texture" (tex ++ "-sampler") $ + attr "texcoord" uv $ + unode "texture" "" + ] + +---------------------------------------------------------- +-- | library_geometries +geo :: [SceneNode] -> [Element] +geo fs = meshes $ concat $ map getGeometries fs + where meshes :: [Geometry] -> [Element] + meshes objs = zipWith mesh_element [1..(length objs)] objs + +toTuple xs = map (\(x,y,z)->(x,y)) xs +toTriple xs = map (\(x,y)->(x,y,0)) xs + +mesh_element :: Int -> Geometry -> Element +mesh_element s (Geometry str pris (Vertices strv parr narr)) = + attr "id" (str ++ "-lib") $ + attr "name" str $ + unode "geometry" $ + unode "mesh" $ + concat $ map (primitives (show s) str parr narr) pris + +material :: [[Int]] -> [[Int]] -> String -> String -> String -> String -> [Element] +material ps ns prname s str symbol = + [ attr "count" (show $ length ps) $ + attr "material" (symbol ++ "G") $ + unode prname + ( (vn s str) ++ + [ unode "vcount" (collada_array $ map length ps), + unode "p" (collada_array $ concat $ zipWith interleave ps ns) + ] + ) + ] + +-- bSubCurve :: Bool -> (X,Y) -> [F2] -> [F2] +-- bSubCurve useTex (dx,dy) bs +primitives :: String -> String -> [Point] -> [Normal] -> Mesh -> [Element] +primitives s str parr narr (S (LinePrimitive ps ns mats)) -- Spline + = (sources_vertices s str (toTriple spl) na) + ++ (concat (map (material ps ns "linestrips" s str) (map fst mats))) + where spl = bSubCurve False (difference_x / 100, difference_y / 100) (toTuple parr) -- using bSubCurve is a hack + na = take (length spl) $ repeat (head narr) + il = interleave [0..((length spl)-1)] [0..((length spl)-1)] + difference_x = (maximum x) - (minimum x) + difference_y = (maximum y) - (minimum y) + x = map sel3_1 parr + y = map sel3_2 parr + toTuple xs = map (\(x,y,z)->(x,y)) xs + +primitives s str parr narr (LP (LinePrimitive ps ns mats)) + = (sources_vertices s str parr narr) + ++ (concat (map (material ps ns "lines" s str) (map fst mats))) + +primitives s str parr narr (LS (LinePrimitive ps ns mats)) + = (sources_vertices s str parr narr) + ++ (concat (map (material ps ns "linestrips" s str) (map fst mats))) + +primitives s str parr narr (P (Polygon ps ns phs mats)) + = (sources_vertices s str parr narr) + ++ (concat (map (material ps ns "polygon" s str) (map fst mats))) + +primitives s str parr narr (PL (LinePrimitive ps ns mats)) + = (sources_vertices s str parr narr) + ++ (concat (map (material ps ns "polylist" s str) (map fst mats))) + +-- TODO: Tr TriangleMesh | Trf TriFan | Trs TriStrip + +collada_array_str list = concat (map (++" ") list) +triple_serialize triples = concat $ map (\(x,y,z) -> [x,y,z]) triples + +sources_vertices s str parr narr = + [ attr "id" (str ++ s ++ "-lib-positions") $ + attr "name" "position" $ + (source str "-lib-positions-array" (triple_serialize parr) ["X", "Y", "Z"]), + attr "id" (str ++ s ++ "-lib-normals") $ + attr "name" "normal" $ + (source str "-lib-normals-array" (triple_serialize narr) ["X", "Y", "Z"]), + attr "id" (str ++ s ++ "-lib-texs") $ + (source str "-lib-tex-array" [0,0,1,0,1,1,0,1] -- [3.855715,1,0,1,3.855715,0,0,0,8.881784e-016,1,1.826221,0,1.826221,1,8.881784e-016,0] + ["S","T"] ), + + attr "id" (str ++ s ++ "-lib-vertices") $ + unode "vertices" $ + attr "semantic" "POSITION" $ + attr "source" ("#" ++ str ++ s ++ "-lib-positions") $ + unode "input" () + ] + + +interl :: Int -> [Int] +interl l = interleave ([0..(l-1)]++[0]) ([0..(l-1)]++[0]) + +interleave (p:points) (n:normals) = [p,n] ++ (interleave points normals) +interleave _ _ = [] + +sel3_1 (a,b,c) = a +sel3_2 (a,b,c) = b +sel3_3 (a,b,c) = c + +vn s str = [ attr "offset" "0" $ attr "semantic" "VERTEX" $ attr "source" ("#" ++ str ++ s ++ "-lib-vertices") $ + unode "input" (), + attr "offset" "1" $ attr "semantic" "NORMAL" $ attr "source" ("#" ++ str ++ s ++ "-lib-normals") $ + unode "input" (), + attr "offset" "0" $ attr "semantic" "TEXCOORD" $ attr "source" ("#" ++ str ++ s ++ "-lib-texs") $ + unode "input" ()] + +source str com ar acc = + unode "source" [ attr "id" (str ++ com) $ attr "count" (show (length ar)) $ + unode "float_array" (collada_array ar), + unode "technique_common" $ + attr "count" (show ((length ar)`div` (length acc)) ) $ attr "offset" "0" $ + attr "source" ("#" ++ str ++ com) $ attr "stride" (show $ length acc) $ + unode "accessor" $ floatAccessor acc + ] + +floatAccessor acc = map (\x -> attr "name" x $ attr "type" "float" $ unode "param" "") acc + +---------------------------------------------------------- +-- | library_visual_scenes: nested nodes with references to cameras, lights, geometries, ... +visual_scene :: Scene -> Element +visual_scene sc = attr "id" "VisualSceneNode" $ attr "name" "untitled" $ + unode "visual_scene" $ treeToNodes sc + +treeToNodes :: Scene -> Element +treeToNodes (Node (SceneNode sid _ _ tr cs _ gs ls ) tree) = + attr "id" sid $ attr "name" sid $ unode "node" $ + (ttn sid tr cs gs ls) ++ (map treeToNodes tree) + +ttn :: String -> [(ID,Transform)] -> [Camera] -> [Geometry] -> [Light] -> [Element] +ttn sid tr cs gs ls = (concat $ map transf tr) + ++ map (instances "instance_camera") (map cam_id cs) + ++ map (instances_geo "instance_geometry") gs + ++ map (instances "instance_light") (map light_id ls) + +cam_id (Perspective pID _ _) = pID +cam_id (Orthographic pID _ _) = pID + +light_id (Ambient aID _) = aID +light_id (Directional dID _) = dID +light_id (Point pID _ _) = pID +light_id (Spot sID _ _ _ _) = sID + +instances :: String -> String -> Element +instances inst sid = attr "url" ("#" ++ sid ++ "-lib") $ unode inst "" + +instances_geo :: String -> Geometry -> Element +instances_geo inst (Geometry str meshes _) = + attr "url" ("#" ++ str ++ "-lib") $ + unode inst $ + getm + where getm | or $ concat $ map hasTextures mats = map (bindsTex.fst) mats + | otherwise = map (binds.fst) mats + mats = concat $ map getMaterials meshes + +binds str = unode "bind_material" $ + unode "technique_common" $ + attr "symbol" (str ++ "G") $ + attr "target" ("#" ++ str ++ "-lib") $ + unode "instance_material" () + +bindsTex str = unode "bind_material" $ + unode "technique_common" $ + attr "symbol" (str ++ "G") $ + attr "target" ("#" ++ str ++ "-lib") $ + unode "instance_material" $ + attr "semantic" "UVSET0" $ + attr "input_semantic" "TEXCOORD" $ + attr "input_set" "0" $ + unode "bind_vertex_input" () + +hasTextures :: (SID,Profile) -> [Bool] +hasTextures (_,(COMMON str _ (PhongTex textures) "")) = map isTex textures +hasTextures (_,(COMMON str _ (PhongCol _) "")) = [] + +transf :: (SID,Transform) -> [Element] +-- transf (Matrix (Mat44 Float)) = unode +transf (sid,(Rotate (xrx:.xry:.xrz:.()) x (yrx:.yry:.yrz:.()) y (zrx:.zry:.zrz:.()) z)) = + [ add_attr (Attr (unqual "sid") "rotateX") $ + unode "rotate" (show xrx ++ " " ++ show xry ++ " " ++ show xrz ++ " " ++ show x), + add_attr (Attr (unqual "sid") "rotateY") $ + unode "rotate" (show yrx ++ " " ++ show yry ++ " " ++ show yrz ++ " " ++ show y), + add_attr (Attr (unqual "sid") "rotateZ") $ + unode "rotate" (show zrx ++ " " ++ show zry ++ " " ++ show zrz ++ " " ++ show z) ] + +transf (sid,(Scale (s0:.s1:.s2:.()))) = + [ add_attr (Attr (unqual "sid") "scale") $ + unode "scale" (show s0 ++ " " ++ show s1 ++ " " ++ show s2) ] + +transf (sid,(Translate (t0:.t1:.t2:.()))) = + [ add_attr (Attr (unqual "sid") "translate") $ + unode "translate" (show t0 ++ " " ++ show t1 ++ " " ++ show t2) ] + +scene str = add_attr (Attr (unqual "url") ("#" ++ str)) $ unode "instance_visual_scene" ()
+ src/Graphics/Formats/Collada/GenerateObjects.hs view
@@ -0,0 +1,145 @@+module Graphics.Formats.Collada.GenerateObjects +where + +import Graphics.Formats.Collada.ColladaTypes +import Graphics.Formats.Collada.GenerateCollada +import Data.Vec (Vec2, Vec3, Mat44, Mat33, (:.)(..), ) +import Data.Tree + +animatedCube = (aScene, animations) + +aScene :: Scene +aScene = Node empty_root [ n aCamera, + n (pointLight "pointLight" 3 4 10), + n (pointLight "pointL" (-500) 1000 400), + n aCube ] + +n x = Node x [] +empty_root = SceneNode "empty" NOTYPE [] [] [] [] [] [] + +aCamera = SceneNode "camera0" NOTYPE [] + [("cubeTran", Translate ((-827.749):.633.855:.1255.017)), + ("rot", Rotate (1:.0:.0) (-22.1954) + (0:.1:.0) (-33) + (0:.0:.1) 0)] + [(Perspective "Persp" (ViewSizeXY (37,37)) (Z 10 1000) )] + [] [] [] + +pointLight str x y z = SceneNode str NOTYPE [] + [("cubeTran", Translate (x:.y:.z)), + ("rot", Rotate (1:.0:.0) 0 + (0:.1:.0) 0 + (0:.0:.1) 0)] + [] [] [] + [(Point "point" (RGB 1 1 1) (Attenuation 1 0 0) )] + +ambientLight = SceneNode "ambientLight" NOTYPE [] + [("cubeTran", Translate ((-500):.1000:.400)), + ("rot", Rotate (1:.0:.0) 0 + (0:.1:.0) 0 + (0:.0:.1) 0)] + [] [] [] + [(Ambient "ambient" (RGB 1 1 1) )] + +aCube = SceneNode "cube_geometry" NOTYPE [] + [("cubeTran", Translate (0:.0:.0)), + ("rot", Rotate (1:.0:.0) 0 + (0:.1:.0) 0 + (0:.0:.1) 0) ] + [] [] + [cube] -- geometries + [] + + +animations :: Animations +animations = Node ("cube_rotate", anim_channel) [] + +anim_channel = Bezier ("input", [0, 2.5, 3.75, 5], [[("name","TIME"),("type","Float")]] ) + ("output",[0, 0, 56, 0], [[("name","ANGLE"),("type","Float")]] ) + ("intangent",[-0.333333, 0, 5, 0, 8.333333, 56, 9.583333, 18.666666], + [[("name","X"),("type","Float")], + [("name","Y"),("type","Float")]] ) + ("outtangent",[2.5, 0, 7.916667, 0, 9.166667, 56, 10.333333, -14.933331], + [[("name","X"),("type","Float")], + [("name","Y"),("type","Float")]] ) + ("interpolations",["BEZIER ", "BEZIER ", "BEZIER ", "BEZIER"], + [[("name","Interpolation"),("type","Name")]] ) + [("cube_geometry/rotateY","ANGLE"), + ("cube_geometry/rotateY","ANGLE"), + ("cube_geometry/rotateY","ANGLE")] + +-- ---------------- +-- a blue/textured cube +-- ---------------- + +cube :: Geometry +cube = Geometry "cube" + [PL (LinePrimitive [[0,2,3,1],[0,1,5,4],[6,7,3,2],[0,4,6,2],[3,7,5,1],[5,7,6,4]] + [[0,1,2,3],[4,5,6,7],[8,9,10,11],[12,13,14,15],[16,17,18,19],[20,21,22,23]] + -- [logo] + [blue] + )] + (Vertices "cube_vertices" + [(-50,50,50),(50,50,50),(-50,-50,50),(50,-50,50),(-50,50,-50), + (50,50,-50),(-50,-50,-50),(50,-50,-50)] + [(0,0,1),(0,0,1),(0,0,1),(0,0,1),(0,1,0),(0,1,0),(0,1,0),(0,1,0),(0,-1,0), + (0,-1,0),(0,-1,0),(0,-1,0),(-1,0,0),(-1,0,0),(-1,0,0),(-1,0,0),(1,0,0), + (1,0,0),(1,0,0),(1,0,0),(0,0,-1),(0,0,-1),(0,0,-1),(0,0,-1)] + ) + +blue = ("blue", COMMON "" NoParam + (PhongCol [(CEmission (Color (0,0,0,1))), + (CAmbient (Color (0,0,0,1))), + (CDiffuse(Color (0.137255,0.403922,0.870588,1))), + (CSpecular(Color (0.5,0.5,0.5,1))), + (CShininess 16), + (CReflective (Color (0,0,0,1))), + (CReflectivity 0.5), + (CTransparent (Color (0,0,0,1))), + (CTransparency 1), + (CIndex_of_refraction 0)] + ) + "" + ) + +logo = ("haskell-logo", COMMON "" NoParam + (PhongTex [(TDiffuse tex)] + ) + "" + ) + +tex = Texture "logo" "Haskell-Logo-Variation.png" + +-- ------------------ +-- generation example +-- ------------------ +animatedCubes = (scene2, animations2) + +scene2 = Node empty_root $ [ n aCamera, n (pointLight "pl" (-500) 1000 400) ] ++ (map n test_objs) + +animations2 :: Animations +animations2 = Node ("cube_rotate", new_channels anim_channel test_objs) [] + +new_channels :: AnimChannel -> [SceneNode] -> AnimChannel +new_channels (Bezier i o it ot interp _) nodes = + Bezier i o it ot interp $ map (\obj -> ((obj_name obj) ++ "/rotateY","ANGLE")) nodes + +obj_name (SceneNode n _ _ _ _ _ _ _) = n + +tran :: SceneNode -> (Float,Float,Float) -> String -> SceneNode +tran (SceneNode _ typ layer tr cam contr geo light) (tx, ty, tz) str = + (SceneNode str typ layer ([("tr", Translate (tx:.ty:.tz:.()))] ++ tr) cam contr geo light) + +test_objs :: [SceneNode] +test_objs = xyz_grid 5 5 5 150 aCube + +xyz_grid :: Int -> Int -> Int -> Float -> SceneNode -> [SceneNode] +xyz_grid x y z d obj = zipWith (tran obj) + (concat (concat (x_line x (map (map (\(a,b,c) -> (a+d,b,c)))) $ + x_line y (map (\(a,b,c) -> (a,b+d,c))) $ + x_line z (\(a,b,c) -> (a,b,c+d)) (0,0,0)) )) + (map enum_obj [1..(x*y*z)]) + where enum_obj i = (obj_name obj) ++ (show i) + +x_line 0 change value = [] +x_line n change value = value : ( x_line (n-1) change (change value) )