#!/usr/bin/perl -w

package Cellular::Automata::1D;

#=============================================================================
#
# $Id: 1D.pm,v 0.01 2001/07/05 20:37:34 mneylon Exp $
# $Revision: 0.01 $
# $Author: mneylon $
# $Date: 2001/07/05 20:37:34 $
# $Log: 1D.pm,v $
# Revision 0.01  2001/07/05 20:37:34  mneylon
# Initial Release
#
#
#=============================================================================

use strict;
use Exporter;
use Carp;

use Data::Dumper;

BEGIN {
    use Exporter   ();
    use vars       qw($VERSION @ISA @EXPORT %EXPORT_TAGS);
    $VERSION     = sprintf( "%d.%02d", q($Revision: 0.01 $) =~ /\s(\d+)\.(\d+)/ );
    @ISA         = qw(Exporter);
    @EXPORT      = qw();
    %EXPORT_TAGS = ( );
}

my %allowed_prefs = (
    ruletype => [ qw( explicit grouped ) ],
    ends     => [ qw( edges mirrors warps ) ]
		     );

sub new
{
    my $class = shift;
    my ( $size, $radius, $colors, $color_rep, $rules, $options ) = @_;

    # Defaults
    croak "Size must be greater than zero" unless ( $size ||= 100 ) > 0;
    croak "Radius must be non-negative" unless ( $radius ||= 1 ) >= 0;
    croak "Colors must be greater than one" unless ( $colors ||= 2 ) > 1;
    
    $color_rep ||= join '', ('A'..'Z');
    if ( ref ( $color_rep ) eq 'ARRAY' ) {
	$color_rep = join '', @$color_rep;
    }
    
    croak "Color representation must have at least as many colors as specified" 
	unless ( length $color_rep >= $colors );
    croak "Color representation must be specified with more than 26 colors"
	unless ( $colors < 26 || 
		 ( $colors > 26 && length $color_rep >= $colors ) );

    croak "Color representation cannot have duplicated characters" 
	unless ( _test_color_representation( $colors, $color_rep ) );

    $rules ||= {};
    $options ||= { ruletype => 'grouped',
		   ends => 'edges' 
		 };

    my $self = { size => $size,
		 radius => $radius,
		 colors => $colors,
		 rep => $color_rep,
		 cells => [ substr( $color_rep, 0, 1 ) x $size ],
		 rules => {},
		 options => {} };
    bless $self, $class;
    $self->set_rules( $rules );
    $self->set_preferences( $options );
    return $self;
}


sub set_rule
{
    my ( $self, $states, $state ) = @_;

    if ( ref( $states ) eq 'ARRAY' ) {
	$states = join '', @$states;
    }

    return 0 unless ( _test_colors( $states, $self->{ colors }, $self->{ rep } )
		    && 
		    _test_colors( $state, $self->{ colors }, $self->{ rep } )
		    );
    return 0 unless ( length $states >= 2 * $self->{ radius } + 1 );
    
    $states = substr( $states, 0, 2 * $self->{ radius } + 1 );
    
    if ( $self->{ options }->{ ruletype } eq 'grouped' ) {
	$states = _sort_on_colors( $states, $self->{ rep } );
    }

    $self->{ rules }->{ $states } = substr( $state, 0, 1 );

    return 1;
}

sub set_rules
{
    my ( $self, @rules ) = @_;

    my %rule_hash;
    if ( @rules == 1 && ref( $rules[0] ) eq 'HASH' ) {
	%rule_hash = %{ $rules[ 0 ] };
    } else {
	%rule_hash = @rules;
    }

    my $total = 0;
    foreach my $rule ( keys %rule_hash ) {
	$total += $self->set_rule( $rule, $rule_hash{ $rule } );
    }
    return $total;
}


sub get_rule
{
    my ( $self, $rule ) = @_;

    if ( $self->{ options }->{ ruletype } eq 'grouped' ) {
	$rule = _sort_on_colors( $rule, $self->{ rep } );
    }
    return $self->{ rules }->{ $rule };
}

sub get_rules
{
    my ( $self ) = @_;
    my %rulehash;
    foreach my $key ( keys %{ $self->{ rules } } ) {
	$rulehash{ $key } = $self->{ rules }->{ $key };
    }
    return %rulehash;
}

sub clear_rules
{
    my ( $self ) = @_;
    $self->{ rules } = {};
}

