ghc/tests/programs/galois_raytrace/Interval.hs

   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 Interval
   7     ( IList
   8     , Intersection
   9     , emptyIList, openIList
  10     , mkEntry, mkExit
  11     , entryexit, exitentry
  12     , mapI
  13     , unionIntervals, intersectIntervals, differenceIntervals
  14     , complementIntervals
  15     ) where
  16
  17 import Geometry
  18
  19 -- The result of a ray trace is represented as a list of surface
  20 -- intersections.  Each intersection is a point along the ray with
  21 -- a flag indicating whether this intersection is an entry or an
  22 -- exit from the solid.  Each intersection also carries unspecified
  23 -- surface data for use by the illumination model.
  24
  25 -- Just the list of intersections isn't enough, however.  An empty
  26 -- list can denote either a trace that is always within the solid
  27 -- or never in the solid.  To dissambiguate, an extra flag is kept
  28 -- that indicates whether we are starting inside or outside of the
  29 -- solid.  As a convenience, we also keep an additional flag that
  30 -- indicates whether the last intersection ends inside or outside.
  31
  32 type IList a            = (Bool, [Intersection a], Bool)
  33 type Intersection a     = (Double, Bool, a)
  34
  35 emptyIList = (False, [], False)
  36 openIList = (True, [], True)
  37
  38 mapI f (b1, is, b2) = (b1, map f is, b2)
  39
  40 isEntry (_, entry, _) = entry
  41 isExit  (_, entry, _) = not entry
  42
  43 mkEntry (t, a) = (t, True,  a)
  44 mkExit  (t, a) = (t, False, a)
  45
  46 entryexit w1 w2 = (False, [mkEntry w1, mkExit w2], False)
  47 exitentry w1 w2 = (True, [mkExit w1, mkEntry w2], True)
  48 arrange   w1@(t1, _) w2@(t2, _) | t1 < t2   = entryexit w1 w2
  49                                 | otherwise = entryexit w2 w1
  50
  51
  52 cmpI :: Intersection a -> Intersection a -> Ordering
  53 cmpI (i, _, _) (j, _, _)
  54   | i `near` j = EQ
  55   | i   <    j = LT
  56   | otherwise  = GT
  57
  58 bad (b1, [], b2) = b1 /= b2
  59 bad (b1, is, b2) = bad' b1 is || b2 /= b3
  60   where (_, b3, _) = last is
  61
  62 bad' b [] = False
  63 bad' b ((_, c, _) : is) = b == c || bad' c is
  64
  65 unionIntervals :: IList a -> IList a -> IList a
  66 unionIntervals (isStartOpen, is, isEndOpen) (jsStartOpen, js, jsEndOpen)
  67   = (isStartOpen || jsStartOpen, uniIntervals is js, isEndOpen || jsEndOpen)
  68   where uniIntervals is [] | jsEndOpen = []
  69                            | otherwise = is
  70         uniIntervals [] js | isEndOpen = []
  71                            | otherwise = js
  72         uniIntervals is@(i : is') js@(j : js')
  73           = case cmpI i j of
  74             EQ -> if isEntry i == isEntry j then i : uniIntervals is' js'
  75                                             else uniIntervals is' js'
  76             LT -> if isEntry j then i : uniIntervals is' js
  77                                else     uniIntervals is' js
  78             GT -> if isEntry i then j : uniIntervals is js'
  79                                else     uniIntervals is js'
  80
  81 intersectIntervals :: IList a -> IList a -> IList a
  82 intersectIntervals is js
  83   = complementIntervals (unionIntervals is' js')
  84   where is' = complementIntervals is
  85         js' = complementIntervals js
  86
  87 differenceIntervals :: IList a -> IList a -> IList a
  88 differenceIntervals is js
  89   = complementIntervals (unionIntervals is' js)
  90   where is' = complementIntervals is
  91
  92 complementIntervals :: IList a -> IList a
  93 complementIntervals (o1, is, o2)
  94   = (not o1, [ (i, not isentry, a) | (i, isentry, a) <- is ], not o2)
  95
  96 -- tests...
  97
  98 {-
  99 mkIn, mkOut :: Double -> Intersection a
 100 mkIn x = (x, True, undefined)
 101 mkOut x = (x, False, undefined)
 102
 103 i1 =  (False, [ mkIn 2, mkOut 7 ], False)
 104 i1' = (True, [ mkOut 2, mkIn 7 ], True)
 105 i2 =  (False, [ mkIn 1, mkOut 3, mkIn 4, mkOut 5, mkIn 6, mkOut 8 ], False)
 106
 107 t1 = unionIntervals i1 i2
 108 t2 = intersectIntervals i1 i2
 109 t3 = intersectIntervals i2 i1
 110 t4 = complementIntervals i1
 111 t5 = intersectIntervals i2 i1'
 112 t6 = differenceIntervals i2 i1
 113 t7 = differenceIntervals i2 i2
 114
 115 sh (o1,is,o2) =
 116     do  if o1 then putStr "..." else return ()
 117         putStr $ foldr1 (++) (map si is)
 118         if o2 then putStr "..." else return ()
 119 si (i, True, _, _) = "<" ++ show i
 120 si (i, False, _, _) = " " ++ show i ++ ">"
 121 -}