[Shootout-list] New Benchmarks
Greg Buchholz
sleepingsquirrel@member.fsf.org
Tue, 15 Mar 2005 13:26:34 -0800 (PST)
--0-94219330-1110921994=:9534
Content-Type: text/plain; charset=us-ascii
Content-Id:
Content-Disposition: inline
--- Brent Fulgham <bfulg@pacbell.net> wrote:
> Consequently, we are always on the lookout for new and
> exciting benchmarks to include (and possibly displace
> 'old' benchmarks.)
<snip>
> I would like to see more "real world" test of this
> kind, since they are (a) interesting, and (b) easier
> to specify in such a way that we don't have to go to
> ridiculous extremes to prevent Haskell (for example)
> from optimizing away operations that it (rightly)
> identifies as worthless! :-)
At one time, I toyed with the idea of doing a (simplified) ray tracer
for the shootout. Toward that end, I wrote a Haskell and Perl
implementation which renderd a POV-like input file and produced a *.ppm
graphics file for output. Maybe this could be inspiration to someone for
creating a new benchmark? One problem might be the length of the
programs. They are a little longer than most of our current benchmarks
(180 lines of Haskell, and 242 lines of Perl). And I suspect that
complicated benchmarks result in fewer people interested in porting to
their favorite language. The programs could be whittled down in size by
eliminating features (like not parsing an input file). FWIW, the current
programs only handle mirrored spheres and checkered planes and you can
see an example of the output at...
http://sleepingsquirrel.org/ray_trace/out.png
Attached are the two programs, and an example input file. (I know the
programs badly need more comments). Two ray tracing resources I found
helpful were...
http://www.cl.cam.ac.uk/Teaching/1999/AGraphHCI/SMAG/node2.html
http://www.flipcode.com/articles/reflection_transmission.pdf
Greg Buchholz
__________________________________
Do you Yahoo!?
Yahoo! Small Business - Try our new resources site!
http://smallbusiness.yahoo.com/resources/
--0-94219330-1110921994=:9534
Content-Type: text/x-haskell; name="trace.hs"
Content-Description: trace.hs
Content-Disposition: inline; filename="trace.hs"
-- 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
--0-94219330-1110921994=:9534
Content-Type: text/x-perl; name="trace.pl"
Content-Description: trace.pl
Content-Disposition: inline; filename="trace.pl"
#!/usr/bin/perl -w
# 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
#
# run: trace.pl 800 600 <test.pov >out.ppm
use strict;
BEGIN { @Plane::ISA = "Shape"; @Sphere::ISA = "Shape" }
package main;
my ($w, $h) = @ARGV;
$/=undef;
my $input = <STDIN>;
my ($cam, @shapes) = parse_text($input);
my $pt_gen = view_plane($w, $h, $cam);
print PPM_preamble($w, $h);
for my $y (reverse 0..($h-1))
{
for my $x (reverse 0..($w-1))
{
my $film_pt = $pt_gen->($x,$y);
my $ray = [$cam->[0], $cam->[0]-$film_pt];
print Shape::find_color($ray, @shapes);
}
}
sub PPM_preamble { "P6\n$_[0] $_[1]\n255\n" }
sub view_plane
{
my ($w, $h, $cam) = @_;
my $pos = $cam->[0];
my $direction = $cam->[1];
my ($a, $b, $c) = $direction->components();
my $p = sqrt($a*$a + $b*$b);
my $r = sqrt($a*$a + $b*$b + $c*$c);
return sub { my $x = -0.5 + $_[0]/($w-1);
my $y = (-0.5 + $_[1]/($h-1)) * $h/$w;
Vec->new([( $x*$b/$p + $y*$a*$c/$p/$r),
(-$x*$a/$p + $y*$b*$c/$p/$r),
(-$y*$r/$p)]) + $pos - $direction }
}
sub parse_text
{
my $input = shift;
my $cam, my @shapes;
my $num = qr/(-?\d+(?:\.\d+)?)\s*/s;
my $angle_vec= qr/<$num,\s*$num,\s*$num>\s*/s;
my $mirrored = qr/(Chrome)\s*/s;
my $pigment = qr/pigment\s*{\s*color\s*$angle_vec}\s*|$mirrored/s;
my $texture = qr/texture\s*{\s*$pigment}\s*/s;
my $sphere = qr/(sphere)\s*{\s*$angle_vec,\s*$num\s+$texture}\s*/s;
my $plane = qr/ (plane)\s*{\s*$angle_vec,\s*$num\s+$texture}\s*/xs;
my $camera = qr/(camera)\s*{\s*location\s*$angle_vec
(?:look_at)\s*$angle_vec}\s*/xs;
while($input =~ m/$sphere|$plane|$camera/gs)
{
no warnings qw(uninitialized);
if($1 eq "sphere")
{
push @shapes, Sphere->new("center" => Vec->new([$2,$3,$4]),
"radius" => $5,
"color" => toColor($6||0,$7||0,$8||0),
"texture"=> $9 ? "Mirrored":"Solid");
}elsif ($10 eq "plane")
{
my $n = Vec->new([$11,$12,$13])->normalize();
push @shapes, Plane->new("normal" => $n,
"point" => -$14 * $n,
"color" => toColor($15,$16,$17));
}elsif ($19 eq "camera")
{
my $location = Vec->new([$20,$21,$22]);
my $look_at = Vec->new([$23,$24,$25]);
$cam = [$location, ($look_at-$location)->normalize()];
}
}
return ($cam, @shapes);
}
sub toColor { my ($r, $g, $b) = @_;
($r>=0 ? ($r<=1.0 ? chr(int($r*255)):chr(255)) : chr(0)) .
($g>=0 ? ($g<=1.0 ? chr(int($g*255)):chr(255)) : chr(0)) .
($b>=0 ? ($b<=1.0 ? chr(int($b*255)):chr(255)) : chr(0)) }
#####################################################
package Shape;
use overload q("")=> \&stringify;
our @World;
our $missed = [-1, main::toColor(0,0,0)];
sub new { my $class = shift;
my $self = {@_};
push @World, $self;
bless $self, $class }
sub find_color
{
my ($ray, @shapes) = @_;
no warnings qw(numeric);
my @c;
push @c, $_->intersect($ray) for (@shapes);
my @near = sort {$a->[0] <=> $b->[0]} grep {$_->[0]>0.001} @c;
return @near ? $near[0]->[1] : toColor(0,0,0);
}
sub stringify { my $self = shift; my $result;
$result .= "$_=>$self->{$_} " for (keys %$self);
return $result; }
#####################################################
package Sphere;
our @ISA = "Shape";
sub intersect
{
my $self = shift; my $ray = shift;
my ($eye, $disp) = @$ray;
my $center = $self->{"center"};
my $r = $self->{"radius"};
my $et = $eye - $center;
my ($a, $b, $c);
$a = $disp->dot($disp);
$b = 2 * $et->dot($disp);
$c = $et->dot($et) - $r*$r;
my $disc = $b*$b - 4*$a*$c;
if($disc>=0)
{
my $t1 = (-$b + sqrt($disc))/(2*$a);
my $t2 = (-$b - sqrt($disc))/(2*$a);
my @near = sort numerically grep {$_ > 0.001} ($t1,$t2);
if(@near)
{
if($self->{"texture"} eq "Solid")
{
return [$near[0],$self->{"color"}];
}
else #Mirrored
{
my $pierced = $eye + ($near[0] * $disp);
my $normal = ($pierced - $center)->normalize();
my $reflect = reflected($disp, $normal);
my $rray = [$pierced, $reflect];
return [$near[0],Shape::find_color($rray,@Shape::World)];
}
}
else { return $Shape::missed; }
}
else { return $Shape::missed; }
}
sub reflected { my $incident = shift; my $normal = shift;
$incident - (2*$incident->dot($normal))*$normal }
sub numerically { $a <=> $b}
#####################################################
package Plane;
use POSIX qw(floor);
our @ISA = "Shape";
sub intersect
{
my $self = shift; my $ray = shift;
my ($eye, $disp) = @$ray;
my $n = $self->{"normal"};
my $pt= $self->{"point" };
my $c = $self->{"color" };
my $t = $n->dot($pt-$eye) / $n->dot($disp);
my ($x, $y, $z) = ($eye + ($t*$disp))->components();
$c=(floor($x/3)%2 == floor($y/3)%2) ? main::toColor(0,0,0) : $c;
return $t>0 ? [$t,$c] : $Shape::missed;
}
#####################################################
package Vec;
use overload '+' => \&vadd,
'-' => \&vsub,
'*' => \&scale,
'abs'=> \&len,
q("")=> \&stringify;
sub new { my $inv = shift;
my $new = shift or die "no argument to Vec->new\n";
bless [@$new], "Vec" }
sub vadd { my $x = shift; my $y = shift;
Vec->new([ $x->[0] + $y->[0],
$x->[1] + $y->[1],
$x->[2] + $y->[2] ]) }
sub vsub { my $x = shift; my $y = shift;
Vec->new([ $x->[0] - $y->[0],
$x->[1] - $y->[1],
$x->[2] - $y->[2] ]) }
sub dot { my $x = shift; my $y = shift;
$x->[0] * $y->[0] +
$x->[1] * $y->[1] +
$x->[2] * $y->[2] }
sub scale { my $x = shift; my $s = shift;
Vec->new([ $x->[0] * $s,
$x->[1] * $s,
$x->[2] * $s ]) }
sub components{ my $x = shift; ($x->[0], $x->[1], $x->[2]) }
sub len { sqrt($_[0]->dot($_[0])) }
sub normalize { $_[0]->scale(1/$_[0]->len()) }
sub stringify { my $x = shift; "[$x->[0], $x->[1], $x->[2]]" }
--0-94219330-1110921994=:9534
Content-Type: application/octet-stream; name="test.pov"
Content-Transfer-Encoding: base64
Content-Description: test.pov
Content-Disposition: attachment; filename="test.pov"
Y2FtZXJhIHsgbG9jYXRpb24gPDAsLTQsMT4gbG9va19hdCA8MCwwLDA+IH0K
CnNwaGVyZSB7IDwwLCAwLjUsIDA+LCAwLjUKICAgICAgICAgdGV4dHVyZSB7
IENocm9tZSB9IH0gCgpzcGhlcmUgeyA8MS4yNSwgLTEsIDA+LCAwLjUKICAg
ICAgICAgdGV4dHVyZSB7IHBpZ21lbnQgeyBjb2xvciA8MC44LCAwLCAwLjg+
fSB9IH0gCgpwbGFuZSB7IDwwLCAwLCAxPiwgLTEwIAogICAgICAgIHRleHR1
cmUge3BpZ21lbnQgeyBjb2xvciA8MC43NSwgMC43NSwgMC45NT4gfSB9CiAg
ICAgIH0KCnBsYW5lIHsgPDAsIDAsIDE+LCA4CiAgICAgICAgdGV4dHVyZSB7
cGlnbWVudCB7IGNvbG9yIDwwLCAwLjcsIDAuMT4gfSB9IH0KCnBsYW5lIHsg
PDAsIDEsIDA+LCAtOTAKICAgICAgICB0ZXh0dXJlIHtwaWdtZW50IHsgY29s
b3IgPDAsIDAsIDA+IH0gfSB9CgpzcGhlcmUgeyA8LTEuNSwgMCwgMC41Piwg
MC44CiAgICAgICAgIHRleHR1cmUgeyBDaHJvbWUgfSB9IAoKc3BoZXJlIHsg
PC0yLCAyLCAtMj4sIDAuNgogICAgICAgICB0ZXh0dXJlIHsgcGlnbWVudCB7
IGNvbG9yIDwwLjcsIDAuNywgMC4yPn0gfSB9IAoKc3BoZXJlIHsgPDIsIDE1
LCAzPiwgMgogICAgICAgICB0ZXh0dXJlIHsgcGlnbWVudCB7IGNvbG9yIDww
LCAwLjEsIDAuOD59IH0gfSAK
--0-94219330-1110921994=:9534--