Support for renumbering vertices.

4 files changed, 226 insertions, 8 deletions

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