contents.pl

#!/usr/bin/perl 

# permutations contents (with iterators)
# emilbarton 2013 - rev. 0216.
# Iterator: Cf. Mark J. Dominus, Higher Order Perl, p. 130


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

if ((@ARGV)== 0 || $ARGV[0] =~ /help|usage/){ &Usage() };

## globals
######################################################################
my ($COND, $CNT, $INTSIG, $START, $TARGET, $TOTAL);
my (@DIGITS, @INDEX, @ITERITEMS); my %DIGH;
$COND = $TARGET = "";
$CNT = $INTSIG = $START = $TOTAL = 0;
@INDEX = split //,"0123456789ABCDEFGHIJKLMN";
for (my $n = 0; $n < scalar(@INDEX); $n++){ $DIGH{$INDEX[$n]} = $n };

## check:
######################################################################
@DIGITS = split //, $ARGV[0];
die "Invalid length." if ((@DIGITS) > (@INDEX) || (@DIGITS) < 2);
my $seen = "", my $signs;
for (my $i = 0; $i < (@DIGITS); $i++) { $signs = $signs.$INDEX[$i] } 
foreach (@DIGITS) {
  my $char = $_; 
  die "Invalid sign: $char" if ($signs !~ /$char/i);
  die "Repeated signs not allowed." if ($seen =~ /$char/i);
  $seen .= $char;
}

my $It = Permute(split(//,$ARGV[0]));

$START = $ARGV[1] if ($ARGV[1]);
$TARGET = $ARGV[2]  if ($ARGV[2]);; 
$COND = $ARGV[3]  if ($ARGV[3]);; 

while (my $Permutation = join '',$It->()) {
  my $Rslt = ""; $TOTAL++;
  if($COND =~ /.+/) { # Non exclusive conditions:  
    if($COND =~ /gradual/){ # Search for all the gradual suites that contain a specified permutation.
      my @suite = &Gradual($Permutation,"1");
      if( $TARGET ~~ @suite ) {
        $CNT++;
        my @uplets = &Partel($Permutation);
        $Rslt = "Gradual suite of $Permutation contains $TARGET and its elementary partition is: @uplets\n";
      }
    } # END gradual.
    if($COND =~ /eqomap/){ # Search for all the permutations identical to their omaps.
      my $omap = &Omap($Permutation,"1o");
      if( $omap =~ /$Permutation/ ) {
        $CNT++;
        $Rslt="$Permutation is identical to its opposite mapping.\n"; 
      }
    } # END eqomap.
    if($COND =~ /inter/){ # Search for all the permutations with intervals showing this property.
      my @res = &Anas($Permutation);
      if($COND =~ /list/){ # Search for this particular set of intervals ordinality.
        my $omap = &Omap($Permutation,"1o");
        if( $res[0] =~ /$TARGET/ ) {
          $CNT++;
          $Rslt =  "$Permutation has $TARGET as list of intervals.\n";
        }
      } # END interlist.
      if($COND =~ /set/){ # Search for this particular set of interval cardinalities.
        if( $res[1] =~ /$TARGET/ ) {
          $CNT++;
          $Rslt = "$Permutation has $TARGET as set of intervals.\n";
        }
      } # END interset.
    } # END inter.
    # put other conditions here:
    # elsif($COND =~ /other/){
    #    .. ;
    # } # END other cond.
  } # END COND.
  # An additionnal print condition (use 'cond-print')
  else {  # The pure list.
    $CNT++;
    $Rslt=$Permutation."\n"; 
  } # END no cond.
  print $Rslt; # May be empty.         
  if($COND =~ /file/ && $Rslt =~ /.+/){
    open FH, ">>contents-$TARGET-$COND.partial" or die "Can't w-open contents-$TARGET-$COND.partial";
    print FH $Rslt;
    close FH;
  }
  if ($INTSIG){ # We got an interrupt signal.
    if($COND =~ /print/){
      open FH, ">>contents-$TARGET-$COND.partial" or die "Can't w-open contents-$TARGET-$COND.partial";
      print FH "Interruption at $Permutation $START\n";
      close FH;
    }
    &Interrupt();
  }
};
if($COND =~ /file/){
  open FH, ">>contents-$TARGET-$COND.partial" or die "Can't w-open contents-$TARGET-$COND.partial";
  print FH "Items found: $CNT/$TOTAL.\n"; ;
  close FH;
  system("mv","contents-$TARGET-$COND.partial","contents-$TARGET-$COND.txt");
}
else { print "Items found (since last interruption): $CNT/$TOTAL.\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 < (@seq)-1; $i++){
    if (&Dodecad($seq[$i],$subname) >= &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().

### 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 =~ /1/) { return(@per) } 
  else { return ($deg) } # 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);
    push @per, $target; 
    last if ($ind =~ /$target/);
  }
  GRAD_END: 
  if ($opt =~ /1/) { return @per } 
  else { return $deg } 
} ## END Gradual().

## interrupt:
sub Interrupt { 
  my $items = join '',@ITERITEMS;
  die("Interruption: $items $START\n");
}

## sigint handler:
sub Inthandler { $INTSIG = 1; }

### 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 < (@seq); $n++){
    # An arithmetic definition for Invert: $res = $res.($axis-($seq[$n]-$axis))%($base+1);
    my $c = &Dodecad($seq[$n],$subname);
    my $sign = "+";  my ($thisnote, $newnote, $thisoct);
    if ($c > $axis) { ($thisnote,$thisoct) = &Notesum($c,$axis,"-",$base); $sign = "-" }
    if ($c < $axis) { ($thisnote,$thisoct) = &Notesum($axis,$c,"-",$base); $sign = "+" }
    if ($c == $axis) { $thisnote = "0"; $sign = "+" }
    ($newnote, $thisoct) = &Notesum($axis,$thisnote,$sign,$base);
    if (defined $octs[$n]){ $thisoct += $octs[$n] }
    else { $thisoct = 2 } 
    $thisoct = "0" unless ($thisoct > 0);
    $thisoct = $base-1 unless ($thisoct < $base);
    $inv .= &Decadod($newnote,$subname);
    $newseq .= &Decadod($newnote,$subname);
    $newocts .= $thisoct;
    $invocts .= $thisoct;
    if (($n>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().

### natural:
sub Natural { ## Revised 111002.
  my ($str) = @_;
  my @tmp = @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] < 0) { $res[0] = 0 } 
      elsif ($res[0] > $base) { $res[0] = $base } 
    }
    else { ## Normal behaviour (for notes):
      if ($res[0] < 0) { $res[0] += $base ; $res[1] = -1 } 
      elsif ($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 < scalar(@map); $n++) { last if ($map[$n] =~ /$perm[$i]/)}
    $res .= &Decadod($n,$subname);
  }
  return $res;
} ## END Omap().

### oppose:
sub Oppose { ## Revised 111007.
  my ($notes, $octs, $base, $axis, $opt) = @_;
  $base //= length($notes);
  $base = (@INDEX) if ($base > (@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 =~ /1/) { return (@per) }
  else { return ($deg) }
} ## 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 {
 @ITERITEMS = @_;
 return sub {
    $START++, return @ITERITEMS if $START==0;
    my $i;
    my $p = $START;
    for ($i=1; $i<=@ITERITEMS && $p%$i==0; $i++) {
      $p /= $i;
    }
    my $d = $p % $i;
    my $j = @ITERITEMS - $i;
    return if $j < 0;
    @ITERITEMS[$j+1..$#ITERITEMS] = reverse @ITERITEMS[$j+1..$#ITERITEMS];
    @ITERITEMS[$j,$j+$d] = @ITERITEMS[$j+$d,$j];
    $START++;
    return @ITERITEMS;
 };
} ## END Permute();

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


### revert:
sub Revert { ## Revised 111007.
  my ($notes, $octaves, $base, $opt) = @_;
  $base //= length($notes);
  $base = (@INDEX) if ($base > (@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 < (@row); $n++){
    my $thisoct = $octs[$n] //= 7;
    $reverse = $row[$n].$reverse;
    $revocts = $thisoct.$revocts;
    $newrow = $row[$n].$newrow;
    $newocts = $thisoct.$newocts;
    if (($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>) { $data .= $_ };
  die "Usage:\n$data";
} ## END usage()

__DATA__

This program can be used to compute a full set of permutations and test each
of them for a specific permutational content (see the default list of 
conditions below). It can be interrupted by SIGINT provided that when 
restarted it is fed with the last reached permutation and index number.

Try:

  $ ./contents.pl digits [[start] target condition]
  
  'digits' is the starting list of signs to permute (e.g. '0123' in
  base 4). This parameter can be set to any value in the ordered list of 
  permutation as long as its index is also provided.
  
  'start' is the index parameter allowing a restart in case of interruption 
  (default 0); Ctl-c will stop the computation and show the last values 
  reached that one would have to enter as 'digits' and 'start' in order 
  to take up where it left off).
  
  'target' is a comparison parameter bond to a specific condition. Some
  conditions (like 'eqomap') do not require such parameter that has then
  to be filled with an empty value (e.g. 0).
  
  'condition' can be set to any code filled at the right place in the loop 
  or by one of default conditions (see below). Any condition name concatenated
  to the mention '-file' will ensure that the output is saved to a file
  whose suffixe will be '.partial' as long as its computation is not fully 
  completed and then '.txt'.
    
  List of default conditions:

  'eqomap' will search each permutation that is equal to its mapped opposite.

  'gradual' will search each gradual suite for the value of 'target' and
  output its root in case of match.
    
  'interlist' will output each permutation whose intervals list match 'target'.

  'interset' will output each permutation whose intervals set match 'target'.
  The difference being that the list enumerates values of intervals from
  left to right and form 0 to n, when the set says how many intervals of each
  kind are represented in the permutation (incrementing their index values).

  
  Example:  

  $ ./contents.pl '01234567' '0' '30254716' 'gradual-file'
  Gradual suite of 16204375 contains 30254716 and its elementary partition is: 167530 2 4
  Gradual suite of 30254716 contains 30254716 and its elementary partition is: 357610 2 4
  ^CInterruption: 52163470 26842

  $ ls
  contents.pl contents-30254716-gradual-file.partial 

  $ ./contents.pl '52163470' '26842' '30254716' 'gradual-file'
  Items found (since last interruption): 0/13478.

  $ ls 
  contents.pl contents-30254716-gradual-file.txt 
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