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 Geometry 7 ( Coords 8 , Ray 9 , Point -- abstract 10 , Vector -- abstract 11 , Matrix -- abstract 12 , Color -- abstract 13 , Box(..) 14 , Radian 15 , matrix 16 , coord 17 , color 18 , uncolor 19 , xCoord , yCoord , zCoord 20 , xComponent , yComponent , zComponent 21 , point 22 , vector 23 , nearV 24 , point_to_vector 25 , vector_to_point 26 , dot 27 , cross 28 , tangents 29 , addVV 30 , addPV 31 , subVV 32 , negV 33 , subPP 34 , norm 35 , normalize 36 , dist2 37 , sq 38 , distFrom0Sq 39 , distFrom0 40 , multSV 41 , multMM 42 , transposeM 43 , multMV 44 , multMP 45 , multMQ 46 , multMR 47 , white 48 , black 49 , addCC 50 , subCC 51 , sumCC 52 , multCC 53 , multSC 54 , nearC 55 , offsetToPoint 56 , epsilon 57 , inf 58 , nonZero 59 , eqEps 60 , near 61 , clampf 62 ) where 63 64 65 type Coords = (Double,Double,Double) 66 67 type Ray = (Point,Vector) -- origin of ray, and unit vector giving direction 68 69 data Point = P !Double !Double !Double -- implicit extra arg of 1 70 deriving (-- never entered-- never enteredShow) 71 data Vector = V !Double !Double !Double -- implicit extra arg of 0 72 deriving (-- never entered-- never enteredShow, -- never entered-- never enteredEq) 73 data Matrix = M !Quad !Quad !Quad !Quad 74 deriving (-- never entered-- never enteredShow) 75 76 data Color = C !Double !Double !Double 77 deriving (-- never entered-- never enteredShow, -- never entered-- never enteredEq) 78 79 data Box = B !Double !Double !Double !Double !Double !Double 80 deriving (-- never entered-- never enteredShow) 81 82 data Quad = Q !Double !Double !Double !Double 83 deriving (-- never entered-- never enteredShow) 84 85 type Radian = Double 86 87 type Tup4 a = (a,a,a,a) 88 89 --{-# INLINE matrix #-} 90 matrix :: Tup4 (Tup4 Double) -> Matrix 91 -- entered 13 timesmatrix ((m11, m12, m13, m14), 92 (m21, m22, m23, m24), 93 (m31, m32, m33, m34), 94 (m41, m42, m43, m44)) 95 = M (Q m11 m12 m13 m14) 96 (Q m21 m22 m23 m24) 97 (Q m31 m32 m33 m34) 98 (Q m41 m42 m43 m44) 99 100 -- never enteredcoord x y z = (x, y, z) 101 102 -- entered 32,514 timescolor r g b = C r g b 103 104 -- entered 60,000 timesuncolor (C r g b) = (r,g,b) 105 106 {-# INLINE xCoord #-} 107 -- entered 187,913 timesxCoord (P x y z) = x 108 {-# INLINE yCoord #-} 109 -- entered 253,212 timesyCoord (P x y z) = y 110 {-# INLINE zCoord #-} 111 -- entered 188,590 timeszCoord (P x y z) = z 112 113 {-# INLINE xComponent #-} 114 -- entered 159,631 timesxComponent (V x y z) = x 115 {-# INLINE yComponent #-} 116 -- entered 248,385 timesyComponent (V x y z) = y 117 {-# INLINE zComponent #-} 118 -- entered 159,631 timeszComponent (V x y z) = z 119 120 point :: Double -> Double -> Double -> Point 121 -- entered 26,833 timespoint x y z = P x y z 122 123 vector :: Double -> Double -> Double -> Vector 124 -- entered 60,006 timesvector x y z = V x y z 125 126 nearV :: Vector -> Vector -> Bool 127 -- never enterednearV (V a b c) (V d e f) = a `near` d && b `near` e && c `near` f 128 129 point_to_vector :: Point -> Vector 130 -- never enteredpoint_to_vector (P x y z) = V x y z 131 132 vector_to_point :: Vector -> Point 133 -- never enteredvector_to_point (V x y z) = P x y z 134 135 {-# INLINE vector_to_quad #-} 136 vector_to_quad :: Vector -> Quad 137 -- entered 197,872 timesvector_to_quad (V x y z) = Q x y z 0 138 139 {-# INLINE point_to_quad #-} 140 point_to_quad :: Point -> Quad 141 -- entered 132,895 timespoint_to_quad (P x y z) = Q x y z 1 142 143 {-# INLINE quad_to_point #-} 144 quad_to_point :: Quad -> Point 145 -- entered 132,895 timesquad_to_point (Q x y z _) = P x y z 146 147 {-# INLINE quad_to_vector #-} 148 quad_to_vector :: Quad -> Vector 149 -- entered 197,872 timesquad_to_vector (Q x y z _) = V x y z 150 151 --{-# INLINE dot #-} 152 dot :: Vector -> Vector -> Double 153 -- entered 112,863 timesdot (V x1 y1 z1) (V x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2 154 155 cross :: Vector -> Vector -> Vector 156 -- entered 32,512 timescross (V x1 y1 z1) (V x2 y2 z2) 157 = V (y1 * z2 - z1 * y2) (z1 * x2 - x1 * z2) (x1 * y2 - y1 * x2) 158 159 -- assumption: the input vector is a normal 160 tangents :: Vector -> (Vector, Vector) 161 -- never enteredtangents v@(V x y z) 162 = (v1, v `cross` v1) 163 where v1 | x == 0 = normalize (vector 0 z (-y)) 164 | otherwise = normalize (vector (-y) x 0) 165 166 {-# INLINE dot4 #-} 167 dot4 :: Quad -> Quad -> Double 168 -- entered 1,323,260 timesdot4 (Q x1 y1 z1 w1) (Q x2 y2 z2 w2) = x1 * x2 + y1 * y2 + z1 * z2 + w1 * w2 169 170 addVV :: Vector -> Vector -> Vector 171 -- never enteredaddVV (V x1 y1 z1) (V x2 y2 z2) 172 = V (x1 + x2) (y1 + y2) (z1 + z2) 173 174 addPV :: Point -> Vector -> Point 175 -- entered 63,350 timesaddPV (P x1 y1 z1) (V x2 y2 z2) 176 = P (x1 + x2) (y1 + y2) (z1 + z2) 177 178 subVV :: Vector -> Vector -> Vector 179 -- entered 53,539 timessubVV (V x1 y1 z1) (V x2 y2 z2) 180 = V (x1 - x2) (y1 - y2) (z1 - z2) 181 182 negV :: Vector -> Vector 183 -- never enterednegV (V x1 y1 z1) 184 = V (-x1) (-y1) (-z1) 185 186 subPP :: Point -> Point -> Vector 187 -- never enteredsubPP (P x1 y1 z1) (P x2 y2 z2) 188 = V (x1 - x2) (y1 - y2) (z1 - z2) 189 190 --{-# INLINE norm #-} 191 norm :: Vector -> Double 192 -- never enterednorm (V x y z) = sqrt (sq x + sq y + sq z) 193 194 --{-# INLINE normalize #-} 195 -- normalize a vector to a unit vector 196 normalize :: Vector -> Vector 197 -- entered 139,761 timesnormalize v@(V x y z) 198 | norm /= 0 = multSV (1/norm) v 199 | otherwise = error "normalize empty!" 200 where norm = sqrt (sq x + sq y + sq z) 201 202 -- This does computes the distance *squared* 203 dist2 :: Point -> Point -> Double 204 -- never entereddist2 us vs = sq x + sq y + sq z 205 where 206 (V x y z) = subPP us vs 207 208 {-# INLINE sq #-} 209 sq :: Double -> Double 210 -- entered 419,283 timessq d = d * d 211 212 {-# INLINE distFrom0Sq #-} 213 distFrom0Sq :: Point -> Double -- Distance of point from origin. 214 -- never entereddistFrom0Sq (P x y z) = sq x + sq y + sq z 215 216 {-# INLINE distFrom0 #-} 217 distFrom0 :: Point -> Double -- Distance of point from origin. 218 -- never entereddistFrom0 p = sqrt (distFrom0Sq p) 219 220 --{-# INLINE multSV #-} 221 multSV :: Double -> Vector -> Vector 222 -- entered 229,838 timesmultSV k (V x y z) = V (k*x) (k*y) (k*z) 223 224 --{-# INLINE multMM #-} 225 multMM :: Matrix -> Matrix -> Matrix 226 -- entered 12 timesmultMM m1@(M q1 q2 q3 q4) m2 227 = M (multMQ m2' q1) 228 (multMQ m2' q2) 229 (multMQ m2' q3) 230 (multMQ m2' q4) 231 where 232 m2' = transposeM m2 233 234 {-# INLINE transposeM #-} 235 transposeM :: Matrix -> Matrix 236 -- entered 12 timestransposeM (M (Q e11 e12 e13 e14) 237 (Q e21 e22 e23 e24) 238 (Q e31 e32 e33 e34) 239 (Q e41 e42 e43 e44)) = (M (Q e11 e21 e31 e41) 240 (Q e12 e22 e32 e42) 241 (Q e13 e23 e33 e43) 242 (Q e14 e24 e34 e44)) 243 244 245 --multMM m1 m2 = [map (dot4 row) (transpose m2) | row <- m1] 246 247 --{-# INLINE multMV #-} 248 multMV :: Matrix -> Vector -> Vector 249 -- entered 197,872 timesmultMV m v = quad_to_vector (multMQ m (vector_to_quad v)) 250 251 --{-# INLINE multMP #-} 252 multMP :: Matrix -> Point -> Point 253 -- entered 132,895 timesmultMP m p = quad_to_point (multMQ m (point_to_quad p)) 254 255 -- mat vec = map (dot4 vec) mat 256 257 {-# INLINE multMQ #-} 258 multMQ :: Matrix -> Quad -> Quad 259 -- entered 330,815 timesmultMQ (M q1 q2 q3 q4) q 260 = Q (dot4 q q1) 261 (dot4 q q2) 262 (dot4 q q3) 263 (dot4 q q4) 264 265 {-# INLINE multMR #-} 266 multMR :: Matrix -> Ray -> Ray 267 -- entered 132,847 timesmultMR m (r, v) = (multMP m r, multMV m v) 268 269 white :: Color 270 -- never enteredwhite = C 1 1 1 271 black :: Color 272 -- entered onceblack = C 0 0 0 273 274 addCC :: Color -> Color -> Color 275 -- entered 151,160 timesaddCC (C a b c) (C d e f) = C (a+d) (b+e) (c+f) 276 277 subCC :: Color -> Color -> Color 278 -- never enteredsubCC (C a b c) (C d e f) = C (a-d) (b-e) (c-f) 279 280 sumCC :: [Color] -> Color 281 -- entered oncesumCC = foldr addCC black 282 283 multCC :: Color -> Color -> Color 284 -- entered 112,863 timesmultCC (C a b c) (C d e f) = C (a*d) (b*e) (c*f) 285 286 multSC :: Double -> Color -> Color 287 -- entered 183,672 timesmultSC k (C a b c) = C (a*k) (b*k) (c*k) 288 289 nearC :: Color -> Color -> Bool 290 -- entered 32,512 timesnearC (C a b c) (C d e f) = a `near` d && b `near` e && c `near` f 291 292 offsetToPoint :: Ray -> Double -> Point 293 -- entered 34,539 timesoffsetToPoint (r,v) i = r `addPV` (i `multSV` v) 294 295 -- 296 297 epsilon, inf :: Double -- aproximate zero and infinity 298 -- entered onceepsilon = 1.0e-10 299 -- entered onceinf = 1.0e20 300 301 nonZero :: Double -> Double -- Use before a division. It makes definitions 302 -- entered 3 timesnonZero x | x > epsilon = x -- more complete and I bet the errors that get 303 | x < -epsilon = x -- introduced will be undetectable if epsilon 304 | otherwise = epsilon -- is small enough 305 306 307 -- entered 376,778 timeseqEps x y = abs (x-y) < epsilon 308 -- entered oncenear = eqEps 309 310 clampf :: Double -> Double 311 -- entered 180,000 timesclampf p | p < 0 = 0 312 | p > 1 = 1 313 | True = p