File Coverage

blib/lib/Data/BiaB/MIDI.pm
Criterion Covered Total %
statement 22 104 21.1
branch 0 28 0.0
condition 0 14 0.0
subroutine 8 9 88.8
pod 0 1 0.0
total 30 156 19.2


line stmt bran cond sub pod time code
1             #! perl
2              
3             package Data::BiaB::MIDI;
4              
5             BEGIN {
6 1     1   717 our $VERSION = '0.10';
7             }
8              
9 1     1   4 use Data::BiaB $VERSION;
  1         1  
  1         20  
10              
11             =head1 NAME
12              
13             Data::BiaB::MIDI - MIDI generator for Data::BiaB
14              
15             =head1 SYNOPSIS
16              
17             This module provides MIDI generation for Data::BiaB.
18              
19             Example:
20              
21             use Data::BiaB;
22             use Data::BiaB::MIDI;
23              
24             # Load an existing song.
25             my $biab = Data::BiaB->new();
26             $biab->load("Vaya_Con_Dios.mgu");
27              
28             # Create MIDI.
29             $biab->makemidi("Vaya_Con_Dios.midi");
30              
31             For convenience, you can run the module from the command line:
32              
33             perl lib/Data/BiaB/MIDI.pm Vaya_Con_Dios.mgu
34              
35             This will produce a MIDI file named C<__new__.midi>.
36              
37             =cut
38              
39             package Data::BiaB;
40              
41 1     1   2 use warnings;
  1         1  
  1         17  
42 1     1   3 use strict;
  1         1  
  1         15  
43 1     1   3 use Carp qw( carp croak );
  1         1  
  1         351  
