collada-types 0.2 → 0.3

raw patch · 5 files changed

+397/−108 lines, 5 filesdep +OpenGLdep +tupledep +vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: OpenGL, tuple, vector

API changes (from Hackage documentation)

Files

• collada-types.cabal +8/−4
• src/Graphics/Formats/Collada/ColladaTypes.hs +26/−22
• src/Graphics/Formats/Collada/GenerateObjects.hs +70/−48
• src/Graphics/Formats/Collada/Transformations.hs +79/−34
• src/Graphics/Formats/Collada/Vector2D3D.hs +214/−0

@@ -1,12 +1,12 @@ Name:               collada-types
-Version:            0.2
+Version:            0.3
 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
 Author:             Tillmann Vogt
-Maintainer:         Tillmann.Vogt@rwth-aachen.de
+Maintainer:         tillk.vogt@googlemail.com
 Build-Type:         Simple
 Cabal-Version:    >=1.6
 
@@ -15,9 +15,13 @@     build-depends:
         base ==4.*,
         containers == 0.4.*,
+        OpenGL >= 2.2.3.0,
         enumerable,
-        tuple-gen
+        tuple-gen,
+        vector,
+        tuple
     exposed-modules:
         Graphics.Formats.Collada.ColladaTypes
         Graphics.Formats.Collada.GenerateObjects
-        Graphics.Formats.Collada.Transformations+        Graphics.Formats.Collada.Transformations
+        Graphics.Formats.Collada.Vector2D3D

@@ -3,7 +3,7 @@ 
 module Graphics.Formats.Collada.ColladaTypes
 (
-    Scene,
+    Scene(..),
     SceneNode(..), NodeType(..),
     Transform(..),
     Camera(..),
@@ -26,12 +26,15 @@     C(..), Color(..),
     Animation(..),
     Fx_common_color_type(..), Fx_common_texture_type(..), Texture(..),
-	Interpolation(..)
+	Interpolation(..),
 )
 where
 
 import Data.Tree
