#!/usr/bin/perl -w
#
#  Displays marbles dropping onto pegs, and bouncing either left or ri
+ght
#  at random, to create a bell-shaped curve.
#
#  September, 2005 -- by jcn
#
                                                                      
+          
##############
### Strict ###
##############
use strict;
use warnings;
                                                                      
+          
                                                                      
+          
####################
### User-defined ###
####################
                                                                      
+          
# Version
my $version = "v1.0  (050908 by jcn)";
                                                                      
+          
# Canvas
my $cvcolor = 'peachpuff';  # Canvas background color
                                                                      
+          
# Chute
my $chute_dx        = 32;   # Distance between chute 'posts'
my $chute_dy        = 12;   # Distance from top of chute to bottom
my $chute_width     = 4;    # Thickness of each chute 'post'
                                                                      
+          
# Pegs
my $npegs           = 8;    # Number of rows of pegs
my $chute_peg_d     = 48;   # Distance from chute bottom to first peg 
+top
my $peg_dx          = 32;   # Difference between any 2 cols of pegs
my $peg_dy          = 40;   # Difference between any 2 rows of pegs
my $peg_r           = 3;    # Radius of a single peg
                                                                      
+          
# Bins
my $peg_bin_d       = 8;    # Distance from last peg bottom to bin top
my $bin_dy          = 128;  # Height of a single bin
my $bin_width       = 1;    # Thickness of each bin 'wall'

                                                                      
+          
# Marbles
my $marble_r        = 12;   # Radius of a single marble
my $marble_delay    = 50;   # Speed of a marble
my $marble_latency  =  4;   # Number of ticks between marble drops
                                                                      
+          
                                                                      
+          
############################
### Calculated variables ###
############################
                                                                      
+          
# Bins
my $nbins         = ($npegs + 1);
                                                                      
+          
# Canvas dimensions
my $cw = 2 * $nbins * $peg_dx;
my $ch = $chute_dy+$chute_peg_d + ($npegs-1) * $peg_dy + $peg_bin_d + 
+$bin_dy;
                                                                      
+          
# Marbles
my $marble_x = $cw / 2;
my $marble_y = $marble_r;
                                                                      
+          
# Bins
my $bin_x    = ($cw / 2) - ($peg_dx * ($npegs - 1));
my $bin_y    = $ch - $bin_dy;
my $bin_dx   = (2 * $peg_dx);
                                                                      
+          
# Pegs
my $peg_x = int($cw / 2);
my $peg_y = $chute_dy + $chute_peg_d;


#################
### Libraries ###
#################
use Data::Dumper;
use Tk;
                                                                      
+          
                                                                      
+          
##################
### Prototypes ###
##################
sub create_gui();
sub init_velocity_vector();
sub update_bin_count($$);
sub fill_bin($$$);
                                                                      
+          
                                                                      
+          
###############
### Globals ###
###############
my $mw = 0;         # Main window object
my @bin_count;      # Bin statistics
my @bin_color;      # Color of each bin
my @bin_fill;       # Fill-color in bin
my @bin_text;       # Bin statistic text
my @vvector;        # Velocity vector
my $cv_marbles = 0; # Canvas object
my $nm_id = 0;      # ID of text for showing total marbles
                                                                      
+          
                                                                      
+          
####################
### Main program ###
####################
create_gui;


###################
### Subroutines ###
###################
                                                                      
