File Coverage

lib/ChordPro/Chords.pm

Criterion	Covered	Total	%
statement	238	374	63.6
branch	82	170	48.2
condition	66	127	51.9
subroutine	24	31	77.4
pod	0	25	0.0
total	410	727	56.4

#! perl

package main;

our $config;
our $options;

package ChordPro::Chords;

use v5.26;
use utf8;
use Carp;
use feature qw( signatures );
no warnings "experimental::signatures";

use ChordPro::Chords::Parser;

# Chords defined by the configs.
my %config_chords;

# Names of chords loaded from configs.
my @chordnames;

# Additional chords, defined by the user.
my %song_chords;

# Current tuning.
my @tuning;			# names, e.g. E2
my @t_ord;			# ordinals, e.g. 4
my $t_oct;			# octave, usually 12

# Assert that an instrument is loaded.
sub assert_tuning () {
    Carp::croak("FATAL: No instrument?") unless @tuning;
}

################ Section Dumping Chords ################

# API: Returns a list of all chord names in a nice order.
# Used by: ChordPro, Output/ChordPro.
sub chordnames () {
    assert_tuning();
    [ sort chordcompare @chordnames ];
}

# Chord order ordinals, for sorting.
my %chordorderkey; {
    my $ord = 0;
    for ( split( ' ', "C C# Db D D# Eb E F F# Gb G G# Ab A A# Bb B" ) ) {
	$chordorderkey{$_} = $ord;
	$ord += 2;
    }
}