-type Vec3 = (Float,Float,Float)
+import Data.Vector
+import Graphics.Rendering.OpenGL (TextureObject)
+import Graphics.Formats.Collada.Vector2D3D (V3(..), V4(..))
+
 type Mat44 = ((Float,Float,Float,Float),
               (Float,Float,Float,Float),
 			  (Float,Float,Float,Float),
@@ -55,19 +58,19 @@ data NodeType = JOINT | NODE | NOTYPE deriving (Show, Eq)
 
 data Transform = LookAt {
-                    lookAtEye:: Vec3,
-                    lookAtInterest :: Vec3,
-                    lookAtUp :: Vec3
+                    lookAtEye:: V3,
+                    lookAtInterest :: V3,
+                    lookAtUp :: V3
                  }
                | Matrix Mat44
-               | Rotate Vec3 Float Vec3 Float Vec3 Float
-               | Scale Vec3
+               | Rotate V3 Float V3 Float V3 Float
+               | Scale V3
                | Skew {
                     skewAngle :: Float,
-                    skewRotation :: Vec3,
-                    skewTranslation :: Vec3
+                    skewRotation :: V3,
+                    skewTranslation :: V3
                  }
-               | Translate Vec3
+               | Translate V3
                deriving (Show, Eq)
 
 data Camera = Perspective {
@@ -196,23 +199,23 @@ 
 data Vertices = Vertices {
                   name :: ID,
-                  verts :: [(Float,Float,Float)],
-                  normals :: [(Float,Float,Float)]
+                  verts :: Vector V3,
+                  normals :: Vector V3
             }
             deriving (Show, Eq)
 
 data LinePrimitive = LinePrimitive {
-                lineP :: [[Int]], -- point indices
-                lineN :: [[Int]], -- normal indices
-                lineT :: [[Int]], -- texture indices
+                lineP :: Vector (Vector Int), -- point indices
+                lineN :: Vector (Vector Int), -- normal indices
+                lineT :: Vector (Vector Int), -- texture indices
                 ms :: [Material]
             }
             deriving (Show, Eq)
 
 data Polygon = Polygon {
-                poylgonP :: [[Int]],
-                poylgonN :: [[Int]],
-                polygonPh :: ([Int],[Int]), -- (indices, indices of a hole)
+                poylgonP :: Vector (Vector Int),
+                poylgonN :: Vector (Vector Int),
+                polygonPh :: (Vector Int, Vector Int), -- (indices, indices of a hole)
                 polygonMs :: [Material]
             }
             deriving (Show, Eq)
@@ -268,15 +271,16 @@                               TShininess Float | TReflective Texture | TReflectivity Float |
                               TTransparent Texture | TTransparency Float | TIndex_of_refraction Float
                               deriving (Show, Eq)
-data C = Color (Float, Float, Float, Float) deriving (Show, Eq)
+data C = Color V4 deriving (Show, Eq)
 
 data Texture = Texture {
                    imageSID :: ID,
-                   path :: String -- ToDo: better type, embedded images
+                   path :: String, -- ToDo: better type
+                   texObj :: Maybe TextureObject -- force evalaution to generate a font cache
             }
             deriving (Show, Eq)
 
 type ID = String
 type SID = String -- Maybe
 
-data Color = RGB Float Float Float deriving (Eq, Show)+data Color = RGB Float Float Float deriving (Eq, Show)

@@ -5,7 +5,10 @@ import Data.Tree
 import Data.Tuple.Gen
 import Data.Word
+import qualified Data.Vector as V
+import Data.Vector (Vector)
 import Graphics.Formats.Collada.ColladaTypes
+import Graphics.Formats.Collada.Vector2D3D
 
 -- type Scene = Tree SceneNode
 n x = Node x []
@@ -33,27 +36,27 @@                    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
+rot x y z = Rotate (V3 1 0 0) x
+                   (V3 0 1 0) y
+                   (V3 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
+tranrot = [ ("tran", Translate (V3 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,2000,2500)),
+                       [("tran", Translate (V3 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)),
+                         [("tran", Translate (V3 x y z)),
                           ("rot", rot 0 0 0)]
                          [] [] []
                          [(Point "point" (RGB 1 1 1) (Attenuation 1 0 0) )]
 
 ambientLight = SceneNode "ambientLight" NOTYPE []
-                         [("tran", Translate ((-500),1000,400)),
+                         [("tran", Translate (V3 (-500) 1000 400)),
                           ("rot", rot 0 0 0)]
                          [] [] []
                          [(Ambient "ambient" (RGB 1 1 1) )]
@@ -61,7 +64,7 @@ aCube :: SceneNode
 aCube = SceneNode "cube_geometry" NOTYPE [] tranrot [] [] [cube] []
 
-obj :: String -> [Geometry] -> (Float,Float,Float) -> SceneNode
+obj :: String -> [Geometry] -> V3 -> SceneNode
 obj name c tr = SceneNode name NOTYPE []
                          [("tran", Translate tr),
                           ("rot", rot 0 0 0)]
@@ -81,37 +84,56 @@                              Bezier [9.583333, 18.666666] [10.333333, -14.933331] ]
                            [("cube_geometry/rotateY","ANGLE")]
 
+fl = V.fromList
+
 -- | 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]] -- indices to vertices
-         [[0,0,0,0],[1,1,1,1],[2,2,2,2],[3,3,3,3],[4,4,4,4],[5,5,5,5]] -- indices to normals
-         [] -- [[0,1,2,3],[0,1,2,3],[0,1,2,3],[0,1,2,3],[0,1,2,3],[0,1,2,3]] -- indices to texture coordinates, use an empty list when no texture
-         -- [logo]
-         [blue]
+         (fl [fl [0,2,3,1], fl [0,1,5,4], fl [6,7,3,2], fl [0,4,6,2], fl [3,7,5,1], fl [5,7,6,4]]) -- indices to vertices
+         (fl [fl [0,0,0,0], fl [1,1,1,1], fl [2,2,2,2], fl [3,3,3,3], fl [4,4,4,4], fl [5,5,5,5]]) -- indices to normals
+         (fl [fl [0,1,2,3], fl [0,1,2,3], fl [0,1,2,3], fl [0,1,2,3], fl [0,1,2,3], fl [0,1,2,3]]) -- indices to texture coordinates, use an empty list when no texture
+         [logo]
+         -- [blue]
        )]
        (Vertices "cube_vertices"
-         [(-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
+         (fl [(V3 (-10) 10 10), (V3 10 10 10), (V3 (-10) (-10) 10), (V3 10 (-10) 10), -- vertices
+              (V3 (-10) 10 (-10)),(V3 10 10 (-10)),(V3 (-10) (-10) (-10)),(V3 10 (-10) (-10))])
+         (fl [(V3 0 0 1), (V3 0 1 0), (V3 0 (-1) 0), (V3 (-1) 0 0), (V3 1 0 0), (V3 0 0 (-1))]) -- normals
        )
 
 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)]
+               (PhongCol [CEmission (Color (V4 0 0 0 1)),
+                          CAmbient  (Color (V4 0 0 0 1)),
+                          CDiffuse(Color (V4 0.137255 0.403922 0.870588 1)),
+                          CSpecular(Color (V4 0.5 0.5 0.5 1)),
+                          CShininess 16, 
+                          CReflective (Color (V4 0 0 0 1)),
+                          CReflectivity 0.5,
+                          CTransparent (Color (V4 0 0 0 1)),
+                          CTransparency 1,
+                          CIndex_of_refraction 0]
                )
                ""
        )
 
