Don't like ads? PRO users don't see any ads ;-)
Public Pastes
Guest

Untitled

By: a guest on May 4th, 2012  |  syntax: Haskell  |  size: 6.29 KB  |  hits: 22  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
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)
  23. addAllC = foldr1 addC
  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
  61.                      , sphRadius  :: Double
  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 ]
create a new version of this paste RAW Paste Data