# Compare routine for chord names.
# API: Used by: Song.
sub chordcompare {
    ( $a, $b ) = @_ if @_;
    my ( $a0, $arest ) = $a =~ /^([A-G][b#]?)(.*)/;
    my ( $b0, $brest ) = $b =~ /^([A-G][b#]?)(.*)/;
    $a0 = $chordorderkey{$a0//"\x{ff}"}//return 0;
    $b0 = $chordorderkey{$b0//"\x{ff}"}//return 0;
    return $a0 <=> $b0 if $a0 != $b0;
    $a0++ if $arest =~ /^m(?:in)?(?!aj)/;
    $b0++ if $brest =~ /^m(?:in)?(?!aj)/;
    for ( $arest, $brest ) {
	s/11/:/;		# sort 11 after 9
	s/13/;/;		# sort 13 after 11
	s/\((.*?)\)/$1/g;	# ignore parens
	s/\+/aug/;		# sort + as aug
    }
    $a0 <=> $b0 || $arest cmp $brest;
}
# Dump a textual list of chord definitions.
# Should be handled by the ChordPro backend?

sub list_chords ( $chords, $origin, $hdr ) {
    assert_tuning();
    my @s;
    if ( $hdr ) {
	my $t = "-" x (((@tuning - 1) * 4) + 1);
	substr( $t, (length($t)-7)/2, 7, "strings" );
	push( @s,
	      "# CHORD CHART",
	      "# Generated by ChordPro " . $ChordPro::VERSION,
	      "# https://www.chordpro.org",
	      "#",
	      "#            " . ( " " x 35 ) . $t,
	      "#       Chord" . ( " " x 35 ) .
	      join("",
		   map { sprintf("%-4s", $_) }
		   @tuning ),
	    );
    }

    foreach my $chord ( @$chords ) {
	my $info;
	if ( eval{ $chord->{name} } ) {
	    $info = $chord;
	}
	elsif ( $origin eq "chord" ) {
	    push( @s, sprintf( "{%s:  %s}", "chord", $chord ) );
	    next;
	}
	else {
	    $info = known_chord($chord);
	}
	next unless $info;
	my $s = sprintf( "{%s %-15.15s base-fret %2d    ".
			 "frets   %s",
			 $origin eq "chord" ? "chord: " : "define:",
			 $info->{name}, $info->{base},
			 @{ $info->{frets} // [] }
			 ? join("",
				map { sprintf("%-4s", $_) }
				map { $_ < 0 ? "X" : $_ }
				@{ $info->{frets} } )
			 : ("    " x strings() ));
	$s .= join("", "    fingers ",
		   map { sprintf("%-4s", $_) }
		   map { $_ < 0 ? "X" : $_ }
		   @{ $info->{fingers} } )
	  if $info->{fingers} && @{ $info->{fingers} };
	$s .= join("", "    keys ",
		   map { sprintf("%2d", $_) }
		   @{ $info->{keys} } )
	  if $info->{keys} && @{ $info->{keys} };
	$s .= "}";
	push( @s, $s );
    }
    \@s;
}

sub dump_chords ( $mode ) {
    assert_tuning();
    print( join( "\n",
		 $mode && $mode == 2
		 ? @{ json_chords(\@chordnames ) }
		 : @{ list_chords(\@chordnames, "__CLI__", 1) } ), "\n" );
}

sub json_chords ( $chords ) {
    assert_tuning();
    my @s;

    push( @s, "// ChordPro instrument definition.",
	  "",
	  qq<{ "instrument" : "> .
	  ($::config->{instrument} || "Guitar, 6 strings, standard tuning") .
	  qq<",>,
	  "",
	  qq<  "tuning" : [ > .
	  join(", ", map { qq{"$_"} } @tuning) . " ],",
	  "",
	  qq{  "chords" : [},
	  "",
	 );

    my $maxl = -1;
    foreach my $chord ( @$chords ) {
	my $t = length( $chord );
	$maxl < $t and $maxl = $t;
    }
    $maxl += 2;

    foreach my $chord ( @$chords ) {
	my $info;
	if ( eval{ $chord->{name} } ) {
	    $info = $chord;
	}
	else {
	    $info = known_chord($chord);
	}
	next unless $info;

	my $name = '"' . $info->{name} . '"';
	my $s = sprintf( qq[    { "name" : %-${maxl}.${maxl}s,] .
                         qq[ "base" : %2d,],
			 $name, $info->{base} );
	if ( @{ $info->{frets} } ) {
	    $s .= qq{ "frets" : [ } .
	      join( ", ", map { sprintf("%2s", $_) } @{ $info->{frets} } ) .
		qq{ ],};
	}
	if ( $info->{fingers} && @{ $info->{fingers} } ) {
	    $s .= qq{ "fingers" : [ } .
	      join( ", ", map { sprintf("%2s", $_) } @{ $info->{fingers} } ) .
		qq{ ],};
	}
	if ( $info->{keys} && @{ $info->{keys} } ) {
	    $s .= qq{ "keys" : [ } .
	      join( ", ", map { sprintf("%2d", $_) } @{ $info->{keys} } ) .
		qq{ ],};
	}
	chop($s);
	$s .= " },";
	push( @s, $s );
    }
    chop( $s[-1] );
    push( @s, "", "  ]," );
    if ( $::config->{pdf}->{diagrams}->{vcells} ) {
	push( @s, qq<  "pdf" : { "diagrams" : { "vcells" : > .
	      $::config->{pdf}->{diagrams}->{vcells} . qq< } },> );
    }
    chop( $s[-1] );
    push( @s, "}" );
    \@s;
}

################ Section Tuning ################

# API: Return the number of strings supported.
# Used by: Songbook, Output::PDF.
sub strings () {
    scalar(@tuning);
}

my $parser;# = ChordPro::Chords::Parser->default;

# API: Set tuning, discarding chords.
# Used by: Config.
sub set_tuning ( $cfg ) {
    my $t = $cfg->{tuning} // [];
    return "Invalid tuning (not array)" unless ref($t) eq "ARRAY";
    $options //= { verbose => 0 };

    if ( @tuning ) {
	( my $t1 = "@$t" ) =~ s/\d//g;
	( my $t2 = "@tuning" ) =~ s/\d//g;
	if ( $t1 ne $t2 ) {
	    warn("Tuning changed, chords flushed\n")
	      if $options->{verbose} > 1;
	    @chordnames = ();
	    %config_chords = ();
	}
    }
    else {
	@chordnames = ();
	%config_chords = ();
    }
    @tuning = @$t;

    # Get ordinals for tuning.
    my $p = ChordPro::Chords::Parser->get_parser("common");
    $t_oct = keys %{ $p->{ns_tbl} };
    for ( @tuning ) {
	return "Invalid tuning (should be note + octave): $_"
	  unless /(^.*?)(\d+)$/;	# split off octave
	my $n = $p->{ns_tbl}->{$1} // $p->{nf_tbl}->{$1};
	return "Invalid tuning (unknown note): $1" unless defined $n;
	push( @t_ord, $2 * $t_oct + $n );
    }

    assert_tuning();
    return;

}

# API: Get tuning.
# Used by: String substitution.
sub get_tuning () {
    @{[@tuning]};
}

# API: Set target parser.
# Used by: ChordPro.
sub set_parser ( $p ) {

    $p = ChordPro::Chords::Parser->get_parser($p)
      unless ref($p) && $p->isa('ChordPro::Chords::Parser');
    $parser = $p;
    warn( "Parser: ", $parser->{system}, "\n" )
      if $options->{verbose} > 1;

    return;
}

# Parser stack.

my @parsers;

# API: Reset current parser.
# Used by: Config.
sub reset_parser () {
    undef $parser;
    @parsers = ();
}

sub get_parser () {
    $parser;
}

sub push_parser ( $p ) {
    $p = ChordPro::Chords::Parser->get_parser($p)
      unless ref($p) && $p->isa('ChordPro::Chords::Parser');
    push( @parsers, $p );
    $parser = $p;
}

sub pop_parser () {
    Carp::croak("Parser stack underflow") unless @parsers;
    $parser = pop(@parsers);
}

################ Section Config & User Chords ################

sub known_chord ( $name ) {
    my $info;
    if ( ref($name) =~ /^ChordPro::Chord::/ ) {
	$info = $name;
	$name = $info->name;
    }
    my $ret = $song_chords{$name} // $config_chords{$name};
    $ret->{_via} = $ret->{origin} . " chords", return $ret if $ret;
    return unless $info;

    # Retry agnostic. Not all can do that.
    $name = eval { $info->agnostic };
    return unless $name;
    $ret = $song_chords{$name} // $config_chords{$name};
    if ( $ret ) {
	$ret = $info->new($ret);
	for ( qw( name display
		  root root_canon root_mod
		  qual qual_canon ext ext_canon
		  bass bass_canon
		  system parser ) ) {
	    next unless defined $info->{$_};
	    $ret->{$_} = $info->{$_};
	}
	$ret->{_via} = "agnostic" . " " . $ret->{origin} . " chords";
    }
    $ret;
}

sub check_chord ( $ii ) {
    my ( $name, $base, $frets, $fingers, $keys )
      = @$ii{qw(name base frets fingers keys)};
    if ( $frets && @$frets && @$frets != strings() ) {
	return scalar(@$frets) . " strings";
    }
    if ( $fingers && @$fingers && @$fingers != strings() ) {
	return scalar(@$fingers) . " strings for fingers";
    }
    unless ( $base > 0 && $base < 24 ) {
	return "base-fret $base out of range";
    }
    if ( $keys && @$keys ) {
	for ( @$keys ) {
	    return "invalid key \"$_\"" unless /^\d+$/ && $_ < 24;
	}
    }
    return;
}

# API: Access the chords table.
# Used by: Utils.
sub config_chords { \%config_chords }

# API: Add a config defined chord.
# Used by: Config.
sub add_config_chord ( $def ) {

    my $res;
    my $name;

    my @extprops = qw( display format );

    # Handle alternatives.
    my @names;
    if ( $def->{name} =~ /.\|./ ) {
	$def->{name} = [ split( /\|/, $def->{name} ) ];
    }
    if ( UNIVERSAL::isa( $def->{name}, 'ARRAY' ) ) {
	$name = shift( @{ $def->{name} } );
	push( @names, @{ $def->{name} } );
    }
    else {
	$name = $def->{name};
    }

    # For derived chords.
    if ( $def->{copy} || $def->{"copyall"} ) {
	my $src = $def->{copy};
	if ( $def->{copyall} ) {
	    return "Cannot copy and copyall at the same time"
	      if $src;
	    $src = $def->{copyall};
	}
	$res = $config_chords{$src};
	return "Cannot copy $src" unless $res;
	if ( $def->{copy} ) {
	    my $r = { %$res };
	    delete $r->{$_} for @extprops;
	    $def = bless { %$r, %$def } => ref($res);
	}
	else {
	    $def = bless { %$res, %$def } => ref($res);
	    $def->{copy} = $def->{copyall};
	}
    }
    delete $def->{name};
    $def->{base} ||= 1;

    my ( $base, $frets, $fingers, $keys ) =
      ( $def->{base}, $def->{frets}, $def->{fingers}, $def->{keys} );
    $res = check_chord($def);
    return $res if $res;

    my $dpinfo;
    if ( $def->{display} ) {
	$dpinfo = parse_chord($def->{display});
	if ( $dpinfo ) {
	    $def->{display} = $dpinfo;
	}
	else {
	    delete $def->{display};
	}
    }
    for $name ( $name, @names ) {
	next if $name =~ /^(\||\s*)$/;
	my $info = parse_chord($name)
	  // ChordPro::Chord::Common->new({ name => $name });

	if ( $info->is_chord && $def->{copy} && $def->is_chord ) {
	    for ( qw( root bass ext qual ) ) {
		delete $def->{$_};
		delete $def->{$_."_mod"};
		delete $def->{$_."_canon"};
	    }
	    for ( qw( ext qual ) ) {
		delete $def->{$_};
		delete $def->{$_."_canon"};
	    }
	}
	Carp::confess(::dump($parser)) unless $parser->{target};
	$config_chords{$name} = bless
	  { origin  => "config",
	    system  => $parser->{system},
	    %$info,
	    %$def,
	    base    => $base,
	    baselabeloffset => $def->{baselabeloffset}||0,
	    frets   => [ $frets && @$frets ? map { $_ eq 'x' ? -1 : $_ } @$frets : () ],
	    fingers => [ $fingers && @$fingers ? @$fingers : () ],
	    keys    => [ $keys && @$keys ? @$keys : () ]
	  } => $parser->{target};
	push( @chordnames, $name );

	# Also store the chord info under a neutral name so it can be
	# found when other note name systems are used.
	my $i;
	if ( $info->is_chord ) {
	    $i = $info->agnostic;
	}
	else {
	    # Retry with default parser.
	    $i = ChordPro::Chords::Parser->default->parse($name);
	    if ( $i && $i->is_chord ) {
		$info->{root_ord} = $i->{root_ord};
		$config_chords{$name}->{$_} = $i->{$_}
		  for qw( root_ord root_mod ext_canon qual_canon );
		$i = $i->agnostic;
	    }
	}
	if ( $info->is_chord ) {
	    $config_chords{$i} = $config_chords{$name};
	    $config_chords{$i}->{origin} = "config";
	}
    }
    return;
}

# API: Add a user defined chord.
# Used by: Song.
sub add_song_chord ( $ii ) {

    return if $ii->name =~ /^(\||\s*)$/;

    my $res = check_chord($ii);
    return $res if $res;

    # Need a parser anyway.
    $parser //= ChordPro::Chords::Parser->get_parser;

    my $c =
      { system  => $parser->{system},
	parser  => $parser,
	%$ii,
      };
    $c->{origin} //= "user";

    # Cleanup.
    for ( qw( display ) ) {
	delete $c->{$_} unless defined $c->{$_};
    }
    for ( qw( frets fingers keys ) ) {
	delete $c->{$_} unless $c->{$_} && @{ $c->{$_} };
    }

    $song_chords{$c->{name}} = bless $c => $parser->{target};
    return;
}

# API: Add an unknown chord.
# Used by: Song.
sub add_unknown_chord ( $name ) {
    $parser //= ChordPro::Chords::Parser->get_parser;
    $song_chords{$name} = bless
      { origin  => "user",
	name    => $name,
	base    => 0,
	frets   => [],
	fingers => [],
        keys    => []
      } => $parser->{target};
}

# API: Reset user defined songs. Should be done for each new song.
# Used by: Songbook, Output::PDF.
sub reset_song_chords () {
    %song_chords = ();
}

# API: Return some chord statistics.
sub chord_stats () {
    my $res = sprintf( "%d config chords", scalar(keys(%config_chords)) );
    $res .= sprintf( ", %d song chords", scalar(keys(%song_chords)) )
      if %song_chords;
    return $res;
}

################ Section Chords Parser ################

sub parse_chord ( $chord ) {

    $parser //= ChordPro::Chords::Parser->get_parser;
    return $parser->parse($chord);
}

################ Section Keyboard keys ################

my %keys =
  ( ""       => [ 0, 4, 7 ],	             # major
	"-"      => [ 0, 3, 7 ],	             # minor
	"7"      => [ 0, 4, 7, 10 ],             # dominant 7th
	"-7"     => [ 0, 3, 7, 10 ],             # minor seventh
	"maj7"   => [ 0, 4, 7, 11 ],             # major 7th
	"-maj7"  => [ 0, 3, 7, 11 ],             # minor major 7th
	"6"      => [ 0, 4, 7, 9 ],              # 6th
	"-6"     => [ 0, 3, 7, 9 ],              # minor 6th
	"6add9"  => [ 0, 4, 7, 9, 14],           # 6/9
	"5"      => [ 0, 7 ],                    # 6th
	"9"      => [ 0, 4, 7, 10, 14 ],         # 9th
	"-9"     => [ 0, 3, 7, 10, 14 ],         # minor 9th
	"maj9"   => [ 0, 4, 7, 11, 14 ],         # major 9th
	"11"     => [ 0, 4, 7, 10, 14, 17 ],     # 11th
	"-11"    => [ 0, 3, 7, 10, 14, 17 ],     # minor 11th
	"13"     => [ 0, 4, 7, 10, 14, 17, 21 ], # 13th
	"-13"    => [ 0, 3, 7, 10, 14, 17, 21 ], # minor 13th
	"maj13"  => [ 0, 4, 7, 11, 14, 21 ],     # major 13th
	"add2"   => [ 0, 2, 4, 7 ],              # add 2
	"add9"   => [ 0, 4, 7, 14 ],             # add 9
	"-add2"  => [ 0, 2, 3, 7 ],              # minor add 2
	"-add9"  => [ 0, 2, 3, 7, 11 ],          # minor add 9
	"-add11" => [ 0, 3, 5, 7, 11 ],          # minor add 11
	"7-5"    => [ 0, 4, 6, 10 ],             # 7 flat 5 altered chord
	"7+5"    => [ 0, 4, 8, 10 ],             # 7 sharp 5 altered chord
	"sus4"   => [ 0, 5, 7 ],                 # sus 4
	"sus2"   => [ 0, 2, 7 ],                 # sus 2
	"7sus2"  => [ 0, 2, 7, 10 ],             # 7 sus 2
	"7sus4"  => [ 0, 5, 7, 10 ],             # 7 sus 4
	"-7sus2" => [ 0, 2, 3, 7, 10 ],          # minor 7 sus 2
	"-7sus4" => [ 0, 3, 5, 7, 10 ],          # minor 7 sus 4
	"0"      => [ 0, 3, 6 ],	             # diminished
	"07"     => [ 0, 3, 6, 9 ],              # diminished 7
	"-7b5"   => [ 0, 3, 6, 10 ],             # minor 7 flat 5
	"+"      => [ 0, 4, 8 ],	             # augmented
	"+7"     => [ 0, 4, 8, 10 ],             # augmented 7
	"h"      => [ 0, 3, 6, 10 ],             # half-diminished seventh
  );

sub get_keys ( $info ) {

    # Has keys defined.
    return $info->{keys} if $info->{keys} && @{$info->{keys}};

    my @keys;

    if ( defined $info->{qual_canon}
	 && defined $info->{ext_canon}
	 && defined $keys{$info->{qual_canon}.$info->{ext_canon}} ) {
	# Known chord extension.
	@keys = @{ $keys{$info->{qual_canon}.$info->{ext_canon}} };
    }
    else {
	# Try to derive from guitar chord.
	return [] unless $info->{frets} && @{$info->{frets}};

	# Get ordinals for tuning.
	my @t_ord = map { $_ % $t_oct } @t_ord;

	my %keys;
	my $i = -1;
	my $base = $info->{base} - 1;
	$base = 0 if $base < 0;
	for ( @{ $info->{frets} } ) {
	    $i++;
	    next if $_ < 0;
	    my $c = $t_ord[$i] + $_ + $base;
	    if ( $info->{root_ord} ) {
		$c += $t_oct if $c < $info->{root_ord};
		$c -= $info->{root_ord};
	    }
	    $keys{ $c % $t_oct }++;
	}
	@keys = sort keys %keys;
    }

    if ( defined $info->{bass} && $info->{bass} ne '' ) {
	# Handle inversions.
	my @k;
	my $bass = $info->{bass_ord} - $info->{root_ord};
	my $oct = 12;		# yes
	$bass += $oct if $bass < 0;
	for ( @keys ) {
	    next if $_ == $bass;
	    push( @k, $_ < $bass ? $_+$oct : $_ );
	}
	unshift( @k, $bass );
	@keys = @k;
    }
    \@keys;
}

################ Section Transposition ################

# API: Transpose a chord.
# Used by: Songbook.
sub transpose ( $c, $xpose, $xcode = "" ) {
    return $c unless $xpose || $xcode;
    return $c if $c =~ /^ .+/;
    my $info = parse_chord($c);
    unless ( $info ) {
	assert_tuning();
	for ( \%song_chords, \%config_chords ) {
	    # Not sure what this is for...
	    # Anyway, it causes unknown but {defined} chords to silently
	    # bypass the trans* warnings.
	    # return if exists($_->{$c});
	}
	$xpose
	  ? warn("Cannot transpose $c\n")
	  : warn("Cannot transcode $c\n");
	return;
    }

    my $res = $info->transcode($xcode)->transpose($xpose)->canonical;

#    Carp::cluck("__XPOSE = ", $xpose, " __XCODE = $xcode, chord $c => $res\n");

    return $res;
}

1;