+diffuse c str (a, COMMON asset NoParam (PhongCol cs) s) = ("color_" ++ str, COMMON asset NoParam (PhongCol (map (replaceDiff c) cs)) s)
+
+replaceDiff c (CDiffuse _) = CDiffuse (Color c)
+replaceDiff _ c = c
+
+ambient c str (a, COMMON asset NoParam (PhongCol cs) s) = ("color_" ++ str, COMMON asset NoParam (PhongCol (map (replaceAmb c) cs)) s)
+
+replaceAmb c (CAmbient _) = CAmbient (Color c)
+replaceAmb _ c = c
+
+
+getDiffuseColor ( CDiffuse  (Color c) ) = Just c
+getDiffuseColor _ = Nothing
+
+getAmbientColor ( CAmbient  (Color c) ) = Just c
+getAmbientColor _ = Nothing
+
 logo = ("haskell-logo", COMMON "" NoParam
                (PhongTex [(TDiffuse tex)]
 			             [[0,0,1,0,1,1,0,1]] -- [u0,v0,u1,v1,..] -coordinates (Floats between 0 and 1) that point into the texture
@@ -119,50 +141,50 @@                ""
        )
 
-tex = Texture "logo" "Haskell-Logo-Variation.png"
+tex = Texture "logo" "Haskell-Logo-Variation.png" Nothing
 
-polys :: [(Float,Float,Float)] -> [(Float,Float,Float)] -> [[Int]] -> [[Int]] -> [Geometry]
+polys :: Vector V3 -> Vector V3 -> Vector (Vector Int) -> Vector (Vector Int) -> [Geometry]
 polys p n pi ni = [Geometry "polygons"
   [PL (LinePrimitive pi -- indices to vertices
                      ni -- indices to normals
-                     [] -- no texure
-              [blue]
+                     V.empty -- no texure
+                     [blue]
          )]
  (Vertices "polygons_vertices" p n)]
 
 
-lines :: [(Float,Float,Float)] -> [(Float,Float,Float)] -> [[Int]] -> [[Int]] -> [Geometry]
+lines :: Vector V3 -> Vector V3 -> Vector (Vector Int) -> Vector (Vector Int) -> [Geometry]
 lines p n pi ni = [Geometry "lines"
   [LS (LinePrimitive pi -- indices to vertices
                      ni -- indices to normals
-                     [] -- no texure
-              [blue]
+                     V.empty -- no texure
+                     [blue]
          )]
  (Vertices "lines_vertices" p n)]
 
 
-trifans :: [(Float,Float,Float)] -> [(Float,Float,Float)] -> [[Int]] -> [[Int]] -> [Geometry]
+trifans :: Vector V3 -> Vector V3 -> Vector (Vector Int)-> Vector (Vector Int) -> [Geometry]
 trifans p n pi ni = [Geometry "trifans"
   [Trf (LinePrimitive pi -- indices to vertices
                       ni -- indices to normals
-                      [] -- no texure
-              [blue]
+                      V.empty -- no texure
+                      [blue]
          )]
  (Vertices "trifans_vertices" p n)]
 
 
-tristrips :: [(Float,Float,Float)] -> [(Float,Float,Float)] -> [[Int]] -> [[Int]] -> [Geometry]
+tristrips :: Vector V3 -> Vector V3 -> Vector (Vector Int) -> Vector (Vector Int) -> [Geometry]
 tristrips p n pi ni = [Geometry "tristrips"
   [Trs (LinePrimitive pi -- indices to vertices
                       ni -- indices to normals
-                      [] -- no texure
-              [blue]
+                      V.empty -- no texure
+                      [blue]
          )]
  (Vertices "trifans_vertices" p n)]
 
 
 ge :: Geometry -> SceneNode
-ge (Geometry name p v) = obj name [Geometry name p v] (0,0,0)
+ge (Geometry name p v) = obj name [Geometry name p v] (V3 0 0 0)
 -- ------------------
 -- a bigger example
 -- ------------------
@@ -190,9 +212,9 @@ obj_name (SceneNode n _ _ _ _ _ _ _) = n
 
 -- | a helper function for xyz_grid
-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))] cam contr geo light)
+tran :: SceneNode -> V3 -> String -> SceneNode
+tran (SceneNode _   typ layer tr                             cam contr geo light) v3 str =
+     (SceneNode str typ	layer [("tr", Translate v3)] cam contr geo light)
 
 test_objs :: [SceneNode]
 test_objs = xyz_grid 10 10 10 150 aCube
