File Coverage

blib/lib/Music/Canon.pm

Criterion	Covered	Total	%
statement	198	221	89.5
branch	99	134	73.8
condition	19	41	46.3
subroutine	19	19	100.0
pod	11	12	91.6
total	346	427	81.0

# -*- Perl -*-
#
# Routines for musical canon construction. See also C of the
# L module for a command line tool interface to this code, and
# the eg/ directory of this module's distribution for other example scripts.
#
# Run perldoc(1) on this file for additional documentation.

package Music::Canon;

use 5.010000;

use List::Util qw/sum/;
use Moo;
use Music::AtonalUtil ();    # Forte Number to interval sets
use Music::Scales qw/get_scale_nums is_scale/;
use namespace::clean;
use Scalar::Util qw/blessed looks_like_number/;

our $VERSION = '2.01';

# Array indices for ascending versus descending scales (as some minor scales
# are different, depending)
my $ASC = 0;
my $DSC = 1;

my $FORTE_NUMBER_RE;

##############################################################################
#
# ATTRIBUTES

has atonal => (
  is      => 'rw',
  default => sub { Music::AtonalUtil->new },
);

has contrary => (
  is => 'rw',
  cocerce =>
    sub { die "contrary needs boolean\n" if !defined $_[0]; $_[0] ? 1 : 0 },
  default => sub { 1 },
  reader  => 'get_contrary',
  writer  => 'set_contrary',
);

has DEG_IN_SCALE => (
  is     => 'rw',
  coerce => sub {
    die "scale degrees must be integer greater than 1"
      if !defined $_[0]
      or !looks_like_number $_[0]
      or $_[0] < 2;
    int $_[0];
  },
  default => sub {
    12;
  },
);

has modal_chrome => (
  is     => 'rw',
  coerce => sub {
    die "modal_chrome needs troolean (-1,0,1)\n" if !defined $_[0];
    $_[0] <=> 0;
  },
  default => sub {
    0;
  },
  reader => 'get_modal_chrome',
  writer => 'set_modal_chrome',
);

has modal_hook => (
  is      => 'rw',
  default => sub {
    sub { undef }
  },
  isa => sub {
    ref $_[0] eq 'CODE';
  },
);

# input tonic pitch for modal_map
has modal_in => (
  is        => 'rw',
  clearer   => 1,
  predicate => 1,
);

# output tonic pitch for modal_map
has modal_out => (
  is        => 'rw',
  clearer   => 1,
  predicate => 1,
);

# these have custom setters as support Forte Numbers and other such cases
# difficult to put into a simple coerce sub, so the user-facing setter are
# really the set_modal_scale_* subs.
has modal_scale_in => (
  is        => 'rw',
  clearer   => 1,
  predicate => 1,
);
has modal_scale_out => (
  is        => 'rw',
  clearer   => 1,
  predicate => 1,
);

has non_octave_scales => (
  is      => 'rw',
  cocerce => sub {
    die "non_octave_scales needs boolean\n" if !defined $_[0];
    $_[0] ? 1 : 0;
  },
  default => sub {
    0;
  },
);

has retrograde => (
  is => 'rw',
  cocerce =>
    sub { die "retrograde needs boolean\n" if !defined $_[0]; $_[0] ? 1 : 0 },
  default => sub { 1 },
  reader  => 'get_retrograde',
  writer  => 'set_retrograde',
);

has transpose => (
  is      => 'rw',
  default => sub { 0 },
  reader  => 'get_transpose',
  writer  => 'set_transpose',
);

##############################################################################
#
# METHODS

sub BUILD {
  my ( $self, $param ) = @_;
  with( exists $param->{pitchstyle} ? $param->{pitchstyle} : 'Music::PitchNum' );

  # as not expected to change much, if at all
  $FORTE_NUMBER_RE = $self->atonal->forte_number_re;

  # Major scale by default
  $self->modal_scale_in( [ [qw(2 2 1 2 2 2 1)], [qw(2 2 1 2 2 2 1)] ] )
    if !$self->has_modal_scale_in;
  $self->modal_scale_out( [ [qw(2 2 1 2 2 2 1)], [qw(2 2 1 2 2 2 1)] ] )
    if !$self->has_modal_scale_out;
}

