path: root/chordparser.pl

#!/usr/bin/perl -w

use strict;

our $VERBOSE = 0;

# TODO: omit syntax needs to support any note, not just 3 and 5.

# TODO: write a Chord class, return instances of that, instead of just
# printing note names.

# TODO: figure out a way to decide which notes are optional (e.g. the 5th
# in a 7th chord, or the 5th and 7th in a 9th chord). Probably need a
# "weight", since the 9th chord's 7th is "more optional" than the 5th.
# (at least on guitar, you're more likely to play the 5th than the
# 7th, and you're not real likely to play both due to only having 6 strings)

# TODO: turn this into a module.

# TODO: chord generator like what chordspeller.pl does (give it some
# notes, it intuits the chord). Almost none of the existing parser code
# will be usable for this. The chordspeller code is very limited (it
# just permutes the notes & compares them to a fixed list of chord types).

# TODO: fretboard stuff

# TODO: notation (treble clef). MusicXML, or generate a PNG, or what?

# TODO: simplify the parser. One way to do this: before parsing, do stuff
# like s/(M|major)/maj/, s/\+/aug/ maybe, I dunno.

# TODO: support roman and arabic numerals. Will require the program to
# determine or be told the key (e.g. IV or 4 is F in key of C). Should
# take them for input and output them too.

# TODO: suggest substitutions? definitely need to know the key!

use Music::Chord::Namer 'chordname';
use Music::Chord::Note;
use Data::Dumper;
our $grammar = <<'EOF';
# terminals

letter: /[A-G]/
flat: /b/
sharp: /#/
major: /(?:maj|M)/
minor: /(?:min|m)/
dimaug: /(?:dim|\+|aug|-|adim)/
sustok: /sus/
sustype: /[24]/
number: /\d\d?/
slash: m(/)
addtok: m(add)
omittok: /no|omit/i
#omitval: /(3|5|7|9|11|13)/ #not yet
omitval: /(3|5)/

# productions

# Our starting rule. Unfortunately kinda ambiguous due to all the
# optional stuff:
chord: note triad(?) degree(?) sus(?) add(s?) bass(?) omit(s?) {
	print Data::Dumper::Dumper(\%item) if $::VERBOSE;
	\%item;
}

note: letter modifier(?)
modifier: flat | sharp
triad: major | minor | dimaug
sus: slash(?) sustok sustype(?)
degree: slash(?) modifier(?) number | slash(?) major number
bass: slash note
add: addsym number | addsym modifier number | modifier number
addsym: addtok | slash
omit: slash(?) omittok omitval

EOF

use Parse::RecDescent;

our %notevals = (
		C => 0,
		D => 2,
		E => 4,
		F => 5,
		G => 7,
		A => 9,
		B => 11,
		1 => 0,
		2 => 2,
		3 => 4,
		4 => 5,
		5 => 7,
		6 => 9,
		7 => 11,
		8 => 0,
		9 => 2,
		10 => 4,
		11 => 5,
		12 => 7,
		13 => 9,
		14 => 11,
		15 => 0,
);

sub mknote {
	my ($name, $mod) = @_;
	$mod ||= '';
#print Data::Dumper::Dumper($mod);
	warn "name '$name', mod '$mod'" if $::VERBOSE;
	my $val = $notevals{$name};
	$val++ if $mod eq '#';
	$val-- if $mod eq 'b';
	return $val % 12;
}

sub extract_mod {
	my $mod = shift || return "";
	if($mod) {
		if($mod->{flat}) {
			$mod = 'b';
		} elsif($mod->{sharp}) {
			$mod = '#';
		} else {
			$mod = "";
		}
	} else {
		$mod = "";
	}
	return $mod;
}

sub extract_note {
	my $n = shift;

	my $mod = extract_mod($n->{"modifier(?)"}->[0]);

	my $note = mknote($n->{letter}->{__PATTERN1__}, $mod);
}

