[SPOILER] Solution to Perl 'Expert' Quiz of the Week #26

I didn't intend to do this week's quiz when I wrote a few days ago, but 
I got the urge the more I thought about it. This entry uses POV-Ray (a 
free/free raytracer) instead of Tk to render the animation. The output 
of this script is a file 'coaster.pov' that contains the necessary info 
to render the track plus an array of ball locations that can be 
iterated over with the 'clock' variable using POV-Ray's built-in 
animation system. You'll have to look at the ball array size (at the 
very bottom of the file) to figure out how the clock should range. 
Pre-rendered demos of each of the 3 examples:

http://homepage.mac.com/third_man/.Movies/hurricane.mov
http://homepage.mac.com/third_man/.Movies/loop.mov
http://homepage.mac.com/third_man/.Movies/quad.mov

Problems: The core code itself isn't great. The physics are too complex 
for the task; I like Pr. Zentara's solution there much better. I ran 
out of time to make a nice smart camera, but maybe I'll have some spare 
time in the next few days to clean that in. It leaks energy. I'm not 
sure why yet.

I have a question for the list... I wanted to put in quick and dirty 
input file error handling with something like:

eval {
     use warnings FATAL => "all";
     snarf_input();
     subdivide_track();
};
if ($@) { die "Input error etc." }

The idea being that those 2 subs stressed most of the features of the 
input stream that I care about, and if they had problems it was a 
problem with the input. The warnings remained benign, however, so that 
did not work out. Can anyone see why that isn't working?

----------------------------------------------------------------

#!/usr/bin/perl
use strict;
use warnings;

my @coords;

# Global vars to track the ball
my $current_segment = 0;
my $current_segment_position = 0;
my $current_time = 0;
my $current_velocity = 0; # velocity is parallel to the track at any 
point
                           # on the track. Positive is forwards.

my $g = 9.8;
my $m = 10; # Mass isn't important as-implemented, but may be in the 
future.

my $track_subdivisions = 4;

my @ball_positions;

snarf_input();
subdivide_track() for (0..$track_subdivisions);
compute_z();
animate(total_seconds => 20, fps => 30);

exit;

sub snarf_input {
     while (<>) {
         # Convert to meters (input is in decimeters).
         push @coords, [map { $_ / 10 } split " ", $_];
     }
}

sub subdivide_track {
     my @new_coords = ($coords[0]);
     for (my $i = 1; $i < @coords; $i++) {
         push @new_coords, [
             map { ($coords[$i]->[$_] + $coords[$i-1]->[$_])/2 } (0..1)
         ],
         $coords[$i];
     }
     @coords = @new_coords;
}

# Calculate the z value of each point on the track as a linear function 
of
# the distance traveled on the track.
sub compute_z {
     my $z_ratio = .25; # For every 1 (x,y) meter traveled on the track, 
how
                        # far back we bump the z.

     my $initial_z = 0;
     $coords[0][2] = $initial_z;
     $coords[0][3] = 0; # 4th coord holds distance marker of this point
                        # along the track.

     for (my $i = 1; $i < @coords; $i++) {
         my $distance = (
             ($coords[$i][0] - $coords[$i-1][0])**2 +
             ($coords[$i][1] - $coords[$i-1][1])**2
         ) ** .5;

         $coords[$i][3] = $coords[$i-1][3] + $distance;
         $coords[$i][2] = $coords[$i][3] * $z_ratio + $initial_z;
     }
}

sub animate {
     my %args = @_;

     my $total_frames = $args{total_seconds} * $args{fps};

     for (my $frame = 0; $frame < $total_frames; $frame++) {
         animate_ball(
             time => (1.0 * $frame) / $args{fps},
         );
     }

     my $fd;
     open($fd, ">coaster.pov")
         or die "Either this program or your computer is screwed up: $!";
     output_static_scene(fd => $fd);
     output_camera(fd => $fd);
     output_ball(fd => $fd)
}

