#NAME
#  abcCode.pm - Calculate Gore/Breathnach codes from ABC notation

#SYNOPSIS
#  use abcCode;
#  $OBJ = new abcCode;
#  ($GBcode,$JCcode,$UDcode,$Used) = $OBJ->abcCode($K,$L,$M,$music,...);

#DESCRIPTION
#  Given a chunk of ABC notation and a (presumed)  tonic  note,  calculate  a
#  code that can be used to characterize the tune.

#  The music can be passed in as one string or as an array of strings. In the
#  latter case, we will treat each string as the start of a new "chunk".

#  For each string of music, we first discard any  pickup  notes,  i.e.,  any
#  notes  before  the first bar line.  We then use the $M and $L values (from
#  the M:  and L:  header lines) to divide each group of notes up into beats.
#  We then take the first note of each beat, and calculate the scale distance
#  from the tonic, giving a number in the range 1-7, and 0 for rests.   These
#  distances are catenated into a string, which is the code that we return.

#  We  ignore  all modes, ornaments and accidentals.  This means that we will
#  produce the same code for the major and minor versions of  a  tune.   (The
#  Gore code does this; the Breathnach code includes accidentals.)

#PARAMETERS
#  The expected parameters to the abcCode() function are:

#  $K  is the tune's key, from which we extract the first char as the tonic.
#  $L  is the tune's basic note length.
#  $M  is the tune's meter, not used if $L is defined.
#  $music
#    The rest of the args should be strings of ABC music notation.  We use as
#    much of it as we need and ignore the rest.

#RETURNS
#  The return value is a list of three strings:

#  $GBcode
#    is the Gore-Breathnach code for the music.  It is a list  of  the  scale
#    steps, using the first letter in $K as the tonic, or 1, and ignoring any
#    notes that are not at a multiple of $L.
#  $JCcode
#    is JC's first-difference code, calculated by subtracing adjacent  values
#    in $GBcode, and ignoring the repeated numbers due to long notes.
#  $Used
#    is  the portion of the music that was actually used to calculate the two
#    codes. It usually matches the $JCcode, since that uses more notes.  This
#    is mostly useful for debugging purposes.

#BUGS
#  This coding scheme is useful but not perfect.  There are a lot of bad  ABC
#  coding practices that can produce poor or useless codes.

#SEE ALSO
#  There is a program abc2code that reads files, feeds them to abcCode(), and
#  displays the results.  It should be in the same directory as this module.

#AUTHOR
#  John Chambers <jc@trillian.mit.edu>

package abcCode;

my($GBcode) = '';		# Gore-Breathnach code string.
my($GBmax)  = 16;		# Max length of GBcode.
my($JCcode) = '';		# JC code is "derivative" of GBcode string.
my($JCmax)  = 15;		# Max length of JCcode.
my($UDcode) = '';		# UD code is list of up/down changes.
my($UDmax)  = 15;		# Max length of UDcode.
my($Length) = 0;		# Length currently accumulated.
my($Cnote)  = '';		# Current note's pitch (letter).
my($Cstep)  = 0;		# Current note's step (absolute).
my($Pnote)  = '';		# Previous note's pitch (letter).
my($Pstep)  = 0;		# Previous note's step (absolute).
my($Pval)   = undef;	# Previous note's pitch value (steps from C).
my($Used)   = '';		# Portion of music used for codes.
my($V)      = 1;		# Verbose level.

$" = '","';
$abcnote = '[A-Ga-g][,\']*[\d/]';	# Pattern to match an ABC note

sub new { my($O) = $_[0]; return $O}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
#    &abcCode($O,$K,$L,$M,...)
# One or more lines of ABC music (i.e., the notes, not the header  lines)  is
# passed  to us in addition to the four args.  We parse the music just enough
# to extract the notes and their lengths.  We pass the notes to abcNote()  to
# do the actual code calculation.
#
# The return value is a list of three strings:
#    ($GBcode,$JCcode,$UDcode,$Used);
# where the strings are:
#   $GBcode is the Gore-Breathnach code.
#   $JCcode is JC's first-difference code.
#   $UDcode is the up/down code.
#   $Used   is the ABC used to generate the codes.
# Note that the $Used string excludes several things:
#   1. Anything before the first bar line is ignored.
#   2. Only the first note of chords is used.
#   3. Grace notes are ignored.
#   4. Accompaniment chords are ignored.
#   5. > and < are ignored (but numeric lengths are honored.

