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

# -*- Perl -*-
#
# Scala scale (musical tuning and temperament) support for Perl, based
# on specification at: http://www.huygens-fokker.org/scala/
#
# Ratio to cent and cent to ratio equations lifted from "Musimathics,
# volume 1", pp. 45-46. MIDI conversion probably from wikipedia.

package Music::Scala;

use 5.010000;
use strict;
use warnings;

use Carp qw/croak/;
use File::Basename qw/basename/;
use Moo;
use namespace::clean;
use Scalar::Util qw/looks_like_number reftype/;

our $VERSION = '1.06';

##############################################################################
#
# ATTRIBUTES
#
# NOTE that much of the Moo setup (getters/setters, how "notes" handled,
# etc) is to preserve compatibility with how the code worked pre-Moo.
# Additional hilarity stemmed from (the mistake of?) offering multiple
# methods to get/set the same data in different guises (notes (as cents
# or ratios), (notes as) cents, (notes as) ratios).

has binmode => (
    is        => 'rw',
    predicate => 1,               # has_binmode
    reader    => 'get_binmode',
    writer    => 'set_binmode',
);

has concertfreq => (
    is      => 'rw',
    default => sub { 440 },
    isa     => sub {
        die 'frequency must be a positive number (Hz)'
          if !defined $_[0]
          or !looks_like_number $_[0]
          or $_[0] <= 0;
    },
    reader => 'get_concertfreq',
    writer => 'set_concertfreq',
);

has concertpitch => (
    is      => 'rw',
    default => sub { 69 },
    isa     => sub {
        die 'pitch must be a positive number'
          if !defined $_[0]
          or !looks_like_number $_[0]
          or $_[0] <= 0;
    },
    reader => 'get_concertpitch',
    writer => 'set_concertpitch',
);

has description => (
    is      => 'rw',
    default => sub { '' },
    isa     => sub {
        die 'description must be string value'
          if !defined $_[0]
          or defined reftype $_[0];
    },
    reader => 'get_description',
    writer => 'set_description',
);

# Sanity on scala scale file reads; other prudent limits with untrusted
# input would be to check the file size, and perhaps to bail if the note
# count is some absurd value.
has MAX_LINES => (
    is      => 'rw',
    default => sub { 3000 },
);

has notes => (
    is        => 'rw',
    clearer   => 1,
    predicate => 1,      # has_notes
);

##############################################################################
#
# METHODS

sub BUILD {
    my ($self, $param) = @_;

    if (exists $param->{file} and exists $param->{fh}) {
        die "new accepts only one of the 'file' or 'fh' arguments\n";
    }

    if (exists $param->{file}) {
        $self->read_scala(file => $param->{file});
    } elsif (exists $param->{fh}) {
        $self->read_scala(fh => $param->{fh});
    }
}

# Absolute interval list to relative (1 2 3 -> 1 1 1)
sub abs2rel {
    my $self = shift;
    return if !@_;
    my @result = $_[0];
    if (@_ > 1) {
        for my $i (1 .. $#_) {
            push @result, $_[$i] - $_[ $i - 1 ];
        }
    }
    return @result;
}

sub cents2ratio {
    my ($self, $cents, $precision) = @_;
    croak 'cents must be a number' if !looks_like_number $cents;
    if (defined $precision) {
        croak 'precision must be a positive integer'
          if !looks_like_number $precision or $precision < 0;
        $precision = int $precision;
    } else {
        $precision = 2;
    }

    return sprintf "%.*f", $precision, 10**($cents / 3986.31371386484);
}

# MIDI calculation, for easy comparison to scala results
sub freq2pitch {
    my ($self, $freq) = @_;
    croak 'frequency must be a positive number'
      if !looks_like_number $freq
      or $freq <= 0;

    # no precision, as assume pitch numbers are integers
    return sprintf '%.0f',
      $self->get_concertpitch +
      12 * (log($freq / $self->get_concertfreq) / 0.693147180559945);
}

sub get_cents {
    my ($self) = @_;
    croak 'no scala loaded' if !$self->has_notes;
    return $self->notes2cents(@{ $self->notes });
}

sub get_notes {
    my ($self) = @_;
    croak 'no scala loaded' if !$self->has_notes;
    return @{ $self->notes };
}

sub get_ratios {
    my ($self) = @_;
    croak 'no scala loaded' if !$self->has_notes;
    return $self->notes2ratios(@{ $self->notes });
}

