File Coverage

blib/lib/MIDI/Drummer/Tiny.pm

Criterion	Covered	Total	%
statement	141	283	49.8
branch	25	64	39.0
condition	15	75	20.0
subroutine	26	41	63.4
pod	23	24	95.8
total	230	487	47.2

package MIDI::Drummer::Tiny;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: Glorified metronome

our $VERSION = '0.4012';

use strictures 2;
use Data::Dumper::Compact qw(ddc);
use List::Util qw(sum0);
use Math::Bezier ();
use MIDI::Util qw(dura_size reverse_dump set_chan_patch set_time_signature);
use Moo;
use Music::Duration ();
use Music::RhythmSet::Util qw(upsize);
use namespace::clean;

use constant TICKS => 96; # Per quarter note


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

    $self->score->noop( 'c' . $self->channel, 'V' . $self->volume );

    if ($self->kit) {
      $self->score->control_change($self->channel, 0, 120);
      $self->score->patch_change($self->channel, $self->kit)
    }

    $self->score->set_tempo( int( 60_000_000 / $self->bpm ) );

    $self->score->control_change($self->channel, 91, $self->reverb);

    # Add a TS to the score but don't reset the beats if given
    $self->set_time_sig( $self->signature, !$args->{beats} );
}


has verbose   => ( is => 'ro', default => sub { 0 } );
has kit       => ( is => 'ro', default => sub { 0 } );
has reverb    => ( is => 'ro', default => sub { 15 } );
has channel   => ( is => 'ro', default => sub { 9 } );
has volume    => ( is => 'ro', default => sub { 100 } );
has bpm       => ( is => 'rw', default => sub { 120 } );
has file      => ( is => 'ro', default => sub { 'MIDI-Drummer.mid' } );
has bars      => ( is => 'ro', default => sub { 4 } );
has score     => ( is => 'ro', default => sub { MIDI::Simple->new_score } );
has signature => ( is => 'rw', default => sub { '4/4' });
has beats     => ( is => 'rw', default => sub { 4 }  );
has divisions => ( is => 'rw', default => sub { 4 } );
has counter   => ( is => 'rw', default => sub { 0 } );


has click          => ( is => 'ro', default => sub { 33 } );
has bell           => ( is => 'ro', default => sub { 34 } );
has kick           => ( is => 'ro', default => sub { 35 } ); # Alt: 36
has acoustic_bass  => ( is => 'ro', default => sub { 35 } );
has electric_bass  => ( is => 'ro', default => sub { 36 } );
has side_stick     => ( is => 'ro', default => sub { 37 } );
has snare          => ( is => 'ro', default => sub { 38 } ); # Alt: 40
has acoustic_snare => ( is => 'ro', default => sub { 38 } );
has electric_snare => ( is => 'ro', default => sub { 40 } );
has clap           => ( is => 'ro', default => sub { 39 } );
has open_hh        => ( is => 'ro', default => sub { 46 } );
has closed_hh      => ( is => 'ro', default => sub { 42 } );
has pedal_hh       => ( is => 'ro', default => sub { 44 } );
has crash1         => ( is => 'ro', default => sub { 49 } );
has crash2         => ( is => 'ro', default => sub { 57 } );
has splash         => ( is => 'ro', default => sub { 55 } );
has china          => ( is => 'ro', default => sub { 52 } );
has ride1          => ( is => 'ro', default => sub { 51 } );
has ride2          => ( is => 'ro', default => sub { 59 } );
has ride_bell      => ( is => 'ro', default => sub { 53 } );
has hi_tom         => ( is => 'ro', default => sub { 50 } );
has hi_mid_tom     => ( is => 'ro', default => sub { 48 } );
has low_mid_tom    => ( is => 'ro', default => sub { 47 } );
has low_tom        => ( is => 'ro', default => sub { 45 } );
has hi_floor_tom   => ( is => 'ro', default => sub { 43 } );
has low_floor_tom  => ( is => 'ro', default => sub { 41 } );
has tambourine     => ( is => 'ro', default => sub { 54 } );
has cowbell        => ( is => 'ro', default => sub { 56 } );
has vibraslap      => ( is => 'ro', default => sub { 58 } );
has hi_bongo       => ( is => 'ro', default => sub { 60 } );
has low_bongo      => ( is => 'ro', default => sub { 61 } );
has mute_hi_conga  => ( is => 'ro', default => sub { 62 } );
has open_hi_conga  => ( is => 'ro', default => sub { 63 } );
has low_conga      => ( is => 'ro', default => sub { 64 } );
has high_timbale   => ( is => 'ro', default => sub { 65 } );
has low_timbale    => ( is => 'ro', default => sub { 66 } );
has high_agogo     => ( is => 'ro', default => sub { 67 } );
has low_agogo      => ( is => 'ro', default => sub { 68 } );
has cabasa         => ( is => 'ro', default => sub { 69 } );
has maracas        => ( is => 'ro', default => sub { 70 } );
has short_whistle  => ( is => 'ro', default => sub { 71 } );
has long_whistle   => ( is => 'ro', default => sub { 72 } );
has short_guiro    => ( is => 'ro', default => sub { 73 } );
has long_guiro     => ( is => 'ro', default => sub { 74 } );
has claves         => ( is => 'ro', default => sub { 75 } );
has hi_wood_block  => ( is => 'ro', default => sub { 76 } );
has low_wood_block => ( is => 'ro', default => sub { 77 } );
has mute_cuica     => ( is => 'ro', default => sub { 78 } );
has open_cuica     => ( is => 'ro', default => sub { 79 } );
has mute_triangle  => ( is => 'ro', default => sub { 80 } );
has open_triangle  => ( is => 'ro', default => sub { 81 } );