sub abcCode {
	my($F) = "abcCode"; print "$F(\"@_\")\n" if $V>4;
	my($O) = shift;			# Object pointer
	my($K) = shift || '';	# Key, i.e., the tonic with some extra junk.
	my($L) = shift || '';	# Length, from L: line.
	my($M) = shift || '';	# Meter,  from L: line.
	if    ($M eq 'C'   ) {$M = '4/4'}	# Common time.
	elsif ($M eq 'C|'  ) {$M = '2/2'}	# Cut time.
	elsif ($M eq 'none') {$M = '4/4'}	# Kludge for free meter.
	elsif ($M =~ m"^([-+\d.])/(\d+)$") {}
	else  {$M = '1/4'}
	my($U) = $M || $L || '1/4';	# Unit length
	print "$F: K=\"$K\" L=\"$L\" M=\"$M U=\"$U\"\"\n" if $V>4;
	local $bars = 0;
	local($c,$x);
	$GBcode = $JCcode = $UDcode = $Pnote = $Cnote = $Used = '';
	$Length = $Cstep = $Pstep = 0;
	$Pval = undef;
	$K =~ s/(.).*/$1/;
	$M = '1/4' unless $M;
	$L = $M unless $L;
	$L =~ s/^\d+/1/;
	$U =~ s/^\d+/1/;
	print STDERR "$F: K=\"$K\" U=\"$U\" M=\"$M\"\n" if $V>4;
	for $x (@_) {								# One or more strings.
		print "$F: Line \"$x\"\n" if $V>5;
		while ($x) {
			last if (length($GBcode) >= $GBmax)
			     && (length($JCcode) >= $JCmax)
				 && (length($UDcode) >= $UDmax);
			print "$F: \"$x\"\n" if $V>5;
			if ($x =~ s/^[\r\s]+//) {
				print "$F: Skip space.\n" if $V>5;
#				$Used .= ' ' if $bars;
			} elsif ($x =~ s/^([\|:]+)//) {		# Bar lines.
				$Used .= '|';
				++$bars;
				print "$F: \"$1\" bar line.\n" if $V>3;
				$Length = 0;					# Discard any fractional beat.
			} elsif ($x =~ s/^("[^"]*")//) {	# Discard gchords.
				print "$F: Drop \"$1\" (gchord).\n" if $V>5;
			} elsif ($x =~ s"^\[([A-Ga-g])([,']*)([\d/]*)[^\]]\]"") {	# Chord
				next unless $bars > 0;
				print "$F: \"$x\"\n" if $V>6;
				$pitch  = $1;
				$octave = $2;
				$length = $3;
				$Used .= "$1$2$3";
				print "$F: pitch=\"$pitch\" octave=\"$octave\" length=\"$length\".\n" if $V>3;
				$c .= $O->abcNote($K,$U,$L,$pitch,$octave,$length);
			} elsif ($x =~ s"^([A-Ga-g])([,']*)([\d/]*)([<>]*)"") {	# Note
				next unless $bars > 0;
				print "$F: \"$x\"\n" if $V>6;
				$pitch  = $1;
				$octave = $2;
				$length = $3;
				$mult   = $4;
				$Used .= "$1$2$3";
				print "$F: pitch=\"$pitch\" octave=\"$octave\" length=\"$length\".\n" if $V>3;
				$c .= $O->abcNote($K,$U,$L,$pitch,$octave,$length);
			} elsif ($x =~ s/^({[^}]*})//) {	# Grace notes..
				print "$F: Comment \"$x\" ignored.\n" if $V>5;
			} elsif ($x =~ s/^\%\s*//) {		# Comments.
				print "$F: Comment \"$x\" ignored.\n" if $V>5;
				next;
			} else {
				$x =~ s"(.)"";
				print "$F: Char \"$1\" ignored.\n" if $V>5;
#				$Used .= $1 if $bars;
			}
		}
	}
	print "$F: Stop with UDcode=\"$UDcode\" JCcode=\"$JCcode\" GBcode=\"$GBcode\"\n" if $V>4;
	$GBcode = substr(($GBcode . ('_' x $GBmax)),0,$GBmax) if length($GBcode) > $GBmax;
	$JCcode = substr(($JCcode . ('_' x $JCmax)),0,$JCmax) if length($JCcode) > $JCmax;
	$UDcode = substr(($UDcode . ('_' x $UDmax)),0,$UDmax) if length($UDcode) > $UDmax;
	return ($GBcode,$JCcode,$UDcode,$Used);
}

my %abcvals = (''=>0,
	'C'=>1,'D'=>2,'E'=>3,'F'=>4,'G'=>5,'A'=>6,'B'=>7,'H'=>6,
	'c'=>8,'d'=>9,'e'=>10,'f'=>11,'g'=>12,'a'=>13,'b'=>14);
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
#   abcNote($O,$K,$U,$L,$N,$o,$D)
# This routine is called for each note encountered.  We add the  duration  to
# the  running total, and then clip off as many notes of length $U as we can,
# adding each to the growing $GBcode string.

