File Coverage

blib/lib/MIDI/Simple/Drummer.pm

Criterion	Covered	Total	%
statement	208	230	90.4
branch	84	108	77.7
condition	26	43	60.4
subroutine	52	57	91.2
pod	43	43	100.0
total	413	481	85.8

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

# ABSTRACT: An algorithmic MIDI drummer

our $VERSION = '0.0813';

use strict;
use warnings;

use MIDI::Simple ();
use Music::Duration ();

BEGIN {
    # Define a division structure to use for durations.
    use constant DIVISION => {
        w => { number =>   1, ordinal =>   '1st', name => 'whole' },
        h => { number =>   2, ordinal =>   '2nd', name => 'half' },
        q => { number =>   4, ordinal =>   '4th', name => 'quarter' },
        e => { number =>   8, ordinal =>   '8th', name => 'eighth' },
        s => { number =>  16, ordinal =>  '16th', name => 'sixteenth' },
        x => { number =>  32, ordinal =>  '32nd', name => 'thirtysecond' },
        y => { number =>  64, ordinal =>  '64th', name => 'sixtyfourth' },
        z => { number => 128, ordinal => '128th', name => 'onetwentyeighth' },
    };

    # Add constants for each known duration.
    for my $n (keys %MIDI::Simple::Length) {
        # Get the duration part of the note name.
        my $name = $n =~ /([whqesxyz])n$/ ? $1 : '';

        if ($name) {
            # Create a meaningful prefix for the named constant.
            my $prefix = '';
            $prefix .= 'triplet'       if $n =~ /t\w/;
            $prefix .= 'double_dotted' if $n =~ /^dd/;
            $prefix .= 'dotted'        if $n =~ /^d[^d]/;
            $prefix .= '_' if $prefix;

            # Add name-based duration.
            my $key = uc($prefix . DIVISION->{$name}{name});
            constant->import($key => $n); # LeoNerd++ clue
            # Add a _prefix for numeric duration constants.
            $prefix .= '_' unless $prefix;
            # Add number-based duration.
            $key = uc($prefix . DIVISION->{$name}{ordinal});
            constant->import($key => $n);
        }
        else {
            warn "ERROR: Unknown note value '$n' - Skipping."
        }
    }
}

sub new { # Is there a drummer in the house?
    my $class = shift;
    # Our drummer is a set of attributes.
    my $self  = {
        # MIDI
        -channel    => 9,
        -volume     => 100,
        -pan        => 64,
        -pan_width  => 0,
        -patch      => 0,
        -reverb     => 20,
        -chorus     => 0,
        # Rhythm
        -accent     => 30,
        -bpm        => 120,
        -phrases    => 4,
        -bars       => 4,
        -beats      => 4,
        -divisions  => 4,
        -signature  => '',
        # The Goods™
        -score      => undef,
        -file       => 'Drummer.mid',
        -kit        => undef,
        -patterns   => undef,
        @_  # Capture any override or extra arguments.
    };

    # Make our drummer a proper object.
    bless $self, $class;

    # Perform any pre-flight default setting.
    $self->_setup;

    return $self;
}

sub _setup { # Where's my roadies, Man?
    my $self = shift;

    # Give unto us, a score with which to fondle.
    $self->{-score} ||= MIDI::Simple->new_score;
    $self->{-score}->noop('c'.$self->{-channel}, 'V'.$self->{-volume});
    $self->{-score}->set_tempo(int(60_000_000 / $self->{-bpm}));

    # Give unto us a drum, so that we might bang upon it all day, instead of working.
    $self->{-kit} ||= $self->_default_kit;
    $self->{-patterns} ||= $self->_default_patterns;

    # Set the groove dimensions if a time signature is given.
    if ($self->{-signature}) {
        $self->signature($self->{-signature});
    }
    else {
        # If no signature is provided, assume 4/4.
        $self->{-beats}     ||= 4;
        $self->{-divisions} ||= 4;
        $self->{-signature} = "$self->{-beats}/$self->{-divisions}";
    }

    $self->{-score}->time_signature(
        $self->{-beats},
        sqrt( $self->{-divisions} ),
        ( $self->{-divisions} == 8 ? 24 : 18 ),
        8
    );

    # Reset the backbeat if the signature is a 3 multiple.
    my $x = $self->{-beats} / 3;
    if ($x !~ /\./) {
        $self->backbeat('Acoustic Bass Drum', 'Acoustic Snare', 'Acoustic Bass Drum');
    }

    # Set the method name for the division metric. Ex: QUARTER for 4.
    for my $note (keys %{+DIVISION}) {
        if (DIVISION->{$note}{number} == $self->{-divisions}) {
            $self->div_name(uc DIVISION->{$note}{name});
        }
    }

    # Set effects.
    $self->reverb;
    $self->chorus;
    $self->pan_width;

    return $self;
}

