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
|
