1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
|
-- Copyright (c) 2000 Galois Connections, Inc.
-- All rights reserved. This software is distributed as
-- free software under the license in the file "LICENSE",
-- which is included in the distribution.
module Construct
( Surface (..)
, Face (..)
, CSG (..)
, Texture
, Transform
, union, intersect, difference
, plane, sphere, cube, cylinder, cone
, transform
, translate, translateX, translateY, translateZ
, scale, scaleX, scaleY, scaleZ, uscale
, rotateX, rotateY, rotateZ
, eye, translateEye
, rotateEyeX, rotateEyeY, rotateEyeZ
) where
import Geometry
-- In each case, we model the surface by a point and a pair of tangent vectors.
-- This gives us enough information to determine the surface
-- normal at that point, which is all that is required by the current
-- illumination model. We can't just save the surface normal because
-- that isn't preserved by transformations.
data Surface
= Planar Point Vector Vector
| Spherical Point Vector Vector
| Cylindrical Point Vector Vector
| Conic Point Vector Vector
deriving Show
data Face
= PlaneFace
| SphereFace
| CubeFront
| CubeBack
| CubeLeft
| CubeRight
| CubeTop
| CubeBottom
| CylinderSide
| CylinderTop
| CylinderBottom
| ConeSide
| ConeBase
deriving Show
data CSG a
= Plane a
| Sphere a
| Cylinder a
| Cube a
| Cone a
| Transform Matrix Matrix (CSG a)
| Union (CSG a) (CSG a)
| Intersect (CSG a) (CSG a)
| Difference (CSG a) (CSG a)
| Box Box (CSG a)
deriving (Show)
-- the data returned for determining surface texture
-- the Face tells which face of a primitive this is
-- the Point is the point of intersection in object coordinates
-- the a is application-specific texture information
type Texture a = (Face, Point, a)
union, intersect, difference :: CSG a -> CSG a -> CSG a
union p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Union p q)
union p q = Union p q
-- rather pessimistic
intersect p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Intersect p q)
intersect p q = Intersect p q
difference (Box b1 p) q = Box b1 (Difference p q)
-- no need to box again inside
-- difference p@(Box b1 _) q = Box b1 (Difference p q)
difference p q = Difference p q
mkBox b p = Box b p
plane, sphere, cube, cylinder, cone :: a -> CSG a
plane = Plane
sphere s =
mkBox (B (-1 - epsilon) (1 + epsilon)
(-1 - epsilon) (1 + epsilon)
(-1 - epsilon) (1 + epsilon)) (Sphere s)
cone s =
mkBox (B (-1 - epsilon) (1 + epsilon)
( - epsilon) (1 + epsilon)
(-1 - epsilon) (1 + epsilon)) (Cone s)
cube s =
mkBox (B (- epsilon) (1 + epsilon)
(- epsilon) (1 + epsilon)
(- epsilon) (1 + epsilon)) (Cube s)
cylinder s =
mkBox (B (-1 - epsilon) (1 + epsilon)
( - epsilon) (1 + epsilon)
(-1 - epsilon) (1 + epsilon)) (Cylinder s)
----------------------------
-- Object transformations
----------------------------
type Transform = (Matrix, Matrix)
transform :: Transform -> CSG a -> CSG a
transform (m, m') (Transform mp mp' p) = Transform (multMM m mp) (multMM mp' m') p
transform mm' (Union p q) = Union (transform mm' p) (transform mm' q)
transform mm' (Intersect p q) = Intersect (transform mm' p) (transform mm' q)
transform mm' (Difference p q) = Difference (transform mm' p) (transform mm' q)
transform mm'@(m,_) (Box box p) = Box (transformBox m box) (transform mm' p)
transform (m, m') prim = Transform m m' prim
translate :: Coords -> CSG a -> CSG a
translateX, translateY, translateZ :: Double -> CSG a -> CSG a
translate xyz = transform $ transM xyz
translateX x = translate (x, 0, 0)
translateY y = translate (0, y, 0)
translateZ z = translate (0, 0, z)
scale :: Coords -> CSG a -> CSG a
scaleX, scaleY, scaleZ, uscale :: Double -> CSG a -> CSG a
scale xyz = transform $ scaleM xyz
scaleX x = scale (x, 1, 1)
scaleY y = scale (1, y, 1)
scaleZ z = scale (1, 1, z)
uscale u = scale (u,u,u)
rotateX, rotateY, rotateZ :: Radian -> CSG a -> CSG a
rotateX a = transform $ rotxM a
rotateY a = transform $ rotyM a
rotateZ a = transform $ rotzM a
unit = matrix
( ( 1.0, 0.0, 0.0, 0.0 ),
( 0.0, 1.0, 0.0, 0.0 ),
( 0.0, 0.0, 1.0, 0.0 ),
( 0.0, 0.0, 0.0, 1.0 ) )
transM (x, y, z)
= ( matrix
( ( 1, 0, 0, x ),
( 0, 1, 0, y ),
( 0, 0, 1, z ),
( 0, 0, 0, 1 ) ),
matrix
( ( 1, 0, 0, -x ),
( 0, 1, 0, -y ),
( 0, 0, 1, -z ),
( 0, 0, 0, 1 ) ) )
scaleM (x, y, z)
= ( matrix
( ( x', 0, 0, 0 ),
( 0, y', 0, 0 ),
( 0, 0, z', 0 ),
( 0, 0, 0, 1 ) ),
matrix
( ( 1/x', 0, 0, 0 ),
( 0, 1/y', 0, 0 ),
( 0, 0, 1/z', 0 ),
( 0, 0, 0, 1 ) ) )
where x' = nonZero x
y' = nonZero y
z' = nonZero z
rotxM t
= ( matrix
( ( 1, 0, 0, 0 ),
( 0, cos t, -sin t, 0 ),
( 0, sin t, cos t, 0 ),
( 0, 0, 0, 1 ) ),
matrix
( ( 1, 0, 0, 0 ),
( 0, cos t, sin t, 0 ),
( 0, -sin t, cos t, 0 ),
( 0, 0, 0, 1 ) ) )
rotyM t
= ( matrix
( ( cos t, 0, sin t, 0 ),
( 0, 1, 0, 0 ),
( -sin t, 0, cos t, 0 ),
( 0, 0, 0, 1 ) ),
matrix
( ( cos t, 0, -sin t, 0 ),
( 0, 1, 0, 0 ),
( sin t, 0, cos t, 0 ),
( 0, 0, 0, 1 ) ) )
rotzM t
= ( matrix
( ( cos t, -sin t, 0, 0 ),
( sin t, cos t, 0, 0 ),
( 0, 0, 1, 0 ),
( 0, 0, 0, 1 ) ),
matrix
( ( cos t, sin t, 0, 0 ),
( -sin t, cos t, 0, 0 ),
( 0, 0, 1, 0 ),
( 0, 0, 0, 1 ) ) )
-------------------
-- Eye transformations
-- These are used to specify placement of the eye.
-- `eye' starts out at (0, 0, -1).
-- These are implemented as inverse transforms of the model.
-------------------
eye :: Transform
translateEye :: Coords -> Transform -> Transform
rotateEyeX, rotateEyeY, rotateEyeZ :: Radian -> Transform -> Transform
eye = (unit, unit)
translateEye xyz (eye1, eye2)
= (multMM m1 eye1, multMM eye2 m2)
where (m1, m2) = transM xyz
rotateEyeX t (eye1, eye2)
= (multMM m1 eye1, multMM eye2 m2)
where (m1, m2) = rotxM t
rotateEyeY t (eye1, eye2)
= (multMM m1 eye1, multMM eye2 m2)
where (m1, m2) = rotyM t
rotateEyeZ t (eye1, eye2)
= (multMM m1 eye1, multMM eye2 m2)
where (m1, m2) = rotzM t
-------------------
-- Bounding boxes
-------------------
mergeBox (B x11 x12 y11 y12 z11 z12) (B x21 x22 y21 y22 z21 z22) =
B (x11 `min` x21) (x12 `max` x22)
(y11 `min` y21) (y12 `max` y22)
(z11 `min` z21) (z12 `max` z22)
transformBox t (B x1 x2 y1 y2 z1 z2)
= (B (foldr1 min (map xCoord pts'))
(foldr1 max (map xCoord pts'))
(foldr1 min (map yCoord pts'))
(foldr1 max (map yCoord pts'))
(foldr1 min (map zCoord pts'))
(foldr1 max (map zCoord pts')))
where pts' = map (multMP t) pts
pts = [point x1 y1 z1,
point x1 y1 z2,
point x1 y2 z1,
point x1 y2 z2,
point x2 y1 z1,
point x2 y1 z2,
point x2 y2 z1,
point x2 y2 z2]
|
