fretting

#!/usr/bin/perl

our $VERSION = '0.15';

use strict;
use warnings;

use integer;

use Algorithm::Combinatorics qw( variations_with_repetition );
use Getopt::Long;
use Getopt::Simple qw( $switch );
use List::AllUtils qw( pairwise sum );
use Pod::Usage;

use constant BACKWARD_INFRACTION => 'B';
use constant SPAN_INFRACTION     => 'S';

=encoding utf-8

=head1 NAME

fretting - Stringed musical instrument fretboard positions

=head1 DESCRIPTION

Show all possible stringed musical instrument fretboard positions.

With the L</ARGUMENTS>, you can define fret group sizes, the number (and names)
of available fingers.  Also, you can show unplayable fingerings and the reasons:
B<B>ackwards or reverse fingering and finger B<S>pan impossibilities.  Also, the
"open position" can be shown.

The symbols for the fingers are from Spanish (de Flamenco).

  index  : índice  (i)
  middle : medular (m)
  ring   : anular  (a)
  little : meñeque (q)
  thumb  : pulgar  (p)

=head1 SYNOPSIS

 $ perl fretting [--help|-h|--docs|-d]
 $ perl fretting --debug \
    --fin "i m a q"  --sfr 1 --nfr 4 \
    --open --unplayable --accumulate

=head2 ARGUMENTS

 --help       : This exciting help message!
 --docs       : The full documentation
 --version    : Program version
 --debug      : Show progress                  0
 --sfret      : Starting fret                  1
 --nfret      : Number of frets                4
 --fingers    : Finger symbols         i m a q p
 --indexes    : One-based finger order list
 --fspan      : Adjacent finger fret span '2 1 2'
 --sfinger    : Starting finger                0
 --nfinger    : Number of fingers              4
 --open       : Show open strings              0
 --unplayable : Show unplayable positions      0
 --accumulate : Show all infractions           0

=cut

# Default, initial parameters.
my $setting = {
    sfret      => { type => '=i', default => 1 },
    nfret      => { type => '=i', default => 4 },
    fingers    => { type => '=s', default => 'i m a q p' },
    indexes    => { type => '=s', default => '' },
    fspan      => { type => '=s', default => '2 1 2' },
    sfinger    => { type => '=i', default => 0 },
    nfinger    => { type => '=i', default => 4 },
    open       => { type => '',   default => 0 },
    docs       => { type => '',   default => 0 },
    debug      => { type => '',   default => 0 },
    unplayable => { type => '',   default => 0 },
    accumulate => { type => '',   default => 0 },
};

# See warnings in output context.
$|++;

# Make an initial finger => index association.
my $indexes = associate($setting->{fingers}{default});

# Get the command line arguments and specify doc level.
setup($setting, @ARGV); # This populates the $switch global hashref.

# Transform space-separated lists into proper arrays.
transform($switch, $setting, $indexes);

# Set the fret range.
set_range($switch);

# Fret groups per finger.
my $v = variations_with_repetition($switch->{range}, $switch->{nfinger});

# Inspect each variation and flag infractions.
inspect_each($switch, $v);

sub inspect_each { # 

    # Line number format width. # TODO Compute instead of hard-coding.
    # Loop counter for each fret group shown in the final output.
    my ($width, $i) = (3, 0);

    # Increment our counter unless --open is given.
    $i++ unless $switch->{open};

    # Inspect each position AKA fret group.
    while (my $position = $v->next) {

        # Flag unplayable fret groups.
        my @infractions = infraction($switch, $position);

        # Interleave the position with fingers.
        my @pairs = pairs($switch->{fingers}, $position);

        # Print a string representation of the fret group.
        printf("%*d. %s %s\n",
            $width, $i++,
            join(' ', @pairs),
            (@infractions ? '-' . join(',', @infractions) : '')
        ) if !@infractions || $switch->{unplayable};
    }
}

sub associate { # Make a finger => index association.

    # Get either fingers or array references.
    my ($fingers, $indexes) = @_;

    # Convert to a proper array.
    my @fingers = ref($fingers) ? @$fingers : split(/\s+/, $fingers);

    # Index the fingers.
    my @indexes;
    if ($indexes) {
        # Convert to a proper array.
        @indexes = ref($indexes) ? @$indexes : split(/\s+/, $indexes);
    }
    else {
        # Index by the number of fingers.
        @indexes = 1 .. @fingers;
    }

    # Return a finger => index hashref.
    return { pairwise { ($a => $b) } @fingers, @indexes };
}

sub setup { # Harvest command-line arguments and use magical POD.

    # Intake a Go::L spec=>default hashref of settings.
    my ($set, @args) = @_;

    # Auto-help if we are called with no arguments.
    pod2usage(-verbose => 1) unless @args;

    # Set handy auto-documentation features.
    Getopt::Long::Configure(qw( auto_version auto_help ));

    # Collect the command-line arguments.
    my $options = Getopt::Simple->new;
    # This populates the global switch variable.
    $options->getOptions($set) || pod2usage(-verbose => 0);

    # Show documentation if requested.
    pod2usage(-verbose => 1) if $switch->{help};
    pod2usage(-verbose => 2) if $switch->{docs};
}

