File Coverage

blib/lib/MIDI/Drummer/Tiny/Grooves.pm

Criterion	Covered	Total	%
statement	74	84	88.1
branch	21	28	75.0
condition	3	5	60.0
subroutine	23	25	92.0
pod	4	4	100.0
total	125	146	85.6

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

use Moo;
use strictures 2;
# use Data::Dumper::Compact qw(ddc);
use File::ShareDir qw(dist_dir);
use Path::Tiny;
use MIDI::Drummer::Tiny ();
use namespace::clean;

#pod =head1 SYNOPSIS
#pod
#pod   use MIDI::Drummer::Tiny ();
#pod   use MIDI::Drummer::Tiny::Grooves ();
#pod   # TODO use MIDI::Drummer::Tiny::Grooves qw(:house :rock); # maybe
#pod
#pod   my $drummer = MIDI::Drummer::Tiny->new(
#pod     file => "grooves.mid",
#pod     kick => 36,
#pod   );
#pod
#pod   my $grooves = MIDI::Drummer::Tiny::Grooves->new(
#pod     drummer => $drummer
#pod   );
#pod
#pod   my $all = $grooves->all_grooves;
#pod
#pod   my $groove = $grooves->get_groove;  # random groove
#pod   $groove = $grooves->get_groove(42); # numbered groove
#pod   print "42. $groove->{cat}\n$groove->{name}";
#pod   $grooves->groove(%{ $groove->{groove} }) for 1 .. 4; # add to score
#pod
#pod   my $set = $grooves->search({ cat => 'house' });
#pod   my $pattern = $set->{27}{groove}; # { kick => '...', }
#pod   $set = $grooves->search({ name => 'deep' }, $set); # refine search
#pod
#pod   for my $i (sort keys %$set) {
#pod     $groove = $set->{$i};
#pod     print "$i. $groove->{cat}\n$groove->{name}]\n";
#pod     $grooves->groove(%{ $groove->{groove} }); # a bit redundant!
#pod   }
#pod
#pod   $grooves->drummer->write;
#pod   # then:
#pod   # > timidity grooves.mid
#pod
#pod =head1 DESCRIPTION
#pod
#pod Return the common grooves, as listed in the "Pocket Operations", that
#pod are L. There are a total of 269 known drum
#pod patterns.
#pod
#pod A groove is a numbered and named hash reference, with the following
#pod structure:
#pod
#pod   1 => {
#pod       cat  => "Basic Patterns",
#pod       name => "ONE AND SEVEN & FIVE AND THIRTEEN",
#pod       groove => sub {
#pod           $self->groove(
#pod               kick  => { num => $self->kick,  pat => ['1000001000000000'] },
#pod               snare => { num => $self->snare, pat => ['0000100000001000'] },
#pod               ...
#pod           );
#pod       },
#pod   },
#pod   2 => { ... }, ... }
#pod
#pod =cut

#pod =head1 ACCESSORS
#pod
#pod =head2 drummer
#pod
#pod   $drummer = $grooves->drummer;
#pod   $grooves->drummer($drummer);
#pod
#pod The L object. If not given in the constructor, a
#pod new one is created when a method is called.
#pod
#pod =cut

has drummer => (
  is      => 'rw',
  isa     => sub { die "Invalid drummer object" unless ref($_[0]) eq 'MIDI::Drummer::Tiny' },
  default => sub { MIDI::Drummer::Tiny->new },
);

#pod =head2 duration
#pod
#pod   $duration = $grooves->duration;
#pod   $grooves->duration($duration);
#pod
#pod The "resolution" duration that is given to the
#pod L method.
#pod
#pod This is initialized to the sixteenth duration of the drummer
#pod L object.
#pod
#pod =cut

has duration => (
    is => 'lazy',
);
sub _build_duration { shift->drummer->sixteenth }

#pod =head2 kick, rimshot, snare, clap, conga, cowbell, shaker, closed, open, cymbal, hi_tom, mid_tom, low_tom
#pod
#pod   $kick = $grooves->kick;
#pod   $grooves->kick(36);
#pod
#pod The drum patches that are used by the grooves.
#pod
#pod Each is initialized to a corresponding patch of the drummer
#pod L object that is given to, or created by the
#pod constructor.
#pod
#pod =cut

#pod =head2 return_patterns
#pod
#pod   $return_patterns = $grooves->return_patterns;
#pod
#pod Either return the raw patterns of 16 beats or C'ed B
#pod object phrases from the B method.
#pod
#pod Default: C<0>
#pod
#pod =cut

has return_patterns => (
  is      => 'rw',
  isa     => sub { die "Not a Boolean" unless $_[0] =~ /^[01]$/ },
  default => sub { 0 },
);

