File Coverage

blib/lib/Music/AtonalUtil.pm

Criterion	Covered	Total	%
statement	579	587	98.6
branch	294	328	89.6
condition	80	87	91.9
subroutine	56	56	100.0
pod	45	45	100.0
total	1054	1103	95.5

# -*- Perl -*-
#
# Code for atonal music analysis and composition (and a certain
# accumulation of somewhat related utility code, in the best fashion of
# that kitchen drawer).

package Music::AtonalUtil;

use 5.010;
use strict;
use warnings;

# as Math::Combinatorics does not preserve input order in return values
use Algorithm::Combinatorics qw/combinations/;
use Carp                     qw/croak/;
use List::Util               qw/shuffle uniqnum/;
use Scalar::Util             qw/looks_like_number refaddr/;

our $VERSION = '1.17';

my $DEG_IN_SCALE = 12;

# Forte Number to prime form mapping. These are mostly in agreement with
# Appendix 2, Table II in "Basic Atonal Theory" (rahn1980) by John Rahn
# (p.140-143), and also against Appendix 1 in "The Structure of Atonal
# Music" (forte1973) by Allen Forte (p.179-181), though Rahn and Forte use
# different methods and thus calculate different prime forms in a few
# cases. See t/forte2pcs2forte.t for tests of these against what
# prime_form() calculates. This code uses the Rahn method (though still
# calls them "Forte Numbers" instead of the perhaps more appropriate
# "Rahn Number").
#
# By mostly, my calculation disagrees with rahn1980 for 7-Z18, 7-20, and
# 8-26 (by eyeball inspection). These three look to be typos in
# rahn1980, as in each case Rahn used the Forte form.
#
# sorting is to align with the table in rahn1980
our %FORTE2PCS = (
    # trichords (complement nonachords)
    '3-1'  => [ 0, 1, 2 ],
    '3-2'  => [ 0, 1, 3 ],
    '3-3'  => [ 0, 1, 4 ],
    '3-4'  => [ 0, 1, 5 ],
    '3-5'  => [ 0, 1, 6 ],
    '3-6'  => [ 0, 2, 4 ],
    '3-7'  => [ 0, 2, 5 ],
    '3-8'  => [ 0, 2, 6 ],
    '3-9'  => [ 0, 2, 7 ],
    '3-10' => [ 0, 3, 6 ],
    '3-11' => [ 0, 3, 7 ],
    '3-12' => [ 0, 4, 8 ],
    # nonachords (trichords)
    '9-1'  => [ 0, 1, 2, 3, 4, 5, 6, 7, 8 ],
    '9-2'  => [ 0, 1, 2, 3, 4, 5, 6, 7, 9 ],
    '9-3'  => [ 0, 1, 2, 3, 4, 5, 6, 8, 9 ],
    '9-4'  => [ 0, 1, 2, 3, 4, 5, 7, 8, 9 ],
    '9-5'  => [ 0, 1, 2, 3, 4, 6, 7, 8, 9 ],
    '9-6'  => [ 0, 1, 2, 3, 4, 5, 6, 8, 10 ],
    '9-7'  => [ 0, 1, 2, 3, 4, 5, 7, 8, 10 ],
    '9-8'  => [ 0, 1, 2, 3, 4, 6, 7, 8, 10 ],
    '9-9'  => [ 0, 1, 2, 3, 5, 6, 7, 8, 10 ],
    '9-10' => [ 0, 1, 2, 3, 4, 6, 7, 9, 10 ],
    '9-11' => [ 0, 1, 2, 3, 5, 6, 7, 9, 10 ],
    '9-12' => [ 0, 1, 2, 4, 5, 6, 8, 9, 10 ],
    # tetrachords (octachords)
    '4-1'   => [ 0, 1, 2, 3 ],
    '4-2'   => [ 0, 1, 2, 4 ],
    '4-4'   => [ 0, 1, 2, 5 ],
    '4-5'   => [ 0, 1, 2, 6 ],
    '4-6'   => [ 0, 1, 2, 7 ],
    '4-3'   => [ 0, 1, 3, 4 ],
    '4-11'  => [ 0, 1, 3, 5 ],
    '4-13'  => [ 0, 1, 3, 6 ],
    '4-Z29' => [ 0, 1, 3, 7 ],
    '4-7'   => [ 0, 1, 4, 5 ],
    '4-Z15' => [ 0, 1, 4, 6 ],
    '4-18'  => [ 0, 1, 4, 7 ],
    '4-19'  => [ 0, 1, 4, 8 ],
    '4-8'   => [ 0, 1, 5, 6 ],
    '4-16'  => [ 0, 1, 5, 7 ],
    '4-20'  => [ 0, 1, 5, 8 ],
    '4-9'   => [ 0, 1, 6, 7 ],
    '4-10'  => [ 0, 2, 3, 5 ],
    '4-12'  => [ 0, 2, 3, 6 ],
    '4-14'  => [ 0, 2, 3, 7 ],
    '4-21'  => [ 0, 2, 4, 6 ],
    '4-22'  => [ 0, 2, 4, 7 ],
    '4-24'  => [ 0, 2, 4, 8 ],
    '4-23'  => [ 0, 2, 5, 7 ],
    '4-27'  => [ 0, 2, 5, 8 ],
    '4-25'  => [ 0, 2, 6, 8 ],
    '4-17'  => [ 0, 3, 4, 7 ],
    '4-26'  => [ 0, 3, 5, 8 ],
    '4-28'  => [ 0, 3, 6, 9 ],
    # octachords (tetrachords)
    '8-1'   => [ 0, 1, 2, 3, 4, 5, 6, 7 ],
    '8-2'   => [ 0, 1, 2, 3, 4, 5, 6, 8 ],
    '8-4'   => [ 0, 1, 2, 3, 4, 5, 7, 8 ],
    '8-5'   => [ 0, 1, 2, 3, 4, 6, 7, 8 ],
    '8-6'   => [ 0, 1, 2, 3, 5, 6, 7, 8 ],
    '8-3'   => [ 0, 1, 2, 3, 4, 5, 6, 9 ],
    '8-11'  => [ 0, 1, 2, 3, 4, 5, 7, 9 ],
    '8-13'  => [ 0, 1, 2, 3, 4, 6, 7, 9 ],
    '8-Z29' => [ 0, 1, 2, 3, 5, 6, 7, 9 ],
    '8-7'   => [ 0, 1, 2, 3, 4, 5, 8, 9 ],
    '8-Z15' => [ 0, 1, 2, 3, 4, 6, 8, 9 ],
    '8-18'  => [ 0, 1, 2, 3, 5, 6, 8, 9 ],
    '8-19'  => [ 0, 1, 2, 4, 5, 6, 8, 9 ],
    '8-8'   => [ 0, 1, 2, 3, 4, 7, 8, 9 ],
    '8-16'  => [ 0, 1, 2, 3, 5, 7, 8, 9 ],
    '8-20'  => [ 0, 1, 2, 4, 5, 7, 8, 9 ],
    '8-9'   => [ 0, 1, 2, 3, 6, 7, 8, 9 ],
    '8-10'  => [ 0, 2, 3, 4, 5, 6, 7, 9 ],
    '8-12'  => [ 0, 1, 3, 4, 5, 6, 7, 9 ],
    '8-14'  => [ 0, 1, 2, 4, 5, 6, 7, 9 ],
    '8-21'  => [ 0, 1, 2, 3, 4, 6, 8, 10 ],
    '8-22'  => [ 0, 1, 2, 3, 5, 6, 8, 10 ],
    '8-24'  => [ 0, 1, 2, 4, 5, 6, 8, 10 ],
    '8-23'  => [ 0, 1, 2, 3, 5, 7, 8, 10 ],
    '8-27'  => [ 0, 1, 2, 4, 5, 7, 8, 10 ],
    '8-25'  => [ 0, 1, 2, 4, 6, 7, 8, 10 ],
    '8-17'  => [ 0, 1, 3, 4, 5, 6, 8, 9 ],
    '8-26'  => [ 0, 1, 3, 4, 5, 7, 8, 10 ],
    # '8-26'  => [ 0, 1, 2, 4, 5, 7, 9, 10 ], # rahn1980
    '8-28' => [ 0, 1, 3, 4, 6, 7, 9, 10 ],
    # pentachords (septachords)
    '5-1'   => [ 0, 1, 2, 3, 4 ],
    '5-2'   => [ 0, 1, 2, 3, 5 ],
    '5-4'   => [ 0, 1, 2, 3, 6 ],
    '5-5'   => [ 0, 1, 2, 3, 7 ],
    '5-3'   => [ 0, 1, 2, 4, 5 ],
    '5-9'   => [ 0, 1, 2, 4, 6 ],
    '5-Z36' => [ 0, 1, 2, 4, 7 ],
    '5-13'  => [ 0, 1, 2, 4, 8 ],
    '5-6'   => [ 0, 1, 2, 5, 6 ],
    '5-14'  => [ 0, 1, 2, 5, 7 ],
    '5-Z38' => [ 0, 1, 2, 5, 8 ],
    '5-7'   => [ 0, 1, 2, 6, 7 ],
    '5-15'  => [ 0, 1, 2, 6, 8 ],
    '5-10'  => [ 0, 1, 3, 4, 6 ],
    '5-16'  => [ 0, 1, 3, 4, 7 ],
    '5-Z17' => [ 0, 1, 3, 4, 8 ],
    '5-Z12' => [ 0, 1, 3, 5, 6 ],
    '5-24'  => [ 0, 1, 3, 5, 7 ],
    '5-27'  => [ 0, 1, 3, 5, 8 ],
    '5-19'  => [ 0, 1, 3, 6, 7 ],
    '5-29'  => [ 0, 1, 3, 6, 8 ],
    '5-31'  => [ 0, 1, 3, 6, 9 ],
    '5-Z18' => [ 0, 1, 4, 5, 7 ],
    '5-21'  => [ 0, 1, 4, 5, 8 ],
    '5-30'  => [ 0, 1, 4, 6, 8 ],
    '5-32'  => [ 0, 1, 4, 6, 9 ],
    '5-22'  => [ 0, 1, 4, 7, 8 ],
    '5-20'  => [ 0, 1, 5, 6, 8 ],    # 0,1,3,7,8 forte1973
    '5-8'   => [ 0, 2, 3, 4, 6 ],
    '5-11'  => [ 0, 2, 3, 4, 7 ],
    '5-23'  => [ 0, 2, 3, 5, 7 ],
    '5-25'  => [ 0, 2, 3, 5, 8 ],
    '5-28'  => [ 0, 2, 3, 6, 8 ],
    '5-26'  => [ 0, 2, 4, 5, 8 ],
    '5-33'  => [ 0, 2, 4, 6, 8 ],
    '5-34'  => [ 0, 2, 4, 6, 9 ],
    '5-35'  => [ 0, 2, 4, 7, 9 ],
    '5-Z37' => [ 0, 3, 4, 5, 8 ],
    # septachords (pentachords)
    '7-1'   => [ 0, 1, 2, 3, 4, 5, 6 ],
    '7-2'   => [ 0, 1, 2, 3, 4, 5, 7 ],
    '7-4'   => [ 0, 1, 2, 3, 4, 6, 7 ],
    '7-5'   => [ 0, 1, 2, 3, 5, 6, 7 ],
    '7-3'   => [ 0, 1, 2, 3, 4, 5, 8 ],
    '7-9'   => [ 0, 1, 2, 3, 4, 6, 8 ],
    '7-Z36' => [ 0, 1, 2, 3, 5, 6, 8 ],
    '7-13'  => [ 0, 1, 2, 4, 5, 6, 8 ],
    '7-6'   => [ 0, 1, 2, 3, 4, 7, 8 ],
    '7-14'  => [ 0, 1, 2, 3, 5, 7, 8 ],
    '7-Z38' => [ 0, 1, 2, 4, 5, 7, 8 ],
    '7-7'   => [ 0, 1, 2, 3, 6, 7, 8 ],
    '7-15'  => [ 0, 1, 2, 4, 6, 7, 8 ],
    '7-10'  => [ 0, 1, 2, 3, 4, 6, 9 ],
    '7-16'  => [ 0, 1, 2, 3, 5, 6, 9 ],
    '7-Z17' => [ 0, 1, 2, 4, 5, 6, 9 ],
    '7-Z12' => [ 0, 1, 2, 3, 4, 7, 9 ],
    '7-24'  => [ 0, 1, 2, 3, 5, 7, 9 ],
    '7-27'  => [ 0, 1, 2, 4, 5, 7, 9 ],
    '7-19'  => [ 0, 1, 2, 3, 6, 7, 9 ],
    '7-29'  => [ 0, 1, 2, 4, 6, 7, 9 ],
    '7-31'  => [ 0, 1, 3, 4, 6, 7, 9 ],
    '7-Z18' => [ 0, 1, 4, 5, 6, 7, 9 ],    # 0,1,2,3,5,8,9 forte1973
        # '7-Z18' => [ 0, 1, 2, 3, 5, 8, 9 ], # rahn1980
    '7-21' => [ 0, 1, 2, 4, 5, 8, 9 ],
    '7-30' => [ 0, 1, 2, 4, 6, 8, 9 ],
    '7-32' => [ 0, 1, 3, 4, 6, 8, 9 ],
    '7-22' => [ 0, 1, 2, 5, 6, 8, 9 ],
    '7-20' => [ 0, 1, 2, 5, 6, 7, 9 ],    # 0,1,2,4,7,8,9 forte1973
        # '7-20'  => [ 0, 1, 2, 4, 7, 8, 9 ], # rahn1980
    '7-8'   => [ 0, 2, 3, 4, 5, 6, 8 ],
    '7-11'  => [ 0, 1, 3, 4, 5, 6, 8 ],
    '7-23'  => [ 0, 2, 3, 4, 5, 7, 9 ],
    '7-25'  => [ 0, 2, 3, 4, 6, 7, 9 ],
    '7-28'  => [ 0, 1, 3, 5, 6, 7, 9 ],
    '7-26'  => [ 0, 1, 3, 4, 5, 7, 9 ],
    '7-33'  => [ 0, 1, 2, 4, 6, 8, 10 ],
    '7-34'  => [ 0, 1, 3, 4, 6, 8, 10 ],
    '7-35'  => [ 0, 1, 3, 5, 6, 8, 10 ],
    '7-Z37' => [ 0, 1, 3, 4, 5, 7, 8 ],
    # hexachords
    '6-1'   => [ 0, 1, 2, 3, 4, 5 ],
    '6-2'   => [ 0, 1, 2, 3, 4, 6 ],
    '6-Z36' => [ 0, 1, 2, 3, 4, 7 ],
    '6-Z3'  => [ 0, 1, 2, 3, 4, 7 ],    # 0,1,2,3,5,6 forte1973
    '6-Z37' => [ 0, 1, 2, 3, 4, 8 ],
    '6-Z4'  => [ 0, 1, 2, 3, 4, 8 ],    # 0,1,2,4,5,6 forte1973
    '6-9'   => [ 0, 1, 2, 3, 5, 7 ],
    '6-Z40' => [ 0, 1, 2, 3, 5, 8 ],
    '6-Z11' => [ 0, 1, 2, 3, 5, 8 ],    # 0,1,2,4,5,7 forte1973
    '6-5'   => [ 0, 1, 2, 3, 6, 7 ],
    '6-Z41' => [ 0, 1, 2, 3, 6, 8 ],
    '6-Z12' => [ 0, 1, 2, 3, 6, 8 ],    # 0,1,2,4,6,7 forte1973
    '6-Z42' => [ 0, 1, 2, 3, 6, 9 ],
    '6-Z13' => [ 0, 1, 2, 3, 6, 9 ],    # 0,1,3,4,6,7 forte1973
    '6-Z38' => [ 0, 1, 2, 3, 7, 8 ],
    '6-Z6'  => [ 0, 1, 2, 3, 7, 8 ],    # 0,1,3,5,6,7 forte1973
    '6-15'  => [ 0, 1, 2, 4, 5, 8 ],
    '6-22'  => [ 0, 1, 2, 4, 6, 8 ],
    '6-Z46' => [ 0, 1, 2, 4, 6, 9 ],
    '6-Z24' => [ 0, 1, 2, 4, 6, 9 ],    # 0,1,3,4,6,8 forte1973
    '6-Z17' => [ 0, 1, 2, 4, 7, 8 ],
    '6-Z43' => [ 0, 1, 2, 4, 7, 8 ],    # 0,1,2,5,6,8 forte1973
    '6-Z47' => [ 0, 1, 2, 4, 7, 9 ],
    '6-Z25' => [ 0, 1, 2, 4, 7, 9 ],    # 0,1,3,5,6,8 forte1973
    '6-Z44' => [ 0, 1, 2, 5, 6, 9 ],
    '6-Z19' => [ 0, 1, 2, 5, 6, 9 ],    # 0,1,3,4,7,8 forte1973
    '6-18'  => [ 0, 1, 2, 5, 7, 8 ],
    '6-Z48' => [ 0, 1, 2, 5, 7, 9 ],
    '6-Z26' => [ 0, 1, 2, 5, 7, 9 ],    # 0,1,3,5,7,8 forte1973
    '6-7'   => [ 0, 1, 2, 6, 7, 8 ],
    '6-Z10' => [ 0, 1, 3, 4, 5, 7 ],
    '6-Z39' => [ 0, 1, 3, 4, 5, 7 ],    # 0,2,3,4,5,8 forte1973
    '6-14'  => [ 0, 1, 3, 4, 5, 8 ],
    '6-27'  => [ 0, 1, 3, 4, 6, 9 ],
    '6-Z49' => [ 0, 1, 3, 4, 7, 9 ],
    '6-Z28' => [ 0, 1, 3, 4, 7, 9 ],    # 0,1,3,5,6,9 forte1973
    '6-34'  => [ 0, 1, 3, 5, 7, 9 ],
    '6-31'  => [ 0, 1, 4, 5, 7, 9 ],    # 0,1,3,5,8,9 forte1973
    '6-30'  => [ 0, 1, 3, 6, 7, 9 ],
    '6-Z29' => [ 0, 2, 3, 6, 7, 9 ],    # 0,1,3,6,8,9 forte1973
    '6-Z50' => [ 0, 2, 3, 6, 7, 9 ],    # 0,1,4,6,7,9 forte1973
    '6-16'  => [ 0, 1, 4, 5, 6, 8 ],
    '6-20'  => [ 0, 1, 4, 5, 8, 9 ],
    '6-8'   => [ 0, 2, 3, 4, 5, 7 ],
    '6-21'  => [ 0, 2, 3, 4, 6, 8 ],
    '6-Z45' => [ 0, 2, 3, 4, 6, 9 ],
    '6-Z23' => [ 0, 2, 3, 4, 6, 9 ],    # 0,2,3,5,6,8 forte1973
    '6-33'  => [ 0, 2, 3, 5, 7, 9 ],
    '6-32'  => [ 0, 2, 4, 5, 7, 9 ],
    '6-35'  => [ 0, 2, 4, 6, 8, 10 ],
);