has whole                         => (is => 'ro', default => sub { 'wn' });
has triplet_whole                 => (is => 'ro', default => sub { 'twn' });
has dotted_whole                  => (is => 'ro', default => sub { 'dwn' });
has double_dotted_whole           => (is => 'ro', default => sub { 'ddwn' });
has half                          => (is => 'ro', default => sub { 'hn' });
has triplet_half                  => (is => 'ro', default => sub { 'thn' });
has dotted_half                   => (is => 'ro', default => sub { 'dhn' });
has double_dotted_half            => (is => 'ro', default => sub { 'ddhn' });
has quarter                       => (is => 'ro', default => sub { 'qn' });
has triplet_quarter               => (is => 'ro', default => sub { 'tqn' });
has dotted_quarter                => (is => 'ro', default => sub { 'dqn' });
has double_dotted_quarter         => (is => 'ro', default => sub { 'ddqn' });
has eighth                        => (is => 'ro', default => sub { 'en' });
has triplet_eighth                => (is => 'ro', default => sub { 'ten' });
has dotted_eighth                 => (is => 'ro', default => sub { 'den' });
has double_dotted_eighth          => (is => 'ro', default => sub { 'dden' });
has sixteenth                     => (is => 'ro', default => sub { 'sn' });
has triplet_sixteenth             => (is => 'ro', default => sub { 'tsn' });
has dotted_sixteenth              => (is => 'ro', default => sub { 'dsn' });
has double_dotted_sixteenth       => (is => 'ro', default => sub { 'ddsn' });
has thirtysecond                  => (is => 'ro', default => sub { 'xn' });
has triplet_thirtysecond          => (is => 'ro', default => sub { 'txn' });
has dotted_thirtysecond           => (is => 'ro', default => sub { 'dxn' });
has double_dotted_thirtysecond    => (is => 'ro', default => sub { 'ddxn' });
has sixtyfourth                   => (is => 'ro', default => sub { 'yn' });
has triplet_sixtyfourth           => (is => 'ro', default => sub { 'tyn' });
has dotted_sixtyfourth            => (is => 'ro', default => sub { 'dyn' });
has double_dotted_sixtyfourth     => (is => 'ro', default => sub { 'ddyn' });
has onetwentyeighth               => (is => 'ro', default => sub { 'zn' });
has triplet_onetwentyeighth       => (is => 'ro', default => sub { 'tzn' });
has dotted_onetwentyeighth        => (is => 'ro', default => sub { 'dzn' });
has double_dotted_onetwentyeighth => (is => 'ro', default => sub { 'ddzn' });


sub note {
    my ($self, @spec) = @_;
    my $size = $spec[0] =~ /^d(\d+)$/ ? $1 / TICKS : dura_size($spec[0]);
    #warn __PACKAGE__,' L',__LINE__,' ',,"$spec[0] => $size\n";
    $self->counter( $self->counter + $size );
    return $self->score->n(@spec);
}


sub accent_note {
    my $self = shift;
    my $accent = shift;
    my $resume = $self->score->Volume;
    $self->score->Volume($accent);
    $self->note(@_);
    $self->score->Volume($resume);
}


sub rest {
    my ($self, @spec) = @_;
    my $size = $spec[0] =~ /^d(\d+)$/ ? $1 / TICKS : dura_size($spec[0]);
    #warn __PACKAGE__,' L',__LINE__,' ',,"$spec[0] => $size\n";
    $self->counter( $self->counter + $size );
    return $self->score->r(@spec);
}


