#!/usr/local/bin/perl -w

# Version: 0.5  1998/01/02
#
# Author: Paul Schuurmans (schuur@mesa.nl)
#
# This program is GNU copylefted.

# TO DO:
#
# - Not all embellishments are implemented yet.
# - Create a help page
# - Create documentation

use strict;
use Getopt::Long;

my $SubText = "";
my $BARS_PER_LINE = 6;
my $DEBUG = 0;
my $opt_allabreve = -1;
my $opt_nummeter  =  0;
my $opt_landscape =  1;
my $opt_beampitch =  ' ';

my @optdefs = (
    'allabreve!'  => \$opt_allabreve,
    'nummeter!'   => \$opt_nummeter,
    'landscape!'  => \$opt_landscape,
    'maxbars=i'   => \$BARS_PER_LINE,
    'text=s'      => \$SubText,
    'beam:s'      => \$opt_beampitch,
);

if (! &GetOptions(@optdefs)){
    print STDERR "Usage:\n\n";
    exit 1;
}


my $BGP_FILE = shift;
# print "File: $BGP_FILE\n";


my @in_queue = ();
my @tokenlist = ();
my %tokens = (
    '$'  => 'meter',
    '@'  => 'tempo',
    '\'' => 'emb grace_hi',
    ','  => 'emb grace_lo',
    'b'  => 'emb grace',
    'c'  => 'emb grace',
    'd'  => 'emb grace',
    'e'  => 'emb grace',
    'f'  => 'emb grace',
    '-'  => 'emb hdbl',
    '='  => 'emb dbl',
    '/'  => 'emb throw',
    '\\' => 'emb slur',
    'l'  => 'emb grip',
    't'  => 'emb taorluath',
    '*'  => 'emb crunluath',
    '#'  => 'emb crunanmach',
    'k'  => 'emb catch',
    'w'  => 'emb birl',
    'W'  => 'emb longbirl',
    '>'  => 'emb bubbly',
    '<'  => 'emb ethrow',
    '^'  => 'emb lowgbg',
    'G'  => 'note',
    'A'  => 'note',
    'B'  => 'note',
    'C'  => 'note',
    'D'  => 'note',
    'E'  => 'note',
    'F'  => 'note',
    'g'  => 'note',
    'a'  => 'note',
    '|'  => 'bar single',
    '||' => 'bar double',
    ';'  => 'linebreak',
    '['  => 'bar repeat_start',
    ']'  => 'bar repeat_end',
    '('  => 'emb gracelist',
    '{'  => 'start_of_score',
    '}'  => 'end_of_score',
    'x'  => 'repeat repeat_first',
    'y'  => 'repeat repeat_second',
    'z'  => 'repeat repeat_both',
);

my %TeXnotes = (
    'G' => 'N',
    'A' => 'a',
    'B' => 'b',
    'C' => 'c',
    'D' => 'd',
    'E' => 'e',
    'F' => 'f',
    'g' => 'g',
    'a' => 'h',
);

my %TeXlen = (
    '1' => 'w',
    '2' => 'h',
    '4' => 'ql',
    '8' => 'c',
    '6' => 's',
    '5' => 't',
    '3' => 'c', #Triplets, show as 1/8 notes
    '9' => 's', #Triplets, show as 1/16 notes
);

# The length of the note in 1/192 notes
my $FullNote = 192;
my %TimeLen = (
    '1' => 192,   # Full note
    '2' =>  96,   # 1/2 note
    '4' =>  48,   # 1/4 note
    '8' =>  24,   # 1/8 note
    '6' =>  12,   # 1/16 note
    '5' =>   6,   # 1/32 note
    '3' =>  16,   # 1/12 note (triplet)
    '9' =>   8,   # 1/24 note (triplet)
);

#
# Handle the 'fixed beams' option.
#
my $opt_flatbeam = 0;
my $flatbeam_TeX = "bb";  # Default pitch if flat beams are used

if ($opt_beampitch ne ' '){ # Flat beams selected
    $opt_flatbeam = 1;
    if ($opt_beampitch){  # Non-default pitch
        my $tp = $TeXnotes{$opt_beampitch};

        if (! defined $tp){
            print STDERR "Illegal pitch value for beams: $opt_beampitch\n";
            exit 1;
        }
        $flatbeam_TeX = "$tp$tp";
    }
}


