File Coverage

blib/lib/Music/Duration/Partition.pm

Criterion	Covered	Total	%
statement	79	86	91.8
branch	14	20	70.0
condition	2	3	66.6
subroutine	17	18	94.4
pod	3	3	100.0
total	115	130	88.4

package Music::Duration::Partition;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: Partition a musical duration into rhythmic phrases

our $VERSION = '0.0814';

use Moo;
use strictures 2;
use MIDI::Simple ();
use Math::Random::Discrete ();
use List::Util qw(min);
use namespace::clean;

use constant TICKS => 96;


has durations => (
    is      => 'ro',
    default => sub { return \%MIDI::Simple::Length },
);


has size => (
    is      => 'ro',
    default => sub { return 4 },
);


has pool => (
    is      => 'ro',
    isa     => sub { die 'Empty pool not allowed' unless ref( $_[0] ) eq 'ARRAY' && @{ $_[0] } > 0 },
    default => sub { return [ keys %MIDI::Simple::Length ] },
);

has _min_size => (
    is      => 'ro',
    builder => 1,
    lazy    => 1,
);

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

    my @sizes = map { $self->_duration($_) } @{ $self->pool };

    return min(@sizes);
}

has _mrd => (
    is      => 'ro',
    builder => 1,
    lazy    => 1,
);

sub _build__mrd {
    my ($self) = @_;
    die 'Sizes of weights and pool not equal'
        unless @{ $self->weights } == @{ $self->pool };
    return Math::Random::Discrete->new($self->weights, $self->pool);
}


has pool_select => (
    is      => 'rw',
    builder => 1,
    lazy    => 1,
);

sub _build_pool_select {
    my ($self) = @_;
    return sub { return $self->_mrd->rand };
};


has weights => (
    is      => 'ro',
    builder => 1,
    lazy    => 1,
);

sub _build_weights {
    my ($self) = @_;
    # Equal probability for all pool members
    return [ (1) x @{ $self->pool } ];
}


has groups => (
    is      => 'ro',
    builder => 1,
    lazy    => 1,
);

sub _build_groups {
    my ($self) = @_;
    return [ (0) x @{ $self->pool } ];
}

has _pool_group => (
    is      => 'ro',
    builder => 1,
    lazy    => 1,
);

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

    my %pool_group;
    for my $i (0 .. @{ $self->pool } - 1) {
        $pool_group{ $self->pool->[$i] } = $self->groups->[$i];
    }

    return \%pool_group;
}


has remainder => (
    is      => 'ro',
    default => sub { return 1 },
);


has verbose => (
    is      => 'ro',
    default => sub { return 0 },
);


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

    my $motif = [];

    my $format = '%.4f';

    my $sum = 0;
    my $group_num = 0;
    my $group_name = '';

    while ( $sum < $self->size ) {
        my $name = $self->pool_select->($self); # Chooses a note duration

        # Compute grouping
        if ($group_num) {
            $group_num--;
            $name = $group_name;
        }
        else {
            if ($self->_pool_group->{$name}) {
                $group_num = $self->_pool_group->{$name} - 1;
                $group_name = $name;
            }
            else {
                $group_num = 0;
                $group_name = '';
            }
        }

        my $size = $self->_duration($name); # Get the duration of the note
        my $diff = $self->size - $sum; # How much is left?

        # The difference is less than the min_size
        if (sprintf( $format, $diff ) < sprintf( $format, $self->_min_size )) {
            warn "WARNING: Leftover duration: $diff\n"
                if $self->verbose;
            push @$motif, 'd' . sprintf('%.0f', TICKS * $diff)
                if $self->remainder && sprintf($format, TICKS * $diff) > 0;
            last;
        }

        # The note duration is greater than the difference
        next
            if sprintf( $format, $size ) > sprintf( $format, $diff );

        # Increment the sum by the note duration
        $sum += $size;

        warn(__PACKAGE__,' ',__LINE__," $name, $size, $sum\n")
            if $self->verbose;

        # Add the note to the motif if the sum is less than the total duration size
        push @$motif, $name
            if $sum <= $self->size;
    }

    return $motif;
}


sub motifs {
    my ($self, $n) = @_;
    my @motifs = map { $self->motif } 1 .. $n;
    return @motifs;
}


sub add_to_score {
    my ($self, $score, $motif, $pitches) = @_;
    for my $i (0 .. $#$motif) {
        $score->n($motif->[$i], $pitches->[$i]);
    }
}

sub _duration {
    my ( $self, $name ) = @_;

    my $dura;

    if ($name =~ /^d(\d+)$/) {
        $dura = $1;
    }
    else {
        $dura = $self->durations->{$name};
    }

    return $dura;
}

1;

__END__