# Convenience functions:
sub _durations { return \%MIDI::Simple::Length }
sub _n2p { return \%MIDI::notenum2percussion }
sub _p2n { return \%MIDI::percussion2notenum }

# Accessors:
sub channel { # The general MIDI drumkit is often channel 9.
    my $self = shift;
    $self->{-channel} = shift if @_;
    return $self->{-channel};
}
sub patch { # Drum kit
    my $self = shift;
    $self->{-patch} = shift if @_;
    $self->{-score}->patch_change($self->{-channel}, $self->{-patch});
    return $self->{-patch};
}
sub reverb { # [0 .. 127]
    my $self = shift;
    $self->{-reverb} = shift if @_;
    $self->{-score}->control_change($self->{-channel}, 91, $self->{-reverb});
    return $self->{-reverb};
}
sub chorus { # [0 .. 127]
    my $self = shift;
    $self->{-chorus} = shift if @_;
    $self->{-score}->control_change($self->{-channel}, 93, $self->{-chorus});
    return $self->{-chorus};
}
sub pan { # [0 Left-Middle-Right 127]
    my $self = shift;
    $self->{-pan} = shift if @_;
    $self->{-score}->control_change($self->{-channel}, 10, $self->{-pan});
    return $self->{-pan};
}
sub pan_width { # [0 .. 64] from center
    my $self = shift;
    $self->{-pan_width} = shift if @_;
    return $self->{-pan_width};
}
sub bpm { # Beats per minute
    my $self = shift;
    $self->{-bpm} = shift if @_;
    return $self->{-bpm};
}
sub volume { # TURN IT DOWN IN THERE!
    my $self = shift;
    $self->{-volume} = shift if @_;
    return $self->{-volume};
}
sub phrases { # o/` How many more times? Treat me the way you wanna do?
    my $self = shift;
    $self->{-phrases} = shift if @_;
    return $self->{-phrases};
}
sub bars { # Number of measures
    my $self = shift;
    $self->{-bars} = shift if @_;
    return $self->{-bars};
}
sub beats { # Beats per measure
    my $self = shift;
    $self->{-beats} = shift if @_;
    return $self->{-beats};
}
sub divisions { # The division of the measure that is "the pulse."
    my $self = shift;
    $self->{-divisions} = shift if @_;
    return $self->{-divisions};
}
sub signature { # The ratio of discipline
    my $self = shift;
    if (@_) {
        # Set the argument to the signature string.
        $self->{-signature} = shift;
        # Set the rhythm metrics.
        ($self->{-beats}, $self->{-divisions}) = split /\//, $self->{-signature}, 2;
    }
    return $self->{-signature};
}
sub div_name { # The name of the denominator of the time signature.
    my $self = shift;
    $self->{-div_name} = shift if @_;
    return $self->{-div_name};
}
sub file { # The name of the MIDI file output
    my $self = shift;
    $self->{-file} = shift if @_;
    return $self->{-file};
}

sub score { # The MIDI::Simple score with no-op-ability
    my $self = shift;

    # If we are presented with a M::S object, assign it as the score.
    $self->{-score} = shift if ref $_[0] eq 'MIDI::Simple';

    # Set any remaining arguments as score no-ops.
    $self->{-score}->noop($_) for @_;

    return $self->{-score};
}

sub accent_note { # Accent a single note.
    my $self = shift;
    my $note = shift;
    $self->score('V' . $self->accent); # Accent!
    $self->note($note, $self->strike);
    $self->score('V' . $self->volume); # Reset the note volume.
}

# API: Subclass and redefine to emit nuance.
sub accent { # Pump up the Volume!
    my $self = shift;
    $self->{-accent} = shift if @_;

    # Add a bit of volume.
    my $accent = $self->{-accent} + $self->volume;
    # But don't try to go above the top.
    $accent = $MIDI::Simple::Volume{fff}
        if $accent > $MIDI::Simple::Volume{fff};

    # Hand back the new volume.
    return $accent;
}
# API: Subclass and redefine to emit nuance.
sub duck { # Drop the volume.
    my $self = shift;
    $self->{-accent} = shift if @_;

    # Subtract a bit of volume.
    my $duck = $self->volume - $self->{-accent};
    # But don't try to go below the bottom.
    $duck = $MIDI::Simple::Volume{ppp}
        if $duck > $MIDI::Simple::Volume{ppp};

    # Hand back the new volume.
    return $duck;
}

