module Graphics.Formats.Collada.GenerateObjects where import Data.Tree 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 [] makeScene sid sceneNodes = Node (SceneNode sid NOTYPE [] tranrot [] [] [] []) (map n sceneNodes) -- | An animated cube animatedCube :: (Scene, [Animation]) animatedCube = (aScene, animation) -- | Example scene with a cube aScene :: Scene aScene = makeScene "aCube" (cameraAndLight ++ [aCube]) lightedGeometry :: [Geometry] -> Scene lightedGeometry g = makeScene "g" (cameraAndLight ++ (map ge g)) 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 (V3 1 0 0) x (V3 0 1 0) y (V3 0 0 1) z 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 (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 (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 (V3 (-500) 1000 400)), ("rot", rot 0 0 0)] [] [] [] [(Ambient "ambient" (RGB 1 1 1) )] aCube :: SceneNode aCube = SceneNode "cube_geometry" NOTYPE [] tranrot [] [] [cube] [] obj :: String -> [Geometry] -> V3 -> SceneNode obj name c tr = SceneNode name NOTYPE [] [("tran", Translate tr), ("rot", rot 0 0 0)] [] [] c -- geometries [] -- | Example animation of the cube animation :: [Animation] animation = [Node ("cube_rotate", anim_channel) []] anim_channel = AnimChannel ("input", [0, 1, 2, 3], [[("name","TIME"), ("type","Float")]] ) ("output",[0, 50, 100, 150], [[("name","ANGLE"), ("type","Float")]] ) [ Bezier [-0.333333, 0] [2.5, 0], -- intangent outtangent Bezier [5,0] [7.916667, 0], Bezier [8.333333, 56] [9.166667, 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 (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" (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 (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 ) "" ) tex = Texture "logo" "Haskell-Logo-Variation.png" Nothing 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 V.empty -- no texure [blue] )] (Vertices "polygons_vertices" p n)] 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 V.empty -- no texure [blue] )] (Vertices "lines_vertices" p n)] 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 V.empty -- no texure [blue] )] (Vertices "trifans_vertices" p n)] 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 V.empty -- no texure [blue] )] (Vertices "trifans_vertices" p n)] ge :: Geometry -> SceneNode ge (Geometry name p v) = obj name [Geometry name p v] (V3 0 0 0) -- ------------------ -- a bigger example -- ------------------ animatedCubes = (scene2, animation2) animatedCubes2 = [(scene2, animation2)] scene2 :: Scene scene2 = Node EmptyRoot $ [ n aCamera, n (pointLight "pl" (-500) 1000 400) ] ++ (map n test_objs) -- | Animation of several cubes animation2 :: [Animation] animation2 = [Node ("cube_rotate", new_channels anim_channel test_objs) []] emptyAnimation :: [[Animation]] emptyAnimation = [] emptyAnim :: [Animation] emptyAnim = [] -- | generate an animation that points to the cubes new_channels :: AnimChannel -> [SceneNode] -> AnimChannel new_channels (AnimChannel i o interp _) nodes = AnimChannel i o interp $ map (\obj -> ((obj_name obj) ++ "/rotateY","ANGLE")) nodes obj_name (SceneNode n _ _ _ _ _ _ _) = n -- | a helper function for xyz_grid 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 -- | 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 (\(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) x_line 0 change value = [] x_line n change value = value : ( x_line (n-1) change (change value) ) ------------------------------------------------------------------- -- visualizing a stream of positions with copies of a base object ------------------------------------------------------------------- positions = map (\(x, y, z) -> (x*100, y*100, z*100) ) $ -- map (\(x,y,z) -> (fromIntegral x, fromIntegral y, fromIntegral z)) en en :: [(Float,Float,Float)] -- en :: [(Word8,Word8,Word8)] -- en = take 100 enumerate -- en = take 100 all3s en = map (\(V x y)->(x*20,y*20,0)) [] base_objects = map (rename aCube) (map show [1..(length positions)]) rename :: SceneNode -> String -> SceneNode rename (SceneNode str typ layer tr cam contr geo light) s = (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) streamScene :: [SceneNode] -> Scene streamScene objects = Node EmptyRoot $ [ n aCamera, n (pointLight "pl" (-500) 1000 400) ] ++ (map n $ objects) streamAnimation :: [(Float,Float,Float)] -> [SceneNode] -> [Animation] streamAnimation ps base_objects = [Node ("cube_stream", EmptyAnim) (map n $ concat $ zipWith (\ind bo -> [tr_channel ind ((show ind) ++ "1") bo (length ps) s1 "X"] ++ [tr_channel ind ((show ind) ++ "2") bo (length ps) s2 "Y"] ++ [tr_channel ind ((show ind) ++ "3") bo (length ps) s3 "Z"]) [1..(length ps)] (map getName base_objects) ) ] where s1 = map (\(a,b,c) -> a) ps s2 = map (\(a,b,c) -> b) ps s3 = map (\(a,b,c) -> c) ps tr_channel ind name bname lps s c = ( "anim" ++ name, AnimChannel ("input", map (*0.3) (map fromIntegral [0..(lps-1)]), [[("name","TIME"), ("type","Float")]] ) ("output", (take ind s) ++ (take (lps-ind) (repeat (head (drop ind s)))), [[("name",c), ("type","Float")]] ) (take lps (repeat Linear)) [(bname ++ "/tran",c)] )