view release on metacpan or  search on metacpan

bin/vov  view on Meta::CPAN

$output_tmpl .= "\n" unless $output_tmpl =~ m/\s$/;

for my $vov_spec (@ARGV) {
    my @vovs           = reverse split '/', $vov_spec;
    my $base_intervals = get_mode_intervals($mode_name);
    my $cur_intervals  = $base_intervals;
    my $sd_transpose   = 0;

    my ( $prev_root_pitch, $prev_root_sd, $pset, $invert_by );
    for my $vov (@vovs) {
        my ( $root_sd, $factor, $alterations, $inv ) = parse_roman_numeral($vov);
        if ( defined $prev_root_sd ) {
            $sd_transpose = $prev_root_pitch;
            # This rotation trick constrains the pitches of the new relative
            # pitch to those of the overlying mode, as otherwise III/ii
            # assuming major will use pitches not present in the underlying
            # major scale.
            $cur_intervals = $atu->rotate( -1 * $prev_root_sd, $base_intervals );
        }
        my $sds = build_triad_degrees( $root_sd, $factor );
        $pset = sd2ps( $sds, $alterations, $cur_intervals, $sd_transpose );

        $prev_root_pitch = $pset->[0];
        $prev_root_sd    = $root_sd;
        $invert_by       = $inv;
    }

    $pset = $atu->rotate( -1 * $invert_by, $pset ) if $invert_by;

    if ($Transpose) {
        for my $p (@$pset) {
            $p += $Transpose;
            $p %= $DEG_IN_SCALE;
        }
    }

    my %out_attr = ( vov => $vov_spec );
    if ($raw_output) {
        $out_attr{chord} = join " ", @$pset;
    } else {
        $out_attr{chord} = join " ", $lyu->p2ly(@$pset);
    }
    my $str = $output_tmpl;
    $str =~
      s/ \Q%{\E (\w+) \Q}\E / defined $out_attr{$1} ? $out_attr{$1} : q{} /egx;
    print $str;
}

exit 0;

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

# Given root scale degree plus a chord factor, returns an array
# reference of scale degrees of the chord elements up to the
# chord factor.
sub build_triad_degrees {
    my ( $root_sd, $factor ) = @_;
    if ( defined $factor ) {
        $factor =~ tr/0-9//cd;    # so can say "5th" or "7th" or the like
        if ( $factor < 1 or $factor > $MAX_CHORD_FACTOR or $factor % 2 == 0 ) {
            croak "factor must be odd number between 1 and $MAX_CHORD_FACTOR inclusive";
        }
    } else {
        $factor = $DEFAULT_CHORD_FACTOR;
    }

    if ( !defined $root_sd or $root_sd < 0 or $root_sd >= $MAX_SCALE_DEGREE ) {
        croak "root scale degree must be 0 to "
          . ( $MAX_SCALE_DEGREE - 1 )
          . " inclusive";
    }

    my @sds;
    # I blame too many slope equation videos & exercises on Khan Academy
    # for this code.
    for my $i ( 1 .. ( $factor * 0.5 + 0.5 ) ) {
        push @sds, ( $root_sd + 2 * $i - 2 ) % $MAX_SCALE_DEGREE;
    }

    return \@sds;
}

# Convert pitches from Music::Scales into a list of intervals
sub get_mode_intervals {
    my ($name) = @_;
    my @pitches = get_scale_nums($name);
    my @intervals;

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

    # pad out scale with VII to I interval
    my $sum = sum @intervals;
    if ( $sum < $DEG_IN_SCALE ) {
        push @intervals, $DEG_IN_SCALE - $sum;
    } elsif ( $sum > $DEG_IN_SCALE ) {
        die "error: do not know what to do with scale larger than $DEG_IN_SCALE\n";
    }
    return \@intervals;
}

# XXX 7ths could use more work? no way to specify MM7 vs. Mm7 (that
# these are notated the same using Roman Numerals does not help).
sub parse_roman_numeral {
    my ($numeral) = @_;
    my ( $pre, $roman, $suf ) =
      $numeral =~ m/^($ROMAN_PREFIX_RE)?($ROMAN_NUMERAL_RE)($ROMAN_SUFFIX_RE)?/;
    $pre //= '';
    $suf //= '';

    my %alterations;
    my $factor = $Default_Factor;
    my $inversion;

    # Inversions by trailing letter format: Ia no inversion, Ib first,
    # etc. 'g' is to support the maximum inversion of a 13th chord.
    if ( $suf =~ m/([a-g])/ ) {
        $inversion = ord($1) - ord('a');