-- 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 <test.pov >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