diff options
author | Joe Crayne <joe@jerkface.net> | 2019-06-10 23:03:04 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-06-10 23:03:04 -0400 |
commit | 38b7bcf654e5e804a13518b060ebdba59bf232bb (patch) | |
tree | 2fa3c4ccf3496750f0ce388a9ea0998fdd93bf69 /src/Graphics |
Initial commit.
Diffstat (limited to 'src/Graphics')
-rw-r--r-- | src/Graphics/Formats/Collada/ColladaTypes.hs | 286 | ||||
-rw-r--r-- | src/Graphics/Formats/Collada/GenerateObjects.hs | 285 | ||||
-rw-r--r-- | src/Graphics/Formats/Collada/Transformations.hs | 97 | ||||
-rw-r--r-- | src/Graphics/Formats/Collada/Vector2D3D.hs | 215 | ||||
-rw-r--r-- | src/Graphics/Triangulation/GJPTriangulation.hs | 360 | ||||
-rw-r--r-- | src/Graphics/Triangulation/KETTriangulation.hs | 64 | ||||
-rw-r--r-- | src/Graphics/Triangulation/Triangulation.hs | 183 | ||||
-rw-r--r-- | src/Graphics/WaveFront.hs | 62 | ||||
-rw-r--r-- | src/Graphics/WaveFront/Foreign.hs | 88 | ||||
-rw-r--r-- | src/Graphics/WaveFront/Lenses.hs | 54 | ||||
-rw-r--r-- | src/Graphics/WaveFront/Load.hs | 108 | ||||
-rw-r--r-- | src/Graphics/WaveFront/Model.hs | 345 | ||||
-rw-r--r-- | src/Graphics/WaveFront/Parse.hs | 88 | ||||
-rw-r--r-- | src/Graphics/WaveFront/Parse/Common.hs | 166 | ||||
-rw-r--r-- | src/Graphics/WaveFront/Parse/MTL.hs | 142 | ||||
-rw-r--r-- | src/Graphics/WaveFront/Parse/OBJ.hs | 173 | ||||
-rw-r--r-- | src/Graphics/WaveFront/Types.hs | 254 |
17 files changed, 2970 insertions, 0 deletions
diff --git a/src/Graphics/Formats/Collada/ColladaTypes.hs b/src/Graphics/Formats/Collada/ColladaTypes.hs new file mode 100644 index 0000000..ad78aa8 --- /dev/null +++ b/src/Graphics/Formats/Collada/ColladaTypes.hs | |||
@@ -0,0 +1,286 @@ | |||
1 | -- some of the Types are from http://hackage.haskell.org/package/GPipe-Collada | ||
2 | -- adopted for possible future combination | ||
3 | |||
4 | module Graphics.Formats.Collada.ColladaTypes | ||
5 | ( | ||
6 | Scene(..), | ||
7 | SceneNode(..), NodeType(..), | ||
8 | Transform(..), | ||
9 | Camera(..), | ||
10 | ViewSize(..), | ||
11 | Z(..), | ||
12 | |||
13 | Light(..), | ||
14 | Attenuation(..), | ||
15 | Controller(..), | ||
16 | |||
17 | Geometry(..), | ||
18 | Mesh(..), | ||
19 | Vertices(..), | ||
20 | LinePrimitive(..), Polygon(..), | ||
21 | -- Polylist(..), Spline(..), TriangleMesh(..), TriFan(..), TriStrip(..), | ||
22 | AnimChannel(..), | ||
23 | ID, SID, | ||
24 | Semantic, | ||
25 | Profile(..), NewParam(..), TechniqueCommon(..), Material, Effect, | ||
26 | C(..), Color(..), | ||
27 | Animation(..), | ||
28 | Fx_common_color_type(..), Fx_common_texture_type(..), Texture(..), | ||
29 | Interpolation(..), | ||
30 | ) | ||
31 | where | ||
32 | |||
33 | import Data.Tree | ||
34 | import Data.Vector | ||
35 | import Graphics.Rendering.OpenGL (TextureObject) | ||
36 | import Graphics.Formats.Collada.Vector2D3D (V3(..), V4(..)) | ||
37 | |||
38 | type Mat44 = ((Float,Float,Float,Float), | ||
39 | (Float,Float,Float,Float), | ||
40 | (Float,Float,Float,Float), | ||
41 | (Float,Float,Float,Float)) | ||
42 | |||
43 | type Scene = Tree SceneNode | ||
44 | |||
45 | data SceneNode = SceneNode { | ||
46 | nodeId :: ID, | ||
47 | nodeType :: NodeType, | ||
48 | nodeLayers :: [String], | ||
49 | nodeTransformations :: [(SID, Transform)], | ||
50 | nodeCameras :: [Camera], | ||
51 | nodeController :: [Controller], | ||
52 | nodeGeometries :: [Geometry], | ||
53 | nodeLights :: [Light] | ||
54 | } | EmptyRoot | ||
55 | deriving (Show, Eq) | ||
56 | |||
57 | |||
58 | data NodeType = JOINT | NODE | NOTYPE deriving (Show, Eq) | ||
59 | |||
60 | data Transform = LookAt { | ||
61 | lookAtEye:: V3, | ||
62 | lookAtInterest :: V3, | ||
63 | lookAtUp :: V3 | ||
64 | } | ||
65 | | Matrix Mat44 | ||
66 | | Rotate V3 Float V3 Float V3 Float | ||
67 | | Scale V3 | ||
68 | | Skew { | ||
69 | skewAngle :: Float, | ||
70 | skewRotation :: V3, | ||
71 | skewTranslation :: V3 | ||
72 | } | ||
73 | | Translate V3 | ||
74 | deriving (Show, Eq) | ||
75 | |||
76 | data Camera = Perspective { | ||
77 | perspectiveID :: ID, | ||
78 | perspectiveFov :: ViewSize, | ||
79 | perspectiveZ :: Z | ||
80 | } | ||
81 | | Orthographic { | ||
82 | orthographicID :: ID, | ||
83 | orthographicViewSize :: ViewSize, | ||
84 | orthographicZ :: Z | ||
85 | } | ||
86 | deriving (Show, Eq) | ||
87 | |||
88 | data ViewSize = ViewSizeX Float | ||
89 | | ViewSizeY Float | ||
90 | | ViewSizeXY (Float,Float) | ||
91 | deriving (Show, Eq) | ||
92 | |||
93 | data Z = Z { | ||
94 | zNear :: Float, | ||
95 | zFar :: Float | ||
96 | } | ||
97 | deriving (Show, Eq) | ||
98 | |||
99 | data Light = Ambient { | ||
100 | ambientID :: ID, | ||
101 | ambientColor :: Color | ||
102 | } | ||
103 | | Directional { | ||
104 | directionalID :: ID, | ||
105 | directionalColor :: Color | ||
106 | } | ||
107 | | Point { | ||
108 | pointID :: ID, | ||
109 | pointColor :: Color, | ||
110 | pointAttenuation :: Attenuation | ||
111 | } | ||
112 | | Spot { | ||
113 | spotID :: ID, | ||
114 | spotColor :: Color, | ||
115 | spotAttenuation :: Attenuation, | ||
116 | spotFallOffAngle :: Float, | ||
117 | spotFallOffExponent :: Float | ||
118 | } | ||
119 | deriving (Show, Eq) | ||
120 | |||
121 | data Attenuation = Attenuation { | ||
122 | attenuationConstant :: Float, | ||
123 | attenuationLinear :: Float, | ||
124 | attenuationQuadratic :: Float | ||
125 | } | ||
126 | deriving (Show, Eq) | ||
127 | |||
128 | data Controller = Controller { | ||
129 | contrId :: ID, | ||
130 | skin :: [Skin], | ||
131 | morph :: [Morph] | ||
132 | } | ||
133 | deriving (Show, Eq) | ||
134 | |||
135 | data Skin = Skin { | ||
136 | bindShapeMatrix :: [Mat44], | ||
137 | source :: [String], | ||
138 | joint :: [Joint], | ||
139 | vertexWeights :: String | ||
140 | } | ||
141 | deriving (Show, Eq) | ||
142 | |||
143 | data Morph = Morph { | ||
144 | geometrySource :: String, | ||
145 | method :: MorphMethod, | ||
146 | morphSource :: String, | ||
147 | morphTargets :: [Input] | ||
148 | } | ||
149 | deriving (Show, Eq) | ||
150 | |||
151 | data MorphMethod = Normalized | Relative deriving (Show, Eq) | ||
152 | |||
153 | data Joint = Joint { | ||
154 | jointID :: String, | ||
155 | prismatic :: Prismatic, | ||
156 | revolute :: Revolute | ||
157 | } | ||
158 | deriving (Show, Eq) | ||
159 | |||
160 | type Prismatic = String | ||
161 | type Revolute = String | ||
162 | |||
163 | data Input = Input { | ||
164 | offset :: Int, | ||
165 | semantic :: Semantic, | ||
166 | inputSource :: String, | ||
167 | set :: Int | ||
168 | } | ||
169 | deriving (Show, Eq) | ||
170 | |||
171 | data Semantic = BINORMAL | COLOR | CONTINUITY | IMAGE | INPUT | IN_TANGENT | INTERPOLATION | | ||
172 | INV_BIND_MATRIX | ISJOINT | LINEAR_STEPS | MORPH_TARGET | MORPH_WEIGHT | | ||
173 | NORMAL | OUTPUT | OUT_TANGENT | POSITION | TANGENT | TEXBINORMAL | | ||
174 | TEXCOORD | TEXTANGENT | UV | VERTEX | WEIGHT | ||
175 | deriving (Show, Eq) | ||
176 | |||
177 | data Geometry = Geometry { | ||
178 | meshID :: ID, | ||
179 | mesh :: [Mesh], | ||
180 | vertices :: Vertices | ||
181 | -- convexMesh :: [Mesh], | ||
182 | -- splines :: [Spline], | ||
183 | -- breps :: [Brep] | ||
184 | } | ||
185 | deriving (Show) | ||
186 | |||
187 | instance Eq Geometry where | ||
188 | (Geometry mid1 _ _) == (Geometry mid2 _ _) = mid1 == mid2 | ||
189 | |||
190 | data Mesh = LP LinePrimitive | -- ^Lines | ||
191 | LS LinePrimitive | -- ^LineStrips | ||
192 | P Polygon | -- ^Polygon: Contains polygon primitives which may contain holes. | ||
193 | PL LinePrimitive | -- ^PolyList: Contains polygon primitives that cannot contain holes. | ||
194 | Tr LinePrimitive | -- ^Triangles | ||
195 | Trf LinePrimitive | -- ^TriFans | ||
196 | Trs LinePrimitive | -- ^TriStrips | ||
197 | S LinePrimitive -- ^Splines | ||
198 | deriving (Show, Eq) | ||
199 | |||
200 | data Vertices = Vertices { | ||
201 | name :: ID, | ||
202 | verts :: Vector V3, | ||
203 | normals :: Vector V3 | ||
204 | } | ||
205 | deriving (Show, Eq) | ||
206 | |||
207 | data LinePrimitive = LinePrimitive { | ||
208 | lineP :: Vector (Vector Int), -- point indices | ||
209 | lineN :: Vector (Vector Int), -- normal indices | ||
210 | lineT :: Vector (Vector Int), -- texture indices | ||
211 | ms :: [Material] | ||
212 | } | ||
213 | deriving (Show, Eq) | ||
214 | |||
215 | data Polygon = Polygon { | ||
216 | poylgonP :: Vector (Vector Int), | ||
217 | poylgonN :: Vector (Vector Int), | ||
218 | polygonPh :: (Vector Int, Vector Int), -- (indices, indices of a hole) | ||
219 | polygonMs :: [Material] | ||
220 | } | ||
221 | deriving (Show, Eq) | ||
222 | |||
223 | type Material = (SID,Effect) | ||
224 | |||
225 | type Effect = Profile | ||
226 | |||
227 | type Animation = Tree (SID, AnimChannel) | ||
228 | |||
229 | data AnimChannel = AnimChannel { | ||
230 | input :: (ID,[Float],Accessor) , -- Accessor: i.e. "TIME" | ||
231 | output :: (ID,[Float],Accessor), | ||
232 | interp :: [Interpolation], | ||
233 | -- target channels in Collada | ||
234 | targets :: [(TargetID,AccessorName)] -- transfer values to several objects | ||
235 | } | EmptyAnim | ||
236 | deriving (Show, Eq) | ||
237 | |||
238 | data Interpolation = Step | Linear | Bezier [Float] [Float] deriving (Show, Eq) | ||
239 | |||
240 | type TargetID = String | ||
241 | type Accessor = [[(AccessorName, AccessorType)]] | ||
242 | type AccessorName = String | ||
243 | type AccessorType = String | ||
244 | |||
245 | data Profile = BRIDGE Asset Extra | | ||
246 | CG Asset Code Include NewParam TechniqueCG Extra | | ||
247 | COMMON Asset NewParam TechniqueCommon String | | ||
248 | GLES Asset NewParam TechniqueCG Extra | | ||
249 | GLES2 Asset Code Include NewParam TechniqueCG Extra | | ||
250 | GLSL Asset Code Include NewParam TechniqueCG Extra | ||
251 | deriving (Show, Eq) | ||
252 | |||
253 | type Asset = String | ||
254 | type Code = String | ||
255 | type Include = String | ||
256 | data NewParam = Annotat | Semantic | Modifier | NoParam deriving (Show, Eq) | ||
257 | data TechniqueCommon = Constant | LambertCol [Fx_common_color_type] | ||
258 | | LambertTex [Fx_common_texture_type] [[Float]] | ||
259 | | PhongCol [Fx_common_color_type] | ||
260 | | PhongTex [Fx_common_texture_type] [[Float]] | ||
261 | | Blinn | ||
262 | deriving (Show, Eq) | ||
263 | data TechniqueCG = IsAsset | IsAnnotate | Pass | Extra deriving (Show, Eq) | ||
264 | data Extra = String deriving (Show, Eq) -- Asset | Technique | ||
265 | data Technique = Profile deriving (Show, Eq) -- XML -- | Xmlns Schema | ||
266 | data Fx_common_color_type = CEmission C | CAmbient C | CDiffuse C | CSpecular C | | ||
267 | CShininess Float | CReflective C | CReflectivity Float | | ||
268 | CTransparent C | CTransparency Float | CIndex_of_refraction Float | ||
269 | deriving (Show, Eq) | ||
270 | data Fx_common_texture_type = TEmission Texture | TAmbient Texture | TDiffuse Texture | TSpecular Texture | | ||
271 | TShininess Float | TReflective Texture | TReflectivity Float | | ||
272 | TTransparent Texture | TTransparency Float | TIndex_of_refraction Float | ||
273 | deriving (Show, Eq) | ||
274 | data C = Color V4 deriving (Show, Eq) | ||
275 | |||
276 | data Texture = Texture { | ||
277 | imageSID :: ID, | ||
278 | path :: String, -- ToDo: better type | ||
279 | texObj :: Maybe TextureObject -- force evalaution to generate a font cache | ||
280 | } | ||
281 | deriving (Show, Eq) | ||
282 | |||
283 | type ID = String | ||
284 | type SID = String -- Maybe | ||
285 | |||
286 | data Color = RGB Float Float Float deriving (Eq, Show) | ||
diff --git a/src/Graphics/Formats/Collada/GenerateObjects.hs b/src/Graphics/Formats/Collada/GenerateObjects.hs new file mode 100644 index 0000000..c1dcae7 --- /dev/null +++ b/src/Graphics/Formats/Collada/GenerateObjects.hs | |||
@@ -0,0 +1,285 @@ | |||
1 | module Graphics.Formats.Collada.GenerateObjects | ||
2 | where | ||
3 | |||
4 | import Data.Enumerable | ||
5 | import Data.Tree | ||
6 | import Data.Tuple.Enum | ||
7 | import Data.Word | ||
8 | import qualified Data.Vector as V | ||
9 | import Data.Vector (Vector) | ||
10 | import Graphics.Formats.Collada.ColladaTypes | ||
11 | import Graphics.Formats.Collada.Vector2D3D | ||
12 | |||
13 | -- type Scene = Tree SceneNode | ||
14 | n x = Node x [] | ||
15 | makeScene sid sceneNodes = Node (SceneNode sid NOTYPE [] tranrot [] [] [] []) (map n sceneNodes) | ||
16 | |||
17 | -- | An animated cube | ||
18 | animatedCube :: (Scene, [Animation]) | ||
19 | animatedCube = (aScene, animation) | ||
20 | |||
21 | -- | Example scene with a cube | ||
22 | aScene :: Scene | ||
23 | aScene = makeScene "aCube" (cameraAndLight ++ [aCube]) | ||
24 | |||
25 | lightedGeometry :: [Geometry] -> Scene | ||
26 | lightedGeometry g = makeScene "g" (cameraAndLight ++ (map ge g)) | ||
27 | |||
28 | lightedSceneNode :: SceneNode -> Scene | ||
29 | lightedSceneNode node = makeScene "node" (cameraAndLight ++ [node]) | ||
30 | |||
31 | lightedScene :: Scene -> Scene | ||
32 | lightedScene node = Node EmptyRoot ((map n cameraAndLight) ++ [node]) | ||
33 | |||
34 | -- | Every scene needs a camera and light | ||
35 | cameraAndLight = [ aCamera, | ||
36 | pointLight "pointLight" 3 4 10, | ||
37 | pointLight "pointL" (-500) 1000 400 ] | ||
38 | |||
39 | rot x y z = Rotate (V3 1 0 0) x | ||
40 | (V3 0 1 0) y | ||
41 | (V3 0 0 1) z | ||
42 | |||
43 | tranrot = [ ("tran", Translate (V3 0 0 0)), ("rot", rot 0 0 0) ] -- there have to be values for an animation channel to access | ||
44 | |||
45 | aCamera = SceneNode "camera0" NOTYPE [] | ||
46 | [("tran", Translate (V3 1000 2000 2500)), | ||
47 | ("rot", rot (-22) 13 0)] | ||
48 | -- [("lookat", LookAt (1000,1000,2500) (0,0,0) (0,1,0))] | ||
49 | [(Perspective "Persp" (ViewSizeXY (37,37)) (Z 10 1000) )] | ||
50 | [] [] [] | ||
51 | |||
52 | pointLight str x y z = SceneNode str NOTYPE [] | ||
53 | [("tran", Translate (V3 x y z)), | ||
54 | ("rot", rot 0 0 0)] | ||
55 | [] [] [] | ||
56 | [(Point "point" (RGB 1 1 1) (Attenuation 1 0 0) )] | ||
57 | |||
58 | ambientLight = SceneNode "ambientLight" NOTYPE [] | ||
59 | [("tran", Translate (V3 (-500) 1000 400)), | ||
60 | ("rot", rot 0 0 0)] | ||
61 | [] [] [] | ||
62 | [(Ambient "ambient" (RGB 1 1 1) )] | ||
63 | |||
64 | aCube :: SceneNode | ||
65 | aCube = SceneNode "cube_geometry" NOTYPE [] tranrot [] [] [cube] [] | ||
66 | |||
67 | obj :: String -> [Geometry] -> V3 -> SceneNode | ||
68 | obj name c tr = SceneNode name NOTYPE [] | ||
69 | [("tran", Translate tr), | ||
70 | ("rot", rot 0 0 0)] | ||
71 | [] [] | ||
72 | c -- geometries | ||
73 | [] | ||
74 | |||
75 | -- | Example animation of the cube | ||
76 | animation :: [Animation] | ||
77 | animation = [Node ("cube_rotate", anim_channel) []] | ||
78 | |||
79 | anim_channel = AnimChannel ("input", [0, 1, 2, 3], [[("name","TIME"), ("type","Float")]] ) | ||
80 | ("output",[0, 50, 100, 150], [[("name","ANGLE"), ("type","Float")]] ) | ||
81 | [ Bezier [-0.333333, 0] [2.5, 0], -- intangent outtangent | ||
82 | Bezier [5,0] [7.916667, 0], | ||
83 | Bezier [8.333333, 56] [9.166667, 56], | ||
84 | Bezier [9.583333, 18.666666] [10.333333, -14.933331] ] | ||
85 | [("cube_geometry/rotateY","ANGLE")] | ||
86 | |||
87 | fl = V.fromList | ||
88 | |||
89 | -- | A blue/textured cube | ||
90 | cube :: Geometry | ||
91 | cube = Geometry "cube" | ||
92 | [PL (LinePrimitive | ||
93 | (fl [fl [0,2,3,1], fl [0,1,5,4], fl [6,7,3,2], fl [0,4,6,2], fl [3,7,5,1], fl [5,7,6,4]]) -- indices to vertices | ||
94 | (fl [fl [0,0,0,0], fl [1,1,1,1], fl [2,2,2,2], fl [3,3,3,3], fl [4,4,4,4], fl [5,5,5,5]]) -- indices to normals | ||
95 | (fl [fl [0,1,2,3], fl [0,1,2,3], fl [0,1,2,3], fl [0,1,2,3], fl [0,1,2,3], fl [0,1,2,3]]) -- indices to texture coordinates, use an empty list when no texture | ||
96 | [logo] | ||
97 | -- [blue] | ||
98 | )] | ||
99 | (Vertices "cube_vertices" | ||
100 | (fl [(V3 (-10) 10 10), (V3 10 10 10), (V3 (-10) (-10) 10), (V3 10 (-10) 10), -- vertices | ||
101 | (V3 (-10) 10 (-10)),(V3 10 10 (-10)),(V3 (-10) (-10) (-10)),(V3 10 (-10) (-10))]) | ||
102 | (fl [(V3 0 0 1), (V3 0 1 0), (V3 0 (-1) 0), (V3 (-1) 0 0), (V3 1 0 0), (V3 0 0 (-1))]) -- normals | ||
103 | ) | ||
104 | |||
105 | blue = ("blue", COMMON "" NoParam | ||
106 | (PhongCol [CEmission (Color (V4 0 0 0 1)), | ||
107 | CAmbient (Color (V4 0 0 0 1)), | ||
108 | CDiffuse(Color (V4 0.137255 0.403922 0.870588 1)), | ||
109 | CSpecular(Color (V4 0.5 0.5 0.5 1)), | ||
110 | CShininess 16, | ||
111 | CReflective (Color (V4 0 0 0 1)), | ||
112 | CReflectivity 0.5, | ||
113 | CTransparent (Color (V4 0 0 0 1)), | ||
114 | CTransparency 1, | ||
115 | CIndex_of_refraction 0] | ||
116 | ) | ||
117 | "" | ||
118 | ) | ||
119 | |||
120 | diffuse c str (a, COMMON asset NoParam (PhongCol cs) s) = ("color_" ++ str, COMMON asset NoParam (PhongCol (map (replaceDiff c) cs)) s) | ||
121 | |||
122 | replaceDiff c (CDiffuse _) = CDiffuse (Color c) | ||
123 | replaceDiff _ c = c | ||
124 | |||
125 | ambient c str (a, COMMON asset NoParam (PhongCol cs) s) = ("color_" ++ str, COMMON asset NoParam (PhongCol (map (replaceAmb c) cs)) s) | ||
126 | |||
127 | replaceAmb c (CAmbient _) = CAmbient (Color c) | ||
128 | replaceAmb _ c = c | ||
129 | |||
130 | |||
131 | getDiffuseColor ( CDiffuse (Color c) ) = Just c | ||
132 | getDiffuseColor _ = Nothing | ||
133 | |||
134 | getAmbientColor ( CAmbient (Color c) ) = Just c | ||
135 | getAmbientColor _ = Nothing | ||
136 | |||
137 | logo = ("haskell-logo", COMMON "" NoParam | ||
138 | (PhongTex [(TDiffuse tex)] | ||
139 | [[0,0,1,0,1,1,0,1]] -- [u0,v0,u1,v1,..] -coordinates (Floats between 0 and 1) that point into the texture | ||
140 | ) | ||
141 | "" | ||
142 | ) | ||
143 | |||
144 | tex = Texture "logo" "Haskell-Logo-Variation.png" Nothing | ||
145 | |||
146 | polys :: Vector V3 -> Vector V3 -> Vector (Vector Int) -> Vector (Vector Int) -> [Geometry] | ||
147 | polys p n pi ni = [Geometry "polygons" | ||
148 | [PL (LinePrimitive pi -- indices to vertices | ||
149 | ni -- indices to normals | ||
150 | V.empty -- no texure | ||
151 | [blue] | ||
152 | )] | ||
153 | (Vertices "polygons_vertices" p n)] | ||
154 | |||
155 | |||
156 | lines :: Vector V3 -> Vector V3 -> Vector (Vector Int) -> Vector (Vector Int) -> [Geometry] | ||
157 | lines p n pi ni = [Geometry "lines" | ||
158 | [LS (LinePrimitive pi -- indices to vertices | ||
159 | ni -- indices to normals | ||
160 | V.empty -- no texure | ||
161 | [blue] | ||
162 | )] | ||
163 | (Vertices "lines_vertices" p n)] | ||
164 | |||
165 | |||
166 | trifans :: Vector V3 -> Vector V3 -> Vector (Vector Int)-> Vector (Vector Int) -> [Geometry] | ||
167 | trifans p n pi ni = [Geometry "trifans" | ||
168 | [Trf (LinePrimitive pi -- indices to vertices | ||
169 | ni -- indices to normals | ||
170 | V.empty -- no texure | ||
171 | [blue] | ||
172 | )] | ||
173 | (Vertices "trifans_vertices" p n)] | ||
174 | |||
175 | |||
176 | tristrips :: Vector V3 -> Vector V3 -> Vector (Vector Int) -> Vector (Vector Int) -> [Geometry] | ||
177 | tristrips p n pi ni = [Geometry "tristrips" | ||
178 | [Trs (LinePrimitive pi -- indices to vertices | ||
179 | ni -- indices to normals | ||
180 | V.empty -- no texure | ||
181 | [blue] | ||
182 | )] | ||
183 | (Vertices "trifans_vertices" p n)] | ||
184 | |||
185 | |||
186 | ge :: Geometry -> SceneNode | ||
187 | ge (Geometry name p v) = obj name [Geometry name p v] (V3 0 0 0) | ||
188 | -- ------------------ | ||
189 | -- a bigger example | ||
190 | -- ------------------ | ||
191 | animatedCubes = (scene2, animation2) | ||
192 | animatedCubes2 = [(scene2, animation2)] | ||
193 | |||
194 | scene2 :: Scene | ||
195 | scene2 = Node EmptyRoot $ [ n aCamera, n (pointLight "pl" (-500) 1000 400) ] ++ (map n test_objs) | ||
196 | |||
197 | -- | Animation of several cubes | ||
198 | animation2 :: [Animation] | ||
199 | animation2 = [Node ("cube_rotate", new_channels anim_channel test_objs) []] | ||
200 | |||
201 | emptyAnimation :: [[Animation]] | ||
202 | emptyAnimation = [] | ||
203 | |||
204 | emptyAnim :: [Animation] | ||
205 | emptyAnim = [] | ||
206 | |||
207 | -- | generate an animation that points to the cubes | ||
208 | new_channels :: AnimChannel -> [SceneNode] -> AnimChannel | ||
209 | new_channels (AnimChannel i o interp _) nodes = | ||
210 | AnimChannel i o interp $ map (\obj -> ((obj_name obj) ++ "/rotateY","ANGLE")) nodes | ||
211 | |||
212 | obj_name (SceneNode n _ _ _ _ _ _ _) = n | ||
213 | |||
214 | -- | a helper function for xyz_grid | ||
215 | tran :: SceneNode -> V3 -> String -> SceneNode | ||
216 | tran (SceneNode _ typ layer tr cam contr geo light) v3 str = | ||
217 | (SceneNode str typ layer [("tr", Translate v3)] cam contr geo light) | ||
218 | |||
219 | test_objs :: [SceneNode] | ||
220 | test_objs = xyz_grid 10 10 10 150 aCube | ||
221 | |||
222 | -- | Generate a 3 dimensional grid where an object (stored in a SceneNode) is repeated in along the grid | ||
223 | xyz_grid :: Int -> Int -> Int -> Float -> SceneNode -> [SceneNode] | ||
224 | xyz_grid x y z d obj = zipWith (tran obj) | ||
225 | (concat (concat (x_line x (map (map (\(V3 a b c) -> (V3 (a+d) b c)))) $ | ||
226 | x_line y (map (\(V3 a b c) -> (V3 a (b+d) c))) $ | ||
227 | x_line z (\(V3 a b c) -> (V3 a b (c+d))) (V3 0 0 0)) )) | ||
228 | (enum_obj obj [1..(x*y*z)]) | ||
229 | |||
230 | enum_obj obj (i:is) = ((obj_name obj) ++ (show i)) : (enum_obj obj is) | ||
231 | |||
232 | x_line 0 change value = [] | ||
233 | x_line n change value = value : ( x_line (n-1) change (change value) ) | ||
234 | |||
235 | ------------------------------------------------------------------- | ||
236 | -- visualizing a stream of positions with copies of a base object | ||
237 | ------------------------------------------------------------------- | ||
238 | |||
239 | positions = map (\(x, y, z) -> (x*100, y*100, z*100) ) $ | ||
240 | -- map (\(x,y,z) -> (fromIntegral x, fromIntegral y, fromIntegral z)) | ||
241 | en | ||
242 | |||
243 | en :: [(Float,Float,Float)] | ||
244 | -- en :: [(Word8,Word8,Word8)] | ||
245 | -- en = take 100 enumerate | ||
246 | -- en = take 100 all3s | ||
247 | |||
248 | en = map (\(V x y)->(x*20,y*20,0)) [] | ||
249 | |||
250 | base_objects = map (rename aCube) (map show [1..(length positions)]) | ||
251 | |||
252 | rename :: SceneNode -> String -> SceneNode | ||
253 | rename (SceneNode str typ layer tr cam contr geo light) s = | ||
254 | (SceneNode (str ++ s) typ layer tr cam contr geo light) | ||
255 | |||
256 | getName (SceneNode str _ _ _ _ _ _ _) = str | ||
257 | get_name (Geometry str _ _) = str | ||
258 | |||
259 | animatedStream = (streamScene base_objects, streamAnimation positions base_objects) | ||
260 | |||
261 | streamScene :: [SceneNode] -> Scene | ||
262 | streamScene objects = Node EmptyRoot $ [ n aCamera, | ||
263 | n (pointLight "pl" (-500) 1000 400) ] ++ | ||
264 | (map n $ objects) | ||
265 | |||
266 | streamAnimation :: [(Float,Float,Float)] -> [SceneNode] -> [Animation] | ||
267 | streamAnimation ps base_objects = | ||
268 | [Node ("cube_stream", EmptyAnim) (map n $ concat $ | ||
269 | zipWith (\ind bo -> [tr_channel ind ((show ind) ++ "1") bo (length ps) s1 "X"] ++ | ||
270 | [tr_channel ind ((show ind) ++ "2") bo (length ps) s2 "Y"] ++ | ||
271 | [tr_channel ind ((show ind) ++ "3") bo (length ps) s3 "Z"]) | ||
272 | [1..(length ps)] (map getName base_objects) ) | ||
273 | ] | ||
274 | where | ||
275 | s1 = map (\(a,b,c) -> a) ps | ||
276 | s2 = map (\(a,b,c) -> b) ps | ||
277 | s3 = map (\(a,b,c) -> c) ps | ||
278 | |||
279 | tr_channel ind name bname lps s c = ( "anim" ++ name, | ||
280 | AnimChannel ("input", map (*0.3) (map fromIntegral [0..(lps-1)]), [[("name","TIME"), ("type","Float")]] ) | ||
281 | ("output", (take ind s) ++ (take (lps-ind) (repeat (head (drop ind s)))), | ||
282 | [[("name",c), ("type","Float")]] ) | ||
283 | (take lps (repeat Linear)) | ||
284 | [(bname ++ "/tran",c)] | ||
285 | ) | ||
diff --git a/src/Graphics/Formats/Collada/Transformations.hs b/src/Graphics/Formats/Collada/Transformations.hs new file mode 100644 index 0000000..9efa801 --- /dev/null +++ b/src/Graphics/Formats/Collada/Transformations.hs | |||
@@ -0,0 +1,97 @@ | |||
1 | module Graphics.Formats.Collada.Transformations where | ||
2 | import Graphics.Formats.Collada.ColladaTypes | ||
3 | import Graphics.Formats.Collada.GenerateObjects | ||
4 | import Graphics.Formats.Collada.Vector2D3D | ||
5 | import Data.Vector (Vector) | ||
6 | import qualified Data.Vector as V | ||
7 | import Data.Tuple.Select | ||
8 | |||
9 | translate :: V3 -> Geometry -> Geometry | ||
10 | translate v (Geometry name prims (Vertices vname ps ns)) = Geometry name prims (Vertices vname (V.map (+ v) ps) ns) | ||
11 | |||
12 | -- |extrude a 2d polygon to 3d, the same points are added again with extrusion direction v | ||
13 | extrude :: V3 -> Geometry -> Geometry | ||
14 | extrude v (Geometry name prims (Vertices vname ps _)) = Geometry name | ||
15 | (map addIndices prims) | ||
16 | (Vertices vname (addNewPoints ps) | ||
17 | (fourN ns) ) | ||
18 | where | ||
19 | addNewPoints :: Vector V3 -> Vector V3 | ||
20 | addNewPoints vs | V.null vs = V.empty | ||
21 | | otherwise = V.cons (V.head vs) $ V.cons ((V.head vs)+v) (addNewPoints (V.tail vs)) | ||
22 | |||
23 | fourN :: Vector V3 -> Vector V3 | ||
24 | fourN vs | V.null vs = V.empty | ||
25 | | otherwise = V.cons (V.head vs) $ | ||
26 | V.cons (V.head vs) $ | ||
27 | V.cons (V.head vs) $ V.cons (V.head vs) (fourN (V.tail vs)) | ||
28 | |||
29 | addIndices (LP (LinePrimitive points normals tex color)) = PL (LinePrimitive (p points) (p points) tex color) | ||
30 | |||
31 | ns = V.map (normalsFrom v) (cycleNeighbours ps) | ||
32 | p :: Vector (Vector Int) -> Vector (Vector Int) | ||
33 | p several_outlines = V.foldr (V.++) V.empty (V.map extr_outline several_outlines) | ||
34 | |||
35 | extr_outline :: Vector Int -> Vector (Vector Int) | ||
36 | extr_outline points = V.map quads (cycleNeighbours points) | ||
37 | where | ||
38 | quads xs = V.cons ((V.head xs)*2) $ -- [x*2,y*2,x*2+1,y*2+1] | ||
39 | V.cons ((V.head (V.tail xs))*2) $ | ||
40 | V.cons ((V.head (V.tail xs))*2+1) $ | ||
41 | V.singleton ((V.head xs)*2+1) | ||
42 | |||
43 | normalsFrom (V3 x0 y0 z0) xs = crosspr (v1x-x0,v1y-y0,v1z-z0) (v1x-v2x,v1y-v2y,v1z-v2z) | ||
44 | where (V3 v1x v1y v1z ,V3 v2x v2y v2z) = (V.head xs, V.head (V.tail xs)) :: (V3,V3) | ||
45 | crosspr (v0,v1,v2) (w0,w1,w2) = (V3 (v1*w2-v2*w1) (v2*w0-v0*w2) (v0*w1-v1*w0)) | ||
46 | |||
47 | -- |return a list containing lists of every element with its neighbour | ||
48 | -- i.e. [e1,e2,e3] -> [ [e1,e2], [e2,e3], [e3, e1] ] | ||
49 | cycleNeighbours :: Vector a -> Vector (Vector a) | ||
50 | cycleNeighbours xs | V.null xs = V.empty | ||
51 | | otherwise = cycleN (V.head xs) xs | ||
52 | |||
53 | cycleN :: a -> Vector a -> Vector (Vector a) | ||
54 | cycleN f xs | V.length xs >= 2 = V.cons (V.fromList [V.head xs, V.head (V.tail xs)]) (cycleN f (V.tail xs)) | ||
55 | | otherwise = V.singleton (V.fromList [V.head xs, f ]) -- if the upper doesn't match close cycle | ||
56 | |||
57 | |||
58 | atop :: Geometry -> Geometry -> Geometry | ||
59 | atop (Geometry name0 prims0 (Vertices vname0 ps0 ns0)) | ||
60 | (Geometry name1 prims1 (Vertices vname1 ps1 ns1)) = Geometry name0 | ||
61 | ( prims0 ++ (map (changeIndices l) prims1) ) | ||
62 | ( Vertices vname0 (ps0 V.++ ps1) (ns0 V.++ ns1) ) | ||
63 | where changeIndices l (LP (LinePrimitive points normals texCoord mat)) = | ||
64 | LP (LinePrimitive (V.map (V.map (l+)) points) (V.map (V.map (l+)) normals) texCoord mat) | ||
65 | changeIndices l (LS (LinePrimitive points normals texCoord mat)) = | ||
66 | LS (LinePrimitive (V.map (V.map (l+)) points) (V.map (V.map (l+)) normals) texCoord mat) | ||
67 | changeIndices l (PL (LinePrimitive points normals texCoord mat)) = | ||
68 | PL (LinePrimitive (V.map (V.map (l+)) points) (V.map (V.map (l+)) normals) texCoord mat) | ||
69 | changeIndices l (Tr (LinePrimitive points normals texCoord mat)) = | ||
70 | Tr (LinePrimitive (V.map (V.map (l+)) points) (V.map (V.map (l+)) normals) texCoord mat) | ||
71 | l = V.length ps0 | ||
72 | |||
73 | |||
74 | changeDiffuseColor :: String -> V4 -> Geometry -> Geometry | ||
75 | changeDiffuseColor str color (Geometry name prims | ||
76 | (Vertices vname ps ns)) = (Geometry name (map (c color) prims) (Vertices vname ps ns)) | ||
77 | where c col (LP (LinePrimitive ps ns texCoord mat)) = | ||
78 | LP (LinePrimitive ps ns texCoord (map (diffuse col str) mat)) | ||
79 | c col (LS (LinePrimitive ps ns texCoord mat)) = | ||
80 | LS (LinePrimitive ps ns texCoord (map (diffuse col str) mat)) | ||
81 | c col (PL (LinePrimitive ps ns texCoord mat)) = | ||
82 | PL (LinePrimitive ps ns texCoord (map (diffuse col str) mat)) | ||
83 | c col (Tr (LinePrimitive ps ns texCoord mat)) = | ||
84 | Tr (LinePrimitive ps ns texCoord (map (diffuse col str) mat)) | ||
85 | |||
86 | changeAmbientColor :: String -> V4 -> Geometry -> Geometry | ||
87 | changeAmbientColor str color (Geometry name prims | ||
88 | (Vertices vname ps ns)) = (Geometry name (map (c color) prims) (Vertices vname ps ns)) | ||
89 | where c col (LP (LinePrimitive ps ns texCoord mat)) = | ||
90 | LP (LinePrimitive ps ns texCoord (map (ambient col str) mat) ) | ||
91 | c col (LS (LinePrimitive ps ns texCoord mat)) = | ||
92 | LS (LinePrimitive ps ns texCoord (map (ambient col str) mat) ) | ||
93 | c col (PL (LinePrimitive ps ns texCoord mat)) = | ||
94 | PL (LinePrimitive ps ns texCoord (map (ambient col str) mat) ) | ||
95 | c col (Tr (LinePrimitive ps ns texCoord mat)) = | ||
96 | Tr (LinePrimitive ps ns texCoord (map (ambient col str) mat) ) | ||
97 | |||
diff --git a/src/Graphics/Formats/Collada/Vector2D3D.hs b/src/Graphics/Formats/Collada/Vector2D3D.hs new file mode 100644 index 0000000..d2868c5 --- /dev/null +++ b/src/Graphics/Formats/Collada/Vector2D3D.hs | |||
@@ -0,0 +1,215 @@ | |||
1 | -- most functions and data types are from https://github.com/cobbpg/sloth2d | ||
2 | |||
3 | module Graphics.Formats.Collada.Vector2D3D | ||
4 | ( Angle | ||
5 | , V2(..), V3(..), V4(..) | ||
6 | , T2 | ||
7 | , unit, (*.), dot, dot3, cross, cross3, perpL, perpR, mul, divide | ||
8 | , turn, turnL, turnNL, turnR, turnNR, parv | ||
9 | , square, mag, norm, dir, v_len, set_len | ||
10 | , inverse, (Graphics.Formats.Collada.Vector2D3D.<>) | ||
11 | , translate, rotate, scale | ||
12 | , translationOf, rotationOf, scaleOf | ||
13 | , withTranslation, withRotation, withScale | ||
14 | ) where | ||
15 | |||
16 | import Data.Monoid | ||
17 | |||
18 | infixl 7 `dot`, `cross` | ||
19 | infixl 5 `turn`, `turnL`, `turnNL`, `turnR`, `turnNR`, `parv` | ||
20 | |||
21 | -- | An angle is a number between -pi and pi. | ||
22 | type Angle = Float | ||
23 | |||
24 | -- | 2D vector: a pair of coordinates. | ||
25 | data V2 = V {-# UNPACK #-} !Float {-# UNPACK #-} !Float | ||
26 | deriving (Show, Eq, Ord) | ||
27 | |||
28 | data V3 = V3 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float | ||
29 | deriving (Show, Eq, Ord) | ||
30 | |||
31 | data V4 = V4 {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float {-# UNPACK #-} !Float | ||
32 | deriving (Show, Eq, Ord) | ||
33 | |||
34 | -- | 2D affine transformation. No shearing allowed, only translation, | ||
35 | -- rotation, and scaling. Transformations can be chained with | ||
36 | -- 'mappend', and 'mempty' is the identity transformation. | ||
37 | data T2 = T | ||
38 | {-# UNPACK #-} !Float {-# UNPACK #-} !Float | ||
39 | {-# UNPACK #-} !Float {-# UNPACK #-} !Float | ||
40 | deriving Show | ||
41 | |||
42 | instance Num V2 where | ||
43 | V x1 y1 + V x2 y2 = V (x1+x2) (y1+y2) | ||
44 | V x1 y1 - V x2 y2 = V (x1-x2) (y1-y2) | ||
45 | V x1 y1 * V x2 y2 = V (x1*x2) (y1*y2) | ||
46 | negate (V x y) = V (negate x) (negate y) | ||
47 | abs (V x y) = V (abs x) (abs y) | ||
48 | signum (V x y) = V (signum x) (signum y) | ||
49 | fromInteger n = let n' = fromInteger n in V n' n' | ||
50 | |||
51 | instance Num V3 where | ||
52 | V3 x1 y1 z1 + V3 x2 y2 z2 = V3 (x1+x2) (y1+y2) (z1+z2) | ||
53 | V3 x1 y1 z1 - V3 x2 y2 z2 = V3 (x1-x2) (y1-y2) (z1-z2) | ||
54 | V3 x1 y1 z1 * V3 x2 y2 z2 = V3 (x1*x2) (y1*y2) (z1*z2) | ||
55 | negate (V3 x y z) = V3 (negate x) (negate y) (negate z) | ||
56 | abs (V3 x y z) = V3 (abs x) (abs y) (abs z) | ||
57 | signum (V3 x y z) = V3 (signum x) (signum y) (signum z) | ||
58 | fromInteger n = let n' = fromInteger n in V3 n' n' n' | ||
59 | |||
60 | -- | Unit vector with the given direction. | ||
61 | unit :: Angle -> V2 | ||
62 | unit a = V (cos a) (sin a) | ||
63 | |||
64 | -- | Multiplication with a scalar. | ||
65 | (*.) :: V2 -> Float -> V2 | ||
66 | V x y *. m = V (x*m) (y*m) | ||
67 | |||
68 | -- | Multiplication with a scalar. | ||
69 | mul (V3 x y z) c = (V3 (x*c) (y*c) (z*c)) | ||
70 | |||
71 | -- | Division by a scalar. | ||
72 | divide (V3 x y z) c = (V3 (x/c) (y/c) (z/c)) | ||
73 | |||
74 | -- | Dot product. | ||
75 | dot :: V2 -> V2 -> Float | ||
76 | V x1 y1 `dot` V x2 y2 = x1*x2+y1*y2 | ||
77 | |||
78 | -- | Dot product. | ||
79 | dot3 :: V3 -> V3 -> Float | ||
80 | V3 x1 y1 z1 `dot3` V3 x2 y2 z2 = x1*x2 + y1*y2 + z1*z2 | ||
81 | |||
82 | -- | Perp-dot product (2D cross product). | ||
83 | cross :: V2 -> V2 -> Float | ||
84 | V x1 y1 `cross` V x2 y2 = x1*y2-y1*x2 | ||
85 | |||
86 | -- | 3D cross product. | ||
87 | cross3 :: V3 -> V3 -> V3 | ||
88 | V3 x1 y1 z1 `cross3` V3 x2 y2 z2 = V3 (y1*z2-z1*y2) (z1*x2-x1*z2) (x1*y2-y1*x2) | ||
89 | |||
90 | -- | Vector rotated 90 degrees leftwards. | ||
91 | perpL :: V2 -> V2 | ||
92 | perpL (V x y) = V (-y) x | ||
93 | |||
94 | -- | Vector rotated 90 degrees rightwards. | ||
95 | perpR :: V2 -> V2 | ||
96 | perpR (V x y) = V y (-x) | ||
97 | |||
98 | -- | Relative direction of two vectors: @turn v1 v2@ equals @GT@ if | ||
99 | -- @v2@ takes a left turn with respect to @v1@, @LT@ if it is a right | ||
100 | -- turn, and @EQ@ if they are parallel. | ||
101 | turn :: V2 -> V2 -> Ordering | ||
102 | V x1 y1 `turn` V x2 y2 = compare (x1*y2) (y1*x2) | ||
103 | |||
104 | -- | @turnL v1 v2 == (turn v1 v2 == GT)@ | ||
105 | turnL :: V2 -> V2 -> Bool | ||
106 | V x1 y1 `turnL` V x2 y2 = x1*y2 > y1*x2 | ||
107 | |||
108 | -- | @turnNL v1 v2 == (turn v1 v2 /= GT)@ | ||
109 | turnNL :: V2 -> V2 -> Bool | ||
110 | V x1 y1 `turnNL` V x2 y2 = x1*y2 <= y1*x2 | ||
111 | |||
112 | -- | @turnR v1 v2 == (turn v1 v2 == LT)@ | ||
113 | turnR :: V2 -> V2 -> Bool | ||
114 | V x1 y1 `turnR` V x2 y2 = x1*y2 < y1*x2 | ||
115 | |||
116 | -- | @turnNR v1 v2 == (turn v1 v2 /= LT)@ | ||
117 | turnNR :: V2 -> V2 -> Bool | ||
118 | V x1 y1 `turnNR` V x2 y2 = x1*y2 >= y1*x2 | ||
119 | |||
120 | -- | @parv v1 v2 == (turn v1 v2 == EQ)@ | ||
121 | parv :: V2 -> V2 -> Bool | ||
122 | V x1 y1 `parv` V x2 y2 = x1*y2 == y1*x2 | ||
123 | |||
124 | -- | Vector length squared. | ||
125 | square :: V2 -> Float | ||
126 | square v = v `dot` v | ||
127 | |||
128 | -- | 3d Vector length squared. | ||
129 | square3 :: V3 -> Float | ||
130 | square3 v = v `dot3` v | ||
131 | |||
132 | -- | Vector length. | ||
133 | mag :: V2 -> Float | ||
134 | mag = sqrt . square | ||
135 | |||
136 | -- | 3d Vector length. | ||
137 | v_len = sqrt . square3 | ||
138 | |||
139 | -- | Set Vector length. | ||
140 | set_len (V3 x y z) l = (V3 (x*c*l) (y*c*l) (z*c*l)) where c = 1 / v_len (V3 x y z) | ||
141 | |||
142 | -- | The angle of a vector with respect to the X axis. | ||
143 | dir :: V2 -> Angle | ||
144 | dir (V x y) = atan2 y x | ||
145 | |||
146 | -- | Vector normalisation. | ||
147 | norm :: V2 -> V2 | ||
148 | norm v@(V x y) = V (x*m) (y*m) | ||
149 | where | ||
150 | m = recip (mag v) | ||
151 | |||
152 | instance Semigroup T2 where (<>) = mappend | ||
153 | instance Monoid T2 where | ||
154 | mempty = scale 1 | ||
155 | T rx1 ry1 tx1 ty1 `mappend` T rx2 ry2 tx2 ty2 = T rx ry tx ty | ||
156 | where | ||
157 | rx = rx1*rx2-ry1*ry2 | ||
158 | ry = ry1*rx2+rx1*ry2 | ||
159 | tx = rx1*tx2-ry1*ty2+tx1 | ||
160 | ty = ry1*tx2+rx1*ty2+ty1 | ||
161 | |||
162 | -- | Inverse transformation | ||
163 | inverse :: T2 -> T2 | ||
164 | inverse (T rx ry tx ty) = T (rx*m) (-ry*m) tx' ty' | ||
165 | where | ||
166 | m = recip (rx*rx+ry*ry) | ||
167 | tx' = m*(-ry*ty-rx*tx) | ||
168 | ty' = m*(ry*tx-rx*ty) | ||
169 | |||
170 | -- | Transformation applied to a vector. | ||
171 | (<>) :: T2 -> V2 -> V2 | ||
172 | T rx ry tx ty <> V x y = V x' y' | ||
173 | where | ||
174 | x' = rx*x-ry*y+tx | ||
175 | y' = ry*x+rx*y+ty | ||
176 | |||
177 | -- | Transformation representing a translation. | ||
178 | translate :: V2 -> T2 | ||
179 | translate (V x y) = T 1 0 x y | ||
180 | |||
181 | -- | Transformation representing a rotation. | ||
182 | rotate :: Angle -> T2 | ||
183 | rotate a = T (cos a) (sin a) 0 0 | ||
184 | |||
185 | -- | Transformation representing a scaling. | ||
186 | scale :: Float -> T2 | ||
187 | scale m = T m 0 0 0 | ||
188 | |||
189 | -- | The translation factor of a transformation. | ||
190 | translationOf :: T2 -> V2 | ||
191 | translationOf (T _ _ tx ty) = V tx ty | ||
192 | |||
193 | -- | The rotation factor of a transformation. | ||
194 | rotationOf :: T2 -> Angle | ||
195 | rotationOf (T rx ry _ _) = dir (V rx ry) | ||
196 | |||
197 | -- | The scaling factor of a transformation. | ||
198 | scaleOf :: T2 -> Float | ||
199 | scaleOf (T rx ry _ _) = mag (V rx ry) | ||
200 | |||
201 | -- | Replacing the translation factor of a transformation. | ||
202 | withTranslation :: T2 -> V2 -> T2 | ||
203 | T rx ry _ _ `withTranslation` V x y = T rx ry x y | ||
204 | |||
205 | -- | Replacing the rotation factor of a transformation. | ||
206 | withRotation :: T2 -> Angle -> T2 | ||
207 | T rx ry tx ty `withRotation` a = T rx' ry' tx ty | ||
208 | where | ||
209 | V rx' ry' = unit a *. mag (V rx ry) | ||
210 | |||
211 | -- | Replacing the scaling factor of a transformation. | ||
212 | withScale :: T2 -> Float -> T2 | ||
213 | T rx ry tx ty `withScale` m = T (m'*rx) (m'*ry) tx ty | ||
214 | where | ||
215 | m' = m / mag (V rx ry) | ||
diff --git a/src/Graphics/Triangulation/GJPTriangulation.hs b/src/Graphics/Triangulation/GJPTriangulation.hs new file mode 100644 index 0000000..cb963c9 --- /dev/null +++ b/src/Graphics/Triangulation/GJPTriangulation.hs | |||
@@ -0,0 +1,360 @@ | |||
1 | {-# LANGUAGE BangPatterns #-} | ||
2 | |||
3 | -- Author: Gergely Patai | ||
4 | -- from sloth2d: https://github.com/cobbpg/sloth2d/blob/master/Physics/Sloth2D/Geometry2D.hs | ||
5 | -- based on Garey, Johnson, Preparata, runtime O(n log n) | ||
6 | |||
7 | module Graphics.Triangulation.GJPTriangulation where | ||
8 | |||
9 | import Data.List | ||
10 | import Data.Ord | ||
11 | import Data.Vector (Vector, (!)) | ||
12 | import qualified Data.Vector as V | ||
13 | import qualified Data.Vector.Algorithms.Intro as V | ||
14 | import Graphics.Formats.Collada.Vector2D3D | ||
15 | |||
16 | data VertexType = TopCap | BottomCap | TopCup | BottomCup | Side | ||
17 | deriving Show | ||
18 | |||
19 | data Vertex = Vtx | ||
20 | { idx :: Int | ||
21 | , prev :: Int | ||
22 | , next :: Int | ||
23 | , vtype :: VertexType | ||
24 | , px :: Float | ||
25 | , py :: Float | ||
26 | } deriving Show | ||
27 | |||
28 | type MonotoneSegment = ([Int],[Int]) | ||
29 | |||
30 | -- | Descriptor for a pair of features. The ordering stands for the | ||
31 | -- following configurations: @LT@ - V to E, @EQ@ - E to E, @GT - E to | ||
32 | -- V, where E stands for edge and V stands for vertex (in other words, | ||
33 | -- you can think of edges being greater than vertices). The integers | ||
34 | -- are the indices of the features: the vertex itself or the first | ||
35 | -- vertex (in ccw order) of the edge. For instance, @(LT,2,4)@ means | ||
36 | -- the pair formed by vertex 2 of the first body and the edge between | ||
37 | -- vertices 4 and 5 of the second body. | ||
38 | type Separation = (Ordering, Int, Int) | ||
39 | |||
40 | -- | Checking whether an angle is within a given interval. | ||
41 | between :: Angle -> (Angle,Angle) -> Bool | ||
42 | a `between` (a1,a2) | ||
43 | | a1 <= a2 = a >= a1 && a <= a2 | ||
44 | | otherwise = a >= a1 || a <= a2 | ||
45 | |||
46 | infixl 6 +< | ||
47 | |||
48 | -- | The sum of two angles. | ||
49 | (+<) :: Angle -> Angle -> Angle | ||
50 | a1 +< a2 = if a < -pi then a+2*pi | ||
51 | else if a > pi then a-2*pi | ||
52 | else a | ||
53 | where | ||
54 | a = a1+a2 | ||
55 | |||
56 | -- | Linear interpolation between two angles along the smaller arc. | ||
57 | alerp :: Angle -> Angle -> Float -> Angle | ||
58 | alerp a1 a2 t = a1+<(a2+<(-a1))*t | ||
59 | |||
60 | -- | Applying a binary function to consecutive pairs in a vector with | ||
61 | -- wrap-around. | ||
62 | pairsWith :: (a -> a -> b) -> Vector a -> Vector b | ||
63 | pairsWith f vs | ||
64 | | V.null vs = V.empty | ||
65 | | otherwise = V.zipWith f vs (V.snoc (V.tail vs) (V.head vs)) | ||
66 | |||
67 | -- | The edge vectors of a polygon given as a list of vertices. | ||
68 | edges :: Vector V2 -> Vector V2 | ||
69 | edges vs = if V.length vs < 2 then V.empty else pairsWith (flip (-)) vs | ||
70 | |||
71 | -- | The absolute angles (with respect to the x axis) of the edges of | ||
72 | -- a polygon given as a list of vertices. | ||
73 | angles :: Vector V2 -> Vector Angle | ||
74 | angles = V.map dir . edges | ||
75 | |||
76 | -- | The signed area of a simple polygon (positive if vertices are in | ||
77 | -- counter-clockwise order). | ||
78 | area :: Vector V2 -> Float | ||
79 | area vs = 0.5 * V.sum (pairsWith cross vs) | ||
80 | |||
81 | -- | The centroid of a simple polygon. | ||
82 | centroid :: Vector V2 -> V2 | ||
83 | centroid vs | ||
84 | | V.null vs = V 0 0 | ||
85 | | otherwise = divsum (V.foldl1' accum (pairsWith gen vs)) | ||
86 | where | ||
87 | gen v1 v2 = let c = v1 `cross` v2 in (c,(v1+v2)*.c) | ||
88 | accum (!c1,!v1) (c2,v2) = (c1+c2,v1+v2) | ||
89 | divsum (c,v) | ||
90 | | c /= 0 = v*.(recip (3*c)) | ||
91 | | otherwise = (V.minimum vs+V.maximum vs)*.0.5 | ||
92 | |||
93 | -- | The moment of inertia of a simple polygon with respect to the origin. | ||
94 | moment :: Vector V2 -> Float | ||
95 | moment vs | ||
96 | | V.length vs < 3 = 0 | ||
97 | | otherwise = divsum (V.foldl1' accum (pairsWith gen vs)) | ||
98 | where | ||
99 | gen v1 v2 = let c = v2 `cross` v1 in (c,(v1 `dot` (v1+v2) + square v2)*c) | ||
100 | accum (!s1,!s2) (p1,p2) = (s1+p1,s2+p2) | ||
101 | divsum (s1,s2) | ||
102 | | s1 /= 0 = s2/(6*s1) | ||
103 | | otherwise = 0 | ||
104 | |||
105 | -- | The convex hull of a collection of vertices in counter-clockwise | ||
106 | -- order. (Andrew's Monotone Chain Algorithm) | ||
107 | convexHull :: Vector V2 -> Vector V2 | ||
108 | convexHull vs = case compare (V.length vs) 2 of | ||
109 | LT -> vs | ||
110 | EQ -> V.fromList . nub . V.toList $ vs | ||
111 | GT -> V.fromList (avs' ++ bvs') | ||
112 | where | ||
113 | svs = V.modify V.sort vs | ||
114 | vmin = V.head svs | ||
115 | vmax = V.last svs | ||
116 | vd = vmax-vmin | ||
117 | |||
118 | (avs,bvs) = V.partition (\v -> vd `turnNR` v-vmax) . V.init . V.tail $ svs | ||
119 | avs' = if V.null avs then [vmin] | ||
120 | else tail . V.foldl' (flip addVertex) [V.head avs,vmin] $ V.snoc (V.tail avs) vmax | ||
121 | bvs' = if V.null bvs then [vmax] | ||
122 | else tail . V.foldr' addVertex [V.last bvs,vmax] $ V.cons vmin (V.init bvs) | ||
123 | |||
124 | addVertex v (v1:vs@(v2:_)) | v1-v2 `turnNR` v-v1 = addVertex v vs | ||
125 | addVertex v vs = v:vs | ||
126 | |||
127 | -- | Monotone decomposition of a simple polygon. | ||
128 | monotoneDecomposition :: Vector V2 -> [MonotoneSegment] | ||
129 | monotoneDecomposition vs = (map getIndices . snd) (V.foldl' addVertex ([], []) scvs) | ||
130 | where | ||
131 | cw = area vs < 0 | ||
132 | ovs = if cw then vs else V.reverse vs | ||
133 | getIndices (l,r) = if cw then (map idx l, map idx r) | ||
134 | else (map idx' l, map idx' r) | ||
135 | where | ||
136 | idx' v = V.length vs - 1 - idx v | ||
137 | addVertex (mss, out) v = case vtype v of | ||
138 | -- open new monotone segment with this sole vertex | ||
139 | TopCap -> (([v], [v]) : mss, out) | ||
140 | -- split monotone segment: all vertices are added to left side, | ||
141 | -- only last two to right; this is the only case where we need | ||
142 | -- to check geometry to find the matching segment | ||
143 | BottomCap -> let (mss',(msl,msr):mss'') = break isContained mss | ||
144 | ms' = (msl, v : msr) | ||
145 | ms'' = ([v, head msr], [head msr]) | ||
146 | in (mss' ++ ms':ms'':mss'', out) | ||
147 | -- close the segment on the right side using the join vertex and | ||
148 | -- the next vertex on its other side | ||
149 | TopCup -> let ([(msl1,msr1),(msl2,msr2)], mssr) = partition isConnected mss | ||
150 | (msl1',msr1',msl2',msr2') = | ||
151 | if idx v == prev (head msr1) | ||
152 | then let i = prev (head msr2) | ||
153 | v' = cvs ! i | ||
154 | in (msl1, v { prev = i } : msr1, v':v:msl2, v':msr2) | ||
155 | else let i = prev (head msr1) | ||
156 | v' = cvs ! i | ||
157 | in (msl2, v { prev = i } : msr2, v':v:msl1, v':msr1) | ||
158 | in ((msl1',msr1'):mssr,(msl2',msr2'):out) | ||
159 | -- close monotone segment (stage for emission, remove from | ||
160 | -- active collection) | ||
161 | BottomCup -> let (mss',(msl,msr):mss'') = break isConnected mss | ||
162 | in (mss' ++ mss'', (v:msl,v:msr):out) | ||
163 | -- add to the segment the upper neighbour belongs to | ||
164 | Side -> let (mss',(msl,msr):mss'') = break isConnected mss | ||
165 | ms' = if idx v == next (head msl) then (v:msl, msr) else (msl, v:msr) | ||
166 | in (mss' ++ ms':mss'', out) | ||
167 | where | ||
168 | isConnected ((vl:_), (vr:_)) = idx v == next vl || idx v == prev vr | ||
169 | isConnected _ = error "isConnected" | ||
170 | |||
171 | isContained ((vl:_), (vr:_)) = px v > xl && px v <= xr | ||
172 | where | ||
173 | vl' = cvs ! (next vl) | ||
174 | vr' = cvs ! (prev vr) | ||
175 | xl = px vl + (px vl' - px vl) * (py v - py vl) / (py vl' - py vl) | ||
176 | xr = px vr + (px vr' - px vr) * (py v - py vr) / (py vr' - py vr) | ||
177 | isContained _ = error "isContained" | ||
178 | |||
179 | scvs = V.modify (V.sortBy (comparing py)) cvs | ||
180 | cvs = V.imap classify ovs | ||
181 | classify i1 v1@(V x1 y1) = Vtx i1 i0 i2 vty x1 y1 | ||
182 | where | ||
183 | vty = case (compare y1 y0, compare y1 y2, v2-v1 `turn` v1-v0) of | ||
184 | (LT, LT, LT) -> BottomCap | ||
185 | (EQ, LT, LT) -> BottomCap | ||
186 | (LT, LT, GT) -> TopCap | ||
187 | (LT, EQ, GT) -> TopCap | ||
188 | (GT, GT, GT) -> BottomCup | ||
189 | (EQ, GT, GT) -> BottomCup | ||
190 | (GT, GT, LT) -> TopCup | ||
191 | (GT, EQ, LT) -> TopCup | ||
192 | _ -> Side | ||
193 | i0 = if i1 == 0 then V.length ovs - 1 else i1-1 | ||
194 | i2 = if i1 == V.length ovs - 1 then 0 else i1+1 | ||
195 | v0@(V _ y0) = ovs ! i0 | ||
196 | v2@(V _ y2) = ovs ! i2 | ||
197 | |||
198 | -- | Triangulation of a monotone polygon. | ||
199 | monotoneTriangulation :: Vector V2 -> MonotoneSegment -> [(Int,Int,Int)] | ||
200 | monotoneTriangulation vs (msl,msr) = snd (foldl' addVertex ([si2,si1],[]) sis) | ||
201 | where | ||
202 | addVertex (si@(s,i):sis,ts) si'@(s',i') | ||
203 | | s /= s' = ([si',si], zipWith (if s' then tl else tr) (si:sis) sis ++ ts) | ||
204 | | concave = (si':si:sis,ts) | ||
205 | | otherwise = (si':si'':map snd si2s'', zipWith (if s' then tr else tl) sis' sis'' ++ ts) | ||
206 | where | ||
207 | concave = isConcave (snd (head sis)) i | ||
208 | (si2s',si2s'') = break visible (zip (si:sis) sis) | ||
209 | where | ||
210 | visible ((_,i1),(_,i2)) = isConcave i2 i1 | ||
211 | (sis',sis'') = unzip si2s' | ||
212 | si'' = last sis'' | ||
213 | |||
214 | tl (_,i1) (_,i2) = (i',i2,i1) | ||
215 | tr (_,i1) (_,i2) = (i',i1,i2) | ||
216 | |||
217 | isConcave i0 i1 = s' == v1-v0 `turnL` v2-v1 | ||
218 | where | ||
219 | v0 = vs ! i0 | ||
220 | v1 = vs ! i1 | ||
221 | v2 = vs ! i' | ||
222 | |||
223 | addVertex _ _ = error "addVertex" | ||
224 | |||
225 | si1:si2:sis = merge msl (init (tail msr)) | ||
226 | merge [] irs = map ((,) True) irs | ||
227 | merge ils [] = map ((,) False) ils | ||
228 | merge ils@(il:ils') irs@(ir:irs') | ||
229 | | y1 < y2 = (True,ir) : merge ils irs' | ||
230 | | otherwise = (False,il) : merge ils' irs | ||
231 | where | ||
232 | V _ y1 = vs ! il | ||
233 | V _ y2 = vs ! ir | ||
234 | |||
235 | -- | Triangulation of a simple polygon. | ||
236 | triangulation :: Vector V2 -> [(Int, Int, Int)] | ||
237 | triangulation vs = [tri | ms <- monotoneDecomposition vs, tri <- monotoneTriangulation vs ms] | ||
238 | |||
239 | -- | A 5-tuple @(d2,ds,sep,v1,v2)@ that provides distance information | ||
240 | -- on two convex polygons, where @d2@ is the square of the distance, | ||
241 | -- @ds@ is its sign (negative in case of penetration), @sep@ describes | ||
242 | -- the opposing features, while @v1@ and @v2@ are the absolute | ||
243 | -- coordinates of the deepest points within the opposite polygon. If | ||
244 | -- the third parameter is @True@, only negative distances are | ||
245 | -- reported, and the function yields @Nothing@ for non-overlapping | ||
246 | -- polygons. This is more efficient if we are only interested in | ||
247 | -- collisions, since the computation can be cancelled upon finding the | ||
248 | -- first separating axis. If the third parameter is @False@, the | ||
249 | -- result cannot be @Nothing@. | ||
250 | convexSeparation | ||
251 | :: Vector V2 -- ^ The vertices of the first polygon (vs1) | ||
252 | -> Vector V2 -- ^ The vertices of the second polygon (vs2) | ||
253 | -> Bool -- ^ Whether we are only interested in overlapping | ||
254 | -> Maybe (Float, Float, Separation, V2, V2) | ||
255 | convexSeparation vs1 vs2 onlyCollision | ||
256 | | onlyCollision = closestPenetratingPair firstValidPair | ||
257 | | otherwise = Just (closestPair firstValidPair) | ||
258 | where | ||
259 | l1 = V.length vs1 | ||
260 | l2 = V.length vs2 | ||
261 | succ1 n = let n' = succ n in if n' >= l1 then 0 else n' | ||
262 | succ2 n = let n' = succ n in if n' >= l2 then 0 else n' | ||
263 | pred1 n = if n == 0 then l1-1 else pred n | ||
264 | pred2 n = if n == 0 then l2-1 else pred n | ||
265 | |||
266 | firstValidPair = until validSeparation stepBackwards (GT,0,0) | ||
267 | |||
268 | -- Exhaustive search for the closest feature pair | ||
269 | closestPair s = go (l1+l2-1) (stepBackwards s) (s,v12) dst | ||
270 | where | ||
271 | (dst,v12) = separation s | ||
272 | go 0 _ (s,(v1,v2)) (sd,sgd) = (sd,-sgd,s,v1,v2) | ||
273 | go n s sep dst | ||
274 | | dst < dst' = go n' (stepBackwards s) sep dst | ||
275 | | otherwise = go n' (stepBackwards s) (s,v12) dst' | ||
276 | where | ||
277 | (dst',v12) = separation s | ||
278 | n' = n-1 | ||
279 | |||
280 | -- Exhaustive search for the closest penetrating feature pair | ||
281 | closestPenetratingPair s = go (l1+l2-1) (stepBackwards s) (s,v12) dst | ||
282 | where | ||
283 | (dst,v12) = separation s | ||
284 | go 0 _ (s,(v1,v2)) (sd,sgd) = Just (sd,-sgd,s,v1,v2) | ||
285 | go n s sep dst@(_,sg) | ||
286 | | sg < 0 = Nothing | ||
287 | | dst < dst' = go n' (stepBackwards s) sep dst | ||
288 | | otherwise = go n' (stepBackwards s) (s,v12) dst' | ||
289 | where | ||
290 | (dst',v12) = separation s | ||
291 | n' = n-1 | ||
292 | {- | ||
293 | -- Step towards the next feature pair counter-clockwise | ||
294 | stepForward (rel,i1,i2) = case rel of | ||
295 | LT -> (turn e1 e2',i1 ,i2') | ||
296 | EQ -> (turn e1' e2',i1',i2') | ||
297 | GT -> (turn e1' e2 ,i1',i2 ) | ||
298 | where | ||
299 | i1' = succ1 i1 | ||
300 | i2' = succ2 i2 | ||
301 | e1 = vs1 ! i1' - vs1 ! i1 | ||
302 | e2 = vs2 ! i2 - vs2 ! i2' | ||
303 | e1' = vs1 ! succ1 i1' - vs1 ! i1' | ||
304 | e2' = vs2 ! i2' - vs2 ! succ2 i2' | ||
305 | -} | ||
306 | -- Step towards the next feature pair clockwise | ||
307 | stepBackwards (_,i1,i2) = case turn e2 e1 of | ||
308 | LT -> (LT,i1 ,i2') | ||
309 | EQ -> (EQ,i1',i2') | ||
310 | GT -> (GT,i1',i2 ) | ||
311 | where | ||
312 | i1' = pred1 i1 | ||
313 | i2' = pred2 i2 | ||
314 | e1 = vs1 ! i1 - vs1 ! i1' | ||
315 | e2 = vs2 ! i2' - vs2 ! i2 | ||
316 | |||
317 | -- Check if the feature pair is valid (i.e. the edge lies within | ||
318 | -- the interval defined by the vertex, or the edges are parallel) | ||
319 | validSeparation (rel,i1,i2) = case rel of | ||
320 | LT -> turnNR e11 e22 && turnNR e22 e12 | ||
321 | EQ -> parv e12 e22 | ||
322 | GT -> turnNR e21 e12 && turnNR e12 e22 | ||
323 | where | ||
324 | v1 = vs1 ! i1 | ||
325 | v2 = vs2 ! i2 | ||
326 | e11 = v1 - vs1 ! pred1 i1 | ||
327 | e12 = vs1 ! succ1 i1 - v1 | ||
328 | e21 = vs2 ! pred2 i2 - v2 | ||
329 | e22 = v2 - vs2 ! succ2 i2 | ||
330 | |||
331 | -- Distance information for a given feature pair | ||
332 | separation (rel,i1,i2) = case rel of | ||
333 | LT -> swap (s v2 v2' e2 sd2 v1) | ||
334 | GT -> s v1 v1' e1 sd1 v2 | ||
335 | EQ | sd1 > sd2 -> min (s v1 v1' e1 sd1 v2) (s v1 v1' e1 sd1 v2') | ||
336 | | otherwise -> swap (min (s v2 v2' e2 sd2 v1) (s v2 v2' e2 sd2 v1')) | ||
337 | where | ||
338 | swap (d,(v1,v2)) = (d,(v2,v1)) | ||
339 | |||
340 | v1 = vs1 ! i1 | ||
341 | v2 = vs2 ! i2 | ||
342 | v1' = vs1 ! succ1 i1 | ||
343 | v2' = vs2 ! succ2 i2 | ||
344 | e1 = v1'-v1 | ||
345 | e2 = v2'-v2 | ||
346 | sd1 = square e1 | ||
347 | sd2 = square e2 | ||
348 | |||
349 | -- The squared distance of the v1 to v2 segment and the v3 vertex | ||
350 | s v1 v2 e12 sd12 v3 = ((sd,signum cp),(v,v3)) | ||
351 | where | ||
352 | e13 = v3-v1 | ||
353 | e23 = v3-v2 | ||
354 | sd12' = recip sd12 | ||
355 | dp = e12 `dot` e13 | ||
356 | -- negative: separation, positive: penetration | ||
357 | cp = e12 `cross` e13 | ||
358 | (v,sd) | dp <= 0 = (v1,square e13) | ||
359 | | dp >= sd12 = (v2,square e23) | ||
360 | | otherwise = (v1+e12*.(dp*sd12'),cp*cp*sd12') | ||
diff --git a/src/Graphics/Triangulation/KETTriangulation.hs b/src/Graphics/Triangulation/KETTriangulation.hs new file mode 100644 index 0000000..b0f0759 --- /dev/null +++ b/src/Graphics/Triangulation/KETTriangulation.hs | |||
@@ -0,0 +1,64 @@ | |||
1 | -- | | ||
2 | -- Module : Graphics.Triangulation.KETTriangulation | ||
3 | -- Copyright :(C) 1997, 1998, 2008 Joern Dinkla, www.dinkla.net | ||
4 | -- | ||
5 | -- Triangulation of simple polygons after Kong, Everett, Toussaint 91 | ||
6 | -- with some changes by T.Vogt: return indices instead of coordinates of triangles and Data.Vector instead of lists | ||
7 | -- | ||
8 | -- see | ||
9 | -- Joern Dinkla, Geometrische Algorithmen in Haskell, Diploma Thesis, | ||
10 | -- University of Bonn, Germany, 1998. | ||
11 | |||
12 | module Graphics.Triangulation.KETTriangulation (ketTri) where | ||
13 | import Graphics.Triangulation.Triangulation (isLeftTurn, isRightTurnOrOn) | ||
14 | import Data.List ( (\\) ) | ||
15 | import Data.Vector (Vector) | ||
16 | import qualified Data.Vector as V | ||
17 | import Graphics.Formats.Collada.Vector2D3D (V2 (V)) | ||
18 | import Debug.Trace | ||
19 | |||
20 | type V2i = (V2,Int) | ||
21 | toV2 = V.map (\(x,i) -> x) | ||
22 | |||
23 | ketTri :: Vector V2 -> [(Int,Int,Int)] | ||
24 | ketTri points | (V.length vertices) > 3 = scan vs stack rs | ||
25 | | otherwise = [] | ||
26 | where vertices = V.zip points (V.generate (V.length points) id) | ||
27 | [p1,p2,p3] = V.toList (V.take 3 vertices) | ||
28 | qs = V.drop 3 vertices | ||
29 | vs = qs V.++ (V.singleton p1) | ||
30 | stack = V.fromList [p3, p2, p1, V.last vertices] | ||
31 | rs = reflexVertices (angles vertices) | ||
32 | |||
33 | scan :: Vector V2i -> Vector V2i -> Vector V2i -> [(Int,Int,Int)] | ||
34 | scan vs stack rs | V.null vs = [] | ||
35 | | V.length vs == 1 = [(snd (V.head stack), snd (V.head (V.tail stack)), snd (V.head vs))] | ||
36 | | V.length stack == 3 = scan (V.tail vs) (V.cons (V.head vs) stack) rs | ||
37 | | isEar rs x_m x_i x_p = (snd x_p, snd x_i, snd x_m) : (scan vs (V.cons x_p ss') rs') | ||
38 | | otherwise = scan (V.tail vs) (V.cons (V.head vs) stack) rs | ||
39 | where [x_p, x_i, x_m] = V.toList (V.take 3 stack) | ||
40 | ss' = V.drop 2 stack | ||
41 | rs' = V.fromList $ (V.toList rs) \\ (isConvex x_m x_p (V.head vs) ++ | ||
42 | isConvex (V.head (V.tail ss')) x_m x_p) | ||
43 | isConvex (im,_) (i,ii) (ip,_) = if isLeftTurn im i ip then [(i,ii)] else [] | ||
44 | |||
45 | isEar :: Vector V2i -> V2i -> V2i -> V2i -> Bool | ||
46 | isEar rs (m,_) (x,_) (p,_) | V.null rs = True | ||
47 | | otherwise = isLeftTurn m x p && not (V.any ( (m,x,p) `containsBNV`) (toV2 rs)) | ||
48 | |||
49 | reflexVertices :: Vector (V2i,V2i,V2i) -> Vector V2i | ||
50 | reflexVertices as | V.null as = V.empty | ||
51 | | isRightTurnOrOn m x p = V.cons (x,xi) $ reflexVertices (V.tail as) | ||
52 | | otherwise = reflexVertices (V.tail as) | ||
53 | where ((m,_),(x,xi),(p,_)) = V.head as | ||
54 | |||
55 | containsBNV (s,t,v) p = (a==b && b==c) | ||
56 | where a = isLeftTurn s t p | ||
57 | b = isLeftTurn t v p | ||
58 | c = isLeftTurn v s p | ||
59 | |||
60 | angles :: Vector a -> Vector (a,a,a) | ||
61 | angles xs = V.zip3 (rotateR xs) xs (rotateL xs) | ||
62 | |||
63 | rotateL xs = (V.tail xs) V.++ (V.singleton (V.head xs)) | ||
64 | rotateR xs = (V.singleton (V.last xs)) V.++ (V.init xs) | ||
diff --git a/src/Graphics/Triangulation/Triangulation.hs b/src/Graphics/Triangulation/Triangulation.hs new file mode 100644 index 0000000..9358ea5 --- /dev/null +++ b/src/Graphics/Triangulation/Triangulation.hs | |||
@@ -0,0 +1,183 @@ | |||
1 | module Graphics.Triangulation.Triangulation where | ||
2 | import Graphics.Formats.Collada.ColladaTypes | ||
3 | import Graphics.Formats.Collada.Transformations (cycleNeighbours,cycleN) | ||
4 | import qualified Graphics.Triangulation.GJPTriangulation as T | ||
5 | import Data.Tuple.Select | ||
6 | import qualified Data.Vector as V | ||
7 | import Data.Vector (Vector, (!)) | ||
8 | import Graphics.Formats.Collada.Vector2D3D (V2 (V), V3(V3)) | ||
9 | import Debug.Trace | ||
10 | import Data.List | ||
11 | |||
12 | type TriangulationFunction = Vector V2 -> [(Int,Int,Int)] | ||
13 | data Tree = Node Int Int [Tree] | ||
14 | |||
15 | instance Show Tree where | ||
16 | show (Node c p tree) = "Node " ++ (show c) ++ " " ++ (show p) ++ "[" ++ (concat(map show tree)) ++ "]" | ||
17 | |||
18 | -- | since there are a lot of triangulation algorithms | ||
19 | -- a triangulation function can be passed | ||
20 | triangulate :: TriangulationFunction -> Geometry -> Geometry | ||
21 | triangulate f (Geometry name prims (Vertices vname ps ns)) = | ||
22 | Geometry name (map triPoly prims) (Vertices vname ps ns) | ||
23 | where | ||
24 | triPoly (LP (LinePrimitive pIndices nIndices tex col)) = | ||
25 | PL (LinePrimitive (tri 0 pIndices) (normals pIndices nIndices) tex col) | ||
26 | -- TO DO: other patterns | ||
27 | tri :: Int -> Vector (Vector Int) -> Vector (Vector Int) | ||
28 | tri i pIndices | V.null pIndices = V.empty | ||
29 | | otherwise = (g ( map (ind (V.head pIndices)) (f (v2s ps (V.head pIndices))))) V.++ | ||
30 | (tri (i+(V.length (V.head pIndices))) (V.tail pIndices)) | ||
31 | ind pIndices (i0,i1,i2) = (pIndices V.! i0, pIndices V.! i1, pIndices V.! i2) | ||
32 | g :: [(Int,Int,Int)] -> Vector (Vector Int) | ||
33 | g [] = V.empty | ||
34 | g ((i0,i1,i2):xs) = V.cons (V.cons i0 $ V.cons i1 $ V.singleton i2) (g xs) | ||
35 | |||
36 | normals pIndices nIndices = V.replicate (V.sum (V.map V.length pIndices)) (V.head nIndices) | ||
37 | |||
38 | v2s :: Vector V3 -> Vector Int -> Vector V2 | ||
39 | v2s ps pIndices | V.null pIndices = V.empty | ||
40 | | otherwise = V.cons (V x z) (v2s ps (V.tail pIndices)) | ||
41 | where (V3 x y z) = ps V.! i | ||
42 | i = (V.head pIndices) | ||
43 | |||
44 | gjpTri :: Vector V2 -> [(Int,Int,Int)] | ||
45 | gjpTri = T.triangulation | ||
46 | |||
47 | |||
48 | -- | some triangulation algorithms on't support polygons with holes | ||
49 | -- These polygons with (nested) holes have to be cut so that they consist of only one outline | ||
50 | -- I.e. the chars a,b,d,e,g,o,p,q contain holes tat have to be deleted. | ||
51 | |||
52 | deleteHoles :: Geometry -> Geometry | ||
53 | deleteHoles (Geometry name prims (Vertices vname ps ns)) = | ||
54 | Geometry name newPrims (Vertices vname ps ns) | ||
55 | where | ||
56 | newPrims = zipWith3 (\pInd tex col -> LP (LinePrimitive pInd pInd tex col)) flattenedTrees (map t prims) (map c prims) | ||
57 | flattenedTrees = zipWith (flatten vs) trees vertices | ||
58 | trees = map (generateTrees ps insidePoly) vertices | ||
59 | pI (LP (LinePrimitive pIndices nIndices tex col)) = pIndices | ||
60 | t (LP (LinePrimitive pIndices nIndices tex col)) = tex | ||
61 | c (LP (LinePrimitive pIndices nIndices tex col)) = col | ||
62 | vertices :: [Vector (Vector Int)] | ||
63 | vertices = map pI prims | ||
64 | vs = V.map (\(V3 x y z) -> V x z) ps | ||
65 | |||
66 | |||
67 | flatten :: Vector V2 -> [Tree] -> Vector (Vector Int) -> Vector (Vector Int) | ||
68 | flatten _ [] is = V.empty | ||
69 | flatten vs ((Node c poly tts):ts) is | ||
70 | | null tts = V.cons (alternate c (pdir poly) (is V.! poly)) (flatten vs ts is) | ||
71 | | otherwise = V.cons (embed vs (flatten vs tts is) (alternate c (pdir poly) (is V.! poly))) (flatten vs ts is) | ||
72 | where | ||
73 | pdir poly = polygonDirection $ V.map (vs V.!) (is V.! poly) | ||
74 | |||
75 | -- |cut a polygon at a good position and insert the contained hole-polygon with opposite direction | ||
76 | embed :: Vector V2 -> Vector (Vector Int) -> Vector Int -> Vector Int | ||
77 | embed vs sub_polys poly | V.null sub_polys = poly | ||
78 | | otherwise = embed vs (V.tail sub_polys) ((V.take (n+1) poly) V.++ | ||
79 | (V.head sub_polys) V.++ | ||
80 | (V.cons (V.head (V.head sub_polys)) (V.drop n poly)) ) | ||
81 | where n = fst $ rotatePoly (vs V.! (V.head (V.head sub_polys))) (V.map (vs V.!) poly) | ||
82 | |||
83 | -- |make sure that direction (clockwise or ccw) of polygons alternates depending on the nesting number c of poly | ||
84 | alternate :: Int -> Bool -> Vector Int -> Vector Int | ||
85 | alternate c b poly | (b && (even c)) || (not b && (odd c)) = poly | ||
86 | | otherwise = V.reverse poly | ||
87 | |||
88 | -- |f should be the funtion to test "contains" | ||
89 | -- the trees then are the hierarchy of containedness of outlines | ||
90 | generateTrees :: Vector V3 -> (Vector V2 -> Vector V2 -> Bool) -> Vector (Vector Int) -> [Tree] | ||
91 | generateTrees vs f ps | V.null ps = [] | ||
92 | | otherwise = (treesList containedPolys []) ++ | ||
93 | (map (\x -> Node 0 x []) separateOutlines) | ||
94 | where containedPolys = filter (\[p0,p1] -> f (pvs p0) (pvs p1)) (combi ++ (map reverse combi)) | ||
95 | combi = combinationsOf 2 [0..((V.length ps)-1)] -- all 2-subsets i.e. [[0,1],[0,2],[1,2]] | ||
96 | -- separate outlines don't contain other outlines | ||
97 | separateOutlines = ([0..((V.length ps)-1)]) \\ (nub $ concat containedPolys) | ||
98 | pvs p = V.map (\(V3 x y z) -> V x z) $ V.map (vs V.!) (ps V.! p) | ||
99 | |||
100 | treesList :: [[Int]] -> [Tree] -> [Tree] | ||
101 | treesList [] trees = trees | ||
102 | treesList ([x,y]:cs) trees = treesList cs (insertTrees [x,y] trees) | ||
103 | |||
104 | insertTrees :: [Int] -> [Tree] -> [Tree] | ||
105 | insertTrees [x,y] trees | or (map fst ins) = map snd ins | ||
106 | | otherwise = (map snd ins) ++ [ Node 0 y [Node 1 x []] ] | ||
107 | where ins = map (insertTree [x,y]) trees | ||
108 | |||
109 | insertTree :: [Int] -> Tree -> (Bool, Tree) | ||
110 | insertTree [x,y] (Node c i []) | y == i = (True, Node c i [Node (c+1) x []] ) | ||
111 | | otherwise = (False, Node c i []) | ||
112 | insertTree [x,y] (Node c i trees) | y == i = (True, Node c i ((Node (c+1) x []):trees) ) | ||
113 | | otherwise = (b, Node c i (map snd subtrees)) | ||
114 | where subtrees = map (insertTree [x,y]) trees | ||
115 | b = or (map fst subtrees) | ||
116 | |||
117 | -- subsets of size k | ||
118 | -- borrowed from David Amos' library: HaskellForMaths | ||
119 | combinationsOf 0 _ = [[]] | ||
120 | combinationsOf _ [] = [] | ||
121 | combinationsOf k (x:xs) = map (x:) (combinationsOf (k-1) xs) ++ combinationsOf k xs | ||
122 | |||
123 | -- |how many positions to rotate a polygon until the start point is nearest to some other point | ||
124 | -- call i.e. with nearest (3,4) [(0,0),(1,2), ... ] 0 0 | ||
125 | rotatePoly :: V2 -> Vector V2 -> (Int,Float) | ||
126 | rotatePoly p poly = nearest p poly (-1) 0 0 | ||
127 | |||
128 | nearest :: V2 -> Vector V2 -> Float -> Int -> Int -> (Int,Float) | ||
129 | nearest (V x0 y0) ps dist l ml | V.null ps = (ml,dist) | ||
130 | | (newDist < dist) || (dist < 0) = nearest (V x0 y0) (V.tail ps) newDist (l+1) l | ||
131 | | otherwise = nearest (V x0 y0) (V.tail ps) dist (l+1) ml | ||
132 | where newDist = (x0-x1)*(x0-x1)+(y0-y1)*(y0-y1) | ||
133 | (V x1 y1) = V.head ps | ||
134 | |||
135 | -- | returns True iff the first point of the first polygon is inside the second poylgon | ||
136 | insidePoly :: Vector V2 -> Vector V2 -> Bool | ||
137 | insidePoly poly1 poly2 | V.null poly1 = False | ||
138 | | V.null poly2 = False | ||
139 | | otherwise = pointInside (V.head poly1) poly2 | ||
140 | |||
141 | -- | A point is inside a polygon if it has an odd number of intersections with the boundary (Jordan Curve theorem) | ||
142 | pointInside :: V2 -> Vector V2 -> Bool | ||
143 | pointInside (V x y) poly = (V.length intersectPairs) `mod` 2 == 1 | ||
144 | where intersectPairs = V.filter (\p -> positiveXAxis p && aboveBelow p) allPairs --, specialCases p] | ||
145 | allPairs = cycleNeighbours poly | ||
146 | positiveXAxis p = (x0 p) > x || (x1 p) > x -- intersect with positive x-axis | ||
147 | -- only lines with one point above + one point below can intersect | ||
148 | aboveBelow p = (((y0 p)> y && (y1 p)< y) || ((y0 p) < y && (y1 p) > y)) | ||
149 | specialCases p = (((dir1 p) > 0 && (dir2 p) <= 0) || ((dir1 p) <= 0 && (dir2 p) > 0))-- cross product for special cases | ||
150 | dir1 p = cross ((x1 p)-(x0 p),(y1 p)-(y0 p)) (1,0) | ||
151 | dir2 p = cross ((x1 p)-(x0 p),(y1 p)-(y0 p)) (x-(x0 p),y-(y0 p)) | ||
152 | cross (a0,b0) (a1,b1) = a0*b1 - a1*b0 | ||
153 | x0 p = (\(V x y) -> x) (V.head p) | ||
154 | x1 p = (\(V x y) -> x) (V.last p) | ||
155 | y0 p = (\(V x y) -> y) (V.head p) | ||
156 | y1 p = (\(V x y) -> y) (V.last p) | ||
157 | |||
158 | -- | the direction of a polygon can be obtained by looking at a maximal point | ||
159 | -- returns True if counterclockwise | ||
160 | -- False if clockwise | ||
161 | polygonDirection :: Vector V2 -> Bool | ||
162 | polygonDirection poly | dir > 0 = True | ||
163 | | dir < 0 = False | ||
164 | | dir ==0 = (x0 > x1) || (y0 < y1) | ||
165 | where p = V.fromList $ nub $ V.toList poly | ||
166 | (V x0 y0) = p V.! lminus | ||
167 | (V x1 y1) = p V.! lplus | ||
168 | dir = area2 (p!lminus) (p!l) (p!lplus) | ||
169 | l = maxim poly 0 0 (-1000000,-1000000) | ||
170 | lminus = (l-1) `mod` (V.length p) | ||
171 | lplus = (l+1) `mod` (V.length p) | ||
172 | -- the index of the right-/upmost point | ||
173 | |||
174 | maxim :: Vector V2 -> Int -> Int -> (Float,Float) -> Int | ||
175 | maxim xs count ml (mx,my) | V.null xs = ml | ||
176 | | (x > mx) || (x >= mx && y > my) = maxim (V.tail xs) (count+1) count (x, y) | ||
177 | | otherwise = maxim (V.tail xs) (count+1) ml (mx,my) | ||
178 | where (V x y) = V.head xs | ||
179 | |||
180 | isRightTurnOrOn m x p = (area2 m x p) <= 0 | ||
181 | isLeftTurn :: V2 -> V2 -> V2 -> Bool | ||
182 | isLeftTurn m x p = (area2 m x p) > 0 | ||
183 | area2 (V x2 y2) (V x0 y0) (V x1 y1) = (x1-x0)*(y2-y0)-(x2-x0)*(y1-y0) | ||
diff --git a/src/Graphics/WaveFront.hs b/src/Graphics/WaveFront.hs new file mode 100644 index 0000000..c71966b --- /dev/null +++ b/src/Graphics/WaveFront.hs | |||
@@ -0,0 +1,62 @@ | |||
1 | -- | | ||
2 | -- Module : Graphics.WaveFront | ||
3 | -- Description : Re-exports public API | ||
4 | -- Copyright : (c) Jonatan H Sundqvist, 2016 | ||
5 | -- License : MIT | ||
6 | -- Maintainer : Jonatan H Sundqvist | ||
7 | -- Stability : experimental|stable | ||
8 | -- Portability : POSIX (not sure) | ||
9 | |||
10 | -- TODO | - Logging | ||
11 | -- - | ||
12 | |||
13 | -- SPEC | - | ||
14 | -- - | ||
15 | |||
16 | |||
17 | |||
18 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
19 | -- GHC Extensions | ||
20 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
21 | |||
22 | |||
23 | |||
24 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
25 | -- API | ||
26 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
27 | -- TODO | - Decide on an API | ||
28 | module Graphics.WaveFront ( | ||
29 | -- * OBJ types | ||
30 | OBJToken(..), VertexIndices(..), OBJ, | ||
31 | |||
32 | -- * MTL types | ||
33 | MTLToken(..), Illumination(..), MTL, MTLTable(..), | ||
34 | |||
35 | -- * Model types | ||
36 | Face(..), Colour(..), Material(..), Model(..), | ||
37 | |||
38 | -- * Lenses | ||
39 | module Lenses, | ||
40 | |||
41 | -- * Parsing | ||
42 | module Graphics.WaveFront.Parse, | ||
43 | |||
44 | -- * Model functions | ||
45 | createModel, tessellate, bounds, fromIndices, fromFaceIndices, diffuseColours, hasTextures, textures, | ||
46 | |||
47 | -- * Loading | ||
48 | module Load, | ||
49 | |||
50 | ) where | ||
51 | |||
52 | |||
53 | |||
54 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
55 | -- We'll need these | ||
56 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
57 | import Graphics.WaveFront.Types | ||
58 | import Graphics.WaveFront.Parse | ||
59 | import Graphics.WaveFront.Parse.Common | ||
60 | import Graphics.WaveFront.Model | ||
61 | import Graphics.WaveFront.Lenses as Lenses | ||
62 | import qualified Graphics.WaveFront.Load as Load | ||
diff --git a/src/Graphics/WaveFront/Foreign.hs b/src/Graphics/WaveFront/Foreign.hs new file mode 100644 index 0000000..7722c07 --- /dev/null +++ b/src/Graphics/WaveFront/Foreign.hs | |||
@@ -0,0 +1,88 @@ | |||
1 | -- | | ||
2 | -- Module : Graphics.WaveFront.Foreign | ||
3 | -- Description : Foreign function interface | ||
4 | -- Copyright : (c) Jonatan H Sundqvist, 2015 | ||
5 | -- License : MIT | ||
6 | -- Maintainer : Jonatan H Sundqvist | ||
7 | -- Stability : experimental|stable | ||
8 | -- Portability : POSIX (not sure) | ||
9 | |||
10 | -- February 24 2015 | ||
11 | |||
12 | -- TODO | - Possible to get rid of newtypes (?) | ||
13 | -- - Decide on an API | ||
14 | |||
15 | -- SPEC | - | ||
16 | -- - | ||
17 | |||
18 | |||
19 | |||
20 | -- TODO: Why do some extensions start with 'X'? | ||
21 | {-# LANGUAGE ForeignFunctionInterface #-} | ||
22 | |||
23 | |||
24 | |||
25 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
26 | -- API | ||
27 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
28 | module Graphics.WaveFront.Foreign where | ||
29 | |||
30 | |||
31 | |||
32 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
33 | -- We'll need these | ||
34 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
35 | -- import System.IO.Unsafe (unsafePerformIO) | ||
36 | -- import Foreign.Storable | ||
37 | -- import qualified Foreign.C as C | ||
38 | |||
39 | -- import Graphics.WaveFront.Types | ||
40 | -- import qualified Graphics.WaveFront.Parse as Parse | ||
41 | |||
42 | |||
43 | |||
44 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
45 | -- Functions | ||
46 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
47 | |||
48 | -- -- | | ||
49 | -- -- I feel dirty... | ||
50 | -- parseOBJ :: C.CString -> COBJ | ||
51 | -- parseOBJ = COBJ . Parsers.parseOBJ . unsafePerformIO . C.peekCString | ||
52 | -- | ||
53 | -- -- | | ||
54 | -- parseMTL :: C.CString -> CMTL | ||
55 | -- parseMTL = CMTL . Parsers.parseMTL . unsafePerformIO . C.peekCString | ||
56 | |||
57 | |||
58 | |||
59 | -- -- | | ||
60 | -- newtype COBJ = COBJ OBJ | ||
61 | -- | ||
62 | -- | ||
63 | -- -- | | ||
64 | -- newtype CMTL = CMTL MTL | ||
65 | -- | ||
66 | -- | ||
67 | -- -- | We | ||
68 | -- instance Storable COBJ where | ||
69 | -- sizeOf = const 0 | ||
70 | -- alignment = const 0 | ||
71 | -- peek _ = error "Work in progress" | ||
72 | -- poke _ = error "Work in progress" | ||
73 | -- | ||
74 | -- | ||
75 | -- -- | We | ||
76 | -- instance Storable CMTL where | ||
77 | -- sizeOf = const 0 | ||
78 | -- alignment = const 0 | ||
79 | -- peek _ = error "Work in progress" | ||
80 | -- poke _ = error "Work in progress" | ||
81 | |||
82 | |||
83 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
84 | -- Pure foreign function interface | ||
85 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
86 | -- I feel the urge to make a joke about 'Unacceptable argument in foreign declaration' | ||
87 | -- foreign export ccall parseOBJ :: C.CString -> COBJ | ||
88 | -- foreign export ccall parseMTL :: C.CString -> CMTL | ||
diff --git a/src/Graphics/WaveFront/Lenses.hs b/src/Graphics/WaveFront/Lenses.hs new file mode 100644 index 0000000..d507ef9 --- /dev/null +++ b/src/Graphics/WaveFront/Lenses.hs | |||
@@ -0,0 +1,54 @@ | |||
1 | -- | | ||
2 | -- Module : Graphics.WaveFront.Lenses | ||
3 | -- Description : | ||
4 | -- Copyright : (c) Jonatan H Sundqvist, 2016 | ||
5 | -- License : MIT | ||
6 | -- Maintainer : Jonatan H Sundqvist | ||
7 | -- Stability : experimental|stable | ||
8 | -- Portability : POSIX (not sure) | ||
9 | -- | ||
10 | |||
11 | -- Created July 9 2016 | ||
12 | |||
13 | -- TODO | - | ||
14 | -- - | ||
15 | |||
16 | -- SPEC | - | ||
17 | -- - | ||
18 | |||
19 | |||
20 | |||
21 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
22 | -- GHC Pragmas | ||
23 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
24 | {-# LANGUAGE TemplateHaskell #-} | ||
25 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
26 | {-# LANGUAGE FunctionalDependencies #-} | ||
27 | {-# LANGUAGE FlexibleInstances #-} | ||
28 | |||
29 | |||
30 | |||
31 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
32 | -- API | ||
33 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
34 | module Graphics.WaveFront.Lenses where | ||
35 | |||
36 | |||
37 | |||
38 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
39 | -- We'll need these | ||
40 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
41 | import Control.Lens (makeLensesWith, abbreviatedFields) | ||
42 | |||
43 | import Graphics.WaveFront.Types | ||
44 | |||
45 | |||
46 | |||
47 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
48 | -- Lenses | ||
49 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
50 | makeLensesWith abbreviatedFields ''VertexIndices | ||
51 | makeLensesWith abbreviatedFields ''Face | ||
52 | makeLensesWith abbreviatedFields ''Colour | ||
53 | makeLensesWith abbreviatedFields ''Material | ||
54 | makeLensesWith abbreviatedFields ''Model \ No newline at end of file | ||
diff --git a/src/Graphics/WaveFront/Load.hs b/src/Graphics/WaveFront/Load.hs new file mode 100644 index 0000000..6d65693 --- /dev/null +++ b/src/Graphics/WaveFront/Load.hs | |||
@@ -0,0 +1,108 @@ | |||
1 | -- | | ||
2 | -- Module : Graphics.WaveFront.Load | ||
3 | -- Description : Loading (and perhaps writing) OBJ and MTL files | ||
4 | -- Copyright : (c) Jonatan H Sundqvist, 2015 | ||
5 | -- License : MIT | ||
6 | -- Maintainer : Jonatan H Sundqvist | ||
7 | -- Stability : experimental|stable | ||
8 | -- Portability : POSIX (not sure) | ||
9 | -- | ||
10 | |||
11 | -- Created July 26 2015 | ||
12 | |||
13 | -- TODO | - Logging | ||
14 | -- - | ||
15 | |||
16 | -- SPEC | - | ||
17 | -- - | ||
18 | |||
19 | |||
20 | |||
21 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
22 | -- GHC Extensions | ||
23 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
24 | {-# LANGUAGE UnicodeSyntax #-} | ||
25 | -- {-# LANGUAGE TupleSections #-} | ||
26 | |||
27 | |||
28 | |||
29 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
30 | -- API | ||
31 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
32 | -- TODO | - Decide on an API | ||
33 | module Graphics.WaveFront.Load ( | ||
34 | obj, mtl, materials, model | ||
35 | ) where | ||
36 | |||
37 | |||
38 | |||
39 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
40 | -- We'll need these | ||
41 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
42 | import System.FilePath (splitFileName, takeDirectory, (</>)) | ||
43 | |||
44 | import Data.Text (Text) | ||
45 | import qualified Data.Text as T | ||
46 | import qualified Data.Text.IO as T | ||
47 | import Data.Vector (Vector) | ||
48 | |||
49 | import Control.Applicative ((<$>)) | ||
50 | import Control.Monad.Trans.Except | ||
51 | import Control.Monad.Trans.Class (lift) | ||
52 | |||
53 | import qualified Data.Attoparsec.Text as Atto | ||
54 | |||
55 | import Graphics.WaveFront.Types | ||
56 | import qualified Graphics.WaveFront.Parse as Parse | ||
57 | import qualified Graphics.WaveFront.Parse.Common as Parse | ||
58 | import Graphics.WaveFront.Model (createMTLTable, createModel) | ||
59 | |||
60 | |||
61 | |||
62 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
63 | -- Functions (IO) | ||
64 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
65 | |||
66 | -- Loading data ---------------------------------------------------------------------------------------------------------------------------- | ||
67 | |||
68 | -- | | ||
69 | -- TODO | - Use bytestrings (?) | ||
70 | -- - Deal with IO and parsing errors | ||
71 | obj :: (Fractional f, Integral i) => String -> IO (Either String (OBJ f Text i [])) | ||
72 | obj fn = runExceptT $ do | ||
73 | lift $ putStrLn $ "Loading obj file: " ++ fn | ||
74 | ExceptT $ Atto.parseOnly (Parse.wholeFile Parse.obj) <$> T.readFile fn | ||
75 | |||
76 | |||
77 | -- | | ||
78 | -- TODO | - Use bytestrings (?) | ||
79 | -- - Merge OBJ and MTL parsers (and plug in format-specific code as needed) (?) | ||
80 | -- - Deal with IO and parsing errors | ||
81 | mtl :: (Fractional f) => String -> IO (Either String (MTL f Text [])) | ||
82 | mtl fn = do | ||
83 | putStrLn $ "Loading mtl file: " ++ fn | ||
84 | Atto.parseOnly (Parse.wholeFile Parse.mtl) <$> T.readFile fn | ||
85 | |||
86 | |||
87 | -- | | ||
88 | -- TODO | - Better names (than 'mtls' and 'fns') (?) | ||
89 | -- - Refactor, simplify | ||
90 | -- - Improve path handling (cf. '</>') | ||
91 | -- - Graceful error handling | ||
92 | materials :: (Fractional f) => [FilePath] -> IO (Either String (MTLTable f Text)) | ||
93 | materials fns = runExceptT $ do | ||
94 | tokens <- mapM (ExceptT . mtl) fns | ||
95 | ExceptT . return $ createTableFromMTLs tokens | ||
96 | where | ||
97 | createTableFromMTLs :: [[MTLToken f Text]] -> Either String (MTLTable f Text) | ||
98 | createTableFromMTLs = createMTLTable . zip (map (T.pack . snd . splitFileName) fns) | ||
99 | |||
100 | |||
101 | -- | Loads an OBJ model from file, including associated materials | ||
102 | -- TODO | - Graceful error handling | ||
103 | model :: (Fractional f, Integral i) => FilePath -> IO (Either String (Model f Text i Vector)) | ||
104 | model fn = runExceptT $ do | ||
105 | obj <- ExceptT $ obj fn | ||
106 | materials <- ExceptT $ materials [ fst (splitFileName fn) </> T.unpack name | LibMTL name <- obj ] | ||
107 | ExceptT . return $ createModel obj materials (Just $ takeDirectory fn) | ||
108 | -- where loadWithName name = mtl name >>= return . (name,) | ||
diff --git a/src/Graphics/WaveFront/Model.hs b/src/Graphics/WaveFront/Model.hs new file mode 100644 index 0000000..96172a8 --- /dev/null +++ b/src/Graphics/WaveFront/Model.hs | |||
@@ -0,0 +1,345 @@ | |||
1 | -- | | ||
2 | -- Module : Graphics.WaveFront.Model | ||
3 | -- Description : | ||
4 | -- Copyright : (c) Jonatan H Sundqvist, 2016 | ||
5 | -- License : MIT | ||
6 | -- Maintainer : Jonatan H Sundqvist | ||
7 | -- Stability : stable | ||
8 | -- Portability : portable | ||
9 | -- | ||
10 | |||
11 | -- TODO | - Single-pass (eg. consume all tokens only once) for additional performance (?) | ||
12 | -- - | ||
13 | |||
14 | -- SPEC | - | ||
15 | -- - | ||
16 | |||
17 | |||
18 | |||
19 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
20 | -- GHC Extensions | ||
21 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
22 | {-# LANGUAGE UnicodeSyntax #-} | ||
23 | {-# LANGUAGE TupleSections #-} | ||
24 | {-# LANGUAGE NamedFieldPuns #-} | ||
25 | {-# LANGUAGE FlexibleContexts #-} | ||
26 | {-# LANGUAGE OverloadedStrings #-} | ||
27 | {-# LANGUAGE ScopedTypeVariables #-} | ||
28 | --{-# LANGUAGE OverloadedLists #-} | ||
29 | |||
30 | |||
31 | |||
32 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
33 | -- Section | ||
34 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
35 | -- TODO | - Clean this up | ||
36 | -- - Decide on API | ||
37 | module Graphics.WaveFront.Model ( | ||
38 | BoundingBox(..), | ||
39 | facesOf, materialsOf, | ||
40 | tessellate, bounds, | ||
41 | hasTextures, textures, | ||
42 | createModel, createMTLTable, | ||
43 | fromIndices, fromFaceIndices, diffuseColours | ||
44 | ) where | ||
45 | |||
46 | |||
47 | |||
48 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
49 | -- We'll need these | ||
50 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
51 | import qualified Data.Vector as V | ||
52 | import Data.Vector (Vector, (!?)) | ||
53 | |||
54 | import Data.Text (Text) | ||
55 | import qualified Data.Map as M | ||
56 | import Data.Map (Map) | ||
57 | import qualified Data.Set as S | ||
58 | import Data.Set (Set) | ||
59 | |||
60 | import Data.List (groupBy) | ||
61 | import Data.Maybe (listToMaybe, catMaybes) | ||
62 | |||
63 | import Linear (V2(..), V3(..)) | ||
64 | |||
65 | import Control.Lens ((^.), (.~), (%~), (&), _1, _2, _3) | ||
66 | |||
67 | import Cartesian.Core (BoundingBox(..), fromExtents, x, y, z) | ||
68 | |||
69 | import Graphics.WaveFront.Types | ||
70 | import Graphics.WaveFront.Lenses | ||
71 | |||
72 | |||
73 | |||
74 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
75 | -- Functions | ||
76 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
77 | |||
78 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
79 | |||
80 | -- TODO | - Factor out these combinators | ||
81 | |||
82 | -- | Performs a computation on adjacent pairs in a list | ||
83 | -- TODO | - Factor out and make generic | ||
84 | pairwise :: (a -> a -> b) -> [a] -> [b] | ||
85 | pairwise f xs = zipWith f xs (drop 1 xs) | ||
86 | |||
87 | |||
88 | -- | Convers an Either to a Maybe | ||
89 | eitherToMaybe :: Either a b -> Maybe b | ||
90 | eitherToMaybe (Right b) = Just b | ||
91 | eitherToMaybe (Left _) = Nothing | ||
92 | |||
93 | |||
94 | -- | Converts a Maybe to an Either | ||
95 | maybeToEither :: a -> Maybe b -> Either a b | ||
96 | maybeToEither _ (Just b) = Right b | ||
97 | maybeToEither a (Nothing) = Left a | ||
98 | |||
99 | -- Parser output churners (OBJ) ------------------------------------------------------------------------------------------------------------ | ||
100 | |||
101 | -- TODO | - Move to separate module (eg. WaveFront.Model) | ||
102 | |||
103 | -- | Creates a mapping between group names and the corresponding bounds ([lower, upper)). | ||
104 | -- | ||
105 | -- TODO | - Figure out how to deal with multiple group names (eg. "g mesh1 nose head") | ||
106 | -- - Include not just face indices but vertex indices (makes it easier to 'slice' GPU buffers) (maybe in a separate function) | ||
107 | groupsOf :: (Ord s, Integral i) => [OBJToken f s i m] -> Map (Set s) (i, i) | ||
108 | groupsOf = buildIndexMapWith . filter notObject | ||
109 | where | ||
110 | notObject (Object _) = False | ||
111 | notObject _ = True | ||
112 | |||
113 | |||
114 | -- | Creates a mapping between object names and the corresponding bounds ([lower, upper)). | ||
115 | objectsOf :: (Ord s, Integral i) => [OBJToken f s i m] -> Map (Set s) (i, i) | ||
116 | objectsOf = buildIndexMapWith . filter notGroup | ||
117 | where | ||
118 | notGroup (Group _) = False | ||
119 | notGroup _ = True | ||
120 | |||
121 | |||
122 | -- | Creates a mapping between names (of groups or objects) to face indices | ||
123 | -- | ||
124 | -- TODO | - Refactor, simplify | ||
125 | -- - What happens if the same group or object appears multiple times (is that possible?) | ||
126 | -- - Rename or add function parameter (the -With suffix implies a function parameter) | ||
127 | buildIndexMapWith :: (Ord s, Integral i) => [OBJToken f s i m] -> Map (Set s) (i, i) | ||
128 | buildIndexMapWith = M.fromList . pairwise zipIndices . update 0 | ||
129 | where | ||
130 | zipIndices (names, low) (_, upp) = (names, (low, upp)) | ||
131 | |||
132 | -- TODO | - Separate Group and Object lists | ||
133 | -- - Rename (?) | ||
134 | -- - Factor out (might be useful for testing) (?) | ||
135 | update faceCount [] = [(S.empty, faceCount)] | ||
136 | update faceCount (Group names:xs) = (names, faceCount) : update faceCount xs | ||
137 | update faceCount (Object names:xs) = (names, faceCount) : update faceCount xs | ||
138 | update faceCount (OBJFace _:xs) = update (faceCount + 1) xs | ||
139 | update faceCount (_:xs) = update faceCount xs | ||
140 | |||
141 | |||
142 | -- | Filters out faces from a stream of OBJTokens and attaches the currently selected material, | ||
143 | -- as defined by the most recent LibMTL and UseMTL tokens. | ||
144 | facesOf :: forall f s i m. Ord s => MTLTable f s -> [OBJToken f s i m] -> [Either String (Face f s i m)] | ||
145 | facesOf materials' = makeFaces Nothing Nothing | ||
146 | where | ||
147 | -- | It's not always rude to make faces | ||
148 | -- TODO | - Keep refactoring... | ||
149 | -- - Rename (?) | ||
150 | makeFaces :: Maybe s -> Maybe s -> [OBJToken f s i m] -> [Either String (Face f s i m)] | ||
151 | makeFaces _ _ [] = [] | ||
152 | makeFaces lib@(Just libName) mat@(Just matName) (OBJFace is:xs) = createFace materials' libName matName is : makeFaces lib mat xs | ||
153 | |||
154 | makeFaces lib@Nothing mat (OBJFace _:xs) = Left "No library selected for face" : makeFaces lib mat xs | ||
155 | makeFaces lib mat@Nothing (OBJFace _:xs) = Left "No material selected for face" : makeFaces lib mat xs | ||
156 | |||
157 | makeFaces _ mat (LibMTL libName:xs) = makeFaces (Just libName) mat xs | ||
158 | makeFaces lib _ (UseMTL matName:xs) = makeFaces lib (Just matName) xs | ||
159 | |||
160 | makeFaces lib mat (_:xs) = makeFaces lib mat xs | ||
161 | |||
162 | |||
163 | -- | | ||
164 | createFace :: Ord s => MTLTable f s -> s -> s -> m (VertexIndices i) -> Either String (Face f s i m) | ||
165 | createFace materials' libName matName indices' = do | ||
166 | material' <- lookupMaterial materials' libName matName | ||
167 | Right $ Face { fIndices=indices', fMaterial=material' } | ||
168 | |||
169 | |||
170 | -- | Tries to find a given material in the specified MTL table | ||
171 | -- TODO | - Specify missing material or library name (would require additional constraints on 's') | ||
172 | -- - Refactor | ||
173 | lookupMaterial :: Ord s => MTLTable f s -> s -> s -> Either String (Material f s) | ||
174 | lookupMaterial materials' libName matName = do | ||
175 | library <- maybeToEither "No such library" (M.lookup libName materials') | ||
176 | maybeToEither "No such material" (M.lookup matName library) | ||
177 | |||
178 | -- Parser output churners (MTL) ------------------------------------------------------------------------------------------------------------ | ||
179 | |||
180 | -- | Constructs an MTL table from a list of (libraryName, token stream) pairs. | ||
181 | -- TODO | - Refactor, simplify | ||
182 | createMTLTable :: Ord s => [(s, [MTLToken f s])] -> Either String (MTLTable f s) | ||
183 | createMTLTable = fmap M.fromList . mapM (\(name, tokens) -> (name,) <$> materialsOf tokens) | ||
184 | |||
185 | |||
186 | -- | Constructs a map between names and materials. Incomplete material definitions | ||
187 | -- result in an error (Left ...). | ||
188 | -- | ||
189 | -- TODO | - Debug information (eg. attributes without an associated material) | ||
190 | -- - Pass in error function (would allow for more flexible error handling) (?) | ||
191 | -- - Deal with duplicated attributes (probably won't crop up in any real situations) | ||
192 | materialsOf :: Ord s => [MTLToken f s] -> Either String (Map s (Material f s)) | ||
193 | materialsOf = fmap M.fromList . mapM createMaterial . partitionMaterials | ||
194 | |||
195 | |||
196 | -- | Creates a new (name, material) pair from a stream of MTL tokens. | ||
197 | -- The first token should be a new material name. | ||
198 | createMaterial :: [MTLToken f s] -> Either String (s, Material f s) | ||
199 | createMaterial (NewMaterial name:attrs) = (name,) <$> fromAttributes attrs | ||
200 | createMaterial attrs = Left $ "Free-floating attributes" | ||
201 | |||
202 | |||
203 | -- | Breaks a stream of MTL tokens into lists of material definitions | ||
204 | -- TODO | - Rename (eg. groupMaterials) (?) | ||
205 | partitionMaterials :: [MTLToken f s] -> [[MTLToken f s]] | ||
206 | partitionMaterials = groupBy (\_ b -> not $ isNewMaterial b) | ||
207 | where | ||
208 | isNewMaterial (NewMaterial _) = True | ||
209 | isNewMaterial _ = False | ||
210 | |||
211 | |||
212 | -- | Creates a material | ||
213 | fromAttributes :: [MTLToken f s] -> Either String (Material f s) | ||
214 | fromAttributes attrs = case colours' of | ||
215 | Nothing -> Left $ "Missing colour(s)" -- TODO: More elaborate message (eg. which colour) | ||
216 | Just (amb, diff, spec) -> Right $ Material { fAmbient=amb,fDiffuse=diff, fSpecular=spec, fTexture=texture' } | ||
217 | where | ||
218 | colours' = materialColours attrs | ||
219 | texture' = listToMaybe [ name | MapDiffuse name <- attrs ] | ||
220 | |||
221 | |||
222 | -- | Tries to extract a diffuse colour, a specular colour, and an ambient colour from a list of MTL tokens | ||
223 | -- TODO | - Should we really require all three colour types (?) | ||
224 | -- - Rename (?) | ||
225 | materialColours :: [MTLToken f s] -> Maybe (Colour f, Colour f, Colour f) | ||
226 | materialColours attrs = (,,) <$> | ||
227 | listToMaybe [ c | (Diffuse c) <- attrs ] <*> | ||
228 | listToMaybe [ c | (Specular c) <- attrs ] <*> | ||
229 | listToMaybe [ c | (Ambient c) <- attrs ] | ||
230 | |||
231 | -- API functions --------------------------------------------------------------------------------------------------------------------------- | ||
232 | |||
233 | -- | Constructs a model from a stream of OBJ tokens, a materials table and an optional path to root of the model (used for textures, etc.) | ||
234 | -- | ||
235 | -- TODO | - Performance, how are 'copies' of coordinates handled (?) | ||
236 | -- - Performance, one pass (with a fold perhaps) | ||
237 | -- | ||
238 | -- I never knew pattern matching in list comprehensions could be used to filter by constructor | ||
239 | createModel :: (Ord s, Integral i) => OBJ f s i [] -> MTLTable f s -> Maybe FilePath -> Either String (Model f s i Vector) | ||
240 | createModel tokens materials root = do | ||
241 | faces' <- sequence $ facesOf materials tokens | ||
242 | return $ Model { fVertices = V.fromList [ vec | OBJVertex vec <- tokens ], | ||
243 | fNormals = V.fromList [ vec | OBJNormal vec <- tokens ], | ||
244 | fTexcoords = V.fromList [ vec | OBJTexCoord vec <- tokens ], | ||
245 | fFaces = packFaces faces', | ||
246 | fGroups = groupsOf tokens, | ||
247 | fObjects = objectsOf tokens, | ||
248 | fMaterials = materials, | ||
249 | fRoot = root } | ||
250 | where | ||
251 | packFace :: Face f s i [] -> Face f s i Vector | ||
252 | packFace face@Face{fIndices} = face { fIndices=V.fromList fIndices } -- indices %~ (_) -- TODO: Type-changing lenses | ||
253 | |||
254 | packFaces :: [] (Face f s i []) -> Vector (Face f s i Vector) | ||
255 | packFaces = V.fromList . map (packFace . tessellate) | ||
256 | |||
257 | |||
258 | -- | | ||
259 | -- TODO | - Specialise to [[Face]] (?) | ||
260 | -- - Check vertex count (has to be atleast three) | ||
261 | -- - Better names (?) | ||
262 | tessellate :: Face f s i [] -> Face f s i [] | ||
263 | tessellate = indices %~ triangles | ||
264 | where | ||
265 | triangles [] = [] | ||
266 | triangles (a:rest) = concat $ pairwise (\b c -> [a, b, c]) rest | ||
267 | |||
268 | |||
269 | -- | Finds the axis-aligned bounding box of the model | ||
270 | -- TODO | - Deal with empty vertex lists (?) | ||
271 | -- - Refactor | ||
272 | -- - Folding over applicative (fold in parallel) | ||
273 | -- - Make sure the order is right | ||
274 | bounds :: (Num f, Ord f, Foldable m, HasVertices (Model f s i m) (m (V3 f))) => Model f s i m -> BoundingBox (V3 f) | ||
275 | bounds model = fromExtents $ axisBounds (model^.vertices) <$> V3 x y z | ||
276 | where | ||
277 | -- TODO | - Factor out 'minmax' | ||
278 | minmaxBy :: (Ord o, Num o, Foldable m) => (a -> o) -> m a -> (o, o) | ||
279 | minmaxBy f values = foldr (\val' acc -> let val = f val' in (min val (fst acc), max val (snd acc))) (0, 0) values -- TODO: Factor out | ||
280 | |||
281 | axisBounds vs axis = minmaxBy (^.axis) vs | ||
282 | |||
283 | -- Orphaned TODOs? | ||
284 | |||
285 | -- TODO | - Deal with missing values properly | ||
286 | -- - Indexing should be defined in an API function | ||
287 | |||
288 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
289 | |||
290 | -- TODO | - Polymorphic indexing and traversing | ||
291 | -- - Profile, optimise | ||
292 | -- - Index buffers | ||
293 | |||
294 | |||
295 | -- | Takes a vector of data, an index function, a choice function, a vector of some type with indices | ||
296 | -- and uses the indices to constructs a new Vector with the data in the original vector. | ||
297 | -- | ||
298 | -- TODO | - Factor out the buffer-building logic | ||
299 | -- - Rewrite the above docstring... | ||
300 | fromIndices :: Vector v -> (Vector v -> i -> b) -> (a -> i) -> Vector a -> Vector b | ||
301 | fromIndices data' index choose = V.map (index data' . choose) | ||
302 | |||
303 | |||
304 | -- | | ||
305 | fromFaceIndices :: Integral i => Vector (v f) -> (Vector (v f) -> a -> b) -> (VertexIndices i -> a) -> Vector (Face f Text i Vector) -> Vector b | ||
306 | fromFaceIndices data' index choose = V.concatMap (fromIndices data' index (choose) . (^.indices)) | ||
307 | |||
308 | |||
309 | -- | | ||
310 | -- TODO: Factor out per-vertex logic so we don't have to redefine this function entirely for each colour type | ||
311 | diffuseColours :: Vector (Face f s i Vector) -> Vector (Colour f) | ||
312 | diffuseColours faces' = V.concatMap (\f -> V.replicate (V.length $ f^.indices) (f^.material.diffuse)) faces' | ||
313 | |||
314 | -- TODO | - Do not create intermediate vectors (automatic fusion?) | ||
315 | -- - Allow fallback values (or function), or use Either | ||
316 | -- - Add docstrings | ||
317 | |||
318 | -- | | ||
319 | unindexedVertices :: Model f Text Int Vector -> Maybe (Vector (V3 f)) | ||
320 | unindexedVertices model = sequence $ fromFaceIndices (model^.vertices) (index) (^.ivertex) (model^.faces) | ||
321 | where | ||
322 | index coords i = coords !? (i-1) | ||
323 | |||
324 | unindexedNormals :: Model f Text Int Vector -> Maybe (Vector (V3 f)) | ||
325 | unindexedNormals model = sequence $ fromFaceIndices (model^.normals) (index) (^.inormal) (model^.faces) | ||
326 | where | ||
327 | index coords mi = mi >>= \i -> coords !? (i-1) | ||
328 | |||
329 | unindexedTexcoords :: Model f Text Int Vector -> Maybe (Vector (V2 f)) | ||
330 | unindexedTexcoords model = sequence $ fromFaceIndices (model^.texcoords) (index) (^.itexcoord) (model^.faces) | ||
331 | where | ||
332 | index coords mi = mi >>= \i -> coords !? (i-1) | ||
333 | |||
334 | -- Model queries --------------------------------------------------------------------------------------------------------------------------- | ||
335 | |||
336 | -- TODO: Turn into Lenses/Getters/Isos (?) | ||
337 | |||
338 | -- | Does the model have textures? | ||
339 | hasTextures :: Ord s => Model f s i m -> Bool | ||
340 | hasTextures = not . S.null . textures | ||
341 | |||
342 | |||
343 | -- | The set of all texture names | ||
344 | textures :: Ord s => Model f s i m -> S.Set s | ||
345 | textures = S.fromList . catMaybes . map (^.texture) . concatMap M.elems . M.elems . (^.materials) | ||
diff --git a/src/Graphics/WaveFront/Parse.hs b/src/Graphics/WaveFront/Parse.hs new file mode 100644 index 0000000..a98f404 --- /dev/null +++ b/src/Graphics/WaveFront/Parse.hs | |||
@@ -0,0 +1,88 @@ | |||
1 | -- | | ||
2 | -- Module : Graphics.WaveFront.Parse | ||
3 | -- Description : | ||
4 | -- Copyright : (c) Jonatan H Sundqvist, February 8 2015 | ||
5 | -- License : MIT | ||
6 | -- Maintainer : Jonatan H Sundqvist | ||
7 | -- Stability : experimental|stable | ||
8 | -- Portability : POSIX (not sure) | ||
9 | -- | ||
10 | -- Created February 8 2015 | ||
11 | -- Wavefront - Parsers.hs | ||
12 | -- Migrated to separate project on February 21 2015 | ||
13 | |||
14 | -- TODO | - Appropriate container types (eg. bytestring, vector) | ||
15 | -- - Grammar specification | ||
16 | -- - Incremental parsing (?) | ||
17 | -- - Improve naming scheme | ||
18 | -- -- Remove 'parse-' prefix, import qualified (eg. 'Parse.obj') | ||
19 | -- | ||
20 | -- - Separate MTL and OBJ parsers (?) (...) | ||
21 | -- - Separate parsing, processing, logging, IO and testing (...) | ||
22 | -- -- Proper path handling (eg. include root in MTLTable or not) | ||
23 | -- | ||
24 | -- - Additional attributes (lighting, splines, etc.) | ||
25 | -- - FFI (...) | ||
26 | -- - Debugging information (line number, missing file, missing values, etc.) (...) | ||
27 | -- - Proper Haddock coverage, including headers (...) | ||
28 | -- - Model type (✓) | ||
29 | -- - Caching (?) | ||
30 | -- - Performance, profiling, optimisations | ||
31 | -- -- Strict or lazy (eg. with Data.Map) (?) | ||
32 | -- -- Multi-threading | ||
33 | -- -- Appropriate container types | ||
34 | -- | ||
35 | -- - PrintfArg instances for the types defined in this module | ||
36 | -- - Reconciling Cabal and hierarchical modules | ||
37 | -- - Dealing with paths in lib statements (requires knowledge of working directories) | ||
38 | -- - Move comments and specification to separate files (eg. README) | ||
39 | -- - Inline comments (for internals, implementation) | ||
40 | -- | ||
41 | -- - Full OBJ spec compliance | ||
42 | -- -- Do the usemtl and libmtl statements affect vertices or faces (?) | ||
43 | -- | ||
44 | -- - Parser bugs | ||
45 | -- -- Negative coordinates enclosed in parentheses (✓) | ||
46 | -- | ||
47 | -- - Decide on a public interface (exports) (API) | ||
48 | -- -- Model will be the main API type | ||
49 | -- -- Processing utils (eg. iterating over model faces; withModelFaces :: ((Material, [(Vertex, Maybe Normalcoords, Maybe Texcoords)]) -> b) -> Model -> [b]) | ||
50 | -- -- Export functions for working with the output data (eg. unzipIndices :: [(Int, Int, Int)] -> ([Int], [Int], [Int])) | ||
51 | -- -- Export certain utilities (eg. second, perhaps in another module) (?) | ||
52 | |||
53 | -- SPEC | - | ||
54 | -- - | ||
55 | |||
56 | |||
57 | |||
58 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
59 | -- GHC Extensions | ||
60 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
61 | {-# LANGUAGE UnicodeSyntax #-} | ||
62 | {-# LANGUAGE TupleSections #-} | ||
63 | {-# LANGUAGE OverloadedStrings #-} | ||
64 | {-# LANGUAGE NamedFieldPuns #-} | ||
65 | |||
66 | |||
67 | |||
68 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
69 | -- API | ||
70 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
71 | -- TODO | - Clean this up | ||
72 | -- - Decide on API | ||
73 | module Graphics.WaveFront.Parse ( | ||
74 | module Graphics.WaveFront.Types, -- TODO: Don't export internal types (duh) | ||
75 | obj, mtl, | ||
76 | comment, lineSeparator | ||
77 | ) where | ||
78 | |||
79 | |||
80 | |||
81 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
82 | -- We'll need these | ||
83 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
84 | import Graphics.WaveFront.Parse.Common | ||
85 | import Graphics.WaveFront.Parse.OBJ (obj) | ||
86 | import Graphics.WaveFront.Parse.MTL (mtl) | ||
87 | |||
88 | import Graphics.WaveFront.Types \ No newline at end of file | ||
diff --git a/src/Graphics/WaveFront/Parse/Common.hs b/src/Graphics/WaveFront/Parse/Common.hs new file mode 100644 index 0000000..bfeb2d8 --- /dev/null +++ b/src/Graphics/WaveFront/Parse/Common.hs | |||
@@ -0,0 +1,166 @@ | |||
1 | -- | | ||
2 | -- Module : Graphics.WaveFront.Parse.Common | ||
3 | -- Description : | ||
4 | -- Copyright : (c) Jonatan H Sundqvist, October 2 2016 | ||
5 | -- License : MIT | ||
6 | -- Maintainer : Jonatan H Sundqvist | ||
7 | -- Stability : experimental|stable | ||
8 | -- Portability : POSIX (not sure) | ||
9 | |||
10 | -- TODO | - Fully polymorphic (even in the string and list types) (?) | ||
11 | -- - | ||
12 | |||
13 | -- SPEC | - | ||
14 | -- - | ||
15 | |||
16 | |||
17 | |||
18 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
19 | -- GHC Extensions | ||
20 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
21 | {-# LANGUAGE OverloadedStrings #-} | ||
22 | |||
23 | |||
24 | |||
25 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
26 | -- Section | ||
27 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
28 | module Graphics.WaveFront.Parse.Common where | ||
29 | |||
30 | |||
31 | |||
32 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
33 | -- We'll need these | ||
34 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
35 | import Data.Text (Text, pack) | ||
36 | import qualified Data.Attoparsec.Text as Atto | ||
37 | |||
38 | import Control.Applicative (pure, liftA2, (<$>), (<*>), (<*), (*>), (<|>)) | ||
39 | import Linear (V2(..), V3(..)) | ||
40 | |||
41 | import Graphics.WaveFront.Types | ||
42 | |||
43 | |||
44 | |||
45 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
46 | -- Functions (pure) | ||
47 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
48 | |||
49 | -- Jon's little helpers -------------------------------------------------------------------------------------------------------------------- | ||
50 | |||
51 | -- | Consumes all input, including any leading or trailing comments and whitespace | ||
52 | -- TODO | - Rename (?) | ||
53 | wholeFile :: Atto.Parser a -> Atto.Parser a | ||
54 | wholeFile p = cutToTheChase *> p <* cutToTheChase <* Atto.endOfInput | ||
55 | |||
56 | |||
57 | -- | Skips any leading comments, line breaks and empty lines | ||
58 | -- TODO | - Rename (?) | ||
59 | -- - Skip whitespace | ||
60 | cutToTheChase :: Atto.Parser () | ||
61 | cutToTheChase = Atto.skipMany ((comment *> pure ()) <|> (Atto.satisfy isLinearSpace *> pure ()) <|> Atto.endOfLine) | ||
62 | |||
63 | |||
64 | -- | OBJ rows may be separated by one or more lines of comments and whitespace, or empty lines. | ||
65 | -- TODO | - Make sure this is right | ||
66 | lineSeparator :: Atto.Parser () | ||
67 | lineSeparator = Atto.skipMany1 $ ignore space *> ignore comment *> Atto.endOfLine | ||
68 | |||
69 | |||
70 | -- | Parses a comment (from the '#' to end of the line), possibly preceded by whitespace | ||
71 | -- TODO | - Break out the whitespace part (?) | ||
72 | comment :: Atto.Parser Text | ||
73 | comment = Atto.skipSpace *> Atto.char '#' *> Atto.takeTill (\c -> (c == '\r') || (c == '\n')) -- TODO: Is the newline consumed (?) | ||
74 | |||
75 | |||
76 | -- | Tries the given parser, falls back to 'Nothing' if it fails | ||
77 | -- TODO | - Use 'try' to enforce backtracking (?) | ||
78 | optional :: Atto.Parser a -> Atto.Parser (Maybe a) | ||
79 | optional p = Atto.option Nothing (Just <$> p) | ||
80 | |||
81 | |||
82 | -- | Like Atto.skipMany, except it skips one match at the most | ||
83 | ignore :: Atto.Parser a -> Atto.Parser () | ||
84 | ignore p = optional p *> pure () | ||
85 | |||
86 | |||
87 | -- | | ||
88 | atleast :: Int -> Atto.Parser a -> Atto.Parser [a] | ||
89 | atleast n p = liftA2 (++) (Atto.count n p) (Atto.many' p) | ||
90 | |||
91 | |||
92 | -- | Skips atleast one white space character (not including newlines and carriage returns) | ||
93 | space :: Atto.Parser () | ||
94 | space = Atto.skipMany1 (Atto.satisfy isLinearSpace) | ||
95 | |||
96 | |||
97 | -- | Predicate for linear space (eg. whitespace besides newlines) | ||
98 | -- TODO | - Unicode awareness (cf. Data.Char.isSpace) | ||
99 | -- - Come up with a better name (?) | ||
100 | isLinearSpace :: Char -> Bool | ||
101 | isLinearSpace c = (c == ' ') || (c == '\t') | ||
102 | |||
103 | |||
104 | -- | One or more letters (cf. 'Atto.letter' for details) | ||
105 | word :: Atto.Parser Text | ||
106 | word = pack <$> Atto.many1 Atto.letter | ||
107 | |||
108 | |||
109 | -- | Used for texture, material, object and group names (and maybe others that I have yet to think of) | ||
110 | -- TODO | - Use Unicode groups, make more robust (?) | ||
111 | name :: Atto.Parser Text | ||
112 | name = pack <$> Atto.many1 (Atto.satisfy $ \c -> (c /= ' ') && (c /= '\t') && (c /= '\r') && (c /= '\n')) | ||
113 | |||
114 | |||
115 | -- | Parses the strings "off" (False) and "on" (True) | ||
116 | toggle :: Atto.Parser Bool | ||
117 | toggle = (Atto.string "off" *> pure False) <|> (Atto.string "on" *> pure True) | ||
118 | |||
119 | |||
120 | -- | Wraps a parser in a '(' and a ')', with no whitespace in between | ||
121 | parenthesised :: Atto.Parser a -> Atto.Parser a | ||
122 | parenthesised p = Atto.char '(' *> p <* Atto.char ')' | ||
123 | |||
124 | |||
125 | -- TODO | - Allow scientific notation (?) | ||
126 | |||
127 | -- | | ||
128 | coord :: Fractional f => Atto.Parser f | ||
129 | coord = space *> (parenthesised Atto.rational <|> Atto.rational) | ||
130 | |||
131 | |||
132 | -- | A single colour channel | ||
133 | -- TODO | - Clamp to [0,1] (cf. partial from monadplus) (?) | ||
134 | -- - Can channels be parenthesised (?) | ||
135 | channel :: Fractional f => Atto.Parser f | ||
136 | channel = space *> (parenthesised Atto.rational <|> Atto.rational) | ||
137 | |||
138 | |||
139 | -- | A colour with three or four channels (RGB[A]) | ||
140 | colour :: Fractional f => Atto.Parser (Colour f) | ||
141 | colour = Colour <$> channel <*> channel <*> channel <*> Atto.option 1 channel | ||
142 | |||
143 | |||
144 | -- | A point in 3D space | ||
145 | point3D :: Fractional f => Atto.Parser (V3 f) | ||
146 | point3D = V3 <$> coord <*> coord <*> coord | ||
147 | |||
148 | |||
149 | -- | A point in 2D space | ||
150 | point2D :: Fractional f => Atto.Parser (V2 f) | ||
151 | point2D = V2 <$> coord <*> coord | ||
152 | |||
153 | |||
154 | -- | | ||
155 | clamp :: Ord n => n -> n -> n -> Atto.Parser n | ||
156 | clamp lower upper n | ||
157 | | between lower upper n = pure n | ||
158 | | otherwise = fail "Number not in range" | ||
159 | where | ||
160 | between lw up n = (lower <= n) && (n <= upper) | ||
161 | -- between 0 <. n <. 5 | ||
162 | |||
163 | -- | | ||
164 | -- TODO | - Clean up and generalise | ||
165 | clamped :: Integral i => i -> i -> Atto.Parser i | ||
166 | clamped lower upper = Atto.decimal >>= clamp lower upper \ No newline at end of file | ||
diff --git a/src/Graphics/WaveFront/Parse/MTL.hs b/src/Graphics/WaveFront/Parse/MTL.hs new file mode 100644 index 0000000..060952f --- /dev/null +++ b/src/Graphics/WaveFront/Parse/MTL.hs | |||
@@ -0,0 +1,142 @@ | |||
1 | -- | | ||
2 | -- Module : Graphics.WaveFront.Parse.MTL | ||
3 | -- Description : | ||
4 | -- Copyright : (c) Jonatan H Sundqvist, October 2 2016 | ||
5 | -- License : MIT | ||
6 | -- Maintainer : Jonatan H Sundqvist | ||
7 | -- Stability : experimental|stable | ||
8 | -- Portability : POSIX (not sure) | ||
9 | |||
10 | -- TODO | - | ||
11 | -- - | ||
12 | |||
13 | -- SPEC | - | ||
14 | -- - | ||
15 | |||
16 | |||
17 | |||
18 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
19 | -- GHC Extensions | ||
20 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
21 | {-# LANGUAGE UnicodeSyntax #-} | ||
22 | {-# LANGUAGE TupleSections #-} | ||
23 | {-# LANGUAGE OverloadedStrings #-} | ||
24 | {-# LANGUAGE NamedFieldPuns #-} | ||
25 | |||
26 | |||
27 | |||
28 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
29 | -- API | ||
30 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
31 | module Graphics.WaveFront.Parse.MTL ( | ||
32 | mtl, row, token, | ||
33 | ambient, diffuse, specular, | ||
34 | mapDiffuse, newMaterial | ||
35 | ) where | ||
36 | |||
37 | |||
38 | |||
39 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
40 | -- We'll need these | ||
41 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
42 | -- import qualified Data.Map as M | ||
43 | -- import qualified Data.Set as S | ||
44 | -- import qualified Data.Vector as V | ||
45 | import Data.Text (Text) | ||
46 | |||
47 | import qualified Data.Attoparsec.Text as Atto | ||
48 | |||
49 | import Control.Applicative ((<$>), (<*), (*>), (<|>)) | ||
50 | |||
51 | import Graphics.WaveFront.Parse.Common | ||
52 | |||
53 | import Graphics.WaveFront.Types hiding (ambient, diffuse, specular) | ||
54 | |||
55 | |||
56 | |||
57 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
58 | -- Functions | ||
59 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
60 | |||
61 | -- MTL parsing ----------------------------------------------------------------------------------------------------------------------------- | ||
62 | |||
63 | -- | Produces a list of MTL tokens | ||
64 | mtl :: (Fractional f) => Atto.Parser (MTL f Text []) | ||
65 | mtl = Atto.sepBy row lineSeparator | ||
66 | |||
67 | |||
68 | -- | Parses a single MTL row. | ||
69 | row :: (Fractional f) => Atto.Parser (MTLToken f Text) | ||
70 | row = token <* ignore comment | ||
71 | |||
72 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
73 | |||
74 | -- | Parse an MTL token | ||
75 | -- TODO: How to deal with common prefix (Ka, Kd, Ks) (backtrack?) | ||
76 | token :: (Fractional f) => Atto.Parser (MTLToken f Text) | ||
77 | token = (Atto.string "Ka" *> ambient) <|> | ||
78 | (Atto.string "Kd" *> diffuse) <|> | ||
79 | (Atto.string "Ks" *> specular) <|> | ||
80 | (Atto.string "Ns" *> specExp) <|> | ||
81 | (Atto.string "illum" *> illum) <|> | ||
82 | (Atto.string "Ni" *> refraction) <|> | ||
83 | (Atto.string "d" *> dissolve) <|> -- TODO: Handle inverse as well (cf. 'Tr' attribute) | ||
84 | (Atto.string "map_Kd" *> mapDiffuse) <|> | ||
85 | (Atto.string "map_Ka" *> mapAmbient) <|> | ||
86 | (Atto.string "newmtl" *> newMaterial) | ||
87 | |||
88 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
89 | |||
90 | -- TODO: Expose these parsers for testing purposes (?) | ||
91 | |||
92 | -- TODO | - Change definition of 'colour' and 'Colour' to only allow three channels (alpha is handled by the 'dissolve' attribute) | ||
93 | -- - Change the definition of 'Colour' or use the one defined in the colour package | ||
94 | |||
95 | -- | Three or four channel values (RGB[A]) | ||
96 | ambient :: (Fractional f) => Atto.Parser (MTLToken f s) | ||
97 | ambient = Ambient <$> colour | ||
98 | |||
99 | |||
100 | -- | Three or four channel values (RGB[A]) | ||
101 | diffuse :: (Fractional f) => Atto.Parser (MTLToken f s) | ||
102 | diffuse = Diffuse <$> colour | ||
103 | |||
104 | |||
105 | -- | Three or four channel values (RGB[A]) | ||
106 | specular :: (Fractional f) => Atto.Parser (MTLToken f s) | ||
107 | specular = Specular <$> colour | ||
108 | |||
109 | |||
110 | -- | A rational number, preceded by whitespace (specular exponent) | ||
111 | specExp :: (Fractional f) => Atto.Parser (MTLToken f s) | ||
112 | specExp = space *> (SpecularExponent <$> Atto.rational) | ||
113 | |||
114 | |||
115 | -- | A number between 0 and 10 (inclusive) (illumination model) | ||
116 | illum :: Atto.Parser (MTLToken f s) | ||
117 | illum = space *> (Illum <$> clamped 0 10) | ||
118 | |||
119 | |||
120 | -- | A rational number, preceded by whitespace (refraction index) | ||
121 | refraction :: (Fractional f) => Atto.Parser (MTLToken f s) | ||
122 | refraction = space *> (Refraction <$> Atto.rational) | ||
123 | |||
124 | |||
125 | -- | A rational number, preceded by whitespace (doss) | ||
126 | dissolve :: (Fractional f) => Atto.Parser (MTLToken f s) | ||
127 | dissolve = space *> (Dissolve <$> Atto.rational) | ||
128 | |||
129 | |||
130 | -- | A texture name, preceded by whitespace | ||
131 | mapDiffuse :: Atto.Parser (MTLToken f Text) | ||
132 | mapDiffuse = space *> (MapDiffuse <$> name) | ||
133 | |||
134 | |||
135 | -- | A texture name, preceded by whitespace | ||
136 | mapAmbient :: Atto.Parser (MTLToken f Text) | ||
137 | mapAmbient = space *> (MapAmbient <$> name) | ||
138 | |||
139 | |||
140 | -- | A material name, preceded by whitespace | ||
141 | newMaterial :: Atto.Parser (MTLToken f Text) | ||
142 | newMaterial = space *> (NewMaterial <$> name) \ No newline at end of file | ||
diff --git a/src/Graphics/WaveFront/Parse/OBJ.hs b/src/Graphics/WaveFront/Parse/OBJ.hs new file mode 100644 index 0000000..37aa5a0 --- /dev/null +++ b/src/Graphics/WaveFront/Parse/OBJ.hs | |||
@@ -0,0 +1,173 @@ | |||
1 | -- | | ||
2 | -- Module : Graphics.WaveFront.Parse.OBJ | ||
3 | -- Description : | ||
4 | -- Copyright : (c) Jonatan H Sundqvist, October 2 2016 | ||
5 | -- License : MIT | ||
6 | -- Maintainer : Jonatan H Sundqvist | ||
7 | -- Stability : experimental|stable | ||
8 | -- Portability : POSIX (not sure) | ||
9 | |||
10 | -- TODO | - Fully polymorphic (even in the string and list types) (?) | ||
11 | -- - | ||
12 | |||
13 | -- SPEC | - | ||
14 | -- - | ||
15 | |||
16 | |||
17 | |||
18 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
19 | -- GHC Extensions | ||
20 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
21 | {-# LANGUAGE UnicodeSyntax #-} | ||
22 | {-# LANGUAGE TupleSections #-} | ||
23 | {-# LANGUAGE OverloadedStrings #-} | ||
24 | {-# LANGUAGE NamedFieldPuns #-} | ||
25 | |||
26 | |||
27 | |||
28 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
29 | -- API | ||
30 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
31 | module Graphics.WaveFront.Parse.OBJ ( | ||
32 | obj, row, face, | ||
33 | normal, texcoord, vertex, object, group, | ||
34 | lib, use, | ||
35 | vertexIndices, | ||
36 | ) where | ||
37 | |||
38 | |||
39 | |||
40 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
41 | -- We'll need these | ||
42 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
43 | import Data.Text (Text) | ||
44 | -- import qualified Data.Vector as V | ||
45 | import qualified Data.Set as S | ||
46 | |||
47 | import qualified Data.Attoparsec.Text as Atto | ||
48 | |||
49 | import Control.Applicative ((<$>), (<*>), (<*), (*>), (<|>)) | ||
50 | |||
51 | -- import Linear (V2(..), V3(..)) | ||
52 | |||
53 | import Graphics.WaveFront.Parse.Common | ||
54 | import Graphics.WaveFront.Types hiding (texture) | ||
55 | |||
56 | |||
57 | |||
58 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
59 | -- Functions | ||
60 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
61 | |||
62 | -- OBJ parsing ----------------------------------------------------------------------------------------------------------------------------- | ||
63 | |||
64 | -- | This function creates an OBJToken or error for each line in the input data | ||
65 | obj :: (Fractional f, Integral i) => Atto.Parser (OBJ f Text i []) | ||
66 | obj = Atto.sepBy row lineSeparator -- <* Atto.endOfInput | ||
67 | |||
68 | |||
69 | -- | Parses a token given a single valid OBJ row | ||
70 | -- | ||
71 | -- TODO | - Correctness (total function, no runtime exceptions) | ||
72 | -- - Handle invalid rows (how to deal with mangled definitions w.r.t indices?) | ||
73 | -- - Use ListLike or Monoid (or maybe Indexable, since that's the real requirement) (?) | ||
74 | row :: (Fractional f, Integral i) => Atto.Parser (OBJToken f Text i []) | ||
75 | row = token <* ignore comment -- TODO: Let the separator handle comments (?) | ||
76 | |||
77 | |||
78 | -- | | ||
79 | -- Parses an OBJ token | ||
80 | token :: (Fractional f, Integral i) => Atto.Parser (OBJToken f Text i []) | ||
81 | token = (Atto.string "f" *> face) <|> | ||
82 | (Atto.string "l" *> line) <|> | ||
83 | -- TODO: How to deal with common prefix (v, vn, vt) (backtrack?) (doesn't seem to be a problem) | ||
84 | (Atto.string "vn" *> normal) <|> | ||
85 | (Atto.string "vt" *> texcoord) <|> | ||
86 | (Atto.string "v" *> vertex) <|> | ||
87 | (Atto.string "o" *> object) <|> | ||
88 | (Atto.string "g" *> group) <|> | ||
89 | (Atto.string "s" *> smooth) <|> | ||
90 | (Atto.string "mtllib" *> lib) <|> | ||
91 | (Atto.string "usemtl" *> use) | ||
92 | |||
93 | |||
94 | -- TODO: Expose these parsers for testing purposes (?) | ||
95 | |||
96 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
97 | |||
98 | -- | Three or more vertex definitions (cf. 'vertexIndices' for details) | ||
99 | face :: Integral i => Atto.Parser (OBJToken f Text i []) | ||
100 | face = OBJFace <$> vertexIndices | ||
101 | |||
102 | |||
103 | -- | A single vertex definition with indices for vertex position, normal, and texture coordinates | ||
104 | -- | ||
105 | -- TODO: | - Should the slashes be optional? | ||
106 | -- - Allowed trailing slashes (I'll have to check the spec again) (?) | ||
107 | -- | ||
108 | -- f Int[/((Int[/Int])|(/Int))] | ||
109 | vertexIndices :: Integral i => Atto.Parser [VertexIndices i] | ||
110 | vertexIndices = atleast 3 (space *> (ivertex <*> index <*> index)) <|> -- vi/ti/ni | ||
111 | atleast 3 (space *> (ivertex <*> nothing <*> skipIndex)) <|> -- vi//ni | ||
112 | atleast 3 (space *> (ivertex <*> index <*> nothing)) <|> -- vi/ti | ||
113 | atleast 3 (space *> (ivertex <*> nothing <*> nothing)) -- vi | ||
114 | where | ||
115 | ivertex :: Integral i => Atto.Parser (Maybe i -> Maybe i -> VertexIndices i) | ||
116 | ivertex = VertexIndices <$> Atto.decimal | ||
117 | |||
118 | index :: Integral i => Atto.Parser (Maybe i) | ||
119 | index = Just <$> (Atto.char '/' *> Atto.decimal) | ||
120 | |||
121 | skipIndex :: Integral i => Atto.Parser (Maybe i) | ||
122 | skipIndex = Atto.char '/' *> index | ||
123 | |||
124 | nothing :: Atto.Parser (Maybe i) | ||
125 | nothing = pure Nothing | ||
126 | |||
127 | -- Geometry primitives --------------------------------------------------------------------------------------------------------------------- | ||
128 | |||
129 | -- | Two integers, separated by whitespace | ||
130 | line :: Integral i => Atto.Parser (OBJToken f Text i m) | ||
131 | line = Line <$> (space *> Atto.decimal) <*> (space *> Atto.decimal) | ||
132 | |||
133 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
134 | |||
135 | -- | Three cordinates, separated by whitespace | ||
136 | normal :: (Fractional f) => Atto.Parser (OBJToken f Text i m) | ||
137 | normal = OBJNormal <$> point3D | ||
138 | |||
139 | |||
140 | -- | Two coordinates, separated by whitespace | ||
141 | texcoord :: (Fractional f) => Atto.Parser (OBJToken f Text i m) | ||
142 | texcoord = OBJTexCoord <$> point2D | ||
143 | |||
144 | |||
145 | -- | Three coordinates, separated by whitespace | ||
146 | vertex :: (Fractional f) => Atto.Parser (OBJToken f s i m) | ||
147 | vertex = OBJVertex <$> point3D | ||
148 | |||
149 | |||
150 | -- | Object names, separated by whitespace | ||
151 | object :: Atto.Parser (OBJToken f Text i m) | ||
152 | object = Object . S.fromList <$> atleast 1 (space *> name) | ||
153 | |||
154 | |||
155 | -- | Group names, separated by whitespace | ||
156 | group :: Atto.Parser (OBJToken f Text i m) | ||
157 | group = Group . S.fromList <$> atleast 1 (space *> name) | ||
158 | |||
159 | |||
160 | -- | Smoothing group | ||
161 | -- TODO: Refactor | ||
162 | smooth :: Atto.Parser (OBJToken f Text i m) | ||
163 | smooth = SmoothGroup <$> (((Atto.string "off" <|> Atto.string "0") *> pure Nothing) <|> (space *> (Just <$> name))) | ||
164 | |||
165 | |||
166 | -- | An MTL library name | ||
167 | lib :: Atto.Parser (OBJToken f Text i m) | ||
168 | lib = LibMTL <$> (space *> name) | ||
169 | |||
170 | |||
171 | -- | An MTL material name | ||
172 | use :: Atto.Parser (OBJToken f Text i m) | ||
173 | use = UseMTL <$> (space *> name) \ No newline at end of file | ||
diff --git a/src/Graphics/WaveFront/Types.hs b/src/Graphics/WaveFront/Types.hs new file mode 100644 index 0000000..ccd1425 --- /dev/null +++ b/src/Graphics/WaveFront/Types.hs | |||
@@ -0,0 +1,254 @@ | |||
1 | -- | | ||
2 | -- Module : Graphics.WaveFront.Types | ||
3 | -- Description : | ||
4 | -- Copyright : (c) Jonatan H Sundqvist, 2015 | ||
5 | -- License : MIT | ||
6 | -- Maintainer : Jonatan H Sundqvist | ||
7 | -- Stability : experimental|stable | ||
8 | -- Portability : POSIX (not sure) | ||
9 | -- | ||
10 | |||
11 | -- Created October 30 2015 | ||
12 | |||
13 | -- TODO | - | ||
14 | -- - | ||
15 | |||
16 | -- SPEC | - | ||
17 | -- - | ||
18 | |||
19 | |||
20 | |||
21 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
22 | -- GHC Pragmas | ||
23 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
24 | {-# LANGUAGE DuplicateRecordFields #-} -- I love GHC 8.0 | ||
25 | {-# LANGUAGE FlexibleContexts #-} | ||
26 | {-# LANGUAGE StandaloneDeriving #-} | ||
27 | {-# LANGUAGE DeriveFunctor #-} | ||
28 | {-# LANGUAGE UndecidableInstances #-} | ||
29 | {-# LANGUAGE DeriveFoldable #-} | ||
30 | |||
31 | |||
32 | |||
33 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
34 | -- API | ||
35 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
36 | module Graphics.WaveFront.Types where | ||
37 | |||
38 | |||
39 | |||
40 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
41 | -- We'll need these | ||
42 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
43 | import Data.Functor.Classes (Show1) --Eq1, Show1, showsPrec1, eq1) | ||
44 | import Data.Map as M (Map) | ||
45 | import Data.Set as S (Set) | ||
46 | import Linear (V2(..), V3(..)) | ||
47 | |||
48 | |||
49 | |||
50 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
51 | -- Types | ||
52 | -------------------------------------------------------------------------------------------------------------------------------------------- | ||
53 | |||
54 | -- OBJ parser types ------------------------------------------------------------------------------------------------------------------------ | ||
55 | |||
56 | -- TODO | - Add strictness annotations (?) | ||
57 | |||
58 | |||
59 | -- | Represents a single (valid) OBJ token | ||
60 | -- | ||
61 | -- TODO | - Polymorphic numerical types (?) | ||
62 | -- - Add context, metadata (eg. line numbers, filename) (?) | ||
63 | -- - Naming scheme (added OBJ prefix to prevent name clashes; cf. Face type) | ||
64 | -- - Comment token (preserve comments in parser output or remove them) (?) | ||
65 | -- | ||
66 | -- - Cover the entire spec (http://www.martinreddy.net/gfx/3d/OBJ.spec) | ||
67 | -- (and handle unimplemented attributes gracefully) | ||
68 | data OBJToken f s i m = OBJVertex (V3 f) | | ||
69 | OBJNormal (V3 f) | | ||
70 | OBJTexCoord (V2 f) | | ||
71 | OBJFace (m (VertexIndices i)) | -- TODO: Associate material with each face, handle absent indices | ||
72 | |||
73 | Line i i | -- Line (I'm assuming the arguments are indices to the endpoint vertices) | ||
74 | |||
75 | UseMTL s | -- TODO: Rename (eg. 'UseMaterial') (?) | ||
76 | LibMTL s | -- | ||
77 | |||
78 | SmoothGroup (Maybe s) | -- Smooth shading group, or Nothing if it is disabled | ||
79 | |||
80 | |||
81 | -- TODO: Use OBJ prefix (?) | ||
82 | Group (Set s) | -- TODO: Do grouped faces have to be consecutive? | ||
83 | Object (Set s) -- TODO: What is the difference between group and object? | ||
84 | -- deriving (Show, Eq) -- TODO: Derive Read (?) | ||
85 | |||
86 | |||
87 | -- | | ||
88 | -- TODO: Rename (?) | ||
89 | -- TODO: Use union instead of Maybe (?) | ||
90 | data VertexIndices i = VertexIndices { | ||
91 | fIvertex :: i, | ||
92 | fItexcoord :: Maybe i, | ||
93 | fInormal :: Maybe i | ||
94 | } deriving (Show, Eq) | ||
95 | |||
96 | |||
97 | -- | Output type of the OBJ parser. | ||
98 | -- | ||
99 | -- TODO | - Rename (?) | ||
100 | -- - Use Integral for line number (?) | ||
101 | -- | ||
102 | type OBJ f s i m = m (OBJToken f s i m) | ||
103 | |||
104 | -- MTL parser types ------------------------------------------------------------------------------------------------------------------------ | ||
105 | |||
106 | -- | Represents a single (valid) MTL token | ||
107 | -- | ||
108 | -- TODO | - Is the alpha channel optional, ignored, disallowed? | ||
109 | -- - Include support for ('Ns', 'Ni', 'd', 'Tr', 'illum') | ||
110 | -- - Assume no colours have an alpha channel, since transparency is handled by the 'd' attribute (?) | ||
111 | data MTLToken f s = Ambient (Colour f) | -- Ka | ||
112 | Diffuse (Colour f) | -- Kd | ||
113 | Specular (Colour f) | -- Ks | ||
114 | |||
115 | SpecularExponent f | -- Ns (TODO: Find out exactly what this entails) | ||
116 | |||
117 | Illum Illumination | -- illum (TODO: Find out what this means) | ||
118 | |||
119 | Dissolve f | -- d (Dissolve; transparency) | ||
120 | Refraction f | -- Ni (Index of refraction; optical_density) | ||
121 | |||
122 | MapDiffuse s | -- map_Kd | ||
123 | MapAmbient s | -- map_Ka | ||
124 | NewMaterial s -- newmtl | ||
125 | deriving (Show, Eq) | ||
126 | |||
127 | |||
128 | -- | | ||
129 | -- 0. Color on and Ambient off | ||
130 | -- 1. Color on and Ambient on | ||
131 | -- 2. Highlight on | ||
132 | -- 3. Reflection on and Ray trace on | ||
133 | -- 4. Transparency: Glass on, Reflection: Ray trace on | ||
134 | -- 5. Reflection: Fresnel on and Ray trace on | ||
135 | -- 6. Transparency: Refraction on, Reflection: Fresnel off and Ray trace on | ||
136 | -- 7. Transparency: Refraction on, Reflection: Fresnel on and Ray trace on | ||
137 | -- 8. Reflection on and Ray trace off | ||
138 | -- 9. Transparency: Glass on, Reflection: Ray trace off | ||
139 | -- 10. Casts shadows onto invisible surfaces | ||
140 | type Illumination = Int | ||
141 | |||
142 | |||
143 | -- | Output type of the MTL parser. Currently a list of line number and token (or error string) pairs | ||
144 | -- TODO | - Add type for processed MTL (eg. a map between names and materials) | ||
145 | type MTL f s m = m (MTLToken f s) -- (line number, MTL token, comment) | ||
146 | |||
147 | |||
148 | -- | | ||
149 | type MTLTable f s = Map s (Map s (Material f s)) | ||
150 | |||
151 | -- Model ----------------------------------------------------------------------------------------------------------------------------------- | ||
152 | |||
153 | type Vertices f m = m (V3 f) | ||
154 | type TexCoords f m = m (Maybe (V2 f)) | ||
155 | type Normals f m = m (Maybe (V3 f)) | ||
156 | type Materials f s m = m (Material f s) | ||
157 | |||
158 | -- API types ------------------------------------------------------------------------------------------------------------------------------- | ||
159 | |||
160 | -- | | ||
161 | -- TODO | - Validation (eg. length ivertices == length == ivertices == length itextures if length isn't 0) | ||
162 | -- - Pack indices in a tuple (eg. indices :: [(Int, Int, Int)]) (?) | ||
163 | -- - Use (String, String) for the names of the mtl file and material instead of Material (?) | ||
164 | -- - Use types so as not to confuse the indices (eg. newtype INormal, newtype ITexcoord) | ||
165 | data Face f s i m = Face { | ||
166 | fIndices :: m (VertexIndices i), | ||
167 | fMaterial :: Material f s | ||
168 | } --deriving (Show, Eq) | ||
169 | |||
170 | |||
171 | -- | | ||
172 | -- TODO | - Use a type from the colour package instead (?) | ||
173 | data Colour f = Colour { | ||
174 | fRed :: f, | ||
175 | fGreen :: f, | ||
176 | fBlue :: f, | ||
177 | fAlpha :: f | ||
178 | } deriving (Show, Eq, Functor, Foldable) | ||
179 | |||
180 | |||
181 | -- | | ||
182 | -- TODO | - Do all materials have an ambient, a diffuse and a specular colour (?) | ||
183 | -- - Support more attributes (entire spec) (?) | ||
184 | -- - Lenses (?) | ||
185 | data Material f s = Material { | ||
186 | fAmbient :: Colour f, | ||
187 | fDiffuse :: Colour f, | ||
188 | fSpecular :: Colour f, | ||
189 | fTexture :: Maybe s | ||
190 | } deriving (Show, Eq) | ||
191 | |||
192 | |||
193 | -- | Abstract representation of an OBJ model with associated MTL definitions. | ||
194 | -- | ||
195 | -- TODO | - Rename (?) | ||
196 | -- - Include metadata, comments, rejected data (?) | ||
197 | -- - Separate type for processed OBJTokens (ie. token + context) | ||
198 | -- - Perform index lookups (?) | ||
199 | -- - Reconsider the types (especially of the materials) | ||
200 | -- - Rename accessor functions (eg. texcoords instead of textures) (?) | ||
201 | -- | ||
202 | -- fTextures :: Set s, | ||
203 | -- data Model f s i m = Model { | ||
204 | data Model f s i m = Model { | ||
205 | fVertices :: m (V3 f), | ||
206 | fNormals :: m (V3 f), | ||
207 | fTexcoords :: m (V2 f), | ||
208 | fFaces :: m (Face f s i m), | ||
209 | fMaterials :: MTLTable f s, -- TODO: Type synonym (?) | ||
210 | fGroups :: Map (Set s) (i, i), -- TODO: Type synonym | ||
211 | fObjects :: Map (Set s) (i, i), -- TODO: Type synonym | ||
212 | fRoot :: Maybe FilePath -- This is where we should look for related assets | ||
213 | } -- deriving (Show, Eq) | ||
214 | |||
215 | -- Monomorphic defaults -------------------------------------------------------------------------------------------------------------------- | ||
216 | |||
217 | |||
218 | -- Instances ------------------------------------------------------------------------------------------------------------------------------- | ||
219 | |||
220 | -- TODO: Use Show1, Eq1, etc. (?) | ||
221 | -- deriving instance (Show1 m) => Show1 (m a) | ||
222 | -- deriving instance (Show1 m) => Show1 (m a) | ||
223 | -- deriving instance (Show1 m) => Show1 (m a) | ||
224 | |||
225 | -- TODO: Clean this up | ||
226 | |||
227 | -- showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS | ||
228 | deriving instance (Show1 m, | ||
229 | Show (m f), | ||
230 | Show (m (V2 f)), | ||
231 | Show (m (V3 f)), | ||
232 | Show (m (Face f s i m)), | ||
233 | Show (m s), | ||
234 | Show f, | ||
235 | Show s, | ||
236 | Show i) => Show (Model f s i m) -- where showsPrec = showsPrec1 | ||
237 | |||
238 | deriving instance (Show1 m, | ||
239 | Show (m f), | ||
240 | Show (m (VertexIndices i)), | ||
241 | Show (m (V3 f)), | ||
242 | Show (m s), | ||
243 | Show f, | ||
244 | Show s, | ||
245 | Show i) => Show (Face f s i m) -- where showsPrec = _ | ||
246 | |||
247 | deriving instance (Show1 m, | ||
248 | Show (m f), | ||
249 | Show (m (VertexIndices i)), | ||
250 | Show (m (V3 f)), | ||
251 | Show (m s), | ||
252 | Show f, | ||
253 | Show s, | ||
254 | Show i) => Show (OBJToken f s i m) -- where showsPrec = _ \ No newline at end of file | ||