summaryrefslogtreecommitdiff
path: root/testsuite/tests/programs/galois_raytrace/Illumination.hs
blob: 155a7a9a76d3ca713ac3d464b0e52b0e43e34cc7 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
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