X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Ftests%2Fprograms%2Fgalois_raytrace%2FConstruct.hs;fp=ghc%2Ftests%2Fprograms%2Fgalois_raytrace%2FConstruct.hs;h=90dbc60f9e5128f8ce06814f18eb9ff091af2803;hb=75a7e5ff20dbc3f3b583d31b4a1ff0b6a1459d49;hp=0000000000000000000000000000000000000000;hpb=49ddc1b81d98bfed558bef41a8fc76e9602c5f05;p=ghc-hetmet.git diff --git a/ghc/tests/programs/galois_raytrace/Construct.hs b/ghc/tests/programs/galois_raytrace/Construct.hs new file mode 100644 index 0000000..90dbc60 --- /dev/null +++ b/ghc/tests/programs/galois_raytrace/Construct.hs @@ -0,0 +1,265 @@ +-- 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]