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 Debug.Trace
genCollada :: Scene -> [Animation] -> IO ()
genCollada sc anim = gCollada (standardAsset " Haskell Programmer " " My Tool ") sc anim
gCollada :: Element -> Scene -> [Animation] -> IO ()
gCollada asset sc anim = writeFile "Collada-File.dae" $
ppTopElement (basicFrame asset sc anim)
basicFrame :: Element -> Scene -> [Animation] -> Element
basicFrame asset sc anim =
attr "xmlns" "http://www.collada.org/2005/11/COLLADASchema" $ attr "version" "1.4.0" $
unode "COLLADA" $
[ asset ] ++
(library_animations (concat $ map 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_visual_scenes" (visual_scene sc)
, unode "scene" (scene "VisualSceneNode")
]
where fs = flatten sc
extr_cam = extract_cameras fs
extr_light = extract_lights fs
extr_im = extr_eff
extr_mat = extr_geo
extr_eff = extr_mat
extr_geo = extract_geometries fs
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"
]
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)]
extract_cameras :: [SceneNode] -> [SceneNode]
extract_cameras snodes = nubBy (\(SceneNode _ _ _ _ c0s _ _ _)
(SceneNode _ _ _ _ c1s _ _ _) -> c0s == c1s) snodes
extract_lights :: [SceneNode] -> [SceneNode]
extract_lights snodes = nubBy (\(SceneNode _ _ _ _ _ _ _ l0s)
(SceneNode _ _ _ _ _ _ _ l1s) -> l0s == l1s) snodes
extract_geometries :: [SceneNode] -> [SceneNode]
extract_geometries snodes = nubBy (\(SceneNode _ _ _ _ _ _ g0s _)
(SceneNode _ _ _ _ _ _ g1s _) -> g0s == g1s) snodes
cam :: SceneNode -> [Element]
cam (SceneNode _ _ _ _ cs _ _ _) = map cam2 cs
cam2 :: Camera -> Element
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) ]
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) ]
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 t m)) = m
getMaterials (LS (LinePrimitive p n t m)) = m
getMaterials (P (Polygon p n ph m)) = m
getMaterials (PL (LinePrimitive p n t m)) = m
getMaterials (S (LinePrimitive p n t m)) = m
mat :: [SceneNode] -> [Element]
mat fs = map (materialElement.fst) $ nubBy (\(a,b) (c,d) -> a==c) $ 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" ()
eff :: [SceneNode] -> [Element]
eff fs = map effects $ nubBy (\(a,b) (c,d) -> a==c) $ 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 $
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" ""
]
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
tex_ar :: [[Int]] -> [[Int]] -> [[Int]] -> String -> String -> String -> (SID,Profile) -> [Element]
tex_ar ps ns ts prname s str (symbol,profile) = tex_array s str (symbol,profile)
material :: [[Int]] -> [[Int]] -> [[Int]] -> String -> String -> String -> (SID,Profile) -> [Element]
material ps ns ts prname s str (symbol,profile) =
[ attr "count" (show $ length ps) $
attr "material" (symbol ++ "G") $
unode prname
( (vnt s str (symbol,profile)) ++
[ unode "vcount" (collada_array $ map length ps),
unode "p" $
if (or $ hasTextures (symbol,profile)) then (collada_array $ concat $ zipWith3 interleave3 ps ns ts)
else (collada_array $ concat $ zipWith interleave ps ns)
]
)
]
extract_sts (COMMON _ _ (PhongTex _ sts) _) = sts
tex_array s str (symbol,profile) | or (hasTextures (symbol,profile)) =
[ attr "id" (str ++ s ++ "-lib-texs") $
(source str "-lib-tex-array" (concat (extract_sts profile))
["S","T"] )]
| otherwise = []
type Point = (Float,Float,Float)
type Normal = (Float,Float,Float)
primitives :: String -> String -> [Point] -> [Normal] -> Mesh -> [Element]
primitives s str parr narr (S (LinePrimitive ps ns ts mats))
= (sources s str (toTriple spl) na)
++ (lib_vertices s str (toTriple spl) na)
++ (concat (map (material new_ps new_ps [] "linestrips" s str) mats))
where spl = bSubCurve False (difference_x / 100, difference_y / 100) (toTuple parr)
na = take (length spl) $ repeat (head narr)
new_ps = [[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
primitives s str parr narr (LP (LinePrimitive ps ns ts mats))
= (sources s str parr narr)
++ (concat (map (tex_ar ps ns ts "lines" s str) mats))
++ (lib_vertices s str parr narr)
++ (concat (map (material ps ns ts "lines" s str) mats))
primitives s str parr narr (LS (LinePrimitive ps ns ts mats))
= (sources s str parr narr)
++ (concat (map (tex_ar ps ns ts "linestrips" s str) mats))
++ (lib_vertices s str parr narr)
++ (concat (map (material ps ns ts "linestrips" s str) mats))
primitives s str parr narr (P (Polygon ps ns phs mats))
= (sources s str parr narr)
++ (concat (map (tex_ar ps ns [] "polygon" s str) mats))
++ (lib_vertices s str parr narr)
++ (concat (map (material ps ns [] "polygon" s str) mats))
primitives s str parr narr (PL (LinePrimitive ps ns ts mats))
= (sources s str parr narr)
++ (concat (map (tex_ar ps ns ts "polylist" s str) mats))
++ (lib_vertices s str parr narr)
++ (concat (map (material ps ns ts "polylist" s str) mats))
collada_array_str list = concat (map (++" ") list)
triple_serialize triples = concat $ map (\(x,y,z) -> [x,y,z]) triples
sources 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"])
]
lib_vertices s str parr narr =
[ 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..(l1)]++[0]) ([0..(l1)]++[0])
interleave (p:points) (n:normals) = [p,n] ++ (interleave points normals)
interleave _ _ = []
interleave3 (p:points) (n:normals) (t:textures) = [p,n,t] ++ (interleave3 points normals textures)
interleave3 _ _ _ = []
sel3_1 (a,b,c) = a
sel3_2 (a,b,c) = b
sel3_3 (a,b,c) = c
vnt s str (symbol,profile) =
[ 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" ()]
++ (texcoord s str (symbol,profile))
texcoord s str (symbol,profile) | or (hasTextures (symbol,profile)) =
[ attr "offset" "2" $
attr "semantic" "TEXCOORD" $
attr "source" ("#" ++ str ++ s ++ "-lib-texs") $
unode "input" () ]
| otherwise = []
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
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 (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" ()