module Graphics.Formats.Collada.GenerateCollada where

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.Vector (Vector)
import qualified Data.Vector as V
import Graphics.SVG.ReadPath(bSubCurve)
import Graphics.Formats.Collada.ColladaTypes
import Graphics.Formats.Collada.Animations (attr, library_animations, collada_array)
import Graphics.Formats.Collada.Vector2D3D (V3(..), V4(..))
import System.IO
import System.IO.Unsafe
import Text.XML.Light
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)

-- | The basic structure of a Collada file, contains library_... nodes, where library_s are used for referencing
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 ] ++
--	, unode "library_animation_clips" $
    (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_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 :: [SceneNode] -> [SceneNode]
extract_cameras snodes = nubBy eqCamera snodes

eqCamera (SceneNode _ _ _ _ c0s _ _ _) (SceneNode _ _ _ _ c1s _ _ _) = c0s == c1s
eqCamera _  _ = False

-- | Extract lights from SceneNodes and remove duplicates
extract_lights :: [SceneNode] -> [SceneNode]
extract_lights snodes = nubBy eqLight snodes

eqLight (SceneNode _ _ _ _ _ _ _ l0s) (SceneNode _ _ _ _ _ _ _ l1s) = l0s == l1s
eqLight _ _ = False

-- | Extract geometries from SceneNodes and remove duplicates
extract_geometries :: [SceneNode] -> [SceneNode]
extract_geometries snodes = nubBy eqGeometries snodes

eqGeometries (SceneNode _ _ _ _ _ _ g0s _) (SceneNode _ _ _ _ _ _ g1s _) = g0s == g1s
eqGeometries _ _ = False

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

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

----------------------------------------------------------
-- | library_lights
light :: SceneNode -> [Element]
light (SceneNode _ _ _ _ _ _ _ l) = map light2 l
light EmptyRoot = []

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
getGeometries EmptyRoot = []
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

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

----------------------------------------------------------
-- | library_effects
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 (V4 e0 e1 e2 e3))) = cnodes "emission" $ collada_array [e0,e1,e2,e3]
colorNodes (CAmbient (Color (V4 a0 a1 a2 a3))) = cnodes "ambient" $ collada_array [a0,a1,a2,a3]
colorNodes (CDiffuse (Color (V4 d0 d1 d2 d3))) = cnodes "diffuse" $ collada_array [d0,d1,d2,d3]
colorNodes (CSpecular (Color (V4 s0 s1 s2 s3))) = cnodes "specular" $ collada_array [s0,s1,s2,s3]
colorNodes (CShininess sh) = unode "shininess" $ unode "float" $ show sh
colorNodes (CReflective (Color (V4 r0 r1 r2 r3))) = cnodes "reflective" $ collada_array [r0,r1,r2,r3]
colorNodes (CReflectivity r) = unode "reflectivity" $ unode "float" $ show r
colorNodes (CTransparent (Color (V4 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" $
           (sources (show s) str parr narr) ++
           ( concat $ map (primitivesSources (show s) str parr narr) pris ) ++
           (lib_vertices (show s) str parr narr) ++
           ( concat $ map (primitives (show s) str parr narr) pris )

type VI = Vector (Vector Int)

tex_ar :: VI -> VI -> VI -> String -> String -> String -> (SID,Profile) -> [Element]
tex_ar ps ns ts prname s str (symbol,profile) = tex_array s str (symbol,profile)

material :: VI -> VI -> VI -> String -> String -> String -> (SID,Profile) -> [Element]
material ps ns ts prname s str (symbol,profile) =
                  [ attr "count" (show $ V.length ps) $
                    attr "material" (symbol ++ "G") $
                      unode prname
                      ( (vnt s str (symbol,profile)) ++
                        [ unode "vcount" (collada_array $ V.toList $ V.map V.length ps),
                          unode "p" $
						  if (or $ hasTextures (symbol,profile)) then interleave3 ps ns ts
						                                         else 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 = []

-- bSubCurve :: Bool -> (X,Y) -> [F2] -> [F2]
-- bSubCurve useTex (dx,dy) bs
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)) -- Spline
                = (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) -- using bSubCurve is a hack
        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 sel1 parr
        y = map sel2 parr
-}

primitivesSources :: String -> String -> Vector V3 -> Vector V3 -> Mesh -> [Element]
primitivesSources s str parr narr (LP (LinePrimitive ps ns ts mats))
                = (concat (map (tex_ar ps ns ts "lines" s str) mats))

primitivesSources s str parr narr (LS (LinePrimitive ps ns ts mats))
                = (concat (map (tex_ar ps ns ts "linestrips" s str) mats))

primitivesSources s str parr narr (P (Polygon ps ns phs mats))
                = (concat (map (tex_ar ps ns V.empty "polygon" s str) mats))

primitivesSources s str parr narr (PL (LinePrimitive ps ns ts mats))
                = (concat (map (tex_ar ps ns ts "polylist" s str) mats))

primitives :: String -> String -> Vector V3 -> Vector V3 -> Mesh -> [Element]
primitives s str parr narr (LP (LinePrimitive ps ns ts mats))
                = (concat (map (material ps ns ts "lines" s str) mats))

primitives s str parr narr (LS (LinePrimitive ps ns ts mats))
                = (concat (map (material ps ns ts "linestrips" s str) mats))

primitives s str parr narr (P (Polygon ps ns phs mats))
                = (concat (map (material ps ns V.empty "polygon" s str) mats))

primitives s str parr narr (PL (LinePrimitive ps ns ts mats))
                = (concat (map (material ps ns ts "polylist" s str) mats))

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

collada_array_str list = concat (map (++" ") list)
triple_serialize :: Vector V3 -> [Float]
triple_serialize triples = concat $V.toList $ V.map (\(V3 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 = il ([0..(l-1)]++[0]) ([0..(l-1)]++[0])
  where
   il (p:points) (n:normals) = [p,n] ++ (il points normals)
   il _ _ = []

interleave :: VI -> VI -> String
interleave points normals | V.null points || V.null normals = []
                          | otherwise = (concat (V.toList (V.zipWith (\x y -> show x ++ " " ++ show y ++ " ") p n))) ++
                                        (interleave (V.tail points) (V.tail normals))
  where p = V.head points
        n = V.head normals

interleave3 :: VI -> VI -> VI -> String
interleave3 points normals tex | V.null points || V.null normals || V.null tex = []
          | otherwise = (concat (V.toList (V.zipWith3 (\x y z ->show x ++" "++ show y ++" "++ show z ++" ") p n t))) ++
                        (interleave3 (V.tail points) (V.tail normals) (V.tail tex))
  where p = V.head points
        n = V.head normals
        t = V.head tex

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

----------------------------------------------------------
-- | 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)
treeToNodes (Node EmptyRoot tree) =
    attr "id" "root" $ attr "name" "root" $ unode "node" $ (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 $
		unode "bind_material" $
        unode "technique_common" $
        getm
  where getm = map (\m -> if or (hasTextures m) then (bindsTex.fst) m
                                                else (binds.fst) m    ) mats
  
        mats = concat $ map getMaterials meshes

binds str = attr "symbol" (str++"G") $
            attr "target" ("#" ++ str ++ "-lib") $
            unode "instance_material" ()

bindsTex str = 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 (V3 xrx xry xrz) x (V3 yrx yry yrz) y (V3 zrx zry zrz) z ) =
                  [  add_attr (Attr (unqual "sid") sid) $
                    unode "rotate" (show xrx ++ " " ++ show xry ++ " " ++ show xrz ++ " " ++ show x),
                     add_attr (Attr (unqual "sid") sid) $
                    unode "rotate" (show yrx ++ " " ++ show yry ++ " " ++ show yrz ++ " " ++ show y),
                     add_attr (Attr (unqual "sid") sid) $
                    unode "rotate" (show zrx ++ " " ++ show zry ++ " " ++ show zrz ++ " " ++ show z) ]

transf (sid, Scale (V3 s0 s1 s2) ) =
                     [ add_attr (Attr (unqual "sid") sid) $
                       unode "scale" (show s0 ++ " " ++ show s1 ++ " " ++ show s2) ] 

transf (sid, Translate (V3 t0 t1 t2) ) =
                     [ add_attr (Attr (unqual "sid") sid) $
                       unode "translate" (show t0 ++ " " ++ show t1 ++ " " ++ show t2) ]

transf (sid, LookAt (V3 px py pz) (V3 ix iy iz) (V3 upx upy upz) ) =
                     [ unode "lookat" (show px ++ " " ++ show py ++ " " ++ show pz ++ " " ++
                                       show ix ++ " " ++ show iy ++ " " ++ show iz ++ " " ++
                                       show upx ++ " " ++ show upy ++ " " ++ show upz) ]

scene str = add_attr (Attr (unqual "url") ("#" ++ str)) $ unode "instance_visual_scene" ()