File Coverage

blib/lib/Music/NeoRiemannianTonnetz.pm

Criterion	Covered	Total	%
statement	106	115	92.1
branch	24	40	60.0
condition	6	10	60.0
subroutine	15	16	93.7
pod	5	5	100.0
total	156	186	83.8

# -*- Perl -*-
#
# Performs Neo-Riemann operations on set classes.
# https://en.wikipedia.org/wiki/Neo-Riemannian_theory

package Music::NeoRiemannianTonnetz;

use 5.010000;
use strict;
use warnings;

use Carp qw/croak/;
use List::Util qw/min/;
use Scalar::Util qw/reftype/;
use Try::Tiny;

our $VERSION = '0.26';

my $DEG_IN_SCALE = 12;

# For the transform table. "SEE ALSO" section in docs has links for
# [refs]. These are expanded as a simple grammar, until a code reference
# is reached; the code reference then looks up what needs to be done via
# the operations table.
my %TRANSFORMATIONS = (
  # 3-11 operations
  P => \&_apply_operation,    # Parallel [WP]
  R => \&_apply_operation,    # Relative [WP]
  L => \&_apply_operation,    # Leittonwechsel [WP]
  N => 'RLP',                 # Nebenverwandt [WP]
  S => 'LPR',                 # Slide [WP]
  H => 'LPL',                 # [WP]

  # 4-27 operations [Childs 1998]
  S23 => \&_apply_operation,
  S32 => \&_apply_operation,
  S34 => \&_apply_operation,
  S43 => \&_apply_operation,
  S56 => \&_apply_operation,
  S65 => \&_apply_operation,
  C32 => \&_apply_operation,
  C34 => \&_apply_operation,
  C65 => \&_apply_operation,
);

# The important bits (these munge set classes to a different form of the
# same parent prime form of a set class, e.g. toggling 0,3,7 to 0,4,7).
# The operation names come from the literature, as well as the magic
# numbers required to change the set classes correctly.
my %OPERATIONS = (
  L => { '0,3,7' => { 7 => 1 },  '0,4,7' => { 0 => -1 } },
  P => { '0,3,7' => { 3 => 1 },  '0,4,7' => { 4 => -1 } },
  R => { '0,3,7' => { 0 => -2 }, '0,4,7' => { 7 => 2 } },
  S23 =>
    { '0,3,6,8' => { 0 => -1, 3 => -1 }, '0,2,5,8' => { 5 => 1, 8 => 1 } },
  S32 =>
    { '0,3,6,8' => { 6 => 1, 8 => 1 }, '0,2,5,8' => { 0 => -1, 2 => -1 } },
  S34 =>
    { '0,3,6,8' => { 0 => 1, 8 => 1 }, '0,2,5,8' => { 0 => -1, 8 => -1 } },
  S43 =>
    { '0,3,6,8' => { 3 => -1, 6 => -1 }, '0,2,5,8' => { 2 => 1, 5 => 1 } },
  S56 =>
    { '0,3,6,8' => { 0 => -1, 6 => -1 }, '0,2,5,8' => { 2 => 1, 8 => 1 } },
  S65 =>
    { '0,3,6,8' => { 3 => 1, 8 => 1 }, '0,2,5,8' => { 0 => -1, 5 => -1 } },
  C32 =>
    { '0,3,6,8' => { 6 => -1, 8 => 1 }, '0,2,5,8' => { 0 => -1, 2 => 1 } },
  C34 =>
    { '0,3,6,8' => { 0 => -1, 8 => 1 }, '0,2,5,8' => { 0 => -1, 8 => 1 } },
  C65 =>
    { '0,3,6,8' => { 3 => -1, 8 => 1 }, '0,2,5,8' => { 0 => -1, 5 => 1 } },
);

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

sub _apply_operation {
  my ( $self, $token, $pset_str, $pset2orig ) = @_;

  if ( !exists $self->{op}->{$token}->{$pset_str} ) {
    croak "no set class [$pset_str] for token '$token'";
  }

  # apply pitch modifications from the operations table
  for my $i ( keys %{ $self->{op}->{$token}->{$pset_str} } ) {
    for my $p ( @{ $pset2orig->{$i} } ) {
      $p += $self->{op}->{$token}->{$pset_str}->{$i};
    }
  }

  # reformulate the (updated) original pitches into new pitch set
  my @new_set;
  for my $r ( values %$pset2orig ) {
    push @new_set, @$r;
  }

  @new_set = sort { $a <=> $b } @new_set;
  return \@new_set;
}

sub new {
  my ( $class, %param ) = @_;
  my $self = { op => \%OPERATIONS, x => \%TRANSFORMATIONS };

  # should not need to alter, but who knows
  $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;
}

