File Coverage

blib/lib/Music/Chord/Progression.pm

Criterion	Covered	Total	%
statement	104	128	81.2
branch	38	72	52.7
condition	12	26	46.1
subroutine	14	15	93.3
pod	2	2	100.0
total	170	243	69.9

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

# ABSTRACT: Create network transition chord progressions

our $VERSION = '0.0607';

use Moo;
use strictures 2;

use Carp qw(croak);
use Data::Dumper::Compact qw(ddc);
use Graph::Directed ();
use Music::Chord::Note ();
use Music::Scales qw(get_scale_notes);

use namespace::clean;


has max => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid integer" unless $_[0] =~ /^\d+$/ },
    default => sub { 8 },
);


has net => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a hashref" unless ref $_[0] eq 'HASH' },
    default => sub {
      { 1 => [qw( 1 2 3 4 5 6 )],
        2 => [qw( 3 4 5 )],
        3 => [qw( 1 2 4 6 )],
        4 => [qw( 1 3 5 6 )],
        5 => [qw( 1 4 6 )],
        6 => [qw( 1 2 4 5 )],
        7 => [] }
    },
);


has chord_map => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not an arrayref" unless ref $_[0] eq 'ARRAY' },
    default => sub { ['', 'm', 'm', '', '', 'm', 'dim'] },
);


has scale_name => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid string" if ref $_[0] },
    default => sub { 'major' },
);


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


has scale => (
    is        => 'lazy',
    init_args => undef,
);

sub _build_scale {
    my ($self) = @_;
    my @scale = get_scale_notes($self->scale_note, $self->scale_name);
    my %equiv = (
        'C#'  => 'Db',
        'D#'  => 'Eb',
        'E#'  => 'F',
        'F#'  => 'Gb',
        'G#'  => 'Ab',
        'A#'  => 'Bb',
        'B#'  => 'C',
        'Cb'  => 'B',
        'Dbb' => 'C',
        'Ebb' => 'D',
        'Fb'  => 'E',
        'Gbb' => 'F',
        'Abb' => 'G',
        'Bbb' => 'A',
    );
    for (@scale) {
        $_ = $equiv{$_} if exists $equiv{$_};
    }
    print ucfirst($self->scale_name), ' scale: ', ddc(\@scale) if $self->verbose;
    return \@scale;
}


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


has tonic => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid setting" unless $_[0] =~ /^-?[01]$/ },
    default => sub { 1 },
);


has resolve => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid setting" unless $_[0] =~ /^-?[01]$/ },
    default => sub { 1 },
);


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


has sub_cond => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid coderef" unless ref($_[0]) eq 'CODE' },
    default => sub { return sub { int rand 4 == 0 } },
);


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


has graph => (
    is        => 'lazy',
    init_args => undef,
);

sub _build_graph {
  my ($self) = @_;
    my $g = Graph::Directed->new;
    for my $posn (keys %{ $self->net }) {
        for my $p (@{ $self->net->{$posn} }) {
            $g->add_edge($posn, $p);
        }
    }
    return $g;
}


has phrase => (
    is        => 'rw',
    init_args => undef,
);