has _grooves => (
    is      => 'lazy',
    builder => '_build__grooves',
);
sub _build__grooves {
    my ($self) = @_;
    my %mapping = (
        BD => 'kick',
        SN => 'snare',
        RS => 'rimshot',
        CH => 'closed',
        OH => 'open',
        CY => 'cymbal',
        CB => 'cowbell',
        CL => 'clap',
        SH => 'shaker',
        HT => 'hi_tom',
        MT => 'mid_tom',
        LT => 'low_tom',
        HC => 'conga',
    );
    my $file = '/drum-pattern-bit-strings.txt';
    my $path = dist_dir('MIDI-Drummer-Tiny') . $file;
    $path = 'share' . $file unless -e $path;
    my @contents = path($path)->lines;
    my (%grooves, $cat, $name, %patterns);
    my $i = 0;
    for my $line (@contents) {
        chomp $line;
        chop $line if $line =~ /\r$/;
        if ($line =~ /^Instrument/) {
            next;
        }
        elsif ($line =~ /^([A-Z][A-Z]),([01]+)$/) {
            my $mapping = $mapping{$1} || next;
            my $val = { num => $self->$mapping, pat => [$2] };
            $patterns{$mapping} = $val;
        }
        elsif ($line =~ /^\* (.+)$/) {
            $cat = $1;
        }
        else {
            if (keys %patterns) {
                # print ddc \%patterns;
                $grooves{++$i} = {
                    cat    => $cat,
                    name   => $name,
                    groove => { %patterns },
                };
            }
            %patterns = ();
            $name = $line;
        }
    }
    # print ddc \%grooves;
    return \%grooves;
}

for my $patch (qw(
    kick
    rimshot
    snare
    clap
    conga
    cowbell
    shaker
    closed
    open
    cymbal
    hi_tom
    mid_tom
    low_tom
)) {
    has $patch => (
        is      => 'lazy',
        builder => '_build_' . $patch,
    );
}
sub _build_kick    { shift->drummer->kick }
sub _build_rimshot { shift->drummer->side_stick }
sub _build_snare   { shift->drummer->snare }
sub _build_clap    { shift->drummer->clap }
sub _build_conga   { shift->drummer->open_hi_conga }
sub _build_cowbell { shift->drummer->cowbell }
sub _build_shaker  { shift->drummer->maracas }
sub _build_closed  { shift->drummer->closed_hh }
sub _build_open    { shift->drummer->open_hh }
sub _build_cymbal  { shift->drummer->crash1 }
sub _build_hi_tom  { shift->drummer->hi_mid_tom }
sub _build_mid_tom { shift->drummer->low_mid_tom }
sub _build_low_tom { shift->drummer->low_tom }

#pod =head1 METHODS
#pod
#pod =head2 new
#pod
#pod   $grooves = MIDI::Drummer::Tiny::Grooves->new;
#pod   $grooves = MIDI::Drummer::Tiny::Grooves->new(%arguments);
#pod
#pod Return a new C object.
#pod
#pod =head2 get_groove
#pod
#pod   $groove = $grooves->get_groove($groove_number);
#pod   $groove = $grooves->get_groove; # random groove
#pod   $groove = $grooves->get_groove(0, $set); # random groove of set
#pod   $groove = $grooves->get_groove($groove_number, $set); # numbered groove of set
#pod
#pod Return a numbered or random groove from either the given B or
#pod all known grooves.
#pod
#pod =cut

sub get_groove {
    my ($self, $groove_number, $set) = @_;
    unless (keys %$set) {
        $set = $self->all_grooves;
    }
    unless ($groove_number) {
        my @keys = keys %$set;
        $groove_number = $keys[ int rand @keys ];
    }
    return $set->{$groove_number};
}

#pod =head2 all_grooves
#pod
#pod   $all = $grooves->all_grooves;
#pod
#pod Return all the known grooves as a hash reference.
#pod
#pod =cut

sub all_grooves {
    my ($self) = @_;
    return $self->_grooves();
}

#pod =head2 search
#pod
#pod   $set = $grooves->search({ cat => $x, name => $y }); # search all grooves
#pod   $set = $grooves->search({ cat => $x, name => $y }, $set); # search a subset
#pod
#pod Return the found grooves with names matching the B or B
#pod strings and given an optional set of grooves to search in.
#pod
#pod =cut

sub search {
    my ($self, $args, $set) = @_;
    unless ($set && keys %$set) {
        $set = $self->all_grooves;
    }
    my $found = {};
    if ($args->{cat}) {
        my $string = lc $args->{cat};
        for my $k (keys %$set) {
            if (lc($set->{$k}{cat}) =~ /$string/) {
                $found->{$k} = $set->{$k};
            }
        }
    }
    if ($args->{name}) {
        my $string = lc $args->{name};
        for my $k (keys %$set) {
            if (lc($set->{$k}{name}) =~ /$string/) {
                $found->{$k} = $set->{$k};
            }
        }
    }
    return $found;
}

#pod =head2 groove
#pod
#pod   $self->groove(%patterns);
#pod
#pod Add the patterns to the score. If the B attribute is
#pod on, the patterns are just returned.
#pod
#pod =cut

sub groove {
    my ($self, %patterns) = @_;
    if ($self->return_patterns) {
        return map { $_ => [ split '', $patterns{$_}{pat}[0] ] } keys %patterns;
    }
    else {
        $self->drummer->sync_patterns(
            (map { $patterns{$_}{num} => $patterns{$_}{pat} } keys %patterns),
            duration => $self->duration,
        );
    }
}

1;

__END__