sub count_in {
    my ($self, $args) = @_;

    my $bars  = $self->bars;
    my $patch = $self->closed_hh;

    if ($args && ref $args) {
        $bars  = $args->{bars}  if defined $args->{bars};
        $patch = $args->{patch} if defined $args->{patch};
    }
    else {
        $bars = $args; # given a simple integer
    }

    for my $i ( 1 .. $self->beats * $bars ) {
        $self->note( $self->quarter, $patch );
    }
}


sub metronome38 {
    my $self = shift;
    my $bars = shift || $self->bars;

    for ( 1 .. $bars ) {
        $self->note( $self->eighth, $self->closed_hh, $self->kick );
        $self->note( $self->eighth, $self->closed_hh);
        $self->note( $self->eighth, $self->closed_hh, $self->snare );
    }
}


sub metronome34 {
    my $self = shift;
    my $bars = shift || $self->bars;

    for ( 1 .. $bars ) {
        $self->note( $self->quarter, $self->ride1, $self->kick );
        $self->note( $self->quarter, $self->ride1 );
        $self->note( $self->quarter, $self->ride1, $self->snare );
    }
}


sub metronome44 {
    my $self = shift;
    my $bars = shift || $self->bars;
    my $flag = shift // 0;

    my $i = 0;

    for my $n ( 1 .. $self->beats * $bars ) {
        if ( $n % 2 == 0 )
        {
            $self->note( $self->quarter, $self->closed_hh, $self->snare );
        }
        else {
            if ( $flag == 0 )
            {
                $self->note( $self->quarter, $self->closed_hh, $self->kick );
            }
            else
            {
                if ( $i % 2 == 0 )
                {
                    $self->note( $self->quarter, $self->closed_hh, $self->kick );
                }
                else
                {
                    $self->note( $self->eighth, $self->closed_hh, $self->kick );
                    $self->note( $self->eighth, $self->kick );
                }
            }

            $i++;
        }
    }
}


sub metronome44swing {
    my $self = shift;
    my $bars = shift || $self->bars;

    for my $n ( 1 .. $bars ) {
        $self->note( $self->quarter,          $self->ride1, $self->kick );
        $self->note( $self->triplet_eighth,   $self->ride1 );
        $self->rest( $self->triplet_eighth );
        $self->note( $self->triplet_eighth,   $self->ride1, $self->kick );
        $self->note( $self->quarter,          $self->ride1, $self->snare );
        $self->note( $self->triplet_eighth,   $self->ride1, $self->kick );
        $self->rest( $self->triplet_eighth );
        $self->note( $self->triplet_eighth,   $self->ride1 );
    }
}


sub metronome54 {
    my $self = shift;
    my $bars = shift || $self->bars;
    for my $n (1 .. $bars) {
        $self->note($self->quarter, $self->closed_hh, $self->kick);
        $self->note($self->quarter, $self->closed_hh);
        $self->note($self->quarter, $self->closed_hh, $self->snare);
        $self->note($self->quarter, $self->closed_hh);
        if ($n % 2) {
            $self->note($self->quarter, $self->closed_hh);
        }
        else {
            $self->note($self->eighth, $self->closed_hh);
            $self->note($self->eighth, $self->kick);
        }
    }
}


sub metronome58 {
    my $self = shift;
    my $bars = shift || $self->bars;
    for my $n (1 .. $bars) {
        $self->note($self->eighth, $self->closed_hh, $self->kick);
        $self->note($self->eighth, $self->closed_hh);
        $self->note($self->eighth, $self->closed_hh, $self->snare);
        $self->note($self->eighth, $self->closed_hh);
        $self->note($self->eighth, $self->closed_hh);
    }
}


sub metronome68 {
    my $self = shift;
    my $bars = shift || $self->bars;
    for my $n (1 .. $bars) {
        $self->note($self->eighth, $self->closed_hh, $self->kick);
        $self->note($self->eighth, $self->closed_hh);
        $self->note($self->eighth, $self->closed_hh);
        $self->note($self->eighth, $self->closed_hh, $self->snare);
        $self->note($self->eighth, $self->closed_hh);
        $self->note($self->eighth, $self->closed_hh);
    }
}


