#!/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]]" }