package qotw::Week7e;

use 5.006;
use strict;
use warnings;
use GD;
use constant ( DEBUG => 0 );

our $VERSION = '0.01';

sub new {
    my $class = shift;
    my %args = (
                rows    => 50,
                cols    => 100,
                vapour  => 50,
                ice     => 2,
                verbose => 0,
                @_,
            );

    die "Dimensions must be of even length\n" 
        if ( $args{rows} % 2 || $args{cols} % 2 );
            
    my $self = bless { cfg => \%args,
                       tick => 0,
                     }, $class;
    
    $self->_init();

    return $self;
}

sub _init {
    my $self = shift;
    my $cols = $self->get_cols();
    my $rows = $self->get_rows();
    
    print "Creating grid\n" if ($self->verbose());
    my $grid = qotw::Week7e::grid->new( $cols, $rows );
    
    my $vapour = int($cols * $rows * ($self->get_vapour()/100));

    print "Placing vapour\n" if ($self->verbose());
    $self->_placenodes( $grid, $vapour, 1 );

    print "Placing ice\n" if ($self->verbose());
    $self->_placenodes( $grid, $self->get_ice, 2 );
    
    $self->{ grid } = $grid;
    
    $self->{ _clear } ||= `clear`;

    return 1;
}

sub _placenodes {
    my ($self, $grid, $count, $value) = @_;

    my $maxx = $grid->get_cols();
    my $maxy = $grid->get_rows();
    
    for (1..$count) {
        while (1) {
            my ($x, $y) = (int(rand($maxx))-1,int(rand($maxy))-1);
            unless ( $grid->node( $x, $y ) != 0 ) {
                $grid->node( $x, $y, $value );
                last;
            }
        }
    }
}

sub get_rows {
    my $self = shift;

    return $self->{ cfg }->{ rows };
}

sub get_cols {
    my $self = shift;

    return $self->{ cfg }->{ cols };
}

sub get_vapour {
    my $self = shift;

    return $self->{ cfg }->{ vapour };
}

sub get_ice {
    my $self = shift;

    return $self->{ cfg }->{ ice };
}

sub verbose {
    my $self = shift;
    my $verbose = shift;
    
    $self->{ cfg }->{ verbose } = $verbose if (defined $verbose);
    
    return $self->{ cfg }->{ verbose };
}


sub tick {
    my $self = shift;
    my $tick = ++$self->{ tick };
    my $grid = $self->grid();

    print "beginning iteration $tick\n" if ($self->verbose());
    $self->{ change } = 0;
    
    my $origin = $tick % 2;
    
    my $maxx = $grid->get_endx();
    my $maxy = $grid->get_endy();

    my $x = $origin;
    my $y = $origin;

    while ($y <= $maxy) {
        $x = $origin;
        print "Processing line $y\n" if ($self->verbose());
        while ($x <= $maxx) {
            # process the neighbourhood
            warn "Doing $x, $y - " if DEBUG;
                     
            my @mn = $self->_domn( $grid->node( $x  , $y   ),
                                    $grid->node( $x+1, $y   ),
                                    $grid->node( $x+1, $y+1 ),
                                    $grid->node( $x  , $y+1 )
                                  );

            # put it back into the grid
            $grid->node( $x  , $y   , $mn[0] );
            $grid->node( $x+1, $y   , $mn[1] );
            $grid->node( $x+1, $y+1 , $mn[2] );
            $grid->node( $x  , $y+1 , $mn[3] );

            $x = $x + 2;
        }
        $y = $y + 2;
    }
    
    return $tick;
}

sub _domn {
    my $self = shift;
    my $field = join('',@_);

    if ($field =~ /1/) {
        if ($field =~ /2/) {
            $field =~ s/1/2/g;
        }else{
            if (int(rand(2))) {
                $field =~ s/(\d\d\d)(\d)/$2$1/;
            }else{
                $field =~ s/(\d)(\d\d\d)/$2$1/;
            }
        }
        $self->{ change }++;
    }

    return split('',$field);
}

sub grid {
    my $self = shift;

    return $self->{ grid };
}

sub change {
    my $self = shift;

    return $self->{ change };
}

sub display {
    my $self = shift;

    print $self->{ _clear };
    print $self->{ tick }."\n";

    my $grid = $self->grid();
    my $endx = $grid->get_endx();
    my $endy = $grid->get_endy();

    my @glyphs = ( ' ', '.', '*' );

    for my $y (0..$endy) {
        for my $x (0..$endx) {
            print $glyphs[ $grid->node( $x, $y ) ];
        }
        print "\n";
    }
    
    return 1;
}