sub set_cell
{
    my ( $self, $pos, $color ) = @_;
    croak "Position is out of range" 
	unless ( $pos >= 0 && $pos < $self->{ size } );
    croak "Color is not one of specified color" 
	unless _test_colors( substr( $color, 0, 1 ), 
			     $self->{ colors }, $self->{ rep } );
    
    $self->{ cells }->[ $pos ] = substr( $color, 0, 1 );
}

sub set_cells
{
    my ( $self, $pos, @colors ) = @_;
    if ( @colors == 1 && ref( $colors[0] eq 'ARRAY' ) ) {
	@colors = @{$colors[0]};
    } elsif ( @colors == 1 ) {
	@colors = split //, $colors[0];
    }

    croak "Position is out of range"
	unless ( $pos >= 0 && $pos < $self->{ size } );
    croak "Color array too large"
	unless ( $pos + @colors <= $self->{ size } );

    foreach my $i ( 0..@colors-1 ) {
	$self->set_cell( $pos + $i, $colors[$i] );
    }
}

sub get_cell
{
    my ( $self, $pos ) = @_;
    croak "Position is out of range"
	unless ( $pos >= 0 && $pos < $self->{ size } );
    return $self->{ cells }->[ $pos ];
}

sub get_cells
{
    my ( $self, $start, $length ) = @_;
    $start ||= 0;
    $length ||= $self->{ size } - $start - 1;
    croak "Start position is out of range"
	unless ( $start >= 0 && $start < $self->{ size } );
    croak "Length is out of range"
	unless ( $start + $length < $self->{ size } && $length > 0 );
    my @array;
    push @array, $self->get_cell( $_ ) foreach ( $start..$start+$length );
    if ( wantarray ) {
	return @array;
    } else {
	return join '', @array;
    }
}

sub set_size
{
    my ( $self, $size ) = @_;
    croak "Size must be greater than zero" 
	unless ( $size > 0 );
    $self->{ size } = $size;
    $self->{ cells } = [ substr( $self->{ rep }, 0, 1 ) x $size ];
}

sub get_size
{
    my ( $self ) = @_;
    return $self->{ size };
}

sub set_radius
{
    my ( $self, $radius ) = @_;
    $self->{ radius } = $radius;
    $self->clear_rules();
}

sub get_radius
{
    my ( $self ) = @_;
    return $self->{ radius };
}

sub set_colors
{
    my ( $self, $colors, @color_rep ) = @_;

    croak "Number of colors must be larger than 1"
	unless $colors > 1;

    my $color_rep;
    if ( @color_rep > 1 ) {
	$color_rep = join '', map { substr( $_, 0, 1 ) } @color_rep;
    } elsif ( @color_rep == 1 ) {
	$color_rep = $color_rep[0];
    } else {
	$color_rep = $self->{ rep };
    }

    # Various checks
    croak "Color representation must be at least as large as number of colors"
	unless ( length( $color_rep ) >= $colors );
    croak "Color representation must have all unique characters"
	unless _test_color_representation( substr( $color_rep, 0, 
						   $colors ) );
	
    $self->{ colors } = $colors;
    $self->{ rep } = $color_rep;
    $self->clear_rules();
}

sub get_colors
{
    my ( $self ) = @_;
    return $self->{ colors };
}

sub set_color_representation
{
    my ( $self, @color_rep ) = @_;
    my $color_rep;
    if ( @color_rep > 1 ) {
	$color_rep = join '', map { substr( $_, 0, 1 ) } @color_rep;
    } else {
	$color_rep = $color_rep[0];
    }
    
    # Various checks
    croak "Color representation must be at least as large as number of colors"
	unless ( length( $color_rep ) >= $self->{ colors } );
    croak "Color representation must have all unique characters"
	unless _test_color_representation( substr( $color_rep, 0, 
						   $self->{ colors } ) );
    $self->{ rep } = $color_rep;
    $self->clear_rules();

}

sub get_color_representation
{
    my ( $self ) = @_;
    return wantarray ? split //, $self->{ rep } : $self->{ rep };
}

