ghc/tests/programs/galois_raytrace/Illumination.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 -- Modified to use stdout (for testing)
   7
   8 module Illumination
   9     ( Object
  10     , Light (..)
  11     , light, pointlight, spotlight
  12     , render
  13     ) where
  14
  15 import Array
  16 import Char(chr)
  17 import IOExts
  18 import Maybe
  19
  20 import Geometry
  21 import CSG
  22 import Surface
  23 import Misc
  24
  25 type Object = CSG (SurfaceFn Color Double)
  26
  27 data Cxt = Cxt {ambient::Color, lights::[Light], object::Object, depth::Int}
  28         deriving Show
  29
  30 render :: (Matrix,Matrix) -> Color -> [Light] -> Object -> Int ->
  31           Radian -> Int -> Int -> String -> IO ()
  32 render (m,m') amb ls obj dep fov wid ht file
  33   = do { debugging
  34        ; putStrLn (showBitmap wid ht pixels)
  35        }
  36   where
  37     debugging = return ()
  38 {-
  39                 do { putStrLn (show cxt)
  40                    ; putStrLn (show (width, delta, aspect, left, top))
  41                    }
  42 -}
  43     obj' = transform (m',m) obj
  44     ls'  = [ transformLight m' l | l <- ls ]
  45     pixelA = listArray ((1,1), (ht,wid))
  46                        [ illumination cxt (start,pixel i j)
  47                        | j <- take ht  [0.5..]
  48                        , i <- take wid [0.5..] ]
  49     antiA  = pixelA //
  50              [ (ix, superSample ix (pixelA ! ix))
  51              | j <- [2 .. ht - 1], i <- [2 .. wid - 1]
  52              , let ix = (j, i)
  53              , contrast ix pixelA ]
  54     pixels = [ [ illumination cxt (start,pixel i j) | i<- take wid [0.5..] ]
  55              | j <- take ht [0.5..]
  56              ]
  57     cxt    = Cxt {ambient=amb, lights=ls',  object=obj', depth=dep}
  58     start  = point  0 0 (-1)
  59     width  = 2 * tan (fov/2)
  60     delta  = width / fromIntegral wid
  61     aspect = fromIntegral ht / fromIntegral wid
  62     left   = - width / 2
  63     top    = - left * aspect
  64     pixel i j = vector (left + i*delta) (top - j*delta) 1
  65
  66     superSample (y, x) col = avg $ col:
  67       [ illumination cxt (start, pixel (fromIntegral x - 0.5 + xd) (fromIntegral y - 0.5 + yd))
  68       | (xd, yd) <- [(-0.333, 0.0), (0.333, 0.0), (0.0, -0.333), (0.0, 0.333)]
  69       ]
  70
  71 avg cs = divN (fromIntegral (length cs)) (uncolor (sumCC cs))
  72   where divN n (r,g,b) = color (r / n) (g / n) (b / n)
  73
  74 contrast :: (Int, Int) -> Array (Int, Int) Color -> Bool
  75 contrast (x, y) arr = any diffMax [ subCC cur (arr ! (x + xd, y + yd))
  76                                   | xd <- [-1, 1], yd <- [-1, 1]
  77                                   ]
  78   where cur = arr ! (x, y)
  79         diffMax col = (abs r) > 0.25 || (abs g) >  0.2 || (abs b) > 0.4
  80            where
  81                  (r,g,b) = uncolor col
  82
  83
  84 illumination :: Cxt -> Ray -> Color
  85 illumination cxt (r,v)
  86   | depth cxt <= 0 = black
  87   | otherwise     = case castRay (r,v) (object cxt) of
  88                       Nothing -> black
  89                       Just info -> illum (cxt{depth=(depth cxt)-1}) info v
  90
  91 illum :: Cxt -> (Point,Vector,Properties Color Double) -> Vector -> Color
  92 illum cxt (pos,normV,(col,kd,ks,n)) v
  93   = ambTerm `addCC` difTerm `addCC` spcTerm `addCC` recTerm
  94   where
  95     visibleLights = unobscured pos (object cxt) (lights cxt) normV
  96     d = depth cxt
  97     amb = ambient cxt
  98     newV = subVV v (multSV (2 * dot normV v) normV)
  99
 100     ambTerm = multSC kd (multCC amb col)
 101     difTerm = multSC kd (sumCC [multSC (dot normV lj) (multCC intensity col)
 102                |(loc,intensity) <- visibleLights,
 103                let lj = normalize ({- pos `subVV` -} loc)])
 104     -- ZZ might want to avoid the phong, when you can...
 105     spcTerm = multSC ks (sumCC [multSC ((dot normV hj) ** n ) (multCC intensity col)
 106                |(loc,intensity) <- visibleLights,
 107                -- ZZ note this is specific to the light at infinity
 108                let lj = {- pos `subVV` -} normalize loc,
 109                let hj = normalize (lj `subVV` normalize v)])
 110     recTerm  = if recCoeff `nearC` black then black else multCC recCoeff recRay
 111     recCoeff = multSC ks col
 112     recRay   = illumination cxt (pos,newV)
 113
 114 showBitmapA :: Int -> Int -> Array (Int, Int) Color -> String
 115 showBitmapA wid ht arr
 116   = header ++ concatMap scaleColor (elems arr)
 117   where
 118     scaleColor col = [scalePixel r, scalePixel g, scalePixel b]
 119            where (r,g,b) = uncolor col
 120     header = "P6\n#Galois\n" ++ show wid ++ " " ++ show ht ++ "\n255\n"
 121
 122 showBitmap :: Int -> Int ->[[Color]] -> String
 123 showBitmap wid ht pss
 124 -- type of assert  | length pss == ht && all (\ ps -> length ps == wid) pss
 125   = header ++ concat [[scalePixel r,scalePixel g,scalePixel b]
 126                       | ps <- pss, (r,g,b) <- map uncolor ps]
 127   where
 128     header = "P6\n#Galois\n" ++ show wid ++ " " ++ show ht ++ "\n255\n"
 129 showBitmap _ _ _ = error "incorrect length of bitmap string"
 130
 131 scalePixel :: Double -> Char
 132 scalePixel p = chr (floor (clampf p * 255))
 133
 134
 135 -- Lights
 136
 137 data Light = Light Vector Color
 138            | PointLight Point Color
 139            | SpotLight Point Point Color Radian Double
 140    deriving Show
 141
 142 light :: Coords -> Color -> Light
 143 light (x,y,z) color =
 144   Light (normalize (vector (-x) (-y) (-z))) color
 145 pointlight (x,y,z) color =
 146   PointLight (point x y z) color
 147 spotlight (x,y,z) (p,q,r) col cutoff exp =
 148   SpotLight (point x y z) (point p q r) col cutoff exp
 149
 150 transformLight m (Light v c) = Light (multMV m v) c
 151 transformLight m (PointLight p c) = PointLight (multMP m p) c
 152 transformLight m (SpotLight p q c r d) = SpotLight (multMP m p) (multMP m q) c r d
 153
 154 unobscured :: Point -> Object -> [Light] ->  Vector -> [(Vector,Color)]
 155 unobscured pos obj lights normV = catMaybes (map (unobscure pos obj normV) lights)
 156
 157 unobscure :: Point -> Object -> Vector ->  Light -> Maybe (Vector,Color)
 158 unobscure pos obj normV (Light vec color)
 159   -- ZZ probably want to make this faster
 160   | vec `dot` normV < 0 = Nothing
 161   | intersects (pos `addPV` (0.0001 `multSV` vec),vec) obj = Nothing
 162   | otherwise               = Just (vec,color)
 163 unobscure pos obj normV (PointLight pp color)
 164   | vec `dot` normV < 0     = Nothing
 165   | intersectWithin (pos `addPV` (0.0001 `multSV` (normalize vec)), vec) obj = Nothing
 166   | otherwise               = Just (vec,is)
 167       where vec = pp `subPP` pos
 168             is  = attenuate vec color
 169 unobscure org obj normV (SpotLight pos at color cutoff exp)
 170   | vec `dot` normV < 0                                                 = Nothing
 171   | intersectWithin (org `addPV` (0.0001 `multSV` (normalize vec)), vec) obj = Nothing
 172   | angle > cutoff                                                      = Nothing
 173   | otherwise                                                           = Just (vec, is)
 174       where vec   = pos `subPP` org
 175             vec'  = pos `subPP` at
 176             angle = acos (normalize vec `dot` (normalize vec'))
 177
 178             asp   = normalize (at `subPP` pos)
 179             qsp   = normalize (org `subPP` pos)
 180             is    = attenuate vec (((asp `dot` qsp) ** exp) `multSC` color)
 181
 182 attenuate :: Vector -> Color -> Color
 183 attenuate vec color = (100 / (99 + sq (norm vec))) `multSC` color
 184
 185 --
 186
 187 castRay ray p
 188   = case intersectRayWithObject ray p of
 189     (True, _, _)                     -> Nothing -- eye is inside
 190     (False, [], _)                   -> Nothing -- eye is inside
 191     (False, (0, b, _) : _, _)        -> Nothing -- eye is inside
 192     (False, (i, False, _) : _, _)    -> Nothing -- eye is inside
 193     (False, (t, b, (s, p0)) : _, _)     ->
 194         let (v, prop) = surface s p0 in
 195             Just (offsetToPoint ray t, v, prop)
 196
 197 intersects ray p
 198   = case intersectRayWithObject ray p of
 199     (True, _, _)                  -> False
 200     (False, [], _)                -> False
 201     (False, (0, b, _) : _, _)     -> False
 202     (False, (i, False, _) : _, _) -> False
 203     (False, (i, b, _) : _, _)     -> True
 204
 205 intersectWithin :: Ray -> Object -> Bool
 206 intersectWithin ray p
 207   = case intersectRayWithObject ray p of
 208     (True, _, _)                  -> False -- eye is inside
 209     (False, [], _)                -> False -- eye is inside
 210     (False, (0, b, _) : _, _)     -> False -- eye is inside
 211     (False, (i, False, _) : _, _) -> False -- eye is inside
 212     (False, (t, b, _) : _, _)     -> t < 1.0