File Coverage

blib/lib/MIDI/Segment.pm

Criterion	Covered	Total	%
statement	94	95	98.9
branch	16	20	80.0
condition	15	17	88.2
subroutine	8	8	100.0
pod	2	2	100.0
total	135	142	95.0

# -*- Perl -*-
# a means to segment MIDI by equal duration
package MIDI::Segment;
our $VERSION = '0.03';
use 5.10.0;
use strict;
use warnings;

use constant {
    # index into MIDI::Event events
    NAME  => 0,    # note_on, etc
    DTIME => 1,    # delta time
    VELO  => 4,    # velocity (volume or loudness)

    # velocity less or equal to this will not be considered a notable
    # "note_on". this may need to be a user-supplied parameter
    MINVELO => 0,
};

sub _durations {
    my ($opus) = @_;
    my ( $maxdur, $vague ) = ( 0, 0 );
    my ( @all_onsets, @links, @track_lens );
    for my $track ( @{ $opus->tracks_r } ) {
        my @onsets = (0);
        my %onset2index;
        my $notes  = 0;
        my $when   = 0;
        my $evlist = $track->events_r;
        for my $tindex ( 0 .. $#$evlist ) {
            my $event = $evlist->[$tindex];
            # TODO may need a "minimum duration" so that too-small
            # durations are not found, but the user could also ignore
            # those when calling split
            if (    $event->[NAME] eq 'note_on'
                and $event->[VELO] > MINVELO
                and $when > $onsets[-1] ) {
                push @onsets, $when;
                $onset2index{$when} = $tindex;
                $notes = 1;
            }
            $when += $event->[DTIME];
        }
        # more complicated would be to skip these tracks, but that would
        # require a sparse list of tracks to apply the subsequent
        # calculations to
        die "no note_on in track" unless $notes;
        push @track_lens, $when;
        $maxdur = $when if $when > $maxdur;
        my $last = $evlist->[-1];
        $vague = 1
          if $last->[DTIME] == 0
          and $last->[NAME] eq 'note_on'
          and $last->[VELO] > MINVELO;
        shift @onsets;
        push @all_onsets, \@onsets;
        push @links,      \%onset2index;
    }
    # TODO can this be reached with the "no note_on in track" limitation?
    #die "no events in MIDI" if $maxdur <= 0;
    my $ragged = 0;
    if ( @track_lens > 1 ) {
        for my $i ( 1 .. $#track_lens ) {
            if ( $track_lens[0] != $track_lens[$i] ) {
                $ragged = $i;
                last;
            }
        }
    }
    return {
        links         => \@links,
        onsets        => \@all_onsets,
        opus          => $opus,
        maximum       => $maxdur,
        ragged        => $ragged,        # track lengths differ?
        segments      => [],
        track_lengths => \@track_lens,
        vague         => $vague,         # track ends on 0 dtime note_on?
    };
}

sub _possible_segments {
    my ( $max, $tracks ) = @_;
    my $half = int( $max / 2 );
    my %possible;
  TRACK: for my $onsets (@$tracks) {
        # TODO or die here, if this is reachable somehow sane
        #next unless @$onsets;
        my ( $lower, $upper ) = ( 0, $#$onsets );
        my $midpoint;
        while ( $lower <= $upper ) {
            $midpoint = ( $lower + $upper ) >> 1;
            if ( $half < $onsets->[$midpoint] ) {
                $upper = $midpoint - 1;
            } elsif ( $half > $onsets->[$midpoint] ) {
                $lower = $midpoint + 1;
            } else {
                @possible{ @{$onsets}[ 0 .. $midpoint ] } = ();
                next TRACK;
            }
        }
        @possible{ @{$onsets}[ 0 .. $midpoint - 1 ] } = ();
    }
    # and only those possible that evenly split the duration
    return [ sort { $a <=> $b } grep { $max % $_ == 0 } keys %possible ];
}

sub new {
    my ( $class, $opus ) = @_;
    my $self = _durations($opus);
    # TODO maybe user-supplied parameters could auto-correct some of
    # these cases, e.g. to extend the tracks to some duration?
    die "problematic MIDI v=$self->{vague} r=$self->{ragged}"
      if $self->{vague} or $self->{ragged};
    my $potential =
      _possible_segments( $self->{maximum}, $self->{onsets} );
  DURATION: for my $dur (@$potential) {
        my $window = $dur;
        while ( $window < $self->{maximum} ) {
            for my $links ( @{ $self->{links} } ) {
                next DURATION unless exists $links->{$window};
            }
            $window += $dur;
        }
        push @{ $self->{segments} }, $dur;
    }
    return bless( $self, $class ), $self->{segments};
}

sub split {
    my ( $self, $dur ) = @_;
    my @segtracks;
    my $links  = $self->{links};
    my $tracks = $self->{opus}->tracks_r;
    for my $tidx ( 0 .. $#$tracks ) {
        my @segments;
        my $evlist = $tracks->[$tidx]->events_r;
        my $start  = 0;
        my $window = $dur;
        my $sidx   = 0;
        while ( $window < $self->{maximum} ) {
            my $end = $links->[$tidx]{$window}
              // die "no onset at $window track $tidx";
            # TODO how create this situation for a test?
            #die "cannot end before start ($start, $end)" if $end <= $start;
            $segtracks[ $sidx++ ][$tidx] = [ @{$evlist}[ $start .. $end - 1 ] ];
            $window += $dur;
            $start = $end;
        }
        $segtracks[$sidx][$tidx] = [ @{$evlist}[ $start .. $#$evlist ] ];
    }
    return \@segtracks;
}

1;
__END__