sub interval2freq {
    my $self = shift;
    croak 'no scala loaded' if !$self->has_notes;

    my @ratios = $self->notes2ratios(@{ $self->notes });

    my @freqs;
    for my $i (ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_) {
        if ($i == 0) {    # special case for unison (ratio 1/1)
            push @freqs, $self->get_concertfreq;
        } else {
            my $is_dsc = $i < 0 ? 1 : 0;

            # for non-"octave" portion, if any
            my $offset = $i % @ratios;

            # "Octave" portion, if any - how many times the interval
            # passes through the complete scale
            my $octave_freq  = 0;
            my $octave_count = abs int $i / @ratios;

            # if non-octave on a negative interval, go one octave past
            # the target, then use the regular ascending logic to
            # backtrack to the proper frequency
            $octave_count++ if $is_dsc and $offset != 0;

            if ($octave_count > 0) {
                my $octaves_ratio = $ratios[-1]**$octave_count;
                $octaves_ratio = 1 / $octaves_ratio if $is_dsc;
                $octave_freq   = $self->get_concertfreq * $octaves_ratio;
            }

            my $remainder_freq = 0;
            if ($offset != 0) {
                $remainder_freq =
                  ($octave_freq || $self->get_concertfreq) * $ratios[ $offset - 1 ];

                # zero as remainder is based from $octave_freq, if
                # relevant, so already includes such
                $octave_freq = 0;
            }

            push @freqs, $octave_freq + $remainder_freq;
        }
    }

    return @freqs;
}

sub is_octavish {
    my $self = shift;
    croak 'no scala loaded' if !$self->has_notes;

    my @ratios = $self->notes2ratios(@{ $self->notes });

    # not octave bounded (double the frequency, e.g. 440 to 880)
    return 0 if $ratios[-1] != 2;

    my $min;
    for my $r (@ratios) {
        # don't know how to handle negative ratios
        return 0 if $r < 0;

        # multiple scales within the same definition file (probably for
        # instruments that have two different scales in the same
        # frequency domain) - but don't know how to handle these
        return 0 if defined $min and $r <= $min;

        $min = $r;
    }

    return 1;
}

sub notes2cents {
    my $self = shift;

    my @cents;
    for my $n (ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_) {
        if ($n =~ m{([0-9]+)/([1-9][0-9]*)}) {
            push @cents, 1200 * ((log($1 / $2) / 2.30258509299405) / 0.301029995663981);
        } else {
            push @cents, $n;
        }
    }

    return @cents;
}

sub notes2ratios {
    my $self = shift;

    my @ratios;
    for my $n (ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_) {
        if ($n =~ m{([0-9]+)/([1-9][0-9]*)}) {
            push @ratios, $1 / $2;    # ratio, as marked with /
        } else {
            push @ratios, 10**($n / 3986.31371386484);
        }
    }

    return @ratios;
}

# MIDI for comparison, the other way
sub pitch2freq {
    my ($self, $pitch) = @_;
    croak "pitch must be MIDI number"
      if !looks_like_number $pitch
      or $pitch < 0;

    return $self->get_concertfreq * (2**(($pitch - $self->get_concertpitch) / 12));
}

sub ratio2cents {
    my ($self, $ratio, $precision) = @_;
    croak 'ratio must be a number' if !looks_like_number $ratio;
    if (defined $precision) {
        croak 'precision must be a positive integer'
          if !looks_like_number $precision or $precision < 0;
        $precision = int $precision;
    } else {
        $precision = 2;
    }

    return sprintf "%.*f", $precision,
      1200 * ((log($ratio) / 2.30258509299405) / 0.301029995663981);
}

sub read_scala {
    my $self = shift;
    my %param;
    if (@_ == 1) {
        $param{file} = $_[0];
    } else {
        %param = @_;
    }

    my $fh;
    if (exists $param{file}) {
        open($fh, '<', $param{file}) or croak 'open failed: ' . $!;
    } elsif (exists $param{fh}) {
        $fh = $param{fh};
    } else {
        croak 'must specify file or fh parameter to read_scala';
    }
    if (exists $param{binmode}) {
        binmode $fh, $param{binmode} or croak 'binmode failed: ' . $!;
    } elsif ($self->has_binmode) {
        binmode $fh, $self->get_binmode or croak 'binmode failed: ' . $!;
    }

    my (@scala, $line_count);
    while (!eof($fh)) {
        my $line = readline $fh;
        croak 'readline failed: ' . $! unless defined $line;
        croak 'input exceeds MAX_LINES' if ++$line_count >= $self->MAX_LINES;
        next if $line =~ m/^[!]/;    # skip comments

        chomp $line;
        push @scala, $line;

        last if @scala == 2;
    }
    # but as might hit the MAX_LINES or eof() instead check again...
    if (@scala != 2) {
        croak 'missing description or note count lines';
    }

    $self->set_description(shift @scala);
    my $NOTECOUNT;
    if ($scala[-1] =~ m/^\s*([0-9]+)/) {
        $NOTECOUNT = $1;
    } else {
        croak 'could not parse note count';
    }

    my @notes;
    my $cur_note = 1;
    while (!eof($fh)) {
        my $line = readline $fh;
        croak 'readline failed: ' . $! unless defined $line;
        croak 'input exceeds MAX_LINES' if ++$line_count >= $self->MAX_LINES;
        next if $line =~ m/^[!]/;    # skip comments

        # All the scales.zip *.scl files as of 2013-02-19 have digits on
        # both sides of the dot (so there are no ".42" cent values, but
        # the "these are all valid pitch lines" does include a "408." as
        # allowed). Some scale files have negative cents, though that is
        # illegal for ratios. All the ratios are plain numbers (no
        # period), or if they have a slash, it is followed by another
        # number (so no "42/" cases). Checked via various greps on the
        # file contents.
        if ($line =~ m/^\s* ( -?[0-9]+\. [0-9]* ) /x) {
            push @notes, $1;    # cents
        } elsif ($line =~ m{^\s* -[0-9] }x) {
            # specification says these "should give a read error"
            croak 'invalid negative ratio in note list';
        } elsif ($line =~ m{^\s* ( [1-9][0-9]* (?:/[0-9]+)? ) }x) {
            my $ratio = $1;
            $ratio .= '/1' if $ratio !~ m{/};    # implicit qualify of ratios
            push @notes, $ratio;
        } else {
            # Nothing in the spec about non-matching lines, so blow up.
            # However, there are six files in scales.zip that have
            # trailing blank lines, though these blank lines occur only
            # after an appropriate number of note entries. So must exit
            # loop before reading those invalid? lines. (Did mail the
            # author about these, so probably has been rectified.)
            croak 'invalid note specification on line ' . $.;
        }

        last if $cur_note++ >= $NOTECOUNT;
    }
    if (@notes != $NOTECOUNT) {
        croak 'expected ' . $NOTECOUNT . ' notes but got ' . scalar(@notes) . " notes";
    }

    # edge case: remove any 1/1 (zero cents) at head of the list, as
    # this implementation treats that as implicit
    shift @notes if sprintf("%.0f", $self->notes2cents($notes[0])) == 0;

    $self->notes(\@notes);

    return $self;
}