sub get_triad_type {
	my $t = shift;
	if($t->{dimaug}) {
		my $da = $t->{dimaug}->{__PATTERN1__};
		$da = 'aug' if $da eq '+';
		$da = 'dim' if $da eq '-';
		return $da;
	} elsif($t->{major}) {
		return 'major';
	} elsif($t->{minor}) {
		return 'minor';
	} else {
		return '';
	}
}

our @note_names = ( 'C', 'C#', 'D', 'D#', 'E', 'F', 'F#', 'G', 'G#', 'A', 'A#', 'B' );
sub get_note_name {
	return $note_names[$_[0] % 12];
}

sub get_sus_type {
	my $s = shift;
	return 0 unless defined $s;
	return $s->{"sustype(?)"}->[0]->{__PATTERN1__} || 4;
}

sub extract_number {
	my $n = shift || return 0;
	return $n->{__PATTERN1__};
}

sub create_chord {
	my $c = shift;
	my $have7 = '';

	my $note = extract_note($c->{note});
	warn "root note is $note" if $::VERBOSE;

	my $bass = $note;
	if($c->{"bass(?)"}->[0]) {
		$bass = extract_note($c->{"bass(?)"}->[0]->{note});
	}
	warn "bass note is $bass" if $::VERBOSE;

	my $third = 4;
	my $fifth = 7;
	my $seventh = undef;
	my $seven_type = 0; # offset in semitones from a minor 7
	my @ext_notes = ();

	my $triad_type = get_triad_type($c->{"triad(?)"}->[0]);
	if($triad_type eq 'major') {
		$seven_type = 1;
		$triad_type = '';
	} elsif($triad_type eq 'minor') {
		($third, $fifth) = (3, 7);
		$seven_type = 0;
	} elsif($triad_type eq 'dim') {
		($third, $fifth) = (3, 6);
		$seven_type = -1;
	} elsif($triad_type eq 'aug') {
		($third, $fifth) = (4, 8);
		$seven_type = 0;
	} elsif($triad_type eq 'adim') {
		($third, $fifth) = (3, 6);
		$seven_type = 0;
		$seventh = 10;
	}

	my $number = extract_number($c->{"degree(?)"}->[0]->{number});
	my $nummod = extract_mod($c->{"degree(?)"}->[0]->{"modifier(?)"}->[0]);
	my $alter = 0;
	if($nummod eq '#') {
		$alter = 1;
	} elsif($nummod eq 'b') {
		$alter = -1;
	}

	if($c->{"degree(?)"}->[0]->{major}) {
		$seven_type = 1;
	}

	if($number) {
		if($number > 15 || $number < 2) {
			die "Invalid degree $number (must be >= 2 and <= 15)\n";
		}

		if($number >= 7) {
			$seventh = 10 + $seven_type;
			for(my $n = 9; $n < $number; $n += 2) {
				warn "\$n == $n" if $::VERBOSE;
				push @ext_notes, $notevals{$n % 7};
			}
			warn "$number $alter " . $notevals{$number} if $::VERBOSE;
			if($number > 7) { push @ext_notes, $notevals{$number} + $alter; }
		} elsif($number == 5) {
			if($alter != 0) {
				$fifth += $alter;
			} else {
				$third = undef;
			}
		} elsif($number == 6) {
			push @ext_notes, $notevals{6 + $alter};
		} elsif($number) {
			die "don't know what to do with number $number, try " . ($number + 7) . " or add" . ($number + 7) . " instead?";
		}
	}

	my $sus_type = get_sus_type($c->{"sus(?)"}->[0]);
#	if($sus_type && ($triad_type ne '')) {
#		die "invalid: can't have both $triad_type and sus$sus_type third!\n";
#	}
	warn "\$sus_type == $sus_type" if $::VERBOSE;
	if($sus_type == 2) {
		$third = 2;
	} elsif($sus_type == 4) {
		$third = 5;
	}

	for my $add (@{$c->{"add(s?)"}}) {
		my $addnum = extract_number($add->{number});
		die "Invalid add '$addnum'" unless $addnum =~ /^\d+$/;
		die "Add '$addnum' out of range (must be >= 2 and <= 15)\n" unless $addnum >= 2 && $addnum <= 15;
		my $mod = extract_mod($add->{modifier});
		my $addnote = mknote($addnum, $mod);
		if($addnum == 5) {
			$fifth = $addnote;
		} else {
			push @ext_notes, $addnote;
		}
		warn "add $mod $addnum ($addnote)\n" if $::VERBOSE;
	}

	for my $omit (@{$c->{"omit(s?)"}}) {
		my $omitnote = $omit->{omitval}->{__PATTERN1__};
		if($omitnote == 3) {
			$third = undef;
		} elsif($omitnote == 5) {
			$fifth = undef;
		} else {
			warn "Don't yet know how to omit $omitnote, ignoring\n";
		}
	}

	warn "triad type is '$triad_type', 3rd $third, 5th $fifth, 7th type $seven_type" if $::VERBOSE;
	if(defined $seventh) { warn "7th is $seventh\n" if $::VERBOSE; }
	if($::VERBOSE) {
		warn "extended note: $_\n" for @ext_notes;
	}

	$third += $note if defined $third;
	$fifth += $note if defined $fifth;
	$seventh += $note if defined $seventh;

	for(@ext_notes) {
		$_ += $note if defined $_;
	}

	my @output = ();
	push @output, get_note_name($bass) unless $bass == $note;
	for($note, $third, $fifth, $seventh, @ext_notes) {
		push @output, get_note_name($_) if defined $_;
	}
	print join " ", @output, "\n";
	print "Music::Chord::Namer gives: " . chordname(@output) . "\n";
	1;
}

