File Coverage

blib/lib/MIDI/Praxis/Variation.pm

Criterion	Covered	Total	%
statement	103	104	99.0
branch	35	38	92.1
condition	18	24	75.0
subroutine	20	20	100.0
pod	16	16	100.0
total	192	202	95.0

package MIDI::Praxis::Variation;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: Variation techniques used in music composition

use strict;
use warnings;

our $VERSION = '0.0607';

use MIDI::Simple ();

use Exporter 'import';

our @EXPORT = qw(
    augmentation
    diminution
    dur
    inversion
    note_name_to_number
    note2num
    ntup
    original
    notes2nums
    raugmentation
    rdiminution
    retrograde
    retrograde_inversion
    transposition
    tye
    tie_durations
);
our %EXPORT_TAGS = (all => [qw(
    augmentation
    diminution
    dur
    inversion
    note_name_to_number
    note2num
    ntup
    original
    notes2nums
    raugmentation
    rdiminution
    retrograde
    retrograde_inversion
    transposition
    tye
    tie_durations
)] );


sub note2num { note_name_to_number(@_) }

sub note_name_to_number {
    my ($in) = @_;

    return () unless $in;

    my $note_number = -1;

    if ($in =~ /^([A-Za-z]+)(\d+)/s) {
        $note_number = $MIDI::Simple::Note{$1} + $2 * 12
          if exists $MIDI::Simple::Note{$1};
    }

    return $note_number;
}



sub notes2nums { original(@_) }

sub original {
    my @notes = @_;

    return () unless @notes;

    my @ret = map { note_name_to_number($_) } @notes;

    return @ret;
}



sub retrograde {
    my @notes =  @_;

    my @ret = ();

    return () unless @notes;

    @ret = reverse original(@notes);

    return @ret;
}



sub transposition {
    my ($delta, @notes) = @_;

    return () unless defined $delta && @notes;

    my @ret = ();

    if ($notes[0] =~ /[A-G]/) {
        @ret = original(@notes);
    }
    else {
        @ret = @notes;
    }

    for (@ret) {
        $_ += $delta;
    }

    return @ret;
}



sub inversion {
    my ($axis, @notes) = @_;

    return () unless $axis && @notes;

    my $center = note_name_to_number($axis);
    my $first  = note_name_to_number($notes[0]);
    my $delta  = $center - $first;

    my @transposed = transposition($delta, @notes);

    # XXX WTF?
    my @ret = map { 2 * $center - $_ } @transposed;

    return @ret;
}



sub retrograde_inversion {
    my ($axis, @notes) = @_;

    return () unless $axis && @notes;

    my @rev_notes = ();
    my @ret = ();

    @rev_notes = reverse @notes;

    @ret = inversion($axis, @rev_notes);

    return @ret;
}



sub dur {
    my ($tempo, $arg) = (MIDI::Simple::Tempo, @_);

    return () unless $arg;

    my $dur = 0;

    if ($arg =~ /^d(\d+)$/) {
        $dur = 0 + $1;
    }
    elsif (exists $MIDI::Simple::Length{$arg}) {   # length spec
        $dur = 0 + ($tempo * $MIDI::Simple::Length{$arg});
    }

    return $dur;
}



sub tie_durations { tye(@_) }

sub tye {
    my @dur_or_len = @_;

    return () unless @dur_or_len;

    my $sum = 0;

    for my $dura (@dur_or_len) {
        $sum += dur($dura);
    }

    return $sum;
}



sub raugmentation {
    my ($ratio, @dur_or_len) = @_;

    return () unless $ratio && 1 < $ratio && @dur_or_len;

    my $sum = 0;

    for my $dura (@dur_or_len) {
        $sum += dur($dura) * $ratio;
    }

    return $sum;
}



sub rdiminution {
    my ($ratio, @dur_or_len) = @_;

    return () unless $ratio && 1 < $ratio && @dur_or_len;

    my $sum = 0;

    for my $dura (@dur_or_len) {
        $sum += dur($dura) / $ratio;
    }

    return sprintf '%.0f', $sum;
}



sub augmentation {
    my @dur_or_len = @_;

    return () unless @dur_or_len;

    my @ret = ();

    for my $dura (@dur_or_len) {
        my $elem = 'd';
        $elem .= raugmentation(2, $dura);
        push @ret, $elem;
    }

    return @ret;
}



sub diminution {
    my @dur_or_len = @_;

    return () unless @dur_or_len;

    my @ret = ();

    for my $dura (@dur_or_len) {
        my $elem = 'd';
        $elem .= rdiminution(2, $dura);
        push @ret, $elem;
    }

    return @ret;
}



sub ntup {
    my ($n, @notes) = @_;

    return () unless defined $n && @notes;

    my @ret = ();

    if (@notes >= $n) {
        for my $index (0 .. @notes - $n) {
            push @ret, @notes[$index .. $index + $n - 1];
        }
    }

    return @ret;
}


1;

__END__