metana.pl

#!/usr/bin/perl 

# permutation analysis 
# emilbarton 2013


# modules:
######################################################################
use strict;
use warnings FATAL => "all";
use sigtrap 'handler' => \&inthandler, 'INT';
use Modern::Perl;

# global vars:
######################################################################
our $Got_sigint = 0;
our @Items;
our $N = 0;
my $SIGNS; my $SEEN = "";
my $INDEX = "0123456789ABCDEFGHIJKLMN";
my @INDEX = split //,$INDEX;
my %Digh;
for 	(my $n = 0; $n < scalar(@INDEX); $n++){ $Digh{$INDEX[$n]} = $n };

# args
######################################################################
if ((@ARGV)== 0 || $ARGV[0] =~ /help|usage/){ &usage() };
my $Targ = $ARGV[0]; my $Len = length($Targ) + 2; 
my @Out = &Metana($Targ);
foreach (@Out) { 
	foreach (@{$_}) {
		my $s = $_;
		my $i = length($s);
		print $s.Tabs(($Len-$i)); 
	}
	print "\n";
}

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

### anas:
sub Anas { ## Revised 110519.
  my ($seq,$mode) = @_;
	my $subname = "Anas()";
  my @seq = split //,$seq;
  my ($i,$n,$ret,$allint,$intern,@inter,@intercnt); 
  foreach (@seq) { push @intercnt, '0' } ;
  for ($i = 0; $i = &Dodecad($seq[$i+1],$subname)) { $intern = &Dodecad($seq[$i],$subname)-&Dodecad($seq[$i+1],$subname);}
    else { $intern = &Dodecad($seq[$i+1],$subname)-&Dodecad($seq[$i],$subname);} 
    ++$intercnt[$intern] ;
    push @inter , &Decadod($intern,$subname);
  }
  for ($i = 0; $i < (@intercnt); $i++) { $intercnt[$i] = &Decadod($intercnt[$i],$subname); }   
  my $int = join '', @inter; 
  my $ict = join '', @intercnt; 
  return ($int,$ict);
} ## END Anas().

### compose:
sub Composind { 
	my ($t,$g) = @_;
  my @target = split //,$t; 
  my @agent = split //,$g;
  my (@agent_by_char, $cnt, $result, @tmp_result, @target_by_char);
  for (my $i = 0; $i < (@agent); $i++) { # We create char-indice pairs.
    $target[$i] = [$target[$i],$i]; $agent[$i] = [$agent[$i],$i];
  }
  @target_by_char = sort {@$a[0] cmp @$b[0]} @target; # We order pairs according to the char.	
  @agent_by_char = sort {${$a}[0] cmp ${$b}[0]} @agent;
  @tmp_result = map { [ @$_ ] } @target_by_char; # Bait modifying sequence: note the indispensable call to map().
  for (my $i = 0; $i < (@agent_by_char); $i++){ ${$tmp_result[$i]}[1] = ${$target_by_char[${$agent_by_char[$i]}[1]]}[1] }
  foreach (sort {${$a}[1]  ${$b}[1]} @tmp_result) { $result .= ${$_}[0] }
  return $result;
} ## END Composind().

### cyclan:
sub Cyclan { ## Revised 110519.
  my ($s,$mode) = @_;
	my $subname = "Cyclan()";
  my @seq = split //,$s;
  my ($i,$n,$ret,$allint,$intern,@inter,@intercnt); 
  my $base = (@seq);
  my $b = sprintf("%0.f",($base)/2); # = ceil(1/2*base) +1
  while ($b >= 0) { push @intercnt, '0'; $b--;} ;
  for ($i = 0; $i < (@seq)-1; $i++){
    if (abs(&Dodecad($seq[$i],$subname)+2*$base-&Dodecad($seq[$i+1],$subname))%$base <= abs(&Dodecad($seq[$i+1],$subname)+2*$base-&Dodecad($seq[$i],$subname))%$base) { $intern = abs(&Dodecad($seq[$i],$subname)+2*$base-&Dodecad($seq[$i+1],$subname))%$base;}
    else { $intern = abs(&Dodecad($seq[$i+1],$subname)+2*$base-&Dodecad($seq[$i],$subname))%$base;} 
    ++$intercnt[$intern] ;
    push @inter , &Decadod($intern,$subname);
  }
  if (abs(&Dodecad($seq[$i],$subname)+2*$base-&Dodecad($seq[0],$subname))%$base <= abs(&Dodecad($seq[0],$subname)+2*$base-&Dodecad($seq[$i],$subname))%$base) { $intern = abs(&Dodecad($seq[$i],$subname)+2*$base-&Dodecad($seq[0],$subname))%$base;}
  else { $intern = abs(&Dodecad($seq[0],$subname)+2*$base-&Dodecad($seq[$i],$subname))%$base;} 
  ++$intercnt[$intern] ;
  push @inter , &Decadod($intern,$subname);
  for ($i = 0; $i < (@intercnt); $i++) {
    $intercnt[$i] = &Dodecad($intercnt[$i],$subname); 
  }   
  my $cyn = join '', @inter;
  my $cyc = join '', @intercnt;
  return ($cyn,$cyc);
} ## END Cyclan().

