summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-07-23 20:07:17 -0400
committerJoe Crayne <joe@jerkface.net>2019-07-23 20:07:17 -0400
commite2a39102145e8cb145c690f9b56d4c63126fe106 (patch)
tree16004ae84193ea752330c2a4f55445dd2264ebed
parentd8dbabde5b6438a0298ed11275b2951f4ae6d7bf (diff)
WIP: Freeform surfaces.
-rw-r--r--src/Wavefront.hs84
-rw-r--r--src/Wavefront/Lex.hs20
-rw-r--r--src/Wavefront/Types.hs24
3 files changed, 106 insertions, 22 deletions
diff --git a/src/Wavefront.hs b/src/Wavefront.hs
index cae6508..3c4eff0 100644
--- a/src/Wavefront.hs
+++ b/src/Wavefront.hs
@@ -1,4 +1,5 @@
1{-# LANGUAGE FlexibleContexts #-} 1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE RankNTypes #-}
2module Wavefront where 3module Wavefront where
3 4
4import Wavefront.Types 5import Wavefront.Types
@@ -60,7 +61,9 @@ objBookKeeping builder = (lift Rank2.<$> builder)
60 incrementCount objFaces $ \x o -> o { objFaces = x } 61 incrementCount objFaces $ \x o -> o { objFaces = x }
61 } 62 }
62 63
64-- TODO: meshlab vertex colors extension
63mkv :: [Double] -> Location 65mkv :: [Double] -> Location
66mkv [x,y,z,r,g,b] = Location x' y' z' 1 where (x':y':z':_) = map realToFrac [x,y,z]
64mkv cs = Location x y z w where (x:y:z:w:_) = map realToFrac cs ++ repeat 1 67mkv cs = Location x y z w where (x:y:z:w:_) = map realToFrac cs ++ repeat 1
65 68
66mkt :: [Double] -> TexCoord 69mkt :: [Double] -> TexCoord
@@ -79,45 +82,94 @@ mkF (RefTriple a at an) = FaceIndex a at an
79elemental :: Element () -> x -> Element x 82elemental :: Element () -> x -> Element x
80elemental element x = fmap (const x) element 83elemental element x = fmap (const x) element
81 84
82modifyFirst :: MonadState (c, d) m => (c -> c) -> m () 85modifyFirst :: MonadState ParserState m => (OBJ DList -> OBJ DList) -> m ()
83modifyFirst = modify' . first 86modifyFirst = modify' . (\f s -> s { pstObj = f (pstObj s) })
84 87
85buildOBJ :: ObjBuilder (State (OBJ DList,Element ())) 88modifySecond :: MonadState ParserState m => (Element () -> Element ()) -> m ()
89modifySecond = modify' . (\f s -> s { pstElm = f (pstElm s) })
90
91(*.*) :: (OBJ DList -> a) -> (Element () -> b) -> ParserState -> (a, b)
92fld *.* elm = \s -> (fld (pstObj s), elm (pstElm s))
93
94data FFPts = Curv Float Float [Int]
95 | Curv2 [Int]
96 | Surf Float Float Float Float [RefTriple]
97
98data FreeForm = FreeForm
99 { ffRat :: Bool
100 , ffTyp :: CSType
101 , ffDeg :: (Int,Int)
102 , ffPts :: FFPts
103 }
104
105initFF :: FreeForm
106initFF = FreeForm
107 { ffRat = False
108 , ffTyp = Bspline
109 , ffDeg = (1,1)
110 , ffPts = Curv2 []
111 }
112
113mkcurv2 :: FreeForm -> EmbeddedCurve
114mkcurv2 ff = EmbeddedCurve
115
116mkcurv :: FreeForm -> Curve
117mkcurv ff = Curve
118
119mksurf :: FreeForm -> Surface
120mksurf ff = Surface
121
122addFreeForm :: (forall x. x -> Element x) -> FreeForm -> OBJ DList -> OBJ DList
123addFreeForm elm ff o = case ffPts ff of
124 Curv2 {} -> o { objEmbeddedCurves = objEmbeddedCurves o `DList.snoc` mkcurv2 ff }
125 Curv {} -> o { objCurves = objCurves o `DList.snoc` elm (mkcurv ff) }
126 Surf {} -> o { objSurfaces = objSurfaces o `DList.snoc` elm (mksurf ff) }
127
128data ParserState = ParserState
129 { pstObj :: OBJ DList
130 , pstElm :: Element ()
131 , pstFF :: FreeForm
132 }
133
134buildOBJ :: ObjBuilder (State ParserState)
86buildOBJ = nullBuilder 135buildOBJ = nullBuilder
87 { vertex = \xs -> modifyFirst $ \o -> o { objLocations = objLocations o `DList.snoc` mkv xs } 136 { vertex = \xs -> modifyFirst $ \o -> o { objLocations = objLocations o `DList.snoc` mkv xs }
88 , vertexT = \xs -> modifyFirst $ \o -> o { objTexCoords = objTexCoords o `DList.snoc` mkt xs } 137 , vertexT = \xs -> modifyFirst $ \o -> o { objTexCoords = objTexCoords o `DList.snoc` mkt xs }
89 , vertexN = \xs -> modifyFirst $ \o -> o { objNormals = objNormals o `DList.snoc` mkn xs } 138 , vertexN = \xs -> modifyFirst $ \o -> o { objNormals = objNormals o `DList.snoc` mkn xs }
90 , points = \xs -> do 139 , points = \xs -> do
91 let p = map Point xs :: [Point] 140 let p = map Point xs :: [Point]
92 (pts,element) <- gets (objPoints *** elemental) 141 (pts,element) <- gets (objPoints *.* elemental)
93 modifyFirst $ \o -> o { objPoints = pts `DList.append` fmap element (DList.fromList p) } 142 modifyFirst $ \o -> o { objPoints = pts `DList.append` fmap element (DList.fromList p) }
94 , line = \xs -> do 143 , line = \xs -> do
95 (lns,element) <- gets (objLines *** elemental) 144 (lns,element) <- gets (objLines *.* elemental)
96 let l = zipWith mkl xs (tail xs) 145 let l = zipWith mkl xs (tail xs)
97 -- Line requires at least two points. We'll ignore it otherwise. 146 -- Line requires at least two points. We'll ignore it otherwise.
98 when (not $ null l) $ 147 when (not $ null l) $
99 modifyFirst $ \o -> o { objLines = lns `DList.append` fmap element (DList.fromList l) } 148 modifyFirst $ \o -> o { objLines = lns `DList.append` fmap element (DList.fromList l) }
100 , face = \xs -> do 149 , face = \xs -> do
101 (fcs,element) <- gets (objFaces *** elemental) 150 (fcs,element) <- gets (objFaces *.* elemental)
102 case map mkF xs of 151 case map mkF xs of
103 a:b:c:ds -> modifyFirst $ \o -> o { objFaces = fcs `DList.snoc` element (Face a b c ds) } 152 a:b:c:ds -> modifyFirst $ \o -> o { objFaces = fcs `DList.snoc` element (Face a b c ds) }
104 _ -> return () -- Ignore faces with less than 3 indices. 153 _ -> return () -- Ignore faces with less than 3 indices.
105 , mtllib = \xs -> do 154 , mtllib = \xs -> do
106 let l = map decodeUtf8 xs 155 let l = map decodeUtf8 xs
107 libs <- gets (objMtlLibs . fst) 156 libs <- gets (objMtlLibs . pstObj)
108 modifyFirst $ \o -> o { objMtlLibs = DList.fromList l `DList.append` libs } 157 modifyFirst $ \o -> o { objMtlLibs = DList.fromList l `DList.append` libs }
109 , groups = \xs -> do 158 , groups = \xs -> do
110 let g = map decodeUtf8 xs 159 let g = map decodeUtf8 xs
111 modify' $ second $ \e -> e { elGroups = g } 160 modifySecond $ \e -> e { elGroups = g }
112 , objectName = \x -> do 161 , objectName = \x -> do
113 let o = decodeUtf8 x 162 let o = decodeUtf8 x
114 modify' $ second $ \e -> e { elObject = Just o } 163 modifySecond $ \e -> e { elObject = Just o }
115 , usemtl = \x -> do 164 , usemtl = \x -> do
116 let mtl = decodeUtf8 x 165 let mtl = decodeUtf8 x
117 libs <- DList.toList <$> gets (objMtlLibs . fst) 166 libs <- DList.toList <$> gets (objMtlLibs . pstObj)
118 modify' $ second $ \e -> e { elMtl = Just (length libs,mtl) } 167 modifySecond $ \e -> e { elMtl = Just (length libs,mtl) }
119 , smoothingGroup = \x -> when (x > 0) $ do 168 , smoothingGroup = \x -> when (x > 0) $ do
120 modify $ second $ \e -> e { elSmoothingGroup = fromIntegral x } 169 modifySecond $ \e -> e { elSmoothingGroup = fromIntegral x }
170 , endFreeForm =
171 modify' $ \s -> s { pstObj = addFreeForm (elemental $ pstElm s) (pstFF s) (pstObj s)
172 , pstFF = initFF }
121 } 173 }
122 174
123blankElement :: Element () 175blankElement :: Element ()
@@ -134,9 +186,12 @@ emptyCounts = OBJ
134 { objLocations = Count 0 186 { objLocations = Count 0
135 , objTexCoords = Count 0 187 , objTexCoords = Count 0
136 , objNormals = Count 0 188 , objNormals = Count 0
189 , objEmbeddedCurves = Count 0
137 , objPoints = Count 0 190 , objPoints = Count 0
138 , objLines = Count 0 191 , objLines = Count 0
139 , objFaces = Count 0 192 , objFaces = Count 0
193 , objCurves = Count 0
194 , objSurfaces = Count 0
140 , objMtlLibs = Count 0 195 , objMtlLibs = Count 0
141 } 196 }
142 197
@@ -145,9 +200,12 @@ mzeroOBJ = OBJ
145 { objLocations = mzero 200 { objLocations = mzero
146 , objTexCoords = mzero 201 , objTexCoords = mzero
147 , objNormals = mzero 202 , objNormals = mzero
203 , objEmbeddedCurves = mzero
148 , objPoints = mzero 204 , objPoints = mzero
149 , objLines = mzero 205 , objLines = mzero
150 , objFaces = mzero 206 , objFaces = mzero
207 , objCurves = mzero
208 , objSurfaces = mzero
151 , objMtlLibs = mzero 209 , objMtlLibs = mzero
152 } 210 }
153 211
@@ -155,7 +213,7 @@ parse :: L.ByteString -> OBJ Vector
155parse bs = Rank2.fmap (Vector.fromList . DList.toList) obj 213parse bs = Rank2.fmap (Vector.fromList . DList.toList) obj
156 where 214 where
157 go = parseCustom buildOBJ (const $ return ()) bs 215 go = parseCustom buildOBJ (const $ return ()) bs
158 (obj,_) = execState go (mzeroOBJ,blankElement) 216 ParserState { pstObj = obj } = execState go (ParserState mzeroOBJ blankElement initFF)
159 217
160parseCustom :: Monad m => ObjBuilder m -> (OBJ Count -> m b) -> L.ByteString -> m b 218parseCustom :: Monad m => ObjBuilder m -> (OBJ Count -> m b) -> L.ByteString -> m b
161parseCustom builder finish bs = do 219parseCustom builder finish bs = do
diff --git a/src/Wavefront/Lex.hs b/src/Wavefront/Lex.hs
index f4cb54a..811553a 100644
--- a/src/Wavefront/Lex.hs
+++ b/src/Wavefront/Lex.hs
@@ -38,7 +38,7 @@ data ObjBuilder m = ObjBuilder
38 , trim :: [CurveSpec] -> m () 38 , trim :: [CurveSpec] -> m ()
39 , hole :: [CurveSpec] -> m () 39 , hole :: [CurveSpec] -> m ()
40 , specialCurves :: [CurveSpec] -> m () 40 , specialCurves :: [CurveSpec] -> m ()
41 , equivalentCurves :: [EmbeddedCurve] -> m () 41 , equivalentCurves :: [EmbeddedCurveRef] -> m ()
42 , groups :: [S.ByteString] -> m () 42 , groups :: [S.ByteString] -> m ()
43 , smoothingGroup :: Int -> m () 43 , smoothingGroup :: Int -> m ()
44 , mergingGroup :: Int -> Double -> m () 44 , mergingGroup :: Int -> Double -> m ()
@@ -188,7 +188,7 @@ echoBuilder = ObjBuilder
188 , trim = \ss -> echo $ unwords ("trim":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss) 188 , trim = \ss -> echo $ unwords ("trim":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss)
189 , hole = \ss -> echo $ unwords ("hole":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss) 189 , hole = \ss -> echo $ unwords ("hole":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss)
190 , specialCurves = \ss -> echo $ unwords ("scrv":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss) 190 , specialCurves = \ss -> echo $ unwords ("scrv":concatMap (\(CurveSpec s e r) -> [show s,show e,show r]) ss)
191 , equivalentCurves = \ccs -> echo $ unwords ("con":map showEmbeddedCurve ccs) 191 , equivalentCurves = \ccs -> echo $ unwords ("con":map showEmbeddedCurveRef ccs)
192 , groups = \gs -> echo $ unwords $ "g":map unpackUtf8 gs 192 , groups = \gs -> echo $ unwords $ "g":map unpackUtf8 gs
193 , smoothingGroup = \sg -> echo ("s " ++ show sg) 193 , smoothingGroup = \sg -> echo ("s " ++ show sg)
194 , mergingGroup = \mg δ -> echo $ unwords ["mg",show mg,show δ] 194 , mergingGroup = \mg δ -> echo $ unwords ["mg",show mg,show δ]
@@ -264,6 +264,8 @@ newtype ObjConfig = ObjConfig
264 { cfgSubst :: IntMap L.ByteString 264 { cfgSubst :: IntMap L.ByteString
265 } 265 }
266 266
267defaultConfig = ObjConfig IntMap.empty
268
267-- consChunk :: S.ByteString -> L.ByteString -> L.ByteString 269-- consChunk :: S.ByteString -> L.ByteString -> L.ByteString
268-- consChunk c bs = L.fromChunks (c : L.toChunks bs) 270-- consChunk c bs = L.fromChunks (c : L.toChunks bs)
269 271
@@ -430,11 +432,11 @@ parseCurveSpecsN n tok bs cont = parseFloatsN 2 tok bs $ \fs bs' -> case fs of
430 432
431 _ -> cont [] bs' 433 _ -> cont [] bs'
432 434
433parseEmbeddedCurves :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([EmbeddedCurve] -> L.ByteString -> b) -> b 435parseEmbeddedCurveRefs :: (L.ByteString -> L.ByteString) -> L.ByteString -> ([EmbeddedCurveRef] -> L.ByteString -> b) -> b
434parseEmbeddedCurves tok bs cont = parseIntsN 1 tok bs $ \is bs' -> case is of 436parseEmbeddedCurveRefs tok bs cont = parseIntsN 1 tok bs $ \is bs' -> case is of
435 (sref:_) -> do 437 (sref:_) -> do
436 parseCurveSpecsN 1 tok bs' $ \cs bs'' -> case cs of 438 parseCurveSpecsN 1 tok bs' $ \cs bs'' -> case cs of
437 (c:_) -> parseEmbeddedCurves tok bs'' $ cont . (EmbeddedCurve sref c :) 439 (c:_) -> parseEmbeddedCurveRefs tok bs'' $ cont . (EmbeddedCurveRef sref c :)
438 _ -> cont [] bs'' 440 _ -> cont [] bs''
439 441
440 _ -> cont [] bs' 442 _ -> cont [] bs'
@@ -472,14 +474,14 @@ data CurveSpec = CurveSpec
472 } 474 }
473 deriving (Eq,Ord,Show) 475 deriving (Eq,Ord,Show)
474 476
475data EmbeddedCurve = EmbeddedCurve 477data EmbeddedCurveRef = EmbeddedCurveRef
476 { curveSurfaceRef :: Int 478 { curveSurfaceRef :: Int
477 , embeddedCurve :: CurveSpec 479 , embeddedCurve :: CurveSpec
478 } 480 }
479 deriving (Eq,Ord,Show) 481 deriving (Eq,Ord,Show)
480 482
481showEmbeddedCurve :: EmbeddedCurve -> String 483showEmbeddedCurveRef :: EmbeddedCurveRef -> String
482showEmbeddedCurve (EmbeddedCurve s c) = unwords 484showEmbeddedCurveRef (EmbeddedCurveRef s c) = unwords
483 [ show s 485 [ show s
484 , show (curveStart c) 486 , show (curveStart c)
485 , show (curveEnd c) 487 , show (curveEnd c)
@@ -560,7 +562,7 @@ parseOBJ builder args bs0
560 then parseI deprecated_cdc 4 -- cdc 562 then parseI deprecated_cdc 4 -- cdc
561 else parseI deprecated_cdp 4 -- cdp 563 else parseI deprecated_cdp 4 -- cdp
562 "co" -> -- con 564 "co" -> -- con
563 parseEmbeddedCurves (findToken args) (next 2 bs) $ \ss bs' -> do 565 parseEmbeddedCurveRefs (findToken args) (next 2 bs) $ \ss bs' -> do
564 equivalentCurves builder ss 566 equivalentCurves builder ss
565 parseOBJ builder args bs' 567 parseOBJ builder args bs'
566 "cs" -> if lengthLessThan 3 bs 568 "cs" -> if lengthLessThan 3 bs
diff --git a/src/Wavefront/Types.hs b/src/Wavefront/Types.hs
index 99bbb15..2ab48ba 100644
--- a/src/Wavefront/Types.hs
+++ b/src/Wavefront/Types.hs
@@ -18,9 +18,12 @@ data OBJ v = OBJ {
18 objLocations :: v Location 18 objLocations :: v Location
19 , objTexCoords :: v TexCoord 19 , objTexCoords :: v TexCoord
20 , objNormals :: v Normal 20 , objNormals :: v Normal
21 , objEmbeddedCurves :: v EmbeddedCurve
21 , objPoints :: v (Element Point) 22 , objPoints :: v (Element Point)
22 , objLines :: v (Element Line) 23 , objLines :: v (Element Line)
23 , objFaces :: v (Element Face) 24 , objFaces :: v (Element Face)
25 , objCurves :: v (Element Curve)
26 , objSurfaces :: v (Element Surface)
24 , objMtlLibs :: v Text 27 , objMtlLibs :: v Text
25 } 28 }
26 29
@@ -28,18 +31,24 @@ type ForThisOBJ (c :: * -> Constraint) v =
28 ( c (v Location) 31 ( c (v Location)
29 , c (v TexCoord) 32 , c (v TexCoord)
30 , c (v Normal) 33 , c (v Normal)
34 , c (v EmbeddedCurve)
31 , c (v (Element Point)) 35 , c (v (Element Point))
32 , c (v (Element Line)) 36 , c (v (Element Line))
33 , c (v (Element Face)) 37 , c (v (Element Face))
38 , c (v (Element Curve))
39 , c (v (Element Surface))
34 , c (v Text) ) 40 , c (v Text) )
35 41
36type ForAllOBJ (c :: * -> Constraint) = 42type ForAllOBJ (c :: * -> Constraint) =
37 ( c Location 43 ( c Location
38 , c TexCoord 44 , c TexCoord
39 , c Normal 45 , c Normal
46 , c EmbeddedCurve
40 , c (Element Point) 47 , c (Element Point)
41 , c (Element Line) 48 , c (Element Line)
42 , c (Element Face) 49 , c (Element Face)
50 , c (Element Curve)
51 , c (Element Surface)
43 , c Text 52 , c Text
44 ) 53 )
45 54
@@ -51,9 +60,12 @@ instance Rank2.Functor OBJ where
51 { objLocations = f (objLocations obj) 60 { objLocations = f (objLocations obj)
52 , objTexCoords = f (objTexCoords obj) 61 , objTexCoords = f (objTexCoords obj)
53 , objNormals = f (objNormals obj) 62 , objNormals = f (objNormals obj)
63 , objEmbeddedCurves = f (objEmbeddedCurves obj)
54 , objPoints = f (objPoints obj) 64 , objPoints = f (objPoints obj)
55 , objLines = f (objLines obj) 65 , objLines = f (objLines obj)
56 , objFaces = f (objFaces obj) 66 , objFaces = f (objFaces obj)
67 , objCurves = f (objCurves obj)
68 , objSurfaces = f (objSurfaces obj)
57 , objMtlLibs = f (objMtlLibs obj) 69 , objMtlLibs = f (objMtlLibs obj)
58 } 70 }
59 71
@@ -65,9 +77,12 @@ instance ForAllOBJ c => Payload c OBJ where
65 { objLocations = f (objLocations obj) 77 { objLocations = f (objLocations obj)
66 , objTexCoords = f (objTexCoords obj) 78 , objTexCoords = f (objTexCoords obj)
67 , objNormals = f (objNormals obj) 79 , objNormals = f (objNormals obj)
80 , objEmbeddedCurves = f (objEmbeddedCurves obj)
68 , objPoints = f (objPoints obj) 81 , objPoints = f (objPoints obj)
69 , objLines = f (objLines obj) 82 , objLines = f (objLines obj)
70 , objFaces = f (objFaces obj) 83 , objFaces = f (objFaces obj)
84 , objCurves = f (objCurves obj)
85 , objSurfaces = f (objSurfaces obj)
71 , objMtlLibs = f (objMtlLibs obj) 86 , objMtlLibs = f (objMtlLibs obj)
72 } 87 }
73 88
@@ -111,6 +126,15 @@ data Normal = Normal {
111 , norZ :: {-# UNPACK #-} !Float 126 , norZ :: {-# UNPACK #-} !Float
112 } deriving (Eq,Ord,Show) 127 } deriving (Eq,Ord,Show)
113 128
129data EmbeddedCurve = EmbeddedCurve
130 deriving (Eq,Ord,Show)
131
132data Curve = Curve
133 deriving (Eq,Ord,Show)
134
135data Surface = Surface
136 deriving (Eq,Ord,Show)
137
114-- | A point is a single index that references the locations. It’s a canonical 138-- | A point is a single index that references the locations. It’s a canonical
115-- type that truly represents a polygonal point. 139-- type that truly represents a polygonal point.
116data Point = Point { 140data Point = Point {