File Coverage

blib/lib/Music/RhythmSet.pm

Criterion	Covered	Total	%
statement	124	124	100.0
branch	32	32	100.0
condition	35	35	100.0
subroutine	18	18	100.0
pod	10	10	100.0
total	219	219	100.0

# -*- Perl -*-
#
# sets of rhythms, comprised of one or more voices (or tracks) and
# various utility functions

package Music::RhythmSet;
our $VERSION = '0.03';

use 5.24.0;
use warnings;
use Carp qw(croak);
use List::GroupingPriorityQueue qw(grpriq_add);
use MIDI;
use Moo;
use namespace::clean;

use Music::RhythmSet::Voice;

has stash  => ( is => 'rw' );
has voices => ( is => 'rw', default => sub { [] } );

# perldoc Moo
sub BUILD {
    my ( $self, $args ) = @_;
    # so ->new->add(...) can instead be written ->new(voicel => [...])
    if ( exists $args->{voicel} ) {
        croak "invalid voicel"
          unless defined $args->{voicel}
          and ref $args->{voicel} eq 'ARRAY';
        $self->add( $args->{voicel}->@* );
        delete $args->{voicel};
    }
}

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

sub add {
    my ( $self, @rest ) = @_;
    croak "nothing to add" unless @rest;

    my $maxid = $self->voices->$#*;

    for my $ref (@rest) {
        croak "invalid voice parameters"
          unless defined $ref and ref $ref eq 'HASH';
        $ref->{id} = ++$maxid;
        push $self->voices->@*, Music::RhythmSet::Voice->new( $ref->%* );
    }

    return $self;
}

sub advance {
    my ( $self, $count, %param ) = @_;
    # this is done stepwise for each voice so that TTL expirations and
    # thus potential new patterns are more likely to be visible to other
    # voices. voices that depend on other voices should therefore be
    # added after those other voices (or there could be a two- or N-pass
    # system to resolve any inter-voice pattern generation difficulties,
    # but that's not supported here)
    for ( 1 .. $count // 1 ) {
        for my $voice ( $self->voices->@* ) {
            $param{set} = $self;
            $voice->advance( 1, %param );
        }
    }
    return $self;
}

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

    for my $cb (qw{header voice}) {
        croak "need $cb callback"
          unless defined $param{$cb}
          and ref $param{$cb} eq 'CODE';
    }

    # patterns can be of different lengths between voices (or can vary
    # over time inside a voice), though may be the same in which case
    # the caller can divide the beat count by however many beats there
    # are in a measure to obtain the measure number. otherwise, the
    # "measure" is the number of beats since the start of the replay log
    $param{divisor} //= 1;
    $param{max}     //= ~0;

    my $queue = [];

    for my $voice ( $self->voices->@* ) {
        my $beat = 0;
        for my $ref ( $voice->replay->@* ) {
            my ( $bpat, $ttl ) = $ref->@*;
            # build a priority queue of when voices change their pattern
            grpriq_add( $queue, $beat, [ $voice->id, $bpat ] );
            $beat += $ttl * $bpat->@*;
        }
    }

    my ( @curpat, @curpat_str );

    # parse the queue for pattern changes and let the caller decide how
    # to act on the results (see eg/beatinator for one way)
    for my $entry ( $queue->@* ) {    # [[id,[bp]],...],beats
        my $measure = $entry->[1] / $param{divisor};
        last if $measure >= $param{max};

        my ( @changed, @repeat );

        for my $ref ( $entry->[0]->@* ) {
            my ( $id, $bpat ) = $ref->@*;
            $changed[$id] = 1;
            $curpat[$id]  = $bpat;
            my $bstr = join( '', $bpat->@* ) =~ tr/10/x./r;
            if ( $bstr eq ( $curpat_str[$id] // '' ) ) {
                $repeat[$id] = 1;
            }
            $curpat_str[$id] = $bstr;
        }

        $param{header}->($measure);

        for my $id ( 0 .. $#curpat ) {
            $param{voice}->(
                $measure, $id, $curpat[$id], $curpat_str[$id], $changed[$id], $repeat[$id]
            );
        }
    }

    return $self;
}

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

    my $new = Music::RhythmSet->new;
    my @voices;

    for my $voice ( $self->voices->@* ) {
        push @voices, $voice->clone;
    }

    $new->voices( \@voices );

    return $new;
}

