File Coverage

blib/lib/MIDI/Ngram.pm

Criterion	Covered	Total	%
statement	251	283	88.6
branch	56	84	66.6
condition	15	33	45.4
subroutine	23	26	88.4
pod	6	6	100.0
total	351	432	81.2

package MIDI::Ngram;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: Find the top repeated note phrases of MIDI files

our $VERSION = '0.1807';

use Moo;
use strictures 2;
use namespace::clean;

use Carp;
use Lingua::EN::Ngram;
use List::Util qw( shuffle uniq );
use List::Util::WeightedChoice qw( choose_weighted );
use MIDI::Util qw(setup_score set_chan_patch);
use Music::Note;


has in_file => (
    is       => 'ro',
    isa      => \&_is_list,
    required => 1,
);


has ngram_size => (
    is      => 'ro',
    isa     => \&_is_integer,
    default => sub { 2 },
);


has min_phrases => (
    is      => 'ro',
    isa     => \&_is_integer,
    default => sub { 2 },
);


has max_phrases => (
    is      => 'ro',
    isa     => \&_is_integer0,
    default => sub { 0 },
);


has bpm => (
    is      => 'ro',
    isa     => \&_is_integer,
    default => sub { 100 },
);


has durations => (
    is      => 'ro',
    isa     => \&_is_list,
    default => sub { [] },
);


has patches => (
    is      => 'ro',
    isa     => \&_is_list,
    default => sub { [ 0 .. 127 ] },
);


has random_patch => (
    is      => 'ro',
    isa     => \&_is_boolean,
    default => sub { 0 },
);


has out_file => (
    is      => 'ro',
    default => sub { 'midi-ngram.mid' },
);


has pause_duration => (
    is      => 'ro',
    isa     => sub { croak 'Invalid duration' unless $_[0] eq '' || $_[0] =~ /^[a-z]+$/ },
    default => sub { '' },
);


has analyze => (
    is  => 'ro',
    isa => \&_is_list,
);


has loop => (
    is      => 'ro',
    isa     => \&_is_integer,
    default => sub { 10 },
);


has weight => (
    is      => 'ro',
    isa     => \&_is_boolean,
    default => sub { 0 },
);


has shuffle_phrases => (
    is      => 'ro',
    isa     => \&_is_boolean,
    default => sub { 0 },
);


has one_channel => (
    is      => 'ro',
    isa     => \&_is_boolean,
    default => sub { 0 },
);


has score => (
    is       => 'rw',
    init_arg => undef,
    lazy     => 1,
);

has _opus_ticks => (
    is => 'rw',
);


has dura_notes => (
    is       => 'ro',
    init_arg => undef,
    default  => sub { {} },
);


has notes => (
    is       => 'ro',
    init_arg => undef,
    default  => sub { {} },
);

has _event_list => (
    is       => 'ro',
    init_arg => undef,
    lazy     => 1,
    builder  => 1,
);

sub _build__event_list {
    my ($self) = @_;

    my %events;

    for my $file ( @{ $self->in_file } ) {
        my $opus = MIDI::Opus->new({ from_file => $file });

        # XXX Assume that all files have the same MIDI ppqn
        $self->_opus_ticks($opus->ticks)
            unless $self->_opus_ticks;

        for my $t ( $opus->tracks ) {
            my $score_r = MIDI::Score::events_r_to_score_r( $t->events_r );
            #MIDI::Score::dump_score($score_r);

            # Collect the note events
            for my $event (@$score_r) {
                # ['note', , , , , ]
                if ($event->[0] eq 'note') {
                    push @{ $events{ $event->[3] }{ $event->[1] } },
                        { note => $event->[4], dura => $event->[2] };
                }
            }
        }
    }

    return \%events;
}


has dura => (
    is       => 'ro',
    init_arg => undef,
    default  => sub { {} },
);

has _dura_list => (
    is       => 'ro',
    init_arg => undef,
    default  => sub { {} },
);


has dura_net => (
    is       => 'ro',
    init_arg => undef,
    lazy     => 1,
    builder  => 1,
);