sub kit { # Arrayrefs of patches
    my $self = shift;
    return $self->_type('-kit', @_);
}
sub patterns { # Coderefs of patterns
    my $self = shift;
    return $self->_type('-patterns', @_);
}

sub _type { # Both kit and pattern access
    my $self = shift;
    my $type = shift || return;

    if (!@_) { # If there are no arguments, return all known types.
        return $self->{$type};
    }
    elsif (@_ == 1) { # Return a single named type with either name=>value or just value.
        my $i = shift;
        return wantarray
            ? ($i => $self->{$type}{$i})
            : $self->{$type}{$i};
    }
    elsif (@_ > 1 && !(@_ % 2)) { # Add new types if given an even list.
        my %args = @_;
        my @t = ();

        while (my ($i, $v) = each %args) {
            $self->{$type}{$i} = $v;
            push @t, $i;
        }
        # Return the named types.
        return wantarray
            ? (map { $_ => $self->{$type}{$_} } @t) # Hash of named types.
            : @t > 1                                # More than one?
                ? [map { $self->{$type}{$_} } @t]   # Arrayref of types.
                : $self->{$type}{$t[0]};            # Else single type.
    }
    else { # Unlikely to ever be triggered.
        warn 'WARNING: Mystery arguments. Giving up.';
    }
}

sub name_of { # Return instrument name(s) given kit keys.
    my $self = shift;
    my $key  = shift || return;
    return wantarray
        ? @{$self->kit($key)} # List of names
        : join ',', @{$self->kit($key)}; # CSV of names
}

sub _set_get { # Internal kit access
    my $self = shift;
    my $key  = shift || return;

    # Set the kit event.
    $self->kit($key => [@_]) if @_;

    return $self->option_strike(@{$self->kit($key)});
}

# API: Add other keys to your kit & patterns, in a subclass.
sub backbeat { return shift->_set_get('backbeat', @_) }
sub snare    { return shift->_set_get('snare', @_) }
sub kick     { return shift->_set_get('kick', @_) }
sub tick     { return shift->_set_get('tick', @_) }
sub hhat     { return shift->_set_get('hhat', @_) }
sub crash    { return shift->_set_get('crash', @_) }
sub ride     { return shift->_set_get('ride', @_) }
sub tom      { return shift->_set_get('tom', @_) }

sub strike { # Return note values.
    my $self = shift;

    # Set the patches, default snare.
    my @patches = @_ ? @_ : @{$self->kit('snare')};

    # Build MIDI::Simple note names from the patch numbers.
    my @notes = map { 'n' . $MIDI::percussion2notenum{$_} } @patches;

    return wantarray ? @notes : join(',', @notes);
}
# API: Redefine this method to use a different decision than rand().
sub option_strike { # When in doubt, crash.
    my $self = shift;

    # Set the patches, default crashes.
    my @patches = @_ ? @_ : @{$self->kit('crash')};

    # Choose a random patch!
    return $self->strike($patches[int(rand @patches)]);
}

sub rotate { # Rotate through a list of patches.
    my $self    = shift;
    my $beat    = shift || 1; # Assume that we are on the first beat if none is given.
    my $patches = shift || $self->kit('backbeat'); # Default backbeat.

    # Strike a note from the patches, based on the beat.
    return $self->strike($patches->[$beat % @$patches]);
}
sub backbeat_rhythm { # AC/DC forever
    # Rotate the backbeat with tick & post-fill strike.
    my $self = shift;

    # Set the default parameters with an argument override.
    my %args = (
        -beat => 1,
        -fill => 0,
        -backbeat => scalar $self->kit('backbeat'),
        -tick => scalar $self->kit('tick'),
        -patches => scalar $self->kit('crash'),
        @_  # Capture any override or extra arguments.
    );

    # Strike a cymbal or use the provided patches.
    my $c = $args{-beat} == 1 && $args{-fill}
        ? $self->option_strike(@{$args{-patches}})
        : $self->strike(@{$args{-tick}});

    # Rotate the backbeat.
    my $n = $self->rotate($args{-beat}, $args{-backbeat});

    # Return the cymbal and backbeat note.
    return wantarray ? ($n, $c) : join(',', $n, $c);
}