sub Decab { ## Revised 110621.
  my ($value,$base,$opts) = @_;
  $base = 24 unless (defined($base) && $base =~ /.+/);
  my @value = split //,$value;
  my $res = 0;
  my $x = (@value) - 1;
  my @newval = @value;
  if ($base  62) {
    die("Decab(): Invalid original base: $base.");
  }
  for (my $n = 0; $n = $base) {
      die("Decab(): Invalid value $newval[$n] in base $base.");
    }
  }
  foreach (@newval) {
    my $digit = $_;
    $res = $res + ($digit * ($base ** $x)); --$x;
  }
  return $res;
} ## END Decab().

### decadod:
sub Decadod { 
  my ($n,$sub) = @_; $sub //="";
  my $subname = "Decadod()";
  my $res = $n;
  if ($n =~ /^([0-9]+)$/){
  	$res = $INDEX[$n] ;
  }	
  else { warn("$subname: $n is no valid arg. ($sub)") } 
  return $res;
} ## END Decadod().

### dodecad:
sub Dodecad { 
  my ($n) = @_; 
	my $res = $n;
	if (exists $Digh{$n}){ $res = $Digh{$n} }
	else { die "Dodecad(): $n is no valid arg." }
  return $res;
} ## END Dodecad().
    
### gradomap:
sub Gradomap { ## Revised 111008.
  my ($perm,$opt) = @_;
  $opt //= "";
  my $deg = &Gradual(&Omap($perm));
  my @msuite; my $len = length($perm);
  @msuite = &Gradual(&Omap($perm),1);
  my (@per,@octs,$octrow,$row);
  for (my $n = 0; $n < (@msuite); $n++) {
  	$row = &Unmap($msuite[$n],$perm);
  	push @per, $row;
    $octrow = &Octset($len,0); 
    push @octs, $octrow;
  }   
  if ($opt =~ /a/) { return(@per) } 
  elsif ($opt =~ /p/) { return([@per], [@octs]) } 
  else { return ($deg, $row, $octrow) } # Opt=last.
} ## END Gradomap().

### gradual:
sub Gradual {
  my ($row,$opt) = @_;
  $opt //= 0;
  my $ind = &Natural($row);
  my $target = $row;
  my $deg = 1; my @per;
  my $len = length($row);
  push @per, $row;
  goto GRAD_END if ($ind =~ /$row/);
  while (++$deg){
    $target = &Composind($target,$row);
    last if ($ind =~ /$target/);
    push @per, $target; 
  }
  GRAD_END: 
  if ($opt == 1) { return @per } 
  else { return $deg } 
} ## END Gradual().


### invert:
sub Invert { ## Revised 111002.
  my ($notes, $octaves, $base, $axis, $opt) = @_; 
	my $subname = "Invert()";
  my @seq = split //,$notes; 
  my @octs = split(//,($octaves //="")); 
  $base //= length($notes);
  $axis //= &Dodecad($seq[0],$subname);
  $opt //="";
  my ($inv, $invocts, $newseq, $newocts,@outnotes,@outocts);
  $inv = $invocts = $newseq = $newocts = "";
  for (my $n = 0; $n  $axis) { ($thisnote,$thisoct) = &Notesum($c,$axis,"-",$base); $sign = "-" }
    if ($c  0);
    $thisoct = $base-1 unless ($thisoct 0) && (($n+1)%$base == 0)){ # The series is ready to be recorded.
			push @outnotes, $newseq; push @outocts, $newocts; 
			$newseq = $newocts = "";
		} ## Otherwise some last notes will be left so:
  }
  if ($newseq =~ /.+/) {
		my $len = length($newseq);
		for (my $n = 0; $n < ($base-$len); $n++) { 
			$newseq .= "0"; $newocts .= "0"; # Fill missing notes.
		} 
		push @outnotes, $newseq; push @outocts, $newocts; 
  }
  if ($opt =~ /s/) { return ([@outnotes], [@outocts]) } ## Serial.
  elsif ($opt =~ /p/) { return ($inv, $invocts) } ## Raw notes and octs.
  return $inv; ## One sequence, no octs.
} ## END Invert().

