Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

Cellular::Automata::1D

by Masem (Monsignor)
on Jul 06, 2001 at 00:44 UTC ( [id://94271]=sourcecode: print w/replies, xml ) Need Help??
Category: Fun Stuff
Author/Contact Info Michael K. Neylon (mneylon-pm@masemware.com)
Description: Allows one to simulate 1D automata with multiple colors using perl. The POD should sufficiently explain the use of the module.

Comments, critiques, and other inputs are gladly accepted!

#!/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 s
+pecified" 
    unless ( length $color_rep >= $colors );
    croak "Color representation must be specified with more than 26 co
+lors"
    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+$lengt
+h );
    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 otherwi
+se

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 autom
+ated
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 st
+ate
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 th
+e
range are used to determin the next state) or explicit (quantity and 
position of cells are important).  Note that in the grouping state, gi
+ven
C colors and a radius of R (where 2*R+1 cells are used), then the numb
+er
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, s
+kipping 
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, bu
+t
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 un
+def
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 droppe
+d
from the array.  If any array elements are not in the color representa
+tion
(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 sim
+ilarly
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 boundar
+ies,
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 u
+sed.

=item C<color_state_array>

An array or a reference to an array of the various color representatio
+ns
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 r
+eturn
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 ce
+ll
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 thi
+s 
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 th
+an
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 les
+s
than the previous value, and C<color_rep> is unspecified, the old colo
+r
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 ar
+ray.

=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 "Softwar
+e"),
to deal in the Software without restriction, including without limitat
+ion
the rights to use, copy, modify, merge, publish, distribute, sublicens
+e,
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 include
+d
in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRES
+S OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILIT
+Y,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHAL
+L
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;

Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others learning in the Monastery: (3)
As of 2024-03-19 04:48 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found