# one-to-one interval mapping, though with the contrary, retrograde, and
# transpose parameters as possible influences on the results.
sub exact_map {
  my $self = shift;

  my ( @new_phrase, $prev_in, $prev_out );

  for my $e ( ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_ ) {
    my $pitch;
    if ( !defined $e ) {
      # presumably rests/silent bits
      push @new_phrase, undef;
      next;
    } elsif ( blessed $e and $e->can('pitch') ) {
      $pitch = $e->pitch;
    } elsif ( looks_like_number $e) {
      $pitch = $e;
    } else {
      # pass through unknowns
      push @new_phrase, $e;
      next;
    }

    my $new_pitch;
    if ( !defined $prev_out ) {
      my $trans = $self->get_transpose;
      if ( !looks_like_number($trans) ) {
        my $transpose_to = $self->pitchnum($trans)
          // die "pitchnum failed to parse '$trans'\n";
        $trans = $transpose_to - $pitch;
      }
      $new_pitch = $pitch + $trans;
    } else {
      my $delta = $pitch - $prev_in;
      $delta *= -1 if $self->get_contrary;
      $new_pitch = $prev_out + $delta;
    }
    push @new_phrase, $new_pitch;
    $prev_in  = $pitch;
    $prev_out = $new_pitch;
  }
  @new_phrase = reverse @new_phrase if $self->get_retrograde;

  return @new_phrase;
}

# mostly for compatibility with older versions of this module
sub get_modal_pitches {
  my ($self) = @_;
  return $self->modal_in, $self->modal_out;
}

sub get_modal_scale_in {
  return @{ $_[0]->modal_scale_in };
}

sub get_modal_scale_out {
  return @{ $_[0]->modal_scale_out };
}

# Modal interval mapping - determines the number of diatonic steps and
# chromatic offset (if any) from the direction and magnitude of the
# delta from the previous input pitch via the input scale intervals,
# then replays that number of diatonic steps and (if possible) chromatic
# offset via the output scale intervals. Ascending vs. descending motion
# may be handled by different scale intervals, if a melodic minor or
# similar asymmetric interval set is involved. If this sounds tricky and
# complicated, it is because it is.
sub modal_map {
  my $self = shift;

  my ( $input_tonic, $output_tonic );
  if ( $self->has_modal_in ) {
    $input_tonic = $self->pitchnum( $self->modal_in )
      // die "pitchnum could not convert modal_in '", $self->modal_in,
      "' to a pitch number\n";
  }
  if ( $self->has_modal_out ) {
    $output_tonic = $self->pitchnum( $self->modal_out )
      // die "pitchnum could not convert modal_out '", $self->modal_out,
      "' to a pitch number\n";
  }

  my $input_mode = $self->modal_scale_in;
  # local copy of the output scale in the event transposition forces a rotation
  # of the intervals
  my $output_mode = $self->modal_scale_out;

  # but have to wait until have the first pitch as might be transposing to a
  # note instead of by some number
  my $trans;
  my $rotate_by     = 0;
  my $rotate_chrome = 0;

  my ( @new_phrase, $prev_in, $prev_out );
  my $phrase_index = 0;
  for my $obj ( ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_ ) {
    my $pitch;
    if ( !defined $obj ) {
      # presumably rests/silent bits
      push @new_phrase, undef;
      next;
    } elsif ( blessed $obj and $obj->can('pitch') ) {
      $pitch = $obj->pitch;
    } elsif ( looks_like_number $obj) {
      $pitch = $obj;
    } else {
      # pass through unknowns
      push @new_phrase, $obj;
      next;
    }

    my $new_pitch;
    if ( defined $prev_in and $pitch == $prev_in ) {
      # oblique motion optimization (a repeated note): just copy previous
      $new_pitch = $prev_out;

    } else {
      # Interval sets are useless without being tied to some pitch, assume this
      # is the first note of the phrase if not already set.
      $input_tonic = $pitch unless defined $input_tonic;

      # NOTE output tonic is not longer set based on transposed pitch (as of
      # v1.00); use set_modal_pitches() to specify as necessary. This change
      # motivated by transpose not really working everywhere. Instead, output
      # tonic by default is the same as the input tonic (so the input and
      # output modes share the same root pitch by default).
      $output_tonic = $input_tonic unless defined $output_tonic;

      if ( !defined $trans ) {
        $trans = $self->get_transpose;
        if ( !looks_like_number($trans) ) {
          # Letter note: "transpose to 'A'" instead of "transpose by N"
          my $transpose_to = $self->pitchnum($trans)
            // die 'pitchnum failed to parse ' . $self->transpose . "\n";
          $trans = $transpose_to - $pitch;
        }

        if ( $trans != 0 ) {
          # Steps must be from input tonic to first note of phrase plus
          # transposition, as if in Bflat-Major if one has a phrase that begins
          # on "D" being moved to "Eflat" that transposition is modal, and not
          # chromatic.
          ( $rotate_by, $rotate_chrome ) =
            ( $self->steps( $input_tonic, $input_tonic + $trans, $input_mode->[$ASC] ) )
            [ 0, 1 ];
          # inverted due to how M::AU->rotate works
          $rotate_by *= -1;

          if ( $rotate_chrome != 0 ) {
            die "transpose to chromatic pitch is as yet unsupported";
          }

          # Transpositions require rotation of the output mode to match where
          # the starting pitch of the phrase lies in the output mode, as
          # otherwise for c-minor to c-minor, transposing from C to E-flat,
          # would for an input phrase of C->Bb->Ab get the C->Bb->Ab intervals
          # instead of those for Eb->D->C. That is, the output would become
          # E-flat minor by virtue of the transposition without the rotation
          # done here.
          if ( $rotate_by != 0 ) {
            $output_mode->[$ASC] =
              $self->atonal->rotate( $rotate_by, $output_mode->[$ASC] );
            $output_mode->[$DSC] =
              $self->atonal->rotate( $rotate_by, $output_mode->[$DSC] );
          }
        }
      }

      # Determine whether input must be figured on the ascending or descending
      # scale intervals; descending intervals only if there is a previous pitch
      # and if the delta from that previous pitch shows descending motion,
      # otherwise ascending. The scales are [[asc],[dsc]] AoA.
      my $input_motion = $ASC;
      $input_motion = $DSC if defined $prev_in and $pitch - $prev_in < 0;
      my $output_motion = $self->get_contrary ? !$input_motion : $input_motion;

      # Magnitude of interval from tonic, and whether above or below the
      # tonic (as if below, must walk scale intervals backwards).
      my ( $steps, $chromatic_offset, $is_dsc, $last_input_interval ) =
        $self->steps( $input_tonic, $pitch, $input_mode->[$input_motion] );

      # Contrary motion means not only the opposite scale intervals,
      # but the opposite direction through those intervals (in
      # melodic minor, ascending motion in ascending intervals (C to
      # Eflat) corresponds to descending motion in descending
      # intervals (C to Aflat).
      $is_dsc = !$is_dsc if $self->get_contrary;

      my $output_interval = 0;

      # Replay the same number of diatonic steps using the appropriate
      # output intervals and direction of interval iteration, plus
      # chromatic adjustments, if any.
      my $idx;
      if ($steps) {
        $steps--;
        for my $s ( 0 .. $steps ) {
          $idx = $s % @{ $output_mode->[$output_motion] };
          $idx = $#{ $output_mode->[$output_motion] } - $idx if $is_dsc;
          $output_interval += $output_mode->[$output_motion][$idx];
        }
      }

      my $hooked = 0;
      if ( $chromatic_offset != 0 ) {
        my $step_interval = $output_mode->[$output_motion][$idx];
        my $step_dir = $step_interval < 0 ? -1 : 1;
        $step_interval = abs $step_interval;

        if ( $chromatic_offset >= $step_interval ) {
          # Whoops, chromatic does not fit into output scale. Punt to hook
          # function to handle everything for this pitch.
          $new_pitch = $self->modal_hook->(
            $output_interval,
            chromatic_offset => $chromatic_offset,
            phrase_index     => $phrase_index,
            scale            => $output_mode->[$output_motion],
            scale_index      => $idx,
            step_dir         => $step_dir,
            step_interval    => $step_interval,
          );
          $hooked = 1;
        } else {
          if ( $step_interval == 2 ) {
            # only one possible chromatic fits
            $output_interval -= $step_dir * $chromatic_offset;
          } else {
            # modal_chrome is a troolean - either a literal chromatic
            # going up or down if positive or negative, otherwise if 0
            # try to figure out something proportional to where the
            # chromatic was between the diatonics of the input scale.
            if ( $self->get_modal_chrome > 0 ) {
              $output_interval -= $step_dir * $chromatic_offset;
            } elsif ( $self->get_modal_chrome < 0 ) {
              $output_interval += $step_dir * ( $chromatic_offset - $step_interval );
            } else {
              my $fraction = sprintf "%.0f",
                $step_interval * $chromatic_offset / $last_input_interval;
              $output_interval += $step_dir * ( $fraction - $step_interval );
            }
          }
        }
      }

      if ( !$hooked ) {
        $output_interval = int( $output_interval * -1 ) if $is_dsc;
        $new_pitch = $output_tonic + $trans + $output_interval;
      }
    }

    push @new_phrase, $new_pitch;
    $prev_in  = $pitch;
    $prev_out = $new_pitch;

    $phrase_index++;
  }
  @new_phrase = reverse @new_phrase if $self->get_retrograde;

  return @new_phrase;
}

sub reset_modal_pitches {
  $_[0]->clear_modal_in;
  $_[0]->clear_modal_out;
}

# mostly for compatibility with how older versions of this module worked,
# and handy to do these in a single call.
sub set_modal_pitches {
  my ( $self, $input_pitch, $output_pitch ) = @_;

  my $pitch;
  if ( defined $input_pitch ) {
    $pitch = $self->pitchnum($input_pitch)
      // die "pitchnum failed to parse $input_pitch\n";
    $self->modal_in($pitch);
    # auto-reset output if something prior there so not carrying along
    # something from a previous conversion, as the default is to use the same
    # pitch for the output tonic as from the input.
    if ( !defined $output_pitch and $self->has_modal_out ) {
      $self->clear_modal_out;
    }
  }
  if ( defined $output_pitch ) {
    $pitch = $self->pitchnum($output_pitch)
      // die "pitchnum failed to parse $output_pitch\n";
    $self->modal_out($pitch);
  }
}

sub set_modal_scale_in {
  my $self = shift;
  $self->modal_scale_in( $self->scales2intervals(@_) );
}

sub set_modal_scale_out {
  my $self = shift;
  $self->modal_scale_out( $self->scales2intervals(@_) );
}

sub scales2intervals {
  my ( $self, $asc, $dsc ) = @_;
  if ( !defined $asc and !defined $dsc ) {
    die "must define one of asc or dsc or both";
  }

  my @intervals;
  my $is_scale = 0;
  if ( defined $asc ) {
    if ( ref $asc eq 'ARRAY' ) {
      # Assume arbitrary list of intervals as integers if array ref
      for my $n (@$asc) {
        die "ascending intervals must be positive integers"
          unless looks_like_number $n and $n =~ m/^[+]?[0-9]+$/;
      }
      $intervals[$ASC] = [@$asc];

    } elsif ( $asc =~ m/($FORTE_NUMBER_RE)/ ) {
      # derive scale intervals from pitches of the named Forte Number
      my $pset = $self->atonal->forte2pcs($1);
      die "no Forte Number parsed from ascending '$asc'" unless defined $pset;
      $intervals[$ASC] = $self->atonal->pcs2intervals($pset);

    } else {
      die "ascending scale '$asc' unknown to Music::Scales"
        unless is_scale($asc);
      my @asc_nums = get_scale_nums($asc);
      my @dsc_nums;
      @dsc_nums = get_scale_nums( $asc, 1 ) unless defined $dsc;

      $intervals[$ASC] = [];
      for my $i ( 1 .. $#asc_nums ) {
        push @{ $intervals[$ASC] }, $asc_nums[$i] - $asc_nums[ $i - 1 ];
      }
      if (@dsc_nums) {
        $intervals[$DSC] = [];
        for my $i ( 1 .. $#dsc_nums ) {
          unshift @{ $intervals[$DSC] }, $dsc_nums[ $i - 1 ] - $dsc_nums[$i];
        }
      }
      $is_scale = 1;
    }
  }

  if ( !defined $dsc ) {
    # Assume descending equals ascending (true in most cases, except
    # melodic minor and similar), unless a scale was involved, as the
    # Music::Scales code should already have setup the descending bit.
    $intervals[$DSC] = $intervals[$ASC] unless $is_scale;
  } else {
    if ( ref $dsc eq 'ARRAY' ) {
      for my $n (@$dsc) {
        die "descending intervals must be positive integers"
          unless looks_like_number $n and $n =~ m/^[+]?[0-9]+$/;
      }
      $intervals[$DSC] = [@$dsc];

    } elsif ( $dsc =~ m/($FORTE_NUMBER_RE)/ ) {
      # derive scale intervals from pitches of the named Forte Number
      my $pset = $self->atonal->forte2pcs($1);
      die "no Forte Number parsed from descending '$dsc'" unless defined $pset;
      $intervals[$DSC] = $self->atonal->pcs2intervals($pset);

    } else {
      die "descending scale '$dsc' unknown to Music::Scales"
        unless is_scale($dsc);
      my @dsc_nums = get_scale_nums( $dsc, 1 );

      $intervals[$DSC] = [];
      for my $i ( 1 .. $#dsc_nums ) {
        unshift @{ $intervals[$DSC] }, $dsc_nums[ $i - 1 ] - $dsc_nums[$i];
      }
    }
  }

  # Complete scales to sum to 12 by default (Music::Scales omits the VII
  # to I interval, and who knows what a custom list would contain).
  if ( !$self->non_octave_scales ) {
    for my $ref (@intervals) {
      my $sum = sum(@$ref) // 0;
      die "empty interval set\n" if $sum == 0;
      if ( $sum < $self->DEG_IN_SCALE ) {
        push @$ref, $self->DEG_IN_SCALE - $sum;
      } elsif ( $sum > $self->DEG_IN_SCALE ) {
        die "non-octave scales require non_octave_scales param";
      }
    }
  }

  return \@intervals;
}

sub steps {
  my ( $self, $from, $to, $scale ) = @_;

  die "from pitch must be a number\n" if !looks_like_number $from;
  die "to pitch must be a number\n"   if !looks_like_number $to;
  die "scales must be reference to two array ref of intervals\n"
    if !defined $scale
    or ref $scale ne 'ARRAY';

  my $delta = $to - $from;
  my $dir = $delta < 0 ? $DSC : $ASC;
  $delta = abs $delta;

  my $running_total = 0;
  my $steps         = 0;
  my $index         = 0;
  while ( $running_total < $delta ) {
    $index = $steps++ % @$scale;
    $index = $#{$scale} - $index if $dir == $DSC;
    $running_total += $scale->[$index];
  }

  return $steps, $running_total - $delta, $dir, $scale->[$index];
}

1;
__END__