#!/usr/bin/perl -w

# Copyright (c) 2010 Jim Peters (http://uazu.net)

# TODO: 
# 
# add naturals in chromatic scales
# 
# generate exercises:
#
# - Up2/Up2/... arpeggios from the scales

$OCAR = $ARGV[0];
die "Bad ocarina name: $OCAR" 
    unless $OCAR eq 'C' || $OCAR eq 'G';
$OUT = $ARGV[1];
die "Bad output directory: $OUT" 
    unless -d $OUT;


@set = (0..11);

%hole = ( '*' => "",
	  0 => "3-1;",
	  1 => "2-1;",
	  2 => "2-2;",
	  3 => "2-3;",
	  4 => "2-4;",
	  5 => "3-2;",
	  6 => "3-3;",
	  7 => "3-4;",
	  8 => "1-5;",
	  9 => "4-5;" );

@fingerings = ( [ "0123456789", ],
		[ "123456789", ],
		[ "12456789", ], ## "*023456789", ],
		[ "23456789", ],
		[ "2456789", "*12356789", ],
		[ "3456789", ],
		[ "456789", ],
		[ "356789", ],
		[ "56789", ],
		[ "26789", ],
		[ "6789", ],
		[ ($OCAR eq 'C' ? "4789" : "2789"), ],  # Different B-flat for C or G ocarina
		## [ "4789", "*689", "*2789", ],
		[ "789", ],
		[ "89", ],
		[ "79", ],
		[ "9", ],
		[ "7", ],
		[ "", ]);

