File Coverage

blib/lib/Music/RhythmSet/Voice.pm

Criterion	Covered	Total	%
statement	196	196	100.0
branch	84	84	100.0
condition	101	101	100.0
subroutine	15	15	100.0
pod	7	7	100.0
total	403	403	100.0

# -*- Perl -*-
#
# a voice (or track) that is comprised of various patterns repeated
# ttl times

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

use 5.24.0;
use warnings;
use Carp qw(confess croak);
use MIDI;
use Moo;
use namespace::clean;

use constant { NOTE_ON => 1, NOTE_OFF => 0, EVENT => 0, DTIME => 1 };

has id      => ( is => 'rw' );
has next    => ( is => 'rw' );
has measure => ( is => 'rw', default => sub { 0 } );
has pattern => ( is => 'rw' );
has replay  => ( is => 'rw', default => sub { [] } );
has stash   => ( is => 'rw' );
has ttl     => ( is => 'rw', default => sub { 0 } );

# perldoc Moo
sub BUILD {
    my ( $self, $args ) = @_;
    if ( exists $args->{pattern} and exists $args->{ttl} ) {
        croak "invalid ttl" if $args->{ttl} < 1;
        croak "invalid pattern"
          unless defined $args->{pattern}
          and ref $args->{pattern} eq 'ARRAY'
          and $args->{pattern}->@*;
        push $self->replay->@*, [ $args->{pattern}, $args->{ttl} ];
    }
}

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

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

    my $measure = $self->measure;

    for ( 1 .. $count // 1 ) {
        my $ttl = $self->ttl - 1;

        $param{measure} = $measure++;
        $param{pattern} = $self->pattern;

        if ( $ttl <= 0 ) {
            my $next = $self->next;

            confess "no next callback"
              unless defined $next and ref $next eq 'CODE';

            ( $param{pattern}, $ttl ) = $next->( $self, %param );

            confess "no pattern set"
              unless defined $param{pattern}
              and ref $param{pattern} eq 'ARRAY'
              and $param{pattern}->@*;
            confess "invalid ttl" if $ttl < 1;

            $self->pattern( $param{pattern} );

            push $self->replay->@*, [ $param{pattern}, $ttl ];
        }

        $self->ttl($ttl);
    }

    $self->measure($measure);

    return $self;
}

