type.pl

#!/usr/bin/perl 

# type of a given permutation
# emilbarton 2013

## modules:
######################################################################
use strict;
use warnings FATAL => "all";

## args and globals
######################################################################
if ((@ARGV)< 1 || $ARGV[0] =~ /help|usage/){ &Usage() };
my $TARGET = $ARGV[0]; my @TARGET = split //, $TARGET;
my @UPLETS; my $MODE = 0;
if ((@ARGV) > 2 ) { if (int($ARGV[2])) { $MODE = $ARGV[2] } }
my $SIGNS; my $SEEN = "";
my $INDEX = "0123456789ABCDEFGHIJKLMN";
my @INDEX = split //,$INDEX;
our 	%Digh;
for 	(my $n = 0; $n < scalar(@INDEX); $n++){ $Digh{$INDEX[$n]} = $n };

## permutation check:
######################################################################
my $LEN = (@TARGET); 
die "invalid length" if ($LEN > (@INDEX) );
for (my $i = 0; $i < $LEN; $i++) { $SIGNS = $SIGNS.$INDEX[$i] }  
foreach (@TARGET) {
	my $char = $_; 
	die "invalid sign in $TARGET: $char" if ($SIGNS !~ /$char/i);
	die "repeated signs not allowed" if ($SEEN =~ /$char/i);
	$SEEN .= $char;
}

## uplets:
######################################################################

print &Ptype($TARGET)."\n";

## subroutines
######################################################################


### baseb:
sub Baseb { ## Revised 110519. 
  my ($value,$base,$obase,$mode) = @_;
  $base = 10 unless (defined($base) && $obase =~ /.+/);
  $mode = 0 unless (defined($mode) && $mode =~ /.+/);
  if ($obase < 2 || $obase > 24) {
    die("Invalid original base.");
  }
  if ($base < 2 || $base > 24) {
    die("Invalid target base.");
  }
  ## Put it in base 10:
  my $newval = &Decab($value,$obase);
  my $res = ($newval%$base);
  if ($res >= 2 && $res < 62) { $res = $INDEX[$res] }
  my @res = $res;
  for ($newval = int($newval/$base);$newval >= 1; $newval = int($newval/$base)) {
    $res = ($newval%$base);
    $res = $INDEX[$res];
    unshift @res, $res ;
    # &Debug($subname, "=> base(): val: $value, res: @res", 1);
  }
  # Permutational mode:
  if ($mode == 1) {
    for (my $i = $base-(scalar(@res)); $i > 0; $i--){ unshift @res,"0" }
  }
  my $rslt = join "",@res;
  return $rslt;
} ## END Baseb().

### decab:
sub Decab { 
  my ($value,$base) = @_;
  my @value = split //,$value;
  my @newval = split //,$value;
  my $res = 0;
  my $x = (@value) - 1;
  if ($base < 2 || $base > 24) {
    die("Invalid original base: $base.");
  }
  for (my $n = 0; $n < (@newval); $n++){ 
    $newval[$n] = $Digh{$newval[$n]};
    { no warnings; 
    	if ($newval[$n] >= $base) {
    		die("Invalid value $newval[$n] in base $base.");
    	}
    }
  }
  foreach (@newval) {
    my $digit = $_;
    { no warnings; $res = $res + ($digit * ($base ** $x)); } 
    --$x;
  }
  return $res;
} ## END Decab().

### decadod:
sub Decadod { 
  my ($n) = @_; 
  my $res = $n;
  if (int($n) < 25){
  	$res = $INDEX[$n] ;
  }	
  else { die("$n is no valid arg. ") }
  return $res;
} ## END Decadod().

### dodecad:
sub Dodecad { 
  my ($n) = @_; 
	my $res = $n;
	if (exists $Digh{$n}){ $res = $Digh{$n} }
	else { die "$n is no valid arg." }
  return $res;
} ## END Dodecad().
    

### partel:
sub Partel { 
  my ($row) = @_;
  my @perm = split //, $row;
  my @partel;
  for (my $n = 0; $n < (@perm); $n++) {
    my $U = "";
    my $j = &Dodecad($perm[$n]);
    my $J = $perm[$n];
    next if ("@partel" =~ /$J/);
    if ($J =~ /$INDEX[$n]/){ push @partel,$J }
    else {
      while ($U !~ /$J/){
        $U .= $J;
        $J = $perm[$j];
        $j = &Dodecad($J);
      }
      push @partel,$U;
    }	
  }		
   return @partel;
} ## END Partel().

### ptype:
sub Ptype { 
  my ($str) = @_;
  my @partel = &Partel($str,"0");
  @partel = sort(@partel);
  my (@len,@type);
  for (my $n = 0; $n <= length($str); $n++) { $len[$n] = 0 }
  for (my $n = 0; $n < (@partel); $n++) { my $l = length($partel[$n]); $len[$l]++; }
  for (my $n = 0; $n <= length($str); $n++) { $len[$n] = &Decadod($len[$n]) }
  shift(@len);
  my $ret;
  foreach (@len){$ret = $ret.$_};
  return $ret;
} ## END Ptype().

### usage:
sub Usage {
	my $data;
	while (<DATA>) { $data .= $_ };
	die "Usage:\n$data";
} ## END Usage()

__DATA__

This program can be used to compute the type of a permutation. 

Try:

  $ ./type.pl target 

  Example:
  
  $ ./type.pl 73206514 
  20000100

Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s