File Coverage

blib/lib/Music/FretboardDiagram.pm

Criterion	Covered	Total	%
statement	105	168	62.5
branch	28	84	33.3
condition	5	15	33.3
subroutine	18	20	90.0
pod	2	3	66.6
total	158	290	54.4

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

# ABSTRACT: Draw fretboard chord diagrams

our $VERSION = '0.1315';

use Moo;
use strictures 2;
use namespace::clean;

use Carp 'croak';
use Imager ();
use List::SomeUtils 'first_index';
use Music::Chord::Namer 'chordname';

use constant WHITE => 'white';
use constant BLACK => 'black';
use constant TAN   => 'tan';


has chord => (
    is => 'rw',
);


has position => (
    is      => 'rw',
    isa     => \&_positive_int,
    default => sub { 1 },
);


has absolute => (
    is      => 'ro',
    isa     => \&_boolean,
    default => sub { 0 },
);


has strings => (
    is      => 'ro',
    isa     => \&_positive_int,
    default => sub { 6 },
);


has frets => (
    is      => 'ro',
    isa     => \&_positive_int,
    default => sub { 5 },
);


has size => (
    is      => 'ro',
    isa     => \&_positive_int,
    default => sub { 30 },
);


has outfile => (
    is      => 'rw',
    default => sub { 'chord-diagram' },
);


has type => (
    is      => 'ro',
    default => sub { 'png' },
);


has font => (
    is      => 'ro',
    default => sub { '/usr/share/fonts/truetype/freefont/FreeMono.ttf' },
);


has tuning => (
    is      => 'ro',
    default => sub { [qw/E B G D A E/] },
);


has horiz => (
    is      => 'ro',
    isa     => \&_boolean,
    default => sub { 0 },
);


has image => (
    is      => 'ro',
    isa     => \&_boolean,
    default => sub { 0 },
);


has string_color => (
    is      => 'ro',
    default => sub { 'blue' },
);


has fret_color => (
    is      => 'ro',
    default => sub { 'darkgray' },
);


has dot_color => (
    is      => 'ro',
    default => sub { 'black' },
);


has showname => (
    is      => 'rw',
    default => sub { 1 },
);


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


has fretboard => (
    is       => 'ro',
    init_arg => undef,
);