sub abcNote {
	my($F) = "abcNote"; # $V = $main::V; print "$F(\"@_\")\n" if $V>4;
	my(	$O,			# Object.
		$Key,		# Key (tonic + mode)
		$Unit,		# Unit length for code calculations.
		$Len,		# Note length (from Len: line).
		$Note,		# Note (letter).
		$Octave,	# Octave (commas or apostrophes).
		$Dur)		# Duration (relative to $Len).
			= @_;
	my($Kstep);		# Note's step within current key.
	my($diff);		# Change of pitch from previous note.
	my($len);		# Note's length in Len: units.
	my($pval);		# Note's pitch relative to C.
	my($ties) = 0;	# Counter for long/tied notes.
	my($Tonic);		# Tonic note.
	my($left);
	if ($Key =~ /([A-Ga-g])/) {
		$Tonic = uc($1);	# Tonic should be upper case
	} elsif ($Key =~ /([Hh])/) {
		$Tonic = 'A';		# K:H and K:Hp use A for the nominal tonic
	} else {
		$Tonic = 'C';		# It might also be Am or Ddor or ...
	}
	print "$F: ----- Note=\"$Note\" Dur=\"$Dur\" Tonic=\"$Tonic\" Key=\"$Key\" Len=\"$Len\" Unit=\"$Unit\" \n" if $V>4;
	print "$F: Pnote=\"$Pnote\" Pstep=$Pstep Pval=$Pval Cnote=\"$Cnote\" Cstep=$Cstep Length=$Length.\n" if $V>4;
	$Dur =~ s"^/"1/";	# Canonicalize the duration.
	$Dur =~ s"/$"/2";
	while ($Dur =~ s"//(\d+)"'/'.($1*2)"e) {
		print "$F: Dur=\"$Dur\" \n" if $V>4;
	}
	$Dur = 1 unless $Dur;
	$len = $O->frmul($Dur,$Len);				# Convert to absolute length.
	print "$F: dur=\"$Dur\" len=\"$len\" Tonic=\"$Tonic\"\n" if $V>5;
	$Cstep = $pval = $abcvals{$Cnote = $Note};	# Current scale step.
	while ($Octave =~ s/,//) {$pval -= 7}
	while ($Octave =~ s/'//) {$pval += 7}
	print "$F: Cnote=\"$Cnote\" Cstep=\"$Cstep Pnote=\"$Pnote\" Pstep=\"$Pstep\" pval=$pval.\n" if $V>5;
	if (defined $Pval) {
		$diff = $pval - $Pval;
		$udcode = ($diff < 0) ? 'd' : ($diff > 0) ? 'u' : '';
		$UDcode .= $udcode;
		print "$F: pval=$pval Pval=$Pval diff=$diff udcode='$udcode' UDcode=\"$UDcode\"\n" if $V>2;
	}
	$Pval = $pval;
	if (eval($Length) == 0) {
		print "$F: First note in beat.\n" if $V>5;
		$O->putNote($Cnote,$Cstep,$Tonic);
	}
	$Length = $O->fradd($Length,$len);
	print "$F: Length=\"$Length\" accumulated since last beat.\n" if $V>5;
	while (($left = eval($Length)) >= eval($Unit)) {
		print "$F: Length=\"$Length\" contains a $Unit beat.\n" if $V>5;
		$Length = $O->fradd($Length,"-$Unit");
		print "$F: Length adjusted to\"$Length\".\n" if $V>5;
		if (eval($Length) > 0) {
			print "$F: Length $Length starts new beat.\n" if $V>5;
			$O->putNote($Cnote,$Cstep,$Tonic);
		}
	}
	print "$F: $Length left.\n" if $V>5;
	$Cstep;
}

sub putNote { my($F) = "putNote"; print "$F(" . join(',',@_) . ")\n" if $V>4;
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
# Add one note to the code string(s).
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
	my($O) = shift;
	my($cnote,$cstep,$tonic) = @_;
	my($diff);		# Offset from previous note to current note.
	$tonic = 'C' unless $tonic;
	print "$F: cnote=\"$cnote\" cstep=\"$cstep\" tonic=$tonic.\n" if $V>4;
	unless (defined $abcvals{$tonic}) {
		print "$F: ### No abcval for '$tonic'\n" if $V>0;
		$tonic = 'C';
	}
	$kstep = $cstep - $abcvals{$tonic} + 1;	# Current step within key.
	$kstep += 7 while $kstep < 1;	# Adjust to [1,7]
	$kstep -= 7 while $kstep > 7;
	if ($Pnote) {
		print "$F: Calculate change from previous note Pnote=\"$Pnote\" Pstep=$Pstep.\n" if $V>5;
		print "$F: diff=$diff JCcode=\"$JCcode\" GBcode=\"$GBcode\"\n" if $V>4;
		$diff = $cstep - $Pstep;
		$diff += 8 while $diff < 0;	# Adjust to [0,7]
		$diff -= 8 while $diff > 7;
		$JCcode .= $diff;
		print "$F: diff=$diff JCcode=\"$JCcode\" GBcode=\"$GBcode\"\n" if $V>4;
	}
	$GBcode .= $kstep;		# Gore-Breathnach code.

	$Pnote = $cnote;
	$Pstep = $cstep;
	print "$F: Pnote=\"$Pnote\" Pstep=\"$Pstep\" Length=$Length JCcode=\"$JCcode\" GBcode=\"$GBcode\"\n" if $V>4;
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
# Fraction adder.  We accept any number of args  and  return  the  sum  as  a
# fraction.   The  args may be integers or fractions.  This currently doesn't
# give sensible results for negative denominators.  If there are no args,  we
# return "0/1".  We don't remove common factors in the result.

sub fradd {
	my($F) = "fradd"; print "$F(\"@_\")\n" if $V>6;
	my($O) = shift;
	my($N) = '0';
	my($D) = '1';
	my($a,$m,$M,$n,$d);
loop:
	for $a (@_) {
		print "$F: N=\"$N\" D=\"$D\" a=\"$a\".\n" if $V>7;
		if (($n,$d) = ($a =~ m"^(-*\d+)/(\d+)$")) {
		} elsif ($a =~ m"^(-*\d+)") {
			$n = $a + 0; $d = 1;
		} else {
			print STDERR "$F: \"$a\" not a number.\n" if $V>0;
		#	$n = 0; $d = 1;
			next loop;
		}
		print "$F: N=\"$N\" D=\"$D\" n=\"$n\" d=\"$d\"\n" if $V>7;
		if ($d != $D) {
			my($gcd) = $O->GCD($d,$D) || 1;
			print "$F: N=\"$N\" D=\"$D\" n=\"$n\" d=\"$d\" gcd=\"$gcd\"\n" if $V>7;
			$m = $d / $gcd; $M = $D / $gcd;
			$N *= $m; $D *= $m;
			$n *= $M; $d *= $M;
			print "$F: N=\"$N\" D=\"$D\" n=\"$n\" d=\"$d\" M=$M m=$m.\n" if $V>7;
		}
		$N += $n;
		print "$F: N=\"$N\" D=\"$D\".\n" if $V>7;
	}
	return "$N/$D";
}

sub frmul {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
# Fraction multiplier. We accept any number of args and return the product as #
# a  fraction.  Numerators and denominators can be negative.  If there are no #
# args, we return "1/1".  We don't remove common factors in the result.       #
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
	my($F) = "frmul"; print "$F(\"@_\")\n" if $V>6;
	my($O) = shift;
	my($N) = '1';
	my($D) = '1';
	my($n,$d);
loop:
	for $a (@_) {
		print "$F: N=\"$N\" D=\"$D\" a=\"$a\".\n" if $V>7;
		if ($a =~ m"^(-*\d+)/(-*\d+)$") {
			$n = int($1);	# Numerator
			$d = int($2);	# Denominator
		} elsif ($a =~ m"^(-*\d*)") {
			$n = int($1);
			$d = 1;
		} else {
			print STDERR "$F: \"$a\" not a number.\n" if $V>0;
		#	$n = 1; $d = 1;
			next loop;
		}
		print "$F: N=\"$N\" D=\"$D\" n=\"$n\" d=\"$d\"\n" if $V>7;
		$N *= $n;
		$D *= $d;
		print "$F: N=\"$N\" D=\"$D\".\n" if $V>7;
	}
	return "$N/$D";
}

sub GCD {my $F = "GCD";
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
# Euclid's algorithm to calculate GCD(X,Y).  It's faster with X>Y, but either #
# order will work.  X and Y should be integers. Note that we always return an #
# integer > 0, so it's safe to use the result as a divisor.                   #
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
	print "$F(\"" . join(',',@_) . "\")\n" if $V>7;
	my($O,$X,$Y) = @_;
	return 1 unless ($X = int($X)) && ($Y = int($Y));
	return $X if ($X == $Y);
	return $O->GCD($Y,$X) if $X < $Y;
	my($R) = $X % $Y;
	return $Y unless $R;
	return $O->GCD($Y,$R);
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #

sub foo {
	my($F) = "foo"; # $V = $main::V; print "$F(\"@_\")\n" if $V>4;
	my($O) = shift;
}

1;