sub metronome74 {
    my $self = shift;
    my $bars = shift || $self->bars;
    for my $n (1 .. $bars) {
        $self->note($self->quarter, $self->closed_hh, $self->kick);
        $self->note($self->quarter, $self->closed_hh);
        $self->note($self->quarter, $self->closed_hh, $self->snare);
        $self->note($self->eighth, $self->closed_hh);
        $self->note($self->eighth, $self->kick);
        $self->note($self->quarter, $self->closed_hh, $self->kick);
        $self->note($self->quarter, $self->closed_hh, $self->snare);
        $self->note($self->quarter, $self->closed_hh);
    }
}


sub metronome78 {
    my $self = shift;
    my $bars = shift || $self->bars;
    for my $n (1 .. $bars) {
        $self->note($self->eighth, $self->closed_hh, $self->kick);
        $self->note($self->eighth, $self->closed_hh);
        $self->note($self->eighth, $self->closed_hh);
        $self->note($self->eighth, $self->closed_hh, $self->kick);
        $self->note($self->eighth, $self->closed_hh, $self->snare);
        $self->note($self->eighth, $self->closed_hh);
        $self->note($self->eighth, $self->closed_hh);
    }
}


sub flam {
    my ($self, $spec, $grace, $patch, $accent) = @_;
    $grace ||= $self->snare;
    $patch ||= $self->snare;
    my $x = $MIDI::Simple::Length{$spec};
    my $y = $MIDI::Simple::Length{ $self->sixtyfourth };
    my $z = sprintf '%0.f', ($x - $y) * TICKS;
    $accent ||= sprintf '%0.f', $self->score->Volume / 2;
    if ($grace eq 'r') {
        $self->rest($self->sixtyfourth);
    }
    else {
        $self->accent_note($accent, $self->sixtyfourth, $grace);
    }
    $self->note('d' . $z, $patch);
}


sub roll {
    my ($self, $length, $spec, $patch) = @_;
    $patch ||= $self->snare;
    my $x = $MIDI::Simple::Length{$length};
    my $y = $MIDI::Simple::Length{$spec};
    my $z = sprintf '%0.f', $x / $y;
    $self->note($spec, $patch) for 1 .. $z;
}


sub crescendo_roll {
    my ($self, $span, $length, $spec, $patch) = @_;
    $patch ||= $self->snare;
    my ($i, $j, $k) = @$span;
    my $x = $MIDI::Simple::Length{$length};
    my $y = $MIDI::Simple::Length{$spec};
    my $z = sprintf '%0.f', $x / $y;
    if ($k) {
        my $bezier = Math::Bezier->new(
            1, $i,
            $z, $i,
            $z, $j,
        );
        for (my $n = 0; $n <= 1; $n += (1 / ($z - 1))) {
            my (undef, $v) = $bezier->point($n);
            $v = sprintf '%0.f', $v;
#            warn(__PACKAGE__,' ',__LINE__," $n INC: $v\n");
            $self->accent_note($v, $spec, $patch);
        }
    }
    else {
        my $v = sprintf '%0.f', ($j - $i) / ($z - 1);
#        warn(__PACKAGE__,' ',__LINE__," VALUE: $v\n");
        for my $n (1 .. $z) {
            if ($n == $z) {
                if ($i < $j) {
                    $i += $j - $i;
                }
                elsif ($i > $j) {
                    $i -= $i - $j;
                }
            }
#            warn(__PACKAGE__,' ',__LINE__," $n INC: $i\n");
            $self->accent_note($i, $spec, $patch);
            $i += $v;
        }
    }
}


sub pattern {
    my ( $self, %args ) = @_;

    $args{instrument} ||= $self->snare;
    $args{patterns}   ||= [];
    $args{beats}      ||= $self->beats;
    $args{negate}     ||= 0;
    $args{repeat}     ||= 1;

    return unless @{ $args{patterns} };

    # set size and duration
    my $size;
    if ( $args{duration} ) {
        $size = dura_size( $args{duration} ) || 1;
    }
    else {
        $size = 4 / length( $args{patterns}->[0] );
        my $dump = reverse_dump('length');
        $args{duration} = $dump->{$size} || $self->quarter;
    }

    # set the default beat-string variations
    $args{vary} ||= {
        0 => sub { $self->rest( $args{duration} ) },
        1 => sub { $self->note( $args{duration}, $args{instrument} ) },
    };

    set_chan_patch( $self->score, $self->channel, $args{instrument} );

    for my $pattern (@{ $args{patterns} }) {
        next if $pattern =~ /^0+$/;

        $pattern =~ tr/01/10/ if $args{negate};

        for ( 1 .. $args{repeat} ) {
            for my $bit ( split //, $pattern ) {
                $args{vary}{$bit}->($self);
            }
        }
    }
}


