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))
-- | the basic structure of a Collada file, contains library_... nodes, where library_s are for referencing
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 ] ++
--	, unode "library_animation_clips" $
    (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_controllers"
    , unode "library_visual_scenes" (visual_scene sc)
    , unode "scene" (scene "VisualSceneNode")
--	, unode "library_formulas" $
--	, unode "library_nodes" $
--  , unode "library_physics_materials" $
--  , unode "library_force_fields" $
--  , unode "library_physics_models" $
--  , unode "library_physics_scenes" $ 
--  , unode "library_rigid_bodies" $
--  , unode "library_joints" $ 
--  , unode "library_kinematics_models" $
--  , unode "library_articulated_systems" $
--  , unode "library_kinematics_scenes" $ 
    ]
  where fs = flatten sc
        extr_cam = extract_cameras fs
        extr_light = extract_lights fs
        extr_im = extr_eff -- images are always part of effects
        extr_mat = extr_geo -- geometries have materials
        extr_eff = extr_mat -- materials are always effects
        extr_geo = extract_geometries fs

-- | document information: author, time created ...
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"
                      ]

-- | time according to iso 8601
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)]

----------------------------------------------------------
-- Filtering of SeneNodes to remove duplicates
----------------------------------------------------------

-- | extract cameras from SceneNodes and remove duplicates
extract_cameras snodes = nubBy (\(SceneNode _ _ _ _ c0s _ _ _) (SceneNode _ _ _ _ c1s _ _ _) -> c0s == c1s) $
                         filter (\(SceneNode _ _ _ _ cs _ _ _) -> (length cs)>0) snodes

-- | extract lights from SceneNodes and remove duplicates
extract_lights snodes = nubBy (\(SceneNode _ _ _ _ _ _ _ l0s) (SceneNode _ _ _ _ _ _ _ l1s) -> l0s == l1s) $
                        filter (\(SceneNode _ _ _ _ _ _ _ ls) -> (length ls)>0) snodes

-- | extract geometries from SceneNodes and remove duplicates
extract_geometries snodes = nubBy (\(SceneNode _ _ _ _ _ _ g0s _) (SceneNode _ _ _ _ _ _ g1s _) -> g0s == g1s) $
                            filter (\(SceneNode _ _ _ _ _ _ gs _) -> (length gs)>0) snodes

---------------------------------------------------------
-- | library_cameras
cam :: SceneNode -> [Element]
cam (SceneNode _ _ _ _ cs _ _ _) = map cam2 cs

-- | Perpective projection: see <http://en.wikipedia.org/wiki/Viewing_frustum>
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) ]

----------------------------------------------------------
-- | library_lights
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) ]

----------------------------------------------------------
-- | library_images
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

----------------------------------------------------------
-- | library_materials
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" ()

----------------------------------------------------------
-- | library_effects
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 $ -- "emission"
               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" ""
                ]

----------------------------------------------------------
-- | library_geometries
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)
                        ] 
                      )
                  ]

-- bSubCurve :: Bool -> (X,Y) -> [F2] -> [F2]
-- bSubCurve useTex (dx,dy) bs
primitives :: String -> String -> [Point] -> [Normal] -> Mesh -> [Element]
primitives s str parr narr (S (LinePrimitive ps ns mats)) -- Spline
                = (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) -- using bSubCurve is a hack
        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)))

--  TODO: Tr TriangleMesh | Trf TriFan | Trs TriStrip

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] -- [3.855715,1,0,1,3.855715,0,0,0,8.881784e-016,1,1.826221,0,1.826221,1,8.881784e-016,0]
			                               ["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..(l-1)]++[0]) ([0..(l-1)]++[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

----------------------------------------------------------
-- | library_visual_scenes: nested nodes with references to cameras, lights, geometries, ...
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 (Matrix (Mat44 Float)) = unode
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" ()