File Coverage

blib/lib/Music/Chord/Note.pm
Criterion Covered Total %
statement 56 56 100.0
branch 20 20 100.0
condition 5 5 100.0
subroutine 10 10 100.0
pod 6 6 100.0
total 97 97 100.0


line stmt bran cond sub pod time code
1             package Music::Chord::Note;
2              
3 3     3   213599 use warnings;
  3         22  
  3         103  
4 3     3   17 use strict;
  3         7  
  3         71  
5 3     3   12 use Carp qw( croak );
  3         6  
  3         3170  
6              
7             our $VERSION = '0.13';
8              
9             my @tone_list = ('C', 'C#', 'D', 'D#', 'E', 'F', 'F#', 'G', 'G#', 'A', 'A#', 'B',
10             'C', 'C#', 'D', 'D#', 'E', 'F', 'F#', 'G', 'G#', 'A', 'A#', 'B');
11              
12             our $base_chord_list = {
13             'base' => '0,4,7',
14             '-5' => '0,4,6',
15             '-6' => '0,4,7,8',
16             '6' => '0,4,7,9',
17             '6(9)' => '0,4,7,9,14', '69' => '0,4,7,9,14',
18             'M7' => '0,4,7,11',
19             'M7(9)' => '0,4,7,11,14', 'M79' => '0,4,7,11,14',
20             'M9' => '0,4,7,11,14',
21             'M11' => '0,4,7,11,14,17',
22             'M13' => '0,4,7,11,14,17,21',
23             '7' => '0,4,7,10',
24             '7(b5)' => '0,4,6,10', '7b5' => '0,4,6,10',
25             '7(-5)' => '0,4,6,10', '7-5' => '0,4,6,10',
26             '7(#5)' => '0,4,7,8,10', '7#5' => '0,4,7,8,10',
27             '7(b9)' => '0,4,7,10,13', '7b9' => '0,4,7,10,13',
28             '7(-9)' => '0,4,7,10,13', '7-9' => '0,4,7,10,13',
29             '-9' => '0,4,7,10,13',
30             '-9(#5)' => '0,4,8,10,13', '-9#5' => '0,4,8,10,13',
31             '7(b9,13)' => '0,4,7,10,13,21', '7(-9,13)' => '0,4,7,10,13,21',
32             '7(9,13)' => '0,4,7,10,14,21',
33             '7(#9)' => '0,4,7,10,15', '7#9' => '0,4,7,10,15',
34             '7(#11)' => '0,4,7,10,15,18', '7#11' => '0,4,7,10,15,18',
35             '7(#13)' => '0,4,10,21', '7#13' => '0,4,10,21',
36             '9' => '0,4,7,10,14',
37             '9(b5)' => '0,4,6,10,14', '9b5' => '0,4,6,10,14',
38             '9(-5)' => '0,4,6,10,14', '9-5' => '0,4,6,10,14',
39             '11' => '0,4,7,10,14,17',
40             '13' => '0,4,7,10,14,17,21',
41             'm' => '0,3,7',
42             'madd4' => '0,3,5,7',
43             'm6' => '0,3,7,9',
44             'm6(9)' => '0,3,7,9,14', 'm69' => '0,3,7,9,14',
45             'mM7' => '0,3,7,11',
46             'm7' => '0,3,7,10',
47             'm7(b5)' => '0,3,6,10', 'm7b5' => '0,3,6,10',
48             'm7(-5)' => '0,3,6,10', 'm7-5' => '0,3,6,10',
49             'm7(#5)' => '0,3,8,10', 'm7#5' => '0,3,8,10',
50             'm7(9)' => '0,3,7,10,14', 'm79' => '0,3,7,10,14',
51             'm9' => '0,3,7,10,14',
52             'm7(9,11)' => '0,3,7,10,14,17',
53             'm11' => '0,3,7,10,14,17',
54             'm13' => '0,3,7,10,14,17,21',
55             'dim' => '0,3,6',
56             'dim7' => '0,3,6,9', 'dim6' => '0,3,6,9',
57             'aug' => '0,4,8',
58             'aug7' => '0,4,8,10',
59             'augM7' => '0,4,8,11',
60             'aug9' => '0,4,8,10,14',
61             'sus2' => '0,2,7',
62             'sus' => '0,5,7',
63             'sus4' => '0,5,7',
64             '7sus4' => '0,5,7,10',
65             'add2' => '0,2,4,7',
66             'add4' => '0,4,5,7',
67             'add9' => '0,4,7,14',
68             };
69              
70             my $scalic_value = {
71             'C' => 0,
72             'C#' => 1, 'Db' => 1,
73             'D' => 2,
74             'D#' => 3, 'Eb' => 3,
75             'E' => 4,
76             'E#' => 5, 'Fb' => 4, # joke!
77             'F' => 5,
78             'F#' => 6, 'Gb' => 6,
79             'G' => 7,
80             'G#' => 8, 'Ab' => 8,
81             'A' => 9,
82             'A#' => 10, 'Bb' => 10,
83             'B' => 11,
84             'Cb' => 11, 'B#' => 0, # joke!
85             };
86              
87             sub new
88             {
89 2     2 1 179 my $class = shift;
90 2         8 bless {}, $class;
91             }
92              
93             sub chord
94             {
95 26     26 1 11780 my ($self, $chord_name) = @_;
96              
97 26 100       218 croak "No CHORD_NAME!" unless $chord_name;
98 25         169 my ($tonic, $kind) = ($chord_name =~ /([A-G][b#]?)(.+)?/);
99 25 100       285 croak "unknown chord $chord_name" unless defined $tonic;
100 22 100       54 $kind = 'base' unless $kind;
101 22         45 my $scalic = $scalic_value->{$tonic};
102             croak "undefined kind of chord $kind($chord_name)"
103 22 100       126 unless defined $base_chord_list->{$kind};
104              
105 21         30 my @keys;
106 21         74 for my $scale ( split /\,/, $base_chord_list->{$kind} ){
107 79         126 my $note = $scale + $scalic;
108 79 100       135 $note = int($note % 24) + 12 if $note > 23;
109 79         137 push @keys, $tone_list[$note];
110             }
111              
112 21         90 return @keys;
113             }
114              
115             sub chord_with_octave
116             {
117 5     5 1 2588 my ($self, $chord_name, $octave) = @_;
118              
119 5   100     18 $octave ||= 4;
120              
121 5         8 return @{ $self->_chord_with_octave([$self->chord($chord_name)], $octave) };
  5         13  
122             }
123              
124             sub _chord_with_octave
125             {
126 5     5   11 my ($self, $chord, $octave) = @_;
127              
128 5 100 100     23 if ($octave < -2 || $octave > 9) {
129 2         265 croak 'octave should be integer between -2 and 9';
130             }
131              
132 3         5 my @position = map { $self->scale($_) } @{$chord};
  11         30  
  3         7  
133 3         4 my @formatted;
134 3         4 my $last_position = -1;
135 3         5 for my $n (0 .. $#{$chord}) {
  3         10  
136 11 100       22 $octave++ if $position[$n] < $last_position;
137 11         18 push @formatted, $chord->[$n] . $octave;
138 11         20 $last_position = $position[$n];
139             }
140              
141 3         17 return \@formatted;
142             }
143              
144             sub chord_num
145             {
146 4     4 1 2197 my ($self, $chord) = @_;
147              
148 4 100       21 $chord = 'base' unless $chord;
149 4 100       90 croak "undefined kind of chord ($chord)" unless defined $base_chord_list->{$chord};
150              
151 3         14 return split /,/, $base_chord_list->{$chord};
152             }
153              
154             sub scale
155             {
156 20     20 1 4957 my $self = shift;
157 20         34 my $note = shift;
158              
159 20         51 $note =~ s/^([a-g])/uc($1)/e;
  1         5  
160 20 100       359 croak "wrong note ($note)" if $note !~ /^[A-G](?:[#b])?$/;
161              
162 16         42 return $scalic_value->{$note};
163             }
164              
165             sub all_chords_list
166             {
167 1     1 1 521 my $self = shift;
168              
169 1         8 return [ grep { $_ ne 'base' } keys %{$base_chord_list} ];
  75         136  
  1         13  
170             }
171              
172             1;
173              
174             __END__