sub BUILD {
    my ( $self, $args ) = @_;

    $self->chord( [ [ $self->position, $self->chord ] ] )
        unless ref $self->chord;

    croak 'chord length and string number differ'
        if $self->chord && length( $self->chord->[0][1] ) != $self->strings;

    my @scale = qw/C Db D Eb E F Gb G Ab A Bb B/;

    # Make a scale position index corresponding to the given tuning
    my @index = map { my $t = $_; first_index { $t eq $_ } @scale } @{ $self->tuning };

    my %notes;

    my $string = 0;
    for my $i ( @index ) {
        # Make a scale note list for the string
        $notes{++$string} = [ map { $scale[ ($i + $_) % @scale ] } 0 .. @scale - 1 ];
    }

    $self->{fretboard} = \%notes;
}


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

    if ( $self->horiz ) {
        return $self->_draw_horiz;
    }

    my $SPACE = $self->size;

    my $frets = $self->frets + 1;
    my $font;

    # Setup a new image
    my $i = Imager->new(
        xsize => $SPACE + $self->strings * $SPACE,
        ysize => $SPACE + $frets * $SPACE,
    );
    $i->box( filled => 1, color => WHITE );

    if ( -e $self->font ) {
        $font = Imager::Font->new( file => $self->font );
    }
    else {
        warn 'WARNING: Font ', $self->font, " not found\n";
    }

    # Draw the horizontal fret lines
    for my $fret ( 0 .. $frets - 1 ) {
        $i->line(
            color => $self->fret_color,
            x1    => $SPACE,
            y1    => $SPACE + $fret * $SPACE,
            x2    => $SPACE + ($self->strings - 1) * $SPACE,
            y2    => $SPACE + $fret * $SPACE,
            aa    => 1,
            endp  => 1
        );

        # Indicate the neck position
        if ( $fret == 1 ) {
            $i->string(
                font  => $font,
                text  => $self->chord->[0][0],
                color => BLACK,
                x     => $SPACE / 4,
                y     => $SPACE * 2 + $SPACE / 4,
                size  => $SPACE / 2,
                aa    => 1,
            );
        }

        if ( $self->_fret_match($fret) ) {
            $i->circle(
                color => TAN,
                r     => $SPACE / 8,
                x     => $SPACE * $self->strings / 2 + $SPACE / 2,
                y     => $SPACE + $fret * $SPACE + $SPACE / 2,
            ) if ( $SPACE + $fret * $SPACE + $SPACE / 2 ) < ( $SPACE * $frets );
        }
    }

    # Draw the vertical string lines
    for my $string ( 0 .. $self->strings - 1 ) {
        $i->line(
            color => $self->string_color,
            x1    => $SPACE + $string * $SPACE,
            y1    => $SPACE,
            x2    => $SPACE + $string * $SPACE,
            y2    => $SPACE + ($frets - 1) * $SPACE,
            aa    => 1,
            endp  => 1
        );
    }

    for my $spec ( @{ $self->chord } ) {
        my ( $posn, $chord ) = @$spec;

        my @chord;

        # Draw the note/mute markers
        my $string = $self->strings;
        for my $note ( split //, $chord ) {
            if ( $note =~ /-/ ) {
                $string--;
                next;
            }

            if ( $note =~ /[xX]/ ) {
                warn "X at 0,$string\n" if $self->verbose;

                $i->string(
                    font  => $font,
                    text  => 'X',
                    color => BLACK,
                    x     => $SPACE + ($self->strings - $string) * $SPACE - $SPACE / 6,
                    y     => $SPACE - 2,
                    size  => $SPACE / 2,
                    aa    => 1,
                );
            }
            elsif ( $note =~ /[oO0]/ ) {
                my $temp = $self->_note_at(0, $string, $note);
                push @chord, $temp;

                warn "O at 0,$string = $temp\n" if $self->verbose;

                $i->string(
                    font  => $font,
                    text  => 'O',
                    color => BLACK,
                    x     => $SPACE + ($self->strings - $string) * $SPACE - $SPACE / 6,
                    y     => $SPACE - 2,
                    size  => $SPACE / 2,
                    aa    => 1,
                );
            }
            else {
                my $temp = $self->_note_at($posn, $string, $note);
                push @chord, $temp;

                warn "Dot at $note,$string = $temp\n" if $self->verbose;

                my $y = $self->absolute
                    ? $SPACE + $SPACE / 2 + ($posn - 1 + $note - 1) * $SPACE
                    : $SPACE + $SPACE / 2 + ($note - 1) * $SPACE;

                $i->circle(
                    color => $self->dot_color,
                    r     => $SPACE / 5,
                    x     => $SPACE + ($self->strings - $string) * $SPACE,
                    y     => $y,
                ) if $y >= $SPACE && $y <= $SPACE * $frets;
            }

            # Decrement the current string number
            $string--;
        }

        # Print the chord name if requested
        if ( $self->showname ) {
            my $chord_name = $self->showname eq '1' ? chordname(@chord) : $self->showname;
            warn "Chord = $chord_name\n" if $self->verbose;
            $i->string(
                font  => $font,
                text  => $chord_name,
                color => BLACK,
                x     => $SPACE,
                y     => ($frets + 1) * $SPACE - $SPACE / 3,
                size  => $SPACE / 2,
                aa    => 1,
            );
        }
    }

    if ( $self->image ) {
        return $i;
    }
    else {
        $self->_output_image($i);
    }
}

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

    my $SPACE = $self->size;

    my $frets = $self->frets + 1;
    my $font;

    # Setup a new image
    my $i = Imager->new(
        ysize => $SPACE + $self->strings * $SPACE,
        xsize => $SPACE + $frets * $SPACE,
    );
    $i->box( filled => 1, color => WHITE );

    if ( -e $self->font ) {
        $font = Imager::Font->new( file => $self->font );
    }
    else {
        warn 'WARNING: Font ', $self->font, " not found\n";
    }

    # Draw the vertical fret lines
    for my $fret ( 0 .. $frets - 1 ) {
        $i->line(
            color => $self->fret_color,
            y1    => $SPACE,
            x1    => $SPACE + $fret * $SPACE,
            y2    => $SPACE + ($self->strings - 1) * $SPACE,
            x2    => $SPACE + $fret * $SPACE,
            aa    => 1,
            endp  => 1
        );

        # Indicate the neck position
        if ( $fret == 1 ) {
            $i->string(
                font  => $font,
                text  => $self->chord->[0][0],
                color => BLACK,
                y     => $SPACE / 2 + $SPACE / 5,
                x     => $SPACE * 2 - $SPACE / 5,
                size  => $SPACE / 2,
                aa    => 1,
            );
        }

        if ( $self->_fret_match($fret) ) {
            $i->circle(
                color => TAN,
                r     => $SPACE / 8,
                y     => $SPACE * $self->strings / 2 + $SPACE / 2,
                x     => $SPACE + $fret * $SPACE + $SPACE / 2,
            ) if ( $SPACE + $fret * $SPACE + $SPACE / 2 ) < ( $SPACE * $frets );
        }
    }

    # Draw the horizontal string lines
    for my $string ( 0 .. $self->strings - 1 ) {
        $i->line(
            color => $self->string_color,
            y1    => $SPACE + $string * $SPACE,
            x1    => $SPACE,
            y2    => $SPACE + $string * $SPACE,
            x2    => $SPACE + ($frets - 1) * $SPACE,
            aa    => 1,
            endp  => 1
        );
    }

    for my $spec ( @{ $self->chord } ) {
        my ( $posn, $chord ) = @$spec;

        my @chord;

        # Draw the note/mute markers
        my $string = 1;
        for my $note ( reverse split //, $chord ) {
            if ( $note =~ /-/ ) {
                $string++;
                next;
            }

            if ( $note =~ /[xX]/ ) {
                warn "X at posn: $posn, fret:0, string:$string\n" if $self->verbose;

                $i->string(
                    font  => $font,
                    text  => 'X',
                    color => BLACK,
                    y     => $SPACE + ($string - 1) * $SPACE + $SPACE / 4,
                    x     => $SPACE - $SPACE / 2,
                    size  => $SPACE / 2,
                    aa    => 1,
                );
            }
            elsif ( $note =~ /[oO0]/ ) {
                my $temp = $self->_note_at(0, $string, $note);
                unshift @chord, $temp;

                warn "O at posn: $posn, fret:0, string:$string = $temp\n" if $self->verbose;

                $i->string(
                    font  => $font,
                    text  => 'O',
                    color => BLACK,
                    y     => $SPACE + ($string - 1) * $SPACE + $SPACE / 4,
                    x     => $SPACE - $SPACE / 2,
                    size  => $SPACE / 2,
                    aa    => 1,
                );
            }
            else {
                my $temp = $self->_note_at($posn, $string, $note);
                unshift @chord, $temp;

                warn "Dot at posn: $posn, fret:$note, string:$string = $temp\n" if $self->verbose;

                my $x = $self->absolute
                    ? $SPACE + $SPACE / 2 + ($posn - 1 + $note - 1) * $SPACE
                    : $SPACE + $SPACE / 2 + ($note - 1) * $SPACE;

                $i->circle(
                    color => $self->dot_color,
                    r     => $SPACE / 5,
                    x     => $x,
                    y     => $SPACE + ($string - 1) * $SPACE,
                ) if $x >= $SPACE && $x <= $SPACE * $frets;
            }

            # Increment the current string number
            $string++;
        }

        # Print the chord name if requested
        if ( $self->showname ) {
            my $chord_name = $self->showname eq '1' ? chordname(@chord) : $self->showname;
            warn "Chord = $chord_name\n" if $self->verbose;
            $i->string(
                font  => $font,
                text  => $chord_name,
                color => BLACK,
                x     => $SPACE,
                y     => ($self->strings + 1) * $SPACE - $SPACE / 3,
                size  => $SPACE / 2,
                aa    => 1,
            );
        }
    }

    if ( $self->image ) {
        return $i;
    }
    else {
        $self->_output_image($i);
    }
}

