File Coverage

blib/lib/Music/Scala.pm
Criterion Covered Total %
statement 212 227 93.3
branch 109 156 69.8
condition 14 26 53.8
subroutine 27 27 100.0
pod 17 18 94.4
total 379 454 83.4


line stmt bran cond sub pod time code
1             # -*- Perl -*-
2             #
3             # Scala scale (musical tuning and temperament) support for Perl, based
4             # on specification at: http://www.huygens-fokker.org/scala/
5             #
6             # Ratio to cent and cent to ratio equations lifted from "Musimathics,
7             # volume 1", pp. 45-46. MIDI conversion probably from wikipedia.
8              
9             package Music::Scala;
10              
11 2     2   58078 use 5.010000;
  2         11  
12 2     2   8 use strict;
  2         3  
  2         31  
13 2     2   8 use warnings;
  2         4  
  2         49  
14              
15 2     2   19 use Carp qw/croak/;
  2         3  
  2         92  
16 2     2   11 use File::Basename qw/basename/;
  2         2  
  2         147  
17 2     2   923 use Moo;
  2         19733  
  2         8  
18 2     2   3204 use namespace::clean;
  2         20068  
  2         11  
19 2     2   453 use Scalar::Util qw/looks_like_number reftype/;
  2         4  
  2         5362  
