While playing around with SDL and cellular autonoma, I made this infection simulator. Black cells are uninfected, uninnoculated hosts. Green are infected, and blue are innoculated.

Each generation, a green cell has a 50% chance of infecting a given black neighbor. A blue cell has a 50% chance of innoculating any given neighbor.

Use your left mouse button to put in green cells, and the right button for blue cells. Press "Enter" to start the simulation. If you run it from a console, the generation count will appear from there. You can hit "Enter" again to stop the simulation and repopulate cells with the mouse.

I'm not all that proud of this code. I initially started it with a combined SDL and Tk program (Tk was used for controling stopping and starting and displaying the generation count). Handling both the SDL and Tk event loops just got to be too much, so I ditched Tk. But there are still some remnants of that decision in the code. I think it's rather sloppy with lexical scopes. Not my best work, but it's functional :)

It's also quite slow, especially as the size of the green/blue population rises. This program has some heavy looping and function calling, which is really hard on Perl. You'd probably get a big speedup if it was rewritten in C. On the plus side, I now know my laptop can play skip-free MP3s while the CPU and memory is heavily loaded :)

Update: Fix a bug in neighbor_list() that duplicated a case.

#!/usr/bin/perl
use strict;
use warnings;
use SDL;
use SDL::App;
use SDL::Color;
use SDL::Rect;
use SDL::Event;

my $APP_WIDTH  = 320;
my $APP_HEIGHT = 240;
my $APP_DEPTH  = 32;
my $APP_TITLE  = 'Infection';

my $COLOR_BLACK = SDL::Color->new(
    -r => 0x00,
    -g => 0x00,
    -b => 0x00,
);
my $COLOR_GREEN = SDL::Color->new(
    -r => 0x00,
    -g => 0xFF,
    -b => 0x00,
);
my $COLOR_BLUE = SDL::Color->new(
    -r => 0x00,
    -g => 0x00,
    -b => 0xFF,
);
my $DEFAULT_OBJECT_WIDTH   = 20;
my $DEFAULT_OBJECT_HEIGHT  = 20;
my $DEFAULT_OBJECT_SPEED   = 10;



{
    my $sdl_app;
    sub set_sdl_app { $sdl_app = shift }
    my $tk_app;
    sub set_tk_app { $tk_app = shift }
    my ($bg, $bg_color);
    sub set_bg { ($bg, $bg_color) = @_ }
    my $infected_color;
    sub set_infected_color { $infected_color = shift }
    my $innoculated_color;
    sub set_innoculated_color { $innoculated_color = shift }


    sub copy
    {
        my @to_copy = @{ +shift };
        my @new_array;
        foreach my $x (0 .. $#to_copy) {
            my @row = @{ $to_copy[$x] };
            foreach my $y (0 .. $#row) {
                $new_array[$x][$y] = $to_copy[$x][$y];
            }
        }

        return @new_array;
    }

    my @cells = (
        map {[
            map 0, 0 .. $APP_HEIGHT - 1
        ]} 0 .. $APP_WIDTH - 1
    );
    my @cells_copy = copy( \@cells );
    sub infect_cell_copy
    {
        my ($x, $y) = @_;
        $cells_copy[$x][$y] = 1;
    }
    sub innoculate_cell_copy
    {
        my ($x, $y) = @_;
        $cells_copy[$x][$y] = -1;
    }
    sub infect_cell
    {
        my ($x, $y) = @_;
        $cells[$x][$y] = 1;
    }
    sub innoculate_cell
    {
        my ($x, $y) = @_;
        $cells[$x][$y] = -1;
    }

    my $generation = 0;
    sub next_generation
    {
        foreach my $x (0 .. $APP_WIDTH) {
            foreach my $y (0 .. $APP_HEIGHT-1) {
                no warnings; # About unintitlized vars
                if( $cells[$x][$y] > 0 ) {
                    infect_neighbors( $x, $y );
                }
                elsif( $cells[$x][$y] < 0 ) {
                    innoculate_neighbors( $x, $y );
                }
            }
        }

        @cells = copy( \@cells_copy );
        $generation++;
        return $generation;
    }
    sub neighbor_list
    {
        my ($x, $y) = @_;
        return (
            [ $x + 1, $y     ],
            [ $x - 1, $y     ],
            [ $x + 1, $y + 1 ],
            [ $x - 1, $y + 1 ],
            [ $x + 1, $y - 1 ],
            [ $x - 1, $y - 1 ],
            [ $x    , $y + 1 ],
            [ $x    , $y - 1 ],
        );
    }

    sub will_change { int rand 2 }
    sub infect_neighbors
    {
        my ($x, $y) = @_;
        my @neighbors = neighbor_list( $x, $y );
        foreach my $neighbor (@neighbors) {
            my ($nx, $ny) = @$neighbor;
            no warnings; # About unintitilized vars
            infect_cell_copy( @$neighbor ) if(
                ($cells[$nx][$ny] == 0) &&
                (will_change));
        }
    }

    sub innoculate_neighbors
    {
        my ($x, $y) = @_;
        my @neighbors = neighbor_list( $x, $y );
        foreach my $neighbor (@neighbors) {
            my ($nx, $ny) = @$neighbor;
            innoculate_cell_copy( @$neighbor ) if will_change;
        }
    }


    sub draw
    {
        my $app = shift;

        $app->fill( $bg => $bg_color );
        foreach my $x (0 .. $APP_WIDTH-1) {
            foreach my $y (0 .. $APP_HEIGHT-1) {
                if( $cells[$x][$y] > 0 ) {
                    $app->pixel( $x, $y, 
                        $infected_color );
                } 
                elsif( $cells[$x][$y] < 0 ) {
                    $app->pixel( $x, $y, 
                        $innoculated_color );
                }
            }
        }

        $app->update( $bg );
    }
}