sub _build_dura_net {
    my ($self) = @_;

    my %net;

    for my $channel (sort { $a <=> $b } keys %{ $self->_event_list }) {
        my @group;
        my $last;

        for my $start (sort { $a <=> $b } keys %{ $self->_event_list->{$channel} }) {
            my $duras = join ',', map { $_->{dura} } @{ $self->_event_list->{$channel}{$start} };

            if (@group == $self->ngram_size) {
                my $group = join ' ', @group;
                $net{$channel}{ $last . '-' . $group }++
                    if $last;
                $last = $group;
                @group = ();
            }
            push @group, $self->dura_convert($duras);
        }
    }

    for my $channel (keys %net) {
        for my $node (keys %{ $net{$channel} }) {
            delete $net{$channel}{$node}
                if $net{$channel}{$node} < $self->min_phrases;
        }
    }

    return \%net;
}


has note_net => (
    is       => 'ro',
    init_arg => undef,
    lazy     => 1,
    builder  => 1,
);

sub _build_note_net {
    my ($self) = @_;

    my %net;

    for my $channel (sort { $a <=> $b } keys %{ $self->_event_list }) {
        my @group;
        my $last;

        for my $start (sort { $a <=> $b } keys %{ $self->_event_list->{$channel} }) {
            my $notes = join ',', map { $_->{note} } @{ $self->_event_list->{$channel}{$start} };

            if (@group == $self->ngram_size) {
                my $group = join ' ', @group;
                $net{$channel}{ $last . '-' . $group }++
                    if $last;
                $last = $group;
                @group = ();
            }

            push @group, $self->note_convert($notes);
        }
    }

    for my $channel (keys %net) {
        for my $node (keys %{ $net{$channel} }) {
            delete $net{$channel}{$node}
                if $net{$channel}{$node} < $self->min_phrases;
        }
    }

    return \%net;
}


has dura_note_net => (
    is       => 'ro',
    init_arg => undef,
    lazy     => 1,
    builder  => 1,
);

sub _build_dura_note_net {
    my ($self) = @_;

    my %net;

    for my $channel (sort { $a <=> $b } keys %{ $self->_event_list }) {
        my @group;
        my $last;

        for my $start (sort { $a <=> $b } keys %{ $self->_event_list->{$channel} }) {
            my $nodes = join ',', map { "|$_->{dura}*$_->{note}|" } @{ $self->_event_list->{$channel}{$start} };

            if (@group == $self->ngram_size) {
                my $group = join ' ', @group;
                $net{$channel}{ $last . '-' . $group }++
                    if $last;
                $last = $group;
                @group = ();
            }
            push @group, $self->dura_note_convert($nodes);
        }
    }

    for my $channel (keys %net) {
        for my $node (keys %{ $net{$channel} }) {
            delete $net{$channel}{$node}
                if $net{$channel}{$node} < $self->min_phrases;
        }
    }

    return \%net;
}


