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
|
import System.IO
import Data.Char
-- ppm image file
-- P3 width height maxcolorval r g b r g b r g b ...
-- max line length: 70
type Angle = Double
type ScreenCoord = (Angle, Angle)
type Color = (Int, Int, Int)
type Coord = (Double, Double, Double)
type Sphere = (Coord, Double)
degrees = pi / 180
eye = (0, 0, 2)
x_of (x, _, _) = x
y_of (_, y, _) = y
z_of (_, _, z) = z
sphere1 = ((40, 85, 0), 4)
sphere2 = ((40, 45, 0), 4)
alpha1 = 180 * degrees
alpha2 = 0 * degrees
beta1 = 20 * degrees
beta2 = -20 * degrees
floorscale = 1
w = 600
h = 400
oversampling = 1 -- each pixel is 2x2 rays
ov_alphaoffset = ((alpha2 - alpha1) / (w-1)) / oversampling
ov_betaoffset = ((beta2 - beta1) / (h-1)) / oversampling
ov_alphaoffsets = take (round oversampling) [0,ov_alphaoffset..]
ov_betaoffsets = take (round oversampling) [0,ov_betaoffset..]
imgheader = "P3 " ++ (show w) ++ " " ++ (show h) ++ " 255\n"
alphas = take (round w) [alpha1,(alpha1 + ((alpha2 - alpha1) / (w-1)))..]
betas = take (round h) [beta1,(beta1 + ((beta2 - beta1) / (h-1)))..]
-- intersect sphere
-- discr = 4(( A u + B v + C w )^2 - (A^2 + B^2 + C^2)(u^2 + v^2 + w^2))
-- where u = source_x - sphere_x (v and w analogous)
-- where A = cos alpha + cos beta
-- B = sin alpha
-- C = sin beta
discr :: Coord -> ScreenCoord -> Sphere -> Double
discr source (alpha, beta) (centre, radius) = 4*(( aa * u + bb * v + cc * w )^2 -
(aa*aa + bb*bb + cc*cc)*(u*u + v*v + w*w - radius^2))
where u = (x_of source) - (x_of centre)
v = (y_of source) - (y_of centre)
w = (z_of source) - (z_of centre)
aa = cos alpha + cos beta
bb = sin alpha
cc = sin beta
intersect_sphere :: Coord -> ScreenCoord -> Sphere -> Double
intersect_sphere source (alpha, beta) (centre, radius)
| delta > 0 = min ((-b - sqrt(delta)) / (2*a)) ((-b + sqrt(delta)) / (2*a))
| otherwise = 0
where delta = discr source (alpha, beta) (centre, radius)
a = aa^2 + bb^2 + cc^2
b = 2 * (aa*u + bb*v + cc*w)
u = (x_of source) - (x_of centre)
v = (y_of source) - (y_of centre)
w = (z_of source) - (z_of centre)
aa = cos alpha + cos beta
bb = sin alpha
cc = sin beta
-- intersect at (x , y , depth )
intersect_floor :: Coord -> ScreenCoord -> (Double, Double, Double)
intersect_floor source (alpha, beta)
| beta < 0 = (-(z_of source) * (cos alpha) / (sin beta) - 2 * (cos beta) / (sin beta),
-(z_of source) * (sin alpha) / (sin beta),
-(z_of source) / (sin beta) )
| otherwise = (0, 0, 0)
floorcolor :: Coord -> ScreenCoord -> Color
floorcolor source (alpha, beta)
| x > (-0.5) && x < 0.5 = (0, attn, attn)
| y > (-0.5) && y < 0.5 = (attn, attn, 0)
| (round (x/floorscale) `mod` 2) == (round (y/floorscale) `mod` 2) = (attn, 0, 0)
| otherwise = (attn, attn, attn)
where attn = max 0 (round (255 - 8*(sqrt t)))
(x, y, t) = intersect_floor source (alpha, beta)
-- blue is beautiful, but a green tint is nice too
skycolor :: Coord -> ScreenCoord -> Color
skycolor source (alpha, beta) = (60,
round ((sqrt (alpha/6)) / (sqrt (90 * degrees)) * 128),
round ((sqrt beta) / (sqrt (90 * degrees)) * 255) )
pixel_color :: Coord -> ScreenCoord -> Color
pixel_color source (alpha, beta)
| intersect_sphere source (alpha, beta) sphere1 > 0 = (200, 0, 0)
| intersect_sphere source (alpha, beta) sphere2 > 0 = (0, 200, 0)
| beta > 0 = skycolor source (alpha, beta)
| beta == 0 = (0, 255, 0)
| otherwise = floorcolor source (alpha, beta)
cartProdTranspose xs ys = [(y,x) | x <- xs, y <- ys]
cartProd xs ys = [(x,y) | x <- xs, y <- ys]
pixel_to_ppm (r,g,b) = show r ++ " " ++ show g ++ " " ++ show b ++ "\n"
tuple2sum x y = (a1 + b1, a2 + b2)
where (a1, a2) = x
(b1, b2) = y
-- from one pixel (alpha, beta), get a list of oversampled pixels
oversample :: ScreenCoord -> [ScreenCoord]
oversample (a,b) = map (tuple2sum (a,b)) (cartProd ov_alphaoffsets ov_betaoffsets)
tuple3sum x y = (a1 + b1, a2 + b2, a3 + b3)
where (a1, a2, a3) = x
(b1, b2, b3) = y
coloraverage :: [Color] -> Color
coloraverage xs = ( round (fromIntegral s1/l),
round (fromIntegral s2/l),
round (fromIntegral s3/l) )
where (s1, s2, s3) = foldr tuple3sum (0,0,0) xs
l = fromIntegral (length xs)
-- calculate color of oversampled pixels
ov_color :: [ScreenCoord] -> Color
ov_color xs = coloraverage (map (pixel_color eye) xs)
-- list of list of (alpha, beta)-tuples
ov_pixels = map oversample (cartProdTranspose betas alphas)
allpixels = map ov_color ov_pixels
image = imgheader ++ (foldr (++) "" (map pixel_to_ppm allpixels))
main = writeFile "foo.ppm" image
|
