File Coverage

blib/lib/Music/Chord/Note.pm

Criterion	Covered	Total	%
statement	61	61	100.0
branch	22	22	100.0
condition	5	5	100.0
subroutine	11	11	100.0
pod	7	7	100.0
total	106	106	100.0

package Music::Chord::Note;

use warnings;
use strict;
use Carp qw( croak );

our $VERSION = '0.14';

my @tone_list = ('C', 'C#', 'D', 'D#', 'E', 'F', 'F#', 'G', 'G#', 'A', 'A#', 'B',
                 'C', 'C#', 'D', 'D#', 'E', 'F', 'F#', 'G', 'G#', 'A', 'A#', 'B');

our $base_chord_list = {
    'base'     => '0,4,7',
    '-5'       => '0,4,6',
    '-6'       => '0,4,7,8',
    '6'        => '0,4,7,9',
    '6(9)'     => '0,4,7,9,14',         '69'       => '0,4,7,9,14',
    'M7'       => '0,4,7,11',
    'M7(9)'    => '0,4,7,11,14',        'M79'       => '0,4,7,11,14',
    'M9'       => '0,4,7,11,14',
    'M11'      => '0,4,7,11,14,17',
    'M13'      => '0,4,7,11,14,17,21',
    '7'        => '0,4,7,10',
    '7(b5)'    => '0,4,6,10',           '7b5'      => '0,4,6,10',
    '7(-5)'    => '0,4,6,10',           '7-5'      => '0,4,6,10',
    '7(#5)'    => '0,4,7,8,10',         '7#5'      => '0,4,7,8,10',
    '7(b9)'    => '0,4,7,10,13',        '7b9'      => '0,4,7,10,13',
    '7(-9)'    => '0,4,7,10,13',        '7-9'      => '0,4,7,10,13',
    '-9'       => '0,4,7,10,13',
    '-9(#5)'   => '0,4,8,10,13',        '-9#5'     => '0,4,8,10,13',
    '7(b9,13)' => '0,4,7,10,13,21',     '7(-9,13)' => '0,4,7,10,13,21',
    '7(9,13)'  => '0,4,7,10,14,21',
    '7(#9)'    => '0,4,7,10,15',        '7#9'      => '0,4,7,10,15',
    '7(#11)'   => '0,4,7,10,15,18',     '7#11'     => '0,4,7,10,15,18',
    '7(#13)'   => '0,4,10,21',          '7#13'     => '0,4,10,21',
    '9'        => '0,4,7,10,14',
    '9(b5)'    => '0,4,6,10,14',        '9b5'      => '0,4,6,10,14',
    '9(-5)'    => '0,4,6,10,14',        '9-5'      => '0,4,6,10,14',
    '11'       => '0,4,7,10,14,17',
    '13'       => '0,4,7,10,14,17,21',
    'm'        => '0,3,7',
    'madd4'    => '0,3,5,7',
    'm6'       => '0,3,7,9',
    'm6(9)'    => '0,3,7,9,14',          'm69'     => '0,3,7,9,14',
    'mM7'      => '0,3,7,11',
    'm7'       => '0,3,7,10',
    'm7(b5)'   => '0,3,6,10',            'm7b5'    => '0,3,6,10',
    'm7(-5)'   => '0,3,6,10',            'm7-5'    => '0,3,6,10',
    'm7(#5)'   => '0,3,8,10',            'm7#5'    => '0,3,8,10',
    'm7(9)'    => '0,3,7,10,14',         'm79'     => '0,3,7,10,14',
    'm9'       => '0,3,7,10,14',
    'm7(9,11)' => '0,3,7,10,14,17',
    'm11'      => '0,3,7,10,14,17',
    'm13'      => '0,3,7,10,14,17,21',
    'dim'      => '0,3,6',
    'dim7'     => '0,3,6,9',            'dim6'     => '0,3,6,9',
    'aug'      => '0,4,8',
    'aug7'     => '0,4,8,10',
    'augM7'    => '0,4,8,11',
    'aug9'     => '0,4,8,10,14',
    'sus2'     => '0,2,7',
    'sus'      => '0,5,7',
    'sus4'     => '0,5,7',
    '7sus4'    => '0,5,7,10',
    'add2'     => '0,2,4,7',
    'add4'     => '0,4,5,7',
    'add9'     => '0,4,7,14',
};

my $scalic_value = {
    'C'  => 0,
    'C#' => 1, 'Db' => 1,
    'D'  => 2,
    'D#' => 3, 'Eb' => 3,
    'E'  => 4,
    'E#' => 5, 'Fb' => 4, # joke!
    'F'  => 5,
    'F#' => 6, 'Gb' => 6,
    'G'  => 7,
    'G#' => 8, 'Ab' => 8,
    'A'  => 9,
    'A#' => 10, 'Bb' => 10,
    'B'  => 11,
    'Cb' => 11, 'B#' => 0, # joke!
};

sub new
{
    my $class = shift;
    bless {}, $class;
}

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

    croak "No CHORD_NAME!" unless $chord_name;
    my ($tonic, $kind) = ($chord_name =~ /([A-G][b#]?)(.+)?/);
    croak "unknown chord $chord_name" unless defined $tonic;
    $kind = 'base' unless $kind;
    my $scalic = $scalic_value->{$tonic};
    croak "undefined kind of chord $kind($chord_name)"
        unless defined $base_chord_list->{$kind};

    my @keys;
    for my $scale ( split /\,/, $base_chord_list->{$kind} ){
        my $note = $scale + $scalic;
        $note = int($note % 24) + 12 if $note > 23;
        push @keys, $tone_list[$note];
    }

    return @keys;
}

sub chord_with_octave
{
    my ($self, $chord_name, $octave) = @_;

    $octave ||= 4;

    return @{ $self->_chord_with_octave([$self->chord($chord_name)], $octave) };
}

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

    if ($octave < -2 || $octave > 9) {
        croak 'octave should be integer between -2 and 9';
    }

    my @position = map { $self->scale($_) } @{$chord};
    my @formatted;
    my $last_position = -1;
    for my $n (0 .. $#{$chord}) {
        $octave++ if $position[$n] < $last_position;
        push @formatted, $chord->[$n] . $octave;
        $last_position = $position[$n];
    }

    return \@formatted;
}

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

    $chord = 'base' unless $chord;
    croak "undefined kind of chord ($chord)" unless defined $base_chord_list->{$chord};

    return split /,/, $base_chord_list->{$chord};
}

sub chord_intervals
{
    my ($self, $name) = @_;

    my @num = $self->chord_num($name);

    my @intervals = reverse map { $_ == 0 ? $num[$_] : $num[$_] - $num[$_ - 1] }
        reverse 0 .. $#num;

    return @intervals;
}

sub scale
{
    my $self = shift;
    my $note = shift;

    $note =~ s/^([a-g])/uc($1)/e;
    croak "wrong note ($note)" if $note !~ /^[A-G](?:[#b])?$/;

    return $scalic_value->{$note};
}

sub all_chords_list
{
    my $self = shift;

    return [ grep { $_ ne 'base' } keys %{$base_chord_list} ];
}

1;

__END__