File Coverage

blib/lib/Music/Chord/Positions.pm

Criterion	Covered	Total	%
statement	137	143	95.8
branch	52	76	68.4
condition	30	63	47.6
subroutine	12	12	100.0
pod	5	6	83.3
total	236	300	78.6

# -*- Perl -*-
#
# TODO
# * chord_pos
#   - support arbitrary? voice counts (would need doubling rules?) Extra
#     voices would likely run into either doubling or maximum pitch
#     limits, so might need good-enough effort (or lots of doublings)?
#   - or lower than @ps voice count, which might require new logic or
#     priority on the pitches?
#   - inversion through "root_any" and then select only root 3rd or
#     whatever afterwards?
#   - nix octave_count and pitch_max in favor of just specified
#     semitones up? - makes sense, as interval_adj_max is a semitone
#     thing.
#   - doublings could use more rules beyond "no" or "anything goes",
#     perhaps optional list of "here's pitches that can be doubled" so
#     can 2x the root or the 5th or whatever on demand.
#   - logic tricky, could it be simplified with a Combinations module or
#     by using ordering results from a glob() expansion?
#   - callbacks so caller can better control the results? (or filter
#     results via counterpoint or other rules, e.g. to exclude || 5ths
#     or other naughty things).
#   - allow doubling of the third: frowned on, but sees frequent use
#     e.g. in the Bach Chorales (if used properly, but rules would need
#     to be enforced somehow else).
#
# * progressions
#   - support this, instead of using mcp-prog script?

package Music::Chord::Positions;

use 5.010;
use strict;
use warnings;

use Carp qw/croak/;
use List::Util qw(max min);

our $VERSION = '0.64';

my $DEG_IN_SCALE = 12;

########################################################################
#
# SUBROUTINES

# TODO move back to List::MoreUtils if that module is fixed up or some
# replacement with fewer open critical bugs is written.
sub all(&@) {
  my $test = shift;
  for (@_) {
    return 0 unless &$test;
  }
  return 1;
}

