File Coverage

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

Criterion	Covered	Total	%
statement	131	134	97.7
branch	26	36	72.2
condition	3	3	100.0
subroutine	19	20	95.0
pod	2	2	100.0
total	181	195	92.8

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

# ABSTRACT: Generate transformed chord progressions

our $VERSION = '0.0302';

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 Music::MelodicDevice::Transposition ();
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 chord_quality => (
    is      => 'ro',
    default => sub { '' },
);


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

sub _build_base_chord {
    my ($self) = @_;
    my $cn = Music::Chord::Note->new;
    my @chord = $cn->chord_with_octave(
        $self->base_note . $self->chord_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 { 'midinum' },
);


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


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


has allowed => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not valid" unless ref $_[0] eq 'ARRAY' },
    default => sub { [qw(T N)] },
);


has transforms => (
    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;
}

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

sub _build__mdt {
    return Music::MelodicDevice::Transposition->new;
}


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

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

    my @transforms = $self->_build_transform;

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

    my @chords;
    my @generated;
    my $i = 0;

    for my $token (@transforms) {
        $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;

        my $chord = _sanitize_chordname(@base);
        push @chords, $chord;

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

        $notes = $transformed;
    }

    return \@generated, \@transforms, \@chords;
}


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

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

    my @transforms = $self->_build_transform;

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

    my @chords;
    my @generated;
    my $posn = 0;

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

        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;

        my $chord = _sanitize_chordname(@base);
        push @chords, $chord;

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

        $notes = $transformed;

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

    return \@generated, \@transforms, \@chords;
}

sub _sanitize_chordname {
    my (@notes) = @_;

    my $chord = chordname(@notes);

    # fix mangled/unknown chordnames
    $chord =~ s/\s+//;
    $chord =~ s/o/dim/;
    $chord =~ s/maj/M/;
    $chord =~ s/sus7/7sus4/;
    $chord =~ s/7adda5/7(#5)/;
    $chord =~ s/7addb2/7(b9,13)/;
    $chord =~ s/9add13/7(9,13)/;
    $chord =~ s/7addm10/7(#9)/;
    $chord = $1 . $2 if $chord =~ /^(.+)\/(\d+)$/;
    # ...and there are probably more to come...

    return $chord;
}

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

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

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

    my @t; # the transformations to return

    if (ref $self->transforms eq 'ARRAY') {
        @t = @{ $self->transforms };
    }
    elsif ($self->transforms =~ /^\d+$/) {
        my @transforms = qw(O I);

        if (grep { $_ eq 'T' } @{ $self->allowed }) {
            push @transforms, (map { 'T' . $_ } 1 .. $self->semitones);  # positive
            push @transforms, (map { 'T-' . $_ } 1 .. $self->semitones); # negative
        }
        if (grep { $_ eq 'N' } @{ $self->allowed }) {
            if ($self->chord_quality eq 7) {
                push @transforms, qw(
                  S23 S32 S34 S43 S56 S65
                  C32     C34         C65
                );
            }
            else {
                my @alphabet = qw(P R L);
                push @transforms, @alphabet;

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

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

        @t = map { $transforms[ int rand @transforms ] }
            1 .. $self->transforms;
    }

    return @t;
}

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

    my $chord;

    if ($token =~ /^O$/) {
        $chord = $pitches; # return to the original chord
    }
    elsif ($token =~ /^I$/) {
        $chord = $notes; # no transformation
    }
    elsif ($token =~ /^T(-?\d+)$/) {
        my $semitones = $1;
        $chord = $self->_mdt->transpose($semitones, $notes);
    }
    else {
        my $task = $self->_nrt->taskify_tokens($token)
            if length $token > 1 && $token !~ /\d/;
        my $op = defined $task ? $task : $token;

        $chord = $self->_nrt->transform($op, $notes);
    }

    return $chord;
}

1;

__END__