File Coverage

blib/lib/Music/VoiceGen.pm

Criterion	Covered	Total	%
statement	90	90	100.0
branch	25	32	78.1
condition	10	23	43.4
subroutine	13	13	100.0
pod	3	4	75.0
total	141	162	87.0

# -*- Perl -*-
#
# Musical voice generation.
#
# Run perldoc(1) on this file for additional documentation.

package Music::VoiceGen;

use 5.10.0;
use strict;
use warnings;

use Carp qw(croak);
use Math::Random::Discrete;
use Moo;
use namespace::clean;
use Scalar::Util qw(looks_like_number);

our $VERSION = '0.01';

has _choices => ( is => 'rwp', );
has _context => (
    is      => 'rwp',
    clearer => 'clear_context',
    coerce  => sub { ref $_[0] eq 'ARRAY' ? $_[0] : \@_ },
    default => sub { [] },
);
has intervals => ( is => 'rwp', );
has MAX_CONTEXT => (
    is     => 'rw',
    coerce => sub {
        croak "MAX_CONTEXT must be positive integer"
          if !defined $_[0]
          or !looks_like_number $_[0]
          or $_[0] < 1;
        int $_[0];
    },
    default => sub {
        1;
    },
);
has pitches   => ( is => 'rwp', );
has possibles => ( is => 'rwp', );

sub BUILD {
    my ( $self, $param ) = @_;

    if ( exists $param->{pitches} and exists $param->{intervals} ) {
        croak "have no pitches to work with"
          if !defined $param->{pitches}
          or ref $param->{pitches} ne 'ARRAY'
          or !@{ $param->{pitches} };
        croak "have no intervals to work with"
          if !defined $param->{intervals}
          or ref $param->{intervals} ne 'ARRAY'
          or !@{ $param->{intervals} };

        my $weightfn = $param->{weightfn} // sub { 1 };

        my ( %allowed_pitches, %allowed_intervals );
        @allowed_pitches{ map int,   @{ $param->{pitches} } }   = ();
        @allowed_intervals{ map int, @{ $param->{intervals} } } = ();

        for my $pitch ( keys %allowed_pitches ) {
            for my $interval ( keys %allowed_intervals ) {
                my $newpitch = $pitch + $interval;
                if ( exists $allowed_pitches{$newpitch} ) {
                    $param->{possibles}{$pitch}{$newpitch} =
                      $weightfn->( $pitch, $newpitch, $interval );
                }
            }
        }
        $self->_set_intervals( $param->{intervals} );
        $self->_set_pitches( $param->{pitches} );

    } elsif ( exists $param->{possibles} ) {
        croak "possibles must be hash reference"
          if !defined $param->{possibles}
          or ref $param->{possibles} ne 'HASH';
        $self->_set_intervals( [] );
        $self->_set_pitches(   [] );
    } else {
        croak "need 'pitches' and 'intervals' or 'possibles'";
    }

    $self->update( $param->{possibles}, preserve_pitches => 1 );
}

sub context {
    my ( $self, $context ) = @_;
    return $self->_context if !defined $context;
    $context = [ @_[ 1 .. $#_ ] ] if ref $context ne 'ARRAY';
    my $mc = $self->MAX_CONTEXT;
    if ( @$context > $mc ) {
        @$context = @$context[ -$mc .. -1 ];
    }
    $self->_set__context($context);
    return $self;
}

sub rand {
    my ($self) = @_;
    my $choices = $self->_choices;
    my $choice;
    my $context = $self->context;
    if ( !@$context ) {
        my @possibles = keys %{ $self->possibles };
        croak "no keys in possibles" if !@possibles;
        $choice = $possibles[ rand @possibles ];
    } else {
        for my $i ( 0 .. $#$context ) {
            my $key = join ".", @$context[ $i .. $#$context ];
            if ( exists $choices->{$key} ) {
                $choice = $choices->{$key}->rand;
                last if defined $choice;
            }
        }
    }

    # see "Known Issues" in docs for ideas on how to workaround
    die "could not find a choice" if !defined $choice;

    push @$context, $choice;
    $self->context($context);

    return $choice;
}

sub update {
    my ( $self, $possibles, %param ) = @_;

    croak "possibles must be hash reference"
      if !defined $possibles
      or ref $possibles ne 'HASH';

    $self->_set_possibles($possibles);

    my %choices;
    for my $fromval ( keys %$possibles ) {
        my ( @choices, @weights );
        for my $toval ( keys %{ $possibles->{$fromval} } ) {
            push @choices, $toval;
            push @weights, $possibles->{$fromval}{$toval};
        }
        $choices{$fromval} = Math::Random::Discrete->new( \@weights, \@choices );
    }
    $self->_set__choices( \%choices );

    unless ( $param{preserve_pitches} ) {
        $self->_set_intervals( [] );
        $self->_set_pitches(   [] );
    }

    return $self;
}

1;
__END__