File Coverage

blib/lib/Music/Guidonian.pm

Criterion	Covered	Total	%
statement	122	122	100.0
branch	74	74	100.0
condition	52	52	100.0
subroutine	15	15	100.0
pod	3	3	100.0
total	266	266	100.0

# -*- Perl -*-
#
# Music::Guidonian - a means of melodic phrase generation based on the
# "Guidonian Hand" that is credited to Guido of Arezzo

package Music::Guidonian;
our $VERSION = '0.05';

use 5.24.0;
use warnings;
use Carp 'croak';
use List::Util 'shuffle';
use List::UtilsBy 'nsort_by';
use Moo;
use namespace::clean;

use constant { INDEX => 0, CHOICE => 1, FIRST => 0, DONE => -1, DIRTY => -1 };

use parent qw(Exporter);
our @EXPORT_OK = qw(intervalize_scale_nums);

has key2pitch  => ( is => 'rw' );
has pitchstyle => ( is => 'ro' );

# perldoc Moo
sub BUILD {
    my ( $self, $args ) = @_;

    if ( exists $args->{key2pitch} and exists $args->{key_set} ) {
        croak "cannot specify both key2pitch and key_set";

    } elsif ( exists $args->{key2pitch} ) {
        croak "key2pitch must be a hash reference with keys"
          unless defined $args->{key2pitch}
          and ref $args->{key2pitch} eq 'HASH'
          and keys $args->{key2pitch}->%*;

    } elsif ( exists $args->{key_set} ) {
        my $set = $args->{key_set};
        croak "key_set must be a hash reference with keys"
          unless defined $set
          and ref $set eq 'HASH'
          and keys $set->%*;

        croak "intervals must be an array with elements"
          unless defined $set->{intervals}
          and ref $set->{intervals} eq 'ARRAY'
          and $set->{intervals}->@*;
        croak "keys must be an array with elements"
          unless defined $set->{keys}
          and ref $set->{keys} eq 'ARRAY'
          and $set->{keys}->@*;
        croak "min must be an integer"
          unless defined $set->{min} and $set->{min} =~ m/^(?a)-?\d+$/;
        croak "max must be an integer"
          unless defined $set->{max} and $set->{max} =~ m/^(?a)-?\d+$/;

        croak "min must be less than max" if $set->{min} >= $set->{max};

        my $curinterval = 0;
        my $curkey      = 0;
        my %key2pitch;
        my $pitch = $set->{min};

        while (1) {
            push @{ $key2pitch{ $set->{keys}->[$curkey] } }, $pitch;
            $pitch += $set->{intervals}->[$curinterval];
            last if $pitch > $set->{max};
            $curinterval = ++$curinterval % $set->{intervals}->@*;
            $curkey      = ++$curkey % $set->{keys}->@*;
        }
        $self->key2pitch( \%key2pitch );

        # may want to preserve this for reference or cloning?
        delete $args->{key_set};

    } else {
        croak "need key2pitch or key_set";
    }

    with( $args->{pitchstyle} ) if exists $args->{pitchstyle};
}

########################################################################
#
# METHODS

