File Coverage

blib/lib/MIDI/Praxis/Variation.pm
Criterion Covered Total %
statement 103 104 99.0
branch 35 38 92.1
condition 18 24 75.0
subroutine 20 20 100.0
pod 16 16 100.0
total 192 202 95.0


line stmt bran cond sub pod time code
1             package MIDI::Praxis::Variation;
2             our $AUTHORITY = 'cpan:GENE';
3              
4             # ABSTRACT: Variation techniques used in music composition
5              
6 1     1   69838 use strict;
  1         9  
  1         29  
7 1     1   6 use warnings;
  1         2  
  1         40  
8              
9             our $VERSION = '0.0604';
10              
11 1     1   715 use MIDI::Simple;
  1         21476  
  1         254  
12              
13 1     1   9 use Exporter 'import';
  1         6  
  1         1250  
14              
15             our @EXPORT = qw(
16             augmentation
17             diminution
18             dur
19             inversion
20             note_name_to_number
21             note2num
22             ntup
23             original
24             notes2nums
25             raugmentation
26             rdiminution
27             retrograde
28             retrograde_inversion
29             transposition
30             tye
31             tie_durations
32             );
33             our %EXPORT_TAGS = (all => [qw(
34             augmentation
35             diminution
36             dur
37             inversion
38             note_name_to_number
39             note2num
40             ntup
41             original
42             notes2nums
43             raugmentation
44             rdiminution
45             retrograde
46             retrograde_inversion
47             transposition
48             tye
49             tie_durations
50             )] );
51              
52              
53 1     1 1 520 sub note2num { note_name_to_number(@_) }
54              
55             sub note_name_to_number {
56 52     52 1 1488 my ($in) = @_;
57              
58 52 100       95 return () unless $in;
59              
60 51         70 my $note_number = -1;
61              
62 51 100       162 if ($in =~ /^([A-Za-z]+)(\d+)/s) {
63             $note_number = $MIDI::Simple::Note{$1} + $2 * 12
64 50 50       170 if exists $MIDI::Simple::Note{$1};
65             }
66              
67 51         112 return $note_number;
68             }
69              
70              
71              
72 1     1 1 585 sub notes2nums { original(@_) }
73              
74             sub original {
75 13     13 1 1038 my @notes = @_;
76              
77 13 100       32 return () unless @notes;
78              
79 12         27 my @ret = map { note_name_to_number($_) } @notes;
  36         63  
80              
81 12         34 return @ret;
82             }
83              
84              
85              
86             sub retrograde {
87 2     2 1 1028 my @notes = @_;
88              
89 2         4 my @ret = ();
90              
91 2 100       7 return () unless @notes;
92              
93 1         4 @ret = reverse original(@notes);
94              
95 1         3 return @ret;
96             }
97              
98              
99              
100             sub transposition {
101 10     10 1 2272 my ($delta, @notes) = @_;
102              
103 10 100 66     39 return () unless defined $delta && @notes;
104              
105 9         16 my @ret = ();
106              
107 9 50       36 if ($notes[0] =~ /[A-G]/) {
108 9         21 @ret = original(@notes);
109             }
110             else {
111 0         0 @ret = @notes;
112             }
113              
114 9         22 for (@ret) {
115 27         39 $_ += $delta;
116             }
117              
118 9         22 return @ret;
119             }
120              
121              
122              
123             sub inversion {
124 7     7 1 2164 my ($axis, @notes) = @_;
125              
126 7 100 66     34 return () unless $axis && @notes;
127              
128 6         16 my $center = note_name_to_number($axis);
129 6         13 my $first = note_name_to_number($notes[0]);
130 6         12 my $delta = $center - $first;
131              
132 6         14 my @transposed = transposition($delta, @notes);
133              
134 6         11 my @ret = map { 2 * $center - $_ } @transposed;
  18         34  
135              
136 6         17 return @ret;
137             }
138              
139              
140              
141             sub retrograde_inversion {
142 4     4 1 2159 my ($axis, @notes) = @_;
143              
144 4 100 66     26 return () unless $axis && @notes;
145              
146 3         6 my @rev_notes = ();
147 3         7 my @ret = ();
148              
149 3         7 @rev_notes = reverse @notes;
150              
151 3         11 @ret = inversion($axis, @rev_notes);
152              
153 3         11 return @ret;
154             }
155              
156              
157              
158             sub dur {
159 24     24 1 1520 my ($tempo, $arg) = (MIDI::Simple::Tempo, @_);
160              
161 24 100       417 return () unless $arg;
162              
163 23         36 my $dur = 0;
164              
165 23 100       84 if ($arg =~ /^d(\d+)$/) {
    50          
166 3         12 $dur = 0 + $1;
167             }
168             elsif (exists $MIDI::Simple::Length{$arg}) { # length spec
169 20         39 $dur = 0 + ($tempo * $MIDI::Simple::Length{$arg});
170             }
171              
172 23         62 return $dur;
173             }
174              
175              
176              
177 1     1 1 526 sub tie_durations { tye(@_) }
178              
179             sub tye {
180 4     4 1 1449 my @dur_or_len = @_;
181              
182 4 100       14 return () unless @dur_or_len;
183              
184 3         7 my $sum = 0;
185              
186 3         6 for my $dura (@dur_or_len) {
187 5         11 $sum += dur($dura);
188             }
189              
190 3         7 return $sum;
191             }
192              
193              
194              
195             sub raugmentation {
196 9     9 1 2822 my ($ratio, @dur_or_len) = @_;
197              
198 9 100 100     59 return () unless $ratio && 1 < $ratio && @dur_or_len;
      66        
199              
200 7         14 my $sum = 0;
201              
202 7         13 for my $dura (@dur_or_len) {
203 8         15 $sum += dur($dura) * $ratio;
204             }
205              
206 7         16 return $sum;
207             }
208              
209              
210              
211             sub rdiminution {
212 9     9 1 2832 my ($ratio, @dur_or_len) = @_;
213              
214 9 100 100     56 return () unless $ratio && 1 < $ratio && @dur_or_len;
      66        
215              
216 7         11 my $sum = 0;
217              
218 7         14 for my $dura (@dur_or_len) {
219 8         16 $sum += dur($dura) / $ratio;
220             }
221              
222 7         30 return sprintf '%.0f', $sum;
223             }
224              
225              
226              
227             sub augmentation {
228 3     3 1 1449 my @dur_or_len = @_;
229              
230 3 100       11 return () unless @dur_or_len;
231              
232 2         4 my @ret = ();
233              
234 2         5 for my $dura (@dur_or_len) {
235 3         6 my $elem = 'd';
236 3         9 $elem .= raugmentation(2, $dura);
237 3         8 push @ret, $elem;
238             }
239              
240 2         8 return @ret;
241             }
242              
243              
244              
245             sub diminution {
246 3     3 1 1616 my @dur_or_len = @_;
247              
248 3 100       13 return () unless @dur_or_len;
249              
250 2         6 my @ret = ();
251              
252 2         5 for my $dura (@dur_or_len) {
253 3         5 my $elem = 'd';
254 3         10 $elem .= rdiminution(2, $dura);
255 3         8 push @ret, $elem;
256             }
257              
258 2         9 return @ret;
259             }
260              
261              
262              
263             sub ntup {
264 5     5 1 2604 my ($n, @notes) = @_;
265              
266 5 100 66     34 return () unless defined $n && @notes;
267              
268 4         8 my @ret = ();
269              
270 4 100       13 if (@notes >= $n) {
271 3         11 for my $index (0 .. @notes - $n) {
272 7         19 push @ret, @notes[$index .. $index + $n - 1];
273             }
274             }
275              
276 4         15 return @ret;
277             }
278              
279              
280             1;
281              
282             __END__