+++ /dev/null
--- 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]
projects / ghc-hetmet.git / blobdiff