+          
#####################
### Marble object ###
#####################
BEGIN {
    my $nmarbles = 0;       # Total marbles dropped
    my %marbles;            # Hash for holding individual marbles
                                                                      
+          
    my $drop_ticks = $marble_latency;
                                                                      
+          
    sub array_of_half_steps($$) {
        my ($ydist, $up_bounce) = @_;
        my @steps;
        while (1) {
            my $nexty = int($ydist / 2);
            last unless ($nexty > 1);
            if ($up_bounce) {
                push @steps, - $nexty;
            } else {
                unshift @steps, $nexty;
            }
            $ydist -= $nexty;
        }
        ($ydist > 0) and $steps[0] += $ydist;
        return \@steps;
    }
                                                                      
+          
    sub init_velocity_vector() {
        my @tmp0;
        my $marble_dy = $peg_y - $marble_y - $marble_r - $peg_r / 2;
        my $marble_dx = $peg_dx;
        my ($pxlist, $pylist, $pdown);
                                                                      
+          
        $pylist = array_of_half_steps($marble_dy, 0);
        map { push @vvector, [ 0, $_ ] } (@$pylist);
                                                                      
+          
        my $up_dy = int($marble_dy / 2);
        $pylist = array_of_half_steps($up_dy, 1);
        $pdown  = array_of_half_steps($up_dy + $marble_dy, 0);
        push @$pylist, @$pdown;
        my $nsteps = @$pylist;
        my $xinc = int($marble_dx / $nsteps);
        my $xextra = $marble_dx - ($nsteps * $xinc);
        for (my $i = 0; $i < $nsteps; $i++) {
            push @$pxlist, $xinc + (($xextra > 0)? 1: 0);
            $xextra--;
        }
                                                                      
+          
        for (my $j = 0; $j < $npegs; $j++) {
            push @vvector, 0;
            for (my $i = 0; $i < @$pylist; $i++) {
                my ($x, $y) = ($pxlist->[$i], $pylist->[$i]);
                push @vvector, [ $x, $y ];
            }
        }
                                                                      
+          
        my $plast = $vvector[-1];
        my ($lastx, $lasty) = ($plast->[0], $plast->[1]);
                                                                      
+          
        my $bottom_y = $peg_y + ($peg_dy * $npegs);
        while ($bottom_y - 2 * $marble_r < $ch) {
            push @vvector, [ 0, $lasty *= 2 ];
            $bottom_y += $lasty;
        }
        push @vvector, 0;
    }

    sub draw_marble($$$) {
        my ($x, $y, $c) = @_;
        my $ra = $marble_r;
        &draw_circle($x-$ra, $y-$ra, $x+$ra, $y+$ra, $c);
    }
                                                                      
+          
    sub new_marble($$$) {
        my ($x, $y, $color) = @_;
        my $idx = $nmarbles++;
        my $old_id = $nm_id;
        my $text = sprintf "Marbles:  %d", $nmarbles;
        $nm_id = $cv_marbles->createText(64, 10, -text => $text);
        $old_id and $cv_marbles->delete($old_id);
        my $id = draw_marble($x, $y, $color);
        my $pmarble = {
            'dir'      => 1,                # Bounce direction (-1 or 
+1)
            'idx'      => $idx,             # Index of this marble
            'id'       => $id,              # This marble's id in the 
+canvas
            'nticks'   => 0,                # Number of total ticks
            'nbounces' => 0,                # Number of bounces (on pe
+gs)
            'nleft'    => 0,                # Number of left-bounces
            'color'    => $color,           # Marble color
        };
    }
                                                                      
+          
    sub random_color() {
        my $r = int rand 256;
        my $g = int rand 256;
        my $b = int rand 256;
        my $color = sprintf "#%02x%02x%02x", $r, $g, $b;
    }
                                                                      
+          
    sub drop_marble() {
        my $mx = $marble_x;
        my $my = $marble_y;
        my $c = random_color;
        my $pm = new_marble($mx, $my, $c);
        $marbles{$pm->{'idx'}} = $pm;
    }

    sub move_marble($$$) {
        my ($id, $deltax, $deltay) = @_;
        $cv_marbles->move($id, $deltax, $deltay);
    }
                                                                      
+          
    sub manage_this_marble($) {
        my ($pm) = @_;
        my $idx = $pm->{'idx'};
        my $id = $pm->{'id'};
        my $nticks = $pm->{'nticks'}++;
        my $pvec = $vvector[$nticks];
        if (!$pvec) {
            (++$pm->{'nbounces'} > $npegs) and return 0;
            $pm->{'dir'} = (0 == (int(rand(9999)) % 2))? -1: 1;
            ($pm->{'dir'} < 0) and $pm->{'nleft'}++;
            $nticks = $pm->{'nticks'}++;
            $pvec = $vvector[$nticks];
        }
        my $dir = $pm->{'dir'};
        my ($dx, $dy) = ($dir * $pvec->[0], $pvec->[1]);
        &move_marble($id, $dx, $dy);
        return 1;
    }
                                                                      
+          
    sub manage_marbles() {
        my @marbles = sort { $a <=> $b } keys %marbles;
        for (my $i = 0; $i < @marbles; $i++) {
            my $idx = $marbles[$i];
            my $pm = $marbles{$idx};
            if (!manage_this_marble($pm)) {
                $cv_marbles->delete($pm->{'id'});
                my $bin_idx = $npegs - $pm->{'nleft'};
                my $count = ++$bin_count[$bin_idx];
                update_bin_count($bin_idx, $count);
                if ($count < $bin_dy) {
                    fill_bin($bin_idx, $count, $pm->{'color'});
                } else {
                    for (my $i = 0; $i < $nbins; $i++) {
                        $bin_count[$i] /= 2;
                        fill_bin($i, $bin_count[$i], $bin_color[$i]);
                    }
                }
                delete $marbles{$idx};
            }
        }
    }
                                                                      
