content: -- Copyright (c) 2000 Galois Connections, Inc.
  -- All rights reserved.  This software is distributed as
  -- free software under the license in the file "LICENSE",
  -- which is included in the distribution.
  
  module Construct
      ( Surface (..)
      , Face (..)
      , CSG (..)
      , Texture
      , Transform
      , union, intersect, difference
      , plane, sphere, cube, cylinder, cone
      , transform
      , translate, translateX, translateY, translateZ
      , scale, scaleX, scaleY, scaleZ, uscale
      , rotateX, rotateY, rotateZ
      , eye, translateEye
      , rotateEyeX, rotateEyeY, rotateEyeZ
      ) where
  
  import Geometry
  
  -- In each case, we model the surface by a point and a pair of tangent vectors.
  -- This gives us enough information to determine the surface
  -- normal at that point, which is all that is required by the current
  -- illumination model.  We can't just save the surface normal because
  -- that isn't preserved by transformations.
  
  data Surface
    = Planar Point Vector Vector
    | Spherical Point Vector Vector
    | Cylindrical Point Vector Vector
    | Conic Point Vector Vector
    deriving Show
  
  data Face
    = PlaneFace
    | SphereFace
    | CubeFront
    | CubeBack
    | CubeLeft
    | CubeRight
    | CubeTop
    | CubeBottom
    | CylinderSide
    | CylinderTop
    | CylinderBottom
    | ConeSide
    | ConeBase
    deriving Show
  
  data CSG a
    = Plane a
    | Sphere a
    | Cylinder a
    | Cube a
    | Cone a
    | Transform Matrix Matrix (CSG a)
    | Union (CSG a) (CSG a)
    | Intersect (CSG a) (CSG a)
    | Difference (CSG a) (CSG a)
    | Box Box (CSG a)
    deriving (Show)
  
  -- the data returned for determining surface texture
  -- the Face tells which face of a primitive this is
  -- the Point is the point of intersection in object coordinates
  -- the a is application-specific texture information
  type Texture a = (Face, Point, a)
  
  union, intersect, difference		:: CSG a -> CSG a -> CSG a
  
  union p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Union p q)
  union p q = Union p q
  
  -- rather pessimistic
  intersect p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Intersect p q)
  intersect p q = Intersect p q
  
  difference (Box b1 p) q = Box b1 (Difference p q)
  -- no need to box again inside
  -- difference p@(Box b1 _) q = Box b1 (Difference p q)
  difference p q = Difference p q
  
  mkBox b p = Box b p
  
  plane, sphere, cube, cylinder, cone	:: a -> CSG a
  
  plane = Plane
  sphere s =
      mkBox (B (-1 - epsilon) (1 + epsilon)
  	     (-1 - epsilon) (1 + epsilon)
  	     (-1 - epsilon) (1 + epsilon)) (Sphere s)
  cone s =
      mkBox (B (-1 - epsilon) (1 + epsilon)
  	     (   - epsilon) (1 + epsilon)
  	     (-1 - epsilon) (1 + epsilon)) (Cone s)
  cube s =
      mkBox (B (- epsilon) (1 + epsilon)
  	     (- epsilon) (1 + epsilon)
  	     (- epsilon) (1 + epsilon)) (Cube s)
  cylinder s =
      mkBox (B (-1 - epsilon) (1 + epsilon)
  	     (   - epsilon) (1 + epsilon)
  	     (-1 - epsilon) (1 + epsilon)) (Cylinder s)
  
  ----------------------------
  -- Object transformations
  ----------------------------
  
  type Transform = (Matrix, Matrix)
  
  transform :: Transform -> CSG a -> CSG a
  
  transform (m, m')   (Transform mp mp' p) = Transform  (multMM m mp)       (multMM mp' m') p
  transform mm'       (Union p q)          = Union      (transform mm' p)   (transform mm' q)
  transform mm'       (Intersect p q)      = Intersect  (transform mm' p)   (transform mm' q)
  transform mm'       (Difference p q)     = Difference (transform mm' p)   (transform mm' q)
  transform mm'@(m,_) (Box box p)          = Box        (transformBox m box) (transform mm' p)
  transform (m, m')   prim                 = Transform  m m' prim
  
  translate				:: Coords -> CSG a -> CSG a
  translateX, translateY, translateZ	:: Double -> CSG a -> CSG a
  
  translate xyz = transform $ transM xyz
  translateX x = translate (x, 0, 0)
  translateY y = translate (0, y, 0)
  translateZ z = translate (0, 0, z)
  
  scale      				:: Coords -> CSG a -> CSG a
  scaleX, scaleY, scaleZ, uscale		:: Double -> CSG a -> CSG a
  
  scale xyz = transform $ scaleM xyz
  scaleX x = scale (x, 1, 1)
  scaleY y = scale (1, y, 1)
  scaleZ z = scale (1, 1, z)
  uscale u = scale (u,u,u)
  
  rotateX, rotateY, rotateZ		:: Radian -> CSG a -> CSG a
  
  rotateX a = transform $ rotxM a
  rotateY a = transform $ rotyM a
  rotateZ a = transform $ rotzM a
  
  unit = matrix
        ( ( 1.0, 0.0, 0.0, 0.0 ),
  	( 0.0, 1.0, 0.0, 0.0 ),
  	( 0.0, 0.0, 1.0, 0.0 ),
  	( 0.0, 0.0, 0.0, 1.0 ) )
  
  transM (x, y, z)
    = ( matrix
        ( ( 1, 0, 0, x ),
  	( 0, 1, 0, y ),
  	( 0, 0, 1, z ),
  	( 0, 0, 0, 1 ) ),
        matrix
        ( ( 1, 0, 0, -x ),
  	( 0, 1, 0, -y ),
  	( 0, 0, 1, -z ),
  	( 0, 0, 0,  1 ) ) )
  
  scaleM (x, y, z)
    = ( matrix
        ( (   x',    0,    0, 0 ),
  	(    0,   y',    0, 0 ),
  	(    0,    0,   z', 0 ),
  	(    0,    0,    0, 1 ) ),
        matrix
        ( ( 1/x',    0,    0, 0 ),
  	(    0, 1/y',    0, 0 ),
  	(    0,    0, 1/z', 0 ),
  	(    0,    0,    0, 1 ) ) )
    where x' = nonZero x
  	y' = nonZero y
  	z' = nonZero z
  
  rotxM t
    = ( matrix
        ( (      1,      0,      0, 0 ),
  	(      0,  cos t, -sin t, 0 ),
  	(      0,  sin t,  cos t, 0 ),
  	(      0,      0,      0, 1 ) ),
        matrix
        ( (      1,      0,      0, 0 ),
  	(      0,  cos t,  sin t, 0 ),
  	(      0, -sin t,  cos t, 0 ),
  	(      0,      0,      0, 1 ) ) )
  
  rotyM t
    = ( matrix
        ( (  cos t,      0,  sin t, 0 ),
  	(      0,      1,      0, 0 ),
  	( -sin t,      0,  cos t, 0 ),
  	(      0,      0,      0, 1 ) ),
        matrix
        ( (  cos t,      0, -sin t, 0 ),
  	(      0,      1,      0, 0 ),
  	(  sin t,      0,  cos t, 0 ),
  	(      0,      0,      0, 1 ) ) )
  
  rotzM t
    = ( matrix
        ( (  cos t, -sin t,      0, 0 ),
  	(  sin t,  cos t,      0, 0 ),
  	(      0,      0,      1, 0 ),
  	(      0,      0,      0, 1 ) ),
        matrix
        ( (  cos t,  sin t,      0, 0 ),
  	( -sin t,  cos t,      0, 0 ),
  	(      0,      0,      1, 0 ),
  	(      0,      0,      0, 1 ) ) )
  
  -------------------
  -- Eye transformations
  
  -- These are used to specify placement of the eye.
  -- `eye' starts out at (0, 0, -1).
  -- These are implemented as inverse transforms of the model.
  -------------------
  
  eye				 	:: Transform
  translateEye				:: Coords -> Transform -> Transform
  rotateEyeX, rotateEyeY, rotateEyeZ	:: Radian -> Transform -> Transform
  
  eye = (unit, unit)
  translateEye xyz (eye1, eye2)
    = (multMM m1 eye1, multMM eye2 m2)
    where (m1, m2) = transM xyz
  rotateEyeX t (eye1, eye2)
    = (multMM m1 eye1, multMM eye2 m2)
    where (m1, m2) = rotxM t
  rotateEyeY t (eye1, eye2)
    = (multMM m1 eye1, multMM eye2 m2)
    where (m1, m2) = rotyM t
  rotateEyeZ t (eye1, eye2)
    = (multMM m1 eye1, multMM eye2 m2)
    where (m1, m2) = rotzM t
  
  -------------------
  -- Bounding boxes
  -------------------
  
  mergeBox (B x11  x12  y11  y12  z11  z12) (B x21  x22  y21  y22  z21  z22) =
      B (x11 `min` x21) (x12 `max` x22)
        (y11 `min` y21) (y12 `max` y22)
        (z11 `min` z21) (z12 `max` z22)
  
  transformBox t (B x1  x2  y1  y2  z1  z2)
    = (B (foldr1 min (map xCoord pts'))
         (foldr1 max (map xCoord pts'))
         (foldr1 min (map yCoord pts'))
         (foldr1 max (map yCoord pts'))
         (foldr1 min (map zCoord pts'))
         (foldr1 max (map zCoord pts')))
    where pts' = map (multMP t) pts
  	pts =  [point x1 y1 z1,
  		point x1 y1 z2,
  		point x1 y2 z1,
  		point x1 y2 z2,
  		point x2 y1 z1,
  		point x2 y1 z2,
  		point x2 y2 z1,
  		point x2 y2 z2]
  