# Relative interval list to absolute (1 1 1 -> 1 2 3)
sub rel2abs {
    my $self = shift;
    return if !@_;
    my @result = $_[0];
    if (@_ > 1) {
        for my $i (1 .. $#_) {
            push @result, $result[-1] + $_[$i];
        }
    }
    return @result;
}

# Given list of frequencies, assume first is root frequency, then
# convert the remainder of the frequencies to cents against that first
# frequency.
sub set_by_frequency {
    my $self  = shift;
    my $freqs = ref $_[0] eq 'ARRAY' ? $_[0] : \@_;
    croak 'need both root and other frequencies' if @$freqs < 2;
    croak 'root frequency must not be zero'      if $freqs->[0] == 0;

    my @notes;
    for my $i (1 .. $#{$freqs}) {
        push @notes,
          1200 *
          ((log($freqs->[$i] / $freqs->[0]) / 2.30258509299405) / 0.301029995663981);
    }

    # edge case: remove any 1/1 (zero cents) at head of the list, as
    # this implementation treats that as implicit
    shift @notes if sprintf("%.0f", $self->notes2cents($notes[0])) == 0;

    $self->notes(\@notes);

    return $self;
}

sub set_notes {
    my $self = shift;
    my @notes;
    for my $n (ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_) {
        if ($n =~ m{^ -?[0-9]+\. (?:[0-9]+)? $}x) {
            push @notes, $n;
        } elsif ($n =~ m{^ [1-9][0-9]* (?:/[0-9]+)? $}x) {
            my $ratio = $n;
            $ratio .= '/1' if $ratio !~ m{/};    # implicit qualify of ratios
            push @notes, $ratio;
        } else {
            croak 'notes must be integer ratios or real numbers';
        }
    }

    # edge case: remove any 1/1 (zero cents) at head of the list, as
    # this implementation treats that as implicit
    shift @notes if sprintf("%.0f", $self->notes2cents($notes[0])) == 0;

    $self->notes(\@notes);
    return $self;
}

sub write_scala {
    my $self = shift;
    croak 'no scala loaded' if !$self->has_notes;

    my %param;
    if (@_ == 1) {
        $param{file} = $_[0];
    } else {
        %param = @_;
    }

    my $fh;
    if (exists $param{file}) {
        open($fh, '>', $param{file}) or croak 'open failed: ' . $!;
    } elsif (exists $param{fh}) {
        $fh = $param{fh};
    } else {
        croak 'must specify file or fh parameter to write_scala';
    }
    if (exists $param{binmode}) {
        binmode $fh, $param{binmode} or croak 'binmode failed: ' . $!;
    } elsif ($self->has_binmode) {
        binmode $fh, $self->get_binmode or croak 'binmode failed: ' . $!;
    }

    my $filename = basename($param{file})
      if exists $param{file};
    my $note_count = @{ $self->notes } || 0;

    say $fh defined $filename
      ? "! $filename"
      : '!';
    say $fh '!';
    say $fh $self->get_description;
    say $fh ' ', $note_count;
    say $fh '!';    # conventional comment between note count and notes

    for my $note (@{ $self->notes }) {
        say $fh ' ', $note;
    }

    return $self;
}

1;
__END__