From 1dbaf7266b0a30096adf5ef58f82dbf156f96d23 Mon Sep 17 00:00:00 2001 From: "Matthias P. Braendli" Date: Sat, 30 Nov 2013 22:29:17 +0100 Subject: render a series of images --- raytracer.hs | 83 ++++++++++++++++++++++++++++++++---------------------------- 1 file 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 -- cgit v1.2.3