module PLY.Data (PLYData, loadPLY, loadElements, loadElementsV3,
loadMeshesV3) where
import Control.Applicative
import Control.Concurrent.ParallelIO (parallel)
import Control.Lens (view)
import Data.Attoparsec.Char8
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BC
import Data.Either (partitionEithers)
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import Linear.Matrix (mkTransformation, (!*))
import Linear.V3
import Linear.V4 (vector)
import System.Directory (canonicalizePath)
import System.FilePath (takeDirectory, (</>))
import PLY.Conf
import PLY.Internal.Parsers (line, parseSkip, skip, multiProps,
parseScalar, header)
import PLY.Types
type Header = (Format, [Element])
newtype PLYData = PLYData (ByteString, Header)
instance Show PLYData where
show (PLYData (_,h)) = "PLYData <bytes> " ++ show h
parseASCII :: Element -> Parser (Vector (Vector Scalar))
parseASCII e = V.replicateM (elNum e)
(skip *> (V.fromList <$> multiProps (elProps e)))
parseASCIIv3 :: forall a. PLYType a => Element -> Parser (VS.Vector (V3 a))
parseASCIIv3 (Element _ n ps@[_,_,_])
| all samePropType ps = VS.replicateM n (skip *> (V3 <$> p <*> p <*> p))
| otherwise = empty
where t = plyType (undefined::a)
p = unsafeUnwrap <$> (parseScalar t <* skipSpace)
samePropType (ScalarProperty t' _) = t == t'
samePropType (ListProperty _ _) = False
parseASCIIv3 _ = empty
loadPLY :: ByteString -> Either String PLYData
loadPLY = aux . parse header
where aux (Fail _t ctxt msg) = Left $ "Parse failed: "++msg++" in "++show ctxt
aux (Partial _) = Left "Incomplete header"
aux (Done t r) = Right $ PLYData (t, r)
loadElements :: ByteString -> PLYData ->
Either String (Vector (Vector Scalar))
loadElements n (PLYData (body, (ASCII, ess))) = go ess body
where go [] _ = Left "Unknown element"
go (e:es) b | elName e == n = parseOnly (parseASCII e) b
| otherwise = go es $
parseSkip (count (elNum e) line *> pure ()) b
loadElements _ _ = error "Binary PLY is unsupported"
loadElementsV3 :: PLYType a => ByteString -> PLYData ->
Either String (VS.Vector (V3 a))
loadElementsV3 n (PLYData (body, (ASCII, ess))) = go ess body
where go [] _ = Left "Unknown element"
go (e:es) b | elName e == n = parseOnly (parseASCIIv3 e) b
| otherwise = go es $
parseSkip (count (elNum e) line *> pure ()) b
loadElementsV3 _ _ = error "Binary PLY is unsupported"
(>=!>) :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c
f >=!> g !x = f x >>= (g $!)
infixr 1 >=!>
loadMeshesV3 :: forall a. (PLYType a, Fractional a) =>
FilePath -> ByteString -> IO (Either [String] (VS.Vector (V3 a)))
loadMeshesV3 confFile element = do dir <- takeDirectory <$>
canonicalizePath confFile
c <- parseConf <$> BS.readFile confFile
either (return . Left . (:[]))
(fmap checkConcat . loadAllMeshes dir)
c
where checkErrors :: [Either String (VS.Vector (V3 a))] -> Either [String] [VS.Vector (V3 a)]
checkErrors xs = let (ls,rs) = partitionEithers xs
in if null ls then Right rs else Left ls
checkConcat :: [Either String (VS.Vector (V3 a))] -> Either [String] (VS.Vector (V3 a))
checkConcat = (fmap VS.concat $!) . checkErrors
loadMesh :: FilePath -> (ByteString, Transformation Double) ->
IO (Either String (VS.Vector (V3 a)))
loadMesh d (f, (t,r)) =
let m = mkTransformation (fmap realToFrac r) (fmap realToFrac t)
in (loadPLY
>=!> loadElementsV3 element
>=!> return . VS.map (view _xyz . (m !*) . vector))
<$> BS.readFile (d </> BC.unpack f)
loadAllMeshes :: FilePath -> Conf ->
IO ([Either String (VS.Vector (V3 a))])
loadAllMeshes dir = parallel . map (loadMesh dir) . meshes