File Coverage

blib/lib/Music/Tension/PlompLevelt.pm

Criterion	Covered	Total	%
statement	83	83	100.0
branch	34	34	100.0
condition	34	34	100.0
subroutine	10	10	100.0
pod	4	4	100.0
total	165	165	100.0

# -*- Perl -*-
#
# "Plomp-Levelt consonance curve" implementation

package Music::Tension::PlompLevelt;

our $VERSION = '1.03';

use strict;
use warnings;
use Carp qw/croak/;
use List::Util qw/sum/;
use Scalar::Util qw/looks_like_number/;

use parent qw(Music::Tension);

# pianowire* are from [Helmholtz 1877 p.79] relative intensity of first
# six harmonics of piano wire, struck at 1/7th its length, for various
# hammer types. Via http://jjensen.org/DissonanceCurve.html
my %AMPLITUDES = (
    'ones'              => [ (1) x 6 ],
    'pianowire-plucked' => [ 1, 0.8, 0.6, 0.3, 0.1, 0.03 ],
    'pianowire-soft'    => [ 1, 1.9, 1.1, 0.2, 0,   0.05 ],
    'pianowire-medium'  => [ 1, 2.9, 3.6, 2.6, 1.1, 0.2 ],
    'pianowire-hard'    => [ 1, 3.2, 5,   5,   3.2, 1 ],
);

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

sub new {
    my ( $class, %param ) = @_;
    my $self = $class->SUPER::new(%param);

    $self->{_amplitudes} = {%AMPLITUDES};

    if ( exists $param{amplitudes} ) {
        for my $name ( keys %{ $param{amplitudes} } ) {
            croak "amplitude profile '$name' must be array reference"
              unless defined $param{amplitudes}->{$name} and ref $param{amplitudes}->{$name} eq 'ARRAY';
            $self->{_amplitudes}->{$name} = $param{amplitudes}->{$name};
        }
    }

    if ( exists $param{default_amp_profile} ) {
        croak "no such profile '$param{default_amp_profile}'"
          unless exists $self->{_amplitudes}->{ $param{default_amp_profile} };
        $self->{_amp_profile} = $param{default_amp_profile};
    } else {
        $self->{_amp_profile} = 'pianowire-medium';
    }

    # NOTE will also need normalize if add setter method to update _amplitudes
    $self->{_normalize_amps} = exists $param{normalize_amps} ? 1 : 0;
    if ( $self->{_normalize_amps} ) {
        for my $amps ( values %{ $self->{_amplitudes} } ) {
            my $sum = sum @$amps;
            for my $amp (@$amps) {
                $amp /= $sum;
            }
        }
    }

    bless $self, $class;
    return $self;
}

# not sure if I've followed the papers correctly; they all operate on a
# single frequency with overtones above that, while for tension I'm
# interested in "given these two frequencies or pitches (with their own
# sets of overtones), how dissonant are they to one another" so
# hopefully I can just tally up the harmonics between the two different
# sets of harmonics?
#
# also, vertical scaling might take more looking at, perhaps arrange so
# with normalize_amps the maximum dissonance has the value of 1? (or
# that the most dissonant interval of the scale, e.g. minor 2nd in equal
# temperament has the value of one?)
sub frequencies {
    my ( $self, $f1, $f2 ) = @_;
    my @harmonics;

    if ( looks_like_number $f1) {
        for my $i ( 0 .. $#{ $self->{_amplitudes}->{ $self->{_amp_profile} } } ) {
            push @{ $harmonics[0] },
              { amp  => $self->{_amplitudes}->{ $self->{_amp_profile} }->[$i] || 0,
                freq => $f1 * ( $i + 1 ),
              };
        }
    } elsif ( defined $f1 and ref $f1 eq 'ARRAY' and @$f1 and ref $f1->[0] eq 'HASH' ) {
        $harmonics[0] = $f1;
    } else {
        croak "unknown input for frequency1";
    }

    if ( looks_like_number $f2) {
        for my $j ( 0 .. $#{ $self->{_amplitudes}->{ $self->{_amp_profile} } } ) {
            push @{ $harmonics[1] },
              { amp  => $self->{_amplitudes}->{ $self->{_amp_profile} }->[$j] || 0,
                freq => $f2 * ( $j + 1 ),
              };
        }
    } elsif ( defined $f2 and ref $f2 eq 'ARRAY' and @$f2 and ref $f2->[0] eq 'HASH' ) {
        $harmonics[1] = $f2;
    } else {
        croak "unknown input for frequency2";
    }

    # code ported from equation at http://jjensen.org/DissonanceCurve.html
    my $tension;
    for my $i ( 0 .. $#{ $harmonics[0] } ) {
        for my $j ( 0 .. $#{ $harmonics[1] } ) {
            my @freqs = sort { $a <=> $b } $harmonics[0]->[$i]{freq},
              $harmonics[1]->[$j]{freq};
            my $q = ( $freqs[1] - $freqs[0] ) / ( 0.021 * $freqs[0] + 19 );
            $tension +=
              $harmonics[0]->[$i]{amp} *
              $harmonics[1]->[$j]{amp} *
              ( exp( -0.84 * $q ) - exp( -1.38 * $q ) );
        }
    }

    return $tension;
}

sub pitches {
    my ( $self, $p1, $p2, $freq_harmonics ) = @_;
    croak "two pitches required" if !defined $p1 or !defined $p2;
    croak "pitches must be positive integers"
      if $p1 !~ m/^[0-9]+$/
      or $p2 !~ m/^[0-9]+$/;

    return $self->frequencies( map( $self->pitch2freq($_), $p1, $p2 ),
        $freq_harmonics );
}

sub vertical {
    my ( $self, $pset ) = @_;
    croak "pitch set must be array ref" unless defined $pset and ref $pset eq 'ARRAY';
    croak "pitch set must contain multiple elements" if @$pset < 2;

    my @freqs = map $self->pitch2freq($_), @$pset;

    my $min = ~0;
    my $max = 0;
    my ( @tensions, $sum );
    for my $i ( 1 .. $#freqs ) {
        my $t = $self->frequencies( $freqs[0], $freqs[$i] );
        $sum += $t;
        $min = $t
          if $t < $min;
        $max = $t
          if $t > $max;
        push @tensions, $t;
    }

    return wantarray ? ( $sum, $min, $max, \@tensions ) : $sum;
}

1;
__END__