### map:
sub Map { ## Revised 111008.
  my ($perm,$map) = @_;
	my $subname = "Map()";
  my @perm = split //, $perm; 
  my @map = split //, $map;
  my ($i, $n, $res);
  for ($i = 0; $i < scalar(@perm); $i++) {
    for ($n = 0; $n < scalar(@map); $n++) { last if ($map[$n] =~ /$perm[$i]/) }		
    $res .= &Decadod($n,$subname);
  }
  return $res;
} ## END Map().

### metana:
sub Metana {
  my ($row) = @_;
  my ($deg,$inv,$len,$map,$mod,$mot,$oc,$opd,$opt,$opp,$rev,$rw,$ser,$tone,$typ);
  my (@ana,@cyc,@mdeg,@oppdeg,@out,@prt,@sdeg);
  my $base = length($row);
  $rev 		= &Revert($row,$base); # $notes, $octaves, $opt
  $opp 		= &Oppose($row);
  $inv 		= &Invert($row);
  $map 		= &Map($opp,$row);
  @sdeg 	= &Gradual($row,1);
  @oppdeg = &Oppsuite($row,'a');
  @mdeg 	= &Gradomap($row,'a');
  $len 		= length($row);
  push @out, [("S: $row", "I: $inv", "R: $rev", "O: $opp", "M: $map")];
  my @names = (['Gradual','Suite:'],['Opposite','Suite:'],['Gradual','Omap', 'Suite','(unmapped):']);
  my $n = 0;
  foreach (\@sdeg, \@oppdeg, \@mdeg) {
    my $ref = $_; my @set;
    push @out, $names[$n++];
    push @out, [("ind", "ser", "int", "ict", "cyn", "cyc", "deg", "odg", "mod", "typ", "opt", "mot", "par")];
    for (my $n = 0; $n < scalar(@{$ref}); $n++) {
      $ser = ${$ref}[$n];
      @ana = &Anas($ser); @cyc = &Anas($ser); 
      $opp = &Oppose($ser); $map =  &Map($opp,$ser); 
      $deg = &Gradual($ser); ($opd,$rw,$oc) = &Oppsuite($ser); ($mod,$rw,$oc) = &Gradomap($ser);
      $typ = &Ptype($ser); $opt = &Ptype($opp); $mot = &Ptype($map); 
      @prt = &Partel($ser,0) if ($INDEX !~ /$ser/);
      @set = ($n+1, $ser, $ana[0], $ana[1], $cyc[0], $cyc[1], $deg, $opd, $mod, $typ, $opt, $mot, "@prt");
	    push @out, [@set];
    }
  }
  return @out;
} ## END Metana().