sub from_string {
    my ( $self, $str, %param ) = @_;
    croak "need a string" unless defined $str and length $str;

    $param{rs} //= "\n";
    if ( $param{sep} ) {
        $param{sep} = qr/\Q$param{sep}\E/;
    } else {
        $param{sep} = qr/\s+/;
    }

    my $linenum = 1;
    my @newplay;
    my $voices = $self->voices;

    for my $line ( split /\Q$param{rs}/, $str ) {
        next if $line =~ m/^\s*(?:#|$)/;
        # the limits are to prevent overly long strings from being
        # parsed; if this is a problem write a modified from_string that
        # does allow such inputs, or modify the unused  count
        if ($line =~ m/^
            (?\d{1,10})     $param{sep}
            (?\d{1,3})        $param{sep}
            (?[x.]{1,256})  $param{sep}
            (?\d{1,5})       \s*(?:[#].*)?
            $/ax
        ) {
            # only +1 ID over max is allowed to avoid creating a sparse
            # voices list; this means that input that starts with voice
            # 1 (or higher) will be rejected, or if voice 4 is seen
            # before the first entry for voice 3 that too will be
            # rejected. this might happen if a sort reordered the events
            # and there was not a sub-sort to keep the voice IDs in
            # ascending order
            if ( $voices->$#* == 0 or $+{id} == $voices->$#* + 1 ) {
                $self->add( {} );
            } elsif ( $+{id} > $voices->$#* ) {
                croak "ID out of range '$+{id}' at line $linenum";
            }
            push $newplay[ $+{id} ]->@*, [ [ split //, $+{bstr} =~ tr/x./10/r ], $+{ttl} ];
        } else {
            croak "invalid record at line $linenum";
        }
        $linenum++;
    }

    # this complication is to make changes to the replay log more atomic
    # given that the above can die mid-parse. the newplay array can be
    # sparse e.g. if four voices already exist and the input only has
    # records for voices 0 and 2
    for my $id ( 0 .. $#newplay ) {
        push $voices->[$id]->replay->@*, $newplay[$id]->@* if defined $newplay[$id];
    }

    return $self;
}

sub measure {
    my ( $self, $num ) = @_;
    for my $voice ( $self->voices->@* ) {
        $voice->measure($num);
    }
    return $self;
}

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

    for my $id ( 0 .. $self->voices->$#* ) {
        for my $pram (qw/dur maxm note rest time/) {
            $param{voice}[$id]{$pram} = $param{$pram}
              if exists $param{$pram} and not exists $param{voice}[$id]{$pram};
        }
    }

    my $id = 0;
    return [ map { $_->to_ly( $param{voice}->[ $id++ ]->%* ) } $self->voices->@* ];
}

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

    $param{format} //= 1;
    $param{ticks}  //= 96;

    for my $id ( 0 .. $self->voices->$#* ) {
        for my $pram (qw/chan dur maxm note notext tempo sustain velo/) {
            $param{track}[$id]{$pram} = $param{$pram}
              if exists $param{$pram} and not exists $param{track}[$id]{$pram};
        }
    }

    my $id = 0;
    return MIDI::Opus->new(
        {   format => $param{format},
            ticks  => $param{ticks},
            tracks =>
              [ map { $_->to_midi( $param{track}->[ $id++ ]->%* ) } $self->voices->@* ]
        }
    );
}

sub to_string {
    my ( $self, @rest ) = @_;

    my $str = '';

    for my $voice ( $self->voices->@* ) {
        $str .= $voice->to_string(@rest);
    }

    return $str;
}

1;
__END__