File Coverage

blib/lib/Music/ToRoman.pm

Criterion	Covered	Total	%
statement	148	153	96.7
branch	85	100	85.0
condition	24	27	88.8
subroutine	23	24	95.8
pod	4	4	100.0
total	284	308	92.2

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

# ABSTRACT: Convert notes and chords to Roman numeral notation

our $VERSION = '0.2002';

use strictures 2;
use List::SomeUtils qw(any first_index);
use Moo;
use Music::Note ();
use Music::Scales qw(get_scale_notes);
use namespace::clean;


has scale_note => (
    is      => 'ro',
    isa     => sub { die 'Invalid note' unless _valid_note( $_[0] ) },
    default => sub { 'C' },
);


has scale_name => (
    is      => 'ro',
    isa     => sub { die 'Invalid scale' unless _valid_scale( $_[0] ) },
    default => sub { 'major' },
);


has major_tonic => (
    is      => 'ro',
    isa     => sub { die 'Invalid note' unless _valid_note( $_[0] ) },
    default => sub { 'C' },
);


has chords => (
    is      => 'ro',
    isa     => sub { die 'Invalid boolean' unless $_[0] == 0 || $_[0] == 1 },
    default => sub { 1 },
);


has verbose => (
    is      => 'ro',
    default => sub { 0 },
);