# Hexchords here are problematic on account of mutual complementary sets
# (different Forte Numbers for the same pitch set).
# TODO review and use what Rahn lists as first in table on p.142-3.
# TODO Rahn puts 6-Z36 and 6-Z3 together, but my code is producing
# two different prime forms for those...
#
# sorting is to align with the table in rahn1980
our %PCS2FORTE = (
    # trichords (complement nonachords)
    '0,1,2' => '3-1',
    '0,1,3' => '3-2',
    '0,1,4' => '3-3',
    '0,1,5' => '3-4',
    '0,1,6' => '3-5',
    '0,2,4' => '3-6',
    '0,2,5' => '3-7',
    '0,2,6' => '3-8',
    '0,2,7' => '3-9',
    '0,3,6' => '3-10',
    '0,3,7' => '3-11',
    '0,4,8' => '3-12',
    # nonachords (trichords)
    '0,1,2,3,4,5,6,7,8'  => '9-1',
    '0,1,2,3,4,5,6,7,9'  => '9-2',
    '0,1,2,3,4,5,6,8,9'  => '9-3',
    '0,1,2,3,4,5,7,8,9'  => '9-4',
    '0,1,2,3,4,6,7,8,9'  => '9-5',
    '0,1,2,3,4,5,6,8,10' => '9-6',
    '0,1,2,3,4,5,7,8,10' => '9-7',
    '0,1,2,3,4,6,7,8,10' => '9-8',
    '0,1,2,3,5,6,7,8,10' => '9-9',
    '0,1,2,3,4,6,7,9,10' => '9-10',
    '0,1,2,3,5,6,7,9,10' => '9-11',
    '0,1,2,4,5,6,8,9,10' => '9-12',
    # tetrachords (octachords)
    '0,1,2,3' => '4-1',
    '0,1,2,4' => '4-2',
    '0,1,2,5' => '4-4',
    '0,1,2,6' => '4-5',
    '0,1,2,7' => '4-6',
    '0,1,3,4' => '4-3',
    '0,1,3,5' => '4-11',
    '0,1,3,6' => '4-13',
    '0,1,3,7' => '4-Z29',
    '0,1,4,5' => '4-7',
    '0,1,4,6' => '4-Z15',
    '0,1,4,7' => '4-18',
    '0,1,4,8' => '4-19',
    '0,1,5,6' => '4-8',
    '0,1,5,7' => '4-16',
    '0,1,5,8' => '4-20',
    '0,1,6,7' => '4-9',
    '0,2,3,5' => '4-10',
    '0,2,3,6' => '4-12',
    '0,2,3,7' => '4-14',
    '0,2,4,6' => '4-21',
    '0,2,4,7' => '4-22',
    '0,2,4,8' => '4-24',
    '0,2,5,7' => '4-23',
    '0,2,5,8' => '4-27',
    '0,2,6,8' => '4-25',
    '0,3,4,7' => '4-17',
    '0,3,5,8' => '4-26',
    '0,3,6,9' => '4-28',
    # octachords (tetrachords)
    '0,1,2,3,4,5,6,7'  => '8-1',
    '0,1,2,3,4,5,6,8'  => '8-2',
    '0,1,2,3,4,5,7,8'  => '8-4',
    '0,1,2,3,4,6,7,8'  => '8-5',
    '0,1,2,3,5,6,7,8'  => '8-6',
    '0,1,2,3,4,5,6,9'  => '8-3',
    '0,1,2,3,4,5,7,9'  => '8-11',
    '0,1,2,3,4,6,7,9'  => '8-13',
    '0,1,2,3,5,6,7,9'  => '8-Z29',
    '0,1,2,3,4,5,8,9'  => '8-7',
    '0,1,2,3,4,6,8,9'  => '8-Z15',
    '0,1,2,3,5,6,8,9'  => '8-18',
    '0,1,2,4,5,6,8,9'  => '8-19',
    '0,1,2,3,4,7,8,9'  => '8-8',
    '0,1,2,3,5,7,8,9'  => '8-16',
    '0,1,2,4,5,7,8,9'  => '8-20',
    '0,1,2,3,6,7,8,9'  => '8-9',
    '0,2,3,4,5,6,7,9'  => '8-10',
    '0,1,3,4,5,6,7,9'  => '8-12',
    '0,1,2,4,5,6,7,9'  => '8-14',
    '0,1,2,3,4,6,8,10' => '8-21',
    '0,1,2,3,5,6,8,10' => '8-22',
    '0,1,2,4,5,6,8,10' => '8-24',
    '0,1,2,3,5,7,8,10' => '8-23',
    '0,1,2,4,5,7,8,10' => '8-27',
    '0,1,2,4,6,7,8,10' => '8-25',
    '0,1,3,4,5,6,8,9'  => '8-17',
    '0,1,3,4,5,7,8,10' => '8-26',    # buggy in rahn1980
    '0,1,3,4,6,7,9,10' => '8-28',
    # pentachords (septachords)
    '0,1,2,3,4' => '5-1',
    '0,1,2,3,5' => '5-2',
    '0,1,2,3,6' => '5-4',
    '0,1,2,3,7' => '5-5',
    '0,1,2,4,5' => '5-3',
    '0,1,2,4,6' => '5-9',
    '0,1,2,4,7' => '5-Z36',
    '0,1,2,4,8' => '5-13',
    '0,1,2,5,6' => '5-6',
    '0,1,2,5,7' => '5-14',
    '0,1,2,5,8' => '5-Z38',
    '0,1,2,6,7' => '5-7',
    '0,1,2,6,8' => '5-15',
    '0,1,3,4,6' => '5-10',
    '0,1,3,4,7' => '5-16',
    '0,1,3,4,8' => '5-Z17',
    '0,1,3,5,6' => '5-Z12',
    '0,1,3,5,7' => '5-24',
    '0,1,3,5,8' => '5-27',
    '0,1,3,6,7' => '5-19',
    '0,1,3,6,8' => '5-29',
    '0,1,3,6,9' => '5-31',
    '0,1,4,5,7' => '5-Z18',
    '0,1,4,5,8' => '5-21',
    '0,1,4,6,8' => '5-30',
    '0,1,4,6,9' => '5-32',
    '0,1,4,7,8' => '5-22',
    '0,1,5,6,8' => '5-20',
    '0,2,3,4,6' => '5-8',
    '0,2,3,4,7' => '5-11',
    '0,2,3,5,7' => '5-23',
    '0,2,3,5,8' => '5-25',
    '0,2,3,6,8' => '5-28',
    '0,2,4,5,8' => '5-26',
    '0,2,4,6,8' => '5-33',
    '0,2,4,6,9' => '5-34',
    '0,2,4,7,9' => '5-35',
    '0,3,4,5,8' => '5-Z37',
    # septachords (pentachords)
    '0,1,2,3,4,5,6'  => '7-1',
    '0,1,2,3,4,5,7'  => '7-2',
    '0,1,2,3,4,6,7'  => '7-4',
    '0,1,2,3,5,6,7'  => '7-5',
    '0,1,2,3,4,5,8'  => '7-3',
    '0,1,2,3,4,6,8'  => '7-9',
    '0,1,2,3,5,6,8'  => '7-Z36',
    '0,1,2,4,5,6,8'  => '7-13',
    '0,1,2,3,4,7,8'  => '7-6',
    '0,1,2,3,5,7,8'  => '7-14',
    '0,1,2,4,5,7,8'  => '7-Z38',
    '0,1,2,3,6,7,8'  => '7-7',
    '0,1,2,4,6,7,8'  => '7-15',
    '0,1,2,3,4,6,9'  => '7-10',
    '0,1,2,3,5,6,9'  => '7-16',
    '0,1,2,4,5,6,9'  => '7-Z17',
    '0,1,2,3,4,7,9'  => '7-Z12',
    '0,1,2,3,5,7,9'  => '7-24',
    '0,1,2,4,5,7,9'  => '7-27',
    '0,1,2,3,6,7,9'  => '7-19',
    '0,1,2,4,6,7,9'  => '7-29',
    '0,1,3,4,6,7,9'  => '7-31',
    '0,1,4,5,6,7,9'  => '7-Z18',    # buggy in rahn1980
    '0,1,2,4,5,8,9'  => '7-21',
    '0,1,2,4,6,8,9'  => '7-30',
    '0,1,3,4,6,8,9'  => '7-32',
    '0,1,2,5,6,8,9'  => '7-22',
    '0,1,2,5,6,7,9'  => '7-20',     # buggy in rahn1980
    '0,2,3,4,5,6,8'  => '7-8',
    '0,1,3,4,5,6,8'  => '7-11',
    '0,2,3,4,5,7,9'  => '7-23',
    '0,2,3,4,6,7,9'  => '7-25',
    '0,1,3,5,6,7,9'  => '7-28',
    '0,1,3,4,5,7,9'  => '7-26',
    '0,1,2,4,6,8,10' => '7-33',
    '0,1,3,4,6,8,10' => '7-34',
    '0,1,3,5,6,8,10' => '7-35',
    '0,1,3,4,5,7,8'  => '7-Z37',
    # hexachords, by first column and then sparse 2nd column
    '0,1,2,3,4,5'  => '6-1',
    '0,1,2,3,4,6'  => '6-2',
    '0,1,2,3,4,7'  => '6-Z36',
    '0,1,2,3,4,8'  => '6-Z37',
    '0,1,2,3,5,7'  => '6-9',
    '0,1,2,3,5,8'  => '6-Z40',
    '0,1,2,3,6,7'  => '6-5',
    '0,1,2,3,6,8'  => '6-Z41',
    '0,1,2,3,6,9'  => '6-Z42',
    '0,1,2,3,7,8'  => '6-Z38',
    '0,1,2,4,5,8'  => '6-15',
    '0,1,2,4,6,8'  => '6-22',
    '0,1,2,4,6,9'  => '6-Z46',
    '0,1,2,4,7,8'  => '6-Z17',
    '0,1,2,4,7,9'  => '6-Z47',
    '0,1,2,5,6,9'  => '6-Z44',
    '0,1,2,5,7,8'  => '6-18',
    '0,1,2,5,7,9'  => '6-Z48',
    '0,1,2,6,7,8'  => '6-7',
    '0,1,3,4,5,7'  => '6-Z10',
    '0,1,3,4,5,8'  => '6-14',
    '0,1,3,4,6,9'  => '6-27',
    '0,1,3,4,7,9'  => '6-Z49',
    '0,1,3,5,7,9'  => '6-34',
    '0,1,4,5,7,9'  => '6-31',
    '0,1,3,6,7,9'  => '6-30',
    '0,2,3,6,7,9'  => '6-Z29',
    '0,1,4,5,6,8'  => '6-16',
    '0,1,4,5,8,9'  => '6-20',
    '0,2,3,4,5,7'  => '6-8',
    '0,2,3,4,6,8'  => '6-21',
    '0,2,3,4,6,9'  => '6-Z45',
    '0,2,3,5,7,9'  => '6-33',
    '0,2,4,5,7,9'  => '6-32',
    '0,2,4,6,8,10' => '6-35',
    '0,1,2,3,5,6'  => '6-Z3',
    '0,1,2,4,5,6'  => '6-Z4',
    '0,1,2,4,5,7'  => '6-Z11',
    '0,1,2,4,6,7'  => '6-Z12',
    '0,1,3,4,6,7'  => '6-Z13',
    '0,1,2,5,6,7'  => '6-Z6',
    '0,1,3,4,6,8'  => '6-Z24',
    '0,1,2,5,6,8'  => '6-Z43',
    '0,1,3,5,6,8'  => '6-Z25',
    '0,1,3,4,7,8'  => '6-Z19',
    '0,1,3,5,7,8'  => '6-Z26',
    '0,2,3,4,5,8'  => '6-Z39',
    '0,1,3,5,6,9'  => '6-Z28',
    '0,1,4,6,7,9'  => '6-Z50',
    '0,2,3,5,6,8'  => '6-Z23',
);

