Animations.hs

module Graphics.Formats.Collada.Animations (attr, library_animations, animations, collada_array) where
import Text.XML.Light
import Graphics.Formats.Collada.ColladaTypes
import Debug.Trace

attr :: String -> String -> (Element -> Element)
attr key value = add_attr (Attr (unqual key) value)

library_animations :: [(SID, AnimChannel)] -> [Element]
library_animations anims | (length as) > 0 = [unode "library_animations" $ as]
                         | otherwise = []
  where as = map animations anims

animations :: (SID, AnimChannel) -> Element
animations (sid, EmptyAnim) = attr "id" "animRoot" $ unode "animation" ()
animations (sid,(AnimChannel (inID,inFloat,inAccessor)
                             (outID,outFloat,outAccessor)
							 interp
                             targets )) =
                attr "id" sid $ unode "animation" $
                [ anim_source_io (sid ++ "-" ++ inID) inFloat inAccessor,
                  anim_source_io (sid ++ "-" ++ outID) outFloat outAccessor ] ++
                (if intangent_exists then [ anim_source_tangents (sid ++ "-intangent") intangentFloat tAccessor ]
                 else []) ++
                (if outtangent_exists then [ anim_source_tangents (sid ++ "-outtangent") outtangentFloat tAccessor ]
                 else []) ++
                [ anim_source_interpolations (sid ++ "-interp") interpString [[("name","Interpolation"), ("type","Name")]],
				  anim_source_sampler sid inID outID intangent_exists outtangent_exists "intangent" "outtangent" "interp" ]
                ++ (map (anim_source_channel sid) targets)
  where
    intangentFloat = concat $ map fst gb
    outtangentFloat = concat $ map snd gb
    intangent_exists = (length intangentFloat) > 0
    outtangent_exists = (length outtangentFloat) > 0
    interpString = map getName interp
    gb = getBezier interp
    getBezier ((Bezier x y) : xs) = (x,y) : (getBezier xs)
    getBezier (_:xs) = getBezier xs
    getBezier [] = []
    getName (Step) = "Step "
    getName (Linear) = "Linear "
    getName (Bezier _ _) = "Bezier "

tAccessor = ( [ [("name","X"),("type","Float")],
                [("name","Y"),("type","Float")] ] )

accessor acc = map (foldr (\(x,y) -> (attr x y)) (unode "param" "")) acc

collada_array list = concat (map (++" ") (map show list))

anim_source_io str ar acc =
                  attr "id" str $ unode "source"
                  [ attr "id" (str ++ "-array") $
                    attr "count" (show (length ar)) $
                    unode "float_array" (collada_array ar),
                    unode "technique_common" $
                    attr "source" ("#" ++ str ++ "-array") $
                    attr "count" (show (length ar)) $
                    attr "stride" "1" $
                    unode "accessor" $ accessor acc
                  ]

anim_source_tangents :: String -> [Float] -> [[(String,String)]] -> Element
anim_source_tangents str ar acc =
                        attr "id" str $ unode "source"
                        [ attr "id" (str ++ "-array") $
                          attr "count" (show (length ar)) $
                          unode "float_array" (collada_array ar),
                          unode "technique_common" $
                            attr "source" ("#" ++ str ++ "-array") $
                            attr "count" (show ((length ar)`div`2)) $
                            attr "stride" "2" $
                              unode "accessor" $ accessor acc
                        ]

anim_source_interpolations :: String -> [String] -> [[(String,String)]] -> Element
anim_source_interpolations str ar acc =
                        attr "id" str $ unode "source"
                        [ attr "id" (str ++ "-array") $
                          attr "count" (show (length ar)) $
                          unode "Name_array" (concat ar),
                          unode "technique_common" $
                            attr "source" ("#" ++ str ++ "-array") $
                            attr "count" (show (length ar)) $
                            attr "stride" "1" $
                              unode "accessor" $ accessor acc
                        ]

anim_source_sampler str inID outID in_exists out_exists intangentID outtangentID interpID =
                  attr "id" (str ++ "-sampler") $
                  unode "sampler" 
                  ([
                     attr "semantic" "INPUT" $ attr "source" ("#" ++ str ++ "-" ++ inID) $
                       unode "input" (),
                     attr "semantic" "OUTPUT" $ attr "source" ("#" ++ str ++ "-" ++ outID) $
                       unode "input" ()
                   ] ++
                   (if in_exists then
                   [attr "semantic" "IN_TANGENT" $ attr "source" ("#" ++ str ++ "-" ++ intangentID) $
                       unode "input" ()]
                   else [])
                   ++
                   (if out_exists then [attr "semantic" "OUT_TANGENT" $ attr "source" ("#" ++ str ++ "-" ++ outtangentID) $
                       unode "input" ()]
                   else [])
                   ++
                   [  attr "semantic" "INTERPOLATION" $ attr "source" ("#" ++ str ++ "-" ++ interpID) $
                       unode "input" ()
                  ])

anim_source_channel s0 (targetID,accessorName) =
                     attr "source" ("#" ++ s0 ++ "-sampler") $
                     attr "target" (targetID ++ "." ++ accessorName) $
                       unode "channel" ()