# Readable, MIDI score pass-throughs.
sub note {
    my $self = shift;
#use Data::Dumper;warn Data::Dumper->new([@_])->Indent(1)->Terse(1)->Sortkeys(1)->Dump;
    return $self->{-score}->n(@_)
}
sub rest { return shift->{-score}->r(@_) }

sub count_in { # And-a one, and-a two...
    my $self = shift;
    my $bars = shift || 1; # Assume that we are on the first bar if none is given.
    my $div  = $self->div_name;

    # Define the note to strike with the given patch. Default 'tick' patch.
    my $strike = @_ ? $self->strike(@_) : $self->tick;

    # Play the number of bars with a single strike.
    for my $i (1 .. $self->beats * $bars) {
        # Accent if we are on the first beat.
        $self->score('V'.$self->accent) if $i % $self->beats == 1;

        # Add a note to the score.
        $self->note($self->$div, $strike);

        # Reset the note volume if we just played the first beat.
        $self->score('V'.$self->volume) if $i % $self->beats == 1;
    }

    # Hand back the note we just used.
    return $strike;
}
sub metronome { # Keep time with a single patch. Default: Pedal Hi-Hat
    my $self = shift;
    # A metronome is just a count-in over the number of phrases
    return $self->count_in($self->phrases, shift || 'Pedal Hi-Hat');
}

sub beat { # Pattern selector method
    my $self = shift;
    # Receive or default arguments.
    my %args = (
        -name => 0, # Provide a pattern name
        -fill => 0, # Provide a fill pattern name
        -last => 0, # Is this the last beat?
        -type => '', # Is this a fill if not named in -fill?
        -time => $self->QUARTER, # Default duration is a quarter note.
        @_
    );

    # Bail out unless we have a proper repertoire.
    return undef unless ref($self->patterns) eq 'HASH';

    # Get the names of the known patterns.
    my @k = keys %{$self->patterns};
    # Bail out if we know nothing.
    return undef unless @k;

    # Do we want a certain type that isn't already in the given name?
    my $n = $args{-name} && $args{-type} && $args{-name} !~ /^.+\s+$args{-type}$/
          ? "$args{-name} $args{-type}" : $args{-name};

    if (@k == 1) { # Return the pattern if there is only one.
        $n = $k[0];
    }
    else { # Otherwise choose a different pattern.
        while ($n eq 0 || $n eq $args{-last}) {
            # TODO API: Allow custom decision method.
            $n = $k[int(rand @k)];
            if ($args{-type}) {
                (my $t = $n) =~ s/^.+\s+($args{-type})$/$1/;
                # Skip if this is not a type for which we are looking.
                $n = 0 unless $t eq $args{-type};
            }
        }
    }

    # Beat it - i.e. add the pattern to the score.
    $self->{-patterns}{$n}->($self, %args);
    # Return the beat note.
    return $n;
}
sub fill {
    my $self = shift;
    # Add the beat pattern to the score.
    return $self->beat(@_, -type => 'fill');
}

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

sub write { # You gotta get it out there, you know. Make some buzz, Man.
    my $self = shift;

    # Set the file if provided or use the default.
    my $file = shift || $self->{-file};

    # Write the score to the file!
    $self->{-score}->write_score($file);

    # Return the filename if it was created or zero if not.
    # XXX Check file-size not existance.
    return -e $file ? $file : 0;
}

# API: Redefine these methods in a subclass.
sub _default_kit {
    my $self = shift;
    # Hand back a set of instruments as lists of GM named patches.
    return {
      backbeat => ['Acoustic Snare', 'Acoustic Bass Drum'],
      snare => ['Acoustic Snare'],     # 38
      kick  => ['Acoustic Bass Drum'], # 35
      tick  => ['Closed Hi-Hat'],
      hhat  => ['Closed Hi-Hat',  # 42
                'Open Hi-Hat',    # 46
                'Pedal Hi-Hat',   # 44
      ],
      crash => ['Chinese Cymbal', # 52
                'Crash Cymbal 1', # 49
                'Crash Cymbal 2', # 57
                'Splash Cymbal',  # 55
      ],
      ride  => ['Ride Bell',      # 53
                'Ride Cymbal 1',  # 51
                'Ride Cymbal 2',  # 59
      ],
      tom   => ['High Tom',       # 50
                'Hi-Mid Tom',     # 48
                'Low-Mid Tom',    # 47
                'Low Tom',        # 45
                'High Floor Tom', # 43
                'Low Floor Tom',  # 41
      ],
  };
}
# There are no known patterns. We are a wannabe at this point.
sub _default_patterns {
    my $self = shift;
    return {};
}

1;

__END__