File Coverage

blib/lib/Music/Chord/Progression/NRO.pm

Criterion	Covered	Total	%
statement	97	99	97.9
branch	18	26	69.2
condition			n/a
subroutine	16	17	94.1
pod	2	2	100.0
total	133	144	92.3

package Music::Chord::Progression::NRO;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: Generate Neo-Riemann chord progressions

our $VERSION = '0.0400';

use Moo;
use strictures 2;
use Algorithm::Combinatorics qw(variations);
use Carp qw(croak);
use Data::Dumper::Compact qw(ddc);
use Music::NeoRiemannianTonnetz ();
use Music::Chord::Note ();
use Music::Chord::Namer qw(chordname);
use namespace::clean;

with 'Music::PitchNum';


has base_note => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid note" unless $_[0] =~ /^[A-G][#b]?$/ },
    default => sub { 'C' },
);


has base_octave => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid octave" unless $_[0] =~ /^[1-8]$/ },
    default => sub { 4 },
);


has base_scale => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid scale" unless $_[0] =~ /^(?:major|minor)$/ },
    default => sub { 'major' },
);


has base_chord => (
    is => 'lazy',
);

sub _build_base_chord {
    my ($self) = @_;
    my $cn = Music::Chord::Note->new;
    my $quality = $self->base_scale eq 'major' ? '' : 'm';
    my @chord = $cn->chord_with_octave($self->base_note . $quality, $self->base_octave);
    return \@chord;
}


has format => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid format" unless $_[0] =~ /^(?:ISO|midinum)$/ },
    default => sub { 'ISO' },
);


has max => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid maximum" unless $_[0] =~ /^[1-9]\d*$/ },
    default => sub { 4 },
);


has transform => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid transform" unless ref $_[0] eq 'ARRAY' || $_[0] =~ /^[1-9]\d*$/ },
    default => sub { 4 },
);


has verbose => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a boolean" unless $_[0] =~ /^[01]$/ },
    default => sub { 0 },
);


has nrt => (
    is => 'lazy',
);

sub _build_nrt {
    return Music::NeoRiemannianTonnetz->new;
}


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

    my ($pitches, $notes) = $self->_get_pitches;

    my @transform = $self->_build_transform;

    $self->_initial_conditions(@transform) if $self->verbose;

    my @generated;
    my $i = 0;

    for my $token (@transform) {
        $i++;

        my $transformed = $self->_build_chord($token, $pitches, $notes);

        my @notes = map { $self->pitchname($_) } @$transformed;
        my @base = map { s/^([A-G][#b]?)\d/$1/r } @notes; # for chord-name

        push @generated, $self->format eq 'ISO' ? \@notes : $transformed;

        printf "%d. %s: %s   %s   %s\n",
            $i, $token,
            ddc($transformed), ddc(\@notes),
            scalar chordname(@base)
            if $self->verbose;

        $notes = $transformed;
    }

    return \@generated;
}


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

    my ($pitches, $notes) = $self->_get_pitches;

    my @transform = $self->_build_transform;

    $self->_initial_conditions(@transform) if $self->verbose;

    my @generated;
    my $posn = 0;

    for my $i (1 .. $self->max) {
        my $token = $transform[ $posn % @transform ];

        my $transformed = $self->_build_chord($token, $pitches, $notes);

        my @notes = map { $self->pitchname($_) } @$transformed;
        my @base = map { s/^([A-G][#b]?)\d/$1/r } @notes; # for chord-name

        push @generated, $self->format eq 'ISO' ? \@notes : $transformed;

        printf "%d. %s (%d): %s   %s   %s\n",
            $i, $token, $posn % @transform,
            ddc($transformed), ddc(\@notes),
            scalar chordname(@base)
            if $self->verbose;

        $notes = $transformed;

        $posn = int rand 2 ? $posn + 1 : $posn - 1;
    }

    return \@generated;
}

sub _get_pitches {
    my ($self) = @_;
    my @pitches = map { $self->pitchnum($_) } @{ $self->base_chord };
    return \@pitches, [ @pitches ];
}

sub _initial_conditions {
    my ($self, @transform) = @_;
    printf "Initial: %s%s %s\nTransforms: %s\n",
        $self->base_note, $self->base_octave, $self->base_scale,
        join(',', @transform);
}

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

    my @transform;

    if (ref $self->transform eq 'ARRAY') {
        @transform = @{ $self->transform };
    }
    elsif ($self->transform =~ /^\d+$/) {
        my @alphabet = qw(P R L);
        my @nro = @alphabet;

        my $iter = variations(\@alphabet, 2);
        while (my $v = $iter->next) {
            push @nro, join('', @$v);
        }
        $iter = variations(\@alphabet, 3);
        while (my $v = $iter->next) {
            push @nro, join('', @$v);
        }

        @transform = ('I', map { $nro[ int rand @nro ] } 1 .. $self->transform - 1);
    }

    return @transform;
}

sub _build_chord {
    my ($self, $token, $pitches, $notes) = @_;

    my $chord;

    if ($token =~ /^I$/) {
        $chord = $pitches; # no transformation
    }
    else {
        my $task = $self->nrt->taskify_tokens($token) if length $token > 1;
        my $tx = defined $task ? $task : $token;

        $chord = $self->nrt->transform($tx, $notes);
    }

    return $chord;
}

1;

__END__