File Coverage

blib/lib/Music/Tension/Counterpoint.pm

Criterion	Covered	Total	%
statement	81	81	100.0
branch	54	54	100.0
condition	15	15	100.0
subroutine	11	11	100.0
pod	4	4	100.0
total	165	165	100.0

# -*- Perl -*-
#
# Counterpoint tension calculation, which here means a boolean pass or
# fail depending on the interval(s) involved

package Music::Tension::Counterpoint;

our $VERSION = '1.03';

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

use constant { DISS => 0, CONS => 1 };

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{big_dissonance} ) {
        $self->{_big_dissonance} = $param{big_dissonance};
    } else {
        # various counterpoint texts allow for dissonant intervals
        # larger than an octave, so this is the default
        $self->{_big_dissonance} = 1;
    }

    if ( exists $param{octave_allow} ) {
        $self->{_octave_allow} = $param{octave_allow};
    } else {
        $self->{_octave_allow} = 1;
    }

    # special lookup table for the "vertical" method when considering
    # interior voices to any voices above
    if ( exists $param{interior} ) {
        croak "interior must be a hash reference"
          unless defined $param{interior} and ref $param{interior} eq 'HASH';
        for my $i ( 0 .. 11 ) {
            croak "interior must include all intervals from 0 through 11"
              if !exists $param{interior}->{$i};
            $self->{_interior}{$i} = $param{interior}->{$i} ? CONS : DISS;
        }
    } else {
        # following Norden 1969
        $self->{_interior} = {
            0  => CONS,    # unison
            1  => DISS,    # minor 2nd
            2  => DISS,    # major 2nd
            3  => CONS,    # minor 3rd
            4  => CONS,    # major 3rd
            5  => CONS,    # perfect fourth
            6  => CONS,    # augmented fourth
            7  => CONS,    # fifth
            8  => CONS,    # minor 6th
            9  => CONS,    # major 6th
            10 => DISS,    # minor 7th
            11 => DISS,    # major 7th
        };
    }
    if ( exists $param{tensions} ) {
        croak "tensions must be a hash reference"
          unless defined $param{tensions} and ref $param{tensions} eq 'HASH';
        for my $i ( -11 .. 11 ) {
            croak "tensions must include all intervals from -11 through 11"
              if !exists $param{tensions}->{$i};
            $self->{_tensions}{$i} = $param{tensions}->{$i} ? CONS : DISS;
        }
    } else {
        # these are typical values for vertical intervals. the otherwise
        # redundant negative intervals are to support melodic checks
        # that may need to know whether a leap is ascending or
        # descending
        $self->{_tensions} = {
            0   => CONS,    # unison
            1   => DISS,    # minor 2nd
            2   => DISS,    # major 2nd
            3   => CONS,    # minor 3rd
            4   => CONS,    # major 3rd
            5   => DISS,    # fourth
            6   => DISS,    # the evil, evil tritone
            7   => CONS,    # fifth
            8   => CONS,    # minor 6th
            9   => CONS,    # major 6th
            10  => DISS,    # minor 7th
            11  => DISS,    # major 7th
            -1  => DISS,    # minor 2nd
            -2  => DISS,    # major 2nd
            -3  => CONS,    # minor 3rd
            -4  => CONS,    # major 3rd
            -5  => DISS,    # fourth
            -6  => DISS,    # the evil, evil tritone
            -7  => CONS,    # fifth
            -8  => CONS,    # minor 6th
            -9  => CONS,    # major 6th
            -10 => DISS,    # minor 7th
            -11 => DISS,    # major 7th
        };
    }

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

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 = $p2 - $p1;
    my $mod      = $interval % $DEG_IN_SCALE;

    if ( abs($interval) >= $DEG_IN_SCALE ) {
        if ( $mod == 0 ) {
            # exclusive test of octave intervals so that they can be
            # treated differently from the unison
            return $self->{_octave_allow} ? CONS : DISS;
        } else {
            # anything above an octave is okay by default; otherwise
            # falls through to the _tensions lookup below
            return CONS if $self->{_big_dissonance};
        }
    }

    my $neg = $interval < 0 ? $DEG_IN_SCALE : 0;
    return $self->{_tensions}->{ $mod - $neg };
}

# why not hide former synopsis code in a method?
sub usable_offsets {
    my $self = shift;
    my @ret  = $self->offset_tensions(@_);
    my @ok;
  OFFS: for my $i ( 1 .. $#ret ) {
        for my $consonant ( @{ $ret[$i] } ) {
            next OFFS unless $consonant;
        }
        push @ok, $i;
    }
    return @ok;
}

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;

    # the root (or lowest) pitch is from where special checks are done;
    # that pitch must be first in the list. also the sort simplifies the
    # interior interval checks (always non-negative intervals)
    my @pcs = sort { $a <=> $b } @$pset;

    for my $i ( 1 .. $#pcs ) {
        return DISS if $self->pitches( $pcs[0], $pcs[$i] ) == DISS;

        # interior voice interval checks may vary; Norden 1969 (p.84)
        # allows for interior perfect and augmented fourths in a 3-part
        # texture but presumably not 2nds nor 7ths. so, new lookup table
        if ( $i < $#pcs ) {
            for my $j ( $i + 1 .. $#pcs ) {
                my $interval = $pcs[$j] - $pcs[$i];
                my $mod      = $interval % $DEG_IN_SCALE;
                if ( $interval >= $DEG_IN_SCALE ) {
                    if ( $mod == 0 ) {
                        if ( $self->{_octave_allow} ) {
                            next;
                        } else {
                            return DISS;
                        }
                    } else {
                        next if $self->{_big_dissonance};
                    }
                }
                return DISS if $self->{_interior}{$mod} == DISS;
            }
        }
    }

    return CONS;
}

1;
__END__