# An attempt to bring that chord-stuff into an Apache Perl module
#
# 9 Jan 01   Erich Rickheit KSC     Created
#
package chord::chr;
use Apache::Constants qw(:common);
use strict;

# hack
my $uval = 0;

# where are GIFs located?
my $imgdir = '/~rickheit/chord';

# external program to generate chords
my $chordprog = "/home/rickheit/public_html/chord/ch/ch";

# intervals between degrees of the scale
my @intervals = qw(0 2 4 5 7 9 11 12 14 16 17 19 21 23 24 26 28 29 31 33 35 36);

# names of the clasical modes, in order
my @modes = qw(Ionian Dorian Phrygian Lydian Myxolydian Aeolian Locrian);

# note names users can enter
my @unotes = qw(x A B C D E F G A# B# C# D# E# F# G# Ab Bb Cb Db Eb Fb Gb);

# map note names to numeric values
my %nval = ( C => 0, D => 2, E => 4, F => 5, G => 7, A => 9, B => 11 );

# intervals in each chord
my @chords = (
  [ '',        [ 4, 7 ] ],
  [ 'm',       [ 3, 7 ] ],
  [ '+',       [ 4, 8 ] ],
  [ 'mb5',     [ 3, 6 ] ],
  [ '7',       [ 4, 7, 10 ] ],
  [ 'maj7',    [ 4, 7, 11 ] ],
  [ 'm7',      [ 3, 7, 10 ] ],
  [ 'm(maj7)', [ 3, 7, 11 ] ],
  [ 'm7b5',    [ 3, 6, 10 ] ],
  [ 'dim',     [ 3, 6, 9 ] ],
  [ 'sus',     [ 5, 7 ] ],
);

# 'standard' chord patterns
my %basic_chords =
(
  '[0]'         => [ qw(x 3 2 0 1 0 1) ],
  '[0]+'        => [ qw(x x 2 1 1 0 1) ],
  '[0]7'        => [ qw(0 3 2 3 1 0 1) ],
  '[0]dim'      => [ qw(x x 1 2 1 2 1) ],
  '[0]m'        => [ qw(x 1 3 3 2 1 3) ],
  '[0]m(maj7)'  => [ qw(1 1 3 2 2 1 3) ],
  '[0]m7'       => [ qw(x 1 3 1 2 1 3) ],
  '[0]m7b5'     => [ qw(x x 2 2 1 2 7) ],
  '[0]maj7'     => [ qw(x 3 2 0 0 0 1) ],
  '[0]mb5'      => [ qw(x x 3 4 3 1 2) ],
  '[0]sus'      => [ qw(x x 3 0 1 3 1) ],
  '[1]'         => [ qw(x x 3 1 2 1 1) ],
  '[1]+'        => [ qw(x x 3 2 2 1 1) ],
  '[1]7'        => [ qw(x x 3 4 2 4 1) ],
  '[1]dim'      => [ qw(x x 2 3 2 3 1) ],
  '[1]m'        => [ qw(x x 2 1 2 0 1) ],
  '[1]m(maj7)'  => [ qw(1 1 3 2 2 1 4) ],
  '[1]m7'       => [ qw(x x 2 4 2 4 1) ],
  '[1]m7b5'     => [ qw(0 4 2 0 0 0 1) ],
  '[1]maj7'     => [ qw(x 4 3 1 1 1 1) ],
  '[1]mb5'      => [ qw(0 4 2 0 2 0 1) ],
  '[1]sus'      => [ qw(x x 3 3 4 1 4) ],
  '[2]'         => [ qw(x x 0 2 3 2 1) ],
  '[2]+'        => [ qw(x x 0 3 3 2 1) ],
  '[2]7'        => [ qw(x x 0 2 1 2 1) ],
  '[2]dim'      => [ qw(x x 0 1 0 1 1) ],
  '[2]m'        => [ qw(x x 0 2 3 1 1) ],
  '[2]m(maj7)'  => [ qw(x 4 0 2 3 1 1) ],
  '[2]m7'       => [ qw(x x 0 2 1 1 1) ],
  '[2]m7b5'     => [ qw(x 3 0 1 1 1 1) ],
  '[2]maj7'     => [ qw(x x 0 2 2 2 1) ],
  '[2]mb5'      => [ qw(x x 0 1 3 1 1) ],
  '[2]sus'      => [ qw(x x 0 2 3 3 1) ],
  '[3]'         => [ qw(x x 3 1 2 1 3) ],
  '[3]+'        => [ qw(x x 1 0 0 4 1) ],
  '[3]7'        => [ qw(x x 1 3 2 3 1) ],
  '[3]dim'      => [ qw(x x 1 2 1 2 1) ],
  '[3]m'        => [ qw(x x 4 3 4 2 1) ],
  '[3]m(maj7)'  => [ qw(x 4 0 2 3 1 2) ],
  '[3]m7'       => [ qw(x x 1 3 2 2 1) ],
  '[3]m7b5'     => [ qw(x 0 1 2 2 2 1) ],
  '[3]maj7'     => [ qw(x x 1 3 3 3 1) ],
  '[3]mb5'      => [ qw(x 0 1 2 4 2 1) ],
  '[3]sus'      => [ qw(x x 1 3 4 4 1) ],
  '[4]'         => [ qw(0 2 2 1 0 0 1) ],
  '[4]+'        => [ qw(x x 2 1 1 0 1) ],
  '[4]7'        => [ qw(0 2 2 1 3 0 1) ],
  '[4]dim'      => [ qw(x x 2 3 2 3 1) ],
  '[4]m'        => [ qw(0 2 2 0 0 0 1) ],
  '[4]m(maj7)'  => [ qw(0 2 1 0 0 0 1) ],
  '[4]m7'       => [ qw(0 2 2 0 3 0 1) ],
  '[4]m7b5'     => [ qw(0 1 0 0 3 0 1) ],
  '[4]maj7'     => [ qw(0 2 1 1 0 x 1) ],
  '[4]mb5'      => [ qw(x x 1 2 4 2 2) ],
  '[4]sus'      => [ qw(0 2 2 2 0 0 1) ],
  '[5]'         => [ qw(1 3 3 2 1 1 1) ],
  '[5]+'        => [ qw(x x 3 2 2 1 1) ],
  '[5]7'        => [ qw(1 3 1 2 1 1 1) ],
  '[5]dim'      => [ qw(x x 0 1 0 1 1) ],
  '[5]m'        => [ qw(1 3 3 1 1 1 1) ],
  '[5]m(maj7)'  => [ qw(0 3 3 1 1 1 1) ],
  '[5]m7'       => [ qw(1 3 1 1 1 1 1) ],
  '[5]m7b5'     => [ qw(1 2 1 1 4 1 1) ],
  '[5]maj7'     => [ qw(x 3 3 2 1 0 1) ],
  '[5]mb5'      => [ qw(x x 3 1 3 1 4) ],
  '[5]sus'      => [ qw(x x 3 3 1 1 1) ],
  '[6]'         => [ qw(2 4 4 3 2 2 1) ],
  '[6]+'        => [ qw(x x 4 3 3 2 1) ],
  '[6]7'        => [ qw(x x 4 3 2 0 1) ],
  '[6]dim'      => [ qw(x x 1 2 1 2 1) ],
  '[6]m'        => [ qw(2 4 4 2 2 2 1) ],
  '[6]m(maj7)'  => [ qw(x 0 3 2 2 2 1) ],
  '[6]m7'       => [ qw(x x 2 2 2 2 1) ],
  '[6]m7b5'     => [ qw(0 0 4 2 1 0 1) ],
  '[6]maj7'     => [ qw(x x 4 3 2 1 1) ],
  '[6]mb5'      => [ qw(x 0 3 1 3 4 5) ],
  '[6]sus'      => [ qw(x x 4 4 2 2 1) ],
  '[7]'         => [ qw(3 2 0 0 0 3 1) ],
  '[7]+'        => [ qw(x x 1 0 0 4 1) ],
  '[7]7'        => [ qw(3 2 0 0 0 1 1) ],
  '[7]dim'      => [ qw(x x 2 3 2 3 1) ],
  '[7]m'        => [ qw(1 3 3 1 1 1 3) ],
  '[7]m(maj7)'  => [ qw(2 1 0 0 3 3 1) ],
  '[7]m7'       => [ qw(1 3 1 1 1 1 3) ],
  '[7]m7b5'     => [ qw(x x 1 2 2 2 5) ],
  '[7]maj7'     => [ qw(x x 4 3 2 1 2) ],
  '[7]mb5'      => [ qw(x x 3 1 3 1 6) ],
  '[7]sus'      => [ qw(x x 0 0 1 3 1) ],
  '[8]'         => [ qw(1 3 3 2 1 1 4) ],
  '[8]+'        => [ qw(x x 2 1 1 0 1) ],
  '[8]7'        => [ qw(x x 1 1 1 2 1) ],
  '[8]dim'      => [ qw(x x 0 1 0 1 1) ],
  '[8]m'        => [ qw(1 3 3 1 1 1 4) ],
  '[8]m(maj7)'  => [ qw(4 2 1 0 0 4 1) ],
  '[8]m7'       => [ qw(x x 1 1 1 1 4) ],
  '[8]m7b5'     => [ qw(x x 1 2 2 2 6) ],
  '[8]maj7'     => [ qw(x x 1 1 1 3 1) ],
  '[8]mb5'      => [ qw(4 2 0 1 0 4 1) ],
  '[8]sus'      => [ qw(x x 1 1 2 4 1) ],
  '[9]'         => [ qw(x 0 2 2 2 0 1) ],
  '[9]+'        => [ qw(x 0 3 2 2 1 1) ],
  '[9]7'        => [ qw(x 0 2 0 2 0 1) ],
  '[9]dim'      => [ qw(x x 1 2 1 2 1) ],
  '[9]m'        => [ qw(x 0 2 2 1 0 1) ],
  '[9]m(maj7)'  => [ qw(0 0 2 1 1 0 1) ],
  '[9]m7'       => [ qw(x 0 2 2 1 3 1) ],
  '[9]m7b5'     => [ qw(x 0 3 3 2 1 3) ],
  '[9]maj7'     => [ qw(x 0 2 1 2 0 1) ],
  '[9]mb5'      => [ qw(x 0 4 2 1 2 4) ],
  '[9]sus'      => [ qw(x x 2 2 3 0 1) ],
  '[10]'        => [ qw(x 1 3 3 3 1 1) ],
  '[10]+'       => [ qw(x x 0 3 3 2 1) ],
  '[10]7'       => [ qw(x x 1 1 1 2 3) ],
  '[10]dim'     => [ qw(x x 2 3 2 3 1) ],
  '[10]m'       => [ qw(x 1 3 3 2 1 1) ],
  '[10]m(maj7)' => [ qw(1 1 3 2 2 1 1) ],
  '[10]m7'      => [ qw(x 1 3 1 2 1 1) ],
  '[10]m7b5'    => [ qw(x x 1 2 2 2 8) ],
  '[10]maj7'    => [ qw(x 1 3 2 3 x 1) ],
  '[10]mb5'     => [ qw(0 1 2 3 2 0 1) ],
  '[10]sus'     => [ qw(x x 3 3 4 1 1) ],
  '[11]'        => [ qw(x 2 4 4 4 2 1) ],
  '[11]+'       => [ qw(x x 1 0 0 4 1) ],
  '[11]7'       => [ qw(0 2 1 2 0 2 1) ],
  '[11]dim'     => [ qw(x x 0 1 0 1 1) ],
  '[11]m'       => [ qw(x 2 4 4 3 2 1) ],
  '[11]m(maj7)' => [ qw(2 2 4 3 3 2 1) ],
  '[11]m7'      => [ qw(x 1 3 1 2 1 2) ],
  '[11]m7b5'    => [ qw(1 0 0 2 0 1 1) ],
  '[11]maj7'    => [ qw(x 2 4 3 4 x 1) ],
  '[11]mb5'     => [ qw(1 2 0 4 0 1 1) ],
  '[11]sus'     => [ qw(x x 3 3 4 1 2) ],
);

sub modal
{ my ($r) = @_;
  my (%arg, $count, $res, $modelist, $keylist, @name, $prog);

  # fetch CGI-style arguments
  %arg = $r->args;
  %arg = $r->content unless %arg;
  $prog = $r->uri;

  # generate the form elements
  $count = 0;
  for (@modes)
  {
    $modelist .= qq(<OPTION VALUE="$count");
    $modelist .= " SELECTED" if $arg{mode} == $count;
    $modelist .= ">$_";
    $count++;
  }

  for (@unotes)
  {
    next if /x/;
    $keylist .= qq(<OPTION);
    $keylist .= " SELECTED" if $arg{key} eq $_;
    $keylist .= ">$_";
  }

  # try to generate some results
  if ($arg{key})
  { my ($i, @interval, $key, $let, $degree, @scale, @chlist);
    my ($deg0, $deg3, $deg4);

    $res = "<HR>\n";

    # find the correct list of intervals for this mode
    for $i (0..14)
    {
      push @interval, $intervals[$arg{mode}+$i] - $intervals[$arg{mode}];
    }

    # numeric value of the key name
    if ($arg{key} =~ /([A-G])([#b])?/)
    {
      $let = $1;
      $key = $nval{$let};
      $key++ if $2 eq '#';
      $key-- if $2 eq 'b';
      $key += 12 while $key < 0;
      $key -= 12 while $key > 11;
    }

    # find the chords at each degree of the mode
    for $degree (0..6)
    { my ($val, $aval, $acc, $chord);

      # what's the name of the note at this degree?
      $val = ($key + $interval[$degree])%12;

      # we know what that note unmodified is..
      $aval = $val - $nval{$let};

      # and we know we'll never see more than 3 sharps or flats, so normalize
      $aval -= 12 while $aval > 3;
      $acc = '#' x  $aval if $aval > 0; 
      $acc = 'b' x -$aval if $aval < 0; 

      push @scale, "$let$acc";
      $name[$val] = "$let$acc";

      for $chord (@chords)
      { my ($ivs, $found);

	$ivs = $$chord[1];
	$found = 1;
	for $i (@$ivs)
	{ my ($n);

	  $n = $i + $interval[$degree];
	  unless (grep { $_ == $n } @interval)
	    { $found = 0; last; }
	}
	if ($found)
	{ my ($nm);

	  $nm = "[$val]$$chord[0]";
	  if    ($degree == 0 && ! $deg0) { $deg0 = $nm; }
	  elsif ($degree == 3 && ! $deg3) { $deg3 = $nm; }
	  elsif ($degree == 4 && ! $deg4) { $deg4 = $nm; }
	  else  { push @chlist, $nm; }
	}
      }

      $let++; if ($let gt 'G') { $let = 'A'; }
    }

    $res .= "<H3>$arg{key} $modes[$arg{mode}] scale (@scale)</H3>\n";
    $res .= "This progression should cover the entire scale:\n<TABLE><TR>";
    $res .= &dchord($deg0, @name);
    $res .= &dchord($deg3, @name);
    $res .= &dchord($deg4, @name);
    $res .= "</TR></TABLE>\n";
    $res .= "<P>These other chords should also be in harmony:\n<TABLE><TR>";

    $count = 0;
    for $i (@chlist)
    {
      $count++;
      if ($count == 1) { $res .= "<TR>\n"; }
      $res .= &dchord($i, @name);
      if ($count == 8) { $count = 0; $res .= "</TR>\n"; }
    }
    if ($count) { $res .= "</TR>\n"; }
    $res .= "</TABLE>\n";
    $res .= "<P>Choose a chord name to find other voicings for that chord.\n";
  }

  # emit the page
  $r->content_type('text/html');
  $r->send_http_header;
  $r->print(<<EOF);
<HTML><HEAD><TITLE>Modal-matic</TITLE></HEAD>
<BODY><CENTER>
<H3>The Modal-matic</H3>
This program attempts to find guitar chords and chord progressions
within a given mode.

<FORM METHOD=POST ACTION="$prog">
Key: <SELECT NAME="key">$keylist</SELECT>
Mode: <SELECT NAME="mode">$modelist</SELECT>
<INPUT TYPE=SUBMIT VALUE=" Find Chords ">
</FORM>
$res
</CENTER></BODY></HTML>
EOF

  return OK;
}

# display a single chord
sub dchord
{ my ($cn, @name) = @_;
  my (@arr, $fret, $buf, $n, $fcn);

  @arr =  @{$basic_chords{$cn}};
  $fret = pop @arr;

  $cn =~ s/\[(\d+)\]/$name[$1]/e;
  ($fcn = $cn) =~ s/#/%23/g;
  $fret = '' if $fret <= 1;

  $n = shift @arr;
  $buf .= qq(<TD ALIGN=CENTER><A HREF="chord?chord=$fcn">$cn</A><BR>\n);
  $buf .= qq($fret<IMG ALIGN=TOP SRC="$imgdir/ch${n}l.gif">);
  while (@arr > 1)
  {
    $n = shift @arr;
    $buf .= qq(<IMG ALIGN=TOP SRC="$imgdir/ch${n}m.gif">);
  }
  $n = shift @arr;
  $buf .= qq(<IMG ALIGN=TOP SRC="$imgdir/ch${n}r.gif">\n</TD>\n);

  return $buf;
}


sub chord
{ my ($r) = @_;
  my (%arg, $prog, @strings, $i, @svals, $res, $slist);

  # fetch CGI-style arguments
  %arg = $r->args;
  %arg = $r->content unless %arg;
  $prog = $r->uri;

  # collect string names
  if ($arg{s1})
  {
    for $i (0..5)
      { push @strings, $arg{"s$i"} unless $arg{"s$i"} eq 'x'; }
  }
  else
  {
    @strings = qw(E A D G B E);
  }

  # build our list of string pulldowns
  for $i (0..5)
  { my ($s, $buf);

    $s = shift @strings || 'x';
    $buf = qq(<SELECT NAME="s$i">);
    for (@unotes)
    {
      $buf .= "<OPTION";
      $buf .= " SELECTED" if $s eq $_;
      $buf .= ">$_";
    }
    $buf .= qq(</SELECT>\n);
    $slist .= $buf;
    push @svals, $s unless $s eq 'x';
  }

  # do we have a chord to figure?
  if ($arg{chord})
  { my ($l, @lines, $fname, $count, $name, $fret, $n);

    $res = "<HR><TABLE>\n";
    $fname = ++$uval;
    $fname = "/tmp/chr.$$.$fname";
    open(PR, "|$chordprog -r4 -i3 -p4 -t @svals . > $fname");
    print PR "$arg{chord}\n";
    close(PR);
    open(IN, $fname);
    while (<IN>)
    {
      push @lines, [ split ];
    }
    close(IN);
    unlink $fname;

    # sort those voicings by base fret
    @lines = sort { $$a[$#$a] <=> $$b[$#$b] } @lines;

    while ($l = shift @lines)
    {
      $count++;
      if ($count == 1) { $res .= "<TR>\n"; }
      $name = shift @$l; $fret = pop @$l;
      $fret = '' if $fret < 2;
      $n = shift @$l;
      $res .= qq(<TD ALIGN=CENTER>$name<BR>\n);
      $res .= qq($fret<IMG ALIGN=TOP SRC="$imgdir/ch${n}l.gif">);
      while (@$l > 1)
      {
	$n = shift @$l;
	$res .= qq(<IMG ALIGN=TOP SRC="$imgdir/ch${n}m.gif">);
      }
      $n = shift @$l;
      $res .= qq(<IMG ALIGN=TOP SRC="$imgdir/ch${n}r.gif">\n</TD>\n);
      if ($count == 8) { $count = 0; $res .= "</TR>\n"; }
    }
    if ($count) { $res .= "</TR>\n"; }
    $res .= "</TABLE>\n";
  }

  # generate the page
  $r->content_type('text/html');
  $r->send_http_header;
  $r->print(<<EOF);
<HTML><HEAD><TITLE>Chord Voicings</TITLE></HEAD>
<BODY><CENTER>
<H3>Chord Voicings</H3>
This program attempts to find all the possible voicings of a given
chord, within limits I hope are reasonable. Not all the chords it finds
may be playable; its knowledge of the anatomy of the hand is limited
to the number of fingers (4) and the number of frets one can easily
reach (4). Also, the chord parser is probably incomplete, but it should
recognize things like 'Am', or 'Edim7' or 'C#/D' or 'A add 7' or 'C6/9'
adequately. You can choose an alternate tuning, or find chords for different
instruments.

<FORM METHOD=POST ACTION="$prog">
Chord to find: <INPUT NAME="chord" VALUE="$arg{chord}"><BR>
Choose an alternate tuning:<BR>
$slist<BR>
<INPUT TYPE=SUBMIT VALUE=" Find Voicings ">
</FORM>
$res
</CENTER></BODY></HTML>
EOF
}

1;