@@ -200,9 +222,9 @@ -- | Generate a 3 dimensional grid where an object (stored in a SceneNode) is repeated in along the grid
 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)) ))
+                       (concat (concat (x_line x (map (map (\(V3 a b c) -> (V3 (a+d) b c)))) $
+                                        x_line y (map (\(V3 a b c) -> (V3 a (b+d) c))) $
+                                        x_line z (\(V3 a b c) -> (V3 a b (c+d)))        (V3 0 0 0)) ))
                        (enum_obj obj [1..(x*y*z)])
 
 enum_obj obj (i:is) = ((obj_name obj) ++ (show i)) : (enum_obj obj is)
@@ -218,12 +240,12 @@  -- map (\(x,y,z) -> (fromIntegral x, fromIntegral y, fromIntegral z))
  en
 
-en :: [(Float,Float,Float)] 
+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)) []
+en = map (\(V x y)->(x*20,y*20,0)) []
 
 base_objects = map (rename aCube) (map show [1..(length positions)])
 

@@ -1,52 +1,97 @@ module Graphics.Formats.Collada.Transformations where
 import Graphics.Formats.Collada.ColladaTypes
-type V = (Float,Float,Float)
+import Graphics.Formats.Collada.GenerateObjects
+import Graphics.Formats.Collada.Vector2D3D
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import Data.Tuple.Select
+
+translate :: V3 -> Geometry -> Geometry
+translate v (Geometry name prims (Vertices vname ps ns)) = Geometry name prims (Vertices vname (V.map (+ v) ps) ns)
+
 -- |extrude a 2d polygon to 3d, the same points are added again with extrusion direction v
