File Coverage

blib/lib/Music/Dice.pm

Criterion	Covered	Total	%
statement	233	244	95.4
branch	9	14	64.2
condition	10	15	66.6
subroutine	79	80	98.7
pod	33	34	97.0
total	364	387	94.0

package Music::Dice;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: Define and roll musical dice

our $VERSION = '0.0206';

use Moo;
use strictures 2;
use Carp qw(croak);
use Games::Dice::Advanced ();
use List::Util::WeightedChoice qw(choose_weighted);
use MIDI::Util qw(midi_dump);
use Music::Duration::Partition ();
use Music::Scales qw(get_scale_notes get_scale_nums);
use Music::ToRoman ();
use Types::Standard qw(ArrayRef Int Str);
use namespace::clean;


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


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


has scale_name => (
    is      => 'ro',
    isa     => sub { croak "$_[0] is not a valid scale name" unless $_[0] =~ /^[a-z]+$/ },
    default => sub { 'chromatic' },
);


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


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


has phrase_pool => (
    is => 'rw',
);


has phrase_weights => (
    is => 'rw',
);


has phrase_groups => (
    is => 'rw',
);


has octaves => (
    is      => 'ro',
    isa     => ArrayRef[Int],
    default => sub { [ 2 .. 6 ] },
);


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

sub _build_notes {
    my ($self) = @_;
    my $keypref = $self->flats ? 'b' : '#';
    my @notes = get_scale_notes($self->scale_note, $self->scale_name, 0, $keypref);
    return \@notes;
}


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

sub _build_intervals {
    my ($self) = @_;
    my @nums = get_scale_nums($self->scale_name);
    my @intervals = map { $nums[$_] - $nums[$_ - 1] } 1 .. $#nums;
    push @intervals, $self->semitones - $nums[-1];
    if ($self->identity) {
        unshift @intervals, 0;
        push @intervals, $self->semitones;
    }
    return \@intervals;
}


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


has chord_triads => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(
            major
            minor
            diminished
            augmented
            custom
        )],
    },
);


has chord_triad_weights => (
    is      => 'ro',
    isa     => ArrayRef[Int],
    default => sub { [qw(2 2 1 1 1)] },
);


has chord_qualities_major => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(
            add2 sus2
            add4 sus4
            -5
            -6 6
            M7 7
            add9
        )],
    },
);


has chord_qualities_major_7 => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        no warnings 'qw';
        [qw(
            7sus4 7b5 7#5
            69
            M79
            7b9 9 7#9
            7(b9,13) 7(9,13)
            9b5
            M11 11 7#11
            M13 13 7#13
        )],
    },
);


has chord_qualities_minor => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(
            madd4
            m6
            m7
        )],
    },
);


has chord_qualities_minor_7 => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        no warnings 'qw';
        [qw(
            m7b5 m7#5
            m9
            m7(9,11)
            m11
            m13
        )],
    },
);


has chord_qualities_diminished => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(
            dim6
            dim7
        )],
    },
);


has chord_qualities_augmented => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(
            augM7 aug7
        )],
    },
);


has chord_qualities_augmented_7 => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        no warnings 'qw';
        [qw(
            aug9
        )],
    },
);


has modes => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(
            ionian
            dorian
            phrygian
            lydian
            mixolydian
            aeolian
            locrian
        )],
    },
);


has ionian_mask => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(I ii iii IV V vi viio)],
    },
);


has dorian_mask => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(i ii III IV v vio VII)],
    },
);


has phrygian_mask => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(i II III iv vo VI vii)],
    },
);


has lydian_mask => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(I II iii ivo V vi vii)],
    },
);


has mixolydian_mask => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(I ii iiio IV v vi VII)],
    },
);


has aeolian_mask => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(i iio III iv v VI VII)],
    },
);


has locrian_mask => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub {
        [qw(io II iii iv V VI vii)],
    },
);


has tonnetzen => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub { [qw(P R L N S H)],
    },
);


has tonnetzen_7 => (
    is      => 'ro',
    isa     => ArrayRef[Str],
    default => sub { [qw(S23 S32 S34 S43 S56 S65 C32 C34 C65)],
    },
);


has rhythmic_phrase_constraints => (
    is      => 'ro',
    isa     => ArrayRef[Int],
    default => sub { [ 3, 4, 5 ] },
);


sub BUILD {
    my ($self, $args) = @_;
    if (exists $args->{phrase_pool} && !ref $args->{phrase_pool} && $args->{phrase_pool} eq 'all') {
        $self->phrase_pool([ sort keys %{ midi_dump('length') } ]);
    }
    else {
        $self->phrase_pool([qw(wn dhn hn dqn qn den en)]);
    }
    $self->phrase_weights([ (1) x @{ $self->phrase_pool } ]);
    $self->phrase_groups([ (1) x @{ $self->phrase_pool } ]);
}