# Based on normal_form of Music::AtonalUtil but always transposes to
# zero (cannot use prime_form, as that goes one step too far and
# conflates [0,4,7] with [0,3,7] which here must be distinct).
sub normalize {
  my $self = shift;
  my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

  croak 'pitch set must contain something' if !@$pset;

  my %origmap;
  for my $p (@$pset) {
    push @{ $origmap{ $p % $self->{_DEG_IN_SCALE} } }, $p;
  }
  if ( keys %origmap == 1 ) {
    return wantarray ? ( keys %origmap, \%origmap ) : keys %origmap;
  }
  my @nset = sort { $a <=> $b } keys %origmap;

  my @equivs;
  for my $i ( 0 .. $#nset ) {
    for my $j ( 0 .. $#nset ) {
      $equivs[$i][$j] = $nset[ ( $i + $j ) % @nset ];
    }
  }
  my @order = reverse 1 .. $#nset;

  my @normal;
  for my $i (@order) {
    my $min_span = $self->{_DEG_IN_SCALE};
    my @min_span_idx;

    for my $eidx ( 0 .. $#equivs ) {
      my $span =
        ( $equivs[$eidx][$i] - $equivs[$eidx][0] ) % $self->{_DEG_IN_SCALE};
      if ( $span < $min_span ) {
        $min_span     = $span;
        @min_span_idx = $eidx;
      } elsif ( $span == $min_span ) {
        push @min_span_idx, $eidx;
      }
    }

    if ( @min_span_idx == 1 ) {
      @normal = @{ $equivs[ $min_span_idx[0] ] };
      last;
    } else {
      @equivs = @equivs[@min_span_idx];
    }
  }

  if ( !@normal ) {
    # nothing unique, pick lowest starting pitch, which is first index
    # by virtue of the numeric sort performed above.
    @normal = @{ $equivs[0] };
  }

  # but must map  (and anything else not ) so b is 0,
  # dis 4, etc. and also update the original pitch mapping - this is
  # the major addition to the otherwise stock normal_form code.
  if ( $normal[0] != 0 ) {
    my $trans = $self->{_DEG_IN_SCALE} - $normal[0];
    my %newmap;
    for my $i (@normal) {
      my $prev = $i;
      $i = ( $i + $trans ) % $self->{_DEG_IN_SCALE};
      $newmap{$i} = $origmap{$prev};
    }
    %origmap = %newmap;
  }

  return
    wantarray ? ( join( ',', @normal ), \%origmap ) : join( ',', @normal );
}

# Turns string of tokens (e.g. 'RLP') into a list of tasks (CODE refs,
# or more strings, which are recursed on until CODE refs or error).
# Returns array reference of such tasks. Called by transform() if user
# has not already done this and passes transform() a string of tokens.
sub taskify_tokens {
  my ( $self, $tokens, $tasks ) = @_;
  $tasks //= [];
  $tokens = [ $tokens =~ m/([A-Z][a-z0-9]*)/g ] if !defined reftype $tokens;

  # XXX optimize input? - runs of P can be reduced, as those just toggle
  # the third - even number of P a no-op, odd number of P can be
  # replaced with 'P'. Other optimizations are likely possible.

  for my $t (@$tokens) {
    if ( exists $self->{x}{$t} ) {
      if ( ref $self->{x}{$t} eq 'CODE' ) {
        push @$tasks, [ $t, $self->{x}{$t} ];
      } elsif ( !defined reftype $self->{x}{$t}
        or ref $self->{x}{$t} eq 'ARRAY' ) {
        $self->taskify_tokens( $self->{x}{$t}, $tasks );
      } else {
        croak 'unknown token in transformation table';
      }
    } else {
      croak "unimplemented transformation token '$t'";
    }
  }

  return $tasks;
}

sub techno { shift; (qw/tonn tz/) x ( 8 * ( shift || 1 ) ) }

sub transform {
  my $self   = shift;
  my $tokens = shift;
  croak 'tokens must be defined' unless defined $tokens;
  my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
  croak 'pitch set must contain something' if !@$pset;

  # Assume list of tasks (code refs to call) if array ref, otherwise try
  # to generate such a list.
  my $tasks;
  if ( ref $tokens eq 'ARRAY' ) {
    $tasks = $tokens;
  } else {
    try { $tasks = $self->taskify_tokens($tokens) } catch { croak $_ };
  }

  my $new_pset = $pset;
  try {
    for my $task (@$tasks) {
      $new_pset =
        $task->[1]->( $self, $task->[0], $self->normalize($new_pset) );
    }
  }
  catch {
    croak $_;
  };
  return $new_pset;
}

1;
__END__