sub process {
    my ($self) = @_;

    for my $channel (sort { $a <=> $b } keys %{ $self->_event_list }) {
        # Skip if this is not a channel to analyze
        next if $self->analyze && keys @{ $self->analyze }
            && !grep { $_ == $channel } @{ $self->analyze };

        my $dura_note_text = '';
        my $dura_text = '';
        my $note_text = '';

        for my $start (sort { $a <=> $b } keys %{ $self->_event_list->{$channel} }) {
            # CSV durations and notes
            my $dura_notes = join ',', map { "|$_->{dura}*$_->{note}|" } @{ $self->_event_list->{$channel}{$start} };
            my $duras = join ',', map { $_->{dura} } @{ $self->_event_list->{$channel}{$start} };
            my $notes = join ',', map { $_->{note} } @{ $self->_event_list->{$channel}{$start} };

            # Transliterate MIDI note numbers to alpha-code
            ( my $str = $duras ) =~ tr/0-9,/a-k/;
            $dura_text .= "$str ";
            ( $str = $notes ) =~ tr/0-9,/a-k/;
            $note_text .= "$str ";
            ( $str = $dura_notes ) =~ tr/0-9,*|/a-m/;
            $dura_note_text .= "$str ";
        }

        # Parse the note text into ngrams
        my $dura_note_ngram = Lingua::EN::Ngram->new( text => $dura_note_text );
        my $dura_note_phrase = $dura_note_ngram->ngram( $self->ngram_size );
        my $dura_ngram = Lingua::EN::Ngram->new( text => $dura_text );
        my $dura_phrase = $dura_ngram->ngram( $self->ngram_size );
        my $note_ngram = Lingua::EN::Ngram->new( text => $note_text );
        my $note_phrase = $note_ngram->ngram( $self->ngram_size );

        # Counter for the ngrams seen
        my $j = 0;

        # Display the ngrams in order of their repetition amount
        for my $p ( sort { $dura_phrase->{$b} <=> $dura_phrase->{$a} || $a cmp $b } keys %$dura_phrase ) {
            # Skip single occurance phrases if requested
            next if $dura_phrase->{$p} < $self->min_phrases;

            $j++;

            # End if a max is set and we are past the maximum
            last if $self->max_phrases > 0 && $j > $self->max_phrases;

            # Transliterate our letter code back to MIDI note numbers
            ( my $num = $p ) =~ tr/a-k/0-9,/;

            # Convert MIDI numbers to named durations.
            my $text = $self->dura_convert($num);

            # Save the number of times the phrase is repeated
            $self->dura->{$channel}{$text} += $dura_phrase->{$p};
        }

        unless (@{ $self->durations }) {
            # Build the durations set
            for my $channel (keys %{ $self->dura }) {
                for my $duras (keys %{ $self->dura->{$channel} }) {
                    # A dura string is a space separated, CSV
                    my @duras = split / /, $duras;
                    push @{ $self->_dura_list->{$channel} }, map { split /,/, $_ } @duras;
                }
                $self->_dura_list->{$channel} = [ uniq @{ $self->_dura_list->{$channel} } ];
            }
        }

        # Reset counter for the ngrams seen
        $j = 0;

        # Display the ngrams in order of their repetition amount
        for my $p ( sort { $note_phrase->{$b} <=> $note_phrase->{$a} || $a cmp $b } keys %$note_phrase ) {
            # Skip single occurance phrases if requested
            next if $note_phrase->{$p} < $self->min_phrases;

            $j++;

            # End if a max is set and we are past the maximum
            last if $self->max_phrases > 0 && $j > $self->max_phrases;

            # Transliterate our letter code back to MIDI note numbers
            ( my $num = $p ) =~ tr/a-k/0-9,/;

            # Convert MIDI numbers to named notes.
            my $text = $self->note_convert($num);

            # Save the number of times the phrase is repeated
            $self->notes->{$channel}{$text} += $note_phrase->{$p};
        }

        # Reset counter for the ngrams seen
        $j = 0;

        # Display the ngrams in order of their repetition amount
        for my $p ( sort { $dura_note_phrase->{$b} <=> $dura_note_phrase->{$a} || $a cmp $b } keys %$dura_note_phrase ) {
            # Skip single occurance phrases if requested
            next if $dura_note_phrase->{$p} < $self->min_phrases;

            $j++;

            # End if a max is set and we are past the maximum
            last if $self->max_phrases > 0 && $j > $self->max_phrases;

            # Transliterate our letter code back to MIDI note numbers
            ( my $num = $p ) =~ tr/a-m/0-9,*|/;

            # Convert MIDI numbers to named notes.
            my $text = $self->dura_note_convert($num);

            # Save the number of times the phrase is repeated
            $self->dura_notes->{$channel}{$text} += $dura_note_phrase->{$p};
        }
    }
}