-extrude :: V -> Geometry -> Geometry
+extrude :: V3 -> Geometry -> Geometry
 extrude v (Geometry name prims (Vertices vname ps _)) = Geometry name
                                                          (map addIndices prims)
-                                                         (Vertices vname (concat twoPoints)
-                                                                         (concat (map (\x -> [x,x,x,x]) ns)) )
+                                                         (Vertices vname (addNewPoints ps)
+                                                                         (fourN ns) )
   where
-  twoPoints = map addPoint ps
-  addPoint point = [point, add v point]
+  addNewPoints :: Vector V3 -> Vector V3
+  addNewPoints vs | V.null vs   = V.empty
+                  | otherwise = V.cons (V.head vs) $ V.cons ((V.head vs)+v) (addNewPoints (V.tail vs))
 
+  fourN :: Vector V3 -> Vector V3
+  fourN vs | V.null vs = V.empty
+           | otherwise = V.cons (V.head vs) $
+                         V.cons (V.head vs) $
+                         V.cons (V.head vs) $ V.cons (V.head vs) (fourN (V.tail vs))
+
   addIndices (LP (LinePrimitive points normals tex color)) = PL (LinePrimitive (p points) (p points) tex color)
-  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)
+  ns = V.map (normalsFrom v) (cycleNeighbours ps)
+  p :: Vector (Vector Int) -> Vector (Vector Int)
+  p several_outlines = V.foldr (V.++) V.empty (V.map extr_outline several_outlines)
 
-add (x0,y0,z0) (x1,y1,z1) = (x0+x1, y0+y1, z0+z1)  
+extr_outline :: Vector Int -> Vector (Vector Int)
+extr_outline points = V.map quads (cycleNeighbours points)
+  where
+  quads xs = V.cons ((V.head xs)*2) $          -- [x*2,y*2,x*2+1,y*2+1]
+             V.cons ((V.head (V.tail xs))*2) $
+             V.cons ((V.head (V.tail xs))*2+1) $
+             V.singleton ((V.head xs)*2+1)
 
+normalsFrom (V3 x0 y0 z0) xs = crosspr (v1x-x0,v1y-y0,v1z-z0) (v1x-v2x,v1y-v2y,v1z-v2z)
+  where (V3 v1x v1y v1z ,V3 v2x v2y v2z) = (V.head xs, V.head (V.tail xs)) :: (V3,V3)
+        crosspr (v0,v1,v2) (w0,w1,w2) = (V3 (v1*w2-v2*w1) (v2*w0-v0*w2) (v0*w1-v1*w0))
+
+-- |return a list containing lists of every element with its neighbour
+-- i.e. [e1,e2,e3] -> [ [e1,e2], [e2,e3], [e3, e1] ]
+cycleNeighbours :: Vector a -> Vector (Vector a)
+cycleNeighbours xs | V.null xs = V.empty
+                   | otherwise = cycleN (V.head xs) xs
+
+cycleN :: a -> Vector a -> Vector (Vector a)
+cycleN f xs | V.length xs >= 2 = V.cons (V.fromList [V.head xs, V.head (V.tail xs)]) (cycleN f (V.tail xs))
+            | otherwise        = V.singleton (V.fromList [V.head xs, f ]) -- if the upper doesn't match close cycle
+
+
 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