44              
45             my @keys =
46             ( '/','C','Db','D','Eb','E','F','Gb','G','Ab','A','Bb','B',
47             'C#','D#','F#','G#','A#',
48             'Cm','Dbm','Dm','Ebm','Em','Fm','Gbm','Gm','Abm','Am','Bbm','Bm',
49             'C#m','D#m','F#m','G#m','A#m',
50             );
51              
52             my %chords =
53             (
54             "2" => [ qw( 0 2 7 ) ],
55             "sus2" => [ qw( 0 2 7 ) ],
56             "dim" => [ qw( 0 3 6 ) ],
57             "0" => [ qw( 0 3 6 ) ],
58             "dim7" => [ qw( 0 3 6 9 ) ],
59             "m7b5" => [ qw( 0 3 6 10 ) ],
60             "ΓΈ" => [ qw( 0 3 6 10 ) ],
61             "m7b5" => [ qw( 0 3 6 10 ) ],
62             "m9b5" => [ qw( 0 3 6 11 14 ) ],
63             "m" => [ qw( 0 3 7 ) ],
64             "m#5" => [ qw( 0 3 7 ) ],
65             "m6" => [ qw( 0 3 7 9 ) ],
66             "m69" => [ qw( 0 3 7 9 14 ) ],
67             "m7" => [ qw( 0 3 7 10 ) ],
68             "m9" => [ qw( 0 3 7 10 14 ) ],
69             "m11" => [ qw( 0 3 7 10 14 17 ) ],
70             "m13" => [ qw( 0 3 7 10 14 17 21 ) ],
71             "mmaj7" => [ qw( 0 3 7 11 ) ],
72             "mM7" => [ qw( 0 3 7 11 ) ],
73             "maug" => [ qw( 0 3 8 ) ],
74             "m7#5" => [ qw( 0 3 8 10 ) ],
75             "7b5" => [ qw( 0 4 6 10 ) ],
76             "7b5b9" => [ qw( 0 4 6 10 13 ) ],
77             "9b5" => [ qw( 0 4 6 10 14 ) ],
78             "13b5" => [ qw( 0 4 6 10 14 17 21 ) ],
79             "7b5#9" => [ qw( 0 4 6 10 15 ) ],
80             "maj7#5" => [ qw( 0 4 6 11 ) ],
81             "" => [ qw( 0 4 7 ) ],
82             "maj" => [ qw( 0 4 7 ) ],
83             "6" => [ qw( 0 4 7 9 ) ],
84             "maj6" => [ qw( 0 4 7 9 ) ],
85             "maj69" => [ qw( 0 4 7 9 14 ) ],
86             "69" => [ qw( 0 4 7 9 14 ) ],
87             "7" => [ qw( 0 4 7 10 ) ],
88             "7b9" => [ qw( 0 4 7 10 13 ) ],
89             "13b9" => [ qw( 0 4 7 10 13 17 21 ) ],
90             "7b9#11" => [ qw( 0 4 7 10 13 18 ) ],
91             "9" => [ qw( 0 4 7 10 14 ) ],
92             "7#9" => [ qw( 0 4 7 10 14 ) ],
93             "11" => [ qw( 0 4 7 10 14 17 ) ],
94             "7b13" => [ qw( 0 4 7 10 14 17 20 ) ],
95             "9b13" => [ qw( 0 4 7 10 14 17 20 ) ],
96             "13" => [ qw( 0 4 7 10 14 17 21 ) ],
97             "13sus" => [ qw( 0 4 7 10 14 17 21 ) ],
98             "13+" => [ qw( 0 4 7 10 14 17 22 ) ],
99             "7#11" => [ qw( 0 4 7 10 14 18 ) ],
100             "9#11" => [ qw( 0 4 7 10 14 18 ) ],
101             "13#11" => [ qw( 0 4 7 10 14 18 21 ) ],
102             "7#9b13" => [ qw( 0 4 7 10 15 17 20 ) ],
103             "13#9" => [ qw( 0 4 7 10 15 17 21 ) ],
104             "maj7" => [ qw( 0 4 7 11 ) ],
105             "M7" => [ qw( 0 4 7 11 ) ],
106             "maj7" => [ qw( 0 4 7 11 ) ],
107             "maj9" => [ qw( 0 4 7 11 14 ) ],
108             "maj9" => [ qw( 0 4 7 11 14 ) ],
109             "maj11" => [ qw( 0 4 7 11 14 17 ) ],
110             "maj13" => [ qw( 0 4 7 11 14 17 21 ) ],
111             "maj13" => [ qw( 0 4 7 11 14 17 21 ) ],
112             "maj9#11" => [ qw( 0 4 7 11 14 18 ) ],
113             "maj13#11" => [ qw( 0 4 7 11 14 18 21 ) ],
114             "aug" => [ qw( 0 4 8 ) ],
115             "+" => [ qw( 0 4 8 ) ],
116             "aug7" => [ qw( 0 4 8 10 ) ],
117             "7#5" => [ qw( 0 4 8 10 ) ],
118             "7#5" => [ qw( 0 4 8 10 ) ],
119             "7+" => [ qw( 0 4 8 10 ) ],
120             "7#5b9" => [ qw( 0 4 8 10 13 ) ],
121             "9#5" => [ qw( 0 4 8 10 14 ) ],
122             "7#5#9" => [ qw( 0 4 8 10 15 ) ],
123             "sus" => [ qw( 0 5 7 ) ],
124             "sus4" => [ qw( 0 5 7 ) ],
125             "4" => [ qw( 0 5 7 ) ],
126             "sus7" => [ qw( 0 5 7 10 ) ],
127             "7sus" => [ qw( 0 5 7 10 ) ],
128             "7susb9" => [ qw( 0 5 7 10 13 ) ],
129             "7sus#9" => [ qw( 0 5 7 10 15 ) ],
130             "7sus#5" => [ qw( 0 5 8 10 ) ],
131             "5b" => [ qw( 0 6 ) ],
132             "5" => [ qw( 0 7 ) ],
133             );
134              
135             my @midikeys = (split(/ /, "C G D A E B F# C# Cb Gb Db Ab Eb Bb F"));
136             my @midinotess = (split(/ /, "C C# D D# E F G G# A A# B"));
137             my @midinotesf = (split(/ /, "C Db D Eb E F G Ab A Bb B"));
138             my %midinotes;
139              
140             sub makemidi {
141 0     0 0   my ( $self, $file ) = @_;
142              
143 0           require MIDI;
144 1     1   4 use constant EV_TIME => 1;
  1         1  
  1         50  
145 1     1   4 use constant TICKS => 120;
  1         1  
  1         688  
146              
147 0 0         unless ( %midinotes ) {
148 0           for ( my $i = 0; $i < @midinotess; $i++ ) {
149 0           $midinotes{$midinotess[$i]} = $i;
150 0           $midinotes{$midinotesf[$i]} = $i;
151             }
152             }
153              
154 0           my $bpm = 4; # beats per measure
155              
156 0           my $key = chordroot($self->{key_nr});
157 0           warn("key=$key");
158 0           my $minor = 0;
159              
160 0 0         if ( $key =~ /^(.+)m$/ ) {
161 0           $minor++;
162 0           $key = $1;
163             }
164 0           $key = $midinotes{$key};
165 0           warn("key=$key");
166 0 0         $key = 14 - $key if $key > 7;
167 0           warn("key=$key $minor");
168             my @pre = (
169 0           [ 'set_tempo', 0, 60000000 / $self->{bpm} ],
170             [ 'time_signature', 0, $bpm, 2, 24, 8 ],
171             [ 'key_signature', 0, $key, $minor ],
172             );
173              
174 0           my @ev;
175 0           my $time = 0;
176 0           my ( $onset, $chan, $pitch, $velo, $flags, $dur );
177 0           $onset = $bpm*TICKS;
178 0           $chan = 2;
179 0           $velo = 40;
180 0           $dur = TICKS;
181 0           my $chord;
182 0           my $beats = 0;
183              
184 0           my @chords;
185             # The chords consist of three parts:
186             # - the intro
187             # - the repeatable part (chorus)
188             # - the coda
189             # The starting and ending bar numbers for the chorus are known.
190              
191 0           my @c = @{$self->{chords}};
  0            
192 0           my $start = $self->{start_chorus_bar};
193 0           my $end = $self->{end_chorus_bar};
194              
195             # Start with the intro, if any.
196 0 0         push( @chords, @c[ 0 .. $bpm*$start-1] ) if $start > 1;
197              
198             # Append the chorus repetitions.
199 0           for ( my $r = $self->{number_of_repeats}; $r > 0; $r-- ) {
200 0           push( @chords, @c[ $bpm*($start-1) .. $bpm*$end-1 ] );
201             }
202              
203             # Append coda part, if any.
204 0 0         push( @chords, @c[ $bpm*$end .. $#c ] ) if $end < $#c;
205              
206             # Now turn the chords into a MIDI track.
207 0           @ev = ();
208 0           foreach ( @chords ) {
209 0 0         $chord = $_ if defined; # undefined -> use previous
210              
211 0 0         if ( ++$beats > $bpm ) {
212             # There are (always?) 4 chord slots per measure.
213 0 0         next if $beats < 4;
214 0           $beats = 0;
215             }
216              
217 0           $time += TICKS;
218              
219 0           my ( $root, $name, $type ) =
220             $chord =~ /^\s*(\d+)\s+\d+\s+(\S+)\s+(.*)/;
221 0           my @notes = @{$chords{$type}};
  0            
222 0 0         unless ( @notes ) {
223 0           warn("Unknown chord[$chord @ $time]: $name$type\n");
224 0           $onset += TICKS;
225 0           next;
226             }
227              
228             warn("CHORD[$time $chord] $root $name$type (@notes)\n")
229 0 0 0       if defined && $self->{debug};
230              
231             # All chord notes on ...
232 0           foreach ( @notes ) {
233             # 60 = central C.
234 0           push( @ev, [ 'note_on', $onset, $chan, 60+$_+$root-1, $velo ] );
235 0           $onset = 0;
236             }
237             # ... and off a beat later.
238 0           $onset = TICKS;
239 0           foreach ( @notes ) {
240 0           push( @ev, [ 'note_off', $onset, $chan, 60+$_+$root-1, $velo ] );
241 0           $onset = 0;
242             }
243             }
244              
245             # Add preamble and make a track.
246 0           my $chords = MIDI::Track->new( { events => [ @pre, @ev ] } );
247 0           my @tracks = ( $chords );
248              
249             # Now for the melody.
250 0           @ev = ();
251 0           foreach ( @{ $self->{melody} } ) {
  0            
252 0           ( $onset, $chan, $pitch, $velo, $flags, $dur ) = @$_;
253              
254             # Skip notes we won't (cannot) handle.
255 0 0 0       next unless $flags == 144 || $flags == 148 || $flags == 147;
      0        
256 0 0 0       next unless $chan && $chan < 16;
257              
258             # Subtrackt lead in.
259 0           $onset -= $bpm*TICKS;
260              
261             # Make MIDI.
262 0           push( @ev, [ 'note_on', $onset, $chan, $pitch, $velo ] );
263 0           push( @ev, [ 'note_off', $onset+$dur, $chan, $pitch, $velo ] );
264             }
265              
266 0 0         unless ( @ev ) {
267 0           carp("No melody?");
268             }
269             else {
270             # Sort on timestamp.
271 0           @ev = sort { $a->[EV_TIME] <=> $b->[EV_TIME] } @ev;
  0            
272              
273             # Convert to delta times.
274 0           $time = 0;
275 0           foreach my $e ( @ev ) {
276 0 0         carp("NEGATIVE DELTA \@ $time: @{[$e->[EV_TIME]-$time]}\n")
  0            
277             if $e->[EV_TIME] < $time;
278             # Make time relative.
279 0           ($time, $e->[EV_TIME]) = ($e->[EV_TIME], $e->[EV_TIME]-$time);
280             }
281              
282             # Create a MIDI track and add it to the tracks.
283 0           my $melody = MIDI::Track->new( { events => [ @pre, @ev ] } );
284 0           push( @tracks, $melody );
285             }
286              
287             # Create the MIDI Opus.
288 0           my $op = MIDI::Opus->new
289             ( { format => 1,
290             ticks => TICKS,
291             tracks => \@tracks,
292             } );
293              
294             # And save.
295 0   0       $op->write_to_file( $file || '__new__.midi' );
296             }
297              
298              
299             1; # End of Data::BiaB
300              
301             package main;
302              
303             unless ( caller ) {
304 1     1   4 use Data::BiaB;
  1         1  
  1         68  
305             my $b = Data::BiaB->new( debug => 1 )->load (shift )->parse;
306             $b->makechords;
307             $b->makemidi;
308             }
309              
310             =head1 AUTHOR
311              
312             Johan Vromans, C<< >>
313              
314             =head1 BUGS AND SUPPORT
315              
316             See L.
317              
318             =head1 COPYRIGHT & LICENSE
319              
320             Copyright 2016 Johan Vromans, all rights reserved.
321              
322             This program is free software; you can redistribute it and/or modify
323             it under the same terms as Perl itself.
324              
325             =cut
326              
327             1;