File Coverage

blib/lib/Music/FretboardDiagram.pm
Criterion Covered Total %
statement 88 151 58.2
branch 21 76 27.6
condition 3 12 25.0
subroutine 17 19 89.4
pod 1 2 50.0
total 130 260 50.0


line stmt bran cond sub pod time code
1             package Music::FretboardDiagram;
2             our $AUTHORITY = 'cpan:GENE';
3              
4             # ABSTRACT: Draw fretboard chord diagrams
5              
6             our $VERSION = '0.1314';
7              
8 1     1   1029 use Moo;
  1         9570  
  1         3  
9 1     1   1638 use strictures 2;
  1         1394  
  1         31  
10 1     1   565 use namespace::clean;
  1         9520  
  1         5  
11              
12 1     1   262 use Carp 'croak';
  1         2  
  1         46  
13 1     1   752 use Imager ();
  1         46972  
  1         33  
14 1     1   423 use List::SomeUtils 'first_index';
  1         5419  
  1         75  
15 1     1   388 use Music::Chord::Namer 'chordname';
  1         2085  
  1         56  
16              
17 1     1   7 use constant WHITE => 'white';
  1         3  
  1         48  
18 1     1   6 use constant BLACK => 'black';
  1         1  
  1         52  
19 1     1   6 use constant TAN => 'tan';
  1         2  
  1         2310  
