1 files changed, 115 insertions, 0 deletions
diff --git a/testsuite/tests/programs/galois_raytrace/Surface.hs b/testsuite/tests/programs/galois_raytrace/Surface.hs
new file mode 100644
index 0000000000..832f0fcae2
--- /dev/null
+++ b/testsuite/tests/programs/galois_raytrace/Surface.hs
@@ -0,0 +1,115 @@
+-- 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 Surface
+    ( SurfaceFn (..)
+    , Properties
+    , sfun, sconst
+    , prop
+    , matte, shiny
+    , chgColor
+    , surface
+    ) where
+
+import Geometry
+import CSG
+import Misc
+
+-- the surface gets passed face then u then v.
+data SurfaceFn c v = SFun (Int -> Double -> Double -> Properties c v)
+                   | SConst (Properties c v)
+
+sfun :: (Int -> Double -> Double -> Properties c v) -> SurfaceFn c v
+sfun = SFun
+sconst :: Properties c v -> SurfaceFn c v
+sconst = SConst
+
+type Properties c v = (c, v, v, v)
+
+prop c d s p = (c, d, s, p)
+
+matte = (white, 1.0, 0.0, 1.0)
+shiny = (white, 0.0, 1.0, 1.0)
+
+chgColor :: c -> Properties d v -> Properties c v
+chgColor c (_, d, s, p) = (c, d, s, p)
+
+instance (Show c, Show v) => Show (SurfaceFn c v) where
+  show (SFun _)   = "Surface function"
+  -- show (SConst p) = "Surface constant: " ++ show p
+  show (SConst p) = "Surface constant"
+
+evalSurface :: SurfaceFn Color Double -> Int -> Double -> Double -> Properties Color Double
+evalSurface (SConst p) = \_ _ _ -> p
+evalSurface (SFun f)   = f
+
+-- calculate surface properties, given the type of
+-- surface, and intersection point in object coordinates
+
+-- surface :: Surface SurfaceFn -> (Int, Point) -> (Vector, Properties)
+
+surface (Planar _ v0 v1) (n, p0, fn)
+  = (norm, evalSurface fn n' u v)
+  where norm = normalize $ cross v0 v1
+	(n', u, v) = planarUV n p0
+
+surface (Spherical _ v0 v1) (_, p0, fn)
+  = (norm, evalSurface fn 0 u v)
+  where x = xCoord p0
+	y = yCoord p0
+	z = zCoord p0
+	k = sqrt (1 - sq y)
+	theta = adjustRadian (atan2 (x / k) (z / k))
+	-- correct so that the image grows left-to-right
+	-- instead of right-to-left
+	u = 1.0 - clampf (theta / (2 * pi))
+	v =       clampf ((y + 1) / 2)
+	norm = normalize $ cross v0 v1
+
+-- ZZ ignore the (incorrect) surface model, and estimate the normal
+-- from the intersection in object space
+surface (Cylindrical _ v0 v1) (_, p0, fn)
+  = (norm, evalSurface fn 0 u v)
+  where x = xCoord p0
+	y = yCoord p0
+	z = zCoord p0
+	u = clampf $ adjustRadian (atan2 x z) / (2 * pi)
+	v = y
+	norm = normalize $ cross v0 v1
+
+-- ZZ ignore the (incorrect) surface model, and estimate the normal
+-- from the intersection in object space
+surface (Conic _ v0 v1) (_, p0, fn)
+  = (norm, evalSurface fn 0 u v)
+  where x = xCoord p0
+	y = yCoord p0
+	z = zCoord p0
+	u = clampf $ adjustRadian (atan2 (x / y) (z / y)) / (2 * pi)
+	v = y
+	norm = normalize $ cross v0 v1
+
+planarUV face p0
+  = case face of
+    PlaneFace      -> (0, x, z)
+
+    CubeFront      -> (0, x, y)
+    CubeBack       -> (1, x, y)
+    CubeLeft       -> (2, z, y)
+    CubeRight      -> (3, z, y)
+    CubeTop        -> (4, x, z)
+    CubeBottom     -> (5, x, z)
+
+    CylinderTop    -> (1, (x + 1) / 2, (z + 1) / 2)
+    CylinderBottom -> (2, (x + 1) / 2, (z + 1) / 2)
+
+    ConeBase       -> (1, (x + 1) / 2, (z + 1) / 2)
+  where x = xCoord p0
+	y = yCoord p0
+	z = zCoord p0
+
+-- misc
+
+adjustRadian :: Radian -> Radian
+adjustRadian r = if r > 0 then r else r + 2 * pi