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


line stmt bran cond sub pod time code
1             package MIDI::Ngram;
2             our $AUTHORITY = 'cpan:GENE';
3              
4             # ABSTRACT: Find the top repeated note phrases of MIDI files
5              
6             our $VERSION = '0.1807';
7              
8 1     1   1384 use Moo;
  1         11668  
  1         5  
9 1     1   2024 use strictures 2;
  1         1605  
  1         39  
10 1     1   681 use namespace::clean;
  1         11816  
  1         17  
11              
12 1     1   287 use Carp;
  1         2  
  1         57  
13 1     1   510 use Lingua::EN::Ngram;
  1         1451  
  1         35  
14 1     1   7 use List::Util qw( shuffle uniq );
  1         2  
  1         110  
15 1     1   488 use List::Util::WeightedChoice qw( choose_weighted );
  1         6506  
  1         61  
16 1     1   489 use MIDI::Util qw(setup_score set_chan_patch);
  1         24411  
  1         78  
17 1     1   469 use Music::Note;
  1         1673  
  1         4528  
18              
19              
20             has in_file => (
21             is => 'ro',
22             isa => \&_is_list,
23             required => 1,
24             );
25              
26              
27             has ngram_size => (
28             is => 'ro',
29             isa => \&_is_integer,
30             default => sub { 2 },
31             );
32              
33              
34             has min_phrases => (
35             is => 'ro',
36             isa => \&_is_integer,
37             default => sub { 2 },
38             );
39              
40              
41             has max_phrases => (
42             is => 'ro',
43             isa => \&_is_integer0,
44             default => sub { 0 },
45             );
46              
47              
48             has bpm => (
49             is => 'ro',
50             isa => \&_is_integer,
51             default => sub { 100 },
52             );
53              
54              
55             has durations => (
56             is => 'ro',
57             isa => \&_is_list,
58             default => sub { [] },
59             );
60              
61              
62             has patches => (
63             is => 'ro',
64             isa => \&_is_list,
65             default => sub { [ 0 .. 127 ] },
66             );
67              
68              
69             has random_patch => (
70             is => 'ro',
71             isa => \&_is_boolean,
72             default => sub { 0 },
73             );
74              
75              
76             has out_file => (
77             is => 'ro',
78             default => sub { 'midi-ngram.mid' },
79             );
80              
81              
82             has pause_duration => (
83             is => 'ro',
84             isa => sub { croak 'Invalid duration' unless $_[0] eq '' || $_[0] =~ /^[a-z]+$/ },
85             default => sub { '' },
86             );
87              
88              
89             has analyze => (
90             is => 'ro',
91             isa => \&_is_list,
92             );
93              
94              
95             has loop => (
96             is => 'ro',
97             isa => \&_is_integer,
98             default => sub { 10 },
99             );
100              
101              
102             has weight => (
103             is => 'ro',
104             isa => \&_is_boolean,
105             default => sub { 0 },
106             );
107              
108              
109             has shuffle_phrases => (
110             is => 'ro',
111             isa => \&_is_boolean,
112             default => sub { 0 },
113             );
114              
115              
116             has one_channel => (
117             is => 'ro',
118             isa => \&_is_boolean,
119             default => sub { 0 },
120             );
121              
122              
123             has score => (
124             is => 'rw',
125             init_arg => undef,
126             lazy => 1,
127             );
128              
129             has _opus_ticks => (
130             is => 'rw',
131             );
132              
133              
134             has dura_notes => (
135             is => 'ro',
136             init_arg => undef,
137             default => sub { {} },
138             );
139              
140              
141             has notes => (
142             is => 'ro',
143             init_arg => undef,
144             default => sub { {} },
145             );
146              
147             has _event_list => (
148             is => 'ro',
149             init_arg => undef,
150             lazy => 1,
151             builder => 1,
152             );
153              
154             sub _build__event_list {
155 1     1   11 my ($self) = @_;
156              
157 1         3 my %events;
158              
159 1         2 for my $file ( @{ $self->in_file } ) {
  1         5  
160 1         13 my $opus = MIDI::Opus->new({ from_file => $file });
161              
162             # XXX Assume that all files have the same MIDI ppqn
163 1 50       6127 $self->_opus_ticks($opus->ticks)
164             unless $self->_opus_ticks;
165              
166 1         11 for my $t ( $opus->tracks ) {
167 3         19 my $score_r = MIDI::Score::events_r_to_score_r( $t->events_r );
168             #MIDI::Score::dump_score($score_r);
169              
170             # Collect the note events
171 3         2862 for my $event (@$score_r) {
172             # ['note', , , , , ]
173 102 100       210 if ($event->[0] eq 'note') {
174 69         79 push @{ $events{ $event->[3] }{ $event->[1] } },
  69         345  
175             { note => $event->[4], dura => $event->[2] };
176             }
177             }
178             }
179             }
180              
181 1         13 return \%events;
182             }
183              
184              
185             has dura => (
186             is => 'ro',
187             init_arg => undef,
188             default => sub { {} },
189             );
190              
191             has _dura_list => (
192             is => 'ro',
193             init_arg => undef,
194             default => sub { {} },
195             );
196              
197              
198             has dura_net => (
199             is => 'ro',
200             init_arg => undef,
201             lazy => 1,
202             builder => 1,
203             );
204              
205             sub _build_dura_net {
206 1     1   2612 my ($self) = @_;
207              
208 1         2 my %net;
209              
210 1         2 for my $channel (sort { $a <=> $b } keys %{ $self->_event_list }) {
  1         14  
  1         18  
211 2         3 my @group;
212             my $last;
213              
214 2         3 for my $start (sort { $a <=> $b } keys %{ $self->_event_list->{$channel} }) {
  277         347  
  2         36  
215 69         89 my $duras = join ',', map { $_->{dura} } @{ $self->_event_list->{$channel}{$start} };
  69         581  
  69         1203  
216              
217 69 100       220 if (@group == $self->ngram_size) {
218 33         58 my $group = join ' ', @group;
219 33 100       82 $net{$channel}{ $last . '-' . $group }++
220             if $last;
221 33         50 $last = $group;
222 33         53 @group = ();
223             }
224 69         123 push @group, $self->dura_convert($duras);
225             }
226             }
227              
228 1         5 for my $channel (keys %net) {
229 2         3 for my $node (keys %{ $net{$channel} }) {
  2         6  
230             delete $net{$channel}{$node}
231 9 100       40 if $net{$channel}{$node} < $self->min_phrases;
232             }
233             }
234              
235 1         9 return \%net;
236             }
237              
238              
239             has note_net => (
240             is => 'ro',
241             init_arg => undef,
242             lazy => 1,
243             builder => 1,
244             );
245              
246             sub _build_note_net {
247 1     1   13 my ($self) = @_;
248              
249 1         2 my %net;
250              
251 1         2 for my $channel (sort { $a <=> $b } keys %{ $self->_event_list }) {
  1         14  
  1         16  
252 2         5 my @group;
253             my $last;
254              
255 2         3 for my $start (sort { $a <=> $b } keys %{ $self->_event_list->{$channel} }) {
  277         344  
  2         34  
256 69         85 my $notes = join ',', map { $_->{note} } @{ $self->_event_list->{$channel}{$start} };
  69         580  
  69         1257  
257              
258 69 100       197 if (@group == $self->ngram_size) {
259 33         53 my $group = join ' ', @group;
260 33 100       94 $net{$channel}{ $last . '-' . $group }++
261             if $last;
262 33         48 $last = $group;
263 33         56 @group = ();
264             }
265              
266 69         132 push @group, $self->note_convert($notes);
267             }
268             }
269              
270 1         5 for my $channel (keys %net) {
271 2         3 for my $node (keys %{ $net{$channel} }) {
  2         8  
272             delete $net{$channel}{$node}
273 20 100       45 if $net{$channel}{$node} < $self->min_phrases;
274             }
275             }
276              
277 1         7 return \%net;
278             }
279              
280              
281             has dura_note_net => (
282             is => 'ro',
283             init_arg => undef,
284             lazy => 1,
285             builder => 1,
286             );
287              
288             sub _build_dura_note_net {
289 1     1   12 my ($self) = @_;
290              
291 1         2 my %net;
292              
293 1         2 for my $channel (sort { $a <=> $b } keys %{ $self->_event_list }) {
  1         14  
  1         17  
294 2         4 my @group;
295             my $last;
296              
297 2         4 for my $start (sort { $a <=> $b } keys %{ $self->_event_list->{$channel} }) {
  277         351  
  2         70  
298 69         95 my $nodes = join ',', map { "|$_->{dura}*$_->{note}|" } @{ $self->_event_list->{$channel}{$start} };
  69         664  
  69         1354  
299              
300 69 100       205 if (@group == $self->ngram_size) {
301 33         65 my $group = join ' ', @group;
302 33 100       98 $net{$channel}{ $last . '-' . $group }++
303             if $last;
304 33         46 $last = $group;
305 33         409 @group = ();
306             }
307 69         137 push @group, $self->dura_note_convert($nodes);
308             }
309             }
310              
311 1         4 for my $channel (keys %net) {
312 2         3 for my $node (keys %{ $net{$channel} }) {
  2         8  
313             delete $net{$channel}{$node}
314 22 100       50 if $net{$channel}{$node} < $self->min_phrases;
315             }
316             }
317              
318 1         8 return \%net;
319             }
320              
321              
322             sub process {
323 1     1 1 9331 my ($self) = @_;
324              
325 1         3 for my $channel (sort { $a <=> $b } keys %{ $self->_event_list }) {
  1         6  
  1         28  
326             # Skip if this is not a channel to analyze
327 0         0 next if $self->analyze && keys @{ $self->analyze }
328 2 0 33     10 && !grep { $_ == $channel } @{ $self->analyze };
  0   33     0  
  0         0  
329              
330 2         6 my $dura_note_text = '';
331 2         3 my $dura_text = '';
332 2         4 my $note_text = '';
333              
334 2         4 for my $start (sort { $a <=> $b } keys %{ $self->_event_list->{$channel} }) {
  277         353  
  2         58  
335             # CSV durations and notes
336 69         89 my $dura_notes = join ',', map { "|$_->{dura}*$_->{note}|" } @{ $self->_event_list->{$channel}{$start} };
  69         585  
  69         1079  
337 69         119 my $duras = join ',', map { $_->{dura} } @{ $self->_event_list->{$channel}{$start} };
  69         567  
  69         1009  
338 69         99 my $notes = join ',', map { $_->{note} } @{ $self->_event_list->{$channel}{$start} };
  69         520  
  69         987  
339              
340             # Transliterate MIDI note numbers to alpha-code
341 69         120 ( my $str = $duras ) =~ tr/0-9,/a-k/;
342 69         112 $dura_text .= "$str ";
343 69         83 ( $str = $notes ) =~ tr/0-9,/a-k/;
344 69         95 $note_text .= "$str ";
345 69         89 ( $str = $dura_notes ) =~ tr/0-9,*|/a-m/;
346 69         122 $dura_note_text .= "$str ";
347             }
348              
349             # Parse the note text into ngrams
350 2         16 my $dura_note_ngram = Lingua::EN::Ngram->new( text => $dura_note_text );
351 2         53 my $dura_note_phrase = $dura_note_ngram->ngram( $self->ngram_size );
352 2         769 my $dura_ngram = Lingua::EN::Ngram->new( text => $dura_text );
353 2         37 my $dura_phrase = $dura_ngram->ngram( $self->ngram_size );
354 2         668 my $note_ngram = Lingua::EN::Ngram->new( text => $note_text );
355 2         31 my $note_phrase = $note_ngram->ngram( $self->ngram_size );
356              
357             # Counter for the ngrams seen
358 2         673 my $j = 0;
359              
360             # Display the ngrams in order of their repetition amount
361 2 50       11 for my $p ( sort { $dura_phrase->{$b} <=> $dura_phrase->{$a} || $a cmp $b } keys %$dura_phrase ) {
  9         24  
362             # Skip single occurance phrases if requested
363 9 100       25 next if $dura_phrase->{$p} < $self->min_phrases;
364              
365 7         9 $j++;
366              
367             # End if a max is set and we are past the maximum
368 7 50 33     20 last if $self->max_phrases > 0 && $j > $self->max_phrases;
369              
370             # Transliterate our letter code back to MIDI note numbers
371 7         15 ( my $num = $p ) =~ tr/a-k/0-9,/;
372              
373             # Convert MIDI numbers to named durations.
374 7         17 my $text = $self->dura_convert($num);
375              
376             # Save the number of times the phrase is repeated
377 7         27 $self->dura->{$channel}{$text} += $dura_phrase->{$p};
378             }
379              
380 2 50       4 unless (@{ $self->durations }) {
  2         8  
381             # Build the durations set
382 2         4 for my $channel (keys %{ $self->dura }) {
  2         18  
383 3         5 for my $duras (keys %{ $self->dura->{$channel} }) {
  3         10  
384             # A dura string is a space separated, CSV
385 10         22 my @duras = split / /, $duras;
386 10         13 push @{ $self->_dura_list->{$channel} }, map { split /,/, $_ } @duras;
  10         22  
  20         45  
387             }
388 3         6 $self->_dura_list->{$channel} = [ uniq @{ $self->_dura_list->{$channel} } ];
  3         24  
389             }
390             }
391              
392             # Reset counter for the ngrams seen
393 2         4 $j = 0;
394              
395             # Display the ngrams in order of their repetition amount
396 2 50       10 for my $p ( sort { $note_phrase->{$b} <=> $note_phrase->{$a} || $a cmp $b } keys %$note_phrase ) {
  71         150  
397             # Skip single occurance phrases if requested
398 27 100       67 next if $note_phrase->{$p} < $self->min_phrases;
399              
400 23         28 $j++;
401              
402             # End if a max is set and we are past the maximum
403 23 50 33     51 last if $self->max_phrases > 0 && $j > $self->max_phrases;
404              
405             # Transliterate our letter code back to MIDI note numbers
406 23         63 ( my $num = $p ) =~ tr/a-k/0-9,/;
407              
408             # Convert MIDI numbers to named notes.
409 23         44 my $text = $self->note_convert($num);
410              
411             # Save the number of times the phrase is repeated
412 23         75 $self->notes->{$channel}{$text} += $note_phrase->{$p};
413             }
414              
415             # Reset counter for the ngrams seen
416 2         4 $j = 0;
417              
418             # Display the ngrams in order of their repetition amount
419 2 50       13 for my $p ( sort { $dura_note_phrase->{$b} <=> $dura_note_phrase->{$a} || $a cmp $b } keys %$dura_note_phrase ) {
  106         183  
420             # Skip single occurance phrases if requested
421 35 100       121 next if $dura_note_phrase->{$p} < $self->min_phrases;
422              
423 24         31 $j++;
424              
425             # End if a max is set and we are past the maximum
426 24 50 33     51 last if $self->max_phrases > 0 && $j > $self->max_phrases;
427              
428             # Transliterate our letter code back to MIDI note numbers
429 24         66 ( my $num = $p ) =~ tr/a-m/0-9,*|/;
430              
431             # Convert MIDI numbers to named notes.
432 24         96 my $text = $self->dura_note_convert($num);
433              
434             # Save the number of times the phrase is repeated
435 24         117 $self->dura_notes->{$channel}{$text} += $dura_note_phrase->{$p};
436             }
437             }
438             }
439              
440              
441             sub populate {
442 1     1 1 3 my ($self) = @_;
443              
444 1         11 my $score = setup_score( bpm => $self->bpm );
445 1         545 $self->score($score);
446              
447 1         2 my @phrases;
448             my $playback;
449              
450 1 50       5 if ( $self->weight ) {
451 0         0 $playback = "Weighted playback:\n\tLoop\tChan\tPhrase\n";
452              
453 0         0 for my $channel ( sort { $a <=> $b } keys %{ $self->notes } ) {
  0         0  
  0         0  
454 0 0       0 my $track_chan = $self->one_channel ? 0 : $channel;
455              
456             # Create a function that adds notes to the score
457             my $func = sub {
458 0 0   0   0 my $patch = $self->random_patch ? $self->_random_patch() : 0;
459              
460 0         0 set_chan_patch( $self->score, $track_chan, $patch );
461              
462 0         0 for my $n ( 1 .. $self->loop ) {
463             my $choice = choose_weighted(
464 0         0 [ keys %{ $self->notes->{$channel} } ],
465 0         0 [ values %{ $self->notes->{$channel} } ]
  0         0  
466             );
467              
468 0         0 $playback .= "\t$n\t$track_chan\t$choice\n";
469              
470             # Add each chosen note to the score
471 0         0 for my $note ( split /\s+/, $choice ) {
472 0         0 my @note = split /,/, $note;
473 0         0 my $duration = @{ $self->durations }
474 0         0 ? $self->durations->[ int rand @{ $self->durations } ]
475 0 0       0 : $self->_dura_list->{$channel}[ int rand @{ $self->_dura_list->{$channel} } ];
  0         0  
476 0         0 $self->score->n( $duration, @note );
477             }
478              
479 0 0       0 $self->score->r( $self->pause_duration )
480             if $self->pause_duration;
481             }
482 0         0 };
483              
484 0         0 push @phrases, $func;
485             }
486             }
487             else {
488 1 50       5 my $type = $self->shuffle_phrases ? 'Shuffled' : 'Ordered';
489 1         3 $playback = "$type playback:\n\tN\tChan\tPhrase\n";
490              
491 1         2 my $n = 0;
492              
493 1         2 for my $channel ( keys %{ $self->notes } ) {
  1         5  
494 2 50       7 my $track_chan = $self->one_channel ? 0 : $channel;
495              
496 2         5 my $notes = $self->notes->{$channel};
497              
498             # Shuffle the phrases if requested
499             my @track_notes = $self->shuffle_phrases
500             ? shuffle keys %$notes
501 2 50       15 : sort { $notes->{$b} <=> $notes->{$a} || $a cmp $b } keys %$notes;
  61 50       107  
502              
503             # Temporary list of all the phrase notes
504 2         5 my @all;
505              
506             # Add the notes to a bucket
507 2         3 for my $phrase ( @track_notes ) {
508 23         29 $n++;
509              
510 23         45 $playback .= "\t$n\t$track_chan\t$phrase\n";
511              
512 23         52 my @phrase = split /\s/, $phrase;
513 23         50 push @all, @phrase;
514 23 50       71 push @all, 'r'
515             if $self->pause_duration;
516             }
517              
518             # Create a function that adds our bucket of notes to the score
519             my $func = sub {
520 2 50   2   114 my $patch = $self->random_patch ? $self->_random_patch() : 0;
521              
522 2         9 set_chan_patch( $self->score, $track_chan, $patch);
523              
524 2         108 for my $note ( @all ) {
525 46 50       3091 if ( $note eq 'r' ) {
526 0         0 $self->score->r( $self->pause_duration );
527             }
528             else {
529 46         94 my @note = split /,/, $note;
530 46         126 my $duration = @{ $self->durations }
531 0         0 ? $self->durations->[ int rand @{ $self->durations } ]
532 46 50       60 : $self->_dura_list->{$channel}[ int rand @{ $self->_dura_list->{$channel} } ];
  46         141  
533 46         116 $self->score->n( $duration, @note );
534             }
535             }
536 2         19 };
537              
538 2         8 push @phrases, $func;
539             }
540             }
541              
542 1         9 $self->score->synch(@phrases);
543              
544 1         90 return $playback;
545             }
546              
547              
548             sub write {
549 0     0 1 0 my ($self) = @_;
550 0         0 $self->score->write_score( $self->out_file );
551             }
552              
553              
554             sub dura_convert {
555 197     197 1 416 my ($self, $string) = @_;
556              
557 197         265 my @text;
558              
559 197         246 my $match = 0;
560              
561 197         498 for my $n ( split /\s+/, $string ) {
562 204         282 my @csv;
563              
564 204         340 for my $v (split /,/, $n) {
565 206         550 my $dura = $v / $self->_opus_ticks;
566              
567 206         735 for my $d (keys %MIDI::Simple::Length) {
568 2983 100       10206 if (sprintf('%.4f', $MIDI::Simple::Length{$d}) eq sprintf('%.4f', $dura)) {
569 206         258 $match++;
570 206         265 $dura = $d;
571 206         277 last;
572             }
573             }
574              
575 206 50       585 push @csv, $match ? $dura : 'd' . $v;
576 206         379 $match = 0;
577             }
578              
579 204         541 push @text, join ',', @csv;
580             }
581              
582 197         550 return join ' ', @text;
583             }
584              
585              
586             sub note_convert {
587 213     213 1 498 my ($self, $string) = @_;
588              
589 213         290 my @text;
590              
591 213         543 for my $n ( split /\s+/, $string ) {
592 238         314 my @csv;
593              
594 238         401 for my $v (split /,/, $n) {
595 240         671 my $note = Music::Note->new( $v, 'midinum' );
596 240         6054 push @csv, $note->format('midi');
597             }
598              
599 238         4865 push @text, join ',', @csv;
600             }
601              
602 213         492 return join ' ', @text;
603             }
604              
605              
606             sub dura_note_convert {
607 95     95 1 169 my ($self, $string) = @_;
608              
609 95         120 my @text;
610              
611 95         236 for my $frag ( split /\|/, $string ) {
612 236         310 my $processed = $frag;
613              
614 236 100       662 if ($frag =~ /^([\w,]+)\*([\w,]+)$/) {
615 119         228 $processed = $self->dura_convert($1)
616             . '*'
617             . $self->note_convert($2);
618             }
619              
620 236         424 push @text, $processed;
621             }
622              
623 95         236 return join '', @text;
624             }
625              
626             sub _random_patch {
627 0     0   0 my ($self) = @_;
628 0         0 return $self->patches->[ int rand @{ $self->patches } ];
  0         0  
629             }
630              
631             sub _is_integer0 {
632 10 100 66 10   257 croak 'Not greater than or equal to zero'
633             unless defined $_[0] && $_[0] =~ /^\d+$/;
634             }
635              
636             sub _is_integer {
637 42 100 33 42   1146 croak 'Invalid integer'
      66        
638             unless defined $_[0] && $_[0] =~ /^\d+$/ && $_[0] > 0;
639             }
640              
641             sub _is_list {
642 32 100   32   776 croak 'Invalid list'
643             unless ref $_[0] eq 'ARRAY';
644             }
645              
646             sub _is_boolean {
647 16 100 66 16   425 croak 'Invalid Boolean'
      33        
      66        
648             unless defined $_[0] && $_[0] =~ /^\d$/ && ( $_[0] == 1 || $_[0] == 0 );
649             }
650              
651             1;
652              
653             __END__