ghc/tests/programs/galois_raytrace/Construct.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 Construct
   7     ( Surface (..)
   8     , Face (..)
   9     , CSG (..)
  10     , Texture
  11     , Transform
  12     , union, intersect, difference
  13     , plane, sphere, cube, cylinder, cone
  14     , transform
  15     , translate, translateX, translateY, translateZ
  16     , scale, scaleX, scaleY, scaleZ, uscale
  17     , rotateX, rotateY, rotateZ
  18     , eye, translateEye
  19     , rotateEyeX, rotateEyeY, rotateEyeZ
  20     ) where
  21
  22 import Geometry
  23
  24 -- In each case, we model the surface by a point and a pair of tangent vectors.
  25 -- This gives us enough information to determine the surface
  26 -- normal at that point, which is all that is required by the current
  27 -- illumination model.  We can't just save the surface normal because
  28 -- that isn't preserved by transformations.
  29
  30 data Surface
  31   = Planar Point Vector Vector
  32   | Spherical Point Vector Vector
  33   | Cylindrical Point Vector Vector
  34   | Conic Point Vector Vector
  35   deriving Show
  36
  37 data Face
  38   = PlaneFace
  39   | SphereFace
  40   | CubeFront
  41   | CubeBack
  42   | CubeLeft
  43   | CubeRight
  44   | CubeTop
  45   | CubeBottom
  46   | CylinderSide
  47   | CylinderTop
  48   | CylinderBottom
  49   | ConeSide
  50   | ConeBase
  51   deriving Show
  52
  53 data CSG a
  54   = Plane a
  55   | Sphere a
  56   | Cylinder a
  57   | Cube a
  58   | Cone a
  59   | Transform Matrix Matrix (CSG a)
  60   | Union (CSG a) (CSG a)
  61   | Intersect (CSG a) (CSG a)
  62   | Difference (CSG a) (CSG a)
  63   | Box Box (CSG a)
  64   deriving (Show)
  65
  66 -- the data returned for determining surface texture
  67 -- the Face tells which face of a primitive this is
  68 -- the Point is the point of intersection in object coordinates
  69 -- the a is application-specific texture information
  70 type Texture a = (Face, Point, a)
  71
  72 union, intersect, difference            :: CSG a -> CSG a -> CSG a
  73
  74 union p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Union p q)
  75 union p q = Union p q
  76
  77 -- rather pessimistic
  78 intersect p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Intersect p q)
  79 intersect p q = Intersect p q
  80
  81 difference (Box b1 p) q = Box b1 (Difference p q)
  82 -- no need to box again inside
  83 -- difference p@(Box b1 _) q = Box b1 (Difference p q)
  84 difference p q = Difference p q
  85
  86 mkBox b p = Box b p
  87
  88 plane, sphere, cube, cylinder, cone     :: a -> CSG a
  89
  90 plane = Plane
  91 sphere s =
  92     mkBox (B (-1 - epsilon) (1 + epsilon)
  93              (-1 - epsilon) (1 + epsilon)
  94              (-1 - epsilon) (1 + epsilon)) (Sphere s)
  95 cone s =
  96     mkBox (B (-1 - epsilon) (1 + epsilon)
  97              (   - epsilon) (1 + epsilon)
  98              (-1 - epsilon) (1 + epsilon)) (Cone s)
  99 cube s =
 100     mkBox (B (- epsilon) (1 + epsilon)
 101              (- epsilon) (1 + epsilon)
 102              (- epsilon) (1 + epsilon)) (Cube s)
 103 cylinder s =
 104     mkBox (B (-1 - epsilon) (1 + epsilon)
 105              (   - epsilon) (1 + epsilon)
 106              (-1 - epsilon) (1 + epsilon)) (Cylinder s)
 107
 108 ----------------------------
 109 -- Object transformations
 110 ----------------------------
 111
 112 type Transform = (Matrix, Matrix)
 113
 114 transform :: Transform -> CSG a -> CSG a
 115
 116 transform (m, m')   (Transform mp mp' p) = Transform  (multMM m mp)       (multMM mp' m') p
 117 transform mm'       (Union p q)          = Union      (transform mm' p)   (transform mm' q)
 118 transform mm'       (Intersect p q)      = Intersect  (transform mm' p)   (transform mm' q)
 119 transform mm'       (Difference p q)     = Difference (transform mm' p)   (transform mm' q)
 120 transform mm'@(m,_) (Box box p)          = Box        (transformBox m box) (transform mm' p)
 121 transform (m, m')   prim                 = Transform  m m' prim
 122
 123 translate                               :: Coords -> CSG a -> CSG a
 124 translateX, translateY, translateZ      :: Double -> CSG a -> CSG a
 125
 126 translate xyz = transform $ transM xyz
 127 translateX x = translate (x, 0, 0)
 128 translateY y = translate (0, y, 0)
 129 translateZ z = translate (0, 0, z)
 130
 131 scale                                   :: Coords -> CSG a -> CSG a
 132 scaleX, scaleY, scaleZ, uscale          :: Double -> CSG a -> CSG a
 133
 134 scale xyz = transform $ scaleM xyz
 135 scaleX x = scale (x, 1, 1)
 136 scaleY y = scale (1, y, 1)
 137 scaleZ z = scale (1, 1, z)
 138 uscale u = scale (u,u,u)
 139
 140 rotateX, rotateY, rotateZ               :: Radian -> CSG a -> CSG a
 141
 142 rotateX a = transform $ rotxM a
 143 rotateY a = transform $ rotyM a
 144 rotateZ a = transform $ rotzM a
 145
 146 unit = matrix
 147       ( ( 1.0, 0.0, 0.0, 0.0 ),
 148         ( 0.0, 1.0, 0.0, 0.0 ),
 149         ( 0.0, 0.0, 1.0, 0.0 ),
 150         ( 0.0, 0.0, 0.0, 1.0 ) )
 151
 152 transM (x, y, z)
 153   = ( matrix
 154       ( ( 1, 0, 0, x ),
 155         ( 0, 1, 0, y ),
 156         ( 0, 0, 1, z ),
 157         ( 0, 0, 0, 1 ) ),
 158       matrix
 159       ( ( 1, 0, 0, -x ),
 160         ( 0, 1, 0, -y ),
 161         ( 0, 0, 1, -z ),
 162         ( 0, 0, 0,  1 ) ) )
 163
 164 scaleM (x, y, z)
 165   = ( matrix
 166       ( (   x',    0,    0, 0 ),
 167         (    0,   y',    0, 0 ),
 168         (    0,    0,   z', 0 ),
 169         (    0,    0,    0, 1 ) ),
 170       matrix
 171       ( ( 1/x',    0,    0, 0 ),
 172         (    0, 1/y',    0, 0 ),
 173         (    0,    0, 1/z', 0 ),
 174         (    0,    0,    0, 1 ) ) )
 175   where x' = nonZero x
 176         y' = nonZero y
 177         z' = nonZero z
 178
 179 rotxM t
 180   = ( matrix
 181       ( (      1,      0,      0, 0 ),
 182         (      0,  cos t, -sin t, 0 ),
 183         (      0,  sin t,  cos t, 0 ),
 184         (      0,      0,      0, 1 ) ),
 185       matrix
 186       ( (      1,      0,      0, 0 ),
 187         (      0,  cos t,  sin t, 0 ),
 188         (      0, -sin t,  cos t, 0 ),
 189         (      0,      0,      0, 1 ) ) )
 190
 191 rotyM t
 192   = ( matrix
 193       ( (  cos t,      0,  sin t, 0 ),
 194         (      0,      1,      0, 0 ),
 195         ( -sin t,      0,  cos t, 0 ),
 196         (      0,      0,      0, 1 ) ),
 197       matrix
 198       ( (  cos t,      0, -sin t, 0 ),
 199         (      0,      1,      0, 0 ),
 200         (  sin t,      0,  cos t, 0 ),
 201         (      0,      0,      0, 1 ) ) )
 202
 203 rotzM t
 204   = ( matrix
 205       ( (  cos t, -sin t,      0, 0 ),
 206         (  sin t,  cos t,      0, 0 ),
 207         (      0,      0,      1, 0 ),
 208         (      0,      0,      0, 1 ) ),
 209       matrix
 210       ( (  cos t,  sin t,      0, 0 ),
 211         ( -sin t,  cos t,      0, 0 ),
 212         (      0,      0,      1, 0 ),
 213         (      0,      0,      0, 1 ) ) )
 214
 215 -------------------
 216 -- Eye transformations
 217
 218 -- These are used to specify placement of the eye.
 219 -- `eye' starts out at (0, 0, -1).
 220 -- These are implemented as inverse transforms of the model.
 221 -------------------
 222
 223 eye                                     :: Transform
 224 translateEye                            :: Coords -> Transform -> Transform
 225 rotateEyeX, rotateEyeY, rotateEyeZ      :: Radian -> Transform -> Transform
 226
 227 eye = (unit, unit)
 228 translateEye xyz (eye1, eye2)
 229   = (multMM m1 eye1, multMM eye2 m2)
 230   where (m1, m2) = transM xyz
 231 rotateEyeX t (eye1, eye2)
 232   = (multMM m1 eye1, multMM eye2 m2)
 233   where (m1, m2) = rotxM t
 234 rotateEyeY t (eye1, eye2)
 235   = (multMM m1 eye1, multMM eye2 m2)
 236   where (m1, m2) = rotyM t
 237 rotateEyeZ t (eye1, eye2)
 238   = (multMM m1 eye1, multMM eye2 m2)
 239   where (m1, m2) = rotzM t
 240
 241 -------------------
 242 -- Bounding boxes
 243 -------------------
 244
 245 mergeBox (B x11  x12  y11  y12  z11  z12) (B x21  x22  y21  y22  z21  z22) =
 246     B (x11 `min` x21) (x12 `max` x22)
 247       (y11 `min` y21) (y12 `max` y22)
 248       (z11 `min` z21) (z12 `max` z22)
 249
 250 transformBox t (B x1  x2  y1  y2  z1  z2)
 251   = (B (foldr1 min (map xCoord pts'))
 252        (foldr1 max (map xCoord pts'))
 253        (foldr1 min (map yCoord pts'))
 254        (foldr1 max (map yCoord pts'))
 255        (foldr1 min (map zCoord pts'))
 256        (foldr1 max (map zCoord pts')))
 257   where pts' = map (multMP t) pts
 258         pts =  [point x1 y1 z1,
 259                 point x1 y1 z2,
 260                 point x1 y2 z1,
 261                 point x1 y2 z2,
 262                 point x2 y1 z1,
 263                 point x2 y1 z2,
 264                 point x2 y2 z1,
 265                 point x2 y2 z2]