#!/usr/bin/perl -w

use strict;

# Nomenclature in the following in comments and variable names:
# Note - index in scale, not equidistant due to half steps
# Tone - 12-tone index, equidistant with small second intervals


# Tones in major and minor scale:
my @major= ( 0, 2, 4, 5, 7, 9, 11 );
my @minor= ( 0, 2, 3, 5, 7, 8, 10 );


# Parse note string in ABC format (without commas or apostrophes) or as note
# char + optional "b" or "#" and return note in great octave as offset from
# great C.  An appended "m" is recognised as denoting a minor scale.
# -> String describing note
# <- Semitone offset from C
#    Flag to use flat accidentals in the scale
#    Flag for minor scale
sub str2scale
{
    my $str= lc shift;
    my ($root, $flat, $minor);

    if( $str =~ /^([a-g])([b#]?)(m)?$/ ) {
        $root= ord($1) - ord("c");
        $root += 7 if $root < 0;
        $root= $major[$root];
        --$root if $2 eq "b";
        $flat= 1 if $2 eq "b" || (!$2 && $1 eq "f");
        ++$root if $2 eq "#";
        $root += 12 if $root < 0;
        $minor= !!$3;
    }
    elsif( $str =~ /^([_=^]?)([a-g])(m)?$/ ) {
        $root= ord($2) - ord("c");
        $root += 7 if $root < 0;
        $root= $major[$root];
        --$root if $1 eq "_";
        $flat= 1 if $1 eq "b" || ((!$2 || $2 eq "=") && $1 eq "f");;
        ++$root if $1 eq "^";
        $minor= !!$3;
    }
    else {
        die "Cannot parse scale string \`$str'.";
    }
    return ($root, $flat, $minor);
}


# Parse note in ABC notation, containing an optional accidental, a note
# character and an optional octave denotation consisting of commas or
# apostrophes.
# -> ABC note string
# <- Tone in semitones relative to great C
sub abc2tone
{
    my $str= shift;

    my ($acc, $note, $oct)= $str =~ /^([_=^]?)([a-g])(,+|'+|)$/i
        or die "Cannot parse note string \`$str'.";
    my $tone= ord(lc($note)) - ord("c");
    $tone += 7 if $tone < 0;
    $tone= $major[$tone];
    --$tone if $acc eq "_";
    ++$tone if $acc eq "^";
    $tone += 12 if $note =~ /[a-g]/;
    $tone += 12 * length($oct) if $oct =~ /^'/;
    $tone -= 12 * length($oct) if $oct =~ /^,/;
    return $tone;
}


# Convert note of a scale to semitone index.
# -> Note index in scale
#    Root note (semitone relative to great C)
#    Flag for minor scale
# <- Tone in semitones relative to great C
sub notetone
{
    my ($note, $root, $minor)= @_;
    my $scale= $minor ? \@minor : \@major;

    my $tone= $root + $$scale[$note % 7];
    my $oct= int(($note + 700) / 7) - 100;
    return $tone + 12 * $oct;
}


my %wholetones= ( 0 => "c", 2 => "d", 4 => "e", 5 => "f", 7 => "g", 9 => "a", 11 => "b" );

# Render tone in ABC notation.
# -> Tone (semitone relative to great C)
#    Flag for using flats not sharps
#    Root tone, serving as flag to use E# / Cb for F# / Gb major
# <- ABC string
sub toneabc
{
    my ($tone, $flat, $root)= @_;

    my $oct= int(($tone + 1200) / 12) - 100;
    my $notechar= $wholetones{($tone + 1200) % 12};
    my $acc= "";
    if( ! defined $notechar ) {
        $oct= int(($tone + 1200 + ($flat ? 1 : -1)) / 12) - 100;
        $notechar= $wholetones{($tone + 1200 + ($flat ? 1 : -1)) % 12};
        $acc= $flat ? "_" : "^";
    }
    elsif( $root == 6 ) {
        if( ! $flat && $notechar eq "f" ) {
            $notechar= "e";
            $acc= "^";
        }
        elsif( $flat && $notechar eq "b" ) {
            $notechar= "c";
            $acc= "_";
        }
    }
    $notechar= uc($notechar) unless $oct > 0;
    my $octstr= $oct > 0 ? "'" x ($oct - 1) : "," x -$oct;
    return $acc . $notechar . $octstr;
}


# Print ABC notes for a single (either rising or falling scale), with the step
# pattern and other parameters we support.
# -> File handle to print to
#    First note (index in scale relative to root note in config)
#    Counter of notes printed on the current line
#    Reference to config hash
# <- Concluding note that has not been printed yet
#    Updated counter of notes printed on the current line
sub printabcscale
{
    my ($out, $note, $linecount, $config)= @_;

    while( 13 ) {
        # stop if the next step pattern would take us out of the tone range
        if( $$config{totstep} > 0 ) {
            last if $note + $$config{stepmax} > $$config{highnote};
        }
        else {
            last if $note + $$config{stepmin} < $$config{lownote};
        }
        # try to break lines between step patterns:
        if( $linecount >= $$config{linemin} && $linecount + @{$$config{steps}} > $$config{linemax} ) {
            print $out "|\n";
            $linecount= 0;
        }
        for (@{$$config{steps}}) {
            my $tone= notetone($note, $$config{root}, $$config{minor});
            print $out toneabc($tone, $$config{flatroot}, $$config{root}), " ";
            $note += $_;
            # emergency line break to keep within limit:
            if( ++$linecount >= $$config{linemax} ) {
                print $out "|\n";
                $linecount= 0;
            }
        }
    }
    return ($note, $linecount);
}


# Determine the first and last note belonging to a scale and within a tone
# range.
# -> Root tone (semitone relative to great C)
#    Flag for minor scale
#    Lowest tone of range (semitone relative to great C)
#    Highest tone of range (semitone relative to great C)
# <- Minimum and maximum tone index in scale
sub noterange
{
    my ($root, $minor, $min, $max)= @_;
    my $first= int((($min - $root) * 7 + 1200.5) / 12) - 100;
    ++$first if notetone($first, $root, $minor) < $min;
    my $last= int((($max - $root) * 7 + 1200.5) / 12) - 100;
    --$last if notetone($last, $root, $minor) > $max;
    return ($first, $last);
}


# Print usage message and exit.
sub usageexit
{
    print STDERR <<EOF;
usage: printscales { -o|-O <outfile> | -r <from>-<to> | -t <title> } [ -s <step>{,<step>} ] <root> { -s <steps> | root }
Generates ABC notation of a scale and renders it as PostScript using abcm2ps.
<root> gives the root note either in ABC notation or as a note character
followed by an optional # or b accidental, in turn followed by an optional m
for minor scales.  -o or -O specify the PostScript output file, with -O
overwriting silently.  The -r option specifies the range of tones to include
(in ABC notation), usually the range your instrument can play.  No printed note
will exceed this range (both limits inclusive), even when the step pattern
extends above or below the starting or following note (see below).  -t gives a
string to print at the top of the output page.
The -s option specifies one or several steps to use in turn.  For example,
"2,-1" alternates a third upwards with a second downwards.  An optional
appended "+" creates an added scale with the same but inverted steps.  The
default is "1", an ordinary rising scale.
For more on ABC notation, see http://abcnotation.com/ .
EOF
    exit;
}


# Parse command line options and key arguments.
# -> Reference to @ARGV
#    Reference to hash for config values computed from options
# <- Key of the next scale, "" if same as previous (only if follow-up), undef
#    for no more scales.
sub parsecmdline
{
    my ($argv, $config)= @_;

    if( grep /^--?h(?:elp)?/i, @$argv ) {
        usageexit();
    }
    while( defined(my $arg= shift @$argv) ) {
        if( $arg !~ /^-/ ) {
            eval { @$config{qw(root flatroot minor)}= str2scale($arg) };
            if( $@ ) {
                print STDERR "$@\n";
                exit;
            }
            # Determine highes and lowest note of scale within instrument range
            @$config{qw(lownote highnote)}= noterange(@$config{qw(root minor bottom top)});
            return 1;
        }
        elsif( $arg eq "-s" ) {
            if( !@$argv || $$argv[0] !~ /^-?\d+(,-?\d+)*\+?$/ ) {
                print STDERR "The -s option requires one or several comma-separated integers as an argument.\n";
                usageexit();
            }
            $$config{return}= $$argv[0] =~ s/\+$//;
            $$config{steps}= [ split(/,/, $$argv[0]) ];
            $$config{totstep}= $$config{stepmin}= $$config{stepmax}= 0;
            for (@{$$config{steps}}) {
                $$config{totstep} += $_;
                $$config{stepmin}= $$config{totstep} if $$config{totstep} < $$config{stepmin};
                $$config{stepmax}= $$config{totstep} if $$config{totstep} > $$config{stepmax};
            }
            if( $$config{totstep} == 0 ) {
                print STDERR "The sum of steps given in the -s option must not be 0.\n";
                exit;
            }
            shift @$argv;
            if( defined($$config{root}) && (! @$argv || $$argv[0] =~ /^-/) ) {
                return 1;
            }
        }
        elsif( $$config{lastroot} ) {
            print STDERR "Only the -s option and/or root may be given repeatedly.\n";
            usageexit();
        }
        elsif( $arg eq "-t" ) {
            if( ! @$argv ) {
                print STDERR "The -t option requires an argument.\n";
                usageexit();
            }
            $$config{title}= shift @$argv;
        }
        elsif( $arg =~ /^-o$/i ) {
            if( !@$argv ) {
                print STDERR "The option $arg requires an argument.\n";
                usageexit();
            }
            $$config{outfname}= shift @$argv;
            if( $arg eq "-o" && -e $$config{outfname} ) {
                print STDERR "Output file $$config{outfname} exists!  Use -O to overwrite.\n";
                usageexit();
            }
        }
        elsif( $arg eq "-r" ) {
            my @rangestrs;
            if( !@$argv || (@rangestrs= split(/-/, shift @$argv)) != 2 ) {
                print STDERR "The -r options requires two comma-separated ABC notes as an argument.\n";
                usageexit();
            }
            eval {
                $$config{bottom}= abc2tone($rangestrs[0]);
                $$config{top}= abc2tone($rangestrs[1]);
            };
            if( $@ ) {
                print STDERR "-r option: $@\n";
                exit;
            }
            if( $$config{top} < $$config{bottom} ) {
                my $tmp= $$config{bottom};
                $$config{bottom}= $$config{top};
                $$config{top}= $tmp;
            }
        }
        else {
            print STDERR "Unknown option \`$arg'.\n";
            usageexit();
        }
    }
    if( ! defined $$config{root} ) {
        print STDERR "No root note passed.\n";
        usageexit();
    }
    return 0;
}


my %config= ( outfname => "scale.ps", bottom => 0, top => 24,
              steps => [ 1 ], stepmin => 0, stepmax => 1, totstep => 1,
              linemin => 20, linemax => 25 );

parsecmdline(\@ARGV, \%config);


my $tmpdir= "/tmp";
my $abcname= "$tmpdir/scale-$$.abc";

open(ABC, ">$abcname") or die "Cannot create ABC file $abcname";

my $titlerow= $config{title} ? "T: $config{title}\n" : "";

print ABC <<EOF;

X: 1
V: clef = treble
${titlerow}K: C
L: 1/4
M: none
%
EOF

do
{
    my $note= $config{$config{totstep} > 0 ? "lownote" : "highnote"};
    my $linecount= 0;

    ($note, $linecount)= printabcscale(*ABC{IO}, $note, $linecount, \%config);

    if( $config{return} ) {
        $_= -$_ for (@{$config{steps}}, $config{totstep});
        @config{qw(stepmin stepmax)}= ( - $config{stepmax}, - $config{stepmin} );
        # If the step pattern extends farther in the direction we were going in
        # the first part, the first return pattern may extend outside the tone
        # range, so we may have to change it.
        if( $config{totstep} > 0 ) {
            while( notetone($note + $config{stepmin}, $config{root}, $config{minor}) < $config{bottom} ) {
                $note += $config{totstep};
            }
        }
        else {
            while( notetone($note + $config{stepmax}, $config{root}, $config{minor}) > $config{top} ) {
                $note += $config{totstep};
            }
        }
        if( $linecount ) {
            print ABC "|";
            if( $linecount + @{$config{steps}} >= $config{linemax} ) {
                print ABC "\n";
                $linecount= 0;
            }
        }
        ($note, $linecount)= printabcscale(*ABC{IO}, $note, $linecount, \%config);
        $_= -$_ for (@{$config{steps}}, $config{totstep});
        @config{qw(stepmin stepmax)}= ( - $config{stepmax}, - $config{stepmin} );
    }

    # Last concluding note
    my $tone= notetone($note, $config{root}, $config{minor});
    print ABC toneabc($tone, $config{flatroot}, $config{root}), " ";

    print ABC "|]\n%\n";

}
while( parsecmdline(\@ARGV, \%config) );

close ABC;

system "abcm2ps -O $config{outfname} $abcname";

unlink $abcname;