File Coverage

blib/lib/Music/RhythmSet/Util.pm

Criterion	Covered	Total	%
statement	119	119	100.0
branch	44	44	100.0
condition	30	30	100.0
subroutine	19	19	100.0
pod	13	13	100.0
total	225	225	100.0

# -*- Perl -*-
#
# various functions related to the generation and comparison of patterns
# of beats, and etc

package Music::RhythmSet::Util;
our $VERSION = '0.04';

use 5.24.0;
use warnings;
use Carp qw(croak);
use Statistics::Lite qw(stddevp);

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

use parent qw(Exporter);
our @EXPORT_OK =
  qw(beatstring compare_onsets duration filter_pattern flatten ocvec onset_count pattern_from rand_onsets score_fourfour score_stddev upsize write_midi);

sub beatstring
{
    my ($bpat) = @_;
    croak "no pattern set"
      unless defined $bpat and ref $bpat eq 'ARRAY';
    return join( '', $bpat->@* ) =~ tr/10/x./r;
}

sub compare_onsets
{
    my ( $first, $second ) = @_;

    my $same   = 0;
    my $onsets = 0;

    for my $i ( 0 .. $first->$#* ) {
        if ( $first->[$i] == NOTE_ON ) {
            $onsets++;
            $same++ if $second->[$i] == NOTE_ON;
        }
    }
    croak "no onsets?! [@$first] [@$second]" unless $onsets;

    return $same / $onsets;
}

sub duration
{
    my ($replay) = @_;
    croak "no replay log"
      unless defined $replay and ref $replay eq 'ARRAY';

    my $measures = 0;
    my $beats    = 0;

    for my $ref ( $replay->@* ) {
        $measures += $ref->[1];
        $beats    += $ref->[0]->@* * $ref->[1];
    }

    return $measures, $beats;
}

sub filter_pattern
{
    my ( $onsets, $total, $trials, $fudge, $nozero ) = @_;

    $fudge //= 0.0039;
    my $best = ~0;
    my $bpat;

    for ( 1 .. $trials ) {
        my $new   = &rand_onsets;
        my $score = score_stddev($new) + score_fourfour($new) * $fudge;
        next if $nozero and $score == 0;
        if ( $score < $best ) {
            $best = $score;
            $bpat = $new;
        }
    }

    return $bpat;
}

sub flatten
{
    my ($replay) = @_;
    croak "no replay log"
      unless defined $replay and ref $replay eq 'ARRAY';
    return [ map { ( $_->[0]->@* ) x $_->[1] } $replay->@* ];
}

# "onset-coordinate vector" notation for a pattern
sub ocvec
{
    my ($bpat) = @_;
    croak "no pattern set"
      unless defined $bpat and ref $bpat eq 'ARRAY';

    my @set;
    my $i = 0;

    for my $x ( $bpat->@* ) {
        push @set, $i if $x == NOTE_ON;
        $i++;
    }

    return \@set;
}

sub onset_count
{
    my ($bpat) = @_;
    croak "no pattern set"
      unless defined $bpat and ref $bpat eq 'ARRAY';

    my $onsets = 0;

    for my $x ( $bpat->@* ) {
        $onsets++ if $x == NOTE_ON;
    }

    return $onsets;
}

sub pattern_from
{
    my ($string) = @_;
    $string =~ tr/x.//cd;
    $string =~ tr/x./10/;
    return [ split '', $string ];
}

sub rand_onsets
{
    my ( $onsets, $total ) = @_;
    croak "onsets must be < total" if $onsets >= $total;

    my @pattern;
    while ($total) {
        if ( rand() < $onsets / $total ) {
            push @pattern, NOTE_ON;
            $onsets--;
        } else {
            push @pattern, NOTE_OFF;
        }
        $total--;
    }

    return \@pattern;
}

sub score_fourfour
{
    my ($bpat) = @_;

    my @beatquality = map { 256 - $_ } qw(
      256 0 16 4
      64 0 32 8
      128 0 16 4
      64 0 32 8
    );
    my $i     = 0;
    my $score = 0;

    for my $x ( $bpat->@* ) {
        $score += $beatquality[$i] if $x == NOTE_ON;
        $i++;
    }

    return $score;
}

sub score_stddev
{
    my ($bpat) = @_;

    my @deltas;
    my $len = $bpat->@*;

    for my $i ( 0 .. $bpat->$#* ) {
        if ( $bpat->[$i] == NOTE_ON ) {
            my $j = $i + 1;
            while (1) {
                if ( $bpat->[ $j % $len ] == NOTE_ON ) {
                    my $d = $j - $i;
                    push @deltas, $d;
                    last;
                }
                $j++;
            }
        }
    }
    croak "no onsets?! [@$bpat]" unless @deltas;

    return stddevp(@deltas);
}

sub upsize
{
    my ( $bpat, $newlen ) = @_;
    croak "no pattern set"
      unless defined $bpat
      and ref $bpat eq 'ARRAY'
      and $bpat->@*;
    my $len = $bpat->@*;
    croak "new length must be greater than pattern length" if $newlen <= $len;
    my $mul = int( $newlen / $len );
    my @pat = (NOTE_OFF) x $newlen;
    for my $i ( 0 .. $bpat->$#* ) {
        if ( $bpat->[$i] == NOTE_ON ) {
            $pat[ $i * $mul ] = NOTE_ON;
        }
    }
    return \@pat;
}

sub write_midi
{
    my ( $file, $track, %param ) = @_;

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

    MIDI::Opus->new(
        {   format => $param{format},
            ticks  => $param{ticks},
            tracks => ref $track eq 'ARRAY' ? $track : [$track]
        }
    )->write_to_file($file);

    return;    # copy "write_to_file" interface
}

1;
__END__