File Coverage

blib/lib/Music/Bassline/Generator.pm

Criterion	Covered	Total	%
statement	153	165	92.7
branch	53	74	71.6
condition	30	85	35.2
subroutine	24	26	92.3
pod	1	1	100.0
total	261	351	74.3

package Music::Bassline::Generator;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: Generate musical basslines

our $VERSION = '0.0609';

use 5.024;

use Moo;
use strictures 2;
use Data::Dumper::Compact qw(ddc);
use Carp qw(croak);
use List::SomeUtils qw(first_index);
use List::Util qw(any min uniq);
use Music::Chord::Note ();
use Music::Note ();
use Music::Scales qw(get_scale_notes get_scale_MIDI);
use Music::VoiceGen ();
use Set::Array ();
use Try::Tiny qw(try catch);
use namespace::clean;

use constant E1 => 28; # lowest note on a bass guitar in standard tuning

with('Music::PitchNum');


has guitar => (
    is      => 'ro',
    isa     => \&_boolean,
    default => sub { 0 },
);


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


has modal => (
    is      => 'ro',
    isa     => \&_boolean,
    default => sub { 0 },
);


has chord_notes => (
    is      => 'ro',
    isa     => \&_boolean,
    default => sub { 1 },
);


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


has intervals => (
    is      => 'ro',
    isa     => sub { croak 'not an array reference' unless ref $_[0] eq 'ARRAY' },
    default => sub { [qw(-3 -2 -1 1 2 3)] },
);


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


has scale => (
    is      => 'ro',
    isa     => sub { croak 'not a code reference' unless ref $_[0] eq 'CODE' },
    builder => 1,
);

