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.
19 , xCoord , yCoord , zCoord
20 , xComponent , yComponent , zComponent
66 type Coords = (Double,Double,Double)
68 type Ray = (Point,Vector) -- origin of ray, and unit vector giving direction
70 data Point = P !Double !Double !Double -- implicit extra arg of 1
72 data Vector = V !Double !Double !Double -- implicit extra arg of 0
74 data Matrix = M !Quad !Quad !Quad !Quad
77 data Color = C !Double !Double !Double
80 data Box = B !Double !Double !Double !Double !Double !Double
83 data Quad = Q !Double !Double !Double !Double
88 type Tup4 a = (a,a,a,a)
90 --{-# INLINE matrix #-}
91 matrix :: Tup4 (Tup4 Double) -> Matrix
92 matrix ((m11, m12, m13, m14),
96 = M (Q m11 m12 m13 m14)
101 coord x y z = (x, y, z)
103 color r g b = C r g b
105 uncolor (C r g b) = (r,g,b)
107 {-# INLINE xCoord #-}
109 {-# INLINE yCoord #-}
111 {-# INLINE zCoord #-}
114 {-# INLINE xComponent #-}
115 xComponent (V x y z) = x
116 {-# INLINE yComponent #-}
117 yComponent (V x y z) = y
118 {-# INLINE zComponent #-}
119 zComponent (V x y z) = z
121 point :: Double -> Double -> Double -> Point
122 point x y z = P x y z
124 vector :: Double -> Double -> Double -> Vector
125 vector x y z = V x y z
127 nearV :: Vector -> Vector -> Bool
128 nearV (V a b c) (V d e f) = a `near` d && b `near` e && c `near` f
130 point_to_vector :: Point -> Vector
131 point_to_vector (P x y z) = V x y z
133 vector_to_point :: Vector -> Point
134 vector_to_point (V x y z) = P x y z
136 {-# INLINE vector_to_quad #-}
137 vector_to_quad :: Vector -> Quad
138 vector_to_quad (V x y z) = Q x y z 0
140 {-# INLINE point_to_quad #-}
141 point_to_quad :: Point -> Quad
142 point_to_quad (P x y z) = Q x y z 1
144 {-# INLINE quad_to_point #-}
145 quad_to_point :: Quad -> Point
146 quad_to_point (Q x y z _) = P x y z
148 {-# INLINE quad_to_vector #-}
149 quad_to_vector :: Quad -> Vector
150 quad_to_vector (Q x y z _) = V x y z
153 dot :: Vector -> Vector -> Double
154 dot (V x1 y1 z1) (V x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2
156 cross :: Vector -> Vector -> Vector
157 cross (V x1 y1 z1) (V x2 y2 z2)
158 = V (y1 * z2 - z1 * y2) (z1 * x2 - x1 * z2) (x1 * y2 - y1 * x2)
160 -- assumption: the input vector is a normal
161 tangents :: Vector -> (Vector, Vector)
164 where v1 | x == 0 = normalize (vector 0 z (-y))
165 | otherwise = normalize (vector (-y) x 0)
168 dot4 :: Quad -> Quad -> Double
169 dot4 (Q x1 y1 z1 w1) (Q x2 y2 z2 w2) = x1 * x2 + y1 * y2 + z1 * z2 + w1 * w2
171 addVV :: Vector -> Vector -> Vector
172 addVV (V x1 y1 z1) (V x2 y2 z2)
173 = V (x1 + x2) (y1 + y2) (z1 + z2)
175 addPV :: Point -> Vector -> Point
176 addPV (P x1 y1 z1) (V x2 y2 z2)
177 = P (x1 + x2) (y1 + y2) (z1 + z2)
179 subVV :: Vector -> Vector -> Vector
180 subVV (V x1 y1 z1) (V x2 y2 z2)
181 = V (x1 - x2) (y1 - y2) (z1 - z2)
183 negV :: Vector -> Vector
185 = V (-x1) (-y1) (-z1)
187 subPP :: Point -> Point -> Vector
188 subPP (P x1 y1 z1) (P x2 y2 z2)
189 = V (x1 - x2) (y1 - y2) (z1 - z2)
191 --{-# INLINE norm #-}
192 norm :: Vector -> Double
193 norm (V x y z) = sqrt (sq x + sq y + sq z)
195 --{-# INLINE normalize #-}
196 -- normalize a vector to a unit vector
197 normalize :: Vector -> Vector
198 normalize v@(V x y z)
199 | norm /= 0 = multSV (1/norm) v
200 | otherwise = error "normalize empty!"
201 where norm = sqrt (sq x + sq y + sq z)
203 -- This does computes the distance *squared*
204 dist2 :: Point -> Point -> Double
205 dist2 us vs = sq x + sq y + sq z
207 (V x y z) = subPP us vs
210 sq :: Double -> Double
213 {-# INLINE distFrom0Sq #-}
214 distFrom0Sq :: Point -> Double -- Distance of point from origin.
215 distFrom0Sq (P x y z) = sq x + sq y + sq z
217 {-# INLINE distFrom0 #-}
218 distFrom0 :: Point -> Double -- Distance of point from origin.
219 distFrom0 p = sqrt (distFrom0Sq p)
221 --{-# INLINE multSV #-}
222 multSV :: Double -> Vector -> Vector
223 multSV k (V x y z) = V (k*x) (k*y) (k*z)
225 --{-# INLINE multMM #-}
226 multMM :: Matrix -> Matrix -> Matrix
227 multMM m1@(M q1 q2 q3 q4) m2
235 {-# INLINE transposeM #-}
236 transposeM :: Matrix -> Matrix
237 transposeM (M (Q e11 e12 e13 e14)
240 (Q e41 e42 e43 e44)) = (M (Q e11 e21 e31 e41)
246 --multMM m1 m2 = [map (dot4 row) (transpose m2) | row <- m1]
248 --{-# INLINE multMV #-}
249 multMV :: Matrix -> Vector -> Vector
250 multMV m v = quad_to_vector (multMQ m (vector_to_quad v))
252 --{-# INLINE multMP #-}
253 multMP :: Matrix -> Point -> Point
254 multMP m p = quad_to_point (multMQ m (point_to_quad p))
256 -- mat vec = map (dot4 vec) mat
258 {-# INLINE multMQ #-}
259 multMQ :: Matrix -> Quad -> Quad
260 multMQ (M q1 q2 q3 q4) q
266 {-# INLINE multMR #-}
267 multMR :: Matrix -> Ray -> Ray
268 multMR m (r, v) = (multMP m r, multMV m v)
275 addCC :: Color -> Color -> Color
276 addCC (C a b c) (C d e f) = C (a+d) (b+e) (c+f)
278 subCC :: Color -> Color -> Color
279 subCC (C a b c) (C d e f) = C (a-d) (b-e) (c-f)
281 sumCC :: [Color] -> Color
282 sumCC = foldr addCC black
284 multCC :: Color -> Color -> Color
285 multCC (C a b c) (C d e f) = C (a*d) (b*e) (c*f)
287 multSC :: Double -> Color -> Color
288 multSC k (C a b c) = C (a*k) (b*k) (c*k)
290 nearC :: Color -> Color -> Bool
291 nearC (C a b c) (C d e f) = a `near` d && b `near` e && c `near` f
293 offsetToPoint :: Ray -> Double -> Point
294 offsetToPoint (r,v) i = r `addPV` (i `multSV` v)
298 epsilon, inf :: Double -- aproximate zero and infinity
302 nonZero :: Double -> Double -- Use before a division. It makes definitions
303 nonZero x | x > epsilon = x -- more complete and I bet the errors that get
304 | x < -epsilon = x -- introduced will be undetectable if epsilon
305 | otherwise = epsilon -- is small enough
308 eqEps x y = abs (x-y) < epsilon
311 clampf :: Double -> Double