sub pairs { # Interleave two arrayrefs.
    my ($A, $B) = @_;

    # Make the arrays the same size (by smallest).
    if (@$A > @$B) {
        @$A = @$A[ 0 .. @$B - 1];
    }
    elsif (@$B > @$A) {
        @$B = @$B[ 0 .. @$A - 1];
    }

    # Return pairs unless the second is 0 (open).
    return pairwise { sprintf '%2s', $b =~ /^[1-9]$/ ? $a . $b : $b } @$A, @$B;
}

sub transform { # Transform space-separated lists into proper arrays.

    # Get settings and default finger indexes.
    my ($set, $default, $indexes) = @_;

    # Traverse the settings.
    for my $option (keys %$set) {

        # If the type of this option is a string (list)...
        if ($default->{$option}{type} eq '=s') {

            # Split the setting by whitespace.
            $set->{$option} = [ split /\s+/, $set->{$option} ];
        }
    }

    # If we have been given a new index list, re-associate.
    # Otherwise use the given defaults.
    $set->{indexes} = $set->{indexes} && @{ $set->{indexes} }
        ? associate($set->{fingers}, $set->{indexes})
        : $indexes;
}

sub set_range { # Define the fret range.

    # Pass-in settings.
    my $set = shift;

    # Set the fret range.
    my @range = ($set->{sfret} .. $set->{sfret} + $set->{nfret} - 1);

    # Prepend zero if requested.
    unshift @range, 0 if $set->{open};

    # Add the range to the settings.
    $set->{range} = \@range;
}

sub infraction { # Flag unplayable fingerings.

    # The settings and position to consider.
    my ($set, $pos) = @_;

    # Declare the flag to return.
    # " a holder for the last seen position.
    # " a finger counter.
    # Declare the "too wide" span offset.
    my ($flag, $previous, $count, $span) = ([], undef, 0, 2);

    # Inspect pairs of the position.
    # This is referred to by `last` unless we are accumulating.
    FLAG: for my $current (@$pos) {

        # Declare a bucket to keep track of fingers and their fret positions.
        my $track = {};

        # Set the first item of the pair and move on.
        if (not defined $previous) {
            $previous = $current;
            next;
        }

        # Increment the finger counter.
        $count++;

        # Skip pairs with zeros i.e. the 0th fret i.e. an open string.
        if ($current && $previous) {

            # Set the previous and current fingers.
            my $last   = $set->{fingers}[$count - 1];
            my $finger = $set->{fingers}[$count];

            # Set the current finger index.
            my $fidx = $set->{indexes}{$finger};

            # Keep track of the fingers and their frets.
            $track->{$last}   = $previous unless exists $track->{$last};
            $track->{$finger} = $current  unless exists $track->{$finger};

            # Show our progress if requested.
            if ($set->{debug}) {

                warn sprintf "Finger: %s(%d) %s(%d)\nFret:%6d%5d\n",
                    $last, $track->{$last},
                    $finger, $track->{$finger},
                    $previous, $current;
            }

            # Collect the fingers that have already been seen.
            my @seen = grep { exists $track->{$_} } @{ $set->{fingers} };

            # Loop over the seen fingers.
            for my $s (@seen) {

                # Skip identical fingers.
                next if $s eq $finger;

                # Set the index of the current seen finger.
                my $sidx = $set->{indexes}{$s};

                # Rule: Lower fingers on higher frets are not allowed.
                #       Higher fingers on lower "
                if (($track->{$s} > $current && $sidx <= $fidx)
                    ||
                    ($track->{$s} < $current && $sidx >= $fidx)
                ) {

                    # Flag the given type of infraction.
                    push @$flag, BACKWARD_INFRACTION;

                    # Skip to the next position unless we are accumulating.
                    last FLAG unless $set->{accumulate};
                }

                # Compute span metrics.
                my $fret_span = abs($current - $track->{$s});
                my $sum = sum_span($sidx, $fidx, @{ $set->{fspan} });

                # Rule: Frets can't be more than the allowed finger span.
                if ($sidx != $fidx && $fret_span > $sum) {

                    # Flag the given type of infraction.
                    push @$flag, SPAN_INFRACTION;

                    # Skip to the next position unless we are accumulating.
                    last FLAG unless $set->{accumulate};
                }
            }
        }

        # Update the previous to the current finger and start again.
        $previous = $current;
    }

    # Return the list of infractions found.
    return @$flag;
}

sub sum_span { # Return the "absolute sum" from a finger span list.

    # Get the list and bounds from the call.
    my ($x, $y, @list) = @_;

    # Convert from finger index to span list position.
    $x--;
    $y--;

    # Restrict the list based on the relative sizes of the bounds.
    my @new = @list[ $x > $y ? ($y .. $x - 1) : ($x .. $y - 1) ];

    # Get the sum of the bounded list.
    my $sum = sum(@new);

    # Return the sum of the span, less one for multi-finger spans.
    return @new > 1 ? $sum - 1 : $sum;
}

__END__

=head1 AUTHOR

Gene Boggs, E<lt>gene.boggs@gmail.comE<gt>

=head1 COPYRIGHT

Copyright 2013 Gene Boggs

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it under
the terms of either: the GNU General Public License as published by the Free
Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut