File Coverage

blib/lib/Music/CreatingRhythms.pm

Criterion	Covered	Total	%
statement	361	378	95.5
branch	85	104	81.7
condition	38	51	74.5
subroutine	52	53	98.1
pod	29	29	100.0
total	565	615	91.8

package Music::CreatingRhythms;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: Combinatorial algorithms to generate rhythms

our $VERSION = '0.0806';

use strictures 2;
use Algorithm::Combinatorics qw(permutations);
use Data::Munge qw(list2re);
use Integer::Partition ();
use List::Util qw(all any);
use Math::Sequence::DeBruijn qw(debruijn);
use Module::Load::Conditional qw(check_install);
use Moo;
use Music::AtonalUtil ();

use if defined check_install(module => 'Math::NumSeq::SqrtContinued'),
    'Math::NumSeq::SqrtContinued';

use namespace::clean;


has verbose => (
    is      => 'ro',
    isa     => sub { die "$_[0] is not a boolean" unless $_[0] =~ /^[01]$/ },
    default => sub { 0 },
);



sub b2int {
    my ($self, $sequences) = @_;
    my @intervals;
    for my $i (@$sequences) {
        my $string = join '', @$i;
        push @intervals, [ map { length $_ } grep { $_ } split /(10*)/, $string ];
    }
    return \@intervals;
}


sub cfcv {
    my ($self, @terms) = @_;

    my $p0 = 0;
    my $p1 = 1;
    my $p2;
    my $q0 = 1;
    my $q1 = 0;
    my $q2;

    for my $t (@terms) {
      $p2 = $t * $p1 + $p0;
      $q2 = $t * $q1 + $q0;
      $p0 = $p1;
      $p1 = $p2;
      $q0 = $q1;
      $q1 = $q2;
    }

    return [ $p2, $q2 ];
}


sub cfsqrt {
    my ($self, $n, $m) = @_;
    $m ||= $n;
    my @terms;

    my $seq = Math::NumSeq::SqrtContinued->new(sqrt => $n);
    for my $i (1 .. $m) {
        my ($j, $value) = $seq->next;
        push @terms, $value;
    }
    return \@terms;
}


sub chsequl {
    my ($self, $t, $p, $q, $n) = @_;
    die "Usage: chsequl(\$type, \$numerator, \$denominator [\$terms])\n"
        unless $t && defined $p && defined $q;
    $n ||= $p + $q;
    my @word;
    my $i = 0;
    while ($i < $n) {
        push @word, $t eq 'u' ? 1 : 0;
        $i++;
        my ($x, $y) = ($p, $q);
        while ($x != $y && $i < $n) {
            if ($x > $y) {
                push @word, 1;
                $y += $q;
            }
            else {
                push @word, 0;
                $x += $p;
            }
            $i++;
        }
        if ($x == $y && $i < $n) {
            push @word, $t eq 'u' ? 0 : 1;
            $i++;
        }
    }
    return \@word;
}


sub comp {
    my ($self, $n) = @_;
    my @compositions;
    my @parts;
    my $i = 0;
    _compose($n - 1, 1, 0, \$i, \@compositions, \@parts);
    return \@compositions;
}

sub _compose {
    my ($n, $p, $k, $i, $compositions, $parts) = @_;
    if ($n == 0) {
        while ($n < $k) {
            push @{ $compositions->[$$i] }, $parts->[$n];
            $n++;
        }
        push @{ $compositions->[$$i] }, $p;
        $$i++;
        return;
    }
    $parts->[$k] = $p;
    _compose($n - 1, 1, $k + 1, $i, $compositions, $parts);
    _compose($n - 1, $p + 1, $k, $i, $compositions, $parts);
}


sub compa {
    my ($self, $n, @intervals) = @_;
    my @compositions;
    my @parts;
    my $i = 0;
    _composea($n - 1, 1, 0, \$i, \@compositions, \@parts, \@intervals);
    return \@compositions;
}

sub _composea {
  my ($n, $p, $k, $i, $compositions, $parts, $intervals) = @_;
  if ($n == 0) {
    if (_allowed($p, $intervals)) {
      while ($n < $k) {
        push @{ $compositions->[$$i] }, $parts->[$n];
        $n++;
      }
      push @{ $compositions->[$$i] }, $p;
      $$i++;
    }
    return;
  }
  if (_allowed($p, $intervals)) {
    $parts->[$k] = $p;
    _composea($n - 1, 1, $k + 1, $i, $compositions, $parts, $intervals);
  }
  _composea($n - 1, $p + 1, $k, $i, $compositions, $parts, $intervals);
}