sub set_preferences
{
    my ( $self, @prefs ) = @_;
    my %prefs;
    if ( @prefs == 1 && ref( $prefs[0] ) eq 'HASH' ) {
	%prefs = %{ $prefs[0] };
    } else {
	%prefs = @prefs;
    }

    foreach my $key ( keys %prefs ) {
	if ( $allowed_prefs{ lc( $key ) } ) {
	    if ( grep { $_ eq lc( $prefs{ $key } ) } 
		 @{ $allowed_prefs{ lc( $key ) } } ) {
		$self->{ options }->{ lc( $key ) } = lc( $prefs{ $key } );
	    } else {
		croak "Value for preference '", lc( $key ), "' must be ",
		"one of (", join(',', @{ $allowed_prefs{ lc{ $key } } } );
	    }
	} else {
	    croak "Preference field '", $key, "' not known";
	}
    }
}

sub get_preferences
{
    my ( $self ) = @_;
    my %hash;
    foreach my $key ( keys %{ $self->{ options } } ) {
	$hash{ $key } = $self->{ options }->{ $key };
    }
    return %hash;
}

sub process
{
    my ( $self, $times ) = @_;
    $times ||= 1;
    foreach ( 1..$times ) { $self->_process(); }
}

# Internal, does one step

sub _process
{
    my ( $self ) = @_;
    my @newstate = ();
    foreach my $i ( 0..$self->{ size }-1 )
    {
	my @states = ();
	# Left end...
	if ( $i < $self->{ radius } ) {
	    foreach my $j ( $i - $self->{ radius } .. -1 ) {
		if ( $self->{ options }->{ ends } eq 'mirrors' ) {
		    push @states, $self->{ cells }->[ abs( $j ) ];
		} elsif ( $self->{ options }->{ ends } eq 'warps' ) {
		    push @states, $self->{ cells }->[ $j + $self->{ size } ];
		} else {
		    push @states, substr( $self->{ rep }, 0, 1 );
		}
	    }
	    foreach my $j ( 0..$i+ $self->{ radius } ) {
		push @states, $self->{ cells }->[ $j ];
	    }
	} elsif ( $i > $self->{ size } - $self->{ radius } - 1 ) {
	    foreach my $j ( $i - $self->{ radius } .. $self->{ size } - 1 ) {
		push @states, $self->{ cells }->[ $j ];
	    }
	    foreach my $j ( $self->{ size } .. $i + $self->{ radius } ) {
		if ( $self->{ options }->{ ends } eq 'mirrors' ) {
		    push @states, $self->{ cells }->[ 2*$self->{ size } - $j - 2 ];
		} elsif ( $self->{ options }->{ ends } eq 'warps' ) {
		    push @states, $self->{ cells }->[ $j - $self->{ size } ];
		} else {
		    push @states, substr( $self->{ rep }, 0, 1 );
		}
	    }
	} else {
	    foreach my $j ( $i - $self->{ radius }..$i + $self->{ radius } ) {
		push @states, $self->{ cells }->[ $j ];
	    }
	}
	
	my $states = join '', @states;
	if ( $self->{ options }->{ ruletype } eq 'grouped' ) {
	    $states = _sort_on_colors( $states, $self->{ rep } );
	}
	if ( $self->{ rules }->{ $states } ) {
	    $newstate[ $i ] = $self->{ rules }->{ $states };
	} else {
	    $newstate[ $i ] = substr( $self->{ rep }, 0, 1 );
	}
    }
    $self->{ cells } = \@newstate;
}


# ----
# Subs below here are for internal use only
# ----


# Internal : Test the given string against the color rep to make
# sure all string characters are only from the color rep.  True if
# so, false otherwise.

sub _test_colors
{
    my ( $string, $colors, $rep  ) = @_;
    return ( $string !~ /[^\Qsubstr( $rep, 0, $colors )\E]/ );
}

# Internal : Test the color representation string to make sure there
# are no duplicates, Returns true if free of duplicates, false otherwise

sub _test_color_representation
{
    my ( $colors, $rep ) = @_;
    return ( substr( $rep, 0, $colors ) !~ /(.).*\1/ );
}

# Internal : Sorts the first string based on the order of colors of
# the second string

sub _sort_on_colors
{
    my ( $string, $order ) = @_;
    return join '',
        sort { index( $order, $b ) <=> index( $order, $a ) }
        split //, $string;
}

__END__

=pod 

=head1 NAME
    
Cellular::Automata::1D - Implements 1-dimensional cellular simulations

