File Coverage

blib/lib/App/Music/PlayTab/LyChord.pm
Criterion Covered Total %
statement 122 133 91.7
branch 41 52 78.8
condition 8 14 57.1
subroutine 6 6 100.0
pod 0 1 0.0
total 177 206 85.9


line stmt bran cond sub pod time code
1             #! perl
2              
3             # Author : Johan Vromans
4             # Created On : Tue Jan 15 15:59:16 2008
5             # Last Modified By: Johan Vromans
6             # Last Modified On: Wed Oct 5 12:00:16 2011
7             # Update Count : 10
8             # Status : Unknown, Use with caution!
9              
10             package App::Music::PlayTab::LyChord;
11              
12 2     2   15906 use strict;
  2         4  
  2         67  
13 2     2   9 use warnings;
  2         2  
  2         107  
14              
15             our $VERSION = "1.006";
16              
17 2     2   709 use App::Music::PlayTab::Note;
  2         3  
  2         42  
18 2     2   10 use Carp;
  2         2  
  2         84  
19 2     2   8 use base qw(App::Music::PlayTab::Chord);
  2         2  
  2         798  
20              
21             sub parse {
22 132     132 0 14442 my ($self, $chord) = @_;
23              
24 132 50       249 $self = $self->new unless ref($self);
25              
26 132         142 $self->{_unparsed} = $chord;
27 132 50       238 $self->{_debug} = 1 if $chord =~ s/^\?//;
28 132         107 $self->{_isrest} = 0;
29 132         120 delete( $self->{bass} );
30              
31 132         114 my $key = $chord;
32 132         99 my $mod = '';
33              
34             # Catch rests.
35 132 100       302 if ( $chord =~ /(^[rs])(\d+\.*)?/ ) {
36 7         8 $self->{_isrest} = 1;
37 7 100       11 if ( defined $2 ) {
38 6         17 my ($dur, $xt) = $2 =~ /^(\d+)(\.*)$/;
39 6         10 $dur = $self->duration_base / $dur;
40 6         16 $dur *= 1.5 foreach split(//, $xt);
41 6         7 $self->{duration} = $dur;
42             }
43 7         12 return $self;
44             }
45              
46             # Treat power chords as modifications.
47 125         154 $chord =~ s;^([[a-g](?:es|is)?(\d+\.*)?)/;$1:/;;
48              
49             # Separate the chord key from the modifications.
50 125 50       465 if ( $chord =~ /(^[a-g](?:es|is)?)(\d+\.*)?(?::(.*))?/ ) {
51 125         163 $key = $1;
52 125         115 $mod = $3;
53 125 100       192 if ( defined $2 ) {
54 75         194 my ($dur, $xt) = $2 =~ /^(\d+)(\.*)$/;
55 75         147 $dur = $self->duration_base / $dur;
56 75         112 $dur *= 1.5 foreach split(//, $xt);
57 75         80 $self->{duration} = $dur;
58             }
59             }
60              
61             # Parse key.
62 125         145 eval { $self->{key} = App::Music::PlayTab::Note->parse($key) };
  125         281  
63             croak("Unrecognized pitch in chord: ".$self->{_unparsed})
64 125 50       312 unless defined $self->{key};
65              
66             # Encodings: a bit is set in $chflags for every note in the chord.
67             # The corresponding element of $chmods is 0 (natural), -1
68             # (lowered), 1 (raised) or undef (suppressed).
69              
70 125         101 my $chflags = '';
71 125         250 my @chmods = (0) x 14;
72              
73             # Assume major triad.
74 125         238 vec($chflags,3,1) = 1;
75 125         170 vec($chflags,5,1) = 1;
76 125         109 $chmods[3] = 0;
77 125         88 $chmods[5] = 0;
78              
79             # Then other modifications.
80 125   66     391 while ( $mod && $mod ne '' ) {
81              
82 58 100       89 if ( $mod =~ /^maj7?(?:\.?(.*))?/ ) { # Maj7
83 3         6 $mod = $+;
84 3         4 vec($chflags,7,1) = 1;
85 3         3 $chmods[7] = 1;
86 3         6 next;
87             }
88 55 100       77 if ( $mod =~ /^m(?:in)?7(?:\.?(.*))?/ ) { # Minor triad 7
89 1         2 $mod = $+;
90 1         3 vec($chflags,7,1) = 1;
91 1         2 $chmods[7] = 0;
92 1         2 vec($chflags,3,1) = 1;
93 1         2 $chmods[3] = -1;
94 1         2 next;
95             }
96 54 100       127 if ( $mod =~ /^m(?:\.?(.*))?/ ) { # Minor triad
97 36         51 $mod = $+;
98 36         46 vec($chflags,3,1) = 1;
99 36         32 $chmods[3] = -1;
100 36         64 next;
101             }
102              
103             # Transform 7sus4 into something we can parse.
104 18         20 $mod =~ s/^(\d+)sus(\d?)/sus$2.$1/;
105              
106 18 100       30 if ( $mod =~ /^sus2(?:\.(.*))?/ ) { # Suspended second
107 1         3 $mod = $+;
108 1         2 vec($chflags,3,1) = 0;
109 1         2 undef $chmods[3];
110 1         2 next;
111             }
112 17 100       30 if ( $mod =~ /^sus4?(?:\.(.*))?/ ) { # Suspended fourth
113 3         5 $mod = $+;
114 3         5 vec($chflags,4,1) = 1; # does it?
115 3         5 undef $chmods[3];
116 3         4 $chmods[4] = 0;
117 3         7 next;
118             }
119 14 100       24 if ( $mod =~ /^aug(?:\.?(.*))?/ ) { # Augmented
120 1         3 $mod = $+;
121 1         2 vec($chflags,5,1) = 1;
122 1         2 $chmods[5] = 1;
123 1         2 next;
124             }
125 13 100       21 if ( $mod =~ /^dim(?:\.?(.*))?/ ) { # Diminished
126 1         2 $mod = $+;
127 1         4 vec($chflags,3,1) = 1;
128 1         3 vec($chflags,5,1) = 1;
129 1         2 vec($chflags,7,1) = 1;
130 1         2 $chmods[3] = -1;
131 1         2 $chmods[5] = -1;
132 1         0 $chmods[7] = -1;
133 1         3 next;
134             }
135             # if ( $mod =~ /^%(.*)/ ) { # half-diminished 7
136             # $mod = $+;
137             # $chflags = '';
138             # vec($chflags,3,1) = 1;
139             # vec($chflags,5,1) = 1;
140             # vec($chflags,7,1) = 1;
141             # $chmods[3] = -1;
142             # $chmods[5] = -1;
143             # $chmods[7] = 0;
144             # next;
145             # }
146 12 100       45 if ( $mod =~ /^(2|5|6|7|9|10|11|13)([-+])?(?:\.(.*))?/ ) { # addition
147 10         10 $mod = $3;
148             # 13th implies 11th implies 9th implies 7th...
149 10 100 66     43 if ( $1 > 7 && !(vec($chflags,7,1)) ) {
150 5         7 vec($chflags,7,1) = 1;
151 5         7 $chmods[7] = 0;
152             }
153 10 100 66     28 if ( $1 > 10 && !(vec($chflags,9,1)) ) {
154 3         4 vec($chflags,9,1) = 1;
155 3         4 $chmods[9] = 0;
156             }
157 10 100 66     27 if ( $1 > 11 && !(vec($chflags,11,1)) ) {
158 2         2 vec($chflags,11,1) = 1;
159 2         3 $chmods[11] = 1;
160             }
161 10         16 vec($chflags,$1,1) = 1;
162 10         14 $chmods[$1] = 0;
163 10 100       17 if ( defined $2 ) {
164 1 50       3 $chmods[$1] = ($2 eq '+') ? 1 : -1;
165             }
166 10         21 next;
167             }
168 2 50       7 if ( $mod =~ /^\^(\d+)(?:\.(.*))?/ ) {
169 2         3 $mod = $2;
170 2         5 vec($chflags,$1,1) = 1;
171 2         4 undef $chmods[$1];
172 2         5 next;
173             }
174              
175             # Power chords.
176 0 0       0 if ( $mod =~ /^\/(.+)/ ) {
177 0         0 my @ch = split(/\//, $1);
178 0         0 foreach my $c ( @ch ) {
179             # my $p = eval { App::Music::PlayTab::Note->parse($c) };
180 0         0 my $p = eval { App::Music::PlayTab::Chord->parse($c) };
  0         0  
181             croak("Unrecognized bass of chord: ".$self->{_unparsed})
182 0 0       0 unless defined $p;
183 0   0     0 $self->{bass} ||= [];
184 0         0 push(@{$self->{bass}}, $p);
  0         0  
185             }
186 0         0 last;
187             }
188 0         0 croak("Unrecognized modification of chord: ".$self->{_unparsed});
189             }
190              
191 125         135 my @vec = (0);
192 125         172 for ( 1..13 ) {
193 1625 100       1955 next unless vec($chflags,$_,1);
194 277 100       334 next unless defined $chmods[$_];
195 272         325 push (@vec, (0,0,2,4,5,7,9,10,12,14,16,17,19,21)[$_]+$chmods[$_]);
196             }
197              
198 125         180 $self->{vec} = [@vec];
199              
200             warn("=> Chord ", $self->{_unparsed}, ": ", $self->{key}->key,
201             " (", $self->{key}->name, ") [ @vec ]\n")
202 125 50       211 if $self->{_debug};
203              
204 125         273 $self;
205             }
206              
207             1;
208              
209             __END__