sub fret_diag {
    my $holes = shift;
    my $rv = ("\\fret-diagram #\"w:4;h:6;p:1;");
    $rv .= $hole{$_}
        for (split(//, $holes));
    return "$rv\"";
}

sub holes_distance {
    my $holes1 = shift;
    my $holes2 = shift;
    my $cnt1 = 0;
    my $cnt2 = 0;
    for (split(//, $holes1)) {
	next if $_ eq '*';
	$cnt1++ if (-1 == index($holes2, $_));
    }
    for (split(//, $holes2)) {
	next if $_ eq '*';
	$cnt2++ if (-1 == index($holes1, $_));
    }

    # Add 1 extra if have to release and press-down in the same
    # change, as this is a harder switch to get right
    return $cnt1 if ($cnt2 == 0);
    return $cnt2 if ($cnt1 == 0);
    return $cnt1 + $cnt2 + 1;
}

sub calc_mean_change {
    my $prev = (shift)->[2];
    my $total = 0;
    my $cnt = 0;
    for (@_) {
	my $curr = $_->[2];
	$total += holes_distance($prev, $curr);
	$prev = $curr;
	$cnt++;
    }
    return $total/$cnt;
}

$key_notes = "c#d&ef#g&a&b";
$cromatic_scale_base = "011223345566";

# Generate a scale.  Return value is a list of
# pitches/notes/fingerings from bottom to top.  Each is a nested
# array, as for example: [ 0, "b", "0123456789" ].
#
sub gen_scale {
    my $base = shift;
    my $scale = shift;

    my $key = ($base + 11) % 12;
    my $keynote = substr($key_notes, $key, 1);
    $keynote = substr($key_notes, $key-1, 1) if $keynote eq '#';
    $keynote = substr($key_notes, $key+1, 1) if $keynote eq '&';
    my @keynotes = ();
    push @keynotes, chr((ord($keynote) - ord('a') + $_) % 7 + ord('a'))
	for (0..6);

    my @pit2ind = ();
    my @ind2pit = ();
    for (0..11) {
	push @pit2ind, scalar(@ind2pit);
	push @ind2pit, $_
	    if ("1" eq substr($scale, $_, 1));
    }

    my @notes = ();
    for (@ind2pit) {
	my $base_letter = $keynotes[substr($cromatic_scale_base, $_, 1)];
	my $base_letter_pitch = index($key_notes, $base_letter);
	my $pitch = ($_ + $base + 11) % 12;
	my $note = $base_letter;

	while (($pitch - $base_letter_pitch + 18) % 12 - 6 > 0) {
	    $pitch--;
	    $note .= "is";
	}
	while (($pitch - $base_letter_pitch + 18) % 12 - 6 < 0) {
	    $pitch++;
	    $note .= "es";
	}
	push @notes, $note;
    }

    my @fing = ();
    my @fingcnt = ();
    my @fingind = ();
    for (0..17) {
	if ('1' ne substr($scale, ($_-$base + 24) % 12, 1)) {
	    push @fing, [ "XXX", ];
	    push @fingcnt, 1;
	    push @fingind, 0;
	} else {
	    my $fing = $fingerings[$_];
	    push @fing, $fing;
	    push @fingcnt, 1 + $#{$fing};
	    push @fingind, 0;
	}
    }
    # Search for fingerings that give smallest changes
    my @minfingind = ();
    my $minfingdist = 9999999999;
  outer:
    while (1) {
	my $dist = 0;
	my $prev = undef;
	for (0..17) {
	    next if "XXX" eq $fing[$_]->[0];
	    my $curr = $fing[$_]->[$fingind[$_]];
	    $dist += holes_distance($prev, $curr)
		if defined $prev;
	    $prev = $curr;
	}
	#print ("  Distance: $dist for (", join(", ", grep { defined($_) } map { $fingcnt[$_] > 1 ? $fingind[$_] : undef } (0..17)), ")\n");
	if ($dist < $minfingdist) {
	    $minfingdist = $dist;
	    @minfingind = @fingind;
	}
	for (0..18) {
	    last outer if ($_ == 18);
	    $fingind[$_]++;
	    last if ($fingind[$_] < $fingcnt[$_]);
	    $fingind[$_] = 0;
	}
    }
    my $dump = 0;
    for (0..17) {
	next unless defined $fing[$_];
	$fing[$_] = $fing[$_]->[$minfingind[$_]];
	#$dump = 1 if 0 != $minfingind[$_];
    }

    my @rv = ();
    for (0..17) {
	my $off = ($_-$base+24) % 12;
	next unless '1' eq substr($scale, $off, 1);
	my $ind = $pit2ind[$off];
	my $oct = $notes[$ind] eq 'bis' ?
	    ($_ < 13 ? "" : "'") :
	    $notes[$ind] eq 'ces' ? 
	    ($_ < 1 ? "'" : "''") :
	    ($_ < 1 ? "" : $_ < 13 ? "'" : "''");
	push @rv, [ $_, $notes[$ind] . $oct, $fing[$_] ];
	print "$_, $notes[$ind]$oct, $fing[$_]\n" if $dump;
    }
    print "\n" if $dump;
    return @rv;
}

sub score_header {
    my @out = ();
    my $count = shift;
    my $ragged = 0;
    my $title = shift;

    if (defined $title && $title eq 'RAGGED') {
	$ragged = 1;
	$title = shift;
    }

    push @out, '\score { ';
    push @out, "  << \\context Staff = \"melody\" \\scale$count >>";
    if (defined $title) {
	push @out, '  \header{';
	push @out, '    piece = \markup  { "' . $title . '" }';
	push @out, '  }';
    }
    push @out, '  \layout {';
    push @out, '    indent = 0\cm';
    push @out, '    ragged-right = ##t' if ($ragged);
    push @out, '    \context { \Score';
    push @out, '      \override SpacingSpanner';
    push @out, "        #'base-shortest-duration = #(ly:make-moment 1 8)";
    push @out, '      \override TimeSignature';
    push @out, "        #'transparent = ##t";
    push @out, '    }';
    push @out, '    \context { \Staff';
    #push @out, '      whichBar = #""';
    push @out, '      \remove "Time_signature_engraver"';
    push @out, '    }';
    push @out, '  }';
    push @out, '}';
    return @out;
}

sub slur_from {
    my $N = shift;
    return [ $N->[0], $N->[1] . '(', $N->[2] ];
}
sub slur_to {
    my $N = shift;
    return [ $N->[0], $N->[1] . ')', $N->[2] ];
}

sub add_length {
    my $note = shift;
    my $len = shift;
    return "$1$len$2"
	if ($note =~ /^(.*?)([()])$/);
    return "$note$len";
}

# draw_note([$x, $note, $fing]) 
sub draw_note {
    my @out = ();

    # Ornamentation
    if (@_ > 1) {
	my $note = (shift)->[1];
	push @out, '\acciaccatura { ' . add_length($note, '16');
	if (@_ > 1) {
	    push @out, '[';
	    push @out, (shift)->[1]
		while (@_ > 1);
	    push @out, ']';
	}
	push @out, '}';
    }

    my $arr = shift;
    my $note = $arr->[1];
    my $fing = $arr->[2];
    push @out, "\\once \\override Voice.Stem #'length = #6.0" if ($note =~ /^g/);
    push @out, "\\once \\override Voice.Stem #'length = #5.0" if ($note =~ /^a/);
    push @out, add_length($note, '4') . "^\\markup " . fret_diag($fing);
    push @out, '\bar ""';
    return @out;
}

sub file_header {
    my $title = shift;
    my $diff = shift;
    my @out = ();
    push @out, "%%% Scales and arpeggios for Mountains Ocarina";
    push @out, "%%% generated by Jim Peters: http://uazu.net/";
    push @out, "%% Title: $title" if defined $title;
    push @out, "%% Diff: $diff" if defined $diff;
    push @out, '\version "2.10.33"';
    push @out, '\header{';
    push @out, '  tagline = ##f';
    push @out, '}';
    return @out;
}

sub voice_start {
    my @out = ();
    my $count = shift;
    push @out, "scale$count = " . '\new Voice { \time 1/4'; 
    push @out, "  #(set-accidental-style 'modern)";
    return @out;
}

sub voice_end {
    my @out = ();
    push @out, '\bar "||"';
    push @out, "}";
    return @out;
}

sub write_file {
    my $fnam = shift;
    my $arr = shift;
    die "Can't create file: $fnam"
	unless open OUT, ">$fnam";
    print OUT join("\n", @{$arr}, '');
    die "Error writing file: $fnam"
	unless close OUT;
}

sub note_after {
    my $note = shift;
    my $match = 0;
    for (@_) {
	return $_ if ($match);
	$match = ($note->[0] == $_->[0]);
    }
    return undef;
}

sub note_before {
    my $note = shift;
    my $rv = undef;
    for (@_) {
	return $rv if ($note->[0] == $_->[0]);
	$rv = $_;
    }
    return undef;
}

sub mordent {
    my $note = shift;
    my $other = shift;
    if (defined $other) {
	return draw_note($note, $other, $note);
    } 
    return draw_note($note);
}

sub turn {
    my $upper = shift;
    my $note = shift;
    my $lower = shift;
    if (defined $upper && defined $lower) {
	return draw_note($upper, $note, $lower, $note);
    } 
    return draw_note($note);
}

@scales = (
	   "101011010101 major Major scale",
	   "101101011001 harm-minor Harmonic Minor scale",
	   "101101010101/101101011010 mel-minor Melodic Minor scale",

	   "101010010100 major-penta Major Pentatonic scale",
	   "100101010010 minor-penta Minor Pentatonic scale (Shakuhachi)",
	   "101001010100 yo-penta Yo Pentatonic scale (Gagaku/Shomyo)",
	   "101010110110 acoustic Acoustic scale (Lydian dominant)",
	   "101010100110 prometheus Prometheus scale",

	   "101100111001 hungarian Hungarian Gypsy scale",
	   "101100111010 minor-gypsy Minor Gypsy scale",
	   "110011011001 byzantine Byzantine scale (Double Harmonic Major)",
	   "110011011010 phrygian-dom Spanish Gypsy scale (Phrygian Dominant)",
	   "110011101001 persian Persian scale",

	   "101011010111 dom-bebop Dominant Bebop scale",
	   "101011011101 major-bebop Major Bebop scale",
	   "101110010100 major-blues Major Blues scale",
	   "100101110010 minor-blues Minor Blues scale",

	   "111111111111 chromatic Chromatic scale",
	   "101010101010 wholetone Whole-tone scale",
	   "101101101101 diminished Diminished scale (whole-step-first)",
	   ###"110110110110 Diminished scale (half-step-first)",

	   "100010010000 major-arp Major arpeggio",
	   "100100010000 minor-arp Minor arpeggio",
	   "100010001000 aug-triad-arp Augmented triad arpeggio",
	   ###"100010100000 Diminished triad arpeggio",
	   "100010010010 dom-7-arp Dominant Seventh arpeggio",
	   "100100010010 min-7-arp Minor Seventh arpeggio",
	   "100100010001 min-maj-7-arp Minor Major Seventh arpeggio",
	   "100100100100 dim-7-arp Diminished Seventh arpeggio",
	   "100100100010 half-dim-7-arp Half-Diminished Seventh arpeggio",
	   );

$| = 1;

@base_name = qw(B C C-sharp D E-flat E F F-sharp G A-flat A B-flat);

my $count = "aaaa";
for my $base0 ("C-OCT", map { (1 + $_ * 7) % 12 } @set) {
    my $one_oct = $base0 eq "C-OCT"; 
    my $base = $one_oct ? 1 : $base0;
    my $base_name = $one_oct ? "One-octave C" : $base_name[$base];
    my $base_fnam = "$OUT/$OCAR" . ($one_oct ? "99" : sprintf("%02d", ($base0+11)%12));
    my $ncnt = -1;
    for my $spec (@scales) {
	$ncnt++;
	for my $ex (0..4) {
	    $spec =~ /^(.*?) (.*?) (.*)$/;
	    my $scale1 = $1;
	    my $scale2 = $1;
	    my $fnam = sprintf("%s%02d%02d-%s.ly", $base_fnam, $ncnt, $ex, $2);
		
	    my $title = $base_name . " " . $3 . ($ex ? " Exercises" : "");
	    print "=== $title\e[K\r";
	    if ($scale1 =~ m|(.*)/(.*)|) {
		$scale1 = $1;
		$scale2 = $2;
	    }
	    my @inc = gen_scale($base, $scale1);
	    my @dec = reverse gen_scale($base, $scale2);
	    if ($one_oct) {
		@inc = grep { $_->[0] >= 1 && $_->[0] <= 13 } @inc;
		@dec = grep { $_->[0] >= 1 && $_->[0] <= 13 } @dec;
	    }

	    my @scale = ();
	    my $last;
	    my @part1 = grep { $_->[0] >= $base } @inc;
	    $last = $part1[@part1-1]->[0];
	    my @part2 = grep { $_->[0] < $last } @dec;
	    $last = $part2[@part2-1]->[0];
	    my @part3 = grep { $_->[0] <= $base && $_->[0] > $last } @inc;
	    push @scale, @part1, @part2, @part3;
	    
	    my $difficulty = sprintf("%.1f", calc_mean_change(@scale));
	    
	    my @out = file_header($title, $difficulty);

	    if ($ex == 0) {
		push @out, voice_start(++$count);
		for (@scale) {
		    push @out, draw_note($_);
		}
		push @out, voice_end();
		push @out, score_header($count);
	    } elsif ($ex == 1) {
		# up-2/down-1 steps
		push @out, voice_start(++$count);
		my $aa = 0;
		while ($aa+1 < @scale && $scale[$aa+1]->[0] > $scale[$aa]->[0]) {
		    if ($aa+2 < @scale && $scale[$aa+2]->[0] > $scale[$aa]->[0]) {
			push @out, draw_note(slur_from($scale[$aa]));
			push @out, draw_note(slur_to($scale[$aa+2]));
		    } else {
			push @out, draw_note($scale[$aa]);
		    }
		    $aa++;
		}
		while ($aa+1 < @scale && $scale[$aa+1]->[0] < $scale[$aa]->[0]) {
		    if ($aa+2 < @scale && $scale[$aa+2]->[0] < $scale[$aa]->[0]) {
			push @out, draw_note(slur_from($scale[$aa]));
			push @out, draw_note(slur_to($scale[$aa+2]));
		    } else {
			push @out, draw_note($scale[$aa]);
		    }
		    $aa++;
		}
		while ($aa+1 < @scale && $scale[$aa+1]->[0] > $scale[$aa]->[0]) {
		    if ($aa+2 < @scale && $scale[$aa+2]->[0] > $scale[$aa]->[0]) {
			push @out, draw_note(slur_from($scale[$aa]));
			push @out, draw_note(slur_to($scale[$aa+2]));
		    } else {
			push @out, draw_note($scale[$aa]);
		    }
		    $aa++;
		}
		push @out, draw_note($scale[$aa]);
		push @out, voice_end();
		push @out, score_header($count);
	    } elsif ($ex == 2) {
		# Upper mordents
		push @out, voice_start(++$count);
		for (@part1) {
		    push @out, mordent($_, note_after($_, @inc));
		}
		for (@part2) {
		    push @out, mordent($_, note_before($_, @dec));
		}
		for (@part3) {
		    push @out, mordent($_, note_after($_, @inc));
		}
		push @out, voice_end();
		push @out, score_header($count);
	    } elsif ($ex == 3) {
		# Inverted mordents
		push @out, voice_start(++$count);
		for (@part1) {
		    push @out, mordent($_, note_before($_, @inc));
		}
		for (@part2) {
		    push @out, mordent($_, note_after($_, @dec));
		}
		for (@part3) {
		    push @out, mordent($_, note_before($_, @inc));
		}
		push @out, voice_end();
		push @out, score_header($count);
	    } elsif ($ex == 4) {
		# Turns
		push @out, voice_start(++$count);
		for (@part1) {
		    push @out, turn(note_after($_, @inc), $_, note_before($_, @inc));
		}
		for (@part2) {
		    push @out, turn(note_before($_, @dec), $_, note_after($_, @dec));
		}
		for (@part3) {
		    push @out, turn(note_after($_, @inc), $_, note_before($_, @inc));
		}
		push @out, voice_end();
		push @out, score_header($count);
	    }

	    write_file($fnam, \@out);
	}
    }
}

my @out = file_header("B-flat alternative fingerings");
push @out, voice_start("aaa");
push @out, draw_note([0, "bes'", "4789" ]);
push @out, draw_note([0, "bes'", "23789" ]);
push @out, draw_note([0, "bes'", "689" ]);
push @out, draw_note([0, "bes'", "2789" ]);
push @out, voice_end();
push @out, score_header("aaa", "RAGGED");
write_file("$OUT/alt-b-flat.ly", \@out);

@out = file_header("E-flat alternative fingerings");
push @out, voice_start("aaa");
push @out, draw_note([0, "ees'", "2456789" ]);
push @out, draw_note([0, "ees'", "12356789" ]);
push @out, voice_end();
push @out, score_header("aaa", "RAGGED");
write_file("$OUT/alt-e-flat.ly", \@out);

@out = file_header("C-sharp alternative fingerings");
push @out, voice_start("aaa");
push @out, draw_note([0, "cis'", "12456789" ]);
push @out, draw_note([0, "cis'", "023456789" ]);
push @out, voice_end();
push @out, score_header("aaa", "RAGGED");
write_file("$OUT/alt-c-sharp.ly", \@out);

for my $key (0..11) {
    my $off = ($key * 7) % 12;
    my $note = substr($key_notes, $off, 1);
    $note = substr($key_notes, $off-1, 1) . "is" if $note eq '#';
    $note = substr($key_notes, $off+1, 1) . "es" if $note eq '&';
    my $prn = $note;
    $prn =~ s/es$/b/;
    $prn =~ s/is$/\#/;

    my @out = file_header("Key signature $prn major");
    push @out, voice_start("aaa");
    push @out, '  \key ' . $note . ' \major';
    push @out, '  \hideNotes';
    push @out, '  c';
    push @out, '  \unHideNotes';
    push @out, voice_end();
    push @out, score_header("aaa", "RAGGED");
    write_file(sprintf("$OUT/keysig-%02d-major.ly", $key), \@out);

    @out = file_header("Key signature $prn minor");
    push @out, voice_start("aaa");
    push @out, '  \key ' . $note . ' \minor';
    push @out, '  \hideNotes';
    push @out, '  c';
    push @out, '  \unHideNotes';
    push @out, voice_end();
    push @out, score_header("aaa", "RAGGED");
    write_file(sprintf("$OUT/keysig-%02d-minor.ly", ($key + 12 - 4) % 12), \@out);
}

print "\e[K";