### natural:
sub Natural { ## Revised 111002.
	my ($str) = @_;
  my @tmp = split(//,$INDEX);
  splice(@tmp,length($str));
	return(join '',@tmp);
} ## END Csgrouper::Natural().

### Notesum:
sub Notesum { ## Revised 111002.
  my ($note,$inter,$sign,$base,$opt) = @_; # Note is expressed in base 10.
  my $subname = "Notesum()";
  $base //= 24; ## Here the base refers to the sign index.
  $opt //= 'n'; ## Normal behaviour (note).
	my @res;
  { no warnings; ## Sometimes vars must be uninitialised:
		{ no warnings;
			$res[0] = ($note + "$sign$inter") ; ## The n-phonic sum.
		}
		$res[1] = "0"; ## The number of octaves up or down that we'll get after summing.
		## This sub can be used to create octave rows alone, but for octaves 
		## we don't care about an octave of the octave! so let's reach limits:
		if ($opt =~ /o/){ ## Cf. Series.pm.
			if ($res[0]  $base) { $res[0] = $base } 
		}
		else { ## Normal behaviour (for notes):
			if ($res[0] = $base) { $res[0] -= $base ; $res[1] = 1 } 
		}
  }
  return @res;
} ## END Notesum().

### octset:
sub Octset { ## Revised 110519.
  my ($siz,$mode) = @_;
  my $octstr = "";
  $mode = 1 if ($mode !~ /.+/);
  # my  @c =  qw/0 1 2 2 2 3 3 3 3 4 4 4 5 5 6 7/; # Too low.
  my  @c =  qw/4 5 6 6 6 7 7 7 7 8 8 8 8 8 9 9/; # This is the range and probability.
  for (my $i = 0; $i < $siz; $i++) { 
		if ($mode == 1) { $octstr .= $c[int(rand(16))] }  
		else { $octstr .= 2 } # No randomness
  } 
  return $octstr;
} ## END Octset().

### omap:
sub Omap { ## Revised 111008.
  ## = &Powerp(&Oppose($row),&Powerp(&Natural($row),$row,-1)).
  ## Indistinct signs not allowed (this would yield a string containing a 'C').
  my ($row) = @_;
	my $subname = "Omap()";
  my @perm = split //,&Oppose($row); 
  my @map = split //, $row;
  my ($res,$n);
  for (my $i = 0; $i < scalar(@perm); $i++){
    for ($n = 0; $n  length($INDEX));
  $opt //= "";
  if ($opt =~ /s/) {  ## Serial.
		my @array = &Invert($notes,$octs,$base,$axis,$opt); 
		my $rows = join '',@{$array[0]};
		my $octs = join '',@{$array[1]};
		return(&Revert($rows,$octs,$base,$opt));
  }
  elsif ($opt =~ /p/) { ## Raw notes and octs.
		my @array = &Invert($notes,$octs,$base,$axis,$opt); 
		return(&Revert($array[0],$array[1],$base,$opt));
  } ## One sequence, no octs:
	return(&Revert(&Invert($notes,$octs,$base,$axis),$octs,$base)); 
} ## END Oppose().

### opsuite:
sub Oppsuite { # Revised 111008.
  my ($row,$opt) = @_;
  my $ind = $row;
  $opt //= "";
  $row = &Oppose($row);
  my $targ = $row; my $deg = 1; my $len = length($row);
  my $octrow = &Octset($len,0);
  my (@per,@octs); 
  push @per, $row; push @octs, $octrow;
  goto OPPDEGEND if ($ind =~ /$row/);
  while (++$deg){
    $targ = &Oppose($targ);
    $octrow = &Octset($len,0);
    push @per, $targ ;
    push @octs, $octrow;
    last if ($ind =~ /$targ/);
    if (scalar(@per)>1000) { ## Todo: Find the highest for base 24..
    	die("Oppsuite(): $ind: $row: $targ ".scalar(@per));
    }
  }
  OPPDEGEND:
  if ($opt =~ /a/) { return (@per) }
  elsif ($opt =~ /p/) { return ([@per], [@octs]) } 
  else { return ($deg,$targ,$octrow) }
} ## END Oppsuite().

### 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().


## permute:
sub Permute {
 @Items = @_;
 return sub {
		$N++, return @Items if $N==0;
		my $i;
		my $p = $N;
		for ($i=1; $i<=@Items && $p%$i==0; $i++) {
			$p /= $i;
		}
		my $d = $p % $i;
		my $j = @Items - $i;
		return if $j < 0;
		@Items[$j+1..$#Items] = reverse @Items[$j+1..$#Items];
		@Items[$j,$j+$d] = @Items[$j+$d,$j];
		$N++;
		return @Items;
 };
}

### powerp:
sub Powerp{
	my ($target,$agent,$pow,$opt) = @_;
	my @rslt;
	if ($pow == 0) {
		$target = &Natural($target);
  }
  else {
		for (my $n = 1; $n <= abs($pow); $n++){
			$target = Composind($target,$agent);
			push @rslt, $target;
		}
  }
  if ($opt == 1) { return @rslt } 
  else { return $target }
} ## END Powerp().

### ptype:
sub Ptype { ## Revised 110519.
	my $subname = "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($INDEX));
  $opt //= ""; 
  my @row = split //, $notes;
  my @octs = split //, ($octaves//="");
  my ($reverse, $revocts, $newrow, $newocts, @outnotes, @outocts);
  $reverse = $revocts = $newrow = $newocts = "";
  for (my $n = 0; $n 0) && (($n+1)%$base == 0)){ # The series is ready to be recorded.
			push @outnotes, $newrow; push @outocts, $newocts; 
			$newrow = $newocts = "";
		} ## Otherwise some last notes will be left so:
  }
  if ($newrow =~ /.+/) {
		my $len = length($newrow);
		for (my $n = 0; $n < ($base-$len); $n++) { $newrow .= "0"; $newocts .= "+0";} # fill missing notes
		push @outnotes, $newrow; push @outocts, $newocts; 
  }
  if ($opt =~ /s/) { return ([@outnotes], [@outocts]) } # Serial.
  elsif ($opt =~ /p/) { return ($reverse, $revocts) } ## Raw notes and octs.
  return $reverse; ## One sequence, no octs.
} ## END Revert().

### tab:
sub Tabs {
  my ($n) = @_;
  my $subname = "Tabs()";
  my $t = "";
  for (my $c = 0; $c < $n; $c++) { $t .=" " }
  $t = " " if ($t !~ / /);
  return $t;
} ## END Tabs().

### unmap:
sub Unmap { ## Revised 111008.
  my ($perm,$map) = @_;
  my $subname = "Unmap()";
  my @perm = split //, $perm; 
  my @map = split //, $map;
  my ($i,$res);
  for ($i = 0; $i < scalar(@perm); $i++){ $res .= $map[&Dodecad($perm[$i],$subname)]; }
  return $res;
} ## END Unmap().

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

__DATA__

This program can be used to analyse one permutation in depth.

Try:

  $ ./metana.pl "30254716"  

  replacing "30254716" by the permutation you want to analyse.


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