ghc/tests/programs/galois_raytrace/Surface.hs

   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 Surface
   7     ( SurfaceFn (..)
   8     , Properties
   9     , sfun, sconst
  10     , prop
  11     , matte, shiny
  12     , chgColor
  13     , surface
  14     ) where
  15
  16 import Geometry
  17 import CSG
  18 import Misc
  19
  20 -- the surface gets passed face then u then v.
  21 data SurfaceFn c v = SFun (Int -> Double -> Double -> Properties c v)
  22                    | SConst (Properties c v)
  23
  24 sfun :: (Int -> Double -> Double -> Properties c v) -> SurfaceFn c v
  25 sfun = SFun
  26 sconst :: Properties c v -> SurfaceFn c v
  27 sconst = SConst
  28
  29 type Properties c v = (c, v, v, v)
  30
  31 prop c d s p = (c, d, s, p)
  32
  33 matte = (white, 1.0, 0.0, 1.0)
  34 shiny = (white, 0.0, 1.0, 1.0)
  35
  36 chgColor :: c -> Properties d v -> Properties c v
  37 chgColor c (_, d, s, p) = (c, d, s, p)
  38
  39 instance (Show c, Show v) => Show (SurfaceFn c v) where
  40   show (SFun _)   = "Surface function"
  41   -- show (SConst p) = "Surface constant: " ++ show p
  42   show (SConst p) = "Surface constant"
  43
  44 evalSurface :: SurfaceFn Color Double -> Int -> Double -> Double -> Properties Color Double
  45 evalSurface (SConst p) = \_ _ _ -> p
  46 evalSurface (SFun f)   = f
  47
  48 -- calculate surface properties, given the type of
  49 -- surface, and intersection point in object coordinates
  50
  51 -- surface :: Surface SurfaceFn -> (Int, Point) -> (Vector, Properties)
  52
  53 surface (Planar _ v0 v1) (n, p0, fn)
  54   = (norm, evalSurface fn n' u v)
  55   where norm = normalize $ cross v0 v1
  56         (n', u, v) = planarUV n p0
  57
  58 surface (Spherical _ v0 v1) (_, p0, fn)
  59   = (norm, evalSurface fn 0 u v)
  60   where x = xCoord p0
  61         y = yCoord p0
  62         z = zCoord p0
  63         k = sqrt (1 - sq y)
  64         theta = adjustRadian (atan2 (x / k) (z / k))
  65         -- correct so that the image grows left-to-right
  66         -- instead of right-to-left
  67         u = 1.0 - clampf (theta / (2 * pi))
  68         v =       clampf ((y + 1) / 2)
  69         norm = normalize $ cross v0 v1
  70
  71 -- ZZ ignore the (incorrect) surface model, and estimate the normal
  72 -- from the intersection in object space
  73 surface (Cylindrical _ v0 v1) (_, p0, fn)
  74   = (norm, evalSurface fn 0 u v)
  75   where x = xCoord p0
  76         y = yCoord p0
  77         z = zCoord p0
  78         u = clampf $ adjustRadian (atan2 x z) / (2 * pi)
  79         v = y
  80         norm = normalize $ cross v0 v1
  81
  82 -- ZZ ignore the (incorrect) surface model, and estimate the normal
  83 -- from the intersection in object space
  84 surface (Conic _ v0 v1) (_, p0, fn)
  85   = (norm, evalSurface fn 0 u v)
  86   where x = xCoord p0
  87         y = yCoord p0
  88         z = zCoord p0
  89         u = clampf $ adjustRadian (atan2 (x / y) (z / y)) / (2 * pi)
  90         v = y
  91         norm = normalize $ cross v0 v1
  92
  93 planarUV face p0
  94   = case face of
  95     PlaneFace      -> (0, x, z)
  96
  97     CubeFront      -> (0, x, y)
  98     CubeBack       -> (1, x, y)
  99     CubeLeft       -> (2, z, y)
 100     CubeRight      -> (3, z, y)
 101     CubeTop        -> (4, x, z)
 102     CubeBottom     -> (5, x, z)
 103
 104     CylinderTop    -> (1, (x + 1) / 2, (z + 1) / 2)
 105     CylinderBottom -> (2, (x + 1) / 2, (z + 1) / 2)
 106
 107     ConeBase       -> (1, (x + 1) / 2, (z + 1) / 2)
 108   where x = xCoord p0
 109         y = yCoord p0
 110         z = zCoord p0
 111
 112 -- misc
 113
 114 adjustRadian :: Radian -> Radian
 115 adjustRadian r = if r > 0 then r else r + 2 * pi