# there is no ->changes method; meanwhile, put the single voice into a
# set object and call ->changes over there if you need that for a
# single voice:
#
#   my $set = Music::RhythmSet->new;
#   $set->voices([$voice]);
#   $set->changes(...)

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

    $param{newid} //= $self->id;

    my $new = Music::RhythmSet::Voice->new(
        id => $param{newid},
        map { $_, scalar $self->$_ } qw(next measure ttl),
    );

    # these 'die' as the bad attribute values were likely not assigned
    # anywhere near the current stack. use Carp::Always or such if you
    # do need to find out where your code calls into here, but you
    # probably instead want to look at any ->pattern(...) or
    # ->replay(...) calls in your code
    my $pat = $self->pattern;
    if ( defined $pat ) {
        die "invalid pattern" unless ref $pat eq 'ARRAY' and $pat->@*;
        $new->pattern( [ $pat->@* ] );
    }

    my $ref = $self->replay;
    if ( defined $ref ) {
        die "replay must be an array reference"
          unless ref $ref eq 'ARRAY';
        die "replay array must contain array references"
          unless ref $ref->[0] eq 'ARRAY';
        $new->replay( [ map { [ [ $_->[0]->@* ], $_->[1] ] } $ref->@* ] );
    }

    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;

    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}
            (?.*?)            $param{sep}
            (?[x.]{1,256})  $param{sep}
            (?\d{1,5})       \s*(?:[#].*)?
            $/ax
        ) {
            # NOTE  is unused and is assumed to be "this voice"
            # regardless of what it contains
            push @newplay, [ [ split //, $+{bstr} =~ tr/x./10/r ], $+{ttl} ];
        } else {
            croak "invalid record at line $linenum";
        }
        $linenum++;
    }

    push $self->replay->@*, @newplay;

    return $self;
}

# TODO some means of note reduction and optional note sustains
# over rests
sub to_ly {
    my ( $self, %param ) = @_;

    my $replay = $self->replay;
    croak "empty replay log"
      unless defined $replay
      and ref $replay eq 'ARRAY'
      and $replay->@*;

    $param{dur}  //= '16';
    $param{note} //= 'c';
    $param{rest} //= 'r';

    my $id   = $self->id // '';
    my $ly   = '';
    my $maxm = $param{maxm} // ~0;

    for my $ref ( $replay->@* ) {
        my ( $bpat, $ttl ) = $ref->@*;
        $ttl = $maxm if $ttl > $maxm;

        $ly .= "  % v$id " . join( '', $bpat->@* ) =~ tr/10/x./r . " $ttl\n";
        if ( $param{time} ) {
            $ly .= '  \time ' . $bpat->@* . '/' . $param{time} . "\n";
        }
        my $str = ' ';
        for my $x ( $bpat->@* ) {
            if ( $x == NOTE_ON ) {
                $str .= ' ' . $param{note} . $param{dur};
            } else {
                $str .= ' ' . $param{rest} . $param{dur};
            }
        }
        $ly .= join( "\n", ($str) x $ttl ) . "\n";

        $maxm -= $ttl;
        last if $maxm <= 0;
    }
    return $ly;
}

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

    my $replay = $self->replay;
    croak "empty replay log"
      unless defined $replay
      and ref $replay eq 'ARRAY'
      and $replay->@*;

    # MIDI::Event, section "EVENTS AND THEIR DATA TYPES"
    $param{chan}  //= 0;
    $param{dur}   //= 20;
    $param{note}  //= 60;
    $param{tempo} //= 500_000;
    $param{velo}  //= 90;        # "default value" per lilypond scm/midi.scm

    my $track  = MIDI::Track->new;
    my $events = $track->events_r;

    my $delay;
    my $id       = $self->id // '';
    my $leftover = 0;
    my $maxm     = $param{maxm} // ~0;

    push $events->@*, [ 'track_name', 0, 'voice' . ( length $id ? " $id" : '' ) ];
    push $events->@*, [ 'set_tempo',  0, $param{tempo} ];

    for my $ref ( $replay->@* ) {
        my ( $bpat, $ttl ) = $ref->@*;
        $ttl = $maxm if $ttl > $maxm;

        push $events->@*,
          [ 'text_event', $leftover,
            "v$id " . join( '', $bpat->@* ) =~ tr/10/x./r . " $ttl\n"
          ];

        $delay = 0;
        my ( $onsets, $open, @midi );

        for my $x ( $bpat->@* ) {
            if ( $x == NOTE_ON ) {
                $onsets++;
                if ( defined $open ) {
                    push @midi, [ 'note_off', $delay, $param{chan}, $open, 0 ];
                    $delay = 0;
                }
                push @midi, [ 'note_on', $delay, map { $param{$_} } qw(chan note velo) ];
                $delay = $param{dur};
                $open  = $param{note};
            } else {
                if ( defined $open ) {
                    push @midi, [ 'note_off', $delay, $param{chan}, $open, 0 ];
                    $delay = 0;
                    undef $open;
                }
                $delay += $param{dur};
            }
        }
        if ( defined $open ) {
            push @midi, [ 'note_off', $delay, $param{chan}, $open, 0 ];
            $delay = 0;
        }

        # trailing rests (e.g. in a [1000] pattern) create a delay that
        # must be applied to the start of subsequent repeats of this
        # measure (if there is an onset that makes this possible) and
        # then must be passed on as leftovers for the next text_event
        if ( $delay and $onsets and $ttl > 1 ) {
            push $events->@*, @midi;
            $midi[0] = [ $midi[0]->@* ];
            $midi[0][1] += $delay;
            push $events->@*, (@midi) x ( $ttl - 1 );
        } else {
            push $events->@*, (@midi) x $ttl;
        }

        # delay from trailing rests *or* a full measure of rest
        $leftover = $delay;

        # remainder of full measures of rest, if any
        $leftover += $bpat->@* * $param{dur} * ( $ttl - 1 ) unless $onsets;

        $maxm -= $ttl;
        last if $maxm <= 0;
    }

    # end of track event for sustain to have something to extend out to,
    # and so that different trailing rests between different voices are
    # less likely to exhibit ragged track ends. it also simplifies the
    # handling of the last event in the stream, below
    push $events->@*, [ 'text_event', $leftover, "v$id EOT\n" ];

    # and here the MIDI is modified if need be -- the above is already
    # complicated, and it's (somewhat) easier to cut events out and
    # fiddle with delays on the completed stream
    if ( $param{sustain} or $param{notext} ) {
        my $i = 0;
        while ( $i < $events->$#* ) {
            if ( $param{sustain} and $events->[$i][0] eq 'note_off' ) {
                # extend delay on the note_off to the next note_on;
                # there might be a text_event between
                my $delay = 0;
                my $j     = $i + 1;
                while (1) {
                    if ( $events->[$j][EVENT] eq 'text_event' and $events->[$j][DTIME] > 0 ) {
                        $delay += $events->[$j][DTIME];
                        $events->[$j][DTIME] = 0;
                    } elsif ( $events->[$j][EVENT] eq 'note_on' ) {
                        if ( $events->[$j][DTIME] > 0 ) {
                            $delay += $events->[$j][DTIME];
                            $events->[$j] = [ $events->[$j]->@* ];
                            $events->[$j][DTIME] = 0;
                        }
                        last;
                    }
                    last if ++$j > $events->$#*;
                }
                $events->[$i] = [ $events->[$i]->@* ];
                $events->[$i][DTIME] += $delay;

            } elsif ( $param{notext} and $events->[$i][EVENT] eq 'text_event' ) {
                my $delay = $events->[$i][DTIME];
                splice $events->@*, $i, 1;
                $events->[$i] = [ $events->[$i]->@* ];
                $events->[$i][DTIME] += $delay;
                next;    # examine the new event at the current index
            }
            $i++;
        }

        # assume the final event is the EOT text_event
        pop $events->@* if $param{notext};
    }

    return $track;
}

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

    my $replay = $self->replay;
    croak "empty replay log"
      unless defined $replay
      and ref $replay eq 'ARRAY'
      and $replay->@*;

    $param{divisor} //= 1;
    $param{rs}      //= "\n";
    $param{sep}     //= "\t";

    my $beat = 0;
    my $id   = $self->id    // '';
    my $maxm = $param{maxm} // ~0;
    my $str  = '';

    for my $ref ( $replay->@* ) {
        my ( $bpat, $ttl ) = $ref->@*;
        my $bstr = join( '', $bpat->@* ) =~ tr/10/x./r;
        $ttl = $maxm if $ttl > $maxm;

        $str .=
          join( $param{sep}, $beat / $param{divisor}, $id, $bstr, $ttl ) . $param{rs};

        $beat += $ttl * $bpat->@*;
        $maxm -= $ttl;
        last if $maxm <= 0;
    }

    return $str;
}

1;
__END__