File Coverage

blib/lib/Music/VoiceGen.pm

Criterion	Covered	Total	%
statement	102	102	100.0
branch	28	36	77.7
condition	10	23	43.4
subroutine	15	15	100.0
pod	4	5	80.0
total	159	181	87.8

# -*- 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 List::Util qw(min);
use Math::Random::Discrete;
use Moo;
use namespace::clean;
use Scalar::Util qw(looks_like_number);

our $VERSION = '0.02';

has _choices => ( is => 'rwp', );
has _context => (
    is      => 'rwp',
    clearer => 'clear_context',
    coerce  => sub { ref $_[0] eq 'ARRAY' ? $_[0] : \@_ },
    default => sub { [] },
);
has contextfn => (
    is  => 'rw',
    isa => sub {
        die "context function must be a code ref"
          unless defined $_[0] and ref $_[0] eq 'CODE';
    },
    default => sub {
        sub { $_[1]->rand, 1 }
    },
);
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', );
# NOTE use the ->update method to set these after ->new
has possibles => ( is => 'rwp', );
has startfn   => (
    is  => 'rw',
    isa => sub {
        die "start function must be a code ref"
          unless defined $_[0] and ref $_[0] eq 'CODE';
    },
    default => sub {
        sub {
            $_[0]->[ CORE::rand @{ $_[0] } ];
        };
    },
);

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 = $self->startfn->( \@possibles );
    } else {
        my $count = 1;
        for my $i ( 0 .. $#$context ) {
            my $key = join ".", @$context[ $i .. $#$context ];
            if ( exists $choices->{$key} ) {
                ( $choice, my $abort ) =
                  $self->contextfn->( $choice, $choices->{$key}, $count );
                last if $abort;
                $count++;
            }
        }
    }

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

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

    return $choice;
}

sub subsets {
    my ( $self, $min, $max, $fn, $list ) = @_;
    croak "subsets needs min,max,coderef,list" if @_ < 5;
    $list = [ @_[ 4 .. $#_ ] ] if ref $list ne 'ARRAY';
    for my $lo ( 0 .. @$list - $min ) {
        for my $hi ( $lo + $min - 1 .. min( $lo + $max - 1, $#$list ) ) {
            $fn->( @$list[ $lo .. $hi ] );
        }
    }
    return $self;
}

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__