# NOTE may need [AB]? at end for what I call "half prime" forms, as
# wikipedia has switched to using that form.
my $FORTE_NUMBER_RE = qr/[3-9]-[zZ]?\d{1,2}/;

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

# Utility method for check_melody - takes melody, a list of pitches,
# optionally how many notes (beyond that of pitches to audit) to check,
# and a code reference that will accept a selection of the melody and
# return something that will be tested against the list of pitches
# (second argument) for equality: true if match, false if not (and then
# a bunch of references containing what failed).
sub _apply_melody_rule {
    my ( $self, $melody, $check_set, $note_count, $code, $flag_sort ) = @_;
    $flag_sort //= 0;

    # make equal to the set if less than the set. no high value test as
    # loop will abort if note_count exceeds the length of melody, below.
    $note_count //= 0;
    $note_count = @$check_set if $note_count < @$check_set;

    # rule is too large for the melody, skip
    return 1, {} if @$check_set > @$melody;

    for my $i ( 0 .. @$melody - @$check_set ) {
        my @selection = @{$melody}[ $i .. $i + @$check_set - 1 ];

        my $sel_audit = $code->( $self, \@selection );
        @$sel_audit = sort { $a <=> $b } @$sel_audit if $flag_sort;
        if ( "@$sel_audit" eq "@$check_set" ) {
            return 0, { index => $i, selection => \@selection };
        }

        if ( $note_count > @$check_set ) {
            for my $count ( @$check_set + 1 .. $note_count ) {
                last if $i + $count - 1 > $#$melody;

                @selection = @{$melody}[ $i .. $i + $count - 1 ];
                my $iter = combinations( \@selection, scalar @$check_set );

                while ( my $subsel = $iter->next ) {
                    $sel_audit  = $code->( $self, $subsel );
                    @$sel_audit = sort { $a <=> $b } @$sel_audit if $flag_sort;
                    if ( "@$sel_audit" eq "@$check_set" ) {
                        return 0, { context => \@selection, index => $i, selection => $subsel };
                    }
                }
            }
        }
    }

    return 1, {};
}

