1 files changed, 95 insertions, 6 deletions

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)