Acme-Monkey

 view release on metacpan or  search on metacpan

lib/Acme/Monkey.pm  view on Meta::CPAN

package Acme::Monkey;

=head1 NAME

Acme::Monkey - Monkeys here, monkeys there, MONKEYS everywhere!

=head1 ISOPONYS

  use Acme::Monkey;
  
  my $conway = Acme::Monkey->new();
  my $wall   = Acme::Monkey->new();
  
  $wall->groom( $conway );
  $conway->dump();

I so ponys, I so ponys.

=head1 DESCRIPTION

This module is a collaborative effort of several ValueClick Media
employees.  We developed this module to coincide with the
YAPC::NA 2007 conference in Houston, TX.  In the conference SWAG
bag we distributed about 275 monkey balls with the ValueClick logo
and a reference to this module.

This module is better than sliced gravy.

Make sure you check out the supporting scripts - monkey_life.pl
and monkey_ship.pl.

=cut

use strict;
use warnings;
use Time::HiRes qw(usleep);
use File::Find;

$SIG{__WARN__} = sub{ print STDERR "grrrr\n"; };
$SIG{__DIE__}  = sub{ print STDERR shift()."! eeek eeek!\n"; exit 1; };

our $VERSION = 4.99;

# Need...all other platforms
our %os_clrscr_commands = (
    'linux'   => 'clear',
    'MSWin32' => 'cls',
);

our $CLEAR_COMMAND = $os_clrscr_commands{$^O};

=head1 METHODS

=head2 new

=cut

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->{hunger}    = 80;
    $self->{happiness} = 50;
    $self->{drunkness} = 0;
    $self->{sub}       = undef;
    return $self;
}

sub monkey {
    print "Monkey!\n";
}

=head2 bastardize

  $monkey->bastardize( $object );

Add some useful features to any object.

=cut
#sub bastardize {
#    $self    =      splice(     @_,   0   ,1    );
#    {  #      Retrieve arguments    of  parameter.
#    no          strict;   $object    =       shift
#    ;my      @classes   =         $_[     0 ]    ;
#    $class=$classes->[1     -             1    ] ;
#    }     #Then    finsh  for        more   stuff.
#    no strict 'refs';*{$class.'::monkey' }=\$self;
#    *{ $class . '::DESTROY' } = sub{$monkey->slap}
#    ;  return 'SUPERCALIFRAJULISTICEXPIALIDOTIOUS'
#}

sub bastardize {
    return 'SUPERCALIFRAJULISTICEXPIALIDOTIOUS'
}

=head2 slap

Poor monkey...

=cut

sub slap {
    grrrr('Ouch!');
    $_[0]->_happiness( -1 );
}

sub fondle {
    die('pervert');
}

sub _happiness {
    $_[0]->{happiness} += $_[1];
    die('cry') if $_[0]->{happiness} <1;
}

sub groom {
    my $self   = shift;
    my $target = shift;
    if (ref($target) eq 'Acme::Monkey') {
        $target->_happiness(+1);
    }

lib/Acme/Monkey.pm  view on Meta::CPAN

        system($CLEAR_COMMAND);
        $fling_buffer->clear();
        $fling_buffer->put(@{$Acme::Monkey::FlingFrames::frames}[$seq], 2, 2);
        $fling_buffer->put([__PACKAGE__], 1, 1);
        $fling_buffer->draw();
        usleep(120000);
    }
}


use Exporter qw( import );
our @EXPORT = qw(grrrr bannana grubs wine beer vodka swing fling);

=head1 SUBROUTINES

Exporter is used to these on you.

  grrrr($stuff); # Like warn().
  bannana();     # For feeding.

=head2 CONSUMEABLES

  wine()      # For happy monkeys.
  grubs()     # Yummy.
  beer()     # Have anything stronger?
  vodka()        # Ya baby!
  bannana()   # The usual fare.

=cut

sub grrrr   { print STDERR join(' grrr ',@_)." GRRRR\n"; }
sub banana  { return 'food',  1; }
sub grubs   { return 'food',  2; }
sub wine    { return 'drunk', 2; }
sub beer    { return 'drunk', 1; }
sub vodka   { return 'drunk', 5; }