sub octave {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->octaves, [ (1) x @{ $self->octaves } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub note {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->notes, [ (1) x @{ $self->notes } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub interval {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->intervals, [ (1) x @{ $self->intervals } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub note_chromatic {
    my ($self) = @_;
    my $d = sub {
        my $keypref = $self->flats ? 'b' : '#';
        my $choices = [ get_scale_notes($self->scale_note, 'chromatic', 0, $keypref) ];
        return choose_weighted($choices, [ (1) x @$choices ])
    };
    return Games::Dice::Advanced->new($d);
}


sub interval_chromatic {
    my ($self) = @_;
    my $d = sub {
        my $choices = [ (1) x $self->semitones ];
        return choose_weighted($choices, $choices);
    };
    return Games::Dice::Advanced->new($d);
}


sub note_major {
    my ($self) = @_;
    my $d = sub {
        my $keypref = $self->flats ? 'b' : '#';
        my $choices = [ get_scale_notes($self->scale_note, 'major', 0, $keypref) ];
        return choose_weighted($choices, [ (1) x @$choices ])
    };
    return Games::Dice::Advanced->new($d);
}


sub interval_major {
    my ($self) = @_;
    my $d = sub {
        my $choices = [qw(2 2 1 2 2 2 1)];
        return choose_weighted($choices, [ (1) x @$choices ]);
    };
    return Games::Dice::Advanced->new($d);
}


sub note_minor {
    my ($self) = @_;
    my $d = sub {
        my $keypref = $self->flats ? 'b' : '#';
        my $choices = [ get_scale_notes($self->scale_note, 'minor', 0, $keypref) ];
        return choose_weighted($choices, [ (1) x @$choices ])
    };
    return Games::Dice::Advanced->new($d);
}


sub interval_minor {
    my ($self) = @_;
    my $d = sub {
        my $choices = [qw(2 1 2 2 1 2 2)];
        return choose_weighted($choices, [ (1) x @$choices ]);
    };
    return Games::Dice::Advanced->new($d);
}


sub chord_triad {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->chord_triads, $self->chord_triad_weights)
    };
    return Games::Dice::Advanced->new($d);
}


sub chord_quality_major {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->chord_qualities_major, [ (1) x @{ $self->chord_qualities_major } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub chord_quality_major_7 {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->chord_qualities_major_7, [ (1) x @{ $self->chord_qualities_major_7 } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub chord_quality_minor {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->chord_qualities_minor, [ (1) x @{ $self->chord_qualities_minor } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub chord_quality_minor_7 {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->chord_qualities_minor_7, [ (1) x @{ $self->chord_qualities_minor_7 } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub chord_quality_diminished {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->chord_qualities_diminished, [ (1) x @{ $self->chord_qualities_diminished } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub chord_quality_augmented {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->chord_qualities_augmented, [ (1) x @{ $self->chord_qualities_augmented } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub chord_quality_augmented_7 {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->chord_qualities_augmented_7, [ (1) x @{ $self->chord_qualities_augmented_7 } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub chord_quality_triad_roll {
    my ($self, $note, $triad) = @_;
    my $quality = '';
    if ($triad eq 'custom') {
        my @custom;
        my $item = $self->unique_item([ $note ]);
        push @custom, $item;
        push @custom, $self->unique_item([ $note, $item ]);
        $quality = " @custom";
    }
    else {
        my $method = 'chord_quality_' . $triad;
        $quality = $self->$method->roll;
    }
    return $quality;
}


sub mode {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->modes, [ (1) x @{ $self->modes } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub ionian {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->ionian_mask, [ (1) x @{ $self->ionian_mask } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub dorian {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->dorian_mask, [ (1) x @{ $self->dorian_mask } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub phrygian {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->phrygian_mask, [ (1) x @{ $self->phrygian_mask } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub lydian {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->lydian_mask, [ (1) x @{ $self->lydian_mask } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub mixolydian {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->mixolydian_mask, [ (1) x @{ $self->mixolydian_mask } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub aeolian {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->aeolian_mask, [ (1) x @{ $self->aeolian_mask } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub locrian {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->locrian_mask, [ (1) x @{ $self->locrian_mask } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub mode_degree_triad_roll {
    my ($self, $mode) = @_;
    my $roman = $self->$mode->roll;
    my $mtr = Music::ToRoman->new(scale_name => $mode);
    my ($degree, $triad) = $mtr->get_scale_degree($roman);
    return $degree, $triad;
}


sub tonnetz {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->tonnetzen, [ (1) x @{ $self->tonnetzen } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub tonnetz_7 {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->tonnetzen_7, [ (1) x @{ $self->tonnetzen_7 } ])
    };
    return Games::Dice::Advanced->new($d);
}

## RHYTHMS ##


sub rhythmic_value {
    my ($self) = @_;
    my $d = sub {
        return choose_weighted($self->phrase_pool, [ (1) x @{ $self->phrase_weights } ])
    };
    return Games::Dice::Advanced->new($d);
}


sub rhythmic_phrase {
    my ($self) = @_;
    my $mdp = Music::Duration::Partition->new(
        size    => $self->beats,
        pool    => $self->phrase_pool,
        weights => $self->phrase_weights,
        groups  => $self->phrase_groups ,
    );
    my $d = sub {
        return $mdp->motif;
    };
    return Games::Dice::Advanced->new($d);
}


sub rhythmic_phrase_constrained {
    my ($self) = @_;
    my $mdp = Music::Duration::Partition->new(
        size    => $self->beats,
        pool    => $self->phrase_pool,
        weights => $self->phrase_weights,
        groups  => $self->phrase_groups ,
    );
    my $d = sub {
        my $motif;
        while (!$motif || !grep { $_ == @$motif } @{ $self->rhythmic_phrase_constraints }) {
            $motif = $mdp->motif;
        }
        return $motif;
    };
    return Games::Dice::Advanced->new($d);
}

## UTILITY ##


sub unique_item {
    my ($self, $excludes, $items) = @_;
    $items ||= $self->notes;
    my $item = '';
    while (!$item || grep { $_ eq $item } @$excludes) {
        $item = $items->[ int rand @$items ];
    }
    return $item;
}

1;

__END__