File Coverage

blib/lib/Music/Tension/PlompLevelt.pm

Criterion	Covered	Total	%
statement	76	85	89.4
branch	18	34	52.9
condition	6	22	27.2
subroutine	11	11	100.0
pod	4	4	100.0
total	115	156	73.7

# -*- Perl -*-
#
# "Plomp-Levelt consonance curve" implementation
#
# Beta interface! May change without notice!

package Music::Tension::PlompLevelt;

use 5.010000;
use strict;
use warnings;

use Carp qw/croak/;
use List::Util qw/sum/;
use Music::Tension ();
use Scalar::Util qw/looks_like_number/;

our @ISA     = qw(Music::Tension);
our $VERSION = '0.70';

# 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 ],
);

########################################################################
#
# SUBROUTINES

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 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 ( 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 ( 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/^\d+$/
      or $p2 !~ m/^\d+$/;

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

sub vertical {
  my ( $self, $pset ) = @_;
  croak "pitch set must be array ref" unless 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__