# Like interval class content (ICC) but instead only calculates adjacent
# intervals. -- "The Geometry of Musical Rhythm", G.T. Toussaint.
# (Perhaps more suitable for rhythm as the adjacent intervals there are
# probably more audible than some harmonic between inner voices.)
sub adjacent_interval_content {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    my @nset = sort { $a <=> $b } uniqnum @$pset;
    croak 'pitch set must contain at least two elements' if @nset < 2;

    my %aic;
    for my $i ( 1 .. $#nset ) {
        $aic{ ( $nset[$i] - $nset[ $i - 1 ] ) % $self->{_DEG_IN_SCALE} }++;
    }
    # and the wrap-around adjacent interval
    if ( @nset > 2 ) {
        $aic{ ( $nset[0] + $self->{_DEG_IN_SCALE} - $nset[-1] )
              % $self->{_DEG_IN_SCALE} }++;
    }

    my @aiv;
    for my $ics ( 1 .. int( $self->{_DEG_IN_SCALE} / 2 ) ) {
        push @aiv, $aic{$ics} || 0;
    }

    return wantarray ? ( \@aiv, \%aic ) : \@aiv;
}

# what bands of the Bark scale do the given frequencies belong to? there
# are several formula for this in the Wikipedia article, this one
# follows Traunmüller 1990 to avoid pulling in trig functions. not sure
# if one is supposed to int() or sprintf() round the result to get to an
# integer value
sub bark_scale {
    shift;
    map { ( 26.81 * $_ ) / ( 1960 + $_ ) - 0.53 } @_;
}