20              
21             our $VERSION = '1.07';
22              
23             ##############################################################################
24             #
25             # ATTRIBUTES
26             #
27             # NOTE that much of the Moo setup (getters/setters, how "notes" handled,
28             # etc) is to preserve compatibility with how the code worked pre-Moo.
29             # Additional hilarity stemmed from (the mistake of?) offering multiple
30             # methods to get/set the same data in different guises (notes (as cents
31             # or ratios), (notes as) cents, (notes as) ratios).
32              
33             has binmode => (
34             is => 'rw',
35             predicate => 1, # has_binmode
36             reader => 'get_binmode',
37             writer => 'set_binmode',
38             );
39              
40             has concertfreq => (
41             is => 'rw',
42             default => sub { 440 },
43             isa => sub {
44             die 'frequency must be a positive number (Hz)'
45             if !defined $_[0]
46             or !looks_like_number $_[0]
47             or $_[0] <= 0;
48             },
49             reader => 'get_concertfreq',
50             writer => 'set_concertfreq',
51             );
52              
53             has concertpitch => (
54             is => 'rw',
55             default => sub { 69 },
56             isa => sub {
57             die 'pitch must be a positive number'
58             if !defined $_[0]
59             or !looks_like_number $_[0]
60             or $_[0] <= 0;
61             },
62             reader => 'get_concertpitch',
63             writer => 'set_concertpitch',
64             );
65              
66             has description => (
67             is => 'rw',
68             default => sub { '' },
69             isa => sub {
70             die 'description must be string value'
71             if !defined $_[0]
72             or defined reftype $_[0];
73             },
74             reader => 'get_description',
75             writer => 'set_description',
76             );
77              
78             # Sanity on scala scale file reads; other prudent limits with untrusted
79             # input would be to check the file size, and perhaps to bail if the note
80             # count is some absurd value.
81             has MAX_LINES => (
82             is => 'rw',
83             default => sub { 3000 },
84             );
85              
86             has notes => (
87             is => 'rw',
88             clearer => 1,
89             predicate => 1, # has_notes
90             );
91              
92             ##############################################################################
93             #
94             # METHODS
95              
96             sub BUILD {
97 6     6 0 45 my ($self, $param) = @_;
98              
99 6 50 66     21 if (exists $param->{file} and exists $param->{fh}) {
100 0         0 die "new accepts only one of the 'file' or 'fh' arguments\n";
101             }
102              
103 6 100       36 if (exists $param->{file}) {
    50          
104 1         4 $self->read_scala(file => $param->{file});
105             } elsif (exists $param->{fh}) {
106 0         0 $self->read_scala(fh => $param->{fh});
107             }
108             }
109              
110             # Absolute interval list to relative (1 2 3 -> 1 1 1)
111             sub abs2rel {
112 2     2 1 1237 my $self = shift;
113 2 50       7 return if !@_;
114 2         5 my @result = $_[0];
115 2 50       5 if (@_ > 1) {
116 2         6 for my $i (1 .. $#_) {
117 13         30 push @result, $_[$i] - $_[ $i - 1 ];
118             }
119             }
120 2         10 return @result;
121             }
122              
123             sub cents2ratio {
124 2     2 1 5 my ($self, $cents, $precision) = @_;
125 2 50       8 croak 'cents must be a number' if !looks_like_number $cents;
126 2 100       5 if (defined $precision) {
127 1 50 33     6 croak 'precision must be a positive integer'
128             if !looks_like_number $precision or $precision < 0;
129 1         3 $precision = int $precision;
130             } else {
131 1         2 $precision = 2;
132             }
133              
134 2         19 return sprintf "%.*f", $precision, 10**($cents / 3986.31371386484);
135             }
136              
137             # MIDI calculation, for easy comparison to scala results
138             sub freq2pitch {
139 1     1 1 595 my ($self, $freq) = @_;
140 1 50 33     9 croak 'frequency must be a positive number'
141             if !looks_like_number $freq
142             or $freq <= 0;
143              
144             # no precision, as assume pitch numbers are integers
145 1         14 return sprintf '%.0f',
146             $self->get_concertpitch +
147             12 * (log($freq / $self->get_concertfreq) / 0.693147180559945);
148             }
149              
150             sub get_cents {
151 3     3 1 819 my ($self) = @_;
152 3 50       12 croak 'no scala loaded' if !$self->has_notes;
153 3         4 return $self->notes2cents(@{ $self->notes });
  3         8  
154             }
155              
156             sub get_notes {
157 6     6 1 3069 my ($self) = @_;
158 6 100       33 croak 'no scala loaded' if !$self->has_notes;
159 5         5 return @{ $self->notes };
  5         38  
160             }
161              
162             sub get_ratios {
163 3     3 1 840 my ($self) = @_;
164 3 50       10 croak 'no scala loaded' if !$self->has_notes;
165 3         5 return $self->notes2ratios(@{ $self->notes });
  3         8  
166             }
167              
168             sub interval2freq {
169 5     5 1 13 my $self = shift;
170 5 50       15 croak 'no scala loaded' if !$self->has_notes;
171              
172 5         7 my @ratios = $self->notes2ratios(@{ $self->notes });
  5         12  
173              
174 5         5 my @freqs;
175 5 50       14 for my $i (ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_) {
  0         0  
176 79 100       91 if ($i == 0) { # special case for unison (ratio 1/1)
177 5         13 push @freqs, $self->get_concertfreq;
178             } else {
179 74 100       105 my $is_dsc = $i < 0 ? 1 : 0;
180              
181             # for non-"octave" portion, if any
182 74         76 my $offset = $i % @ratios;
183              
184             # "Octave" portion, if any - how many times the interval
185             # passes through the complete scale
186 74         86 my $octave_freq = 0;
187 74         96 my $octave_count = abs int $i / @ratios;
188              
189             # if non-octave on a negative interval, go one octave past
190             # the target, then use the regular ascending logic to
191             # backtrack to the proper frequency
192 74 100 100     151 $octave_count++ if $is_dsc and $offset != 0;
193              
194 74 100       98 if ($octave_count > 0) {
195 58         64 my $octaves_ratio = $ratios[-1]**$octave_count;
196 58 100       85 $octaves_ratio = 1 / $octaves_ratio if $is_dsc;
197 58         77 $octave_freq = $self->get_concertfreq * $octaves_ratio;
198             }
199              
200 74         71 my $remainder_freq = 0;
201 74 100       94 if ($offset != 0) {
202 59   66     96 $remainder_freq =
203             ($octave_freq || $self->get_concertfreq) * $ratios[ $offset - 1 ];
204              
205             # zero as remainder is based from $octave_freq, if
206             # relevant, so already includes such
207 59         66 $octave_freq = 0;
208             }
209              
210 74         128 push @freqs, $octave_freq + $remainder_freq;
211             }
212             }
213              
214 5         23 return @freqs;
215             }
216              
217             sub is_octavish {
218 2     2 1 11 my $self = shift;
219 2 50       9 croak 'no scala loaded' if !$self->has_notes;
220              
221 2         3 my @ratios = $self->notes2ratios(@{ $self->notes });
  2         6  
222              
223             # not octave bounded (double the frequency, e.g. 440 to 880)
224 2 100       9 return 0 if $ratios[-1] != 2;
225              
226 1         2 my $min;
227 1         3 for my $r (@ratios) {
228             # don't know how to handle negative ratios
229 12 50       17 return 0 if $r < 0;
230              
231             # multiple scales within the same definition file (probably for
232             # instruments that have two different scales in the same
233             # frequency domain) - but don't know how to handle these
234 12 50 66     28 return 0 if defined $min and $r <= $min;
235              
236 12         13 $min = $r;
237             }
238              
239 1         5 return 1;
240             }
241              
242             sub notes2cents {
243 17     17 1 28 my $self = shift;
244              
245 17         22 my @cents;
246 17 50       36 for my $n (ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_) {
  0         0  
247 42 100       114 if ($n =~ m{([0-9]+)/([1-9][0-9]*)}) {
248 20         78 push @cents, 1200 * ((log($1 / $2) / 2.30258509299405) / 0.301029995663981);
249             } else {
250 22         42 push @cents, $n;
251             }
252             }
253              
254 17         74 return @cents;
255             }
256              
257             sub notes2ratios {
258 11     11 1 14 my $self = shift;
259              
260 11         14 my @ratios;
261 11 50       27 for my $n (ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_) {
  0         0  
262 82 100       166 if ($n =~ m{([0-9]+)/([1-9][0-9]*)}) {
263 25         55 push @ratios, $1 / $2; # ratio, as marked with /
264             } else {
265 57         123 push @ratios, 10**($n / 3986.31371386484);
266             }
267             }
268              
269 11         34 return @ratios;
270             }
271              
272             # MIDI for comparison, the other way
273             sub pitch2freq {
274 54     54 1 237 my ($self, $pitch) = @_;
275 54 50 33     148 croak "pitch must be MIDI number"
276             if !looks_like_number $pitch
277             or $pitch < 0;
278              
279 54         252 return $self->get_concertfreq * (2**(($pitch - $self->get_concertpitch) / 12));
280             }
281              
282             sub ratio2cents {
283 2     2 1 779 my ($self, $ratio, $precision) = @_;
284 2 50       7 croak 'ratio must be a number' if !looks_like_number $ratio;
285 2 100       6 if (defined $precision) {
286 1 50 33     18 croak 'precision must be a positive integer'
287             if !looks_like_number $precision or $precision < 0;
288 1         2 $precision = int $precision;
289             } else {
290 1         2 $precision = 2;
291             }
292              
293 2         19 return sprintf "%.*f", $precision,
294             1200 * ((log($ratio) / 2.30258509299405) / 0.301029995663981);
295             }
296              
297             sub read_scala {
298 10     10 1 4657 my $self = shift;
299 10         14 my %param;
300 10 100       22 if (@_ == 1) {
301 1         2 $param{file} = $_[0];
302             } else {
303 9         22 %param = @_;
304             }
305              
306 10         13 my $fh;
307 10 50       15 if (exists $param{file}) {
    0          
308 10 100       335 open($fh, '<', $param{file}) or croak 'open failed: ' . $!;
309             } elsif (exists $param{fh}) {
310 0         0 $fh = $param{fh};
311             } else {
312 0         0 croak 'must specify file or fh parameter to read_scala';
313             }
314 9 100       44 if (exists $param{binmode}) {
    100          
315 1 50   1   25 binmode $fh, $param{binmode} or croak 'binmode failed: ' . $!;
  1         5  
  1         2  
  1         5  
316             } elsif ($self->has_binmode) {
317 5 50       45 binmode $fh, $self->get_binmode or croak 'binmode failed: ' . $!;
318             }
319              
320 9         9237 my (@scala, $line_count);
321 9         179 while (!eof($fh)) {
322 29         64 my $line = readline $fh;
323 29 50       40 croak 'readline failed: ' . $! unless defined $line;
324 29 100       77 croak 'input exceeds MAX_LINES' if ++$line_count >= $self->MAX_LINES;
325 28 100       73 next if $line =~ m/^[!]/; # skip comments
326              
327 16         22 chomp $line;
328 16         27 push @scala, $line;
329              
330 16 100       35 last if @scala == 2;
331             }
332             # but as might hit the MAX_LINES or eof() instead check again...
333 8 50       18 if (@scala != 2) {
334 0         0 croak 'missing description or note count lines';
335             }
336              
337 8         174 $self->set_description(shift @scala);
338 8         53 my $NOTECOUNT;
339 8 50       29 if ($scala[-1] =~ m/^\s*([0-9]+)/) {
340 8         14 $NOTECOUNT = $1;
341             } else {
342 0         0 croak 'could not parse note count';
343             }
344              
345 8         11 my @notes;
346 8         9 my $cur_note = 1;
347 8         18 while (!eof($fh)) {
348 94         134 my $line = readline $fh;
349 94 50       115 croak 'readline failed: ' . $! unless defined $line;
350 94 50       149 croak 'input exceeds MAX_LINES' if ++$line_count >= $self->MAX_LINES;
351 94 100       149 next if $line =~ m/^[!]/; # skip comments
352              
353             # All the scales.zip *.scl files as of 2013-02-19 have digits on
354             # both sides of the dot (so there are no ".42" cent values, but
355             # the "these are all valid pitch lines" does include a "408." as
356             # allowed). Some scale files have negative cents, though that is
357             # illegal for ratios. All the ratios are plain numbers (no
358             # period), or if they have a slash, it is followed by another
359             # number (so no "42/" cases). Checked via various greps on the
360             # file contents.
361 88 100       246 if ($line =~ m/^\s* ( -?[0-9]+\. [0-9]* ) /x) {
    50          
    50          
362 51         93 push @notes, $1; # cents
363             } elsif ($line =~ m{^\s* -[0-9] }x) {
364             # specification says these "should give a read error"
365 0         0 croak 'invalid negative ratio in note list';
366             } elsif ($line =~ m{^\s* ( [1-9][0-9]* (?:/[0-9]+)? ) }x) {
367 37         57 my $ratio = $1;
368 37 100       66 $ratio .= '/1' if $ratio !~ m{/}; # implicit qualify of ratios
369 37         53 push @notes, $ratio;
370             } else {
371             # Nothing in the spec about non-matching lines, so blow up.
372             # However, there are six files in scales.zip that have
373             # trailing blank lines, though these blank lines occur only
374             # after an appropriate number of note entries. So must exit
375             # loop before reading those invalid? lines. (Did mail the
376             # author about these, so probably has been rectified.)
377 0         0 croak 'invalid note specification on line ' . $.;
378             }
379              
380 88 100       195 last if $cur_note++ >= $NOTECOUNT;
381             }
382 8 50       11 if (@notes != $NOTECOUNT) {
383 0         0 croak 'expected ' . $NOTECOUNT . ' notes but got ' . scalar(@notes) . " notes";
384             }
385              
386             # edge case: remove any 1/1 (zero cents) at head of the list, as
387             # this implementation treats that as implicit
388 8 100       19 shift @notes if sprintf("%.0f", $self->notes2cents($notes[0])) == 0;
389              
390 8         23 $self->notes(\@notes);
391              
392 8         126 return $self;
393             }
394              
395             # Relative interval list to absolute (1 1 1 -> 1 2 3)
396             sub rel2abs {
397 2     2 1 4 my $self = shift;
398 2 50       5 return if !@_;
399 2         3 my @result = $_[0];
400 2 50       5 if (@_ > 1) {
401 2         4 for my $i (1 .. $#_) {
402 13         20 push @result, $result[-1] + $_[$i];
403             }
404             }
405 2         7 return @result;
406             }
407              
408             # Given list of frequencies, assume first is root frequency, then
409             # convert the remainder of the frequencies to cents against that first
410             # frequency.
411             sub set_by_frequency {
412 2     2 1 687 my $self = shift;
413 2 100       7 my $freqs = ref $_[0] eq 'ARRAY' ? $_[0] : \@_;
414 2 50       6 croak 'need both root and other frequencies' if @$freqs < 2;
415 2 50       5 croak 'root frequency must not be zero' if $freqs->[0] == 0;
416              
417 2         3 my @notes;
418 2         3 for my $i (1 .. $#{$freqs}) {
  2         6  
419 3         10 push @notes,
420             1200 *
421             ((log($freqs->[$i] / $freqs->[0]) / 2.30258509299405) / 0.301029995663981);
422             }
423              
424             # edge case: remove any 1/1 (zero cents) at head of the list, as
425             # this implementation treats that as implicit
426 2 50       5 shift @notes if sprintf("%.0f", $self->notes2cents($notes[0])) == 0;
427              
428 2         8 $self->notes(\@notes);
429              
430 2         6 return $self;
431             }
432              
433             sub set_notes {
434 3     3 1 913 my $self = shift;
435 3         4 my @notes;
436 3 100       9 for my $n (ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_) {
  1         3  
437 10 100       50 if ($n =~ m{^ -?[0-9]+\. (?:[0-9]+)? $}x) {
    50          
438 6         11 push @notes, $n;
439             } elsif ($n =~ m{^ [1-9][0-9]* (?:/[0-9]+)? $}x) {
440 4         5 my $ratio = $n;
441 4 50       9 $ratio .= '/1' if $ratio !~ m{/}; # implicit qualify of ratios
442 4         8 push @notes, $ratio;
443             } else {
444 0         0 croak 'notes must be integer ratios or real numbers';
445             }
446             }
447              
448             # edge case: remove any 1/1 (zero cents) at head of the list, as
449             # this implementation treats that as implicit
450 3 50       7 shift @notes if sprintf("%.0f", $self->notes2cents($notes[0])) == 0;
451              
452 3         13 $self->notes(\@notes);
453 3         7 return $self;
454             }
455              
456             sub write_scala {
457 2     2 1 2106 my $self = shift;
458 2 50       7 croak 'no scala loaded' if !$self->has_notes;
459              
460 2         4 my %param;
461 2 50       7 if (@_ == 1) {
462 0         0 $param{file} = $_[0];
463             } else {
464 2         7 %param = @_;
465             }
466              
467 2         24 my $fh;
468 2 100       8 if (exists $param{file}) {
    50          
469 1 50       92 open($fh, '>', $param{file}) or croak 'open failed: ' . $!;
470             } elsif (exists $param{fh}) {
471 1         3 $fh = $param{fh};
472             } else {
473 0         0 croak 'must specify file or fh parameter to write_scala';
474             }
475 2 100       9 if (exists $param{binmode}) {
    50          
476 1 50       12 binmode $fh, $param{binmode} or croak 'binmode failed: ' . $!;
477             } elsif ($self->has_binmode) {
478 1 50       7 binmode $fh, $self->get_binmode or croak 'binmode failed: ' . $!;
479             }
480              
481             my $filename = basename($param{file})
482 2 100       118 if exists $param{file};
483 2   50     4 my $note_count = @{ $self->notes } || 0;
484              
485 2 100       24 say $fh defined $filename
486             ? "! $filename"
487             : '!';
488 2         6 say $fh '!';
489 2         8 say $fh $self->get_description;
490 2         8 say $fh ' ', $note_count;
491 2         3 say $fh '!'; # conventional comment between note count and notes
492              
493 2         3 for my $note (@{ $self->notes }) {
  2         6  
494 14         21 say $fh ' ', $note;
495             }
496              
497 2         58 return $self;
498             }
499              
500             1;
501             __END__