sub _fret_match {
    my ($self, $fret) = @_;
    return ( $self->position + $fret == 3 )
        || ( $self->position + $fret == 5 )
        || ( $self->position + $fret == 7 )
        || ( $self->position + $fret == 9 )
        || ( $self->position + $fret == 12 )
        || ( $self->position + $fret == 15 )
        || ( $self->position + $fret == 17 )
        || ( $self->position + $fret == 19 )
        || ( $self->position + $fret == 21 )
        || ( $self->position + $fret == 24 );
}

sub _note_at {
    my ($self, $posn, $string, $n) = @_;
    my $i;
    if ($posn) {
        $i = ($posn + $n - 1) % @{ $self->fretboard->{1} };
    }
    else {
        $i = 0;
    }
    return $self->fretboard->{$string}[$i];
}

sub _output_image {
    my ($self, $img) = @_;
    my $name = $self->outfile . '.' . $self->type;
    $img->write( type => $self->type, file => $name )
        or croak "Can't save $name: ", $img->errstr;
}

sub _positive_int {
    my ($arg) = @_;
    croak "$arg is not a positive integer" unless $arg =~ /^[1-9]\d*$/;
}

sub _boolean {
    my ($arg) = @_;
    croak "$arg is not a Boolean value" unless $arg =~ /^[10]$/;
}


sub spec_to_notes {
    my ($self, $spec) = @_;

    my @notes;

    croak 'chord length and string number differ'
        if length $spec != $self->strings;

    my $string = $self->strings;

    for my $n (split //, $spec) {
        if ($n eq 'x' || $n eq 'X') {
            $string--;
            next;
        }

        if ( $n =~ /[oO0]/ ) {
            push @notes, $self->_note_at(0, $string, $n);
        }
        else {
            push @notes, $self->_note_at($self->position, $string, $n);
        }

        $string--;
    }

    return \@notes;
}

1;

__END__