From f414c3f017a9da40440262bda8aac0486ef6e21b Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 20 Jul 2019 21:03:55 -0400 Subject: Support for renumbering vertices. --- src/Text/UTF8.hs | 81 +++++++++++++++++++++++++++++++++++++++++ src/Wavefront.hs | 45 ++++++++++++++++++++++- src/Wavefront/Lex.hs | 101 ++++++++++++++++++++++++++++++++++++++++++++++++--- wavefront-obj.cabal | 7 +++- 4 files changed, 226 insertions(+), 8 deletions(-) create mode 100644 src/Text/UTF8.hs diff --git a/src/Text/UTF8.hs b/src/Text/UTF8.hs new file mode 100644 index 0000000..d793c8e --- /dev/null +++ b/src/Text/UTF8.hs @@ -0,0 +1,81 @@ +module Text.UTF8 (packUtf8,unpackUtf8) where + +import Data.Word --(Word8,Word32) +import Data.Bits ((.|.),(.&.),shiftL,shiftR) +import Data.Char (chr,ord) +import qualified Data.ByteString as B + +packUtf8 :: String -> B.ByteString +packUtf8 = B.pack . encode + +unpackUtf8 :: B.ByteString -> String +unpackUtf8 = decode . B.unpack + + +replacement_character :: Char +replacement_character = '\xfffd' + +-- +-- | Decode a UTF8 string packed into a list of Word8 values, directly to String +-- +decode :: [Word8] -> String +decode [ ] = "" +decode (c:cs) + | c < 0x80 = chr (fromEnum c) : decode cs + | c < 0xc0 = replacement_character : decode cs + | c < 0xe0 = multi1 + | c < 0xf0 = multi_byte 2 0xf 0x800 + | c < 0xf8 = multi_byte 3 0x7 0x10000 + | c < 0xfc = multi_byte 4 0x3 0x200000 + | c < 0xfe = multi_byte 5 0x1 0x4000000 + | otherwise = replacement_character : decode cs + where + multi1 = case cs of + c1 : ds | c1 .&. 0xc0 == 0x80 -> + let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) + in if d >= 0x000080 then toEnum d : decode ds + else replacement_character : decode ds + _ -> replacement_character : decode cs + + multi_byte :: Int -> Word8 -> Int -> [Char] + multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) + where + aux 0 rs acc + | overlong <= acc && acc <= 0x10ffff && + (acc < 0xd800 || 0xdfff < acc) && + (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs + | otherwise = replacement_character : decode rs + + aux n (r:rs) acc + | r .&. 0xc0 == 0x80 = aux (n-1) rs + $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) + + aux _ rs _ = replacement_character : decode rs + + +-- | Encode a single Haskell Char to a list of Word8 values, in UTF8 format. +encodeChar :: Char -> [Word8] +encodeChar = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) + , 0x80 + oc .&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `shiftR` 18) + , 0x80 + ((oc `shiftR` 12) .&. 0x3f) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +encode :: String -> [Word8] +encode = concatMap encodeChar + diff --git a/src/Wavefront.hs b/src/Wavefront.hs index 638b849..32959d4 100644 --- a/src/Wavefront.hs +++ b/src/Wavefront.hs @@ -11,6 +11,7 @@ import qualified Data.DList as DList ;import Data.DList (DList) import Data.Functor.Identity import qualified Data.IntMap as IntMap +import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import qualified Data.Vector as Vector ;import Data.Vector (Vector) @@ -104,7 +105,7 @@ buildOBJ = nullBuilder , mtllib = \xs -> do let l = map decodeUtf8 xs libs <- gets (objMtlLibs . fst) - modifyFirst $ \o -> o { objMtlLibs = libs `DList.append` DList.fromList l } + modifyFirst $ \o -> o { objMtlLibs = DList.fromList l `DList.append` libs } , groups = \xs -> do let g = map decodeUtf8 xs modify' $ second $ \e -> e { elGroups = g } @@ -159,3 +160,45 @@ parseCustom :: Monad m => ObjBuilder m -> (OBJ Count -> m b) -> L.ByteString -> parseCustom builder finish bs = do counts <- execStateT (parseOBJ (objBookKeeping builder) (ObjConfig IntMap.empty) bs) emptyCounts finish counts + +data Renumbering = Renumbering + { renumV :: Int -> Int + , renumVT :: Int -> Int + , renumVN :: Int -> Int + , renumVP :: Int -> Int + } + +renumFrom1 :: Renumbering +renumFrom1 = Renumbering + { renumV = succ + , renumVT = succ + , renumVN = succ + , renumVP = succ + } + +addCounts :: OBJ Count -> Renumbering -> Renumbering +addCounts c r = Renumbering + { renumV = addc (objLocations c) . renumV r + , renumVT = addc (objTexCoords c) . renumVT r + , renumVN = addc (objNormals c) . renumVN r + , renumVP = renumVP r -- TODO + } + +addc :: Count x -> Int -> Int +addc (Count c) x = c + x + +renumTriple :: Renumbering -> RefTriple -> RefTriple +renumTriple r (RefTriple v t n) = RefTriple (renumV r v) (renumVT r <$> t) (renumVN r <$> n) + +applyRenumbering :: MonadState Renumbering m => ObjBuilder m -> ObjBuilder m +applyRenumbering builder = builder + { face = \ts -> do + r <- get + face builder $ map (renumTriple r) ts + , line = \ts -> do + r <- get + line builder $ map (renumTriple r) ts + , surf = \u0 u1 v0 v1 ts -> do + r <- get + surf builder u0 u1 v0 v1 $ map (renumTriple r) ts + } diff --git a/src/Wavefront/Lex.hs b/src/Wavefront/Lex.hs index 05a6595..f4cb54a 100644 --- a/src/Wavefront/Lex.hs +++ b/src/Wavefront/Lex.hs @@ -2,15 +2,21 @@ {-# LANGUAGE OverloadedStrings #-} module Wavefront.Lex where +import Data.Bool import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S import Data.ByteString.Internal as BS +import Data.ByteString.Lex.Fractional as F +import Data.ByteString.Lex.Integral as I import Data.Char import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import Data.ByteString.Lex.Fractional as F -import Data.ByteString.Lex.Integral as I +import Data.List +import Data.Maybe import qualified Rank2 +import Control.Monad.Writer.Lazy + +import Text.UTF8 data ObjBuilder m = ObjBuilder { vertex :: [Double] -> m () @@ -18,7 +24,7 @@ data ObjBuilder m = ObjBuilder , vertexN :: [Double] -> m () , vertexP :: [Double] -> m () , face :: [RefTriple] -> m () - , line :: [RefTriple] -> m () + , line :: [RefTriple] -> m () , cstype :: Bool -> CSType -> m () , curv2 :: [Int] -> m () , curv :: Double -> Double -> [Int] -> m () @@ -67,7 +73,7 @@ instance Rank2.Functor ObjBuilder where , vertexN = \vs -> f $ vertexN b vs , vertexP = \vs -> f $ vertexP b vs , face = \is -> f $ face b is - , line = \is -> f $ line b is + , line = \is -> f $ line b is , cstype = \isRat typ -> f $ cstype b isRat typ , curv2 = \is -> f $ curv2 b is , curv = \u0 v0 is -> f $ curv b u0 v0 is @@ -159,6 +165,59 @@ nullBuilder = ObjBuilder , badToken = \bs -> pure () } +echoBuilder :: (MonadWriter (f String) m, Applicative f) => ObjBuilder m +echoBuilder = ObjBuilder + { vertex = \vs -> echo $ unwords ("v": map show vs) + , vertexT = \vs -> echo $ unwords ("vt": map show vs) + , vertexN = \vs -> echo $ unwords ("vn": map show vs) + , vertexP = \vs -> echo $ unwords ("vp": map show vs) + , face = \ts -> echo $ unwords ("f":map showRefTriple ts) + , line = \ts -> echo $ unwords ("l":map showRefTriple ts) + , cstype = \isRat typ -> echo $ unwords [ if isRat then "cstype rat" else "cstype" + , map toLower (show typ) ] + , curv2 = \is -> echo $ unwords ("curv2":map show is) + , curv = \u0 v0 is -> echo $ unwords ("curv":show u0:show v0:map show is) + , parm = \isU ds -> echo $ unwords ("parm":showParamSpec isU:map show ds) + , specialPoints = \is -> echo $ unwords ("sp":map show is) + , endFreeForm = echo "end" + , ctech = \approx -> echo $ "ctech " ++ showCurveSamplingSpec approx + , stech = \approx -> echo $ "stech " ++ showSurfaceSamplingSpec approx + , deg = \is -> echo $ unwords ("deg":map show is) + , surf = \u0 u1 v0 v1 ts -> echo $ unwords $ "surf " : map show [u0,u1,v0,v1] + ++ map showRefTriple ts + , trim = \ss -> echo $ unwords ("trim":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss) + , hole = \ss -> echo $ unwords ("hole":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss) + , specialCurves = \ss -> echo $ unwords ("scrv":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss) + , equivalentCurves = \ccs -> echo $ unwords ("con":map showEmbeddedCurve ccs) + , groups = \gs -> echo $ unwords $ "g":map unpackUtf8 gs + , smoothingGroup = \sg -> echo ("s " ++ show sg) + , mergingGroup = \mg δ -> echo $ unwords ["mg",show mg,show δ] + , usemtl = \mtl -> echo ("usemtl " ++ unpackUtf8 mtl) + , deprecated_cdc = \is -> echo $ unwords ("cdc":map show is) + , deprecated_bzp = \is -> echo $ unwords ("bzp":map show is) + , mtllib = \fns -> echo $ unwords $ "mtllib " : map unpackUtf8 fns + , objectName = \obn -> echo ("o " ++ unpackUtf8 obn) + , bmat = \isU is -> echo $ unwords ("bmat":showParamSpec isU:map show is) + , step = \is -> echo $ unwords ("step":map show is) + , points = \is -> echo $ unwords ("p":map show is) + , usemap = \mp -> echo $ "usemap " ++ maybe "off" unpackUtf8 mp + , maplib = \fns -> echo ("maplib " ++ show fns) + , c_interp = \flag -> echo $ "c_interp " ++ bool "off" "on" flag + , d_interp = \flag -> echo $ "d_interp " ++ bool "off" "on" flag + , deprecated_cdp = \x -> echo $ "cdp " ++ show x + , deprecated_bsp = \x -> echo $ "bsp " ++ show x + , trace_obj = \x -> echo $ "trace_obj " ++ unpackUtf8 x + , shadow_obj = \x -> echo $ "shadow_obj " ++ unpackUtf8 x + , deprecated_res = \x -> echo $ "res " ++ show x + , bevel = \x -> echo $ "bevel " ++ show x + , lod = \x -> echo $ "lod " ++ show x + , call = \fn as -> echo $ unwords ("call":map unpackUtf8 (fn:as)) + , command = \e cmd -> do echo $ "csh " ++ (bool ('-':) id e $ unpackUtf8 $ L.toStrict cmd) + return L.empty + , badToken = \bs -> echo $ "bad token: " ++ show (L.take 20 bs) + } + where + echo = tell . pure data CurveSamplingSpec -- ctech cparm @@ -175,6 +234,11 @@ data CurveSamplingSpec | CurvatureBasedPolygon { maxDistanceToCurve :: Double, maximumDegreesPerSample :: Double } deriving (Eq,Show) +showCurveSamplingSpec :: CurveSamplingSpec -> String +showCurveSamplingSpec (UniformSubdivision d) = "cparm " ++ show d +showCurveSamplingSpec (MaxLengthPolygonal d) = "cspace " ++ show d +showCurveSamplingSpec (CurvatureBasedPolygon d a) = unwords ["curv",show d,show a] + data SurfaceSamplingSpec -- stech cparma ures vres = UniformIsoparametric { uDivisionsPerDegree :: Double, vDivisionsPerDegree :: Double } @@ -186,6 +250,11 @@ data SurfaceSamplingSpec | CurvatureBasedPolytope { maxDistanceToSurface :: Double, maxDegreesPerCorner :: Double } deriving (Eq,Show) +showSurfaceSamplingSpec :: SurfaceSamplingSpec -> String +showSurfaceSamplingSpec (UniformIsoparametric ures vres) = unwords ["cparma",show ures,show vres] +showSurfaceSamplingSpec (UniformAfterTrimming uvres) = "cparmb " ++ show uvres +showSurfaceSamplingSpec (MaxLengthPolytopal maxlength) = "cspace " ++ show maxlength +showSurfaceSamplingSpec (CurvatureBasedPolytope maxd maxa) = unwords ["curv",show maxd,show maxa] data ObjState = ObjState { @@ -291,13 +360,13 @@ findNewLine ps o@(ObjConfig args) bs = case L.break (\c -> c=='\n' || c=='\\' || nextToken :: (L.ByteString -> L.ByteString) -> L.ByteString -> L.ByteString nextToken tok bs = tok $ L.dropWhile (not . isSpace) bs -parseFloats tok bs cont = case L.splitAt 10 (tok bs) of +parseFloats tok bs cont = case L.splitAt 22 (tok bs) of (ds,bs') -> case F.readSigned F.readExponential (L.toStrict ds) of Just (x,b) -> parseFloats tok (reconsChunk b bs') (cont . (x :)) Nothing -> cont [] bs parseFloatsN 0 _ bs cont = cont [] bs -parseFloatsN n tok bs cont = case L.splitAt 10 (tok bs) of +parseFloatsN n tok bs cont = case L.splitAt 22 (tok bs) of (ds,bs') -> case F.readSigned F.readExponential (L.toStrict ds) of Just (x,b) -> parseFloatsN (n-1) tok (reconsChunk b bs') (cont . (x :)) Nothing -> cont [] bs @@ -376,6 +445,10 @@ data CSType = Bmatrix | Bezier | Bspline | Cardinal | Taylor data ParamSpec = ParamU | ParamV deriving (Eq,Ord,Show,Enum) +showParamSpec :: ParamSpec -> String +showParamSpec ParamU = "u" +showParamSpec ParamV = "v" + data RefTriple = RefTriple { refV :: {-# UNPACK #-} !Int , refT :: !(Maybe Int) @@ -384,6 +457,14 @@ data RefTriple = RefTriple -- data RefTriple = RefTriple Int (Maybe Int) (Maybe Int) deriving (Eq,Ord,Show) +showRefTriple :: RefTriple -> String +showRefTriple (RefTriple v Nothing (Just n)) = show v ++ "//" ++ show n +showRefTriple (RefTriple v mt mn) = intercalate "/" $ map show + $ mappend [v] + $ maybe id (mappend . pure) mt + $ maybe id (mappend . pure) mn + $ [] + data CurveSpec = CurveSpec { curveStart :: Double , curveEnd :: Double @@ -397,6 +478,14 @@ data EmbeddedCurve = EmbeddedCurve } deriving (Eq,Ord,Show) +showEmbeddedCurve :: EmbeddedCurve -> String +showEmbeddedCurve (EmbeddedCurve s c) = unwords + [ show s + , show (curveStart c) + , show (curveEnd c) + , show (curveRef c) + ] + lengthLessThan :: Int -> L.ByteString -> Bool lengthLessThan n bs = foldr (\c ret ac -> let m = S.length c in if ac <= m then False else ret $! ac - m) diff --git a/wavefront-obj.cabal b/wavefront-obj.cabal index 5baa231..507c3c6 100644 --- a/wavefront-obj.cabal +++ b/wavefront-obj.cabal @@ -17,7 +17,7 @@ library exposed-modules: Wavefront.Lex , Wavefront.Types , Wavefront - -- other-modules: + other-modules: Text.UTF8 other-extensions: ConstraintKinds , DeriveFunctor , FlexibleContexts @@ -44,3 +44,8 @@ library hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wmissing-signatures + +executable objcat + main-is: tools/objcat.hs + build-depends: base, bytestring, containers, dlist, mtl, wavefront-obj -- cgit v1.2.3