package Permute;

#
#   String Permutation Expander
#   11/15/2007  MF  ver 0.04
#

use strict;

sub New{
    my $class = shift;
    my $string = shift;
    my %options = @_;

    my $self = {};
    bless ($self, $class);

    if (ref($options{marker}) eq "ARRAY" and
     $options{marker}[0] ne $options{marker}[0]){
        $self->{Smark} = $options{marker}[0];
        $self->{Emark} = $options{marker}[1];
    }elsif( defined $options{marker} ){
        warn "Invalid Marker Option";
        return;
    }else{
        $self->{Smark} = '[';
        $self->{Emark} = ']';
    }
    $self->_parse($string);
    return $self;
}


sub Next{
    my $obj = shift;
    $obj->_index(+1);   
    return $obj->Read;
}


sub Prev{
    my $obj = shift;
    if ($obj->{ci} == 0){
        $obj->{ci} = $obj->{mi};
        $obj->_sync;
    }else{
        $obj->_index(-1);   
    }
    return $obj->Read;
}


sub Read{
    my $obj = shift;
    if ($obj->{ci} == 0){
        return;
    }
    my $red;
    for ( @{ $obj->{blob} } ){
        $red .= "$_->[0][ $_->[1] ]";
    }
    return $red;    
}


sub GetIndex{
    return $_[0]->{ci};
}


sub GetCount{
    return $_[0]->{mi};
}


sub SetIndex{
    my ($obj, $newidx) = @_;
    unless ($newidx =~ /^\d+$/ and $newidx <= $obj->{mi}){
        return;
    }
    $obj->{ci} = $newidx;
    $obj->_sync;
    return 1;
}


sub Reset{
    $_[0]->{ci} = 0;
}


sub All{
    my $obj = shift;
    $obj->{saveidx} = $obj->GetIndex;
    $obj->Reset;
    my @all;
    my $string;
    while ($string = $obj->Next){
        push(@all, $string)
    }
    $obj->SetIndex($obj->{saveidx}); 
    if (wantarray){
        return @all;
    }
    return \@all;
}

# separates string and iteration segments
sub _parse{
    
    my ($obj, $string) = @_;
    my ($S, $E) = ($obj->{Smark}, $obj->{Emark});
    my @accum;
    $obj->{ci} = 0;
    $obj->{mi} = 1;

    while(defined $string){
        my ($pre, $remain) = split(/\Q$S/o, $string, 2);
        if (defined $pre){
            push(@accum, [ [$pre], 0, 1 ]);
        }

        my ($perm, $post) = split(/\Q$E/o, $remain, 2);
        if (defined $perm){
            my $subaref = _expand($perm);
            push(@accum, [ $subaref, 0, scalar(@$subaref) ]);
            $obj->{mi} *= scalar @$subaref;
        }
        $string = $post;
    }
    $obj->{blob} = \@accum;
}

# expands iteration segments into array
sub _expand{

    my @block = split(/\s*,\s*/, shift);
    my @acc;
    for (@block){
        if ($_ =~ /^\'(.+)\'$/)             { push(@acc, $1) }
        elsif ($_ =~ /^\"(.+)\"$/)          { push(@acc, $1) }
        elsif ($_ =~ /^(\d+)\.\.(\d+)$/)    { push(@acc, _seq($1, $2))
+ }
        elsif ($_ =~ /^([a-z])\.\.([a-z])$/){ push(@acc, _seq($1, $2))
+ }
        elsif ($_ =~ /^([A-Z])\.\.([A-Z])$/){ push(@acc, _seq($1, $2))
+ }
        else                                { push(@acc, split(/\s+/, 
+$_)) }
    }   
    return \@acc;
}

# expands num/character sequences
sub _seq{
    my ($beg, $end) = @_;
    if ($end lt $beg){
        my $str = qq("$end".."$beg");
        return reverse eval $str;
    }else{
        my $str = qq("$beg".."$end");
        return (eval "$str");
    }
}

# increment or decrement the object index
sub _index{

    my ($obj, $incr) = @_;
    $obj->{ci} += $incr;    
    if ($obj->{ci} < 0){
        $obj->{ci} = $obj->{mi};
    }elsif ($obj->{ci} > $obj->{mi}){
        $obj->{ci} = 0;
    }
    if ($obj->{ci}){
        $obj->_sync;
    }
}

# synchronize object index with iteration array indexes
sub _sync{

    my $obj = shift;
    my $ai = $obj->{ci} - 1;
    for my $seg (reverse @{ $obj->{blob} }){

        if ($seg->[2] == 1){
            next
        }
        $seg->[1] = $ai % $seg->[2];
        $ai = int($ai / $seg->[2]);
    }
}


1;
__END__
[download]