sub compam {
    my ($self, $n, $m, @intervals) = @_;
    $m--;
    my @compositions;
    my @parts;
    my $i = 0;
    _composeam($n - 1, 1, 0, $m, \$i, \@compositions, \@parts, \@intervals);
    return \@compositions;
}

sub _composeam {
  my ($n, $p, $k, $m, $i, $compositions, $parts, $intervals) = @_;
  if ($n == 0) {
    if ($k == $m && _allowed($p, $intervals)) {
      while ($n < $k) {
        push @{ $compositions->[$$i] }, $parts->[$n];
        $n++;
      }
      push @{ $compositions->[$$i] }, $p;
      $$i++;
    }
    return;
  }
  if ($k < $m && _allowed($p, $intervals)) {
    $parts->[$k] = $p;
    _composeam($n - 1, 1, $k + 1, $m, $i, $compositions, $parts, $intervals);
  }
  _composeam($n - 1, $p + 1, $k, $m, $i, $compositions, $parts, $intervals);
}


sub compm {
    my ($self, $n, $m) = @_;
    $m--;
    my @compositions;
    my @parts;
    my $i = 0;
    _composem($n - 1, 1, 0, $m, \$i, \@compositions, \@parts);
    return \@compositions;
}

sub _composem {
    my ($n, $p, $k, $m, $i, $compositions, $parts) = @_;
    if ($n == 0) {
        if ($k == $m) {
            while ($n < $k) {
                push @{ $compositions->[$$i] }, $parts->[$n];
                $n++;
            }
            push @{ $compositions->[$$i] }, $p;
            $$i++;
        }
        return;
    }
    if ($k < $m) {
        $parts->[$k] = $p;
        _composem($n - 1, 1, $k + 1, $m, $i, $compositions, $parts);
    }
    _composem($n - 1, $p + 1, $k, $m, $i, $compositions, $parts);
}


sub compmrnd {
    my ($self, $n, $m) = @_;
    return [0] unless $n;
    my @compositions;
    my ($p, $j, $np);
    for(my $mp = $m - 1, $np = $n - 1, $j = 1; $mp > 0; --$np) {
        $p = $mp / $np;
        if ($p % 2 == 0) {
            push @compositions, $j;
            $mp--;
            $j = 1;
        }
        else {
            $j++;
        }
    }
    push @compositions, $j + $np;
    return \@compositions;
}


sub comprnd {
    my ($self, $n) = @_;
    return [0] unless $n;
    my @compositions;
    my $p = 1;
    for my $i (1 .. $n - 1) {
        if ((int rand 2) % 2 == 0) {
            $p++;
        }
        else {
            push @compositions, $p;
            $p = 1;
        }
    }
    push @compositions, $p;
    return \@compositions;
}


