summaryrefslogtreecommitdiffstats
path: root/raytracer.hs
diff options
context:
space:
mode:
authorMatthias P. Braendli <matthias.braendli@mpb.li>2013-11-30 22:29:17 +0100
committerMatthias P. Braendli <matthias.braendli@mpb.li>2013-11-30 22:29:17 +0100
commit1dbaf7266b0a30096adf5ef58f82dbf156f96d23 (patch)
tree5972291b771cff888828d693ccea6dbc948f4978 /raytracer.hs
parente1b79d47ad855466dd48c29eddf0e061ce99e9c8 (diff)
downloadhaskell-1dbaf7266b0a30096adf5ef58f82dbf156f96d23.tar.gz
haskell-1dbaf7266b0a30096adf5ef58f82dbf156f96d23.tar.bz2
haskell-1dbaf7266b0a30096adf5ef58f82dbf156f96d23.zip
render a series of images
Diffstat (limited to 'raytracer.hs')
-rw-r--r--raytracer.hs83
1 files changed, 44 insertions, 39 deletions
diff --git a/raytracer.hs b/raytracer.hs
index 8bc697d..ed0726d 100644
--- a/raytracer.hs
+++ b/raytracer.hs
@@ -1,5 +1,6 @@
import System.IO
import Data.Char
+import Debug.Trace
-- ppm image file
-- P3 width height maxcolorval r g b r g b r g b ...
-- max line length: 70
@@ -13,25 +14,37 @@ data Sphere = Sphere Coord Double Color deriving (Show, Eq)
degrees = pi / 180
-eye = (0, 0, 8)
+eye = (0, 0, 40)
x_of (x, _, _) = x
y_of (_, y, _) = y
z_of (_, _, z) = z
-sphere1 = Sphere (80, 80, 5) 10 (55,255,0)
-sphere2 = Sphere (80, -80, -5) 20 (255,60,0)
-sphere3 = Sphere (-80, 80, -5) 20 (5,60,200)
-sphere4 = Sphere (-80, -80, -5) 20 (0,255,255)
+sphere1 = Sphere (0, 80, 5) 10 (55,255,0)
+sphere2 = Sphere (80, 0, 5) 20 (255,60,0)
+--sphere3 = Sphere (0, -80, 5) 20 (5,60,200)
+--sphere4 = Sphere (-80, 0, 5) 20 (0,255,255)
+--spheres = [sphere1, sphere2, sphere3, sphere4]
-spheres = [sphere1, sphere2, sphere3, sphere4]
+filename num = "foo/foo" ++ show num ++ ".ppm"
-alpha1 = 120 * degrees
+spherepos = take 80 [0,1..]
+
+spheres num = [Sphere (num, 2+(num/2), 5) 20 (255,60,0), sphere1]
+
+writenum :: Double -> IO ()
+writenum num = trace ("Rendering " ++ show (filename num))
+ writeFile (filename num) (image $ spheres num)
+
+main = mapM writenum spherepos
+
+
+alpha1 = 360 * degrees
alpha2 = 0 * degrees
beta1 = 20 * degrees
-beta2 = -20 * degrees
+beta2 = -90 * degrees
floorscale = 4
@@ -49,7 +62,7 @@ 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"
+imgheader = "P3 " ++ (show $ round w) ++ " " ++ (show $ round h) ++ " 255\n"
alphas = take (round w) [alpha1,(alpha1 + ((alpha2 - alpha1) / (w-1)))..]
betas = take (round h) [beta1,(beta1 + ((beta2 - beta1) / (h-1)))..]
@@ -101,21 +114,22 @@ intersect_sphere source (alpha, beta) (Sphere centre radius color)
intersect_point_floor :: Coord -> ScreenCoord -> (Coord, Double)
-intersect_point_floor (_, _, z) (alpha, beta)
- | beta < 0 = ( (-z * (cos alpha) / (sin beta) - 2 * (cos beta) / (sin beta),
+intersect_point_floor (_, _, z) (alpha, beta) =
+ ( (-z * (cos alpha) / (sin beta) - 2 * (cos beta) / (sin beta),
-z * (sin alpha) / (sin beta),
0),
-z / (sin beta) )
- | otherwise = ((0, 0, 0), 0)
intersect_floor :: Coord -> ScreenCoord -> (Coord, Double, Color)
intersect_floor source (alpha, beta)
- | x > (-0.5) && x < 0.5 = ((x, y, z), t, (0, attn, attn))
- | y > (-0.5) && y < 0.5 = ((x, y, z), t, (attn, attn, 0))
- | (round (x/floorscale) `mod` 2) == (round (y/floorscale) `mod` 2) = ((x, y, z), t, (attn, 0, 0))
+ | beta >= 0 = ((0, 0, 0), 0, black)
+ | x > (-0.5) && x < 0.5 = ((x, y, z), t, (0, attn, attn))
+ | y > (-0.5) && y < 0.5 = ((x, y, z), t, (attn, attn, 0))
+ | (round (x/floorscale) `mod` 2) == (round (y/floorscale) `mod` 2) =
+ ((x, y, z), t, (attn, 0, 0))
| otherwise = ((x, y, z), t, (attn, attn, attn))
- where attn = max 0 (round (255 - 8*(sqrt t)))
- ((x, y, z), t) = intersect_point_floor source (alpha, beta)
+ where attn = max 0 (round (255 - 8*(sqrt t)))
+ ((x, y, z), t) = intersect_point_floor source (alpha, beta)
-- blue is beautiful, but a green tint is nice too
skycolor :: Coord -> ScreenCoord -> Color
@@ -126,8 +140,8 @@ skycolor source (alpha, beta) = (60,
data SphereIntersect = SphereIntersect Double Color deriving (Eq, Show) -- distance color
instance Ord SphereIntersect where
(SphereIntersect d1 _) `compare` (SphereIntersect d2 _)
- | d2 == 0 = LT
- | d1 == 0 = GT
+ | d2 <= 0 = LT
+ | d1 <= 0 = GT
| otherwise = d1 `compare` d2
nearest_sphere :: Coord -> ScreenCoord -> [Sphere] -> SphereIntersect
@@ -138,31 +152,22 @@ nearest_sphere source scoord spheres =
-- also include floor in objects
nearest_obj :: Coord -> ScreenCoord -> [Sphere] -> (Double, Color)
nearest_obj source scoord spheres
- | spheredist > 0 = (spheredist, spherecolor)
--- | floordist > spheredist && spheredist > 0 = (spheredist, spherecolor)
+ | floordist == 0 && spheredist > 0 = (spheredist, spherecolor)
+ | floordist > spheredist && spheredist > 0 = (spheredist, spherecolor)
| otherwise = (floordist, floorcolor)
where (SphereIntersect spheredist spherecolor) = nearest_sphere source scoord spheres
(_, floordist, floorcolor) = intersect_floor source scoord
-- First iteration
-pixel_color :: Coord -> ScreenCoord -> Color
-pixel_color source scoord
+pixel_color :: Coord -> [Sphere] -> ScreenCoord -> Color
+pixel_color source spheres scoord
| nearest_object_dist > 0 = objcolor
- | beta > 0 = skycolor source scoord
| beta == 0 = (0, 255, 0)
- | otherwise = (255, 0, 255)
+ | otherwise = skycolor source scoord
where (_, beta) = scoord
(nearest_object_dist, objcolor) = nearest_obj source scoord spheres
---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]
@@ -188,15 +193,15 @@ coloraverage xs = ( round (fromIntegral s1/l),
l = fromIntegral (length xs)
-- calculate color of oversampled pixels
-ov_color :: [ScreenCoord] -> Color
-ov_color xs = coloraverage (map (pixel_color eye) xs)
+ov_color :: [Sphere] -> [ScreenCoord] -> Color
+ov_color spheres coords = coloraverage (map (pixel_color eye spheres) coords)
-- list of list of (alpha, beta)-tuples
ov_pixels = map oversample (cartProdTranspose betas alphas)
-allpixels = map ov_color ov_pixels
+allpixels spheres = map (ov_color spheres) ov_pixels
+
+image spheres = imgheader ++ (foldr (++) "" (map pixel_to_ppm (allpixels spheres)))
+
-image = imgheader ++ (foldr (++) "" (map pixel_to_ppm allpixels))
-main = do putStrLn "Rendering";
- writeFile "foo.ppm" image