+          
    sub time_passes() {
        if (++$drop_ticks >= $marble_latency) {
            $drop_ticks = 0;
            drop_marble;
        }
                                                                      
+          
        manage_marbles;
    }
}
                                                                      
+          
                                                                      
+          
##################
### GUI object ###
##################
BEGIN {
    my $stats_cv = 0;   # Statistics canvas
                                                                      
+          
    sub draw_circle($$$$$) {
        my ($x0, $y0, $x1, $y1, $color) = @_;
        $cv_marbles->createOval($x0, $y0, $x1, $y1, -fill => $color);
    }
                                                                      
+          
    sub draw_peg($$) {
        my ($x, $y) = @_;
        my $ra = $peg_r;
        my @opts = (-fill => 'black');
        $cv_marbles->createOval($x-$ra, $y-$ra, $x+$ra, $y+$ra, @opts)
+;
    }
                                                                      
+          
    sub draw_pegs() {
        my $n_pegs_in_row = 1;
        my $x0 = $peg_x;
        my $y0 = $peg_y;
        for (my $i = 0; $i < $npegs; $i++) {
            my ($x1, $y1) = ($x0, $y0);
            for (my $n = 0; $n < $n_pegs_in_row; $n++) {
                draw_peg($x1, $y1);
                $x1 += 2 * $peg_dx;
            }
            $y0 += $peg_dy;
            $x0 -= $peg_dx;
            ++$n_pegs_in_row;
        }
    }
                                                                      
+          
    sub draw_chute() {
        my ($x0, $x1) = (($cw - $chute_dx) / 2, ($cw + $chute_dx) / 2)
+;
        my ($y0, $y1) = (0, $chute_dy);
        $cv_marbles->createLine($x0, $y0, $x0, $y1, -width => $chute_w
+idth);
        $cv_marbles->createLine($x1, $y0, $x1, $y1, -width => $chute_w
+idth);
    }
                                                                      
+          
    sub fill_bin($$$) {
        my ($idx, $count, $color) = @_;
        my $old_idx = $bin_fill[$idx];
        my $x0 = $idx * $bin_x + 1;
        my $x1 = $x0 + $bin_x - 2;
        my $y0 = $ch - $count;
        my $y1 = $ch;
        my @opts = (-fill => $color);
        my $id = $cv_marbles->createRectangle($x0, $y0, $x1, $y1, @opt
+s);
        $bin_fill[$idx] = $id;
        $bin_color[$idx] = $color;
        $old_idx and $cv_marbles->delete($old_idx);
    }

    sub update_bin_count($$) {
        my ($idx, $count) = @_;
        my $old_idx = $bin_text[$idx];
        my $text = sprintf "%d", $count;
        my $x = ($idx + 1) * $bin_x - 32;
        $bin_text[$idx] = $stats_cv->createText($x, 10, -text => $text
+);
        $old_idx and $stats_cv->delete($old_idx);
    }
                                                                      
+          
    sub draw_bins() {
        my ($x0, $y0, $y1) = ($bin_x, $bin_y, $ch);
        for (my $i = 0; $i < $nbins; $i++) {
            $cv_marbles->createLine($x0, $y0, $x0, $y1, -width => $bin
+_width);
            $x0 += $bin_dx;
            $bin_count[$i] = 0;
            $bin_text[$i] = 0;
            $bin_fill[$i] = 0;
            update_bin_count($i, 0);
        }
    }
                                                                      
+          
    sub draw_framework() {
        draw_chute;
        draw_pegs;
        draw_bins;
    }

    sub create_gui() {
        $mw = new MainWindow(-title => "Marbles  $version");
        $mw->minsize($cw, 50 + $ch);
        $mw->maxsize($cw, 50 + $ch);
        my $f0 = $mw->Frame->pack(-fill => 'x');
        my $f1 = $f0->Frame->pack(-fill => 'x');
        my $f2 = $f0->Frame->pack(-fill => 'x');
        my $f3 = $f0->Frame->pack(-fill => 'x');
        my $b1 = $f1->Button(-text => 'Exit (esc)', -bg => 'green');
        $b1->configure(-command => sub { exit });
        $b1->pack(-side => 'right');
        $mw->bind("<Escape>", sub { $b1->invoke });
        my @opts = (-height => $ch, -bg => $cvcolor);
        $cv_marbles = $f2->Canvas(-width => $cw, @opts);
        $cv_marbles->pack();
        $stats_cv = $f3->Canvas(-bg => $cvcolor);
        $stats_cv->pack(-fill => 'x');
        $mw->repeat($marble_delay, \&time_passes);
        draw_framework();
        init_velocity_vector;
        MainLoop;
    }
}
[download]