sub sync_patterns {
    my ($self, %patterns) = @_;

    my $master_duration = delete $patterns{duration};

    my @subs;
    for my $instrument (keys %patterns) {
        push @subs, sub {
            $self->pattern(
                instrument => $instrument,
                patterns   => $patterns{$instrument},
                $master_duration ? (duration => $master_duration) : (),
            );
        },
    }

    $self->sync(@subs);
}


sub add_fill {
    my ($self, $fill, %patterns) = @_;

    $fill ||= sub {
        return {
            duration       => 8,
            $self->open_hh => '000',
            $self->snare   => '111',
            $self->kick    => '000',
        };
    };
    my $fill_patterns = $fill->($self);
    print 'Fill: ', ddc($fill_patterns) if $self->verbose;
    my $fill_duration = delete $fill_patterns->{duration} || 8;
    my $fill_length   = length((values %$fill_patterns)[0]);

    my %lengths;
    for my $instrument (keys %patterns) {
        $lengths{$instrument} = sum0 map { length $_ } @{ $patterns{$instrument} };
    }

    my $lcm = _multilcm($fill_duration, values %lengths);
    print "LCM: $lcm\n" if $self->verbose;

    my $size = 4 / $lcm;
    my $dump = reverse_dump('length');
    my $master_duration = $dump->{$size} || $self->eighth; # XXX this || is not right
    print "Size: $size, Duration: $master_duration\n" if $self->verbose;

    my $fill_chop = $fill_duration == $lcm
        ? $fill_length
        : int($lcm / $fill_length) + 1;
    print "Chop: $fill_chop\n" if $self->verbose;

    my %fresh_patterns;
    for my $instrument (keys %patterns) {
        # get a single "flattened" pattern as an arrayref
        my $pattern = [ map { split //, $_ } @{ $patterns{$instrument} } ];
        # the fresh pattern is possibly upsized with the LCM
        $fresh_patterns{$instrument} = @$pattern < $lcm
            ? [ join '', @{ upsize($pattern, $lcm) } ]
            : [ join '', @$pattern ];
    }
    print 'Patterns: ', ddc(\%fresh_patterns) if $self->verbose;

    my %replacement;
    for my $instrument (keys %$fill_patterns) {
        # get a single "flattened" pattern as a zero-pre-padded arrayref
        my $pattern = [ split //, sprintf '%0*s', $fill_duration, $fill_patterns->{$instrument} ];
        # the fresh pattern string is possibly upsized with the LCM
        my $fresh = @$pattern < $lcm
            ? join '', @{ upsize($pattern, $lcm) }
            : join '', @$pattern;
        # the replacement string is the tail of the fresh pattern string
        $replacement{$instrument} = substr $fresh, -$fill_chop;
    }
    print 'Replacements: ', ddc(\%replacement) if $self->verbose;

    my %replaced;
    for my $instrument (keys %fresh_patterns) {
        # get the string to replace
        my $string = join '', @{ $fresh_patterns{$instrument} };
        # replace the tail of the string
        my $pos = length $replacement{$instrument};
        substr $string, -$pos, $pos, $replacement{$instrument};
        print "$instrument: $string\n" if $self->verbose;
        # prepare the replaced pattern for syncing
        $replaced{$instrument} = [ $string ];
    }

    $self->sync_patterns(
        %replaced,
        duration => $master_duration,
    );

    return \%replaced;
}


sub set_time_sig {
    my ($self, $signature, $set) = @_;
    $self->signature($signature) if $signature;
    $set //= 1;
    if ($set) {
        my ($beats, $divisions) = split /\//, $self->signature;
        $self->beats($beats);
        $self->divisions($divisions);
    }
    set_time_signature($self->score, $self->signature);
}


sub set_bpm {
    my ($self, $bpm) = @_;
    $self->bpm($bpm);
    $self->score->set_tempo( int( 60_000_000 / $self->bpm ) );
}


sub sync {
    my $self = shift;
    $self->score->synch(@_);
}


sub write {
    my $self = shift;
    $self->score->write_score( $self->file );
}

# lifted from https://www.perlmonks.org/?node_id=56906
sub _gcf {
    my ($x, $y) = @_;
    ($x, $y) = ($y, $x % $y) while $y;
    return $x;
}
sub _lcm {
    return($_[0] * $_[1] / _gcf($_[0], $_[1]));
}
sub _multilcm {
    my $x = shift;
    $x = _lcm($x, shift) while @_;
    return $x;
}

1;

__END__