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