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 -- never entered-- never enteredShow
   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 -- never entered-- never enteredShow
   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 (-- never entered-- never enteredShow)
   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 -- entered onceunion 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 -- never enteredintersect p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Intersect p q)
   79 intersect p q = Intersect p q
   80 
   81 -- never entereddifference (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 -- entered oncemkBox b p = Box b p
   87 
   88 plane, sphere, cube, cylinder, cone     :: a -> CSG a
   89 
   90 -- entered onceplane = Plane
   91 -- never enteredsphere s =
   92     mkBox (B (-1 - epsilon) (1 + epsilon)
   93              (-1 - epsilon) (1 + epsilon)
   94              (-1 - epsilon) (1 + epsilon)) (Sphere s)
   95 -- never enteredcone s =
   96     mkBox (B (-1 - epsilon) (1 + epsilon)
   97              (   - epsilon) (1 + epsilon)
   98              (-1 - epsilon) (1 + epsilon)) (Cone s)
   99 -- entered oncecube s =
  100     mkBox (B (- epsilon) (1 + epsilon)
  101              (- epsilon) (1 + epsilon)
  102              (- epsilon) (1 + epsilon)) (Cube s)
  103 -- never enteredcylinder 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 -- entered 15 timestransform (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 -- entered 3 timestranslate xyz = transform $ transM xyz
  127 -- never enteredtranslateX x = translate (x, 0, 0)
  128 -- never enteredtranslateY y = translate (0, y, 0)
  129 -- never enteredtranslateZ 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 -- entered oncescale xyz = transform $ scaleM xyz
  135 -- never enteredscaleX x = scale (x, 1, 1)
  136 -- never enteredscaleY y = scale (1, y, 1)
  137 -- never enteredscaleZ z = scale (1, 1, z)
  138 -- entered onceuscale u = scale (u,u,u)
  139 
  140 rotateX, rotateY, rotateZ               :: Radian -> CSG a -> CSG a
  141 
  142 -- entered oncerotateX a = transform $ rotxM a
  143 -- entered oncerotateY a = transform $ rotyM a
  144 -- never enteredrotateZ a = transform $ rotzM a
  145 
  146 -- entered onceunit = 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 -- entered 3 timestransM (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 -- entered oncescaleM (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 -- entered oncerotxM 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 -- entered oncerotyM 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 -- never enteredrotzM 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 -- entered onceeye = (unit, unit)
  228 -- never enteredtranslateEye xyz (eye1, eye2)
  229   = (multMM m1 eye1, multMM eye2 m2)
  230   where (m1, m2) = transM xyz
  231 -- never enteredrotateEyeX t (eye1, eye2)
  232   = (multMM m1 eye1, multMM eye2 m2)
  233   where (m1, m2) = rotxM t
  234 -- never enteredrotateEyeY t (eye1, eye2)
  235   = (multMM m1 eye1, multMM eye2 m2)
  236   where (m1, m2) = rotyM t
  237 -- never enteredrotateEyeZ t (eye1, eye2)
  238   = (multMM m1 eye1, multMM eye2 m2)
  239   where (m1, m2) = rotzM t
  240 
  241 -------------------
  242 -- Bounding boxes
  243 -------------------
  244 
  245 -- never enteredmergeBox (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 -- entered 6 timestransformBox 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]