=head1 SYNOPSIS

    use Cellular::Automata::1D;

    my $am = new Cellular::Automata( 100, 3, 3, ".*X" );
    $am->set_preferences( { ends => 'edges',
			    ruletype => 'grouped'
			    } );
    $am->set_rules( { '...' => '*',
		      '..*' => '*',
		      '.**' => 'X',
		      '***' => 'X',
		      '..X' => 'X',
		      '.XX' => '.',
		      'XXX' => '.',
		      '.*X' => 'X',
		      '**X' => 'X',
		      '*XX' => ',' } );
    $am->set_cells( 0, '.*X.*X.*X.' );
    $am->process( 100 );
    print $am->get_cells( );

=head1 DESCRIPTION

C<Cellular::Automata::1D> allows one to create automata that are automated
by rules set by the user.  The class allows for an number of 'colors' 
(or states) for cells, as well as for a cell to determine it's next state
by looking over a range of cells (eg, the 'radius').  Rulesets may be
defined as grouped (only the quantity of cells of certain colors in the
range are used to determin the next state) or explicit (quantity and 
position of cells are important).  Note that in the grouping state, given
C colors and a radius of R (where 2*R+1 cells are used), then the number
of rules required (N) will be:
 
               ( C + 2*R )!
     N = -----------------------  (eg, choose( C + ( 2*R+1 ) - 1, 2*R+1 ) )
         ( 2*R + 1 )! ( C - 1 )!

while for explicit rules, this quantity will be

     N = C^(2*R+1)

While this module tries to allow you to easily define such rulesets, skipping 
over unneeded rules, 
be aware that any large values of C or R will drastically increase the 
ruleset.

In all cases, the cells are numbers from 0 upwards, starting from the 'left'.

Note that in the case of grouping rulesets, the rule will be stored in a
'sorted' manner which may be different from what you inputted into the
ruleset.  For example, in a 3 color, radius 3 rule set, a rule that is 
entered for "212" may be stored and returned (through C<get_rules>
for example) as "122"; in a grouping ruleset, these are equivalent, but
will of course be different for explcit rulesets.

For any number of colors, the first color is assumed to be the 'dead'
state.  That is, if during determination of the next state, the
automata runs into a situation that has not been specified by the
rules, the cell will be set to the 'dead' state.  In addition, this is
used by the C<ends> prefernece setting, C<edges>.

=over

=item C<new>( [<size>], [<radius>] [<colors>], [<color_rep>], [<rules>], [<options>] )

Creates a new automata.  The following arguments can be passed to
C<new>:

=over

=item C<size> (Default: 100)

The size of the automata.

=item C<radius> (Default: 1)

The radius that the cell will 'see' to determine the next state.  
Thus, each rule will involve (2*radius + 1) cells centered on the one
to be changed.

=item C<colors> (Default: 2)

The number of colors or states that a cell can take

=item C<color_rep> (Default: "AB")

The character representation of the colors/states of the cell.  This
will not only be used to set and get the state of cells, but also used
for the ruleset.  Color 0 will be associated with the first character,
Color 1 with the second, and so forth.  If C<<colors>> is greater than
26, you must give an argument for C<<color_rep>>, as by default, the
first 26 characters will be assigned starting from A.to Z.

=item C<rules> ( Default: {} )

A reference to a hash containing the rules.  See c<set_rule> below
for more details on this.

=item C<options> ( Default: { ruletype => 'GROUPED', ends => 'EDGES' } )

A reference to a hash containing options for the automata.  See 
C<set_options> for specifics on this.

=back

=item C<set_rule>( <state_array> || <state_string>,  <new_state> )

Adds a new rule or changes an existing rule.  This function returns undef
if the rule was failed to be added.

=over

=item C<state_array>

A reference to an array of characters that represents the state.  This
must be at least (2*radius+1) elements long; extra elements are dropped
from the array.  If any array elements are not in the color representation
(see C<new>), this function will return undef as noted above.

=item C<state_string>

A string of characters that represents the state.  This is handled similarly
to C<state_array>

=item C<new_state>

A character that represents the new state that the cell should be set
to if this rule is activated.  This character should in the color
representation (see C<new>).

=back

=item C<set_rules>( <ruleset> )

Adds or updates (as appropriate) a number of rules at one time.
Returns the number of rules that were added from this function.

=over

=item C<ruleset>

A hash or reference to a hash, where the keys are either the same as
the C<state_array> or C<state_string> given above, and the values are
the C<new_state> values associated with each state. 

=back

=item C<get_rule>( <state_array> || <state_string> )

Returns the C<new_state> that is associated with the given state. 
C<state_array> and C<state_string> are in the same format as in 
C<set_rule>. 

=item C<get_rules>

