diff --git a/collada-types.cabal b/collada-types.cabal --- a/collada-types.cabal +++ b/collada-types.cabal @@ -1,7 +1,7 @@ Name: collada-types -Version: 0.1 -Synopsis: data exchange between graphic applications -Description: Collada is the standard graphics format for data exchange between 3d Tools. As well as the file format also its represenation as an algebraic data type could be used to make libraries more composable. Please propose changes. +Version: 0.2 +Synopsis: Data exchange between graphic applications +Description: Collada is the standard graphics format for data exchange between 3d tools. As well as the file format also its representation as an algebraic data type could be used to make libraries more composable. Please propose changes. category: graphics License: BSD3 License-file: LICENSE diff --git a/src/Graphics/Formats/Collada/GenerateObjects.hs b/src/Graphics/Formats/Collada/GenerateObjects.hs --- a/src/Graphics/Formats/Collada/GenerateObjects.hs +++ b/src/Graphics/Formats/Collada/GenerateObjects.hs @@ -1,66 +1,70 @@ module Graphics.Formats.Collada.GenerateObjects where -import Graphics.Formats.Collada.ColladaTypes +import Data.Enumerable import Data.Tree import Data.Tuple.Gen -import Data.Enumerable import Data.Word +import Graphics.Formats.Collada.ColladaTypes +-- type Scene = Tree SceneNode +n x = Node x [] +makeScene sid sceneNodes = Node (SceneNode sid NOTYPE [] tranrot [] [] [] []) (map n sceneNodes) + +-- | An animated cube +animatedCube :: (Scene, [Animation]) animatedCube = (aScene, animation) --- | Example scene with a camera, lights and a cube +-- | Example scene with a cube aScene :: Scene -aScene = Node EmptyRoot [ n aCamera, - n (pointLight "pointLight" 3 4 10), - n (pointLight "pointL" (-500) 1000 400), - n aCube ] +aScene = makeScene "aCube" (cameraAndLight ++ [aCube]) --- type Scene = Tree SceneNode +lightedGeometry :: [Geometry] -> Scene +lightedGeometry g = makeScene "g" (cameraAndLight ++ (map ge g)) -n x = Node x [] +lightedSceneNode :: SceneNode -> Scene +lightedSceneNode node = makeScene "node" (cameraAndLight ++ [node]) +lightedScene :: Scene -> Scene +lightedScene node = Node EmptyRoot ((map n cameraAndLight) ++ [node]) + +-- | Every scene needs a camera and light +cameraAndLight = [ aCamera, + pointLight "pointLight" 3 4 10, + pointLight "pointL" (-500) 1000 400 ] + +rot x y z = Rotate (1,0,0) x + (0,1,0) y + (0,0,1) z + +tranrot = [ ("tran", Translate (0,0,0)), ("rot", rot 0 0 0) ] -- there have to be values for an animation channel to access + aCamera = SceneNode "camera0" NOTYPE [] - [("tran", Translate (1000,1000,2500)), - ("rot", Rotate (1,0,0) (-22) - (0,1,0) 13 - (0,0,1) 0)] + [("tran", Translate (1000,2000,2500)), + ("rot", rot (-22) 13 0)] -- [("lookat", LookAt (1000,1000,2500) (0,0,0) (0,1,0))] [(Perspective "Persp" (ViewSizeXY (37,37)) (Z 10 1000) )] [] [] [] pointLight str x y z = SceneNode str NOTYPE [] [("tran", Translate (x,y,z)), - ("rot", Rotate (1,0,0) 0 - (0,1,0) 0 - (0,0,1) 0)] + ("rot", rot 0 0 0)] [] [] [] [(Point "point" (RGB 1 1 1) (Attenuation 1 0 0) )] ambientLight = SceneNode "ambientLight" NOTYPE [] [("tran", Translate ((-500),1000,400)), - ("rot", Rotate (1,0,0) 0 - (0,1,0) 0 - (0,0,1) 0)] + ("rot", rot 0 0 0)] [] [] [] [(Ambient "ambient" (RGB 1 1 1) )] aCube :: SceneNode -aCube = SceneNode "cube_geometry" NOTYPE [] - [("tran", Translate (0,0,0)), - ("rot", Rotate (1,0,0) 0 - (0,1,0) 0 - (0,0,1) 0) ] - [] [] - [cube] -- geometries - [] +aCube = SceneNode "cube_geometry" NOTYPE [] tranrot [] [] [cube] [] -obj :: String -> [Geometry] -> SceneNode -obj name c = SceneNode name NOTYPE [] - [("tran", Translate (0,0,0)), - ("rot", Rotate (1,0,0) 0 - (0,1,0) 0 - (0,0,1) 0)] +obj :: String -> [Geometry] -> (Float,Float,Float) -> SceneNode +obj name c tr = SceneNode name NOTYPE [] + [("tran", Translate tr), + ("rot", rot 0 0 0)] [] [] c -- geometries [] @@ -88,8 +92,8 @@ [blue] )] (Vertices "cube_vertices" - [(-50,50,50), (50,50,50), (-50,-50,50), (50,-50,50), -- vertices - (-50,50,-50),(50,50,-50),(-50,-50,-50),(50,-50,-50)] + [(-10,10,10), (10,10,10), (-10,-10,10), (10,-10,10), -- vertices + (-10,10,-10),(10,10,-10),(-10,-10,-10),(10,-10,-10)] [(0,0,1), (0,1,0), (0,-1,0), (-1,0,0), (1,0,0), (0,0,-1)] -- normals ) @@ -157,14 +161,8 @@ (Vertices "trifans_vertices" p n)] -lightedScene :: [Geometry] -> Scene -lightedScene g = Node EmptyRoot ( [ n aCamera, - n (pointLight "pointLight" 3 4 10), - n (pointLight "pointL" (-500) 1000 400)] ++ - (map n (map ge g)) ) - ge :: Geometry -> SceneNode -ge (Geometry name p v) = obj name [Geometry name p v] +ge (Geometry name p v) = obj name [Geometry name p v] (0,0,0) -- ------------------ -- a bigger example -- ------------------ @@ -216,13 +214,17 @@ -- visualizing a stream of positions with copies of a base object ------------------------------------------------------------------- -positions = take 50 $ map (\(x, y, z) -> (x*100, y*100, z*100) ) $ - map (\(x,y,z) -> (fromIntegral x, fromIntegral y, fromIntegral z)) en +positions = map (\(x, y, z) -> (x*100, y*100, z*100) ) $ + -- map (\(x,y,z) -> (fromIntegral x, fromIntegral y, fromIntegral z)) + en -en :: [(Word8,Word8,Word8)] -en = enumerate --- en = all3s +en :: [(Float,Float,Float)] +-- en :: [(Word8,Word8,Word8)] +-- en = take 100 enumerate +-- en = take 100 all3s +en = map (\(x,y)->(x*20,y*20,0)) [] + base_objects = map (rename aCube) (map show [1..(length positions)]) rename :: SceneNode -> String -> SceneNode @@ -230,6 +232,7 @@ (SceneNode (str ++ s) typ layer tr cam contr geo light) getName (SceneNode str _ _ _ _ _ _ _) = str +get_name (Geometry str _ _) = str animatedStream = (streamScene base_objects, streamAnimation positions base_objects) diff --git a/src/Graphics/Formats/Collada/Transformations.hs b/src/Graphics/Formats/Collada/Transformations.hs --- a/src/Graphics/Formats/Collada/Transformations.hs +++ b/src/Graphics/Formats/Collada/Transformations.hs @@ -5,18 +5,41 @@ extrude :: V -> Geometry -> Geometry extrude v (Geometry name prims (Vertices vname ps _)) = Geometry name (map addIndices prims) - (Vertices vname (concat (map addPoints lines)) + (Vertices vname (concat twoPoints) (concat (map (\x -> [x,x,x,x]) ns)) ) where + twoPoints = map addPoint ps + addPoint point = [point, add v point] + addIndices (LP (LinePrimitive points normals tex color)) = PL (LinePrimitive (p points) (p points) tex color) - lines = cycleNeighbours ps - addPoints points = points ++ ( map (add v) (reverse points) ) - add (x0,y0,z0) (x1,y1,z1) = (x0+x1, y0+y1, z0+z1) - ns = map (normals v) lines + p several_outlines = concat $ map extr_outline several_outlines + extr_outline points = map quads (cycleNeighbours points) + quads = \[x,y] -> [x*2, y*2, y*2+1, x*2+1] + + ns = map (normals v) (cycleNeighbours ps) normals (vx0,vy0,vz0) [(vx1,vy1,vz1),(vx2,vy2,vz2)] = crosspr (vx1-vx0,vy1-vy0,vz1-vz0) (vx1-vx2,vy1-vy2,vz1-vz2) crosspr (v0,v1,v2) (w0,w1,w2) = (v1*w2-v2*w1, v2*w0-v0*w2, v0*w1-v1*w0) - p points = concat $ map (map (\x -> [x*4, x*4+1, x*4+2, x*4+3])) points + +add (x0,y0,z0) (x1,y1,z1) = (x0+x1, y0+y1, z0+z1) + +atop :: Geometry -> Geometry -> Geometry +atop (Geometry name0 prims0 (Vertices vname0 ps0 ns0)) + (Geometry name1 prims1 (Vertices vname1 ps1 ns1)) = Geometry name0 + ( prims0 ++ (map (changeIndices l) prims1) ) + ( Vertices vname0 (ps0++ps1) (ns0++ns1) ) + where changeIndices l (LP (LinePrimitive points normals tex color)) = + LP (LinePrimitive (map (map (l+)) points) (map (map (l+)) normals) tex color) + changeIndices l (LS (LinePrimitive points normals tex color)) = + LS (LinePrimitive (map (map (l+)) points) (map (map (l+)) normals) tex color) + changeIndices l (PL (LinePrimitive points normals tex color)) = + PL (LinePrimitive (map (map (l+)) points) (map (map (l+)) normals) tex color) + changeIndices l (Tr (LinePrimitive points normals tex color)) = + Tr (LinePrimitive (map (map (l+)) points) (map (map (l+)) normals) tex color) + l = length ps0 + +translate :: (Float,Float,Float) -> Geometry -> Geometry +translate v (Geometry name prims (Vertices vname ps ns)) = Geometry name prims (Vertices vname (map (add v) ps) ns) -- |return a list containing lists of every element with its neighbour -- i.e. [e1,e2,e3] -> [ [e1,e2], [e2,e3], [e3, e1] ]