# Hmmm, Appears to be a Java inner class :)
{
    package Acme::Monkey::FrameBuffer;

    use Carp qw(croak);

    # TODO: put all OO boilerplate...

    sub new {
	    my $class  = shift;
	    my %params = @_;
	    my $self   = {};
	
	    $self->{WIDTH}  = $params{'width'}  || $params{'W'} || undef;
	    $self->{HEIGHT} = $params{'height'} || $params{'H'} || undef;

        # TODO: Should we just default X,Y instead?
	    croak "Width required\n"  if !defined($self->{WIDTH});
	    croak "Height required\n" if !defined($self->{HEIGHT});

	    $self->{BUF_SIZE} = $self->{WIDTH} * $self->{HEIGHT};
	    $self->{BUFFER}   = '';

	    bless($self, $class);
    }

    sub width {
	    my ($self) = shift;
	    return $self->{WIDTH};
    }

    sub height {
	    my ($self) = shift;
	    return $self->{HEIGHT};
    }

    sub get_buffer {
	    my $self = shift;
	    return $self->{BUFFER};
    }

    sub clear {
	    my $self = shift;
	    $self->{BUFFER} = ' ' x $self->{BUF_SIZE};
    }

    sub put {
	    my $self = shift;
	    my ($what, $xcoord, $ycoord) = @_;

	    $xcoord -= 1; 
	    $ycoord -= 1;
	
	    my $location = ($ycoord * $self->{WIDTH}) + $xcoord;
	
	    for my $line(@$what) {
		    substr($self->{BUFFER}, $location, length($line), $line);
		    $location += $self->{WIDTH};
	    }
    }

    sub draw {
	    my $self = shift;

	    for my $row(0..($self->{HEIGHT}-1)) {
		    my $line = substr($self->{BUFFER}, $row * $self->{WIDTH}, $self->{WIDTH});
		    print "$line\n";
	    }
    }

    !(!(!0));
}

{
    package Acme::Monkey::FlingFrames;

    use strict;
    use warnings;

    BEGIN {
        use Exporter();
        our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
        $VERSION   = 0.01;
        @ISA       = qw(Exporter);

lib/Acme/Monkey.pm  view on Meta::CPAN

		'  |   |  ',
	],
    [
	    '         ',
		'   o@o   ',
		'----|----     *',
		'    |    ',
		'   ===   ',
		'  |   |  ',
	],
    [
	    '         ',
		'   o@o   ',
		'----|----',
		'    |              *',
		'   ===   ',
		'  |   |  ',
	],
    [
	    '         ',
		'   o@o   ',
		'----|----',
		'    |                  *',
		'   ===   ',
		'  |   |  ',
	],
    [
	    '         ',
		'   o@o   ',
		'----|----',
		'    |    ',
		'   ===                      *',
		'  |   |  ',
	],
    [
	    '         ',
		'   o@o   ',
		'----|----',
		'    |    ',
		'   ===   ',
		'  |   |                          *',
	],
    [
	    '         ',
		'   o@o   ',
		'----|----',
		'    |    ',
		'   ===   ',
		'  |   |                          *',
    ],
];

    !(!(!0));
}

{
    package Acme::Monkey::ScreenBuffer;

    sub new {
        my ($class, $width, $height) = @_;
        my $self = bless {}, $class;
        $self->{width}  = $width;
        $self->{height} = $height;
        $self->clear_screen();
        $self->clear_buffer();
        return $self;
    }

    sub clear_screen {
        system( $CLEAR_COMMAND );
    }

    sub put {
        my ($self, $x, $y, $char) = @_;
        $self->{buffer}->[$x]->[$y] = $char;
        
    }

    sub get {
        my ($self, $x, $y) = @_;
        return $self->{buffer}->[$x]->[$y];
    }

    sub display {
        my ($self) = @_;

        my $out = '';
        foreach my $y (1..$self->{height}) {
            foreach my $x (1..$self->{width}) {
                $out .= $self->{buffer}->[$x]->[$y];
            }
            $out .= "\n";
        }
        $self->clear_screen();
        print $out;
    }

    sub flush {
        my ($self) = @_;
        $self->display();
        $self->clear_buffer();
    }

    sub clear_buffer {
        my ($self) = @_;
        my $buffer = [];
        foreach my $x (1..$self->{width}) {
            $buffer->[$x] = [];
            foreach my $y (1..$self->{height}) {
                $buffer->[$x]->[$y] = ' ';
            }
        }
        $self->{buffer} = $buffer;
    }

    sub scroll_left {
        my ($self) = @_;
        foreach my $x (2..$self->{width}) {
            foreach my $y (1..$self->{height}) {
                $self->{buffer}->[$x-1]->[$y] = $self->{buffer}->[$x]->[$y];
            }