Returns the current ruleset from the automata as a hash.  Keys are in
the same format as C<state_string> from C<set_rule>, values are the
associated C<new_state>s.

=item C<clear_rules>

Empties the ruleset of all rules.

=item C<set_cell>( <pos>, <color> )

Sets the cell at the given position Cpos> to the color C<color>.  Note 
that both C<pos> and C<color> must fall within the appropriate boundaries,
otherwise this function will return undef.

=item C<set_cells>( <pos>, <color_state_string> || <color_state_array> )
   
Sets a consecutive block of cells using a given input of color states.

=over

=item C<pos>

The position where the setting should start.

=item C<color_state_string>

A string composed of the various color representations that is to be used.

=item C<color_state_array>

An array or a reference to an array of the various color representations
that are to be set.  Note that if an array (not a reference to one) is
passed that is only composed of one element, it will be assume that
this is a C<color_state_string>.

=back

=item C<get_cell>( <pos> )

Returns the color state of the cell at the given position C<pos>.

=item C<get_cells>( [<start>], [<length>] )

Returns the color states of the cells.  If in scalar mode, this will return
the states as a string.  If in scalar mode, an array will be returns.  By
default, this will return the values for all cells.

=over

=item C<start> ( Default: 0 )

The starting position of which cells' values should be returned.  The return
value includes this specific cell's value.  

=item C<length> ( Default: from C<start> to end of cell list )

The length of cells starting from the C<start> position to be returned.  
If not specified, will return all cells starting from C<start> to the
end of the list.

=back

=item C<set_size>( <size> )

Sets the number of cells to be used in the automata.  B<The current cell
state is cleared to the 'dead' color value>.

=item C<get_size>

Returns the current number of cells in the automata.

=item C<set_radius>( <size> )

Sets the radius that should be used in determining the next state.  
B<This will call the function C<clear_rules>, due to the nature of this 
change>.

=item C<get_radius>( <size> )

Returns the current radius.

=item C<set_colors>( <number> [<color_rep>] )

Sets the number of colors to be used in the automata. B<This will call
the function C<clear_rules>, due to the nature of this change>.
 
=over

=item C<number>

The number of colors to be used.  If the number of colors is larger than
the previous color values, B<and> C<color_rep> is unspecified, this
function will issue a C<die>.  If the number of colors is equal or less
than the previous value, and C<color_rep> is unspecified, the old color
representation will be used.  

=item C<color_rep>

The new color representation to be used.  See C<new> for more details.  
Note that this must be at least as long as the number of colors given,
otherwise.this function will die.  

=back

=item C<get_colors>

Returns the number of colors for the automata.

=item C<get_color_representation>

Returns the color representation.  If in scalar context, this will be returned
as a string, while if in array context, this will be returned as an array.

=item C<set_preferences>( <prefs> )

Sets the preferences for the automata.

=over

=item C<prefs>

A hash or a reference to a hash.  The keys that are recognized are as
follows:

=over

=item C<ruletype> - Recongized values: grouped | explicit

Determines how the ruleset should be used, as a grouped (where only
quantity of the various cells matter), or explicit (where position 
and number both matter).

=item C<ends> - Recongized values: edges | mirrors | warps

Determined how cells near the end should behave.  If 'edges', any 
spaces that would be outside the block of cells are considered 
as empty, otherwise represented by the first color state.  If 
'mirrors', a mirror copy of the cells starting one back from the 
edge are made.  If 'warps', the edges are assumed to warp to the
other side of the automata and taken from there.

For example, given this 3 color automata, with a radius of 3:

    AABCBABCAC

In considering the first cell on the left, each C<ends> value would
produce a rule look-up as follows:

    edges:   AAAAABC
  mirrors:   CBAAABC
    warps:   CACAABC

=back

=back

=item C<get_prefs>

Returns the preferences for the automata as a hash.  Keys are each of the 
preference keys given above, with their associated values.

=item C<process>( [<number>] )

Processes the given number of steps in automata.

=over

=item C<number> ( Default: 1 )

Number of steps to perform.

=back

=back


=head1 HISTORY

    $Date: 2001/07/05 20:37:34 $

    $Log: 1D.pm,v $
    Revision 0.01  2001/07/05 20:37:34  mneylon
    Initial Release


=head1 AUTHOR

This package was written by Michael K. Neylon

=head1 COPYRIGHT

Copyright 2001 by Michael K. Neylon

=head1 LICENSE

Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT
OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.

=cut

42;