+                                                         ( Vertices vname0 (ps0 V.++ ps1) (ns0 V.++ ns1) )
+  where changeIndices l (LP (LinePrimitive points                                  normals  texCoord mat)) =
+                         LP (LinePrimitive (V.map (V.map (l+)) points) (V.map (V.map (l+)) normals) texCoord mat)
+        changeIndices l (LS (LinePrimitive points                                  normals  texCoord mat)) =
+                         LS (LinePrimitive (V.map (V.map (l+)) points) (V.map (V.map (l+)) normals) texCoord mat)
+        changeIndices l (PL (LinePrimitive points                                  normals  texCoord mat)) =
+                         PL (LinePrimitive (V.map (V.map (l+)) points) (V.map (V.map (l+)) normals) texCoord mat)
+        changeIndices l (Tr (LinePrimitive points                                  normals  texCoord mat)) =
+                         Tr (LinePrimitive (V.map (V.map (l+)) points) (V.map (V.map (l+)) normals) texCoord mat)
+        l = V.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] ]
-cycleNeighbours :: [a] -> [[a]]
-cycleNeighbours [] = []
-cycleNeighbours xs = cycleN (head xs) xs
+changeDiffuseColor :: String -> V4 -> Geometry -> Geometry
+changeDiffuseColor str color (Geometry name prims
+                               (Vertices vname ps ns)) = (Geometry name (map (c color) prims) (Vertices vname ps ns))
+  where c col (LP (LinePrimitive ps ns texCoord mat)) =
+               LP (LinePrimitive ps ns texCoord (map (diffuse col str) mat))
+        c col (LS (LinePrimitive ps ns texCoord mat)) =
+               LS (LinePrimitive ps ns texCoord (map (diffuse col str) mat))
+        c col (PL (LinePrimitive ps ns texCoord mat)) =
+               PL (LinePrimitive ps ns texCoord (map (diffuse col str) mat))
+        c col (Tr (LinePrimitive ps ns texCoord mat)) =
+               Tr (LinePrimitive ps ns texCoord (map (diffuse col str) mat))
 
-cycleN :: a -> [a] -> [[a]]
-cycleN f (x:y:xs) = [x,y] : (cycleN f (y:xs))
-cycleN f e = [[head e, f ]] -- if the upper doesn't match close cycle
+changeAmbientColor :: String -> V4 -> Geometry -> Geometry
+changeAmbientColor str color (Geometry name prims
+                               (Vertices vname ps ns)) = (Geometry name (map (c color) prims) (Vertices vname ps ns))
+  where c col (LP (LinePrimitive ps ns texCoord mat)) =
+               LP (LinePrimitive ps ns texCoord (map (ambient col str) mat) ) 
+        c col (LS (LinePrimitive ps ns texCoord mat)) =
+               LS (LinePrimitive ps ns texCoord (map (ambient col str) mat) )
+        c col (PL (LinePrimitive ps ns texCoord mat)) =
+               PL (LinePrimitive ps ns texCoord (map (ambient col str) mat) )
+        c col (Tr (LinePrimitive ps ns texCoord mat)) =
+               Tr (LinePrimitive ps ns texCoord (map (ambient col str) mat) )
+

