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 Intersections
    7     ( intersectRayWithObject,
    8       quadratic
    9     ) where
   10 
   11 import Data.Maybe(isJust)
   12 
   13 import Construct
   14 import Geometry
   15 import Interval
   16 import Misc
   17 
   18 -- This is factored into two bits.  The main function `intersections'
   19 -- intersects a line with an object.
   20 -- The wrapper call `intersectRayWithObject' coerces this to an intersection
   21 -- with a ray by clamping the result to start at 0.
   22 
   23 -- entered 115,538 timesintersectRayWithObject ray p
   24   = clampIntervals is
   25   where is = intersections ray p
   26 
   27 -- entered 205,130 timesclampIntervals (True, [], True) = (False, [(0, True, undefined)], True)
   28 clampIntervals empty@(False, [], False) = empty
   29 clampIntervals (True, is@((i, False, p) : is'), isOpen)
   30   | i `near` 0 || i < 0
   31   = clampIntervals (False, is', isOpen)
   32   | otherwise
   33   = (False, (0, True, undefined) : is, isOpen)
   34 clampIntervals ivals@(False, is@((i, True, p) : is'), isOpen)
   35   | i `near` 0 || i < 0
   36   -- can unify this with first case...
   37   = clampIntervals (True, is', isOpen)
   38   | otherwise
   39   = ivals
   40 
   41 -- entered 496,770 timesintersections ray (Union p q)
   42   = unionIntervals is js
   43   where is = intersections ray p
   44         js = intersections ray q
   45 
   46 intersections ray (Intersect p q)
   47   = intersectIntervals is js
   48   where is = intersections ray p
   49         js = intersections ray q
   50 
   51 intersections ray (Difference p q)
   52   = differenceIntervals is (negateSurfaces js)
   53   where is = intersections ray p
   54         js = intersections ray q
   55 
   56 intersections ray (Transform m m' p)
   57   = mapI (xform m) is
   58   where is = intersections (m' `multMR` ray) p
   59         xform m (i, b, (s, p0)) = (i, b, (transformSurface m s, p0))
   60 
   61 intersections ray (Box box p)
   62   | intersectWithBox ray box = intersections ray p
   63   | otherwise = emptyIList
   64 
   65 intersections ray p@(Plane s)
   66   = intersectPlane ray s
   67 
   68 intersections ray p@(Sphere s)
   69   = intersectSphere ray s
   70 
   71 intersections ray p@(Cube s)
   72   = intersectCube ray s
   73 
   74 intersections ray p@(Cylinder s)
   75   = intersectCylinder ray s
   76 
   77 intersections ray p@(Cone s)
   78   = intersectCone ray s
   79 
   80 negateSurfaces :: IList (Surface, Texture a) -> IList (Surface, Texture a)
   81 -- never enterednegateSurfaces = mapI negSurf
   82   where negSurf (i, b, (s,t)) = (i, b, (negateSurface s, t))
   83 
   84 -- never enterednegateSurface (Planar p0 v0 v1)
   85   = Planar p0 v1 v0
   86 negateSurface (Spherical p0 v0 v1)
   87   = Spherical p0 v1 v0
   88 negateSurface (Cylindrical p0 v0 v1)
   89   = Cylindrical p0 v1 v0
   90 negateSurface (Conic p0 v0 v1)
   91   = Conic p0 v1 v0
   92 
   93 -- entered 32,512 timestransformSurface m (Planar p0 v0 v1)
   94   = Planar p0' v0' v1'
   95   where p0' = multMP m p0
   96         v0' = multMV m v0
   97         v1' = multMV m v1
   98 
   99 transformSurface m (Spherical p0 v0 v1)
  100   = Spherical p0' v0' v1'
  101   where p0' = multMP m p0
  102         v0' = multMV m v0
  103         v1' = multMV m v1
  104 
  105 -- ditto as above
  106 transformSurface m (Cylindrical p0 v0 v1)
  107   = Cylindrical p0' v0' v1'
  108   where p0' = multMP m p0
  109         v0' = multMV m v0
  110         v1' = multMV m v1
  111 
  112 transformSurface m (Conic p0 v0 v1)
  113   = Conic p0' v0' v1'
  114   where p0' = multMP m p0
  115         v0' = multMV m v0
  116         v1' = multMV m v1
  117 
  118 --------------------------------
  119 -- Plane
  120 --------------------------------
  121 
  122 intersectPlane :: Ray -> a -> IList (Surface, Texture a)
  123 -- entered 115,538 timesintersectPlane ray texture = intersectXZPlane PlaneFace ray 0.0 texture
  124 
  125 intersectXZPlane :: Face -> Ray -> Double -> a -> IList (Surface, Texture a)
  126 -- entered 115,538 timesintersectXZPlane n (r,v) yoffset texture
  127   | b `near` 0
  128   = -- the ray is parallel to the plane - it's either all in, or all out
  129     if y `near` yoffset || y < yoffset then openIList else emptyIList
  130 
  131     -- The line intersects the plane. Find t such that
  132     -- (x + at, y + bt, z + ct) intersects the X-Z plane.
  133     -- t may be negative (the ray starts within the halfspace),
  134     -- but we'll catch that later when we clamp the intervals
  135 
  136   | b < 0       -- the ray is pointing downwards
  137   = (False, [mkEntry (t0, (Planar p0 v0 v1, (n, p0, texture)))], True)
  138 
  139   | otherwise   -- the ray is pointing upwards
  140   = (True,  [mkExit (t0, (Planar p0 v0 v1, (n, p0, texture)))],  False)
  141 
  142   where t0 = (yoffset-y) / b
  143         x0 = x + a * t0
  144         z0 = z + c * t0
  145         p0 = point x0 0 z0
  146         v0 = vector 0 0 1
  147         v1 = vector 1 0 0
  148 
  149         x = xCoord r
  150         y = yCoord r
  151         z = zCoord r
  152         a = xComponent v
  153         b = yComponent v
  154         c = zComponent v
  155 
  156 
  157 --------------------------------
  158 -- Sphere
  159 --------------------------------
  160 
  161 intersectSphere :: Ray -> a -> IList (Surface, Texture a)
  162 -- never enteredintersectSphere ray@(r, v) texture
  163   = -- Find t such that (x + ta, y + tb, z + tc) intersects the
  164     -- unit sphere, that is, such that:
  165     --   (x + ta)^2 + (y + tb)^2 + (z + tc)^2 = 1
  166     -- This is a quadratic equation in t:
  167     --   t^2(a^2 + b^2 + c^2) + 2t(xa + yb + zc) + (x^2 + y^2 + z^2 - 1) = 0
  168     let c1 = sq a + sq b + sq c
  169         c2 = 2 * (x * a + y * b + z * c)
  170         c3 = sq x + sq y + sq z - 1
  171     in
  172         case quadratic c1 c2 c3 of
  173         Nothing -> emptyIList
  174         Just (t1, t2) -> entryexit (g t1) (g t2)
  175     where x = xCoord r
  176           y = yCoord r
  177           z = zCoord r
  178           a = xComponent v
  179           b = yComponent v
  180           c = zComponent v
  181           g t = (t, (Spherical origin v1 v2, (SphereFace, p0, texture)))
  182               where origin = point 0 0 0
  183                     x0 = x + t * a
  184                     y0 = y + t * b
  185                     z0 = z + t * c
  186                     p0 = point  x0 y0 z0
  187                     v0 = vector x0 y0 z0
  188                     (v1, v2) = tangents v0
  189 
  190 
  191 --------------------------------
  192 -- Cube
  193 --------------------------------
  194 
  195 intersectCube :: Ray -> a -> IList (Surface, Texture a)
  196 -- entered 17,309 timesintersectCube ray@(r, v) texture
  197   = -- The set of t such that (x + at, y + bt, z + ct) lies within
  198     -- the unit cube satisfies:
  199     --    0 <= x + at <= 1,  0 <= y + bt <= 1,  0 <= z + ct <= 1
  200     -- The minimum and maximum such values of t give us the two
  201     -- intersection points.
  202     case intersectSlabIval (intersectCubeSlab face2 face3 x a)
  203         (intersectSlabIval (intersectCubeSlab face5 face4 y b)
  204                            (intersectCubeSlab face0 face1 z c)) of
  205     Nothing -> emptyIList
  206     Just (t1, t2) -> entryexit (g t1) (g t2)
  207   where g ((n, v0, v1), t)
  208           = (t, (Planar p0 v0 v1, (n, p0, texture)))
  209           where p0 = offsetToPoint ray t
  210         face0 = (CubeFront,  vectorY, vectorX)
  211         face1 = (CubeBack,   vectorX, vectorY)
  212         face2 = (CubeLeft,   vectorZ, vectorY)
  213         face3 = (CubeRight,  vectorY, vectorZ)
  214         face4 = (CubeTop,    vectorZ, vectorX)
  215         face5 = (CubeBottom, vectorX, vectorZ)
  216         vectorX = vector 1 0 0
  217         vectorY = vector 0 1 0
  218         vectorZ = vector 0 0 1
  219         x = xCoord r
  220         y = yCoord r
  221         z = zCoord r
  222         a = xComponent v
  223         b = yComponent v
  224         c = zComponent v
  225 
  226 -- entered 51,927 timesintersectCubeSlab n m w d
  227   | d `near` 0 = if (0 <= w) && (w <= 1)
  228                  then Just ((n, -inf), (m, inf)) else Nothing
  229   | d > 0      = Just ((n,  (-w)/d), (m, (1-w)/d))
  230   | otherwise  = Just ((m, (1-w)/d), (n,  (-w)/d))
  231 
  232 -- entered 34,618 timesintersectSlabIval Nothing Nothing  = Nothing
  233 intersectSlabIval Nothing (Just i) = Nothing
  234 intersectSlabIval (Just i) Nothing = Nothing
  235 intersectSlabIval (Just (nu1@(n1, u1), mv1@(m1, v1)))
  236                   (Just (nu2@(n2, u2), mv2@(m2, v2)))
  237   = checkInterval (nu, mv)
  238   where nu = if u1 < u2 then nu2 else nu1
  239         mv = if v1 < v2 then mv1 else mv2
  240         checkInterval numv@(nu@(_, u), (m, v))
  241           -- rounding error may force us to push v out a bit
  242           | u `near` v = Just (nu, (m, u + epsilon))
  243           | u    <   v = Just numv
  244           | otherwise  = Nothing
  245 
  246 
  247 --------------------------------
  248 -- Cylinder
  249 --------------------------------
  250 
  251 intersectCylinder :: Ray -> a -> IList (Surface, Texture a)
  252 -- never enteredintersectCylinder ray texture
  253   = isectSide `intersectIntervals` isectTop `intersectIntervals` isectBottom
  254   where isectSide   = intersectCylSide ray texture
  255         isectTop    = intersectXZPlane CylinderTop ray 1.0 texture
  256         isectBottom = complementIntervals $ negateSurfaces $
  257                       intersectXZPlane CylinderBottom ray 0.0 texture
  258 
  259 -- never enteredintersectCylSide (r, v) texture
  260   = -- The ray (x + ta, y + tb, z + tc) intersects the sides of the
  261     -- cylinder if:
  262     --    (x + ta)^2 + (z + tc)^2 = 1  and 0 <= y + tb <= 1.
  263     if (sq a + sq c) `near` 0
  264     then -- The ray is parallel to the Y-axis, and does not intersect
  265          -- the cylinder sides.  It's either all in, or all out
  266         if (sqxy `near` 1.0 || sqxy < 1.0) then openIList else emptyIList
  267    else -- Find values of t that solve the quadratic equation
  268         --   (a^2 + c^2)t^2 + 2(ax + cz)t + x^2 + z^2 - 1 = 0
  269         let c1 = sq a + sq c
  270             c2 = 2 * (x * a + z * c)
  271             c3 = sq x + sq z - 1
  272         in
  273         case quadratic c1 c2 c3 of
  274         Nothing -> emptyIList
  275         Just (t1, t2) -> entryexit (g t1) (g t2)
  276 
  277   where sqxy = sq x + sq y
  278         g t = (t, (Cylindrical origin v1 v2, (CylinderSide, p0, texture)))
  279             where origin = point 0 0 0
  280                   x0 = x + t * a
  281                   y0 = y + t * b
  282                   z0 = z + t * c
  283                   p0 = point  x0 y0 z0
  284                   v0 = vector x0 0 z0
  285                   (v1, v2) = tangents v0
  286 
  287         x = xCoord r
  288         y = yCoord r
  289         z = zCoord r
  290         a = xComponent v
  291         b = yComponent v
  292         c = zComponent v
  293 
  294 
  295 -------------------
  296 -- Cone
  297 -------------------
  298 
  299 intersectCone :: Ray -> a -> IList (Surface, Texture a)
  300 -- never enteredintersectCone ray texture
  301   = isectSide `intersectIntervals` isectTop `intersectIntervals` isectBottom
  302   where isectSide   = intersectConeSide ray texture
  303         isectTop    = intersectXZPlane ConeBase ray 1.0 texture
  304         isectBottom = complementIntervals $ negateSurfaces $
  305                       intersectXZPlane ConeBase ray 0.0 texture
  306 
  307 -- never enteredintersectConeSide (r, v) texture
  308   = -- Find the points where the ray intersects the cond side.  At any points of
  309     -- intersection, we must have:
  310     --    (x + ta)^2 + (z + tc)^2 = (y + tb)^2
  311     -- which is the following quadratic equation:
  312     --    t^2(a^2-b^2+c^2) + 2t(xa-yb+cz) + (x^2-y^2+z^2) = 0
  313     let c1 = sq a - sq b + sq c
  314         c2 = 2 * (x * a - y * b + c * z)
  315         c3 = sq x - sq y + sq z
  316     in  case quadratic c1 c2 c3 of
  317         Nothing -> emptyIList
  318         Just (t1, t2) ->
  319             -- If either intersection strikes the middle, then the other
  320             -- can only be off by rounding error, so we make a tangent
  321             -- strike using the "good" value.
  322             -- If the intersections straddle the origin, then it's
  323             -- an exit/entry pair, otherwise it's an entry/exit pair.
  324             let y1 = y + t1 * b
  325                 y2 = y + t2 * b
  326             in  if y1 `near` 0                  then entryexit (g t1) (g t1)
  327                 else if y2 `near` 0             then entryexit (g t2) (g t2)
  328                 else if (y1 < 0) `xor` (y2 < 0) then exitentry (g t1) (g t2)
  329                 else                                 entryexit (g t1) (g t2)
  330 
  331   where g t = (t, (Conic origin v1 v2, (ConeSide, p0, texture)))
  332             where origin = point 0 0 0
  333                   x0 = x + t * a
  334                   y0 = y + t * b
  335                   z0 = z + t * c
  336                   p0 = point  x0 y0 z0
  337                   v0 = normalize $ vector x0 (-y0) z0
  338                   (v1, v2) = tangents v0
  339 
  340         x = xCoord r
  341         y = yCoord r
  342         z = zCoord r
  343         a = xComponent v
  344         b = yComponent v
  345         c = zComponent v
  346 
  347         -- beyond me why this isn't defined in the prelude...
  348         xor False b = b
  349         xor True  b = not b
  350 
  351 
  352 -------------------
  353 -- Solving quadratics
  354 -------------------
  355 
  356 quadratic :: Double -> Double -> Double -> Maybe (Double, Double)
  357 -- never enteredquadratic a b c =
  358   -- Solve the equation ax^2 + bx + c = 0 by using the quadratic formula.
  359   let d = sq b - 4 * a * c
  360       d' = if d `near` 0 then 0 else d
  361   in if d' < 0
  362      then Nothing -- There are no real roots.
  363      else
  364         if a > 0 then Just (((-b) - sqrt d') / (2 * a),
  365                             ((-b) + sqrt d') / (2 * a))
  366                  else Just (((-b) + sqrt d') / (2 * a),
  367                             ((-b) - sqrt d') / (2 * a))
  368 
  369 -------------------
  370 -- Bounding boxes
  371 -------------------
  372 
  373 data MaybeInterval = Interval !Double !Double
  374                    | NoInterval
  375 
  376 -- entered 115,538 timesisInterval (Interval _ _) = True
  377 isInterval _              = False
  378 
  379 intersectWithBox :: Ray -> Box -> Bool
  380 -- entered 115,538 timesintersectWithBox (r, v) (B x1 x2 y1 y2 z1 z2)
  381   = isInterval interval
  382   where x_interval = intersectRayWithSlab (xCoord r) (xComponent v) (x1, x2)
  383         y_interval = intersectRayWithSlab (yCoord r) (yComponent v) (y1, y2)
  384         z_interval = intersectRayWithSlab (zCoord r) (zComponent v) (z1, z2)
  385         interval = intersectInterval x_interval
  386                    (intersectInterval y_interval z_interval)
  387 
  388 intersectInterval :: MaybeInterval -> MaybeInterval -> MaybeInterval
  389 -- entered 231,076 timesintersectInterval NoInterval _ = NoInterval
  390 intersectInterval _ NoInterval = NoInterval
  391 intersectInterval (Interval a b) (Interval c d)
  392   | b < c || d < a = NoInterval
  393   | otherwise = Interval (a `max` c) (b `min` d)
  394 
  395 {-# INLINE intersectRayWithSlab #-}
  396 intersectRayWithSlab :: Double -> Double -> (Double,Double) -> MaybeInterval
  397 -- entered 346,614 timesintersectRayWithSlab xCoord alpha (x1, x2)
  398   | alpha == 0 = if xCoord < x1 || xCoord > x2 then NoInterval else infInterval
  399   | alpha >  0 = Interval a b
  400   | otherwise  = Interval b a
  401   where a = (x1 - xCoord) / alpha
  402         b = (x2 - xCoord) / alpha
  403 
  404 -- entered onceinfInterval = Interval (-inf) inf