diff options
Diffstat (limited to 'testsuite/tests/programs/galois_raytrace/Illumination.hs')
| -rw-r--r-- | testsuite/tests/programs/galois_raytrace/Illumination.hs | 224 |
1 files changed, 224 insertions, 0 deletions
diff --git a/testsuite/tests/programs/galois_raytrace/Illumination.hs b/testsuite/tests/programs/galois_raytrace/Illumination.hs new file mode 100644 index 0000000000..155a7a9a76 --- /dev/null +++ b/testsuite/tests/programs/galois_raytrace/Illumination.hs @@ -0,0 +1,224 @@ +-- 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. + +-- Modified to use stdout (for testing) + +module Illumination + ( Object + , Light (..) + , light, pointlight, spotlight + , render + ) where + +import Array +import Char(chr) +import Maybe + +import Geometry +import CSG +import Surface +import Misc + +type Object = CSG (SurfaceFn Color Double) + +data Cxt = Cxt {ambient::Color, lights::[Light], object::Object, depth::Int} + deriving Show + +render :: (Matrix,Matrix) -> Color -> [Light] -> Object -> Int -> + Radian -> Int -> Int -> String -> IO () +render (m,m') amb ls obj dep fov wid ht file + = do { debugging + ; putStrLn (showBitmap' wid ht pixels) + } + where + debugging = return () +{- + do { putStrLn (show cxt) + ; putStrLn (show (width, delta, aspect, left, top)) + } +-} + obj' = transform (m',m) obj + ls' = [ transformLight m' l | l <- ls ] + pixelA = listArray ((1,1), (ht,wid)) + [ illumination cxt (start,pixel i j) + | j <- take ht [0.5..] + , i <- take wid [0.5..] ] + antiA = pixelA // + [ (ix, superSample ix (pixelA ! ix)) + | j <- [2 .. ht - 1], i <- [2 .. wid - 1] + , let ix = (j, i) + , contrast ix pixelA ] + pixels = [ [ illumination cxt (start,pixel i j) | i<- take wid [0.5..] ] + | j <- take ht [0.5..] + ] + cxt = Cxt {ambient=amb, lights=ls', object=obj', depth=dep} + start = point 0 0 (-1) + width = 2 * tan (fov/2) + delta = width / fromIntegral wid + aspect = fromIntegral ht / fromIntegral wid + left = - width / 2 + top = - left * aspect + pixel i j = vector (left + i*delta) (top - j*delta) 1 + + superSample (y, x) col = avg $ col: + [ illumination cxt (start, pixel (fromIntegral x - 0.5 + xd) (fromIntegral y - 0.5 + yd)) + | (xd, yd) <- [(-0.333, 0.0), (0.333, 0.0), (0.0, -0.333), (0.0, 0.333)] + ] + +avg cs = divN (fromIntegral (length cs)) (uncolor (sumCC cs)) + where divN n (r,g,b) = color (r / n) (g / n) (b / n) + +contrast :: (Int, Int) -> Array (Int, Int) Color -> Bool +contrast (x, y) arr = any diffMax [ subCC cur (arr ! (x + xd, y + yd)) + | xd <- [-1, 1], yd <- [-1, 1] + ] + where cur = arr ! (x, y) + diffMax col = (abs r) > 0.25 || (abs g) > 0.2 || (abs b) > 0.4 + where + (r,g,b) = uncolor col + + +illumination :: Cxt -> Ray -> Color +illumination cxt (r,v) + | depth cxt <= 0 = black + | otherwise = case castRay (r,v) (object cxt) of + Nothing -> black + Just info -> illum (cxt{depth=(depth cxt)-1}) info v + +illum :: Cxt -> (Point,Vector,Properties Color Double) -> Vector -> Color +illum cxt (pos,normV,(col,kd,ks,n)) v + = ambTerm `addCC` difTerm `addCC` spcTerm `addCC` recTerm + where + visibleLights = unobscured pos (object cxt) (lights cxt) normV + d = depth cxt + amb = ambient cxt + newV = subVV v (multSV (2 * dot normV v) normV) + + ambTerm = multSC kd (multCC amb col) + difTerm = multSC kd (sumCC [multSC (dot normV lj) (multCC intensity col) + |(loc,intensity) <- visibleLights, + let lj = normalize ({- pos `subVV` -} loc)]) + -- ZZ might want to avoid the phong, when you can... + spcTerm = multSC ks (sumCC [multSC ((dot normV hj) ** n ) (multCC intensity col) + |(loc,intensity) <- visibleLights, + -- ZZ note this is specific to the light at infinity + let lj = {- pos `subVV` -} normalize loc, + let hj = normalize (lj `subVV` normalize v)]) + recTerm = if recCoeff `nearC` black then black else multCC recCoeff recRay + recCoeff = multSC ks col + recRay = illumination cxt (pos,newV) + +showBitmapA :: Int -> Int -> Array (Int, Int) Color -> String +showBitmapA wid ht arr + = header ++ concatMap scaleColor (elems arr) + where + scaleColor col = [scalePixel r, scalePixel g, scalePixel b] + where (r,g,b) = uncolor col + header = "P6\n#Galois\n" ++ show wid ++ " " ++ show ht ++ "\n255\n" + +showBitmap :: Int -> Int ->[[Color]] -> String +showBitmap wid ht pss +-- type of assert | length pss == ht && all (\ ps -> length ps == wid) pss + = header ++ concat [[scalePixel r,scalePixel g,scalePixel b] + | ps <- pss, (r,g,b) <- map uncolor ps] + where + header = "P6\n#Galois\n" ++ show wid ++ " " ++ show ht ++ "\n255\n" +showBitmap _ _ _ = error "incorrect length of bitmap string" + +scalePixel :: Double -> Char +scalePixel p = chr (floor (clampf p * 255)) + +showBitmap' :: Int -> Int ->[[Color]] -> String +showBitmap' wid ht pss +-- type of assert | length pss == ht && all (\ ps -> length ps == wid) pss + = header + ++ unlines [ unwords [unwords [scalePixel' r,scalePixel' g,scalePixel' b] + | (r,g,b) <- map uncolor ps] + | ps <- pss ] + where + header = "P3\n#Galois\n" ++ show wid ++ " " ++ show ht ++ "\n255\n" +showBitmap' _ _ _ = error "incorrect length of bitmap string" + +scalePixel' :: Double -> String +scalePixel' p = show (floor (clampf p * 255)) + +-- Lights + +data Light = Light Vector Color + | PointLight Point Color + | SpotLight Point Point Color Radian Double + deriving Show + +light :: Coords -> Color -> Light +light (x,y,z) color = + Light (normalize (vector (-x) (-y) (-z))) color +pointlight (x,y,z) color = + PointLight (point x y z) color +spotlight (x,y,z) (p,q,r) col cutoff exp = + SpotLight (point x y z) (point p q r) col cutoff exp + +transformLight m (Light v c) = Light (multMV m v) c +transformLight m (PointLight p c) = PointLight (multMP m p) c +transformLight m (SpotLight p q c r d) = SpotLight (multMP m p) (multMP m q) c r d + +unobscured :: Point -> Object -> [Light] -> Vector -> [(Vector,Color)] +unobscured pos obj lights normV = catMaybes (map (unobscure pos obj normV) lights) + +unobscure :: Point -> Object -> Vector -> Light -> Maybe (Vector,Color) +unobscure pos obj normV (Light vec color) + -- ZZ probably want to make this faster + | vec `dot` normV < 0 = Nothing + | intersects (pos `addPV` (0.0001 `multSV` vec),vec) obj = Nothing + | otherwise = Just (vec,color) +unobscure pos obj normV (PointLight pp color) + | vec `dot` normV < 0 = Nothing + | intersectWithin (pos `addPV` (0.0001 `multSV` (normalize vec)), vec) obj = Nothing + | otherwise = Just (vec,is) + where vec = pp `subPP` pos + is = attenuate vec color +unobscure org obj normV (SpotLight pos at color cutoff exp) + | vec `dot` normV < 0 = Nothing + | intersectWithin (org `addPV` (0.0001 `multSV` (normalize vec)), vec) obj = Nothing + | angle > cutoff = Nothing + | otherwise = Just (vec, is) + where vec = pos `subPP` org + vec' = pos `subPP` at + angle = acos (normalize vec `dot` (normalize vec')) + + asp = normalize (at `subPP` pos) + qsp = normalize (org `subPP` pos) + is = attenuate vec (((asp `dot` qsp) ** exp) `multSC` color) + +attenuate :: Vector -> Color -> Color +attenuate vec color = (100 / (99 + sq (norm vec))) `multSC` color + +-- + +castRay ray p + = case intersectRayWithObject ray p of + (True, _, _) -> Nothing -- eye is inside + (False, [], _) -> Nothing -- eye is inside + (False, (0, b, _) : _, _) -> Nothing -- eye is inside + (False, (i, False, _) : _, _) -> Nothing -- eye is inside + (False, (t, b, (s, p0)) : _, _) -> + let (v, prop) = surface s p0 in + Just (offsetToPoint ray t, v, prop) + +intersects ray p + = case intersectRayWithObject ray p of + (True, _, _) -> False + (False, [], _) -> False + (False, (0, b, _) : _, _) -> False + (False, (i, False, _) : _, _) -> False + (False, (i, b, _) : _, _) -> True + +intersectWithin :: Ray -> Object -> Bool +intersectWithin ray p + = case intersectRayWithObject ray p of + (True, _, _) -> False -- eye is inside + (False, [], _) -> False -- eye is inside + (False, (0, b, _) : _, _) -> False -- eye is inside + (False, (i, False, _) : _, _) -> False -- eye is inside + (False, (t, b, _) : _, _) -> t < 1.0 |