has chords => (
    is        => 'rw',
    init_args => undef,
);



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


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

    croak 'chord_map length must equal number of net keys'
        unless @{ $self->chord_map } == keys %{ $self->net };

    print 'Graph: ' . $self->graph, "\n" if $self->verbose;

    # Create a random progression
    my @progression;
    my $v; # Vertex
    for my $n (1 .. $self->max) {
        $v = $self->_next_successor($n, $v);
        push @progression, $v;
    }
    print 'Progression: ', ddc(\@progression) if $self->verbose;

    my @chord_map = @{ $self->chord_map };

    if ($self->substitute) {
        my $i = 0;
        for my $chord (@chord_map) {
            my $substitute = $self->sub_cond->() ? $self->substitution($chord) : $chord;
            if ($substitute eq $chord && $i < @progression && $self->sub_cond->()) {
                $progression[$i] .= 't'; # Indicate that we should tritone substitute
            }
            $chord = $substitute;
            $i++;
        }
    }
    print 'Chord map: ', ddc(\@chord_map) if $self->verbose;

    my @phrase = map { $self->_tt_sub(\@chord_map, $_) } @progression;
    $self->phrase(\@phrase);
    print 'Phrase: ', ddc($self->phrase) if $self->verbose;

    # Add octaves to the chords
    my $mcn = Music::Chord::Note->new;
    my @chords;
    for my $chord (@phrase) {
        my @chord = $mcn->chord_with_octave($chord, $self->octave);
        push @chords, \@chord;
    }

    if ($self->flat) {
        my %equiv = (
            'C#' => 'Db',
            'D#' => 'Eb',
            'E#' => 'F',
            'F#' => 'Gb',
            'G#' => 'Ab',
            'A#' => 'Bb',
            'B#' => 'C',
        );
        for my $chord (@chords) {
            for my $note (@$chord) {
                $note =~ s/^([A-G]#)(\d+)$/$equiv{$1}$2/ if $note =~ /#/;
            }
        }
    }

    $self->chords(\@chords);
    print 'Chords: ', ddc($self->chords) if $self->verbose;

    return \@chords;
}

sub _next_successor {
    my ($self, $n, $v) = @_;

    $v //= 1;

    my $s;

    if ($n == 1) {
        if ($self->tonic == 0) {
            $s = $self->graph->random_successor(1);
        }
        elsif ($self->tonic == 1) {
            $s = 1;
        }
        else {
            $s = $self->_full_keys;
        }
    }
    elsif ($n == $self->max) {
        if ($self->resolve == 0) {
            $s = $self->graph->random_successor($v) || $self->_full_keys;
        }
        elsif ($self->resolve == 1) {
            $s = 1;
        }
        else {
            $s = $self->_full_keys;
        }
    }
    else {
        $s = $self->graph->random_successor($v);
    }

    return $s;
}

sub _full_keys {
    my ($self) = @_;
    my @keys = grep { keys @{ $self->net->{$_} } > 0 } keys %{ $self->net };
    return $keys[int rand @keys];
}

sub _tt_sub {
    my ($self, $chord_map, $n) = @_;

    my $note;

    if ($n =~ /t/) {
        my @fnotes = get_scale_notes('C', 'chromatic', 0, 'b');
        my @snotes = get_scale_notes('C', 'chromatic');
        my %ftritone = map { $fnotes[$_] => $fnotes[($_ + 6) % @fnotes] } 0 .. $#fnotes;
        my %stritone = map { $snotes[$_] => $snotes[($_ + 6) % @snotes] } 0 .. $#snotes;

        $n =~ s/t//;
        $note = $ftritone{ $self->scale->[$n - 1] } || $stritone{ $self->scale->[$n - 1] };
        print 'Tritone: ', $self->scale->[$n - 1], " => $note\n" if $self->verbose;
    }
    else {
        $note = $self->scale->[$n - 1];
    }

    $note .= $chord_map->[$n - 1];
    print "Note: $note\n" if $self->verbose;

    return $note;
}


sub substitution {
    my ($self, $chord) = @_;

    my $substitute = $chord;

    if ($chord eq '' || $chord eq 'm') {
        my $roll = int rand 2;
        $substitute = $roll == 0 ? $chord . 'M7' : $chord . 7;
    }
    elsif ($chord eq 'dim' || $chord eq 'aug') {
        $substitute = $chord . 7;
    }
    elsif ($chord eq '-5' || $chord eq '-9') {
        $substitute = "7($chord)";
    }
    elsif ($chord eq 'M7') {
        my $roll = int rand 3;
        $substitute = $roll == 0 ? 'M9' : $roll == 1 ? 'M11' : 'M13';
    }
    elsif ($chord eq '7') {
        my $roll = int rand 3;
        $substitute = $roll == 0 ? '9' : $roll == 1 ? '11' : '13';
    }
    elsif ($chord eq 'm7') {
        my $roll = int rand 3;
        $substitute = $roll == 0 ? 'm9' : $roll == 1 ? 'm11' : 'm13';
    }

    print qq|Substitute: "$chord" => "$substitute"\n| if $self->verbose && $substitute ne $chord;

    return $substitute;
}

1;

__END__