$::RD_ERRORS = $::RD_WARN = $::RD_HINT = $::VERBOSE;
#$RD_TRACE = 1;
#$RD_ERRORS = $RD_WARN = $RD_TRACE = 1;
#$RD_AUTOACTION = q { print join ' ', @item, "\n" };
#$RD_AUTOACTION = q { main::print_array(@item); print "\n" };
$::RD_AUTOACTION = q { \%item };
our $parser = Parse::RecDescent->new($grammar);
push @ARGV, "C#m/E" unless @ARGV;
for(@ARGV) {
	my $arg = $_;

# Allow major, Major, MAJOR, mAj, etc.
	$arg =~ s/min(or)?/min/i;
	$arg =~ s/maj(or)?/maj/i;

# Allow root note name to be lowercase
	$arg =~ s/^([a-g])/uc $1/e;

# Allow bass note name to be lowercase
	$arg =~ s/(\/)([a-g][#b]?)$/$1 . ucfirst $2/e;

# Turn (foo) into /foo, allows for E7(#9) => E7/#9
	$arg =~ s/\((.*?)\)/\/$1/g;

# Allow some English:
	$arg =~ s/flat/b/gi;
	$arg =~ s/sharp/#/gi;
	$arg =~ s/augmented/aug/gi;
	$arg =~ s/diminished/dim/gi;
	$arg =~ s/(half|auto).?dim/adim/i;
	$arg =~ s/hendrix/7#9/i;

	my $fixedarg = $arg;
	my $chord = $parser->chord(\$arg) || die "Invalid chord: $_\n";
	die "Trailing junk: $arg" if $arg;
	if($fixedarg eq $_) {
		print "$_: ";
	} else {
		print "$_ ($fixedarg): ";
	}
	create_chord($chord);
	my $cn = Music::Chord::Note->new();
	print "Music::Chord::Note gives: ";
	eval {
		my @got = $cn->chord($fixedarg);
		print join " ", @got, "\n";
	};
	print $@ if $@;
}