sub _build_scale {
    my ($self) = @_;
    if ($self->modal) {
        return sub {
            my ($chord) = @_;
            my ($chord_note) = _parse_chord($chord);
            my @modes = qw( ionian dorian phrygian lydian mixolydian aeolian locrian );
            my @key_notes = get_scale_notes($self->keycenter, $modes[0]);
            my $position = first_index { $_ eq $chord_note } @key_notes;
            my $scale = $position >= 0 ? $modes[$position] : $modes[0];
            return $scale;
        };
    }
    else {
        return sub { $_[0] =~ /^[A-G][#b]?m/ ? 'minor' : 'major' };
    }
}


has tonic => (
    is      => 'ro',
    isa     => \&_boolean,
    default => sub { 0 },
);


has positions => (
    is => 'ro',
);


has verbose => (
    is      => 'ro',
    isa     => \&_boolean,
    default => sub { 0 },
);

sub _boolean {
    my ($arg) = @_;
    croak 'not a boolean' unless $arg =~ /^[01]$/;
}


sub generate {
    my ($self, $chord, $num, $next_chord) = @_;

    $chord ||= 'C';
    $num   ||= 4;

    if ($chord =~ /^(.+)\//) {
        $chord  = $1;
    }
    my ($chord_note, $flavor) = _parse_chord($chord);

    my $next_chord_note;
    ($next_chord_note) = _parse_chord($next_chord)
        if $next_chord;

    print "CHORD: $chord => $chord_note, $flavor\n" if $self->verbose;
    print "NEXT: $next_chord => $next_chord_note\n" if $self->verbose && $next_chord;

    my $scale = $self->scale->($chord);
    my $next_scale = defined $next_chord ? $self->scale->($next_chord) : '';

    my $cn = Music::Chord::Note->new;

    my @notes = map { $self->pitchnum($_) }
        $cn->chord_with_octave($chord, $self->octave);

    my @pitches;
    if ($self->positions && $scale) {
        my @scale = get_scale_MIDI($chord_note, $self->octave, $scale);
        for my $n (0 .. $#scale) {
            push @pitches, $scale[$n] if grep { $_ == $n } @{ $self->positions->{$scale} };
        }
    }
    elsif ($scale) {
        @pitches = get_scale_MIDI($chord_note, $self->octave, $scale);
    }
    else {
        @pitches = ();
    }

    my @next_pitches = $next_scale ? get_scale_MIDI($next_chord_note, $self->octave, $next_scale) : ();

    # Add unique chord notes to the pitches
    if ($self->chord_notes) {
        print "CHORD NOTES\n" if $self->verbose;
        for my $n (@notes) {
            if (not any { $_ == $n } @pitches) {
                push @pitches, $n;
                if ($self->verbose) {
                    my $x = $self->pitchname($n);
                    print "\tADD: $x\n";
                }
            }
        }
    }
    @pitches = sort { $a <=> $b } @pitches; # Pitches are midi numbers

    # Determine if we should skip certain notes given the chord flavor
    my @tones = get_scale_notes($chord_note, $scale);
    print "\t$scale SCALE: ", ddc(\@tones) if $self->verbose;
    my @fixed;
    for my $p (@pitches) {
        my $n = Music::Note->new($p, 'midinum');
        my $x = $n->format('isobase');
        # Inspect both # & b
        if ($x =~ /#/) {
            $n->en_eq('flat');
        }
        elsif ($x =~ /b/) {
            $n->en_eq('sharp');
        }
        my $y = $n->format('isobase');
        if (($flavor =~ /[#b]5/ && $tones[4] && ($x eq $tones[4] || $y eq $tones[4]))
            ||
            ($flavor =~ /7/ && $flavor !~ /[Mm]7/ && $tones[6] && ($x eq $tones[6] || $y eq $tones[6]))
            ||
            ($flavor =~ /[#b]9/ && $tones[1] && ($x eq $tones[1] || $y eq $tones[1]))
            ||
            ($flavor =~ /dim/ && $tones[2] && ($x eq $tones[2] || $y eq $tones[2]))
            ||
            ($flavor =~ /dim/ && $tones[6] && ($x eq $tones[6] || $y eq $tones[6]))
            ||
            ($flavor =~ /aug/ && $tones[6] && ($x eq $tones[6] || $y eq $tones[6]))
        ) {
            print "\tDROP: $x\n" if $self->verbose;
            next;
        }
        push @fixed, $p;
    }

    if ($self->guitar) {
        @fixed = sort { $a <=> $b } map { $_ < E1 ? $_ + 12 : $_ } @fixed;
    }

    if ($self->wrap) {
        my $n = Music::Note->new($self->wrap, 'ISO');
        $n = $n->format('midinum');
        @fixed = sort { $a <=> $b } map { $_ > $n ? $_ - 12 : $_ } @fixed;
    }

    # Make sure there are no duplicate pitches
    @fixed = uniq @fixed;
    $self->_verbose_notes('NOTES', @fixed) if $self->verbose;

    my @chosen;
    if (@fixed > 1) {
        try {
            my $voice = Music::VoiceGen->new(
                pitches   => \@fixed,
                intervals => $self->intervals,
            );

            # Try to start the phrase in the middle of the scale
            $voice->context($fixed[int @fixed / 2]);

            # Get a passage of quasi-random pitches
            @chosen = map { $voice->rand } 1 .. $num;
        }
        catch {
            # warn "Can't instantiate Music::VoiceGen: $_\n";
            @chosen = ($fixed[0]) x $num;
        };
    }
    else {
        @chosen = ($fixed[0]) x $num;
    }

    # Choose the right note given the scale if the tonic is set
    if ($self->tonic) {
        $chosen[0] = $fixed[0];
    }

    # Intersect with the next-chord pitches
    if ($next_chord) {
        my $A1 = Set::Array->new(@fixed);
        my $A2 = Set::Array->new(@next_pitches);
        my @intersect = @{ $A1->intersection($A2) };
        $self->_verbose_notes('INTERSECT', @intersect) if $self->verbose;
        # Anticipate the next chord
        if (@intersect) {
            if (my $closest = _closest($chosen[-2] || $chosen[-1], \@intersect)) {
                $chosen[-1] = $closest;
            }
        }
    }

    # Show them what they've won, Bob!
    $self->_verbose_notes('CHOSEN', @chosen) if $self->verbose;

    return \@chosen;
}

sub _parse_chord {
  my ($chord) = @_;
    my $chord_note;
    my $flavor;
    if ($chord =~ /^([A-G][#b]?)(.*)$/) {
        $chord_note = $1;
        $flavor = $2;
    }
    return $chord_note, $flavor;
}

# Show a phrase of midinums as ISO notes
sub _verbose_notes {
    my ($self, $title, @notes) = @_;
    @notes = map { $self->pitchname($_) } @notes;
    print "\t$title: ", ddc(\@notes);
}

# Find the closest absolute difference to the key, in the list
sub _closest {
    my ($key, $list) = @_;
    # Remove the key from the list
    $list = [ grep { $_ != $key } @$list ];
    return undef unless @$list;
    # Find the absolute difference
    my @diff = map { abs($key - $_) } @$list;
    my $min = min @diff;
    my @closest;
    # Get all the minimum elements of list
    for my $n (0 .. $#diff) {
        next if $diff[$n] != $min;
        push @closest, $list->[$n];
    }
    # Return a random minimum
    return $closest[int rand @closest];
}

1;

__END__