diff options
author | Joe Crayne <joe@jerkface.net> | 2019-07-23 23:21:57 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-07-23 23:21:57 -0400 |
commit | e52cbba217272384df4285c45beb73c90ad67c09 (patch) | |
tree | 3a33a50d5bf10817976192f3f8a4682578187002 /src/Wavefront.hs | |
parent | e2a39102145e8cb145c690f9b56d4c63126fe106 (diff) |
Diffstat (limited to 'src/Wavefront.hs')
-rw-r--r-- | src/Wavefront.hs | 51 |
1 files changed, 45 insertions, 6 deletions
diff --git a/src/Wavefront.hs b/src/Wavefront.hs index 3c4eff0..e6b31ec 100644 --- a/src/Wavefront.hs +++ b/src/Wavefront.hs | |||
@@ -2,8 +2,8 @@ | |||
2 | {-# LANGUAGE RankNTypes #-} | 2 | {-# LANGUAGE RankNTypes #-} |
3 | module Wavefront where | 3 | module Wavefront where |
4 | 4 | ||
5 | import Wavefront.Types | 5 | import Wavefront.Types as Types |
6 | import Wavefront.Lex | 6 | import Wavefront.Lex as Lex |
7 | 7 | ||
8 | import Control.Arrow | 8 | import Control.Arrow |
9 | import Control.Monad.State | 9 | import Control.Monad.State |
@@ -75,10 +75,17 @@ mkn cs = Normal x y z where (x:y:z:_) = map realToFrac cs ++ repeat 0 | |||
75 | mkl :: RefTriple -> RefTriple -> Line | 75 | mkl :: RefTriple -> RefTriple -> Line |
76 | mkl (RefTriple a at _) (RefTriple b bt _) = Line (LineIndex a at) (LineIndex b bt) | 76 | mkl (RefTriple a at _) (RefTriple b bt _) = Line (LineIndex a at) (LineIndex b bt) |
77 | 77 | ||
78 | -- I'd have thought these would be Coercible, but I guess not. | ||
79 | mkF :: RefTriple -> FaceIndex | 78 | mkF :: RefTriple -> FaceIndex |
80 | mkF (RefTriple a at an) = FaceIndex a at an | 79 | mkF (RefTriple a at an) = FaceIndex a at an |
81 | 80 | ||
81 | -- 'mkF' and 'mkTyp' are a little awkward, but it increases modularity. | ||
82 | mkTyp :: Lex.CSType -> Types.CSType | ||
83 | mkTyp Lex.Bmatrix = Types.Bmatrix | ||
84 | mkTyp Lex.Bezier = Types.Bezier | ||
85 | mkTyp Lex.Bspline = Types.Bspline | ||
86 | mkTyp Lex.Cardinal = Types.Cardinal | ||
87 | mkTyp Lex.Taylor = Types.Taylor | ||
88 | |||
82 | elemental :: Element () -> x -> Element x | 89 | elemental :: Element () -> x -> Element x |
83 | elemental element x = fmap (const x) element | 90 | elemental element x = fmap (const x) element |
84 | 91 | ||
@@ -88,26 +95,33 @@ modifyFirst = modify' . (\f s -> s { pstObj = f (pstObj s) }) | |||
88 | modifySecond :: MonadState ParserState m => (Element () -> Element ()) -> m () | 95 | modifySecond :: MonadState ParserState m => (Element () -> Element ()) -> m () |
89 | modifySecond = modify' . (\f s -> s { pstElm = f (pstElm s) }) | 96 | modifySecond = modify' . (\f s -> s { pstElm = f (pstElm s) }) |
90 | 97 | ||
98 | modifyFF :: MonadState ParserState m => (FreeForm -> FreeForm) -> m () | ||
99 | modifyFF = modify' . (\f s -> s { pstFF = f (pstFF s) }) | ||
100 | |||
91 | (*.*) :: (OBJ DList -> a) -> (Element () -> b) -> ParserState -> (a, b) | 101 | (*.*) :: (OBJ DList -> a) -> (Element () -> b) -> ParserState -> (a, b) |
92 | fld *.* elm = \s -> (fld (pstObj s), elm (pstElm s)) | 102 | fld *.* elm = \s -> (fld (pstObj s), elm (pstElm s)) |
93 | 103 | ||
94 | data FFPts = Curv Float Float [Int] | 104 | data FFPts = Curv Float Float [Int] |
95 | | Curv2 [Int] | 105 | | Curv2 [Int] |
96 | | Surf Float Float Float Float [RefTriple] | 106 | | Surf Float Float Float Float [FaceIndex] |
97 | 107 | ||
98 | data FreeForm = FreeForm | 108 | data FreeForm = FreeForm |
99 | { ffRat :: Bool | 109 | { ffRat :: Bool |
100 | , ffTyp :: CSType | 110 | , ffTyp :: Types.CSType |
101 | , ffDeg :: (Int,Int) | 111 | , ffDeg :: (Int,Int) |
102 | , ffPts :: FFPts | 112 | , ffPts :: FFPts |
113 | , ffParamU :: [Float] | ||
114 | , ffParamV :: [Float] | ||
103 | } | 115 | } |
104 | 116 | ||
105 | initFF :: FreeForm | 117 | initFF :: FreeForm |
106 | initFF = FreeForm | 118 | initFF = FreeForm |
107 | { ffRat = False | 119 | { ffRat = False |
108 | , ffTyp = Bspline | 120 | , ffTyp = Types.Bspline |
109 | , ffDeg = (1,1) | 121 | , ffDeg = (1,1) |
110 | , ffPts = Curv2 [] | 122 | , ffPts = Curv2 [] |
123 | , ffParamU = [] | ||
124 | , ffParamV = [] | ||
111 | } | 125 | } |
112 | 126 | ||
113 | mkcurv2 :: FreeForm -> EmbeddedCurve | 127 | mkcurv2 :: FreeForm -> EmbeddedCurve |
@@ -118,6 +132,21 @@ mkcurv ff = Curve | |||
118 | 132 | ||
119 | mksurf :: FreeForm -> Surface | 133 | mksurf :: FreeForm -> Surface |
120 | mksurf ff = Surface | 134 | mksurf ff = Surface |
135 | { surfIsRational = ffRat ff | ||
136 | , surfDegree = ffDeg ff | ||
137 | , surfType = ffTyp ff | ||
138 | , surfRangeU = case ffPts ff of | ||
139 | Surf minu maxu _ _ _ -> (minu,maxu) | ||
140 | _ -> (0,1) | ||
141 | , surfRangeV = case ffPts ff of | ||
142 | Surf _ _ minv maxv _ -> (minv,maxv) | ||
143 | _ -> (0,1) | ||
144 | , surfPoints = case ffPts ff of | ||
145 | Surf _ _ _ _ pts -> pts | ||
146 | _ -> [] | ||
147 | , surfKnotsU = ffParamU ff | ||
148 | , surfKnotsV = ffParamV ff | ||
149 | } | ||
121 | 150 | ||
122 | addFreeForm :: (forall x. x -> Element x) -> FreeForm -> OBJ DList -> OBJ DList | 151 | addFreeForm :: (forall x. x -> Element x) -> FreeForm -> OBJ DList -> OBJ DList |
123 | addFreeForm elm ff o = case ffPts ff of | 152 | addFreeForm elm ff o = case ffPts ff of |
@@ -167,6 +196,16 @@ buildOBJ = nullBuilder | |||
167 | modifySecond $ \e -> e { elMtl = Just (length libs,mtl) } | 196 | modifySecond $ \e -> e { elMtl = Just (length libs,mtl) } |
168 | , smoothingGroup = \x -> when (x > 0) $ do | 197 | , smoothingGroup = \x -> when (x > 0) $ do |
169 | modifySecond $ \e -> e { elSmoothingGroup = fromIntegral x } | 198 | modifySecond $ \e -> e { elSmoothingGroup = fromIntegral x } |
199 | |||
200 | -- Free-form support | ||
201 | , cstype = \israt typ -> modifyFF $ \s -> s { ffRat = israt, ffTyp = mkTyp typ } | ||
202 | , deg = \ds -> modifyFF $ \s -> s { ffDeg = ((!! 0) &&& (!! 1)) (ds ++ [3,3]) } | ||
203 | , surf = \u0 u1 v0 v1 ts -> do | ||
204 | let [uA,uB,vA,vB] = map realToFrac [u0,u1,v0,v1] | ||
205 | modifyFF $ \s -> s { ffPts = Surf uA uB vA vB (map mkF ts) } | ||
206 | , parm = \uv ks -> case uv of | ||
207 | ParamU -> modifyFF $ \s -> s { ffParamU = map realToFrac ks } | ||
208 | ParamV -> modifyFF $ \s -> s { ffParamV = map realToFrac ks } | ||
170 | , endFreeForm = | 209 | , endFreeForm = |
171 | modify' $ \s -> s { pstObj = addFreeForm (elemental $ pstElm s) (pstFF s) (pstObj s) | 210 | modify' $ \s -> s { pstObj = addFreeForm (elemental $ pstElm s) (pstFF s) (pstObj s) |
172 | , pstFF = initFF } | 211 | , pstFF = initFF } |