never executed always true always false
    1 {-|
    2 Module: Flaw.Asset.Collada
    3 Description: Collada support.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, OverloadedStrings, RankNTypes #-}
    8 
    9 module Flaw.Asset.Collada
   10   ( Parse()
   11   , ColladaM()
   12   , ColladaCache(..)
   13   , ColladaSettings(..)
   14   , tryGetElementAttr
   15   , getElementAttr
   16   , getChildrenWithTag
   17   , getSingleChildWithTag
   18   , runCollada
   19   , initColladaCache
   20   , tryGetElementById
   21   , getElementById
   22   , resolveElement
   23   , getAllElementsByTag
   24   , ColladaVerticesData(..)
   25   , parseTrianglesOrPolyList
   26   , parseMesh
   27   , parseGeometry
   28   , ColladaNodeTag(..)
   29   , parseNode
   30   , nullAnimation
   31   , parseAnimation
   32   , animateNode
   33   , ColladaSkeleton(..)
   34   , ColladaSkeletonNode(..)
   35   , parseSkeleton
   36   , animateSkeleton
   37   , ColladaSkin(..)
   38   , ColladaBone(..)
   39   , parseSkin
   40   , ColladaElement
   41   ) where
   42 
   43 import Control.Monad
   44 import Control.Monad.Except
   45 import Control.Monad.Fail
   46 import Control.Monad.State
   47 import qualified Data.ByteString.Lazy as BL
   48 import Data.List
   49 import Data.Maybe
   50 import qualified Data.Map.Lazy as ML
   51 import qualified Data.Map.Strict as MS
   52 import qualified Data.Text as T
   53 import qualified Data.Vector as V
   54 import qualified Data.Vector.Algorithms.Intro as VAI
   55 import qualified Data.Vector.Generic as VG
   56 import qualified Data.Vector.Generic.Mutable as VGM
   57 import qualified Data.Vector.Mutable as VM
   58 import qualified Data.Vector.Storable as VS
   59 import qualified Data.Vector.Storable.Mutable as VSM
   60 import qualified Data.Vector.Unboxed as VU
   61 import qualified Data.Vector.Unboxed.Mutable as VUM
   62 import Data.Word
   63 import Foreign.Storable
   64 import System.IO.Unsafe
   65 import qualified Text.XML as XML
   66 
   67 import Flaw.Math
   68 import Flaw.Math.Transform
   69 
   70 data ColladaCache = ColladaCache
   71   { ccSettings :: !ColladaSettings
   72   , ccRootElement :: !XML.Element
   73   , ccElementsById :: !(MS.Map T.Text XML.Element)
   74   , ccWord32Arrays :: !(MS.Map T.Text (VS.Vector Word32))
   75   , ccFloatArrays :: !(MS.Map T.Text (VS.Vector Float))
   76   , ccNameArrays :: !(MS.Map T.Text (V.Vector T.Text))
   77   }
   78 
   79 data ColladaSettings = ColladaSettings
   80   { csUnit :: Float
   81   , csUnitMat :: Float4x4
   82   , csInvUnitMat :: Float4x4
   83   }
   84 
   85 type ColladaM a = StateT ColladaCache (Either T.Text) a
   86 
   87 instance MonadFail (Either T.Text) where
   88   fail = Left . T.pack
   89 
   90 -------- XML helpers.
   91 
   92 tryGetElementAttr :: T.Text -> XML.Element -> Maybe T.Text
   93 tryGetElementAttr attrName XML.Element
   94   { XML.elementAttributes = attributes
   95   } = ML.lookup XML.Name
   96   { XML.nameLocalName = attrName
   97   , XML.nameNamespace = Nothing
   98   , XML.namePrefix = Nothing
   99   } attributes
  100 
  101 -- | Get attribute of element.
  102 getElementAttr :: T.Text -> XML.Element -> ColladaM T.Text
  103 getElementAttr attrName element = case tryGetElementAttr attrName element of
  104   Just attr -> return attr
  105   Nothing -> throwError $ "no exactly one attribute: " <> attrName
  106 
  107 -- | Get children elements with specified tag.
  108 getChildrenWithTag :: T.Text -> XML.Element -> ColladaM [XML.Element]
  109 getChildrenWithTag tag XML.Element
  110   { XML.elementNodes = nodes
  111   } = return $ concatMap f nodes where
  112   f node = case node of
  113     XML.NodeElement element@XML.Element
  114       { XML.elementName = XML.Name
  115         { XML.nameLocalName = name
  116         }
  117       } -> [element | name == tag]
  118     _ -> []
  119 
  120 getSingleChildWithTag :: T.Text -> XML.Element -> ColladaM XML.Element
  121 getSingleChildWithTag tag element = do
  122   children <- getChildrenWithTag tag element
  123   case children of
  124     [r] -> return r
  125     _ -> throwError $ "no exactly one child: " <> tag
  126 
  127 runCollada :: ColladaM a -> Either T.Text a
  128 runCollada r = evalStateT r undefined
  129 
  130 -- | Init collada cache.
  131 initColladaCache :: BL.ByteString -> ColladaM ()
  132 initColladaCache fileData = do
  133   XML.Document
  134     { XML.documentRoot = rootElement
  135     } <- case XML.parseLBS XML.def fileData of
  136     Left e -> throwError $ "parse collada XML: " <> T.pack (show e)
  137     Right document -> return document
  138   put ColladaCache
  139     { ccSettings = ColladaSettings
  140       { csUnit = 1
  141       , csUnitMat = identityTransform
  142       , csInvUnitMat = identityTransform
  143       }
  144     , ccRootElement = rootElement
  145     , ccElementsById = MS.empty
  146     , ccWord32Arrays = MS.empty
  147     , ccFloatArrays = MS.empty
  148     , ccNameArrays = MS.empty
  149     }
  150   traverseElement rootElement
  151   where
  152     ignoreErrors q = catchError q (\_ -> return ())
  153     traverseElement element@XML.Element
  154       { XML.elementName = XML.Name
  155         { XML.nameLocalName = tag
  156         }
  157       , XML.elementNodes = nodes
  158       } = do
  159       when (tag == "COLLADA") $ ignoreErrors $ do
  160         assetElement <- getSingleChildWithTag "asset" element
  161         unitElement <- getSingleChildWithTag "unit" assetElement
  162         unit <- (read . T.unpack) <$> getElementAttr "meter" unitElement
  163         let invUnit = 1 / unit
  164         state $ \cache@ColladaCache
  165           { ccSettings = settings
  166           } -> ((), cache
  167           { ccSettings = settings
  168             { csUnit = unit
  169             , csUnitMat = Mat4x4
  170               unit 0 0 0
  171               0 unit 0 0
  172               0 0 unit 0
  173               0 0 0 1
  174             , csInvUnitMat = Mat4x4
  175               invUnit 0 0 0
  176               0 invUnit 0 0
  177               0 0 invUnit 0
  178               0 0 0 1
  179             }
  180           })
  181       ignoreErrors $ do
  182         elementId <- getElementAttr "id" element
  183         cache <- get
  184         put $ cache
  185           { ccElementsById = MS.insert elementId element $ ccElementsById cache
  186           }
  187       mapM_ traverseNode nodes
  188     traverseNode node = case node of
  189       XML.NodeElement element -> traverseElement element
  190       _ -> return ()
  191 
  192 -- | Try to get element by id.
  193 tryGetElementById :: T.Text -> ColladaM (Maybe XML.Element)
  194 tryGetElementById name = MS.lookup name . ccElementsById <$> get
  195 
  196 -- | Get element by id.
  197 getElementById :: T.Text -> ColladaM XML.Element
  198 getElementById name = do
  199   cache <- get
  200   case MS.lookup name $ ccElementsById cache of
  201     Just element -> return element
  202     Nothing -> throwError $ "no element: " <> name
  203 
  204 -- | Get element by #id or local name.
  205 resolveElement :: T.Text -> ColladaM XML.Element
  206 resolveElement name = case T.stripPrefix "#" name of
  207   Just elementId -> getElementById elementId
  208   Nothing -> throwError "local addresses not implemented yet" -- TODO: local addresses
  209 
  210 -- | Get all elements by tag.
  211 getAllElementsByTag :: T.Text -> ColladaM [XML.Element]
  212 getAllElementsByTag tag = do
  213   ColladaCache
  214     { ccRootElement = rootElement
  215     } <- get
  216   return $ traverseElement rootElement []
  217   where
  218     traverseElement element@XML.Element
  219       { XML.elementName = XML.Name
  220         { XML.nameLocalName = elementName
  221         }
  222       , XML.elementNodes = nodes
  223       } results = if elementName == tag then element : nodesResults else nodesResults where
  224       nodesResults = foldr traverseNode results nodes
  225     traverseNode node results = case node of
  226       XML.NodeElement element -> traverseElement element results
  227       _ -> results
  228 
  229 class Parse a where
  230   parse :: T.Text -> a
  231 
  232 class (Parse a, VG.Vector v a) => ParseArray a v | a -> v where
  233   getParsedArrays :: ColladaM (MS.Map T.Text (v a))
  234   putParsedArrays :: (MS.Map T.Text (v a) -> MS.Map T.Text (v a)) -> ColladaM ()
  235 
  236 instance Parse Int where
  237   parse = read . T.unpack
  238 
  239 instance Parse Word32 where
  240   parse = read . T.unpack
  241 instance ParseArray Word32 VS.Vector where
  242   getParsedArrays = ccWord32Arrays <$> get
  243   putParsedArrays f = do
  244     cache <- get
  245     put cache { ccWord32Arrays = f $ ccWord32Arrays cache }
  246 
  247 instance Parse Float where
  248   parse = read . T.unpack
  249 instance ParseArray Float VS.Vector where
  250   getParsedArrays = ccFloatArrays <$> get
  251   putParsedArrays f = do
  252     cache <- get
  253     put cache { ccFloatArrays = f $ ccFloatArrays cache }
  254 
  255 instance Parse T.Text where
  256   parse = id
  257 instance ParseArray T.Text V.Vector where
  258   getParsedArrays = ccNameArrays <$> get
  259   putParsedArrays f = do
  260     cache <- get
  261     put cache { ccNameArrays = f $ ccNameArrays cache }
  262 
  263 -- | Get contents of an element as CData, split into words and parse.
  264 parseArrayUncached :: ParseArray a v => XML.Element -> ColladaM (v a)
  265 parseArrayUncached element = case XML.elementNodes element of
  266   [XML.NodeContent content] -> return $ VG.fromList $ map parse $ T.words content
  267   _ -> throwError "wrong array"
  268 
  269 -- | Get contents of an element as CData, split into words, parse and cache.
  270 parseArray :: ParseArray a v => XML.Element -> ColladaM (v a)
  271 parseArray element = catchError withId withoutId where
  272   withId = do
  273     elementId <- getElementAttr "id" element
  274     arrays <- getParsedArrays
  275     case MS.lookup elementId arrays of
  276       Just result -> return result
  277       Nothing -> do
  278         result <- parseArrayUncached element
  279         putParsedArrays $ MS.insert elementId result
  280         return result
  281   withoutId _err = parseArrayUncached element
  282 
  283 -- | Parse "source" tag. Right now it just returns underlying array with stride.
  284 parseSource :: ParseArray a v => XML.Element -> ColladaM (v a, Int)
  285 parseSource element@XML.Element
  286   { XML.elementName = XML.Name
  287     { XML.nameLocalName = name
  288     }
  289   } =
  290   if name == "vertices" then do
  291     inputElement <- getSingleChildWithTag "input" element
  292     sourceElement <- resolveElement =<< getElementAttr "source" inputElement
  293     parseSource sourceElement
  294   else do
  295     techniqueElement <- getSingleChildWithTag "technique_common" element
  296     accessorElement <- getSingleChildWithTag "accessor" techniqueElement
  297     count <- parse <$> getElementAttr "count" accessorElement
  298     stride <- parse <$> getElementAttr "stride" accessorElement
  299     arrayElement <- resolveElement =<< getElementAttr "source" accessorElement
  300     values <- parseArray arrayElement
  301     return (VG.take (count * stride) values, stride)
  302 
  303 -- | "Input" tag structure.
  304 data ColladaInputTag = ColladaInputTag
  305   { citSemantic :: !T.Text
  306   , citOffset :: {-# UNPACK #-} !Int
  307   , citSourceElement :: !XML.Element
  308   }
  309 
  310 -- | Parse "input" tag.
  311 parseInput :: XML.Element -> ColladaM ColladaInputTag
  312 parseInput inputElement = do
  313   semantic <- getElementAttr "semantic" inputElement
  314   let offset = maybe 0 parse $ tryGetElementAttr "offset" inputElement
  315   sourceElement <- resolveElement =<< getElementAttr "source" inputElement
  316   return ColladaInputTag
  317     { citSemantic = semantic
  318     , citOffset = offset
  319     , citSourceElement = sourceElement
  320     }
  321 
  322 data ColladaVerticesData = ColladaVerticesData
  323   { cvdCount :: {-# UNPACK #-} !Int
  324   , cvdPositionIndices :: ColladaM (VS.Vector Word32)
  325   , cvdPositions :: ColladaM (VS.Vector Float3)
  326   , cvdNormals :: ColladaM (VS.Vector Float3)
  327   , cvdTexcoords :: ColladaM (VS.Vector Float2)
  328   , cvdWeights :: ColladaM (VS.Vector Float4)
  329   , cvdBones :: ColladaM (VS.Vector (Vec4 Word8))
  330   }
  331 
  332 parseTrianglesOrPolyList :: XML.Element -> ColladaM ColladaVerticesData
  333 parseTrianglesOrPolyList element = do
  334   -- get count
  335   trianglesCount <- parse <$> getElementAttr "count" element
  336   -- if it's polylist, it has "vcount" element with numbers of vertices in each polygon
  337   -- check that there're only triangles
  338   vcountElements <- getChildrenWithTag "vcount" element
  339   case vcountElements of
  340     [vcountElement] -> do
  341       vcounts <- parseArray vcountElement
  342       if VG.length vcounts /= trianglesCount then throwError "wrong number of vcounts"
  343       else unless (VG.all (== (3 :: Word32)) vcounts) $ throwError "only triangles are supported"
  344     [] -> return ()
  345     _ -> throwError "must be 0 or 1 vcount element"
  346   -- parse indices
  347   indices <- parseArray =<< getSingleChildWithTag "p" element
  348   -- parse inputs
  349   inputs <- mapM parseInput =<< getChildrenWithTag "input" element
  350   -- calculate stride and count
  351   let stride = 1 + maximum (map citOffset inputs)
  352   let count = VG.length indices `quot` stride
  353 
  354   -- check
  355   when (trianglesCount * 3 /= count) $ throwError "wrong number of triangles or indices"
  356 
  357   -- flip indices to fix vertex order in triangles
  358   let
  359     flippedIndices = VS.generate (count * stride) $ \i -> let
  360       (p, q) = i `divMod` stride
  361       (pp, pq) = p `divMod` 3
  362       f k = case k of
  363         0 -> 1
  364         1 -> 0
  365         2 -> 2
  366         _ -> undefined
  367       in indices VG.! ((pp * 3 + f pq) * stride + q)
  368 
  369     stream semantic = case filter (\i -> citSemantic i == semantic) inputs of
  370       [ColladaInputTag
  371         { citOffset = offset
  372         , citSourceElement = sourceElement
  373         }] -> do
  374         values <- parseStridables =<< parseSource sourceElement
  375         return $ VG.generate count $ \i -> values VG.! fromIntegral (flippedIndices VG.! (i * stride + offset))
  376       [] -> return VG.empty
  377       _ -> throwError $ "parseTrianglesOrPolyList: wrong semantic: " <> semantic
  378 
  379     positionIndices = case filter (\i -> citSemantic i == "VERTEX") inputs of
  380       [ColladaInputTag
  381         { citOffset = offset
  382         }] -> return $ VG.generate count $ \i -> flippedIndices VG.! (i * stride + offset)
  383       _ -> throwError "no position indices"
  384 
  385   unit <- (csUnit . ccSettings) <$> get
  386 
  387   -- special handling of texcoord streams: allow both 2-coord and 3-coord streams
  388   let
  389     texcoords = catchError (stream "TEXCOORD") $ \_e -> VG.map (\(Vec3 x y _z) -> Vec2 x y) <$> stream "TEXCOORD"
  390 
  391   return ColladaVerticesData
  392     { cvdCount = count
  393     , cvdPositionIndices = positionIndices
  394     , cvdPositions = VG.map (* vecFromScalar unit) <$> stream "VERTEX"
  395     , cvdNormals = stream "NORMAL"
  396     , cvdTexcoords = texcoords
  397     , cvdWeights = return VG.empty
  398     , cvdBones = return VG.empty
  399     }
  400 
  401 parseMesh :: XML.Element -> ColladaM ColladaVerticesData
  402 parseMesh element = parseTrianglesOrPolyList =<< do
  403   -- get triangles or polylist tag
  404   trianglesElements <- getChildrenWithTag "triangles" element
  405   case trianglesElements of
  406     [trianglesElement] -> return trianglesElement
  407     [] -> getSingleChildWithTag "polylist" element
  408     _ -> throwError "must be 0 or 1 triangles element"
  409 
  410 parseGeometry :: XML.Element -> ColladaM ColladaVerticesData
  411 parseGeometry element = parseMesh =<< getSingleChildWithTag "mesh" element
  412 
  413 -- | Transform.
  414 data ColladaTransformTag
  415   = ColladaTranslateTag Float3
  416   | ColladaRotateTag Float3 Float
  417   | ColladaMatrixTag Float4x4
  418   deriving Show
  419 
  420 -- | Node.
  421 data ColladaNodeTag = ColladaNodeTag
  422   { cntElement :: !XML.Element
  423   , cntID :: !T.Text
  424   , cntSID :: !T.Text
  425   , cntTransforms :: [(Maybe T.Text, ColladaTransformTag)]
  426   , cntSubnodes :: [ColladaNodeTag]
  427   } deriving Show
  428 
  429 parseNode :: XML.Element -> ColladaM ColladaNodeTag
  430 parseNode element@XML.Element
  431   { XML.elementNodes = elementNodes
  432   } = do
  433   let
  434     nodeId = fromMaybe "" $ tryGetElementAttr "id" element
  435     sid = fromMaybe "" $ tryGetElementAttr "sid" element
  436 
  437   settings <- ccSettings <$> get
  438 
  439   let
  440     unit = csUnit settings
  441     unitMat = csUnitMat settings
  442     invUnitMat = csInvUnitMat settings
  443 
  444     -- traverse sub elements
  445     f node@ColladaNodeTag
  446       { cntTransforms = transforms
  447       , cntSubnodes = subnodes
  448       } elementNode = case elementNode of
  449       XML.NodeElement subElement@XML.Element
  450         { XML.elementName = XML.Name
  451           { XML.nameLocalName = subElementName
  452           }
  453         } -> case subElementName of
  454         "node" -> do
  455           subnode <- parseNode subElement
  456           return node
  457             { cntSubnodes = subnodes ++ [subnode]
  458             }
  459         "translate" -> do
  460           let maybeTransformSID = tryGetElementAttr "sid" subElement
  461           Vec3 x y z <- (`constructStridable` 0) <$> parseArray subElement
  462           return node
  463             { cntTransforms = transforms ++ [(maybeTransformSID, ColladaTranslateTag $ Vec3 x y z * vecFromScalar unit)]
  464             }
  465         "rotate" -> do
  466           let maybeTransformSID = tryGetElementAttr "sid" subElement
  467           Vec4 x y z a <- (`constructStridable` 0) <$> parseArray subElement
  468           return node
  469             { cntTransforms = transforms ++ [(maybeTransformSID, ColladaRotateTag (Vec3 x y z) (a * pi / 180 :: Float))]
  470             }
  471         "matrix" -> do
  472           let maybeTransformSID = tryGetElementAttr "sid" subElement
  473           mat <- (`constructStridable` 0) <$> parseArray subElement
  474           return node
  475             { cntTransforms = transforms ++ [(maybeTransformSID, ColladaMatrixTag (unitMat `mul` (mat :: Float4x4) `mul` invUnitMat))]
  476             }
  477         _ -> return node
  478       _ -> return node
  479 
  480   foldM f ColladaNodeTag
  481     { cntElement = element
  482     , cntID = nodeId
  483     , cntSID = sid
  484     , cntTransforms = []
  485     , cntSubnodes = []
  486     } elementNodes
  487 
  488 -- | Parse "sampler" tag.
  489 -- Essentially just resolves INPUT and OUTPUT sources.
  490 parseSampler :: (ParseArray i vi, ParseArray o vo) => XML.Element -> ColladaM ((vi i, Int), (vo o, Int))
  491 parseSampler element = do
  492   inputElements <- getChildrenWithTag "input" element
  493   inputs <- mapM parseInput inputElements
  494   let
  495     getInput semantic = case filter (\i -> citSemantic i == semantic) inputs of
  496       [ColladaInputTag
  497         { citOffset = 0
  498         , citSourceElement = sourceElement
  499         }] -> parseSource sourceElement
  500       _ -> throwError $ "parseSampler: wrong semantic: " <> semantic
  501   resultInputs <- getInput "INPUT"
  502   resultOutputs <- getInput "OUTPUT"
  503   return (resultInputs, resultOutputs)
  504 
  505 -- | Animation is just a collection of channels.
  506 newtype ColladaAnimation = ColladaAnimation [ColladaChannelTag]
  507 
  508 -- | Empty animation.
  509 nullAnimation :: ColladaAnimation
  510 nullAnimation = ColladaAnimation []
  511 
  512 -- | "Channel" tag structure.
  513 data ColladaChannelTag = ColladaChannelTag
  514   { cctTarget :: !T.Text
  515   , cctSamplerElement :: !XML.Element
  516   } deriving Show
  517 
  518 -- | Parse "animation" tag.
  519 parseAnimation :: XML.Element -> ColladaM ColladaAnimation
  520 parseAnimation element = do
  521   channelElements <- getChildrenWithTag "channel" element
  522   fmap ColladaAnimation $ forM channelElements $ \channelElement -> do
  523     samplerElement <- resolveElement =<< getElementAttr "source" channelElement
  524     target <- getElementAttr "target" channelElement
  525     return ColladaChannelTag
  526       { cctTarget = target
  527       , cctSamplerElement = samplerElement
  528       }
  529 
  530 -- | Create animation function for node.
  531 animateNode :: Transform t => ColladaNodeTag -> ColladaAnimation -> ColladaM (Float -> t Float)
  532 animateNode ColladaNodeTag
  533   { cntID = nodeId
  534   , cntTransforms = transformTags
  535   } (ColladaAnimation channels) = do
  536 
  537   ColladaSettings
  538     { csUnit = unit
  539     , csUnitMat = unitMat
  540     , csInvUnitMat = invUnitMat
  541     } <- fmap ccSettings get
  542 
  543   -- list of animators (one per transform tag)
  544   transformTagAnimators <- forM transformTags $ \(maybeName, initialTransformTag) -> do
  545 
  546     -- if transform tag is named, there might be some channels affecting it
  547     transformTagAnimator <- case maybeName of
  548 
  549       Just name -> do
  550         -- list of transform combinators for channels affecting transform
  551         channelAnimators <- fmap concat $ forM channels $ \ColladaChannelTag
  552           { cctTarget = target
  553           , cctSamplerElement = samplerElement
  554           } -> case T.stripPrefix (nodeId <> "/" <> name) target of
  555             Just path -> case initialTransformTag of
  556               ColladaTranslateTag _initialOffset -> case path of
  557 
  558                 "" -> do
  559                   a <- animateSampler samplerElement
  560                   return [\(ColladaTranslateTag _offset) time -> ColladaTranslateTag $ a time * vecFromScalar unit]
  561 
  562                 ".X" -> do
  563                   a <- animateSampler samplerElement
  564                   return [\(ColladaTranslateTag (Vec3 _x y z)) time -> ColladaTranslateTag $ Vec3 (a time * unit) y z]
  565 
  566                 ".Y" -> do
  567                   a <- animateSampler samplerElement
  568                   return [\(ColladaTranslateTag (Vec3 x _y z)) time -> ColladaTranslateTag $ Vec3 x (a time * unit) z]
  569 
  570                 ".Z" -> do
  571                   a <- animateSampler samplerElement
  572                   return [\(ColladaTranslateTag (Vec3 x y _z)) time -> ColladaTranslateTag $ Vec3 x y (a time * unit)]
  573 
  574                 _ -> throwError $ "unknown path for translate tag: " <> path
  575 
  576               ColladaRotateTag _initialAxis _initialAngle -> case path of
  577 
  578                 "" -> do
  579                   a <- animateSampler samplerElement
  580                   return [\(ColladaRotateTag _axis _angle) time -> let
  581                     Vec4 x y z angle = a time
  582                     in ColladaRotateTag (Vec3 x y z) (angle * pi / 180)]
  583 
  584                 ".ANGLE" -> do
  585                   a <- animateSampler samplerElement
  586                   return [\(ColladaRotateTag axis _angle) time -> ColladaRotateTag axis (a time * pi / 180)]
  587 
  588                 _ -> throwError $ "unknown path for rotate tag: " <> path
  589 
  590               ColladaMatrixTag _initialMat -> case path of
  591 
  592                 "" -> do
  593                   a <- animateSampler samplerElement
  594                   return [\(ColladaMatrixTag _matrix) time -> ColladaMatrixTag (unitMat `mul` (a time :: Float4x4) `mul` invUnitMat)]
  595 
  596                 _ -> throwError $ "unknown path for matrix tag: " <> path
  597 
  598             Nothing -> return []
  599         -- resulting animation function
  600         return $ \time -> foldl' (\transformTag channelAnimator -> channelAnimator transformTag time) initialTransformTag channelAnimators
  601 
  602       Nothing -> return $ const initialTransformTag
  603 
  604     -- convert transform tag to transform
  605     return $ \time -> case transformTagAnimator time of
  606       ColladaTranslateTag offset -> transformTranslation offset
  607       ColladaRotateTag axis angle -> transformAxisRotation axis angle
  608       ColladaMatrixTag mat -> transformFromMatrix mat
  609 
  610   -- resulting function combines transforms from all transform animators
  611   return $ \time ->
  612     foldr (\transformTagAnimator transform ->
  613       combineTransform (transformTagAnimator time) transform) identityTransform transformTagAnimators
  614 
  615 class Stridable s a where
  616   stridableStride :: s a -> Int
  617   constructStridable :: VG.Vector v a => v a -> Int -> s a
  618 
  619 instance Vectorized a => Stridable Vec2 a where
  620   stridableStride _ = 2
  621   constructStridable v i = Vec2 (q 0) (q 1) where q j = v VG.! (i + j)
  622 
  623 instance Vectorized a => Stridable Vec3 a where
  624   stridableStride _ = 3
  625   constructStridable v i = Vec3 (q 0) (q 1) (q 2) where q j = v VG.! (i + j)
  626 
  627 instance Vectorized a => Stridable Vec4 a where
  628   stridableStride _ = 4
  629   constructStridable v i = Vec4 (q 0) (q 1) (q 2) (q 3) where q j = v VG.! (i + j)
  630 
  631 instance Vectorized a => Stridable Mat4x4 a where
  632   stridableStride _ = 16
  633   constructStridable v i = Mat4x4
  634     (q 0) (q 1) (q 2) (q 3)
  635     (q 4) (q 5) (q 6) (q 7)
  636     (q 8) (q 9) (q 10) (q 11)
  637     (q 12) (q 13) (q 14) (q 15)
  638     where q j = v VG.! (i + j)
  639 
  640 -- | Convert vector of primitive values to vector of Stridables.
  641 stridableStream :: (Storable a, Storable (s a), Stridable s a) => VS.Vector a -> VS.Vector (s a)
  642 stridableStream = f undefined where
  643   f :: (Storable a, Storable (s a), Stridable s a) => s a -> VS.Vector a -> VS.Vector (s a)
  644   f u v = VS.generate (VG.length v `quot` stride) $ \i -> constructStridable v $ i * stride where
  645     stride = stridableStride u
  646 
  647 parseStridables :: (Storable a, Storable (s a), Stridable s a) => (VS.Vector a, Int) -> ColladaM (VS.Vector (s a))
  648 parseStridables (q, stride) = f undefined q where
  649   f :: (Storable a, Storable (s a), Stridable s a) => s a -> VS.Vector a -> ColladaM (VS.Vector (s a))
  650   f u v = if stride == stridableStride u
  651     then return $ stridableStream v
  652     else throwError "wrong stride"
  653 
  654 class Animatable a where
  655   animatableStride :: a -> Int
  656   animatableConstructor :: VS.Vector Float -> Int -> a
  657   interpolateAnimatable :: Float -> a -> a -> a
  658 
  659 instance Animatable Float where
  660   animatableStride _ = 1
  661   animatableConstructor v i = v VG.! i
  662   interpolateAnimatable t a b = a * (1 - t) + b * t
  663 
  664 instance Animatable Float3 where
  665   animatableStride = stridableStride
  666   animatableConstructor v i = Vec3 (v VG.! i) (v VG.! (i + 1)) (v VG.! (i + 2))
  667   interpolateAnimatable t a b = a * vecFromScalar (1 - t) + b * vecFromScalar t
  668 
  669 instance Animatable Float4 where
  670   animatableStride = stridableStride
  671   animatableConstructor v i = Vec4 (v VG.! i) (v VG.! (i + 1)) (v VG.! (i + 2)) (v VG.! (i + 3))
  672   interpolateAnimatable t a b = a * vecFromScalar (1 - t) + b * vecFromScalar t
  673 
  674 instance Animatable Float4x4 where
  675   animatableStride = stridableStride
  676   animatableConstructor = constructStridable
  677   interpolateAnimatable t a b = a * matFromScalar (1 - t) + b * matFromScalar t
  678 
  679 animateSampler :: Animatable a => XML.Element -> ColladaM (Float -> a)
  680 animateSampler element = do
  681   ((inputs, 1), (outputs, outputStride)) <- parseSampler element
  682   let
  683     len = VG.length inputs
  684     search time left right = if left + 1 < right then let
  685       mid = (left + right) `quot` 2
  686       midTime = inputs VG.! mid
  687       in if time >= midTime then search time mid right else search time left mid
  688       else left
  689   return $ \time -> let
  690     offset = search time 0 len
  691     offset2 = offset + 1
  692     input = inputs VG.! offset
  693     input2 = inputs VG.! offset2
  694     output = animatableConstructor outputs $ offset * outputStride
  695     output2 = animatableConstructor outputs $ offset2 * outputStride
  696     t = (time - input) / (input2 - input)
  697     in if offset + 1 >= len then output else interpolateAnimatable t output output2
  698 
  699 -- | Flattened node hierarchy, in strict order from root to leaves.
  700 newtype ColladaSkeleton = ColladaSkeleton (V.Vector ColladaSkeletonNode) deriving Show
  701 
  702 data ColladaSkeletonNode = ColladaSkeletonNode
  703   { csklnNodeTag :: ColladaNodeTag
  704   , csklnParentId :: {-# UNPACK #-} !Int
  705   } deriving Show
  706 
  707 -- | Create flat skeleton structure for node hierarchy.
  708 parseSkeleton :: XML.Element -> ColladaM ColladaSkeleton
  709 parseSkeleton element = do
  710   rootNodeTag <- parseNode element
  711   let
  712     go parentId currentId nodeTag@ColladaNodeTag
  713       { cntSubnodes = subnodeTags
  714       } = (resultNextId, node : concat resultSubnodes) where
  715       node = ColladaSkeletonNode
  716         { csklnNodeTag = nodeTag
  717         , csklnParentId = parentId
  718         }
  719       (resultNextId, resultSubnodes) = foldl (
  720         \(accNextId, accSubnodes) subnodeTag -> let
  721           (nextId, subnodes) = go currentId accNextId subnodeTag
  722           in (nextId, accSubnodes ++ [subnodes])
  723         ) (currentId + 1, []) subnodeTags
  724     (_, nodes) = go (-1) 0 rootNodeTag
  725   return $ ColladaSkeleton $ V.fromList nodes
  726 
  727 -- | Create animation function for skeleton.
  728 animateSkeleton :: Transform t => ColladaSkeleton -> ColladaAnimation -> ColladaM (t Float -> Float -> V.Vector (t Float))
  729 animateSkeleton (ColladaSkeleton nodes) animation = do
  730   nodeAnimators <- forM nodes $ \ColladaSkeletonNode
  731     { csklnNodeTag = nodeTag
  732     } -> animateNode nodeTag animation
  733   return $ \rootTransform time -> V.create $ do
  734     transforms <- VM.new $ V.length nodes
  735     forM_ [0..(V.length nodes - 1)] $ \i -> do
  736       let
  737         ColladaSkeletonNode
  738           { csklnParentId = parentId
  739           } = nodes V.! i
  740       parentTransform <- if parentId >= 0 then VM.read transforms parentId else return rootTransform
  741       VM.write transforms i $ combineTransform parentTransform $ (nodeAnimators V.! i) time
  742     return transforms
  743 
  744 newtype ColladaSkin t = ColladaSkin
  745   {
  746   -- | Bones used in skinning, in order corresponding to bone indices in mesh.
  747     cskinBones :: V.Vector (ColladaBone t)
  748   } deriving Show
  749 
  750 data ColladaBone t = ColladaBone
  751   {
  752   -- | Index of bone in skeleton.
  753     cboneSkeletonIndex :: !Int
  754   -- | Inverse bind transform.
  755   , cboneInvBindTransform :: !t
  756   } deriving Show
  757 
  758 parseSkin :: Transform t => ColladaSkeleton -> XML.Element -> ColladaM (ColladaVerticesData, ColladaSkin (t Float))
  759 parseSkin (ColladaSkeleton nodes) skinElement = do
  760   ColladaSettings
  761     { csUnitMat = unitMat
  762     , csInvUnitMat = invUnitMat
  763     } <- fmap ccSettings get
  764 
  765   bindShapeTransform <- fmap (\v -> constructStridable v 0 :: Float4x4) (parseArray =<< getSingleChildWithTag "bind_shape_matrix" skinElement)
  766 
  767   jointsElement <- getSingleChildWithTag "joints" skinElement
  768   jointsInputs <- mapM parseInput =<< getChildrenWithTag "input" jointsElement
  769 
  770   let
  771     findInput inputs semantic parent = case filter (\input -> citSemantic input == semantic) inputs of
  772       [input] -> return input :: ColladaM ColladaInputTag
  773       _ -> throwError $ "no single " <> parent <> " input with " <> semantic <> " semantic"
  774 
  775   jointsJointInput <- findInput jointsInputs "JOINT" "joints"
  776   jointsJointNames <- fmap fst $ parseSource $ citSourceElement jointsJointInput
  777   jointsInvBindMatrixInput <- findInput jointsInputs "INV_BIND_MATRIX" "joints"
  778   jointsInvBindTransforms <- parseStridables =<< parseSource (citSourceElement jointsInvBindMatrixInput)
  779 
  780   skinBones <- flip VG.imapM jointsJointNames $ \i jointName -> case V.findIndex (\ColladaSkeletonNode
  781     { csklnNodeTag = ColladaNodeTag
  782       { cntSID = sid
  783       }
  784     } -> sid == jointName) nodes of
  785     Just nodeIndex -> return ColladaBone
  786       { cboneSkeletonIndex = nodeIndex
  787       , cboneInvBindTransform = transformFromMatrix $ unitMat `mul` (jointsInvBindTransforms VG.! i :: Float4x4) `mul` bindShapeTransform `mul` invUnitMat
  788       }
  789     Nothing -> throwError $ "missing skeleton node for joint " <> jointName
  790 
  791   let
  792     namedBones = MS.fromList $ zip (VG.toList jointsJointNames) [0..]
  793 
  794   vertexWeightsElement <- getSingleChildWithTag "vertex_weights" skinElement
  795   vertexWeightsInputs <- mapM parseInput =<< getChildrenWithTag "input" vertexWeightsElement
  796   let
  797     vertexWeightsStride = length vertexWeightsInputs
  798 
  799   vertexWeightsJointInput <- findInput vertexWeightsInputs "JOINT" "vertex_weights"
  800   vertexWeightsJointNames <- fmap fst $ parseSource $ citSourceElement vertexWeightsJointInput
  801   let
  802     vertexWeightsJointOffset = citOffset vertexWeightsJointInput
  803   vertexWeightsJointBones <- VG.forM vertexWeightsJointNames $ \jointName -> case MS.lookup jointName namedBones of
  804     Just bone -> return bone
  805     Nothing -> throwError $ "missing bone for joint " <> jointName
  806 
  807   vertexWeightsWeightInput <- findInput vertexWeightsInputs "WEIGHT" "vertex_weights"
  808   vertexWeightsWeights <- fmap fst $ parseSource $ citSourceElement vertexWeightsWeightInput
  809   let
  810     vertexWeightsWeightOffset = citOffset vertexWeightsWeightInput
  811 
  812   count <- parse <$> getElementAttr "count" vertexWeightsElement
  813   vcount <- parseArray =<< getSingleChildWithTag "vcount" vertexWeightsElement
  814   v <- parseArray =<< getSingleChildWithTag "v" vertexWeightsElement
  815 
  816   let
  817     -- constant
  818     bonesPerVertex = 4
  819 
  820     (rawWeights, rawBones) = unsafePerformIO $ do
  821       weights <- VSM.new $ count * bonesPerVertex
  822       bones <- VSM.new $ count * bonesPerVertex
  823       -- loop for vertices
  824       let
  825         f j i bonesCount = do
  826           weightJointPairs <- VUM.new $ fromIntegral (bonesCount :: Word32)
  827 
  828           -- loop for bones of vertex
  829           forM_ [0..(fromIntegral bonesCount - 1)] $ \k -> let
  830             o = (j + k) * vertexWeightsStride
  831             jointIndex = v VG.! (o + vertexWeightsJointOffset) :: Word32
  832             weightIndex = v VG.! (o + vertexWeightsWeightOffset)
  833             in VGM.write weightJointPairs k (vertexWeightsWeights VG.! fromIntegral weightIndex, vertexWeightsJointBones VG.! fromIntegral jointIndex)
  834 
  835           -- sort weight-joint pairs
  836           VAI.sort weightJointPairs
  837 
  838           -- pick up most weighted
  839           freezedWeightJointPairs <- VU.unsafeFreeze weightJointPairs
  840           let
  841             len = VG.length freezedWeightJointPairs
  842             bestWeightJointPairs =
  843               if len >= bonesPerVertex then VG.drop (len - bonesPerVertex) freezedWeightJointPairs
  844               else freezedWeightJointPairs VG.++ VG.fromList (replicate (bonesPerVertex - len) (0, 0))
  845 
  846             -- calc sum of weights to normalize
  847             weightSum = VG.sum $ VG.map fst bestWeightJointPairs
  848 
  849           -- write weights and bones
  850           forM_ [0..(bonesPerVertex - 1)] $ \k -> do
  851             let
  852               (weight, bone) = bestWeightJointPairs VG.! k
  853             VGM.write weights (i * bonesPerVertex + k) $ weight / weightSum
  854             VGM.write bones (i * bonesPerVertex + k) bone
  855 
  856           return $ j + fromIntegral bonesCount
  857         in VG.ifoldM'_ f 0 vcount
  858 
  859       freezedWeights <- VG.unsafeFreeze weights
  860       freezedBones <- VG.unsafeFreeze bones
  861       return (stridableStream freezedWeights, stridableStream freezedBones)
  862 
  863   verticesData <- parseGeometry =<< resolveElement =<< getElementAttr "source" skinElement
  864 
  865   positionIndices <- cvdPositionIndices verticesData
  866 
  867   return (verticesData
  868     { cvdWeights = return $ VS.generate (VG.length positionIndices) $ \i -> rawWeights VG.! fromIntegral (positionIndices VG.! i)
  869     , cvdBones = return $ VS.generate (VG.length positionIndices) $ \i -> rawBones VG.! fromIntegral (positionIndices VG.! i)
  870     }, ColladaSkin
  871     { cskinBones = skinBones
  872     })
  873 
  874 -- Re-export of some XML types.
  875 type ColladaElement = XML.Element