sub populate {
    my ($self) = @_;

    my $score = setup_score( bpm => $self->bpm );
    $self->score($score);

    my @phrases;
    my $playback;

    if ( $self->weight ) {
        $playback = "Weighted playback:\n\tLoop\tChan\tPhrase\n";

        for my $channel ( sort { $a <=> $b } keys %{ $self->notes } ) {
            my $track_chan = $self->one_channel ? 0 : $channel;

            # Create a function that adds notes to the score
            my $func = sub {
                my $patch = $self->random_patch ? $self->_random_patch() : 0;

                set_chan_patch( $self->score, $track_chan, $patch );

                for my $n ( 1 .. $self->loop ) {
                    my $choice = choose_weighted(
                        [ keys %{ $self->notes->{$channel} } ],
                        [ values %{ $self->notes->{$channel} } ]
                    );

                    $playback .= "\t$n\t$track_chan\t$choice\n";

                    # Add each chosen note to the score
                    for my $note ( split /\s+/, $choice ) {
                        my @note = split /,/, $note;
                        my $duration = @{ $self->durations }
                            ? $self->durations->[ int rand @{ $self->durations } ]
                            : $self->_dura_list->{$channel}[ int rand @{ $self->_dura_list->{$channel} } ];
                        $self->score->n( $duration, @note );
                    }

                    $self->score->r( $self->pause_duration )
                        if $self->pause_duration;
                }
            };

            push @phrases, $func;
        }
    }
    else {
        my $type = $self->shuffle_phrases ? 'Shuffled' : 'Ordered';
        $playback = "$type playback:\n\tN\tChan\tPhrase\n";

        my $n = 0;

        for my $channel ( keys %{ $self->notes } ) {
            my $track_chan = $self->one_channel ? 0 : $channel;

            my $notes = $self->notes->{$channel};

            # Shuffle the phrases if requested
            my @track_notes = $self->shuffle_phrases
                ? shuffle keys %$notes
                : sort { $notes->{$b} <=> $notes->{$a} || $a cmp $b } keys %$notes;

            # Temporary list of all the phrase notes
            my @all;

            # Add the notes to a bucket
            for my $phrase ( @track_notes ) {
                $n++;

                $playback .= "\t$n\t$track_chan\t$phrase\n";

                my @phrase = split /\s/, $phrase;
                push @all, @phrase;
                push @all, 'r'
                    if $self->pause_duration;
            }

            # Create a function that adds our bucket of notes to the score
            my $func = sub {
                my $patch = $self->random_patch ? $self->_random_patch() : 0;

                set_chan_patch( $self->score, $track_chan, $patch);

                for my $note ( @all ) {
                    if ( $note eq 'r' ) {
                        $self->score->r( $self->pause_duration );
                    }
                    else {
                        my @note = split /,/, $note;
                        my $duration = @{ $self->durations }
                            ? $self->durations->[ int rand @{ $self->durations } ]
                            : $self->_dura_list->{$channel}[ int rand @{ $self->_dura_list->{$channel} } ];
                        $self->score->n( $duration, @note );
                    }
                }
            };

            push @phrases, $func;
        }
    }

    $self->score->synch(@phrases);

    return $playback;
}


sub write {
    my ($self) = @_;
    $self->score->write_score( $self->out_file );
}


sub dura_convert {
    my ($self, $string) = @_;

    my @text;

    my $match = 0;

    for my $n ( split /\s+/, $string ) {
        my @csv;

        for my $v (split /,/, $n) {
            my $dura = $v / $self->_opus_ticks;

            for my $d (keys %MIDI::Simple::Length) {
                if (sprintf('%.4f', $MIDI::Simple::Length{$d}) eq sprintf('%.4f', $dura)) {
                    $match++;
                    $dura = $d;
                    last;
                }
            }

            push @csv, $match ? $dura : 'd' . $v;
            $match = 0;
        }

        push @text, join ',', @csv;
    }

    return join ' ', @text;
}


sub note_convert {
    my ($self, $string) = @_;

    my @text;

    for my $n ( split /\s+/, $string ) {
        my @csv;

        for my $v (split /,/, $n) {
            my $note = Music::Note->new( $v, 'midinum' );
            push @csv, $note->format('midi');
        }

        push @text, join ',', @csv;
    }

    return join ' ', @text;
}


sub dura_note_convert {
    my ($self, $string) = @_;

    my @text;

    for my $frag ( split /\|/, $string ) {
        my $processed = $frag;

        if ($frag =~ /^([\w,]+)\*([\w,]+)$/) {
            $processed = $self->dura_convert($1)
                . '*'
                . $self->note_convert($2);
        }

        push @text, $processed;
    }

    return join '', @text;
}

sub _random_patch {
    my ($self) = @_;
    return $self->patches->[ int rand @{ $self->patches } ];
}

sub _is_integer0 {
    croak 'Not greater than or equal to zero'
        unless defined $_[0] && $_[0] =~ /^\d+$/;
}

sub _is_integer {
    croak 'Invalid integer'
        unless defined $_[0] && $_[0] =~ /^\d+$/ && $_[0] > 0;
}

sub _is_list {
    croak 'Invalid list'
        unless ref $_[0] eq 'ARRAY';
}

sub _is_boolean {
    croak 'Invalid Boolean'
        unless defined $_[0] && $_[0] =~ /^\d$/ && ( $_[0] == 1 || $_[0] == 0 );
}

1;

__END__