sub parse {
    my ( $self, $chord ) = @_;

    die 'No chord to parse'
        unless $chord;

    my $note_re = qr/[A-G][#b]?[#b]?/;

    # Get the roman representation of the scale
    my @scale = $self->get_scale_mode;
    print "SCALE: @scale\n" if $self->verbose;

    my @notes;

    # If the note has a double sharp and is not in major, manually rotate the scale notes, since Music::Scales does not.
    if ( $self->scale_note =~ /##/ && $self->scale_name ne 'major' && $self->scale_name ne 'ionian' ) {
        my %modes = (
            dorian     => 2,
            phrygian   => 3,
            lydian     => 4,
            mixolydian => 5,
            aeolian    => 6,
            minor      => 6,
            locrian    => 7,
        );

        @notes = get_scale_notes( $self->major_tonic, 'major' );

        # Rotate the major scale to the correct mode
        push @notes, shift @notes for 1 .. $modes{ $self->scale_name } - 1;
    }
    else {
        @notes = get_scale_notes( $self->scale_note, $self->scale_name );
    }
    print "NOTES: @notes\n" if $self->verbose;

# XXX Not working?
#    my %ss_enharmonics = (
#        'C##' => 'D',
#        'D##' => 'E',
#        'F##' => 'G',
#        'G##' => 'A',
#        'A##' => 'B',
#    );
#    for ( @notes ) {
#        $_ = $ss_enharmonics{$_}
#            if $ss_enharmonics{$_};
#    }
#use Data::Dumper;warn(__PACKAGE__,' ',__LINE__," MARK: ",Dumper\@notes);

    # Convert a diminished chord
    $chord =~ s/dim/o/;

    # Get just the note part of the chord name
    ( my $note = $chord ) =~ s/^($note_re).*$/$1/;

    my %bb_enharmonics = (
        Cbb => 'Bb',
        Dbb => 'C',
        Ebb => 'D',
        Fbb => 'Eb',
        Gbb => 'F',
        Abb => 'G',
        Bbb => 'A',
    );

    $note = $bb_enharmonics{$note}
        if $note =~ /bb$/;

    # Get the roman representation based on the scale position
    my $position = first_index { $_ eq $note } @notes;

    if ( $position < 0 && ( $note eq 'Cb' || $note eq 'Fb' ) ) {
        $note = 'B'
            if $note eq 'Cb';
        $note = 'E'
            if $note eq 'Fb';
        $position = first_index { $_ eq $note } @notes;
    }
    elsif ( $note eq 'E#' ) { # XXX Why does this work?
        $note = 'F';
    }

    my $accidental = '';
    if ( $position < 0 && $note =~ /[#b]+$/ ) {
        my $n = Music::Note->new( $note, 'isobase' );
        my $name = $n->format('isobase');
        ( $accidental = $name ) =~ s/^[A-G]([#b]+)$/$1/;
        $n->en_eq( $accidental =~ /^#/ ? 'b' : '#' );
        $note = $n->format('isobase');
        $position = first_index { $_ eq $note } @notes;
        $accidental = '';
    }

    # If the note is not in the scale find the new position and accidental
    if ( $position < 0 ) {
        ( $position, $accidental ) = _pos_acc( $note, $position, \@notes );
    }

    my $roman = $scale[$position];
    print "ROMAN 1: $roman\n" if $self->verbose;

    # Get everything but the note part
    ( my $decorator = $chord ) =~ s/^(?:$note_re)(.*)$/$1/;

    # Are we minor or diminished?
    my $minor = $decorator =~ /[-moø]/ ? 1 : 0;
    print "CHORD: $chord, NOTE: $note, NEW ACCI: $accidental, DECO: $decorator, MINOR: $minor, POSN: $position\n" if $self->verbose;

    # Convert the case of the roman representation based on minor or major
    if ( $self->chords ) {
        $roman = $minor && $decorator !~ /maj/i ? lc($roman) : uc($roman);
    }

    # Add any accidental found in a non-scale note
    $roman = $accidental . $roman if $accidental;
    print "ROMAN 2: $roman\n" if $self->verbose;

    # Handle these unfortunate edge cases:
    $roman = _up_to_flat( $roman, \@scale );
    print "ROMAN 3: $roman\n" if $self->verbose;

    # Handle the decorator variations
    if ( $decorator =~ /maj/i || $decorator =~ /min/i ) {
        $decorator = lc $decorator;
    }
    elsif ( $decorator =~ /△/ ) {
        $decorator =~ s/△/maj/;
    }
    elsif ( $decorator =~ /ø/ ) {
        $decorator =~ s/ø/7b5/;
    }
    else {
        # Drop the minor and major part of the chord name
        $decorator =~ s/[-Mm]//i;
    }
    print "DECO: $decorator\n" if $self->verbose;

    # A remaining note name is a bass decorator
    if ( $decorator =~ /($note_re)/ ) {
        my $name = $1;

        $position = first_index { $_ eq $name } @notes;
        print "BASS NOTE: $name, POSN: $position\n" if $self->verbose;

        if ( $position >= 0 ) {
            $decorator =~ s/$note_re/$scale[$position]/;
        }
        else {
            ( $position, $accidental ) = _pos_acc( $name, $position, \@notes );
            print "NEW POSN: $position, ACCI: $accidental\n" if $self->verbose;

            my $bass = $accidental . $scale[$position];
            $decorator =~ s/$note_re/$bass/;

            # Handle these unfortunate edge cases
            $decorator = _up_to_flat( $decorator, \@scale );
        }
        print "NEW DECO: $decorator\n" if $self->verbose;
    }

    # Append the remaining decorator to the roman representation
    $roman .= $decorator;

    $roman =~ s/bI\b/vii/g;
    $roman =~ s/bIV\b/iii/g;

    print "ROMAN 4: $roman\n" if $self->verbose;

    return $roman;
}


sub get_scale_mode {
    my ($self) = @_;

    my @scale = qw( I ii iii IV V vi vii ); # Default to major/ionian

    if ( $self->scale_name eq 'dorian' ) {
        @scale = qw( i ii III IV v vi VII );
    }
    elsif ( $self->scale_name eq 'phrygian' ) {
        @scale = qw( i II III iv v VI vii );
    }
    elsif ( $self->scale_name eq 'lydian' ) {
        @scale = qw( I II iii iv V vi vii );
    }
    elsif ( $self->scale_name eq 'mixolydian' ) {
        @scale = qw( I ii iii IV v vi VII );
    }
    elsif ( $self->scale_name eq 'minor' || $self->scale_name eq 'aeolian' ) {
        @scale = qw( i ii III iv v VI VII );
    }
    elsif ( $self->scale_name eq 'locrian' ) {
        @scale = qw( i II iii iv V VI vii );
    }

    return @scale;
}


sub get_scale_degree {
    my ($self, $roman) = @_;
    my $degree = 1; # Default to major/ionian
    my $type = 'major';
    if ( $roman =~ /^vii/i ) {
        $degree = 7;
    }
    elsif ( $roman =~ /^vi/i ) {
        $degree = 6;
    }
    elsif ( $roman =~ /^v/i ) {
        $degree = 5;
    }
    elsif ( $roman =~ /^iv/i ) {
        $degree = 4;
    }
    elsif ( $roman =~ /^iii/i ) {
        $degree = 3;
    }
    elsif ( $roman =~ /^ii/i ) {
        $degree = 2;
    }
    if ( $roman =~ /o$/ ) {
        $type = 'diminished';
    }
    elsif ( $roman =~ /^[iv]+$/ ) {
        $type = 'minor';
    }
    return $degree, $type;
}


sub get_scale_chords {
    my ($self) = @_;

    my %diminished = (
      major      => 'vii',
      ionian     => 'vii',
      dorian     => 'vi',
      phrygian   => 'v',
      lydian     => 'iv',
      mixolydian => 'iii',
      minor      => 'ii',
      aeolian    => 'ii',
      locrian    => 'i',
    );
    my @chords = map { m/^$diminished{ $self->scale_name }$/ ? 'dim' : m/^[A-Z]+$/ ? '' : 'm' } $self->get_scale_mode;

    return @chords;
}

sub _up_to_flat {
    my ($numeral, $roman) = @_;

    # Change a roman sharp to a flat of the succeeding scale position
    $numeral =~ s/#([IV]+)/b$roman->[ ( ( first_index { lc($1) eq lc($_) } @$roman ) + 1 ) % @$roman ]/i;

    return $numeral;
};

sub _pos_acc {
    my ( $note, $position, $notes ) = @_;

    my $accidental;

    # If the note has no accidental...
    if ( length($note) == 1 ) {
        # Find the scale position of the closest similar note
        $position = first_index { $_ =~ /^$note/ } @$notes;

        # Get the accidental of the scale note
        ( $accidental = $notes->[$position] ) =~ s/^[A-G](.)$/$1/;

        # TODO: Explain why.
        $accidental = $accidental eq '#' ? 'b' : '#';
    }
    else {
        # Enharmonic double sharp equivalents
        my %previous_enharmonics = (
            'C#' => 'C##',
            'Db' => 'C##',
            'F#' => 'F##',
            'Gb' => 'F##',
            'G#' => 'G##',
            'Ab' => 'G##',
        );
        $note = $previous_enharmonics{$note}
            if exists $previous_enharmonics{$note} && any { $_ =~ /[CFG]##/ } @$notes;

        # Get the accidental of the given note
        ( my $letter, $accidental ) = $note =~ /^([A-G])(.+)$/;

        # Get the scale position of the closest similar note
        $position = first_index { $_ =~ /^$letter/ } @$notes;

        $accidental = $accidental eq '##' ? 'b' : $accidental;
    }

    return $position, $accidental;
}

sub _valid_note {
    my ($note) = @_;

    my @valid = ();

    my @notes = 'A' .. 'G';

    push @valid, @notes;
    push @valid, map { $_ . '#' } @notes;
    push @valid, map { $_ . '##' } @notes;
    push @valid, map { $_ . 'b' } @notes;

    return any { $_ eq $note } @valid;
}

sub _valid_scale {
    my ($name) = @_;

    my @valid = qw(
        ionian
        major
        dorian
        phrygian
        lydian
        mixolydian
        aeolian
        minor
        locrian
    );

    return any { $_ eq $name } @valid;
}

1;

__END__