File Coverage

blib/lib/Music/Tension/Cope.pm

Criterion	Covered	Total	%
statement	81	81	100.0
branch	54	54	100.0
condition	45	45	100.0
subroutine	12	12	100.0
pod	7	7	100.0
total	199	199	100.0

# -*- Perl -*-
#
# "Copian" tension analysis for 12-pitch material in equal temperament

package Music::Tension::Cope;

our $VERSION = '1.03';

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

use parent qw(Music::Tension);

my $DEG_IN_SCALE = 12;

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

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

    if ( exists $param{duration_weight} ) {
        croak "duration_weight must be a number"
          if !looks_like_number $param{duration_weight};
        $self->{_duration_weight} = $param{duration_weight};
    } else {
        $self->{_duration_weight} = 0.1;
    }

    if ( exists $param{metric_weight} ) {
        croak "metric_weight must be a number"
          if !looks_like_number $param{metric_weight};
        $self->{_metric_weight} = $param{metric_weight};
    } else {
        $self->{_metric_weight} = 0.1;
    }

    if ( exists $param{octave_adjust} ) {
        croak "octave_adjust must be a number"
          if !looks_like_number $param{octave_adjust};
        $self->{_octave_adjust} = $param{octave_adjust};
    } else {
        $self->{_octave_adjust} = -0.02;
    }

    if ( exists $param{tensions} ) {
        croak "tensions must be a hash reference"
          unless defined $param{tensions} and ref $param{tensions} eq 'HASH';
        for my $i ( 0 .. 11 ) {
            croak "tensions must include all intervals from 0 through 11"
              if !exists $param{tensions}->{$i};
        }
        $self->{_tensions} = $param{tensions};
    } else {
        # default interval tensions taken from "Computer Models of
        # Musical Creativity", Cope, p.229-230, from least tension (0.0)
        # to greatest (1.0), less if greater than an octave
        $self->{_tensions} = {
            0  => 0.0,
            1  => 1.0,
            2  => 0.8,
            3  => 0.225,
            4  => 0.2,
            5  => 0.55,
            6  => 0.65,
            7  => 0.1,
            8  => 0.275,
            9  => 0.25,
            10 => 0.7,
            11 => 0.9,
        };
    }

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

# approach tension - horizontal tension, I'm assuming harmonic function,
# therefore limit to intervals in same register.
sub approach {
    my ( $self, $p1 ) = @_;
    croak "pitch is required"     if !defined $p1;
    croak "pitch must be integer" if $p1 !~ m/^-?[0-9]+$/;

    $self->pitches( 0, abs($p1) % $DEG_IN_SCALE );
}

# tension over durations
sub duration {
    my ( $self, $input, $duration ) = @_;

    croak "duration must be a positive value"
      if !defined $duration
      or !looks_like_number($duration)
      or $duration <= 0;

    my $tension;
    if ( ref $input eq 'ARRAY' ) {
        $tension = $self->vertical($input);
    } elsif ( looks_like_number($input) ) {
        $tension = $input;
    } else {
        croak "unknown pitch set or prior tension value";
    }

    # p.232-233 [Cope 2005] - this result "is then added to any grouping's
    #   accumulated tension weighting"
    return $self->{_duration_weight} * $duration +
      $self->{_duration_weight} * $tension;
}

# KLUGE things into whatever is closest equal temperament for now
sub frequencies {
    my ( $self, $f1, $f2 ) = @_;
    croak "two frequencies required" if !defined $f1 or !defined $f2;
    croak "frequencies must be positive numbers"
      if !looks_like_number $f1
      or !looks_like_number $f2
      or $f1 < 0
      or $f2 < 0;

    $self->pitches( map $self->freq2pitch($_), $f1, $f2 );
}

# tension based on where note is within measure p.232 [Cope 2005]
sub metric {
    my ( $self, $b, $v ) = @_;
    croak "input must be positive numeric"
      if !defined $b
      or !looks_like_number($b)
      or $b <= 0
      or !defined $v
      or !looks_like_number($v)
      or $v <= 0;

    return ( $b * $self->{_metric_weight} ) / $v;
}

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

    my $interval = abs( $p2 - $p1 );
    my $octave   = int( $interval / $DEG_IN_SCALE );
    my $tension =
      $self->{_tensions}->{ $interval % $DEG_IN_SCALE } +
      ( $octave > 0 ? $self->{_octave_adjust} : 0 );
    $tension = 0 if $tension < 0;

    return $tension;
}

# tension from first note to all others above it in a passed pitch set.
# returns sum, min, max, and an array ref of tensions, unless just the
# sum is desired by context
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 @pcs = @$pset;

    # reposition pitches upwards if subsequent lower than the
    # initial pitch
    for my $i ( 1 .. $#pcs ) {
        if ( $pcs[$i] < $pcs[0] ) {
            $pcs[$i] += $DEG_IN_SCALE +
              ( int( ( $pcs[0] - $pcs[$i] - 1 ) / $DEG_IN_SCALE ) ) * $DEG_IN_SCALE;
        }
    }

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

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

1;
__END__