sub iterator {
    my ( $self, $sequence, %param ) = @_;
    croak "sequence is not an array reference"
      unless defined $sequence and ref $sequence eq 'ARRAY';
    croak "sequence is too short" if @$sequence < 2;

    if ( exists $param{renew} ) {
        croak "renew is not a code reference"
          unless !defined $param{renew}
          or ref $param{renew} eq 'CODE';
    } else {
        $param{renew} = \&_renew;
    }

    my $key2pitch = $self->key2pitch;
    croak "no key2pitch map is set"
      unless defined $key2pitch
      and ref $key2pitch eq 'HASH'
      and keys %$key2pitch;

    # the possibilities are either scalars (integer pitch numbers, a
    # static choice) or an [ INDEX, CHOICE ] array reference where the
    # CHOICE is an array reference of possible integer pitch numbers
    my @possible;
    for my $i ( 0 .. $#$sequence ) {
        my $s = $sequence->[$i];
        croak "sequence element is undefined ($i)" unless defined $s;
        if ( $s =~ m/^(?a)-?\d+$/ ) {
            push @possible, $s;
        } else {
            my $choices = $key2pitch->{$s} // '';
            croak "choices are not an array reference for '$s'"
              unless ref $choices eq 'ARRAY';
            my $length = $choices->@*;
            croak "no choices for '$s' at index $i" if $length == 0;
            if ( $length == 1 ) {
                push @possible, $choices->[0];
                next;
            }
            $param{renew}->( $choices, $i, \@possible, $param{stash} )
              if defined $param{renew};
            push @possible, [ FIRST, $choices ];    # INDEX, CHOICE
        }
    }

    # edge case: there is only one iteration due to a lack of choices.
    # fail so that the iterator is not complicated to handle that
    my $refcount = 0;
    for my $p (@possible) { $refcount++ if ref $p eq 'ARRAY' }
    croak "no choices in @possible" if $refcount == 0;

    return sub {
        return unless @possible;

        my @phrase;
        for my $p (@possible) {
            if ( ref $p eq 'ARRAY' ) {
                push @phrase, 0 + $p->[CHOICE][ $p->[INDEX] ];
            } else {
                push @phrase, 0 + $p;
            }
        }

        my $dirty = 0;
        for my $i ( reverse DONE .. $#possible ) {
            if ( $i == DONE ) {
                @possible = ();
                $dirty    = 0;
                last;
            } elsif ( ref $possible[$i] eq 'ARRAY' ) {
                if ( ++$possible[$i][INDEX] >= $possible[$i][CHOICE]->@* ) {
                    $possible[$i][INDEX] = DIRTY;
                    $dirty = 1;
                } else {
                    # nothing more to update (this time)
                    last;
                }
            }
        }
        if ($dirty) {
            for my $i ( 0 .. $#possible ) {
                if ( ref $possible[$i] eq 'ARRAY' and $possible[$i][INDEX] == DIRTY ) {
                    $possible[$i][INDEX] = FIRST;
                    $param{renew}->( $possible[$i][CHOICE], $i, \@possible, $param{stash} )
                      if defined $param{renew};
                }
            }
        }

        if ( defined $self->pitchstyle ) {
            for my $p (@phrase) {
                $p = $self->pitchname($p);
            }
        }

        return \@phrase;
    };
}

# this has various problems not typical to melodies, such as confining
# leaps towards the end of the phrase in early subsequent iterations.
# improvements might be to use a non-random starting pitch (e.g. one
# suitable to previous material unknown to the current phrase), or to
# sometimes shuffle the choices mid-phrase, or to leap when there is a
# repeated note?
sub _renew {
    my ( $choices, $index, $possible ) = @_;
    if ( $index == 0 ) {
        $choices = [ shuffle @$choices ];
    } else {
        my $previous = $possible->[ $index - 1 ];
        my $previous_pitch =
          ref $previous eq 'ARRAY'
          ? $previous->[CHOICE][ $previous->[INDEX] ]
          : $previous;
        $choices = [ nsort_by { abs( $previous_pitch - $_ ) } $choices->@* ];
    }
}

########################################################################
#
# FUNCTIONS

# convert Music::Scales "get_scale_nums" to the interval for each step,
# making various assumptions (or lack of sanity tests) along the way
# (pretty sure I've written this same code elsewhere...)
sub intervalize_scale_nums {
    my ( $scale, $max_interval ) = @_;
    $max_interval ||= 12;    # assume Western 12-tone system
    my @intervals;
    my $previous = 0;
    for my $s (@$scale) {
        next if $s == 0;
        push @intervals, $s - $previous;
        $previous = $s;
    }
    push @intervals, $max_interval - $previous;
    return \@intervals;
}

1;
__END__