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