20              
21              
22             has chord => (
23             is => 'rw',
24             );
25              
26              
27             has position => (
28             is => 'rw',
29             isa => \&_positive_int,
30             default => sub { 1 },
31             );
32              
33              
34             has absolute => (
35             is => 'ro',
36             isa => \&_boolean,
37             default => sub { 0 },
38             );
39              
40              
41             has strings => (
42             is => 'ro',
43             isa => \&_positive_int,
44             default => sub { 6 },
45             );
46              
47              
48             has frets => (
49             is => 'ro',
50             isa => \&_positive_int,
51             default => sub { 5 },
52             );
53              
54              
55             has size => (
56             is => 'ro',
57             isa => \&_positive_int,
58             default => sub { 30 },
59             );
60              
61              
62             has outfile => (
63             is => 'rw',
64             default => sub { 'chord-diagram' },
65             );
66              
67              
68             has type => (
69             is => 'ro',
70             default => sub { 'png' },
71             );
72              
73              
74             has font => (
75             is => 'ro',
76             default => sub { '/usr/share/fonts/truetype/freefont/FreeMono.ttf' },
77             );
78              
79              
80             has tuning => (
81             is => 'ro',
82             default => sub { [qw/E B G D A E/] },
83             );
84              
85              
86             has horiz => (
87             is => 'ro',
88             isa => \&_boolean,
89             default => sub { 0 },
90             );
91              
92              
93             has image => (
94             is => 'ro',
95             isa => \&_boolean,
96             default => sub { 0 },
97             );
98              
99              
100             has string_color => (
101             is => 'ro',
102             default => sub { 'blue' },
103             );
104              
105              
106             has fret_color => (
107             is => 'ro',
108             default => sub { 'darkgray' },
109             );
110              
111              
112             has dot_color => (
113             is => 'ro',
114             default => sub { 'black' },
115             );
116              
117              
118             has showname => (
119             is => 'rw',
120             default => sub { 1 },
121             );
122              
123              
124             has verbose => (
125             is => 'ro',
126             isa => \&_boolean,
127             default => sub { 0 },
128             );
129              
130              
131             has fretboard => (
132             is => 'ro',
133             init_arg => undef,
134             );
135              
136              
137             sub BUILD {
138 4     4 0 26 my ( $self, $args ) = @_;
139              
140 4 50       70 $self->chord( [ [ $self->position, $self->chord ] ] )
141             unless ref $self->chord;
142              
143 4 100 66     52 croak 'chord length and string number differ'
144             if $self->chord && length( $self->chord->[0][1] ) != $self->strings;
145              
146 3         10 my @scale = qw/C Db D Eb E F Gb G Ab A Bb B/;
147              
148             # Make a scale position index corresponding to the given tuning
149 3     129   4 my @index = map { my $t = $_; first_index { $t eq $_ } @scale } @{ $self->tuning };
  18         24  
  18         42  
  129         155  
  3         7  
150              
151 3         6 my %notes;
152              
153 3         4 my $string = 0;
154 3         5 for my $i ( @index ) {
155             # Make a scale note list for the string
156 18         31 $notes{++$string} = [ map { $scale[ ($i + $_) % @scale ] } 0 .. @scale - 1 ];
  216         313  
157             }
158              
159 3         18 $self->{fretboard} = \%notes;
160             }
161              
162              
163             sub draw {
164 1     1 1 342 my ($self) = @_;
165              
166 1 50       5 if ( $self->horiz ) {
167 0         0 return $self->_draw_horiz;
168             }
169              
170 1         3 my $SPACE = $self->size;
171              
172 1         3 my $frets = $self->frets + 1;
173 1         1 my $font;
174              
175             # Setup a new image
176 1         9 my $i = Imager->new(
177             xsize => $SPACE + $self->strings * $SPACE,
178             ysize => $SPACE + $frets * $SPACE,
179             );
180 1         217 $i->box( filled => 1, color => WHITE );
181              
182 1 50       8943 if ( -e $self->font ) {
183 0         0 $font = Imager::Font->new( file => $self->font );
184             }
185             else {
186 1         49 warn 'WARNING: Font ', $self->font, " not found\n";
187             }
188              
189             # Draw the horizontal fret lines
190 1         6 for my $fret ( 0 .. $frets - 1 ) {
191 6         7161 $i->line(
192             color => $self->fret_color,
193             x1 => $SPACE,
194             y1 => $SPACE + $fret * $SPACE,
195             x2 => $SPACE + ($self->strings - 1) * $SPACE,
196             y2 => $SPACE + $fret * $SPACE,
197             aa => 1,
198             endp => 1
199             );
200              
201             # Indicate the neck position
202 6 100       824 if ( $fret == 1 ) {
203 1         18 $i->string(
204             font => $font,
205             text => $self->position,
206             color => BLACK,
207             x => $SPACE / 4,
208             y => $SPACE * 2 + $SPACE / 4,
209             size => $SPACE / 2,
210             aa => 1,
211             );
212             }
213              
214 6 100       59 if ( $self->_fret_match($fret) ) {
215 2 50       41 $i->circle(
216             color => TAN,
217             r => $SPACE / 8,
218             x => $SPACE * $self->strings / 2 + $SPACE / 2,
219             y => $SPACE + $fret * $SPACE + $SPACE / 2,
220             ) if ( $SPACE + $fret * $SPACE + $SPACE / 2 ) < ( $SPACE * $frets );
221             }
222             }
223              
224             # Draw the vertical string lines
225 1         141 for my $string ( 0 .. $self->strings - 1 ) {
226 6         592 $i->line(
227             color => $self->string_color,
228             x1 => $SPACE + $string * $SPACE,
229             y1 => $SPACE,
230             x2 => $SPACE + $string * $SPACE,
231             y2 => $SPACE + ($frets - 1) * $SPACE,
232             aa => 1,
233             endp => 1
234             );
235             }
236              
237 1         113 for my $spec ( @{ $self->chord } ) {
  1         4  
238 1         2 my ( $posn, $chord ) = @$spec;
239              
240 1         2 my @chord;
241              
242             # Draw the note/mute markers
243 1         4 my $string = $self->strings;
244 1         4 for my $note ( split //, $chord ) {
245 6 50       13 if ( $note =~ /-/ ) {
246 0         0 $string--;
247 0         0 next;
248             }
249              
250 6 50       15 if ( $note =~ /[xX]/ ) {
    0          
251 6 50       12 warn "X at 0,$string\n" if $self->verbose;
252              
253 6         17 $i->string(
254             font => $font,
255             text => 'X',
256             color => BLACK,
257             x => $SPACE + ($self->strings - $string) * $SPACE - $SPACE / 6,
258             y => $SPACE - 2,
259             size => $SPACE / 2,
260             aa => 1,
261             );
262             }
263             elsif ( $note =~ /[oO0]/ ) {
264 0         0 my $temp = $self->fretboard->{$string}[0];
265 0         0 push @chord, $temp;
266              
267 0 0       0 warn "O at 0,$string = $temp\n" if $self->verbose;
268              
269 0         0 $i->string(
270             font => $font,
271             text => 'O',
272             color => BLACK,
273             x => $SPACE + ($self->strings - $string) * $SPACE - $SPACE / 6,
274             y => $SPACE - 2,
275             size => $SPACE / 2,
276             aa => 1,
277             );
278             }
279             else {
280 0         0 my $temp = $self->_note_at($string, $note);
281 0         0 push @chord, $temp;
282              
283 0 0       0 warn "Dot at $note,$string = $temp\n" if $self->verbose;
284              
285 0 0       0 my $y = $self->absolute
286             ? $SPACE + $SPACE / 2 + ($posn - 1 + $note - 1) * $SPACE
287             : $SPACE + $SPACE / 2 + ($note - 1) * $SPACE;
288              
289 0 0 0     0 $i->circle(
290             color => $self->dot_color,
291             r => $SPACE / 5,
292             x => $SPACE + ($self->strings - $string) * $SPACE,
293             y => $y,
294             ) if $y >= $SPACE && $y <= $SPACE * $frets;
295             }
296              
297             # Decrement the current string number
298 6         98 $string--;
299             }
300              
301             # Print the chord name if requested
302 1 50       5 if ( $self->showname ) {
303 1 50       6 my $chord_name = $self->showname eq '1' ? chordname(@chord) : $self->showname;
304 1 50       788 warn "Chord = $chord_name\n" if $self->verbose;
305 1         8 $i->string(
306             font => $font,
307             text => $chord_name,
308             color => BLACK,
309             x => $SPACE,
310             y => ($frets + 1) * $SPACE - $SPACE / 3,
311             size => $SPACE / 2,
312             aa => 1,
313             );
314             }
315             }
316              
317 1 50       23 if ( $self->image ) {
318 1         3 return $i;
319             }
320             else {
321 0         0 $self->_output_image($i);
322             }
323             }
324              
325             sub _draw_horiz {
326 0     0   0 my ($self) = @_;
327              
328 0         0 my $SPACE = $self->size;
329              
330 0         0 my $frets = $self->frets + 1;
331 0         0 my $font;
332              
333             # Setup a new image
334 0         0 my $i = Imager->new(
335             ysize => $SPACE + $self->strings * $SPACE,
336             xsize => $SPACE + $frets * $SPACE,
337             );
338 0         0 $i->box( filled => 1, color => WHITE );
339              
340 0 0       0 if ( -e $self->font ) {
341 0         0 $font = Imager::Font->new( file => $self->font );
342             }
343             else {
344 0         0 warn 'WARNING: Font ', $self->font, " not found\n";
345             }
346              
347             # Draw the vertical fret lines
348 0         0 for my $fret ( 0 .. $frets - 1 ) {
349 0         0 $i->line(
350             color => $self->fret_color,
351             y1 => $SPACE,
352             x1 => $SPACE + $fret * $SPACE,
353             y2 => $SPACE + ($self->strings - 1) * $SPACE,
354             x2 => $SPACE + $fret * $SPACE,
355             aa => 1,
356             endp => 1
357             );
358              
359             # Indicate the neck position
360 0 0       0 if ( $fret == 1 ) {
361 0         0 $i->string(
362             font => $font,
363             text => $self->position,
364             color => BLACK,
365             y => $SPACE / 2 + $SPACE / 5,
366             x => $SPACE * 2 - $SPACE / 5,
367             size => $SPACE / 2,
368             aa => 1,
369             );
370             }
371              
372 0 0       0 if ( $self->_fret_match($fret) ) {
373 0 0       0 $i->circle(
374             color => TAN,
375             r => $SPACE / 8,
376             y => $SPACE * $self->strings / 2 + $SPACE / 2,
377             x => $SPACE + $fret * $SPACE + $SPACE / 2,
378             ) if ( $SPACE + $fret * $SPACE + $SPACE / 2 ) < ( $SPACE * $frets );
379             }
380             }
381              
382             # Draw the horizontal string lines
383 0         0 for my $string ( 0 .. $self->strings - 1 ) {
384 0         0 $i->line(
385             color => $self->string_color,
386             y1 => $SPACE + $string * $SPACE,
387             x1 => $SPACE,
388             y2 => $SPACE + $string * $SPACE,
389             x2 => $SPACE + ($frets - 1) * $SPACE,
390             aa => 1,
391             endp => 1
392             );
393             }
394              
395 0         0 for my $spec ( @{ $self->chord } ) {
  0         0  
396 0         0 my ( $posn, $chord ) = @$spec;
397              
398 0         0 my @chord;
399              
400             # Draw the note/mute markers
401 0         0 my $string = 1;
402 0         0 for my $note ( reverse split //, $chord ) {
403 0 0       0 if ( $note =~ /-/ ) {
404 0         0 $string++;
405 0         0 next;
406             }
407              
408 0 0       0 if ( $note =~ /[xX]/ ) {
    0          
409 0 0       0 warn "X at fret:0, string:$string\n" if $self->verbose;
410              
411 0         0 $i->string(
412             font => $font,
413             text => 'X',
414             color => BLACK,
415             y => $SPACE + ($string - 1) * $SPACE + $SPACE / 4,
416             x => $SPACE - $SPACE / 2,
417             size => $SPACE / 2,
418             aa => 1,
419             );
420             }
421             elsif ( $note =~ /[oO0]/ ) {
422 0         0 my $temp = $self->fretboard->{$string}[0];
423 0         0 unshift @chord, $temp;
424              
425 0 0       0 warn "O at fret:0, string:$string = $temp\n" if $self->verbose;
426              
427 0         0 $i->string(
428             font => $font,
429             text => 'O',
430             color => BLACK,
431             y => $SPACE + ($string - 1) * $SPACE + $SPACE / 4,
432             x => $SPACE - $SPACE / 2,
433             size => $SPACE / 2,
434             aa => 1,
435             );
436             }
437             else {
438 0         0 my $temp = $self->_note_at($string, $note);
439 0         0 unshift @chord, $temp;
440              
441 0 0       0 warn "Dot at fret:$note, string:$string = $temp\n" if $self->verbose;
442              
443 0 0       0 my $x = $self->absolute
444             ? $SPACE + $SPACE / 2 + ($posn - 1 + $note - 1) * $SPACE
445             : $SPACE + $SPACE / 2 + ($note - 1) * $SPACE;
446              
447 0 0 0     0 $i->circle(
448             color => $self->dot_color,
449             r => $SPACE / 5,
450             x => $x,
451             y => $SPACE + ($string - 1) * $SPACE,
452             ) if $x >= $SPACE && $x <= $SPACE * $frets;
453             }
454              
455             # Increment the current string number
456 0         0 $string++;
457             }
458              
459             # Print the chord name if requested
460 0 0       0 if ( $self->showname ) {
461 0 0       0 my $chord_name = $self->showname eq '1' ? chordname(@chord) : $self->showname;
462 0 0       0 warn "Chord = $chord_name\n" if $self->verbose;
463 0         0 $i->string(
464             font => $font,
465             text => $chord_name,
466             color => BLACK,
467             x => $SPACE,
468             y => ($self->strings + 1) * $SPACE - $SPACE / 3,
469             size => $SPACE / 2,
470             aa => 1,
471             );
472             }
473             }
474              
475 0 0       0 if ( $self->image ) {
476 0         0 return $i;
477             }
478             else {
479 0         0 $self->_output_image($i);
480             }
481             }
482              
483             sub _fret_match {
484 6     6   9 my ($self, $fret) = @_;
485 6   33     107 return ( $self->position + $fret == 3 )
486             || ( $self->position + $fret == 5 )
487             || ( $self->position + $fret == 7 )
488             || ( $self->position + $fret == 9 )
489             || ( $self->position + $fret == 12 )
490             || ( $self->position + $fret == 15 )
491             || ( $self->position + $fret == 17 )
492             || ( $self->position + $fret == 19 )
493             || ( $self->position + $fret == 21 )
494             || ( $self->position + $fret == 24 );
495             }
496              
497             sub _note_at {
498 6     6   1811 my ($self, $string, $n) = @_;
499 6         116 return $self->fretboard->{$string}[ ($self->position + $n - 1) % @{ $self->fretboard->{1} } ];
  6         43  
500             }
501              
502             sub _output_image {
503 0     0   0 my ($self, $img) = @_;
504 0         0 my $name = $self->outfile . '.' . $self->type;
505 0 0       0 $img->write( type => $self->type, file => $name )
506             or croak "Can't save $name: ", $img->errstr;
507             }
508              
509             sub _positive_int {
510 34     34   1265 my ($arg) = @_;
511 34 100       461 croak "$arg is not a positive integer" unless $arg =~ /^[1-9]\d*$/;
512             }
513              
514             sub _boolean {
515 36     36   1132 my ($arg) = @_;
516 36 100       467 croak "$arg is not a Boolean value" unless $arg =~ /^[10]$/;
517             }
518              
519             1;
520              
521             __END__