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