# Utility, converts a scale_degrees-bit number into a pitch set.
#            7   3  0
# 137 -> 000010001001 -> [0,3,7]
sub bits2pcs {
    my ( $self, $bs ) = @_;

    my @pset;
    for my $p ( 0 .. $self->{_DEG_IN_SCALE} - 1 ) {
        push @pset, $p if $bs & ( 1 << $p );
    }
    return \@pset;
}

# Audits a sequence of pitches for suitability, per various checks
# passed in via the params hash (based on Smith-Brindle Reginald's
# "Serial Composition" discussion of atonal melody construction).
sub check_melody {
    my $self   = shift;
    my $params = shift;
    my $melody = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    my $rules_applied = 0;

    my ( %intervals, @intervals );
    for my $i ( 1 .. $#$melody ) {
        my $ival = abs $melody->[$i] - $melody->[ $i - 1 ];
        $intervals{$ival}++;
        push @intervals, $ival;
    }

    if ( exists $params->{dup_interval_limit} ) {
        for my $icount ( values %intervals ) {
            if ( $icount >= $params->{dup_interval_limit} ) {
                return wantarray ? ( 0, "dup_interval_limit" ) : 0;
            }
        }
        $rules_applied++;
    }

    for my $ruleset ( @{ $params->{exclude_interval} || [] } ) {
        croak "no interval set in exclude_interval rule"
          if not exists $ruleset->{iset}
          or ref $ruleset->{iset} ne 'ARRAY';
        next if @{ $ruleset->{iset} } > @intervals;

        # check (magnitude of the) intervals of the melody. code ref just
        # returns the literal intervals to compare against what is in the
        # iset. (other options might be to ICC the intervals, or fold them
        # into a single register, etc. but that would take more coding.)
        my ( $ret, $results ) = $self->_apply_melody_rule(
            \@intervals, $ruleset->{iset}, $ruleset->{in},
            sub { [ @{ $_[1] } ] },
            $ruleset->{sort} ? 1 : 0
        );
        if ( $ret != 1 ) {
            return wantarray ? ( 0, "exclude_interval", $results ) : 0;
        }
        $rules_applied++;
    }

    for my $ps_ref ( [qw/exclude_prime prime_form/],
        [qw/exclude_half_prime half_prime_form/] ) {
        my $ps_rule   = $ps_ref->[0];
        my $ps_method = $ps_ref->[1];

        for my $ruleset ( @{ $params->{$ps_rule} || [] } ) {
            croak "no pitch set in $ps_rule rule"
              if not exists $ruleset->{ps}
              or ref $ruleset->{ps} ne 'ARRAY';

            # for intervals code, not necessary for pitch set operations, all of
            # which sort the pitches as part of the calculations involved
            delete $ruleset->{sort};

            # excludes from *any* subset for the given subset magnitudes of the
            # parent pitch set
            for my $ss_mag ( @{ $ruleset->{subsets} || [] } ) {
                croak "subset must be of lesser magnitude than pitch set"
                  if $ss_mag >= @{ $ruleset->{ps} };
                my $in_ss = $ruleset->{in} // 0;
                $in_ss = @{ $ruleset->{ps} }
                  if $in_ss < @{ $ruleset->{ps} };
                # except scale down to fit smaller subset pitch set
                $in_ss -= @{ $ruleset->{ps} } - $ss_mag;

                next if $in_ss > @$melody;

                my $all_subpsets = $self->subsets( $ss_mag, $ruleset->{ps} );
                my %seen_s_pset;
                for my $s_pset (@$all_subpsets) {
                    my $s_prime = $self->$ps_method($s_pset);
                    next if $seen_s_pset{"@$s_prime"}++;
                    my ( $ret, $results ) =
                      $self->_apply_melody_rule( $melody, $s_prime,
                        $in_ss, sub { $_[0]->$ps_method( $_[1] ) } );
                    if ( $ret != 1 ) {
                        return wantarray ? ( 0, $ps_rule, $results ) : 0;
                    }
                }
                $rules_applied++;
            }

            my ( $ret, $results ) =
              $self->_apply_melody_rule( $melody, $ruleset->{ps}, $ruleset->{in},
                sub { $_[0]->$ps_method( $_[1] ) } );
            if ( $ret != 1 ) {
                return wantarray ? ( 0, $ps_rule, $results ) : 0;
            }

            $rules_applied++;
        }
    }

    if ( $rules_applied == 0 ) {
        return wantarray ? ( 0, "no rules applied" ) : 0;
    }
    return wantarray ? ( 1, "ok" ) : 1;
}

sub circular_permute {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
    croak 'pitch set must contain something' if !@$pset;

    my @perms;
    for my $i ( 0 .. $#$pset ) {
        for my $j ( 0 .. $#$pset ) {
            $perms[$i][$j] = $pset->[ ( $i + $j ) % @$pset ];
        }
    }
    return \@perms;
}

