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))
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 ] ++
(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_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 snodes = nubBy (\(SceneNode _ _ _ _ c0s _ _ _) (SceneNode _ _ _ _ c1s _ _ _) -> c0s == c1s) $
filter (\(SceneNode _ _ _ _ cs _ _ _) -> (length cs)>0) snodes
extract_lights snodes = nubBy (\(SceneNode _ _ _ _ _ _ _ l0s) (SceneNode _ _ _ _ _ _ _ l1s) -> l0s == l1s) $
filter (\(SceneNode _ _ _ _ _ _ _ ls) -> (length ls)>0) snodes
extract_geometries snodes = nubBy (\(SceneNode _ _ _ _ _ _ g0s _) (SceneNode _ _ _ _ _ _ g1s _) -> g0s == g1s) $
filter (\(SceneNode _ _ _ _ _ _ gs _) -> (length gs)>0) snodes
cam :: SceneNode -> [Element]
cam (SceneNode _ _ _ _ cs _ _ _) = map cam2 cs
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 m)) = m
getMaterials (LS (LinePrimitive p n m)) = m
getMaterials (P (Polygon p n ph m)) = m
getMaterials (PL (LinePrimitive p n m)) = m
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" ()
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 $
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
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)
]
)
]
primitives :: String -> String -> [Point] -> [Normal] -> Mesh -> [Element]
primitives s str parr narr (S (LinePrimitive ps ns mats))
= (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)
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)))
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]
["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..(l1)]++[0]) ([0..(l1)]++[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
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" ()