sub new {
  my ( $class, %param ) = @_;
  my $self = {};

  $self->{_DEG_IN_SCALE} = int( $param{DEG_IN_SCALE} // $DEG_IN_SCALE );
  if ( $self->{_DEG_IN_SCALE} < 2 ) {
    croak 'degrees in scale must be greater than one';
  }

  bless $self, $class;
  return $self;
}

########################################################################
#
# Methods of Music

sub chord_inv {
  my ( $self, $pitch_set, %params ) = @_;
  croak 'pitch set reference required'
    unless defined $pitch_set and ref $pitch_set eq 'ARRAY';

  my $max_pitch = max(@$pitch_set);
  my $next_register =
    $max_pitch + $self->{_DEG_IN_SCALE} - $max_pitch % $self->{_DEG_IN_SCALE};

  my @inversions;
  for my $i ( 0 .. $#$pitch_set - 1 ) {
    # Inversions simply flip lower notes up above the highest pitch in
    # the original pitch set.
    push @inversions,
      [
      @$pitch_set[ $i + 1 .. $#$pitch_set ],
      map { $next_register + $_ } @$pitch_set[ 0 .. $i ]
      ];

    # Normalize to "0th" register if lowest pitch is an octave+ out
    if ( exists $params{'pitch_norm'} and $params{'pitch_norm'} ) {
      my $min_pitch = min( @{ $inversions[-1] } );
      if ( $min_pitch >= $self->{_DEG_IN_SCALE} ) {
        my $offset = $min_pitch - $min_pitch % $self->{_DEG_IN_SCALE};
        $_ -= $offset for @{ $inversions[-1] };
      }
    }
  }

  if ( exists $params{'inv_num'} ) {
    croak 'inversion number out of range'
      if $params{'inv_num'} !~ m/^\d+$/
      or $params{'inv_num'} < 1
      or $params{'inv_num'} > @inversions;
    @inversions = @{ $inversions[ $params{'inv_num'} - 1 ] };
  }

  return \@inversions;
}

sub chord_pos {
  my ( $self, $pitch_set, %params ) = @_;
  croak 'pitch set reference required'
    unless defined $pitch_set and ref $pitch_set eq 'ARRAY';

  my (
    @ps,             @potentials,    @revoicings,
    @voice_iters,    @voice_max,     %seen_intervals,
    $min_pitch_norm, $next_register, $unique_pitch_count,
  );

  $params{'interval_adj_max'} =
    ( exists $params{'interval_adj_max'}
      and defined $params{'interval_adj_max'} )
    ? $params{'interval_adj_max'}
    : 19;

  if ( exists $params{'octave_count'} ) {
    $params{'octave_count'} = 2 if $params{'octave_count'} < 2;
  } else {
    $params{'octave_count'} = 2;
  }

  if ( exists $params{'pitch_max'} and $params{'pitch_max'} < 1 ) {
    $params{'pitch_max'} =
      ( $params{'octave_count'} + 1 ) * $self->{_DEG_IN_SCALE} +
      $params{'pitch_max'};
  }

  if ( exists $params{'voice_count'} ) {
    if ( @$pitch_set > $params{'voice_count'} ) {
      die
        "case where pitches in chord exceeds allowed voices not implemented";
    }
  } else {
    $params{'voice_count'} = @$pitch_set;
  }

  @ps = sort { $a <=> $b } @$pitch_set;

  $min_pitch_norm = $ps[0] % $self->{_DEG_IN_SCALE};
  $next_register =
    $ps[-1] + ( $self->{_DEG_IN_SCALE} - $ps[-1] % $self->{_DEG_IN_SCALE} );
  {
    my %seen_pitch;
    @seen_pitch{ map { $_ % $self->{_DEG_IN_SCALE} } @ps } = ();
    $unique_pitch_count = keys %seen_pitch;
  }

  if ( $params{'voice_count'} > @ps ) {
    my $doubled_count = $params{'voice_count'} - @ps;
    die "multiple extra voices not implemented" if $doubled_count > 1;

    # Double lowest pitch in octave above highest pitch C E G -> C E G C
    push @ps, $next_register + $ps[0];
  }

  @potentials = @ps;
  for my $i ( 1 .. $params{'octave_count'} ) {
    for my $n (@ps) {
      my $p = $n + $i * $self->{_DEG_IN_SCALE};
      push @potentials, $p
        unless exists $params{'pitch_max'} and $p > $params{'pitch_max'};
    }
  }
  my %uniq_pots;
  @uniq_pots{@potentials} = ();
  @potentials = sort { $a <=> $b } keys %uniq_pots;

  for my $i ( 0 .. $params{'voice_count'} - 1 ) {
    $voice_iters[$i] = $i;
    $voice_max[$i]   = $#potentials - $params{'voice_count'} + $i + 1;
  }
  if ( exists $params{'root_lock'} and $params{'root_lock'} ) {
    $voice_max[0] = $voice_iters[0];
  }

  while ( $voice_iters[0] <= $voice_max[0] ) {
  TOPV: while ( $voice_iters[-1] <= $voice_max[-1] ) {
      my @chord = @potentials[@voice_iters];
      $voice_iters[-1]++;

      my %harmeq;
      for my $p (@chord) {
        $harmeq{ $p % $self->{_DEG_IN_SCALE} }++;
      }
      unless ( exists $params{'no_limit_uniq'} and $params{'no_limit_uniq'} )
      {
        next if keys %harmeq < $unique_pitch_count;
      }
      unless ( exists $params{'no_limit_doublings'}
        and $params{'no_limit_doublings'} ) {
        for my $k ( grep { $_ != $min_pitch_norm } keys %harmeq ) {
          next TOPV if $harmeq{$k} > 1;
        }
      }

      my ( @intervals, %intv_by_idx );
      for my $j ( 1 .. $#chord ) {
        push @intervals, $chord[$j] - $chord[ $j - 1 ];
        next TOPV if $intervals[-1] > $params{'interval_adj_max'};

        $intv_by_idx{ $j - 1 } = $intervals[-1] if @chord > 2;
      }
      # TODO these routines have not been tested against chords with 5+
      # voices, so may allow pitch sets that violate the spirit of the
      # following (3rds in the middle of otherwise open voicings would
      # be what I would expect to see pass in 5+ voice chords).
      if (  @chord > 2
        and exists $params{'no_partial_closed'}
        and $params{'no_partial_closed'} ) {
        # Exclude 3rds near fundamental where next voice 5th+ out
        if ( $intervals[0] < 5 and $intervals[1] > 6 ) {
          next TOPV;
        }
        # Exclude 3rds at top where next lower voice 5th+ out
        if ( $intervals[-1] < 5 and $intervals[-2] > 6 ) {
          next TOPV;
        }

        # Exclude cases where highest voice has wandered off by a larger
        # interval than seen below.
        my @ordered_intv =
          sort { $intv_by_idx{$b} <=> $intv_by_idx{$a} } keys %intv_by_idx;
        if ( $ordered_intv[0] > $ordered_intv[-1]
          and all { $intv_by_idx{ $ordered_intv[0] } > 1 + $intv_by_idx{$_} }
          @ordered_intv[ 1 .. $#ordered_intv ] ) {
          next TOPV;
        }
      }

      # Nix any identical chord voicings (c e g == c' e' g')
      unless ( exists $params{'allow_transpositions'}
        and $params{'allow_transpositions'} ) {
        next TOPV if $seen_intervals{"@intervals"}++;
      }

      push @revoicings, \@chord;
    }

    # Increment any lower voices if top voice(s) maxed out
    for my $i ( reverse 1 .. $#voice_iters ) {
      if ( $voice_iters[$i] > $voice_max[$i] ) {
        $voice_iters[ $i - 1 ]++;
      }
    }

    unless ( exists $params{'root_any'} and $params{'root_any'} ) {
      while ( $potentials[ $voice_iters[0] ] % $self->{_DEG_IN_SCALE} !=
        $min_pitch_norm ) {
        $voice_iters[0]++;
        last if $voice_iters[0] > $voice_max[0];
      }
    }

    # Reset higher voices to close positions above lower voices
    for my $i ( 1 .. $#voice_iters ) {
      if ( $voice_iters[$i] > $voice_max[$i] ) {
        $voice_iters[$i] = $voice_iters[ $i - 1 ] + 1;
      }
    }
  }

  return \@revoicings;
}

# Change a pitch set collection (vertical) into voices (horizontal)
sub chords2voices {
  my ( $self, $pitch_sets ) = @_;
  croak 'not a list of pitch sets' unless ref $pitch_sets->[0] eq 'ARRAY';

  # Nothing to swap, change nothing
  return $pitch_sets if @$pitch_sets < 2;

  my @voices;
  for my $vi ( 0 .. $#{ $pitch_sets->[0] } ) {
    for my $j ( 0 .. $#$pitch_sets ) {
      push @{ $voices[$vi] }, $pitch_sets->[$j][$vi];
    }
  }

  return [ reverse @voices ];
}

sub scale_degrees {
  my ( $self, $dis ) = @_;
  if ( defined $dis ) {
    croak 'scale degrees value must be positive integer greater than 1'
      if !defined $dis
      or $dis !~ /^\d+$/
      or $dis < 2;
    $self->{_DEG_IN_SCALE} = $dis;
  }
  return $self->{_DEG_IN_SCALE};
}

1;
__END__