sub complement {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    my %seen;
    @seen{@$pset} = ();
    return [ grep { !exists $seen{$_} } 0 .. $self->{_DEG_IN_SCALE} - 1 ];
}

sub fnums { \%FORTE2PCS }

sub forte_number_re {
    return $FORTE_NUMBER_RE;
}

sub forte2pcs {
    my ( $self, $forte_number ) = @_;
    return $FORTE2PCS{ uc $forte_number };
}

# simple wrapper around check_melody to create something to work with,
# depending on the params.
sub gen_melody {
    my ( $self, %params ) = @_;

    my $attempts     = 1000;    # enough for Helen, enough for us
    my $max_interval = $params{melody_max_interval} || 16;    # tessitura of a 10th
    delete $params{melody_max_interval};

    if ( !keys %params ) {
        # based on Reginald's ideas (insofar as those can be represented by
        # the rules system I've cobbled together)
        %params = (
            exclude_half_prime => [
                { ps => [ 0, 4, 5 ] },    # leading tone/tonic/dominant
            ],
            exclude_interval => [
                { iset => [ 5, 5 ], },    # adjacent fourths ("cadential basses")
            ],
            exclude_prime => [
                { ps => [ 0, 3, 7 ], in => 4 },       # major or minor triad, any guise
                { ps => [ 0, 2, 5, 8 ], },            # 7th, any guise, exact
                { ps => [ 0, 2, 4, 6 ], in => 5 },    # whole tone formation
                    # 7-35 (major/minor scale) but also excluding from all 5-x or
                    # 6-x subsets of said set
                { ps => [ 0, 1, 3, 5, 6, 8, 10 ], subsets => [ 6, 5 ] },
            ],
        );
    }

    my $got_melody = 0;
    my @melody;
    eval {
      ATTEMPT: while ( $attempts-- > 0 ) {
            my %seen;
            my @pitches = 0 .. $self->{_DEG_IN_SCALE} - 1;
            @melody = splice @pitches, rand @pitches, 1;
            $seen{ $melody[0] } = 1;
            my $melody_low  = $melody[0];
            my $melody_high = $melody[0];

            while (@pitches) {
                my @potential = grep {
                    my $base_pitch = $_ % 12;
                    my $ret        = 0;
                    for my $p (@pitches) {
                        if ( $base_pitch == $p ) { $ret = 1; last }
                    }
                    $ret
                } $melody_high - $max_interval .. $melody_low + $max_interval;
                my $choice      = $potential[ rand @potential ];
                my $base_choice = $choice % 12;
                @pitches = grep $_ != $base_choice, @pitches;
                push @melody, $choice;

                $melody_low  = $choice if $choice < $melody_low;
                $melody_high = $choice if $choice > $melody_high;
            }

            # but negative pitches are awkward for various reasons
            if ( $melody_low < 0 ) {
                $melody_low = abs $melody_low;
                $_ += $melody_low for @melody;
            }

            ( $got_melody, my $msg ) = $self->check_melody( \%params, \@melody );
            next ATTEMPT if $got_melody != 1;

            last;
        }
    };
    croak $@ if $@;
    croak "could not generate a melody" unless $got_melody;

    return \@melody;
}

# copied from Music::NeoRiemannianTonnetz 'normalize', see perldocs
# for differences between this and prime_form and normal_form
sub half_prime_form {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'pitch set must contain something' if !@$pset;

    my %origmap;
    for my $p (@$pset) {
        push @{ $origmap{ $p % $self->{_DEG_IN_SCALE} } }, $p;
    }
    if ( keys %origmap == 1 ) {
        return wantarray ? ( keys %origmap, \%origmap ) : keys %origmap;
    }
    my @nset = sort { $a <=> $b } keys %origmap;

    my @equivs;
    for my $i ( 0 .. $#nset ) {
        for my $j ( 0 .. $#nset ) {
            $equivs[$i][$j] = $nset[ ( $i + $j ) % @nset ];
        }
    }
    my @order = reverse 1 .. $#nset;

    my @normal;
    for my $i (@order) {
        my $min_span = $self->{_DEG_IN_SCALE};
        my @min_span_idx;

        for my $eidx ( 0 .. $#equivs ) {
            my $span =
              ( $equivs[$eidx][$i] - $equivs[$eidx][0] ) % $self->{_DEG_IN_SCALE};
            if ( $span < $min_span ) {
                $min_span     = $span;
                @min_span_idx = $eidx;
            } elsif ( $span == $min_span ) {
                push @min_span_idx, $eidx;
            }
        }

        if ( @min_span_idx == 1 ) {
            @normal = @{ $equivs[ $min_span_idx[0] ] };
            last;
        } else {
            @equivs = @equivs[@min_span_idx];
        }
    }

    if ( !@normal ) {
        # nothing unique, pick lowest starting pitch, which is first index
        # by virtue of the numeric sort performed above.
        @normal = @{ $equivs[0] };
    }

    # but must map  (and anything else not ) so b is 0,
    # dis 4, etc. and also update the original pitch mapping - this is
    # the major addition to the otherwise stock normal_form code.
    if ( $normal[0] != 0 ) {
        my $trans = $self->{_DEG_IN_SCALE} - $normal[0];
        my %newmap;
        for my $i (@normal) {
            my $prev = $i;
            $i = ( $i + $trans ) % $self->{_DEG_IN_SCALE};
            $newmap{$i} = $origmap{$prev};
        }
        %origmap = %newmap;
    }

    return wantarray ? ( \@normal, \%origmap ) : \@normal;
}

sub interval_class_content {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    my @nset = sort { $a <=> $b } uniqnum @$pset;
    croak 'pitch set must contain at least two elements' if @nset < 2;

    my %icc;
    for my $i ( 1 .. $#nset ) {
        for my $j ( 0 .. $i - 1 ) {
            $icc{
                $self->pitch2intervalclass(
                    ( $nset[$i] - $nset[$j] ) % $self->{_DEG_IN_SCALE}
                )
            }++;
        }
    }

    my @icv;
    for my $ics ( 1 .. int( $self->{_DEG_IN_SCALE} / 2 ) ) {
        push @icv, $icc{$ics} || 0;
    }

    return wantarray ? ( \@icv, \%icc ) : \@icv;
}

sub intervals2pcs {
    my $self        = shift;
    my $start_pitch = shift;
    my $iset        = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
    croak 'interval set must contain something' if !@$iset;

    $start_pitch //= 0;
    $start_pitch = int $start_pitch;

    my @pset = $start_pitch;
    for my $i (@$iset) {
        push @pset, ( $pset[-1] + $i ) % $self->{_DEG_IN_SCALE};
    }

    return \@pset;
}

sub invariance_matrix {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
    croak 'pitch set must contain something' if !@$pset;

    my @ivm;
    for my $i ( 0 .. $#$pset ) {
        for my $j ( 0 .. $#$pset ) {
            $ivm[$i][$j] = ( $pset->[$i] + $pset->[$j] ) % $self->{_DEG_IN_SCALE};
        }
    }

    return \@ivm;
}

sub invert {
    my $self = shift;
    my $axis = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
    croak 'pitch set must contain something' if !@$pset;

    $axis //= 0;
    $axis = int $axis;

    my @inverse = @$pset;
    for my $p (@inverse) {
        $p = ( $axis - $p ) % $self->{_DEG_IN_SCALE};
    }

    return \@inverse;
}

# Utility routine to get the last few elements of a list (but never more
# than the whole list, etc).
sub lastn {
    my ( $self, $pset, $n ) = @_;
    croak 'cannot get elements of nothing'
      if !defined $pset
      or ref $pset ne 'ARRAY';

    return unless @$pset;

    $n //= $self->{_lastn};
    croak 'n of lastn must be number' unless looks_like_number $n;

    my $len = @$pset;
    $len = $n if $len > $n;
    $len *= -1;
    return @{$pset}[ $len .. -1 ];
}

