Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
PerlMonks  

marbles

by liverpole (Monsignor)
on Sep 09, 2005 at 02:04 UTC ( #490406=sourcecode: print w/ replies, xml ) Need Help??

Category: GUI programming
Author/Contact Info liverpole
Description: Years ago (before I started learning Perl), I created a "bouncing ball" program in C, which displayed balls which randomly bounced left or right each time they hit a "peg".  My brother, a 5th grade teacher, started using it to teach his class about probabilities and statistics, and was always amused that they found it hard to believe the outcome would always be the same -- a "bell-shaped" curve.  I just recently rewrote the code in Perl, which will let my brother demonstrate it for his classes using Windows (rather than be constrained by Linux).  It will run under both, but Linux requires that the Tk module be installed first, of course.

Let me know if you have any questions, and I'll be more than happy to explain.

#!/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;
    }
}
                                                                      
+          

Comment on marbles
Download Code
Re: marbles
by zentara (Archbishop) on Sep 09, 2005 at 10:50 UTC
    Beautiful work (and there is no memory leak either, ++ ).

    I'm not really a human, but I play one on earth. flash japh
      zentara,
      As anyone will tell you, I am addicted to PerlMonks. I try to read every single thread on a daily basis though I no longer have the time to check them several times a day for follow ups.

      Ok - so what does this have to do with you and your reply - I have been able to get a good gauge for who is good at what. When it comes to Tk and GUI programming you are obviously no slump. To see you compliment someone else's code without offering suggestions I can only assume it was decent code as I have no clue when it comes to such matters. You went a step further and asserted that there were no memory leaks.

      Perhaps you might be willing to let us know how you came to that conclusion? I assume there are certain red flags that you look for coming from a great deal of experience in the matter. As someone who has had GUI programming on his "to-do" list for some time now, I would very much appreciate an education. If the details seem more appropriate in a new thread - that's fine, I am sure I will see it ;-)

      Don't feel bad if you don't have the time or just don't feel inclined - I will still look forward to your posts.

      Cheers - L~R

        Hi, after writing many Tk programs that run for any period of time, and have alot of "screen action", one of the main problems is Tk's ( and Perl in general) lack of automatic garbage collection. This is not a true memory leak, in the c sense, but just problems with the ref counts of Tk objects not going to zero(for various reasons) and stray objects get left laying around. This can cause the memory usage to climb at a perceptible rate.

        The first thing I do, with any Tk program is monitor it's memory usage as it runs, to see if it stays stable after a few minutes. See linux memory leak monitor for the handy little monitoring tool I use.

        These memory gains, usually come when writers undef objects and recreate them, or when objects have photos associated with them. In liverpole's cool program, he just used a single canvas object, so there was no gain, even though it "appeared" he was creating and destroying screen objects.

        By the way, this memory gain problem in GUI programs is not limited to Tk.....it affects all GUIs.


        I'm not really a human, but I play one on earth. flash japh

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://490406]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others lurking in the Monastery: (5)
As of 2014-12-26 01:53 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    Is guessing a good strategy for surviving in the IT business?





    Results (163 votes), past polls