-- Raytracer -- Renders a POV-like file (on STDIN) and produces a *.ppm file on STDOUT -- Uses a right-handed coordinate system -- -- z y X increases towards the right -- | / Y increases going into the monitor -- | / Z increases upwards -- +---->x -- -- compile: ghc -package parsec -O2 -o trace trace.hs -- run: trace 800 600 out.ppm import System(getArgs) import List(sort, sortBy) import Char(chr) import Debug.Trace import Text.ParserCombinators.Parsec --Vector stuff data Vec = V !Double !Double !Double deriving Show instance Num Vec where (V a b c) + (V x y z) = (V (a+x) (b+y) (c+z)) (V a b c) - (V x y z) = (V (a-x) (b-y) (c-z)) instance Eq Vec where (V a b c) == (V x y z) = (a==x) && (b==y) && (c==z) instance Eq Color where (RGB a b c) == (RGB x y z) = (a==x) && (b==y) && (c==z) dot (V a b c) (V x y z) = a*x + b*y + c*z scale :: Double -> Vec -> Vec scale n (V a b c) = V (n*a) (n*b) (n*c) normalize (V x y z) = (V (x/len) (y/len) (z/len)) where len = sqrt(x*x + y*y + z*z) --Shape definitions data Shape = Sphere Center Radius Color Texture | Plane Surf_norm Position Color deriving Show type Center = Vec type Radius = Double data Color = RGB !Int !Int !Int deriving Show data Texture = Solid | Mirrored deriving Show data Camera = Cam Position Direction deriving Show type Position = Vec type Direction = Vec type Ray = (Vec, Vec) type Surf_norm = Vec --Start everything main = do (width:height:rest) <- getArgs let w = read width let h = read height input <- getContents let (cam, shapes) = (parse_text shape_parse input) let pos = case (cam) of (Cam p d) -> p putStr $ showPPM w h $ map (\ray-> ray `intersect` shapes) (map (make_ray pos) $ view_plane w h cam) missed = (-1, RGB 0 0 0) top :: [(Double, Color)] -> (Double, Color) top ps = if ps==[] then missed else head ps --vector equation of the ray is P(t) = (Eye-Center) + t*Disp intersect :: Ray -> [Shape] -> Color intersect ray@(eye,disp) objects = snd $ top $ fst_sort (map isect objects) where fst_sort xs = sortBy (\a b->(fst a) `compare` (fst b)) (filter (\t-> (fst t)>0) xs) isect shape = case (shape) of (Sphere center radius color texture) -> if disc >= 0 then closest else missed where et = eye - center a = disp `dot` disp b = (et + et) `dot` disp c = (et `dot` et) - radius*radius disc = b*b - 4*a*c t1 = (-b + sqrt(disc))/(2*a) t2 = (-b - sqrt(disc))/(2*a) small = filter (>0.01) (sort (t1:t2:[])) closest = if small == [] then missed else case (texture) of Solid -> (head small,color) Mirrored -> (head small,recur) where refl_ray = (pierced, r) r = reflected disp norm pierced = eye+((head small) `scale` disp) norm = normalize (pierced - center) recur = intersect refl_ray objects (Plane norm pos color) -> if t >= 0 then (t,c) else missed where t = (norm `dot` (pos - eye))/(norm `dot` disp) (V x y z) = eye + (t `scale` disp) c = if ((mod (floor (x/3)) 2) == (mod (floor (y/3)) 2)) then (RGB 0 0 0) else color reflected :: Vec -> Vec -> Vec reflected incident normal = incident - ((2*(incident `dot` normal)) `scale` normal) make_ray lens_pos film_pt = (lens_pos, ( (lens_pos - film_pt))) view_plane w h (Cam pos dir@(V a b c)) = map (+ (pos - dir)) arr where p = sqrt $ a*a+b*b r = sqrt $ a*a+b*b+c*c arr = [(V (x*b/p+y*a*c/p/r) (-x*a/p+y*b*c/p/r) (-y*r/p))| y<-ys, x<-xs] xs = [ -0.5 + x'/(w-1) | x'<-reverse [0..w-1]] ys = [(-0.5 + y'/(h-1))*h/w | y'<-reverse [0..h-1]] --PPM specific stuff showPPM _ _ [] = [] showPPM w h xs = "P6\n" ++ (show (floor w)) ++ " " ++ (show (floor h)) ++ "\n255\n" ++ concatMap colorize xs colorize (RGB r g b) = [(chr r),(chr g),(chr b)] -- Parsing functions parse_text p input = case (parse p "" input) of Left err -> error $ "Bleech! Invalid input"++ (show err) Right x -> x shape_parse = do cam <- camera_parse shapes <- many1 (sphere_parse <|> plane_parse) return (cam, shapes) camera_parse = do string "camera"; spaces; char '{'; spaces; string "location"; spaces; loc <- angle_vec; string "look_at" ; spaces; look <- angle_vec; char '}'; spaces; return (Cam loc (normalize $ look - loc)) sphere_parse = do string "sphere"; spaces; char '{'; spaces center <- angle_vec; char ','; spaces radius <- number; spaces; (color,text) <- parse_texture; spaces; char '}'; spaces; return (Sphere center radius color text) plane_parse = do string "plane"; spaces; char '{'; spaces v <- angle_vec; char ','; spaces dist <- number; spaces; (color,text) <- parse_texture; spaces; char '}'; spaces; return (Plane (normalize v) ((-1*dist) `scale` (normalize v)) color) parse_texture = do string "texture"; spaces; char '{'; spaces color <- (try parse_pigment) <|> parse_chrome char '}'; spaces; return color parse_pigment = do string "pigment"; spaces; char '{'; spaces; string "color"; spaces; c <- angle_vec; spaces; char '}'; spaces; return $ (RGB (toColor (c!!!0)) (toColor (c!!!1)) (toColor (c!!!2)), Solid) parse_chrome = do string "Chrome"; spaces; return ((RGB 0 0 0), Mirrored) toColor c | c >= 1.0 = 255 | c <= 0.0 = 0 | otherwise = floor $ c * 255 (V a b c) !!! 0 = a (V a b c) !!! 1 = b (V a b c) !!! 2 = c angle_vec = do char '<';spaces; v <- number `sepBy1` (do {spaces;char ',';spaces}); char '>';spaces; return (V (v!!0) (v!!1) (v!!2)) number = do sign <- option ' ' (char '-') i <- many1 digit f <- option "" $ do { p <- char '.'; n <- many1 digit; return (p:n)} return $ read $ sign:i ++ f