sub mininterval {
    my ( $self, $from, $to ) = @_;
    my $dir = 1;

    croak 'from pitch must be a number' unless looks_like_number $from;
    croak 'to pitch must be a number'   unless looks_like_number $to;

    $from %= $self->{_DEG_IN_SCALE};
    $to   %= $self->{_DEG_IN_SCALE};

    if ( $from > $to ) {
        ( $from, $to ) = ( $to, $from );
        $dir = -1;
    }
    my $interval = $to - $from;
    if ( $interval > $self->{_DEG_IN_SCALE} / 2 ) {
        $dir  *= -1;
        $from += $self->{_DEG_IN_SCALE};
        $interval = $from - $to;
    }

    return $interval * $dir;
}

sub multiply {
    my $self   = shift;
    my $factor = shift;
    my $pset   = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
    croak 'pitch set must contain something' if !@$pset;

    $factor //= 1;
    $factor = int $factor;

    return [ map { my $p = $_ * $factor % $self->{_DEG_IN_SCALE}; $p } @$pset ];
}

# Utility methods for get/check/reset of each element in turn of a given
# array reference, with wrap-around. Handy if pulling sequential
# elements off a list, but have much code between the successive calls.
{
    my %seen;

    # get the iterator value for a ref
    sub geti {
        my ( $self, $ref ) = @_;
        croak 'need an array reference' if !defined $ref or ref $ref ne 'ARRAY';
        return $seen{ refaddr $ref} || 0;
    }

    # grabi(42, \@array) obtains 42 elements from array, looping to
    # fill if necessary
    sub grabi {
        my ( $self, $count, $ref ) = @_;
        croak 'need an array reference' if !defined $ref or ref $ref ne 'ARRAY';
        croak 'count must be non-negative integer'
          if !looks_like_number($count)
          or $count < 0;
        return if @$ref == 0 or $count == 0;
        $seen{ refaddr $ref} ||= 0;
        my @results;
        while ( $count > 0 ) {
            push @results, $ref->[ $seen{ refaddr $ref} ];
            $seen{ refaddr $ref } = ( $seen{ refaddr $ref } + 1 ) % @$ref;
            $count--;
        }
        return @results;
    }

    # nexti(\@array) - returns subsequent elements of array on each
    # successive call
    sub nexti {
        my ( $self, $ref ) = @_;
        croak 'need an array reference' if !defined $ref or ref $ref ne 'ARRAY';
        $seen{ refaddr $ref} ||= 0;
        $seen{ refaddr $ref } = ( $seen{ refaddr $ref } + 1 ) % @$ref;
        $ref->[ $seen{ refaddr $ref} ];
    }

    # reseti(\@array) - resets counter
    sub reseti {
        my ( $self, $ref ) = @_;
        croak 'need an array reference' if !defined $ref or ref $ref ne 'ARRAY';
        $seen{ refaddr $ref} = 0;
    }

    # set the iterator for a ref
    sub seti {
        my ( $self, $ref, $i ) = @_;
        croak 'need an array reference' if !defined $ref or ref $ref ne 'ARRAY';
        croak 'iterator must be number'
          unless looks_like_number($i);
        $seen{ refaddr $ref} = $i;
    }

    # returns current element, but does not advance pointer
    sub whati {
        my ( $self, $ref ) = @_;
        croak 'need an array reference' if !defined $ref or ref $ref ne 'ARRAY';
        $seen{ refaddr $ref} ||= 0;
        $ref->[ $seen{ refaddr $ref} % @$ref ];
    }
}