@@ -0,0 +1,214 @@+-- most functions and data types are from https://github.com/cobbpg/sloth2d++module Graphics.Formats.Collada.Vector2D3D+    ( Angle+    , V2(..), V3(..), V4(..)+    , T2+    , unit, (*.), dot, dot3, cross, cross3, perpL, perpR, mul, divide+    , turn, turnL, turnNL, turnR, turnNR, parv+    , square, mag, norm, dir, v_len, set_len+    , inverse, (<>)+    , translate, rotate, scale+    , translationOf, rotationOf, scaleOf+    , withTranslation, withRotation, withScale+    ) where++import Data.Monoid++infixl 7 `dot`, `cross`+infixl 5 `turn`, `turnL`, `turnNL`, `turnR`, `turnNR`, `parv`++-- | An angle is a number between -pi and pi.+type Angle = Float++-- | 2D vector: a pair of coordinates.+data V2 = V {-# UNPACK #-} !Float {-# UNPACK #-} !Float+    deriving (Show, Eq, Ord)++data V3 = V3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float+    deriving (Show, Eq, Ord)++data V4 = V4 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float+    deriving (Show, Eq, Ord)++-- | 2D affine transformation. No shearing allowed, only translation,+-- rotation, and scaling. Transformations can be chained with+-- 'mappend', and 'mempty' is the identity transformation.+data T2 = T+    {-# UNPACK #-} !Float {-# UNPACK #-} !Float+    {-# UNPACK #-} !Float {-# UNPACK #-} !Float+    deriving Show++instance Num V2 where+    V x1 y1 + V x2 y2 = V (x1+x2) (y1+y2)+    V x1 y1 - V x2 y2 = V (x1-x2) (y1-y2)+    V x1 y1 * V x2 y2 = V (x1*x2) (y1*y2)+    negate (V x y) = V (negate x) (negate y)+    abs (V x y) = V (abs x) (abs y)+    signum (V x y) = V (signum x) (signum y)+    fromInteger n = let n' = fromInteger n in V n' n'++instance Num V3 where+    V3 x1 y1 z1 + V3 x2 y2 z2 = V3 (x1+x2) (y1+y2) (z1+z2)+    V3 x1 y1 z1 - V3 x2 y2 z2 = V3 (x1-x2) (y1-y2) (z1-z2)+    V3 x1 y1 z1 * V3 x2 y2 z2 = V3 (x1*x2) (y1*y2) (z1*z2)+    negate (V3 x y z) = V3 (negate x) (negate y) (negate z)+    abs (V3 x y z) = V3 (abs x) (abs y) (abs z)+    signum (V3 x y z) = V3 (signum x) (signum y) (signum z)+    fromInteger n = let n' = fromInteger n in V3 n' n' n'++-- | Unit vector with the given direction.+unit :: Angle -> V2+unit a = V (cos a) (sin a)++-- | Multiplication with a scalar.+(*.) :: V2 -> Float -> V2+V x y *. m = V (x*m) (y*m)++-- | Multiplication with a scalar.+mul (V3 x y z) c = (V3  (x*c)  (y*c)  (z*c))++-- | Division by a scalar.+divide (V3 x y z) c = (V3  (x/c)  (y/c)  (z/c))++-- | Dot product.+dot :: V2 -> V2 -> Float+V x1 y1 `dot` V x2 y2 = x1*x2+y1*y2++-- | Dot product.+dot3 :: V3 -> V3 -> Float+V3 x1 y1 z1 `dot3` V3 x2 y2 z2 = x1*x2 + y1*y2 + z1*z2++-- | Perp-dot product (2D cross product).+cross :: V2 -> V2 -> Float+V x1 y1 `cross` V x2 y2 = x1*y2-y1*x2++-- | 3D cross product.+cross3 :: V3 -> V3 -> V3+V3 x1 y1 z1 `cross3` V3 x2 y2 z2 = V3 (y1*z2-z1*y2)  (z1*x2-x1*z2)  (x1*y2-y1*x2)++-- | Vector rotated 90 degrees leftwards.+perpL :: V2 -> V2+perpL (V x y) = V (-y) x++-- | Vector rotated 90 degrees rightwards.+perpR :: V2 -> V2+perpR (V x y) = V y (-x)++-- | Relative direction of two vectors: @turn v1 v2@ equals @GT@ if+-- @v2@ takes a left turn with respect to @v1@, @LT@ if it is a right+-- turn, and @EQ@ if they are parallel.+turn :: V2 -> V2 -> Ordering+V x1 y1 `turn` V x2 y2 = compare (x1*y2) (y1*x2)++-- | @turnL v1 v2 == (turn v1 v2 == GT)@+turnL :: V2 -> V2 -> Bool+V x1 y1 `turnL` V x2 y2 = x1*y2 > y1*x2++-- | @turnNL v1 v2 == (turn v1 v2 /= GT)@+turnNL :: V2 -> V2 -> Bool+V x1 y1 `turnNL` V x2 y2 = x1*y2 <= y1*x2++-- | @turnR v1 v2 == (turn v1 v2 == LT)@+turnR :: V2 -> V2 -> Bool+V x1 y1 `turnR` V x2 y2 = x1*y2 < y1*x2++-- | @turnNR v1 v2 == (turn v1 v2 /= LT)@+turnNR :: V2 -> V2 -> Bool+V x1 y1 `turnNR` V x2 y2 = x1*y2 >= y1*x2++-- | @parv v1 v2 == (turn v1 v2 == EQ)@+parv :: V2 -> V2 -> Bool+V x1 y1 `parv` V x2 y2 = x1*y2 == y1*x2++-- | Vector length squared.+square :: V2 -> Float+square v = v `dot` v++-- | 3d Vector length squared.+square3 :: V3 -> Float+square3 v = v `dot3` v++-- | Vector length.+mag :: V2 -> Float+mag = sqrt . square++-- | 3d Vector length.+v_len = sqrt . square3++-- | Set Vector length.+set_len (V3 x y z) l = (V3  (x*c*l)  (y*c*l)  (z*c*l)) where c = 1 / v_len (V3 x y z)++-- | The angle of a vector with respect to the X axis.+dir :: V2 -> Angle+dir (V x y) = atan2 y x++-- | Vector normalisation.+norm :: V2 -> V2+norm v@(V x y) = V (x*m) (y*m)+  where+    m = recip (mag v)++instance Monoid T2 where+    mempty = scale 1+    T rx1 ry1 tx1 ty1 `mappend` T rx2 ry2 tx2 ty2 = T rx ry tx ty+      where+        rx = rx1*rx2-ry1*ry2+        ry = ry1*rx2+rx1*ry2+        tx = rx1*tx2-ry1*ty2+tx1+        ty = ry1*tx2+rx1*ty2+ty1++-- | Inverse transformation+inverse :: T2 -> T2+inverse (T rx ry tx ty) = T (rx*m) (-ry*m) tx' ty'+  where+    m = recip (rx*rx+ry*ry)+    tx' = m*(-ry*ty-rx*tx)+    ty' = m*(ry*tx-rx*ty)++-- | Transformation applied to a vector.+(<>) :: T2 -> V2 -> V2+T rx ry tx ty <> V x y = V x' y'+  where+    x' = rx*x-ry*y+tx+    y' = ry*x+rx*y+ty++-- | Transformation representing a translation.+translate :: V2 -> T2+translate (V x y) = T 1 0 x y++-- | Transformation representing a rotation.+rotate :: Angle -> T2+rotate a = T (cos a) (sin a) 0 0++-- | Transformation representing a scaling.+scale :: Float -> T2+scale m = T m 0 0 0++-- | The translation factor of a transformation.+translationOf :: T2 -> V2+translationOf (T _ _ tx ty) = V tx ty++-- | The rotation factor of a transformation.+rotationOf :: T2 -> Angle+rotationOf (T rx ry _ _) = dir (V rx ry)++-- | The scaling factor of a transformation.+scaleOf :: T2 -> Float+scaleOf (T rx ry _ _) = mag (V rx ry)++-- | Replacing the translation factor of a transformation.+withTranslation :: T2 -> V2 -> T2+T rx ry _ _ `withTranslation` V x y = T rx ry x y++-- | Replacing the rotation factor of a transformation.+withRotation :: T2 -> Angle -> T2+T rx ry tx ty `withRotation` a = T rx' ry' tx ty+  where+    V rx' ry' = unit a *. mag (V rx ry)++-- | Replacing the scaling factor of a transformation.+withScale :: T2 -> Float -> T2+T rx ry tx ty `withScale` m = T (m'*rx) (m'*ry) tx ty+  where+    m' = m / mag (V rx ry)