# Untitled

By: a guest on May 4th, 2012  |  syntax: Haskell  |  size: 6.29 KB  |  hits: 22  |  expires: Never
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
1. import Data.Maybe
2.
3. ---- precise comparison of Doubles
4.
5. eps = 1e-8
6. x !>  y = x     > y+eps
7. x !<  y = x+eps < y
8. x !>= y = x+eps > y
9. x !<= y = x     < y+eps
10. x !== y = x !<= y && x !>= y
11.
12. ---- color (rgb values are between 0 and 1)
13.
14. data Color = Color Double Double Double
15.
16. instance Show Color where
17.   show (Color r g b) = format r ++ " " ++ format g ++ " " ++ format b
18.     where format = show . round . (*255) . min 1
19.
20. scaleC (Color x y z) k = Color (k*x) (k*y) (k*z)
21. multC (Color x y z) (Color a b c) = Color (x*a) (y*b) (z*c)
22. addC (Color x y z) (Color a b c) = Color (x+a) (y+b) (z+c)
24.
25. ---- 3d vector (can represent a point)
26.
27. data Vector = Vector Double Double Double
28.             deriving Show
29.
30. (Vector x y z) ^* k = Vector (x*k) (y*k) (z*k)
31. (Vector x y z) ^/ k = Vector (x/k) (y/k) (z/k)
32.
33. (Vector x y z) ^+^ (Vector a b c) = Vector (x+a) (y+b) (z+c)
34. (Vector x y z) ^-^ (Vector a b c) = Vector (x-a) (y-b) (z-c)
35. (Vector x y z) ^*^ (Vector a b c) = Vector (y*c-b*z) (z*a-c*x) (x*b-a*y)
36. (Vector x y z) ^.^ (Vector a b c) = x*a + y*b + z*c
37. p              ^|^ q              = sqrt \$ (p^-^q) ^.^ (p^-^q)
38.
39. neg (Vector x y z) = Vector (-x) (-y) (-z)
40. norm v = sqrt \$ v ^.^ v
41. normalize v = v ^/ (norm v)
42.
43. ---- ray directed from starting point
44.
45. data Ray = Ray { rayFrom :: Vector
46.                , rayDir  :: Vector
47.                } deriving Show
48.
49. rayPoints :: Vector -> Vector -> Ray
50. rayPoints a b = Ray a (normalize \$ b^-^a)
51.
52. ---- light source
53.
54. data Light = Light { lightPos   :: Vector
55.                    , lightColor :: Color
56.                    } deriving Show
57.
58. ---- objects in scenes
59.
60. data Object = Sphere { sphCenter  :: Vector
62.                      , sphDiffuse :: Color
63.                      , sphReflect :: Color
64.                      , sphRough   :: Double
65.                      } deriving Show
66.
67. ---- intersection of a ray and an object
68.
69. data Inter = Inter { interPoint   :: Vector
70.                    , interDist    :: Double
71.                    , interOuter   :: Bool
72.                    , interNormal  :: Vector
73.                    , interDiffuse :: Color
74.                    , interReflect :: Color
75.                    , interRough   :: Double
76.                    } deriving Show
77.
78. findInter :: Ray -> Object -> Maybe Inter
79. findInter (Ray st dir) (Sphere c r diffuse reflect rough)
80.   | d0 !>= r  = Nothing
81.   | t2 !<= 0  = Nothing
82.   | otherwise = Just \$ Inter point dist outer normal diffuse reflect rough
83.   where
84.     t0     = (dir ^.^ (c^-^st)) / (dir ^.^ dir)
85.     p0     = st ^+^ (dir^*t0)
86.     d0     = p0 ^|^ c
87.     delta  = sqrt \$ r^2 - d0^2
88.     t1     = t0 - delta
89.     t2     = t0 + delta
90.     time   = if outer then t1 else t2
91.     point  = st ^+^ (dir^*time)
92.     dist   = point ^|^ st
93.     outer  = t1 !> 0
94.     normal = normalize \$ point ^-^ c
95.
96. ---- light effects
97.
98. ambiental :: Color
99. ambiental = Color 0.06 0.06 0.06
100.
101. diffusion :: Light -> Inter -> Color
102. diffusion l i = (lightColor l) `multC` (interDiffuse i) `scaleC` cosA
103.   where dirL = normalize \$ (lightPos l) ^-^ (interPoint i)
104.         cosA = dirL ^.^ (interNormal i)
105.
106. reflection :: Ray -> Light -> Inter -> Color
107. reflection r l i = (lightColor l) `multC` (interReflect i) `scaleC` powCosA
108.   where normal  = interNormal i
109.         dirR    = rayDir r
110.         dirL    = normalize \$ (lightPos l) ^-^ (interPoint i)
111.         cosA    = normal ^* (normal ^.^ dirL) ^* 2 ^-^ dirL ^.^ (neg dirR)
112.         powCosA = (cosA `max` 0) ** (interRough i)
113.
114. dropSingle :: Ray -> Light -> Inter -> Color
115. dropSingle r l i | isNothing liM               = Color 0 0 0
116.                  | interDist li !< (posL^|^pt) = Color 0 0 0
117.                  | otherwise                   = result
118.   where posL   = lightPos l
119.         pt     = interPoint i
120.         liM    = obstacle \$ rayPoints posL pt
121.         li     = fromJust liM
122.         result = addAllC [diffusion l i, reflection r l i]
123.
124. dropLight :: Ray -> Inter -> Color
125. dropLight r i = addAllC [dropSingle r l i | l <- lights] `addC` ambiental
126.
127. ---- rendering
128.
129. obstacle :: Ray -> Maybe Inter
130. obstacle ray = foldl (\a -> closer a . findInter ray) Nothing objs
131.   where closer Nothing  b        = b
132.         closer a        Nothing  = a
133.         closer (Just x) (Just y) | interDist x < interDist y = Just x
134.                                  | otherwise                 = Just y
135.
136. traceRay :: Ray -> Color
137. traceRay ray | isNothing obst = Color 0 0 0
138.              | otherwise      = dropLight ray i
139.   where obst = obstacle ray
140.         i    = fromJust obst
141.
142. getPixel :: Int -> Int -> Int -> Int -> Color
143. getPixel w h x y = traceRay \$ rayPoints eye pt
144.   where w' = fromIntegral w
145.         h' = fromIntegral h
146.         x' = fromIntegral x
147.         y' = fromIntegral y
148.         pt = corner ^+^ (xAxis ^* (x' / (w'-1) * viewW))
149.                     ^-^ (yAxis ^* (y' / (h'-1) * viewH))
150.
151. render :: Int -> Int -> [Color]
152. render w h = [getPixel w h x y | y <- [0..h-1], x <- [0..w-1]]
153.
154. ---- writing to file
155.
156. formatPGM :: Int -> Int -> String
157. formatPGM w h = format \$ render w h
158.   where format ps = "P3\n" ++
159.                    show w ++ " " ++ show h ++ "\n" ++
160.                    "255\n" ++
161.                    concatMap (\c -> show c ++ "\n") ps
162.
163. writePGM :: Int -> Int -> IO ()
164. writePGM w h = writeFile file \$ formatPGM w h
165.
166. main = writePGM 400 400
167.
168. ---- constants
169.
170. file    = "slika.ppm"
171.
172. viewH   = 20
173. viewW   = 20
174. eye     = Vector 10 0  0
175. view    = Vector  0 0  0
176. viewUp  = Vector  0 0 10
177. viewDir = normalize \$ view ^-^ eye
178. xAxis   = normalize \$ viewDir ^*^ yAxis
179. yAxis   = normalize \$ viewUp ^-^ (viewDir ^* (viewDir^.^viewUp))
180. zAxis   = normalize \$ neg viewDir
181. corner  = view ^-^ (xAxis ^* (viewW/2)) ^+^ (yAxis ^* (viewH/2))
182.
183. lights  = [ Light (Vector 10   5    5 ) (Color 0.4     0    0)
184.           , Light (Vector 10 (-5)   5 ) (Color   0  0.31 0.31)
185.           , Light (Vector  2   5  (-1)) (Color 0.31 0.31    0)
186.           ]
187. objs    = [ Sphere (Vector (-2) (-2)   2 ) 5 (Color 1 1 1) (Color 0.5 0.5 0.5) 10
188.           , Sphere (Vector (-2)   2  (-3)) 5 (Color 1 1 1) (Color 0.5 0.5 0.5) 10
189.           ] ++
190.           [ Sphere (Vector (-5) (i'/9*25-12.5) (j'/9*25-12.5)) 0.5
191.                    (Color 1 1 1) (Color 0.5 0.5 0.5) 4
192.           | i <- [0..9], j <- [0..9]
193.           , let i' = fromIntegral i, let j' = fromIntegral j ]