{
    my $running = 0;
    sub toggle_running { $running ^= 1 }

    sub run
    {
        my ($sdl_app) = @_;
        while(1) {
            handle_events( $sdl_app );
            if( $running ) {
                my $gen = next_generation;
                local $| = 1;
                print "Generation $gen\r";
            }
            draw( $sdl_app );
        }
    }

    my $mouse_button = 0;
    sub handle_events
    {
        my ($sdl_app) = @_;

        my $event = SDL::Event->new;
        while( $event->poll ) {
            my $type = $event->type;
            if( $type == SDL_MOUSEBUTTONDOWN ) {
                my $x = $event->button_x;
                my $y = $event->button_y;
                $mouse_button = $event->button;
                if(! $running ) {
                    if( $mouse_button == 1 ) {
                        infect_cell( $x, $y );
                    }
                    elsif( $mouse_button == 3 ) {
                        innoculate_cell( $x, $y );
                    }
                }
            }
            elsif( $type == SDL_MOUSEMOTION ) {
                next unless $mouse_button;
                my $x = $event->button_x;
                my $y = $event->button_y;
                if(! $running ) {
                    if( $mouse_button == 1 ) {
                        infect_cell( $x, $y );
                    }
                    elsif( $mouse_button == 3 ) {
                        innoculate_cell( $x, $y );
                    }
                }
            }
            elsif( $type == SDL_MOUSEBUTTONUP ) {
                $mouse_button = 0;
            }
            elsif( $type == SDL_KEYDOWN ) {
                toggle_running 
                    if $event->key_state( SDLK_RETURN );
            }
            elsif( $type == SDL_QUIT ) {
                exit 0;
            }
        }
    }
}

sub init_sdl
{
    my $app = SDL::App->new(
        -title   => $APP_TITLE,
        -width   => $APP_WIDTH,
        -height  => $APP_HEIGHT,
        -depth   => $APP_DEPTH,
    );
    set_sdl_app( $app );

    my $bg = SDL::Rect->new(
        -height  => $APP_HEIGHT,
        -width   => $APP_WIDTH,
    );
    set_bg( $bg => $COLOR_BLACK );

    set_infected_color( $COLOR_GREEN );
    set_innoculated_color( $COLOR_BLUE );

    return $app;
}


{
    my $sdl_app  = init_sdl;

    run( $sdl_app );
}

[download]

"There is no shame in being self-taught, only in not trying to learn in the first place." -- Atrus, Myst: The Book of D'ni.

Janitored by Arunbear - added readmore tags, as per Monastery guidelines

Back to Cool Uses for Perl