sub count_digits {
    my ($self, $digit, $n) = @_;
    my $x = 0;
    if (ref $n) {
        for my $i (@$n) {
            $x++ if $i == $digit;
        }
    }
    else {
           if ($digit == 0) { $x = $n =~ tr/0// }
        elsif ($digit == 1) { $x = $n =~ tr/1// }
        elsif ($digit == 2) { $x = $n =~ tr/2// }
        elsif ($digit == 3) { $x = $n =~ tr/3// }
        elsif ($digit == 4) { $x = $n =~ tr/4// }
        elsif ($digit == 5) { $x = $n =~ tr/5// }
        elsif ($digit == 6) { $x = $n =~ tr/6// }
        elsif ($digit == 7) { $x = $n =~ tr/7// }
        elsif ($digit == 8) { $x = $n =~ tr/8// }
        elsif ($digit == 9) { $x = $n =~ tr/9// }
    }
    return $x;
}


sub count_ones {
    my ($self, $n) = @_;
    return $self->count_digits(1, $n);
}


sub count_zeros {
    my ($self, $n) = @_;
    return $self->count_digits(0, $n);
}


sub de_bruijn {
    my ($self, $n) = @_;
    my $sequence = $n ? debruijn([1,0], $n) : 0;
    return [ split //, $sequence ];
}


sub euclid {
    my ($self, $n, $m) = @_;
    my $intercept = 1;
    my $slope = $n / $m;
    my @pattern = ('0') x $m;
    for my $y ( 1 .. $n ) {
        $pattern[ sprintf '%.0f', ( $y - $intercept ) / $slope ] = '1';
    }
    return \@pattern;
}


sub int2b {
    my ($self, $intervals) = @_;
    my @sequences;
    for my $i (@$intervals) {
        my @bitstring;
        for my $j (@$i) {
            my $bits = '1' . '0' x ($j - 1);
            push @bitstring, split //, $bits;
        }
        push @sequences, \@bitstring;
    }
    return \@sequences;
}


sub invert_at {
    my ($self, $n, $parts) = @_;
    my @head = @$parts[ 0 .. $n - 1 ];
    my @tail = map { $_ ? 0 : 1 } @$parts[ $n .. $#$parts ];
    my @data = (@head, @tail);
    return \@data;
}


sub neck {
    my ($self, $n) = @_;
    my @necklaces;
    my @parts = (1);
    my $i = 0;
    _neckbin($n, 1, 1, \$i, \@necklaces, \@parts);
    return \@necklaces;
}

sub _neckbin {
    my ($n, $k, $l, $i, $necklaces, $parts) = @_;
    # k = length of necklace
    # l = length of longest prefix that is a lyndon word
    if ($k > $n) {
        if(($n % $l) == 0) {
            for $k (1 .. $n) {
                push @{ $necklaces->[$$i] }, $parts->[$k];
            }
            $$i++;
        }
    }
    else {
        $parts->[$k] = $parts->[ $k - $l ];
        if ($parts->[$k] == 1) {
            _neckbin($n, $k + 1, $l, $i, $necklaces, $parts);
            $parts->[$k] = 0;
            _neckbin($n, $k + 1, $k, $i, $necklaces, $parts);
        }
        else {
            _neckbin($n, $k + 1, $l, $i, $necklaces, $parts);
        }
    }
}


sub necka {
    my ($self, $n, @intervals) = @_;
    my @necklaces;
    my @parts = (1);
    my $i = 0;
    _neckbina($n, 1, 1, 1, \$i, \@necklaces, \@parts, \@intervals);
    return \@necklaces;
}

sub _neckbina {
    my ($n, $k, $l, $p, $i, $necklaces, $parts, $intervals) = @_;
    if ($k > $n) {
      if (($n % $l) == 0 && _allowed($p, $intervals) && $p <= $n) {
        for $k (1 .. $n) {
          push @{ $necklaces->[$$i] }, $parts->[$k];
        }
        $$i++;
      }
    }
    else {
        $parts->[$k] = $parts->[ $k - $l ];
        if ($parts->[$k] == 1) {
            if (_allowed($p, $intervals) || $k == 1) {
              _neckbina($n, $k + 1, $l, 1, $i, $necklaces, $parts, $intervals);
            }
            $parts->[$k] = 0;
            _neckbina($n, $k + 1, $k, $p + 1, $i, $necklaces, $parts, $intervals);
        }
        else {
            _neckbina($n, $k + 1, $l, $p + 1, $i, $necklaces, $parts, $intervals);
        }
    }
}


sub neckam {
    my ($self, $n, $m, @intervals) = @_;
    my @necklaces;
    my @parts = (1);
    my $i = 0;
    _neckbinam($n, 1, 1, 0, 1, $m, \$i, \@necklaces, \@parts, \@intervals);
    return \@necklaces;
}

sub _neckbinam {
    my ($n, $k, $l, $q, $p, $m, $i, $necklaces, $parts, $intervals) = @_;
    if ($k > $n) {
        if(($n % $l) == 0 && _allowed($p, $intervals) && $p <= $n && $q == $m) {
            for $k (1 .. $n) {
                push @{ $necklaces->[$$i] }, $parts->[$k];
            }
            $$i++;
        }
    }
    else {
        $parts->[$k] = $parts->[ $k - $l ];
        if ($parts->[$k] == 1) {
            if (_allowed($p, $intervals) || $k == 1) {
                _neckbinam($n, $k + 1, $l, $q + 1, 1, $m, $i, $necklaces, $parts, $intervals);
            }
            $parts->[$k] = 0;
            _neckbinam($n, $k + 1, $k, $q, $p + 1, $m, $i, $necklaces, $parts, $intervals);
        }
        else {
            _neckbinam($n, $k + 1, $l, $q, $p + 1, $m, $i, $necklaces, $parts, $intervals);
        }
    }
}


sub neckm {
    my ($self, $n, $m) = @_;
    my @necklaces;
    my @parts = (1);
    my $i = 0;
    _neckbinm($n, 1, 1, 0, $m, \$i, \@necklaces, \@parts);
    return \@necklaces;
}

sub _neckbinm {
    my ($n, $k, $l, $p, $m, $i, $necklaces, $parts) = @_;
    # k = length of necklace
    # l = length of longest prefix that is a lyndon word
    # p = number of parts (ones)
    if ($k > $n) {
        if (($n % $l) == 0 && $p == $m) {
            for $k (1 .. $n) {
              push @{ $necklaces->[$$i] }, $parts->[$k];
            }
            $$i++;
        }
    }
    else {
        $parts->[$k] = $parts->[ $k - $l ];
        if ($parts->[$k] == 1) {
            _neckbinm($n, $k + 1, $l, $p + 1, $m, $i, $necklaces, $parts);
            $parts->[$k] = 0;
            _neckbinm($n, $k + 1, $k, $p, $m, $i, $necklaces, $parts);
        }
        else {
            _neckbinm($n, $k + 1, $l, $p, $m, $i, $necklaces, $parts);
        }
    }
}


sub part {
    my ($self, $n) = @_;
    my $i = Integer::Partition->new($n, { lexicographic => 1 });
    my @partitions;
    while (my $p = $i->next) {
        push @partitions, [ sort { $a <=> $b } @$p ];
    }
    return \@partitions;
}


sub parta {
    my ($self, $n, @parts) = @_;
    my $re = list2re @parts;
    my $i = Integer::Partition->new($n, { lexicographic => 1 });
    my @partitions;
    while (my $p = $i->next) {
      push @partitions, [ sort { $a <=> $b } @$p ]
        if all { $_ =~ /^$re$/ } @$p;
    }
    return \@partitions;
}


sub partam {
    my ($self, $n, $m, @parts) = @_;
    my $re = list2re @parts;
    my $i = Integer::Partition->new($n);
    my @partitions;
    while (my $p = $i->next) {
        push @partitions, [ sort { $a <=> $b } @$p ]
          if @$p == $m && all { $_ =~ /^$re$/ } @$p;
    }
    return \@partitions;
}


sub partm {
    my ($self, $n, $m) = @_;
    my $i = Integer::Partition->new($n);
    my @partitions;
    while (my $p = $i->next) {
        push @partitions, [ sort { $a <=> $b } @$p ]
          if @$p == $m;
    }
    return \@partitions;
}


sub permi {
    my ($self, $parts) = @_;
    my @permutations = permutations($parts);
    return \@permutations;
}


sub pfold {
    my ($self, $n, $m, $f) = @_;
    my @sequence;
    my ($j, $k);
    for (my $i = 1; $i <= $n; ++$i) {
      _oddeven($i, \$k, \$j);
      $k = $k % $m;
      my $y = $f & (1 << $k) ? 1 : 0;
      if ((2 * $j + 1) % 4 > 1) {
          $y = 1 - $y;
      }
      push @sequence, $y;
    }
    return \@sequence;
}

# find x and y such that n = 2^x * (2*y+1)
sub _oddeven {
    my ($n, $x, $y) = @_;
    my $k;
    # two's complement of n = -n or ~n + 1
    my $l = $n & -$n; # this is 2^a
    $$y = ($n / $l - 1) / 2;
    for ($k = 0; $l > 1; ++$k) {
        $l >>= 1;
    }
    $$x = $k;

    return;
}


sub reverse_at {
    my ($self, $n, $parts) = @_;
    my @head = @$parts[ 0 .. $n - 1 ];
    my @tail = reverse @$parts[ $n .. $#$parts ];
    my @data = (@head, @tail);
    return \@data;
}


sub rotate_n {
    my ($self, $n, $parts) = @_;
    my $atu = Music::AtonalUtil->new;
    my $sequence = $atu->rotate($n, $parts);
    return $sequence;
}

sub _allowed { # is p one of the parts?
    my ($p, $parts) = @_;
    return any { $p == $_ } @$parts;
}

1;

__END__