sub export {
    my $self = shift;
    my $file = shift;
    my $size = shift || 1;

    print "Creating canvas\n" if ($self->verbose());
    my $img = GD::Image->new($self->get_cols*$size, $self->get_rows*$size);

    my @colours = ( $img->colorAllocate(0,0,0),
                    $img->colorAllocate(0,0,255),
                    $img->colorAllocate(255,255,255) );

    my $grid = $self->grid();
    my $maxx = $grid->get_endx();
    my $maxy = $grid->get_endy();
    
    print "Painting canvas\n" if ($self->verbose());
    for my $y (0..$maxy) {
        for my $x (0..$maxx) {
            my $c = $x*$size;
            my $d = $y*$size;
            $img->filledRectangle($c,$d,$c+$size,$d+$size,$colours[$grid->node($x,$y)]);
        }
    }

    print "Converting to png format\n" if ($self->verbose());
    my $png = $img->png;
    print "Writing to file\n" if ($self->verbose());
    open OUTPUT, "> $file" or die "Can't open output file $file : $!\n";
    binmode OUTPUT;
    print OUTPUT $png;
    close OUTPUT;
}

package qotw::Week7e::grid;

sub new {
    my $class = shift;
    my $cols = shift;
    my $rows = shift;

    my $self = bless { rows => $rows,
                       cols => $cols,
                       endx => $cols - 1,
                       endy => $rows - 1,
                       grid => [],
                     }, $class;

    $self->_makegrid();

    return $self;
}

sub _makegrid {
    my $self = shift;

    my $endx = $self->get_endx();
    my $endy = $self->get_endy();

    my $grid = $self->get_grid();
    
    for ( 0..$endx ) {
        my @col = ();
        map { $col[$_] = 0 } (0 .. $endy);
        push @$grid, \@col;
    }
}

sub node {
    my ($self, $x, $y, $value) = @_;

    my $grid = $self->get_grid();
    $x = 0 if ( $x == $self->{ cols });
    $y = 0 if ( $y == $self->{ rows } );
    
    $grid->[$x]->[$y] = $value if (defined $value);
        
    return $grid->[$x]->[$y];
}
   
sub get_rows {
    my $self = shift;

    return $self->{ rows };
}

sub get_cols {
    my $self = shift;

    return $self->{ cols };
}

sub get_endx {
    my $self = shift;

    return $self->{ endx };
}

sub get_endy {
    my $self = shift;

    return $self->{ endy };
}

sub get_grid {
    my $self = shift;

    return $self->{ grid };
}

1;
__END__

=head1 NAME

qotw::Week7e - Calculate a simulation of frost.

=head1 SYNOPSIS

  use qotw::Week7e;
  my $frost = qotw::Week7e->new( 
        rows    => 50, 
        cols    => 100, 
        ice     => 2, 
        vapour  => 50, 
        verbose => 0 
        );
        
  while (1) {
    my $loop = $frost->tick();
    
    # Write out a snapshot every 20 ticks
    if (!($loop % 20)) {
        my $file = sprintf "frost%04.0d.png", $loop;
        $frost->export( $file );
    }

    # Carry on until there's no further change
    unless ($frost->change()) {
        my $file = sprintf "frost%04.0d.png", $loop;
        $frost->export( $file );
        print "\nRun complete on iteration $loop\n";
        last;
    }
  }

=head1 DESCRIPTION

This module implements the frost simulation algorithm puzzle set as
Perl Quiz of the Week # 7.

=head1 SIMULATION METHODS

=over 4

=item new( row => x, col => y, vapour => z, ice => n, verbose => v );

Create a new grid of size x by y. Distribute a vapour density of z%
randomly throughout the grid. Place n ice particles randomly on the
grid.

Prints out various descriptive messages if verbose is set to a true
value.

=item tick();

perform the calculations for the next step.

Returns the number of ticks processed in this simulation.

=item grid();

Returns an object of type qotw::Week7e::grid that represents the
current grid.

=item display();

update an ASCII graphical display of the grid.

=item export( 'filename' );

export a png graphic into the filename specified.

=back 4

=head1 GRID METHODS

=over 4

=item node( $x, $y, $value );

Get or set a node in the grid. Called with two arguments, it returns
the value of the node at that position. Called with a third argument it
sets the position to the third value.

=head1 AUTHOR

Simon Wilcox, E<lt>perl@simonwilcox.co.ukE<gt>

=head1 SEE ALSO

L<perl>.

=cut
