File Coverage

blib/lib/Music/LilyPondUtil.pm

Criterion	Covered	Total	%
statement	199	214	92.9
branch	122	160	76.2
condition	38	50	76.0
subroutine	27	29	93.1
pod	16	16	100.0
total	402	469	85.7

# -*- Perl -*-
#
# http://www.lilypond.org/ related utility code (mostly to transition
# between Perl processing integers and the related appropriate letter
# names for the black dots in lilypond). See also Music::PitchNum.

package Music::LilyPondUtil;

use 5.010000;
use strict;
use warnings;
use Carp qw/croak/;
use Scalar::Util qw/blessed looks_like_number/;
use Try::Tiny;

our $VERSION = '0.55';

# Since dealing with lilypond, assume 12 pitch material
my $DEG_IN_SCALE = 12;
my $TRITONE      = 6;

# Default register - due to "c" in lilypond absolute notation mapping to
# the fourth register, or MIDI pitch number 48. Used by the reg_*
# utility subs.
my $REL_DEF_REG = 4;

# Just the note and register information - the 0,6 bit grants perhaps
# too much leeway for relative motion (silly things like c,,,,,,,
# relative to the top note on a piano) but there are other bounds on the
# results so that they lie within the span of the MIDI note numbers.
my $LY_NOTE_RE = qr/(([a-g])(?:eses|isis|es|is)?)(([,'])\g{-1}{0,6})?/;

my %N2P = (
  qw/bis 0 c 0 deses 0 bisis 1 cis 1 des 1 cisis 2 d 2 eeses 2 dis 3 ees 3 feses 3 disis 4 e 4 fes 4 eis 5 f 5 geses 5 eisis 6 fis 6 ges 6 fisis 7 g 7 aeses 7 gis 8 aes 8 gisis 9 a 9 beses 9 ais 10 bes 10 ceses 10 aisis 11 b 11 ces 11/
);
# mixing flats and sharps not supported, either one or other right now
my %P2N = (
  flats  => {qw/0 c 1 des 2 d 3 ees 4 e 5 f 6 ges 7 g 8 aes 9 a 10 bes 11 b/},
  sharps => {qw/0 c 1 cis 2 d 3 dis 4 e 5 f 6 fis 7 g 8 gis 9 a 10 ais 11 b/},
);

# Diabolus in Musica, indeed (direction tritone heads in relative mode)
my %TTDIR = (
  flats  => {qw/0 -1 1 1 2 -1 3 1 4 -1 5 1 6 1 7 -1 8 1 9 -1 10 1 11 -1/},
  sharps => {qw/0 1 1 -1 2 1 3 -1 4 1 5 1 6 -1 7 1 8 -1 9 1 10 -1 11 -1/},
);

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

sub _range_check {
  my ( $self, $pitch ) = @_;
  if ( $pitch < $self->{_min_pitch} ) {
    if ( exists $self->{_min_pitch_hook} ) {
      return $self->{_min_pitch_hook}
        ( $pitch, $self->{_min_pitch}, $self->{_max_pitch}, $self );
    } else {
      die "pitch $pitch is too low\n";
    }

  } elsif ( $pitch > $self->{_max_pitch} ) {
    if ( exists $self->{_max_pitch_hook} ) {
      return $self->{_max_pitch_hook}
        ( $pitch, $self->{_min_pitch}, $self->{_max_pitch}, $self );
    } else {
      die "pitch $pitch is too high\n";
    }
  }

  return;
}

sub _symbol2relreg {
  my ($symbol) = @_;
  $symbol ||= q{};

  # no leap, within three stave lines of previous note
  return 0 if length $symbol == 0;

  die "invalid register symbol $symbol\n"
    if $symbol !~ m/^(([,'])\g{-1}*)$/;

  my $count = length $1;
  $count *= $2 eq q{'} ? 1 : -1;

  return $count;
}

sub chrome {
  my ( $self, $chrome ) = @_;
  if ( defined $chrome ) {
    croak q{chrome must be 'sharps' or 'flats'} unless exists $P2N{$chrome};
    $self->{_chrome} = $chrome;
  }
  return $self->{_chrome};
}

sub clear_prev_note {
  my ($self) = @_;
  undef $self->{prev_note};
}

sub clear_prev_pitch {
  my ($self) = @_;
  undef $self->{prev_pitch};
}

# diatonic (piano white key) pitch number for a given input note (like
# prev_note() below except without side-effects).
sub diatonic_pitch {
  my ( $self, $note ) = @_;

  croak 'note not defined' unless defined $note;

  my $pitch;
  if ( $note =~ m/^$LY_NOTE_RE/ ) {
    # TODO duplicates (portions of) same code, below
    my $real_note     = $1;
    my $diatonic_note = $2;
    my $reg_symbol    = $3 // '';

    croak "unknown lilypond note $note" unless exists $N2P{$real_note};

    $pitch =
      $N2P{$diatonic_note} + $self->reg_sym2num($reg_symbol) * $DEG_IN_SCALE;
    $pitch %= $DEG_IN_SCALE if $self->{_ignore_register};

  } else {
    croak "unknown note $note";
  }

  return $pitch;
}

sub ignore_register {
  my ( $self, $state ) = @_;
  $self->{_ignore_register} = $state if defined $state;
  return $self->{_ignore_register};
}

sub keep_state {
  my ( $self, $state ) = @_;
  $self->{_keep_state} = $state if defined $state;
  return $self->{_keep_state};
}

sub mode {
  my ( $self, $mode ) = @_;
  if ( defined $mode ) {
    croak q{mode must be 'absolute' or 'relative'}
      if $mode ne 'absolute' and $mode ne 'relative';
    $self->{_mode} = $mode;
  }
  return $self->{_mode};
}

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

  $self->{_chrome} = $param{chrome} || 'sharps';
  croak q{chrome must be 'sharps' or 'flats'}
    unless exists $P2N{ $self->{_chrome} };

  $self->{_keep_state}      = $param{keep_state}      // 1;
  $self->{_ignore_register} = $param{ignore_register} // 0;

  # Default min_pitch of 21 causes too many problems for existing code,
  # so minimum defaults to 0, which is a bit beyond the bottom of 88-key
  # pianos. 108 is the top of a standard 88-key piano.
  $self->{_min_pitch} = $param{min_pitch} // 0;
  $self->{_max_pitch} = $param{max_pitch} // 108;

  if ( exists $param{min_pitch_hook} ) {
    croak 'min_pitch_hook must be code ref'
      unless ref $param{min_pitch_hook} eq 'CODE';
    $self->{_min_pitch_hook} = $param{min_pitch_hook};
  }
  if ( exists $param{max_pitch_hook} ) {
    croak 'max_pitch_hook must be code ref'
      unless ref $param{max_pitch_hook} eq 'CODE';
    $self->{_max_pitch_hook} = $param{max_pitch_hook};
  }

  $self->{_mode} = $param{mode} || 'absolute';
  croak q{'mode' must be 'absolute' or 'relative'}
    if $self->{_mode} ne 'absolute' and $self->{_mode} ne 'relative';

  $self->{_p2n_hook} = $param{p2n_hook}
    || sub { $P2N{ $_[1] }->{ $_[0] % $DEG_IN_SCALE } };
  croak q{'p2n_hook' must be code ref}
    unless ref $self->{_p2n_hook} eq 'CODE';

  $self->{_sticky_state} = $param{sticky_state} // 0;
  $self->{_strip_rests}  = $param{strip_rests}  // 0;

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

sub notes2pitches {
  my $self = shift;
  my @pitches;

  for my $n ( ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_ ) {
    # pass through what hopefully are raw pitch numbers, otherwise parse
    # note from subset of the lilypond note format
    if ( !defined $n ) {
      # might instead blow up? or have option to blow up...
      push @pitches, undef unless $self->{_strip_rests};

    } elsif ( $n =~ m/^(-?\d+)$/ ) {
      push @pitches, $n;

    } elsif ( $n =~ m/^(?i)[rs]/ or $n =~ m/\\rest/ ) {
      # rests or lilypond 'silent' bits
      push @pitches, undef unless $self->{_strip_rests};

    } elsif ( $n =~ m/^$LY_NOTE_RE/ ) {
      # "diatonic" (here, the white notes of a piano) are necessary
      # for leap calculations in relative mode, as "cisis" goes down
      # to "aeses" despite the real notes ("d" and "g," in absolute
      # mode) being a fifth apart. Another way to think of it: the
      # diatonic "c" and "a" of "cisis" and "aeses" are within three
      # stave lines of one another; anything involving three or more
      # stave lines is a leap.
      my $real_note     = $1;
      my $diatonic_note = $2;
      my $reg_symbol    = $3 // '';

      croak "unknown lilypond note $n" unless exists $N2P{$real_note};

      my ( $diatonic_pitch, $real_pitch );
      if ( $self->{_mode} ne 'relative' ) {    # absolute
            # TODO see if can do this code regardless of mode, and still
            # sanity check the register for absolute/relative-no-previous,
            # but not for relative-with-previous, to avoid code
            # duplication in abs/r-no-p blocks - or call subs with
            # appropriate register numbers.
        ( $diatonic_pitch, $real_pitch ) =
          map { $N2P{$_} + $self->reg_sym2num($reg_symbol) * $DEG_IN_SCALE }
          $diatonic_note, $real_note;

        # Account for edge cases of ces and bis and the like
        my $delta = $diatonic_pitch - $real_pitch;
        if ( abs($delta) > $TRITONE ) {
          $real_pitch += $delta > 0 ? $DEG_IN_SCALE : -$DEG_IN_SCALE;
        }

      } else {    # relatively more complicated

        if ( !defined $self->{prev_note} ) {    # absolute if nothing prior
          ( $diatonic_pitch, $real_pitch ) =
            map { $N2P{$_} + $self->reg_sym2num($reg_symbol) * $DEG_IN_SCALE }
            $diatonic_note, $real_note;

          # Account for edge cases of ces and bis and the like
          my $delta = $diatonic_pitch - $real_pitch;
          if ( abs($delta) > $TRITONE ) {
            $real_pitch += $delta > 0 ? $DEG_IN_SCALE : -$DEG_IN_SCALE;
          }

        } else {                                # meat of relativity
          my $reg_number =
            int( $self->{prev_note} / $DEG_IN_SCALE ) * $DEG_IN_SCALE;

          my $reg_delta =
            $self->{prev_note} % $DEG_IN_SCALE - $N2P{$diatonic_note};
          if ( abs($reg_delta) > $TRITONE ) {
            $reg_number += $reg_delta > 0 ? $DEG_IN_SCALE : -$DEG_IN_SCALE;
          }

          # adjust register by the required relative offset
          my $reg_offset = _symbol2relreg($reg_symbol);
          if ( $reg_offset != 0 ) {
            $reg_number += $reg_offset * $DEG_IN_SCALE;
          }

          ( $diatonic_pitch, $real_pitch ) =
            map { $reg_number + $N2P{$_} } $diatonic_note, $real_note;

          my $delta = $diatonic_pitch - $real_pitch;
          if ( abs($delta) > $TRITONE ) {
            $real_pitch += $delta > 0 ? $DEG_IN_SCALE : -$DEG_IN_SCALE;
          }
        }

        $self->{prev_note} = $diatonic_pitch if $self->{_keep_state};
      }

      push @pitches, $real_pitch;

    } else {
      croak "unknown note '$n'";
    }
  }

  if ( $self->{_ignore_register} ) {
    for my $p (@pitches) {
      $p %= $DEG_IN_SCALE if defined $p;
    }
  }

  undef $self->{prev_note} unless $self->{_sticky_state};

  return @pitches > 1 ? @pitches : $pitches[0];
}

# Converts pitches to lilypond names
sub p2ly {
  my $self = shift;

  my @notes;
  for my $obj ( ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_ ) {
    my $pitch;
    if ( !defined $obj ) {
      croak "cannot convert undefined value to lilypond element";
    } elsif ( blessed $obj and $obj->can("pitch") ) {
      $pitch = $obj->pitch;
    } elsif ( looks_like_number $obj) {
      $pitch = int $obj;
    } else {
      # pass through on unknowns (could be rests or who knows what)
      push @notes, $obj;
      next;
    }

    # Response handling on range check:
    # * exception - out of bounds, default die() handler tripped
    # * defined return value - got something from a hook function, use that
    # * undefined - pitch is within bounds, continue with code below
    my $range_result;
    try { $range_result = $self->_range_check($pitch) }
    catch {
      croak $_;
    };
    if ( defined $range_result ) {
      push @notes, $range_result;
      next;
    }

    my $note = $self->{_p2n_hook}( $pitch, $self->{_chrome} );
    croak "could not lookup note for pitch '$pitch'" unless defined $note;

    my $register;
    if ( $self->{_mode} ne 'relative' ) {
      $register = $self->reg_num2sym( $pitch / $DEG_IN_SCALE );

    } else {    # relatively more complicated
      my $rel_reg = $REL_DEF_REG;
      if ( defined $self->{prev_pitch} ) {
        my $delta = int( $pitch - $self->{prev_pitch} );
        if ( abs($delta) >= $TRITONE ) {    # leaps need , or ' variously
          if ( $delta % $DEG_IN_SCALE == $TRITONE ) {
            $rel_reg += int( $delta / $DEG_IN_SCALE );

            # Adjust for tricky changing tritone default direction
            my $default_dir =
              $TTDIR{ $self->{_chrome} }
              ->{ $self->{prev_pitch} % $DEG_IN_SCALE };
            if ( $delta > 0 and $default_dir < 0 ) {
              $rel_reg++;
            } elsif ( $delta < 0 and $default_dir > 0 ) {
              $rel_reg--;
            }

          } else {    # not tritone, but leap
                      # TT adjust is to push <1 leaps out so become 1
            $rel_reg +=
              int( ( $delta + ( $delta > 0 ? $TRITONE : -$TRITONE ) ) /
                $DEG_IN_SCALE );
          }
        }
      }
      $register = $self->reg_num2sym($rel_reg);
      $self->{prev_pitch} = $pitch if $self->{_keep_state};
    }

    # Do not care about register (even in absolute mode) if keeping state
    if ( $self->{_keep_state} ) {
      croak "register out of range for pitch '$pitch'"
        unless defined $register;
    } else {
      $register = '';
    }
    push @notes, $note . $register;
  }

  undef $self->{prev_pitch} unless $self->{_sticky_state};
  return @_ > 1 ? @notes : $notes[0];
}

# MUST NOT accept raw pitch numbers, as who knows if "61" is a "cis"
# or "des" or the like, which will in turn affect the relative
# calculations!
sub prev_note {
  my ( $self, $pitch ) = @_;
  if ( defined $pitch ) {
    if ( $pitch =~ m/^$LY_NOTE_RE/ ) {
      # TODO duplicates (portions of) same code, below
      my $real_note     = $1;
      my $diatonic_note = $2;
      my $reg_symbol    = $3 // '';

      croak "unknown lilypond note $pitch" unless exists $N2P{$real_note};

      # for relative-to-this just need the diatonic
      $self->{prev_note} =
        $N2P{$diatonic_note} +
        $self->reg_sym2num($reg_symbol) * $DEG_IN_SCALE;

    } else {
      croak "unknown pitch '$pitch'";
    }
  }
  return $self->{prev_note};
}

sub prev_pitch {
  my ( $self, $pitch ) = @_;
  if ( defined $pitch ) {
    if ( blessed $pitch and $pitch->can("pitch") ) {
      $self->{prev_pitch} = $pitch->pitch;
    } elsif ( looks_like_number $pitch) {
      $self->{prev_pitch} = int $pitch;
    } else {
      try { $self->{prev_pitch} = $self->diatonic_pitch($pitch) }
      catch {
        croak $_;
      };
    }
  }
  return $self->{prev_pitch};
}

# Utility, converts arbitrary numbers into lilypond register notation
sub reg_num2sym {
  my ( $self, $number ) = @_;
  croak 'register number must be numeric'
    if !defined $number
    or !looks_like_number $number;

  $number = int $number;
  my $symbol = q{};
  if ( $number < $REL_DEF_REG ) {
    $symbol = q{,} x ( $REL_DEF_REG - $number );
  } elsif ( $number > $REL_DEF_REG ) {
    $symbol = q{'} x ( $number - $REL_DEF_REG );
  }
  return $symbol;
}

# Utility, converts arbitrary ,, or ''' into appropriate register number
sub reg_sym2num {
  my ( $self, $symbol ) = @_;
  croak 'undefined register symbol' unless defined $symbol;
  croak 'invalid register symbol'   unless $symbol =~ m/^(,|')*$/;

  my $dir = $symbol =~ m/[,]/ ? -1 : 1;

  return $REL_DEF_REG + $dir * length $symbol;
}

sub sticky_state {
  my ( $self, $state ) = @_;
  $self->{_sticky_state} = $state if defined $state;
  return $self->{_sticky_state};
}

sub strip_rests {
  my ( $self, $state ) = @_;
  $self->{_strip_rests} = $state if defined $state;
  return $self->{_strip_rests};
}

1;
__END__