sub new {
    my ( $class, %param ) = @_;
    my $self = {};

    $self->{_DEG_IN_SCALE} = int( $param{DEG_IN_SCALE} // $DEG_IN_SCALE );
    if ( $self->{_DEG_IN_SCALE} < 2 ) {
        croak 'degrees in scale must be greater than one';
    }

    if ( exists $param{lastn} ) {
        croak 'lastn must be number'
          unless looks_like_number $param{lastn};
        $self->{_lastn} = $param{lastn};
    } else {
        $self->{_lastn} = 2;
    }

    # XXX packing not implemented beyond "right" method (via www.mta.ca docs)
    $self->{_packing} = 'right';    # $param{PACKING} // 'right';

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

sub normal_form {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'pitch set must contain something' if !@$pset;

    my %origmap;
    for my $p (@$pset) {
        push @{ $origmap{ $p % $self->{_DEG_IN_SCALE} } }, $p;
    }
    if ( keys %origmap == 1 ) {
        return wantarray ? ( [ keys %origmap ], \%origmap ) : [ keys %origmap ];
    }
    my @nset = sort { $a <=> $b } keys %origmap;

    my $equivs = $self->circular_permute( \@nset );
    my @order  = 1 .. $#nset;
    # NOTE this only performs 'right' packing, see commits
    # 9f0c33f8260af9584d38c92af4e7a6a39f7e2769 and prior for long since
    # unimplemented notes on this topic
    @order = reverse @order;

    my @normal;
    for my $i (@order) {
        my $min_span = $self->{_DEG_IN_SCALE};
        my @min_span_idx;

        for my $eidx ( 0 .. $#$equivs ) {
            my $span =
              ( $equivs->[$eidx][$i] - $equivs->[$eidx][0] ) % $self->{_DEG_IN_SCALE};
            if ( $span < $min_span ) {
                $min_span     = $span;
                @min_span_idx = $eidx;
            } elsif ( $span == $min_span ) {
                push @min_span_idx, $eidx;
            }
        }

        if ( @min_span_idx == 1 ) {
            @normal = @{ $equivs->[ $min_span_idx[0] ] };
            last;
        } else {
            @$equivs = @{$equivs}[@min_span_idx];
        }
    }

    if ( !@normal ) {
        # nothing unique, pick lowest starting pitch, which is first index
        # by virtue of the numeric sort performed above.
        @normal = @{ $equivs->[0] };
    }

    $_ += 0 for @normal;    # KLUGE avoid Test::Differences seeing '4' vs. 4

    return wantarray ? ( \@normal, \%origmap ) : \@normal;
}

# Utility, converts a pitch set into a scale_degrees-bit number:
#                7   3  0
# [0,3,7] -> 000010001001 -> 137
sub pcs2bits {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'pitch set must contain something' if !@$pset;

    my $bs = 0;
    for my $p ( map $_ % $self->{_DEG_IN_SCALE}, @$pset ) {
        $bs |= 1 << $p;
    }
    return $bs;
}

sub pcs2forte {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'pitch set must contain something' if !@$pset;

    return $PCS2FORTE{ join ',', @{ $self->prime_form($pset) } };
}

sub pcs2intervals {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'pitch set must contain at least two elements' if @$pset < 2;

    my @intervals;
    for my $i ( 1 .. $#{$pset} ) {
        push @intervals, $pset->[$i] - $pset->[ $i - 1 ];
    }

    return \@intervals;
}

sub pcs2str {
    my $self = shift;
    croak 'must supply a pitch set' if !defined $_[0];

    my $str;
    if ( ref $_[0] eq 'ARRAY' ) {
        $str = '[' . join( ',', @{ $_[0] } ) . ']';
    } elsif ( $_[0] =~ m/,/ ) {
        $str = '[' . $_[0] . ']';
    } else {
        $str = '[' . join( ',', @_ ) . ']';
    }
    return $str;
}

sub pitch2intervalclass {
    my ( $self, $pitch ) = @_;

    # ensure member of the tone system, otherwise strange results
    $pitch %= $self->{_DEG_IN_SCALE};

    return $pitch > int( $self->{_DEG_IN_SCALE} / 2 )
      ? $self->{_DEG_IN_SCALE} - $pitch
      : $pitch;
}

# XXX tracking of original pitches would be nice, though complicated, as
# ->invert would need to be modified or a non-modulating version used
sub prime_form {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'pitch set must contain something' if !@$pset;

    my @forms = scalar $self->normal_form($pset);
    push @forms, scalar $self->normal_form( $self->invert( 0, $forms[0] ) );

    for my $set (@forms) {
        $set = $self->transpose( $self->{_DEG_IN_SCALE} - $set->[0], $set )
          if $set->[0] != 0;
    }

    my @prime;
    if ( "@{$forms[0]}" eq "@{$forms[1]}" ) {
        @prime = @{ $forms[0] };
    } else {
        # look for most compact to the left
        my @sums = ( 0, 0 );
      PITCH:
        for my $i ( 0 .. $#$pset ) {
            for my $j ( 0 .. 1 ) {
                $sums[$j] += $forms[$j][$i];
            }
            if ( $sums[0] < $sums[1] ) {
                @prime = @{ $forms[0] };
                last PITCH;
            } elsif ( $sums[0] > $sums[1] ) {
                @prime = @{ $forms[1] };
                last PITCH;
            }
        }
    }

    return \@prime;
}

# Utility, "mirrors" a pitch to be within supplied min/max values as
# appropriate for how many times the pitch "reflects" back within those
# limits, which will depend on which limit is broken and by how much.
sub reflect_pitch {
    my ( $self, $v, $min, $max ) = @_;
    croak 'pitch must be a number' if !looks_like_number $v;
    croak 'limits must be numbers and min less than max'
      if !looks_like_number $min
      or !looks_like_number $max
      or $min >= $max;
    return $v if $v <= $max and $v >= $min;

    my ( @origins, $overshoot, $direction );
    if ( $v > $max ) {
        @origins   = ( $max, $min );
        $overshoot = abs( $v - $max );
        $direction = -1;
    } else {
        @origins   = ( $min, $max );
        $overshoot = abs( $min - $v );
        $direction = 1;
    }
    my $range    = abs( $max - $min );
    my $register = int( $overshoot / $range );
    if ( $register % 2 == 1 ) {
        @origins = reverse @origins;
        $direction *= -1;
    }
    my $remainder = $overshoot % $range;

    return $origins[0] + $remainder * $direction;
}

sub retrograde {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'pitch set must contain something' if !@$pset;

    return [ reverse @$pset ];
}

sub rotate {
    my $self = shift;
    my $r    = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'rotate value must be integer'
      if !defined $r
      or $r !~ /^-?\d+$/;
    croak 'pitch set must contain something' if !@$pset;

    my @rot;
    if ( $r == 0 ) {
        @rot = @$pset;
    } else {
        for my $i ( 0 .. $#$pset ) {
            $rot[$i] = $pset->[ ( $i - $r ) % @$pset ];
        }
    }

    return \@rot;
}

# Utility method to rotate a list to a named element (for example "gis"
# in a list of note names, see my etude no.2 for results of heavy use of
# such rotations).
sub rotateto {
    my $self = shift;
    my $what = shift;
    my $dir  = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'nothing to search on' unless defined $what;
    croak 'nothing to rotate on' if !@$pset;

    my @idx = 0 .. $#$pset;

    $dir //= 1;
    @idx = reverse @idx if $dir < 0;

    for my $i (@idx) {
        next unless $pset->[$i] eq $what;
        return $self->rotate( -$i, $pset );
    }
    croak "no such element $what";
}

# XXX probably should disallow changing this on the fly, esp. if allow
# method chaining, as it could throw off results in wacky ways.
sub scale_degrees {
    my ( $self, $dis ) = @_;
    if ( defined $dis ) {
        croak 'scale degrees value must be positive integer greater than 1'
          if $dis !~ /^\d+$/
          or $dis < 2;
        $self->{_DEG_IN_SCALE} = $dis;
    }
    return $self->{_DEG_IN_SCALE};
}

sub set_complex {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'pitch set must contain something' if !@$pset;

    my $iset = $self->invert( 0, $pset );
    my $dis  = $self->scale_degrees;

    my @plex = $pset;
    for my $i ( 1 .. $#$pset ) {
        for my $j ( 0 .. $#$pset ) {
            if ( $j == 0 ) {
                $plex[$i][0] = $iset->[$i];
            } else {
                $plex[$i][$j] = ( $pset->[$j] + $iset->[$i] ) % $dis;
            }
        }
    }

    return \@plex;
}

sub subsets {
    my $self = shift;
    my $len  = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    my @nset = uniqnum map { $_ % $self->{_DEG_IN_SCALE} } @$pset;
    croak 'pitch set must contain two or more unique pitches' if @nset < 2;

    if ( defined $len ) {
        croak 'length must be less than size of pitch set (but not zero)'
          if $len >= @nset
          or $len == 0;
        if ( $len < 0 ) {
            $len = @nset + $len;
            croak 'negative length exceeds magnitude of pitch set' if $len < 1;
        }
    } else {
        $len = @nset - 1;
    }

    return [ combinations( \@nset, $len ) ];
}

sub tcis {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'pitch set must contain something' if !@$pset;

    my %seen;
    @seen{@$pset} = ();

    my @tcis;
    for my $i ( 0 .. $self->{_DEG_IN_SCALE} - 1 ) {
        $tcis[$i] = 0;
        for my $p ( @{ $self->transpose_invert( $i, 0, $pset ) } ) {
            $tcis[$i]++ if exists $seen{$p};
        }
    }
    return \@tcis;
}

sub tcs {
    my $self = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'pitch set must contain something' if !@$pset;

    my %seen;
    @seen{@$pset} = ();

    my @tcs = scalar @$pset;
    for my $i ( 1 .. $self->{_DEG_IN_SCALE} - 1 ) {
        $tcs[$i] = 0;
        for my $p ( @{ $self->transpose( $i, $pset ) } ) {
            $tcs[$i]++ if exists $seen{$p};
        }
    }
    return \@tcs;
}

sub transpose {
    my $self = shift;
    my $t    = shift;
    my @tset = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;

    croak 'transpose value not set'          if !defined $t;
    croak 'pitch set must contain something' if !@tset;

    $t = int $t;
    for my $p (@tset) {
        $p = ( $p + $t ) % $self->{_DEG_IN_SCALE};
    }
    return \@tset;
}

sub transpose_invert {
    my $self = shift;
    my $t    = shift;
    my $axis = shift;
    my $pset = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];

    croak 'transpose value not set'          if !defined $t;
    croak 'pitch set must contain something' if !@$pset;

    $axis //= 0;
    my $tset = $self->invert( $axis, $pset );

    $t = int $t;
    for my $p (@$tset) {
        $p = ( $p + $t ) % $self->{_DEG_IN_SCALE};
    }
    return $tset;
}

sub variances {
    my ( $self, $pset1, $pset2 ) = @_;

    croak 'pitch set must be array ref' unless ref $pset1 eq 'ARRAY';
    croak 'pitch set must contain something' if !@$pset1;
    croak 'pitch set must be array ref' unless ref $pset2 eq 'ARRAY';
    croak 'pitch set must contain something' if !@$pset2;

    my ( @union, @intersection, @difference, %count );
    for my $p ( @$pset1, @$pset2 ) {
        $count{$p}++;
    }
    for my $p ( sort { $a <=> $b } keys %count ) {
        push @union,                                              $p;
        push @{ $count{$p} > 1 ? \@intersection : \@difference }, $p;
    }
    return wantarray ? ( \@intersection, \@difference, \@union ) : \@intersection;
}

sub zrelation {
    my ( $self, $pset1, $pset2 ) = @_;

    croak 'pitch set must be array ref' unless ref $pset1 eq 'ARRAY';
    croak 'pitch set must contain something' if !@$pset1;
    croak 'pitch set must be array ref' unless ref $pset2 eq 'ARRAY';
    croak 'pitch set must contain something' if !@$pset2;

    my @ic_vecs;
    for my $ps ( $pset1, $pset2 ) {
        push @ic_vecs, scalar $self->interval_class_content($ps);
    }
    return ( "@{$ic_vecs[0]}" eq "@{$ic_vecs[1]}" ) ? 1 : 0;
}

1;
__END__