open BGP, "<$BGP_FILE" || die "Could not open $BGP_FILE\n";
    
#
# Read the bgp header
#
my $header = <BGP>;
$header =~ s/\s+$//;   # Strip trailing whitespace

#
# Skip everything until the beginning of the tune
#
my $line;
while (<BGP>){
    $line = $_;
    last if ($_ =~ /^{/);
    print "% Junk: $line";
}
@in_queue = split //, $line;

#
# Read all tokens
#
my $LexPrevNote = '-';

my $scan_token;
while ($scan_token = &ReadToken){
    last if $scan_token eq 'end_of_score';
    push @tokenlist, $scan_token;
}

#
# Debugging: print token list
#
# my $i = 1;
# foreach (@tokenlist){
#     printf "%4d  %s\n", $i, $_;
#     $i++;
# }
#exit;

#
# Create the tex preamble
#
my ($title, $type, $author) = split /\s+-\s+/, $header;
$type = "" if ! defined $type;
$author = "" if ! defined $author;

if (! ($SubText =~ s/\s+-\s+/ \\hss /g)){
    $SubText .= "\\hss";
}

my $Allabreve = ($type =~ /reel/i); # Reels use cut common time (alla breve)

$Allabreve = 0 if $opt_allabreve == 0;
$Allabreve = 1 if $opt_allabreve >= 1;

my $TieOpen = 0;

my $BarCount   = 0;

my $ticks = 0;
my $beatlength = $TimeLen{'4'}; # Quarter note

my @beamgroup = ();
my $bg_ticks = 0;

my $landscape_TeX = ($opt_landscape) ? "\\landscape\n" : "";
print <<XXX;
%&bagpipe
%
% Created by bgp2tex from $BGP_FILE
%
\\input bagpipe
\\def\\freqbarno{9999}
\\maxlinesinpage=12
%
\\ifx\\medleyflag\\relax\\else
  \\nopagenumbers\\pageno=1\\medtall\\medwidewidth\\fi
\\newpitch
$landscape_TeX%
\\line{\\moyen $title \\hss
\\rm $type \\hss $author}
\\line{$SubText}
%
\\debutmorceau
\\setelemq{1.2}%
XXX


#
# Process the token list
#
my $Emb_Store = '';
my $LookAheadNote = '';
my $TeXoutput = '';

my $BarStarted = 0;
my $LineStarted = 1;

my $Token = '';

for (;;){
    #
    # Get a token
    #
    $Token = shift @tokenlist;

    last if ! $Token;  # End of list = end of tune

    print STDERR "Token: [$Token]\n" if $DEBUG;

    $LookAheadNote = "";

    #
    # Find the token type
    #
    my ($type, @args) = split /\s+/, $Token;

    #
    # Some kind of bar
    #
    if ($type eq 'bar'){
        $ticks = 0;
        &FlushBeam;
        $Emb_Store = '';
        &TeX_Bar($Token);
        next;
    }

    if ($type eq 'repeat'){
        my $rep = $args[0];

        $ticks = 0;
        &FlushBeam;
        $Emb_Store = '';
        if ($rep eq 'repeat_first'){
            &AddLineTeX("\\setprimavolta\\xbarre");
        }
        if ($rep eq 'repeat_second'){
            &AddLineTeX("\\setsecondavolta\\xbarre");
        }
        if ($rep eq 'repeat_both'){
            &AddBarTeX("\\Uptext{\$\\vert\$ 1.\\&2.}");
        }
        next;
    }

    #
    # Setting the meter
    #
    if ($type eq 'meter'){
        my $counts = $args[0];
        my $beat   = $args[1];

        my $TeXmeter = "\\meterfrac{$counts}{$beat}";

        if ($beat == 4){ # Common time
# print "Common time: $counts / $beat\n";
            $beatlength = $TimeLen{'4'}; # A Beat is a quarter note

            if ($counts == 4){ # Special notations for 4/4 meter
                if ($Allabreve){
                    $beatlength *= 2; # Reels use allabreve...
                    $TeXmeter = "\\allabreve";
                }
                elsif (!$opt_nummeter){
                    $TeXmeter = "\\meterC";
                }
            }
        }
        elsif (($counts % 3) == 0){ # Compound time
# print "Compound time: $counts / $beat\n";
            $beatlength = 3 * $TimeLen{'8'};
        }
        else {
            # I don't know what time this is....
            $beatlength = $TimeLen{'4'};
        }
        &AddLineTeX("%\n\\generalmeter{$TeXmeter}\\writemeters%\n");
        next;
    }

    #
    # Embellishments
    #
    if ($type eq 'emb'){
        $Emb_Store = $Token;  # Just keep it for the following note
        next;
    }

    #
    # Notes
    #
    if ($type eq 'note'){
# print "$Token\n";

        $LookAheadNote = $Token; # Note is not processed yet...

        my $notelen = 0;

        #
        # Determine the note parameters
        #
        my $note = &ParseNote($Token);

        #
        # Unflagged notes can't be part of a beam group
        #
        if (! $note->{'flagged'}){
# print "    Unflagged note, flush previous\n";
            &FlushBeam;
        }

        #
        # Beam groups can not cross beats
        #
        my $cur_beat = int($ticks / $beatlength);
        my $next_beat = $cur_beat + 1;
        my $nb_ticks  = $next_beat * $beatlength; # Start of next beat in ticks
        my $afterticks = $ticks + $note->{'ticks'};       # Ticks after current note

        if ($afterticks > $nb_ticks){             # Note crosses a beat
# print "    Note crosses beat\n";
            &FlushBeam;
        }

        #
        # Add the note to the current beam group
        #
        if ($Emb_Store){        # If this note had an embellishment
            push @beamgroup, $Emb_Store;
            $Emb_Store = '';
        }
        push @beamgroup, $Token;    # Add it to the group
        $bg_ticks += $note->{'ticks'};
        $LookAheadNote = "";        # Note is processed

#print "Adding note, Ticks: $ticks\n";
#print "    Notelength: " . $note->{'ticks'} . "\n";
#print "    Afterticks: $afterticks\n";
#print "    Beatlength: $beatlength\n";

        $ticks = $afterticks;

        #
        # Unflagged notes can't be part of a beam group
        #
        if (! $note->{'flagged'}){
# print "    Unflagged note, flush this\n";
            &FlushBeam("");
            next;        # We're done with this note
        }

        #
        # Check if the note completes the beat
        #
        if (($afterticks % $beatlength) == 0){   # Current beat is complete
# print "    Next note will be on the beat\n";
            &FlushBeam("");
        }
    }

#    print "    Ticks: $ticks\n";

}
print <<XXX;
$TeXoutput
\\suspmorceau
%
\\byemedley
\\bye
XXX

1;

#
# This is it!! This routine generates the BagpipTeX code
# for the beamgroups containing all the notes and embellishments.
# It also handles beams, ties and triplets.
#

sub FlushBeam
{
    if ($#beamgroup < 0){
        return;
    }

    #
    # Use next note to determine if a
    # tie must be started on the last note
    # of the beam group.
    #
    my $next_note = &NextNote;
    my $nn = &ParseNote($next_note);

    my $token;
    my $prefix = '';
    my $beam   = '';
    my $bparm  = '';
    my $barg   = '';
    my $bnotes = 0;

    my $triplet = 0;

    while ($token = shift @beamgroup){
        my $t = &ParseNote($token);

        if ($t->{'type'} eq 'emb'){
            my $nn = &ParseNote($beamgroup[0]);         # The following note in the group
            my $emb_tex = &Emb_TeX($t, $nn->{'pitch'}); # Generate the TeX code

            if ($bnotes == 0){    # No beam yet
                $prefix = $emb_tex;
            }
            else {
                $barg .= $emb_tex;
            }
            next;
        }

        # Must be a note

        my $note_pitch = $TeXnotes{$t->{'pitch'}};
        my $note_dur   = $TeXlen{$t->{'length'}};

        if ($bnotes == 0){  # First note
            if ($#beamgroup < 0){ # Single note
                my $note_tex = $note_dur;

                $note_tex .= "p " if $t->{'dotted'};
                $note_tex .= $note_pitch;

                if ($prefix eq ""){
                    $prefix = "\\etn"; # Add some spacing if no grace note
                }

                # Close an open tie if there is one
                my $tie_close = &EndTie;

                # Start a new tie here if necessary
                my $tie_open = &StartTie($t);

                $note_tex .= '\\psk' if ($TieOpen);

                if ($tokenlist[0] !~ /^bar /){ # Add some spacing, unless a bar follows
                    $note_tex .= "\\etn";
                }

                &AddBarTeX("$prefix$tie_close$tie_open\\$note_tex");
                last;
            }
            # First note of a series

            $bparm .= $note_pitch;
        }
        else { # Not the first note
            $barg .= '}'; # Close the previous note
        }
        $beam .= $note_dur;
        $barg .= '{';
        $barg .= &EndTie;  # Close tie, if any

        $bnotes++;

        my $triptex = '';
        if ($t->{'length'} =~ /[39]/){ # A triplet note
            $triplet++;
            $triptex = "\\itenu1h"   if $triplet == 1;
            $triptex = "\\Uptext{3}" if $triplet == 2;
            $triptex = "\\tten1"     if $triplet == 3;
        }
        else {
            $triplet = 0;
        }

        if ($#beamgroup < 0){ # Last note

            # Start a tie here if necessary
            my $tie_open = &StartTie($t);

            $barg .= "$tie_open$triptex\\b$note_pitch";
            $barg .= "p" if $t->{'dotted'};

            $barg .= "}";

            $barg .= '\\psk' if ($TieOpen);

            $bparm .= $note_pitch;

            $bparm = $flatbeam_TeX if ($opt_flatbeam);
            &AddBarTeX("$prefix\\b$beam $bparm$bnotes$barg");
            last;
        }
        else { # Not last note
            $barg .= "$triptex\\b$note_pitch";
            $barg .= "p" if $t->{'dotted'};

            my $nn = &ParseNote($beamgroup[0]); # Next in group
            if ($nn->{'type'} ne 'emb'){    # No gracenote following
                if (! $t->{'dotted'}){      # And note is not dotted
                    $barg .= "\\psk";       # Add some space
                }
            }

        }


    }


    
    @beamgroup = ();
    $bg_ticks = 0;

} # FlushBeam


sub StartTie
{
    my ($t) = @_;

    return '' if $TieOpen; # Already an open tie (??)

    my $tie_tex = '';
    my $nxt = &NextNote;
    my $nn = &ParseNote($nxt); # Next in group
    if ($nn->{'type'} eq 'note'){  # A note is following
        if ($nn->{'pitch'} eq $t->{'pitch'}){ # Same pitch: tie
            my $note_pitch = $TeXnotes{$t->{'pitch'}};

            $tie_tex = "\\itenu0$note_pitch";
            $TieOpen = 1;
        }
    }

    return $tie_tex;

} # StartTie


sub EndTie
{

    return '' if ! $TieOpen;  # No open tie

    $TieOpen = 0;

    return '\\tten0';

} # EndTie
            

#
# Genetrate TeX code for embellishments
#

sub Emb_TeX
{
    my ($ep, $next_pitch) = @_;

    my $emb = $ep->{'emb'}; # The kind of embellishment
    my $prev_pitch = $ep->{'prev_pitch'};

    my @args = @{$ep->{'args'}};

    #
    # Find which gracenote is applicable for grace_hi
    #
    if ($emb eq 'grace_hi'){
        $emb = 'grace';
        $args[0] = 'g';

        if (($next_pitch eq 'g') || ($prev_pitch eq 'g')){
            $args[0] = 'a';
        }
    }

    #
    # Find which gracenote is applicable for grace_lo
    #
    if ($emb eq 'grace_lo'){
        $emb = 'grace';
        $args[0] = 'G';

        if ($next_pitch =~ /[EFga]/){
            $args[0] = 'A';
        }
    }

    if ($emb eq 'grace'){
        my $texval = $TeXnotes{$args[0]}; # Translate value to MusicTeX value

        return "\\gr$texval";
    }

    #
    # Full doublings
    #

    if ($emb eq 'dbl'){
        my $texval = $TeXnotes{$next_pitch}; # Translate value to MusicTeX value
        return "\\dbl$texval";
    }

    #
    # Half doublings
    #

    if ($emb eq 'hdbl'){
        my $texval = $TeXnotes{$next_pitch}; # Translate value to MusicTeX value
        return "\\hdbl$texval";
    }

    #
    # Throws
    #

    if ($emb eq 'throw'){
        my $texval  = $TeXnotes{$next_pitch};

        if ($next_pitch =~ /[DF]/){
            return "\\thrw$texval";
        }

print STDERR "SHAKEs are not fully implemented!!\n";
        return "\\shk$texval";
    }

    #
    # Grips
    #
    if ($emb eq 'grip'){
print STDERR "GRIPs are questionably implemented!!\n";

        return "\\dgrip" if $next_pitch eq 'D';
        return "\\grip";
    }

    #
    # Taorluaths
    #

    if ($emb eq 'taorluath'){
        return "\\grip" if $next_pitch eq 'E'; # Cant play one on E...
        return "\\dtaor" if $prev_pitch eq 'D';
        return "\\gtaor" if $prev_pitch eq 'g';
    
        return "\\taor";
    }

    #
    # Bubbly's
    #

    if ($emb eq 'bubbly'){
        return "\\bubbly";
    }
    if ($emb eq 'gbubbly'){
        return "\\gbubbly";
    }

    #
    # Birls
    #

    if ($emb eq 'birl'){
        if ($prev_pitch eq 'A'){
            return "\\wbirl";
        }
        return "\\birl";
    }

    if ($emb eq 'longbirl'){
        return "\\birl";
    }
    
    if ($emb eq 'glongbirl'){
        if ($prev_pitch eq 'g'){
            return "\\tbirl";
        }
        return "\\sbirl";
    }

    #
    # Arbitrary gracenote lists
    #

    if ($emb eq 'gracelist'){
        my $hinote = 'N';  # Determines bar height
        my @notes = map { $TeXnotes{$_} } @args;   # Translate notes to bagpipe tex

        # Find highest note
        foreach (@notes){
            $hinote = $_ if ($_ gt $hinote);
        }
        my $refnote = 'e';
        $refnote = 'g' if ($hinote ge 'h'); # Allow more headroom for hi A
            
        my $lastnote = pop @notes;
        my $bodynotes = join '', @notes;

        return "\\multigr $refnote\{$bodynotes\}$lastnote";
    }

print STDERR "Unimplemented embellishment: $emb\n";
    return "";

} # Emb_TeX


sub NextNote
{
    return $Emb_Store if $Emb_Store;         # There was an embellishment waiting
    return $LookAheadNote if $LookAheadNote; # We already found the next note

    foreach (@tokenlist){
        my ($type, @args) = split /\s+/, $_;

        if (($type eq 'note') || ($type eq 'emb')){
            return $_;
        }
    }
    return "end_of_score";

} # NextNote


sub ParseNote
{
    my $token = shift @_;

# print STDERR "ParseNote [$token]\n";

    my $note = {};
    my ($type, @args) = split /\s+/, $token;

    $note->{'type'} = $type;

    if ($type eq 'note'){
        my $dotted = 0;
        if ($args[0] eq 'dotted'){
            $dotted = 1;
            shift @args;
        }
        my $pitch  = shift @args;
        my $length = shift @args;

        my $ticks = $TimeLen{$length};
        my $flagged = ($ticks >= $TimeLen{'4'}) ? 0 : 1; # 1/4, 1/2 and Whole notes have no flag

        $ticks = (1.5 * $ticks) if $dotted;

        $note->{'ticks'}   = $ticks;
        $note->{'dotted'}  = $dotted;
        $note->{'pitch'}   = $pitch;
        $note->{'length'}  = $length;
        $note->{'flagged'} = $flagged;

        return $note;
    }

    if ($type eq 'emb'){
        $note->{'emb'}        = shift @args; # The kind of embellishment
        $note->{'prev_pitch'} = pop @args;   # The pitch of the previous note
        $note->{'args'}       = \@args;      # All other arguments
        return $note;
    }

    return $note;

} # ParseNote


sub TeX_Bar
{
    my $token = shift @_;

    my ($type, $bar, $break) = split /\s+/, $token;


    if ((defined $break && ($break eq 'break')) || ($BarCount+1 >= $BARS_PER_LINE)){
        &CloseBar(1, $bar);
        $BarCount = 0;
        $LineStarted = 0;
    }
    else {
        &CloseBar(0, $bar);
    }

} # TeX_Bar


sub AddLineTeX
{
    my $tex = shift @_;

    &OpenLine;
    &CloseBar(0, 'single');

    $TeXoutput .= $tex;

} # AddLineTeX


sub AddBarTeX
{
    my $tex = shift @_;

    &OpenLine;
    &OpenBar;

    $TeXoutput .= $tex;

} # AddBarTeX


sub OpenLine
{
    return if $LineStarted; # Line already open

    $TeXoutput.=<<XXX;

\\suspmorceau
%
\\generalmeter{}%
\\reprmorceau
XXX
    
    $LineStarted = 1;
    print "$TeXoutput";
    $TeXoutput = '';

} # OpenLine


sub OpenBar
{
    return if $BarStarted;

    $TeXoutput .= "\\notes";
    $BarStarted = 1;

} # OpenBar


sub CloseBar
{
    my ($lastofline, $bar) = @_;

    if (!$BarStarted){
        if ($bar eq 'repeat_start'){
            &OpenLine;
            $TeXoutput .= "\\leftrepeatsymbol\n";
        }
        return;
    }

    $TeXoutput .= "\\enotes";
    $BarCount++;

    if ($bar eq 'repeat_start'){
        $TeXoutput .= "\\setleftrepeat";
    }

    if ($bar eq 'repeat_end'){
        $TeXoutput .= "\\setrightrepeat";
    }

    if ($bar eq 'double'){
        $TeXoutput .= "\\setdoublebar";
    }

    if (!$lastofline){ # Must close previous bar
        $TeXoutput .= "\\xbarre\n";
        print "$TeXoutput";
        $TeXoutput = '';
    }
    $BarStarted = 0;

} # CloseBar


#
# The lexical scanner routines
#

sub GetChar
{
    my ($c, $val);

    for (;;){
        $c = shift @in_queue;
        if (! defined $c){
            $c = getc BGP;
        }

        return "" if ! defined $c;

        $val = unpack("c", $c);

        next if ($c le " ");   # Skip control chars and blanks

        return $c;
    }


} # GetChar


sub UngetChar
{
    my $c = shift;

    unshift @in_queue, $c;

} # UngetChar


sub ReadToken
{
    my ($char, $token);

    while (($char = &GetChar) ne ""){
        last if exists $tokens{$char};
        print "Unknown token: $char\n";
    }
    $token =  $tokens{$char};

    $token = '' if ! defined $token;

    if ($token eq 'note'){
        my $noteval = &GetChar;
        my $dot     = &GetChar;

        if ($dot ne '.'){
            &UngetChar($dot);
            $dot = "";
        }
        else {
            $token = "note dotted";
        }

        $LexPrevNote = $char;

        return "$token $char $noteval";
    }

    if ($token eq 'linebreak'){
        $token = "bar single";
        &UngetChar(';');
    }

    if ($token eq 'bar single'){
        my $nextchar = &GetChar;

        if ($nextchar eq '|'){
            $token = "bar double";
        }
        else {
            &UngetChar($nextchar);
        }
    }

    if ($token =~ /^bar /){
        my $nextchar = &GetChar;
        if ($nextchar =~ /[;\}]/){
            $token .= " break";

            &UngetChar($nextchar) if ($nextchar eq '}');
        }
        else {
            &UngetChar($nextchar);
        }
        return "$token";
    }

    if ($token eq 'emb grace_hi'){
        my $nextchar = &GetChar;

        if ($nextchar ne 'W'){
            &UngetChar($nextchar);
        }
        else {
            $token = "emb glongbirl";
        }
    }

    if ($token eq 'grace_lo'){
        my $nextchar = &GetChar;

        if ($nextchar ne '>'){
            &UngetChar($nextchar);
        }
        else {
            $token = "gbubbly";
        }
    }

    if ($token eq 'emb grace'){
        $token .= " \U$char";
    }

    if ($token eq 'emb gracelist'){
        my $next;

        while ($next = &GetChar){
            last if $next eq ')';
            $token .= " $next";
        }
    }

    if ($token =~ /^emb /){
        $token .= " $LexPrevNote";
    }

    if ($token eq 'meter'){
        my $m1 = &GetChar;
        my $m2 = &GetChar;

        $token .= " $m1 $m2";
    }

    if ($token eq 'tempo'){
        my $c;

        $token .= " ";
        while (($c = &GetChar) =~ /\d/){
            $token .= $c;
        }
        &UngetChar($c);  # Read one too much
    }

    return "$token";

} # ReadToken