sub animate_ball {
     my %args = @_;
     my $fd = $args{fd};
     my $time = $args{time};

     my $delta_t = $time - $current_time;
     $current_time = $time;

     # Roll across track segments until $delta_t goes to 0
     while($delta_t > 0) {
         my $kinetic_energy = $m * ($current_velocity ** 2) / 2;

         # Stop if we're about to fly off the end.
         return if $current_segment == $#coords;

         # Points of interest
         my $p_next = $coords[$current_segment+1];
         my $p_prev = $coords[$current_segment];
         my $scale = ($current_segment_position / ($p_next->[3] 
-$p_prev->[3]));
         my $p_cur = [ map {
             $p_prev->[$_] + $scale * ($p_next->[$_] - $p_prev->[$_])
         } (0..2) ];

         my $is_upwards_slope =
             $p_prev->[1] < $p_next->[1];

         my $going_forwards = $current_velocity > 0 ||
             ($current_velocity==0 && !$is_upwards_slope);

         my $delta_y = $going_forwards ?
             $p_next->[1] - $p_cur->[1] : $p_prev->[1] - $p_cur->[1];

         # Get what the kinetic energy would be added if the ball rolled 
all
         # the way to the end of this track segment.
         my $energy_change = -($m * $g * $delta_y);
         my $end_ke = $energy_change + $kinetic_energy;

         # If the ball will reverse before it reaches the endpoint
         # in the direction it's currently going...
         if ($end_ke < 0) {
             # Fudge and set velocity to 0 rather than find the apex.
             $current_velocity = 0;
             next;
         }

         my $end_velocity = ($end_ke * 2/$m) ** .5;
         $end_velocity *= -1 if !$going_forwards;
         my $avg_velocity = ($current_velocity + $end_velocity) / 2;

         my $distance_left = $going_forwards ?
             $p_next->[3] - $p_prev->[3] - $current_segment_position :
             $current_segment_position;

         # If we will reach the endpoint with time to spare...
         if (abs($delta_t * $avg_velocity) >= $distance_left)  {
             # Watch out for the case where we fudge the apex and 
avg_velocity
             # is zero.
             if ($distance_left > 0) {
                 my $actual_time = $distance_left / abs($avg_velocity);
                 $delta_t -= $actual_time;
             }
             $current_velocity = $end_velocity;

             if ($going_forwards) {
                 $current_segment++;
                 $current_segment_position = 0;
             }
             else {
                 $current_segment_position =
                     $p_prev->[3] - $coords[$current_segment-1]->[3];
                 $current_segment--;
             }
             next;
         }
         # Otherwise, where do we end up on this segment?
         else {
             # Fudge and pretend avg_velocity is valid even if we fall 
short
             # or long.
             $current_segment_position += $avg_velocity * $delta_t;

             # ... but get the new velocity right so that it's just a
             # temporal problem and not an energy violation.
             my $old_y = $p_cur->[1];
             my $scale = (
                 $current_segment_position / ($p_next->[3] -$p_prev->[3])
             );
             my $new_y = $p_prev->[1] + $scale * ($p_next->[1] - 
$p_prev->[1]);

             my $changed_energy = abs($m * $g * ($old_y - $new_y));
             my $new_v = ($changed_energy * 2/$m) ** .5;
             $new_v *= -1 if $old_y < $new_y;
             $new_v *= -1 if !$going_forwards;
             $current_velocity += $new_v;
             $delta_t = 0;
             next;
         }
     }

     my $p_next = $coords[$current_segment+1];
     my $p_prev = $coords[$current_segment];
     my $scale = ($current_segment_position / ($p_next->[3] 
-$p_prev->[3]));
     my $p_cur = [
         map { $p_prev->[$_] + $scale * ($p_next->[$_] - $p_prev->[$_]) 
} (0..2)
     ];

     push @ball_positions, $p_cur;
}

sub output_camera {
     my %args = @_;
     my $fd = $args{fd};

     print $fd <<CAMERA;
camera{
     location  <20, 30, -40>
     direction z
     look_at <20, 30, 20>
}
CAMERA
}

sub output_ball {
     my %args = @_;
     my $fd = $args{fd};
     my $size = @ball_positions;
     print $fd "#declare ball_array = array[$size][3] {\n";
     print $fd join(", ", map { "{" . join(",", @{$_}) . "}" } 
@ball_positions);
     print $fd "\n}\n";
     print $fd <<BALL;
sphere {
     < ball_array[clock][0], ball_array[clock][1], ball_array[clock][2] >
     .8
     texture { txtMetal }
}
BALL
}

sub output_static_scene {
     my %args = @_;
     my $fd = $args{fd};

     print $fd <<BOILERPLATE;
// Generated by coaster.pl

#include "stdinc.inc"
#include "metals.inc"

#declare txtMetal=T_Chrome_2C

light_source { <-15, 30, -25> color <1, 1, 1> }
light_source { < 15, 30, -25> color <1, 1, 1> }

plane {
    y, 0
    texture {
        pigment {checker color <0.1, 0.3, 0.4>, color <0.2, 0.5, 0.7>}
        finish {diffuse 0.7 reflection 0.2}
        scale <4, 1, 4>
    }
}
BOILERPLATE

     for (my $i = 1; $i < @coords; $i+= 2^$track_subdivisions) {
         print $fd <<TRACK;
union {
     sphere {
         <$coords[$i-1][0], $coords[$i-1][1], $coords[$i-1][2] - .3>
         .2
     }
     cylinder {
         <$coords[$i-1][0], $coords[$i-1][1], $coords[$i-1][2] - .3>
         <$coords[$i][0], $coords[$i][1], $coords[$i][2] - .3>
         .2
     }

     sphere {
         <$coords[$i-1][0], $coords[$i-1][1], $coords[$i-1][2] + .3>
         .2
     }
     cylinder {
         <$coords[$i-1][0], $coords[$i-1][1], $coords[$i-1][2] + .3>
         <$coords[$i][0], $coords[$i][1], $coords[$i][2] + .3>
         .2
     }
     texture {
         txtMetal
     }
}
TRACK
     }
}

sub min {
     return $_[0] < $_[1] ? $_[0] : $_[1];
}

sub max {
     return $_[0] > $_[1] ? $_[0] : $_[1];
}