#!/usr/bin/perl

#use Parse::DSLUtils qw(:yapp);
use Data::Dumper;
use strict;
use utf8::all;
my $instruments=join("",<DATA>);
my %DEF = (
  drumoff  => "[I:MIDI= drumoff]\n"  ,
  chordoff => "[I:MIDI= gchordoff]\n" ,
  chordon  => "[I:MIDI= gchordon]\n" ,
  transpose => "[I:MIDI= transpose #1]\n",
  volume    => "[I:MIDI= control 5 #1]\n",
  chordvol  => "[I:MIDI= chordvol #1 MIDI= bassvol #1]\n",
);
my $gchordsre =qr{([bcfghijGHIJz\d()]+)};
my $drumsre =qr{([dz\d()]+)};
my $optbarsre =qr{(?:(\d+)/)?};

my $M=qr{\\};    ## prev: §

my $yyst;
my $yyFile=preproc({def=>{%DEF}},join("",<>));



my @yySTACK=();
my @yyreturnstack=();
sub yynextreturn{ push (@yyreturnstack,[@_]) }
sub yynextreturns{ push (@yyreturnstack,@_) }
sub yy_push_state{ push(@yySTACK,$yyst); $yyst= $_[0]; }
sub yy_pop_state{ $yyst= pop(@yySTACK);}

sub lex{ 
  use v5.16;
  no warnings 'experimental';
  
  my $c=0;
  my $chs="";
  my $Met;


  $yyst //= "ABC";
  $yyFile //= join("",<>) . "__EOF__";

 while(1){
  for($yyFile){

   if(@yyreturnstack){ return (@{shift(@yyreturnstack)})};


	when(m/\G[\ \t]+/gc){}
	when(m/\G##.+/gc){}
     when(m!\G\s*__EOF__!gc) { return("EOF","iii") } 
     when(m!\G$!gc         ) { return("",undef)    } 

  if($yyst eq "ABC"){   ### ABC header level
     when(m/\G(M:\s*(\d+).*\n)/gc )           { $Met=$2; print $1,"%  ($Met)\n";                 } ; 

     when(m/\Gdrummode\s+(\w+)\s*=\s*$optbarsre$drumsre\s+(.*)\n/gc )
                  { $DEF{$1} = drummode($2,$3, $4);  } ; 

     when(m/\Gchordmode\s+(\w+)\s*=\s*$optbarsre$gchordsre\h+(\S+)\h+(\S.*)\n/gc )
                  { $DEF{$1} = chordmode($2,$3,$4,$5);  } ; 

     when(m/\Gchordmode\s+(\w+)\s*=\s*$optbarsre$gchordsre\s*(.*)\n/gc )
                  { $DEF{$1} = chordmode($2,$3,$4);  } ; 

     when(m/\Gdrummode(.*)/gc )      { die("bad drummode '$1'\n")       } ; 
     when(m/\Gchordmode(.*)/gc )     { die("bad chordmode '$1'\n")      } ; 

     when(m/\G\\(\w+)\s*[=←]\s*\{(.*?)\}/gc )
                  { $DEF{$1}=$2;                     } ; 
     when(m/\G\{(.*?)\}\s*[→]\s*\\(\w+)/gc )
                  { $DEF{$1}=$2; print $2            } ; 
     when(m/\G\\(\w+)/gc )           { print($DEF{$1} || err("undef function:$1"));      } ; 

     when(m/\Gchords\[(\w+)\]\{/gc ) { print($DEF{$1} || err("undf:$1")); yy_push_state("CHORDS");} ; 
     when(m/\Gchords\{/gc )          {                             yy_push_state("CHORDS");} ; 

     when(m/\GCH:\s*(\w+)\s*/gc )       { print("V:$1\n"); yy_push_state("CHVOICE"); } ; 
                                  ## }}

     when(m/\G(.*\n)/gc )            { print $1;                        } ; 
}


  if($yyst eq "CHVOICE"){

     when(m/\G\n([VWX]:\s*)/gc )     { print $1;   yy_pop_state();} ; 
     when(m/\GCH:\s*(\w+)/gc )       { print("V:$1");} ; 

     when(m/\G\\(\w+)\s*[=←]\s*\{(.*?)\}/gc )  { $DEF{$1}=$2; } ; 
     when(m/\G\{(.*?)\}\s*[→]\s*\\(\w+)/gc )   { $DEF{$1}=$2; print $2            } ; 
     when(m/\G\\(\w+)/gc )           { print($DEF{$1} || err("undf f$1"));       } ; 

     when(m/\G(:?\|\|?\]?\d?:?)/gc ) {
             if($c < $Met) { print nch("${chs}z".($Met-$c)."$1\n");}
               else      { print nch("$chs$1\n");}
             $c=0; $chs=""
           } ; 

     when(m/\G\./gc )                { $c++; $chs .= "z";} ; 

     when(m/\G([^\s.:|]+)/gc )       { $c++; $chs .= qq{ "$1"z}; } ; 
     when(m/\G([:])/gc )             { $chs .= $1;} ; 
     when(m/\G\n/gc )                { } ; 

}


  if($yyst eq "CHORDS"){   ### {{

     when(m/\G\}\h*\n/gc )    { print $chs; yy_pop_state();  } ; 
     when(m/\G\}/gc )         { print $chs; yy_pop_state();  } ; 

     when(m/\G\\(\w+)\s*[=←]\s*\{(.*?)\}/gc )
                 { $DEF{$1}=$2; } ; 

     when(m/\G\{(.*?)\}\s*[→]\s*\\(\w+)/gc )
                 { $DEF{$1}=$2; print $2            } ; 

     when(m/\G\\(\w+)/gc )          { print($DEF{$1} || err("undff $1"));       } ; 


     when(m/\G\./gc )                { $c++; $chs .= "z";} ; 

     when(m/\G(:?\|\|?\]?\d?:?)/gc ) {
             if($c < $Met) { print nch("${chs}z".($Met-$c)."$1\n");}
               else      { print nch("$chs$1\n");}
             $c=0; $chs=""
           } ; 

     when(m/\G([^\s.:|]+)/gc )       { $c++; $chs .= qq{ "$1"z}; } ; 
     when(m/\G###([:])/gc )          { $chs .= $1;} ; 

     when(m/\G\n/gc )                { } ; 

}



     if(m!\G(.|\n)!gc ) {
         print STDERR "Simbolos desconhecidos '",
                      substr($yyFile,pos($yyFile),20),"... (state=$yyst)'\n" ;
         return(lex()); } 
     }
 }
}


sub preproc{
 my %opt =(dolar => qr"\\",param=>"C",def=>{});
 if(ref($_[0]) eq "HASH") {%opt = (%opt , %{shift(@_)}) } ;
 my ($a)=@_;
 my %DEF=(%{$opt{def}});
 my $c=0;
 my $M=$opt{dolar};
 my $M1='\\';
 while(
      $a =~ s{$M\binclude\(\s*(\S+?)\s*\)}{
              open(my $F,"<:utf8","$1") or die("#Cant open $1\n");
              my $c=join("",<$F>);
              close $F;
              $c =~  s/\h*(\r\n|\n\r|\n|\r)/\n/g;   ## remove sp before \n
              $c =~  s/^(\xFF\xFE|\xFE\xFF|\xEF\xBB\xBF|\x{FEFF})//;  # BOM!
              $c;}ge
   or $a =~ s{$M(\w+)\s*[=←]\s*\{(.*?)\}}{
              $DEF{"$1"}=qq{$2};"" }ge
   or $a =~ s{$M(\w+)\s*[=←]\s*\((.*?)\)}{
              $DEF{"$1"}=qq{$2};"" }ge
   or $a =~ s{$M(\w+)\((.*?)\)\s*[=←]\s*\{(.*?)\}}{
              my($x1,$x2,$x3)=($1,$2,$3);
              $DEF{"$x1"}= ($x3 =~ s!\b$x2\b!#1!gr) ; "" }ge
   or $a =~ s{\{(.*?)\}\s*[→]\s*$M(\w+)}{
              $DEF{"$2"}=qq{$1}; "$1" }ge
   or $a =~ s{$M(\w+)\((.*?)\)}{
              my($x1,$x2)=($1,$2);
              $DEF{$x1}=~ s!#1!$x2!gr }ge
   or $a =~ s{$M(\w+)}{ $DEF{"$1"} || "\cA$1";       }ge
 ){ err("Infinite loop") if($c++ > 10)}
 $a=~ s/\cA/$M1/g;
# print Dumper(\%DEF);
# print $a;
# exit 1;
 $a;
}

sub err   { die("% Error '$_[0]'($yyst)\n") }
sub instruC{ "[I:MIDI= chordprog $_[0]]\n"}
sub instruB{ "[I:MIDI= bassprog $_[0]]\n"}
sub gchord{ "[I:MIDI= gchord    $_[0]]\n"}
sub nch   { return ($_[0] =~ s/zz(\d)?/"z".(($1||1)+1)/ger) }
sub sinstruC{my $pat=shift;
  $pat=~s/-/.*\\b/g;
  my ($i,$j) = ($instruments =~ m!(\d+)=($pat.*)!g);
  instruC($i,$j) }
sub sinstruB{my $pat=shift;
  $pat=~s/-/.*\\b/g;
  my ($i,$j) = ($instruments =~ m!(\d+)=($pat.*)!g);
  instruB($i,$j) }
sub drum  { "[I:MIDI= drum $_[0] $_[1] MIDI= drumon]\n"}

sub drummode{ my ($bars,$drum,$c)=@_;
  my $r="";
  $r.= "[I:MIDI= drumbars $bars]\n" if($bars =~ /\S/);
  $r.= "[I:MIDI= drum $drum $c MIDI= drumon]\n"; # FIXME
  return $r;
}

sub chordmode{ my ($bars,$gchords,$instru,$bass)=@_;
  $bass=$instru if(not defined($bass));
  my $r="";
  $r.="[I:MIDI= gchordbars $bars]\n" if($bars =~ /\S/);
  $r.= gchord($gchords)       if($gchords =~ /\S/);
  $r.= instruC($instru)       if($instru =~ /^\s*\d+\s*$/);
  $r.= sinstruC($1)           if($instru =~ /^\s*([a-zA-Z].*\S)\s*$/);
  $r.= instruB($bass)         if($bass =~ /^\s*\d+\s*$/);
  $r.= sinstruB($1)           if($bass =~ /^\s*([a-zA-Z].*\S)\s*$/);
  return $r
}

lex();


__DATA__

0=piano
1=bright acoustic piano
2=electric grand piano
3=honky-tonk piano
4=electric piano 1
5=electric piano 2
6=harpsichord
7=clavi
8=celesta
9=glockenspiel
10=music box
11=vibraphone
12=marimba
13=xylophone
14=tubular bells
15=dulcimer
16=drawbar organ
17=percussive organ
18=rock organ
19=organ // church organ
20=reed organ
21=accordion
22=harmonica
23=tango accordion
24=guitar (nylon)
25=guitar (steel)
26=electric guitar (jazz)
27=electric guitar (clean)
28=electric guitar (muted)
29=overdriven guitar
30=distortion guitar
31=guitar harmonics
32=acoustic bass
33=electric bass (finger)
34=electric bass (pick)
35=fretless bass
36=slap bass 1
37=slap bass 2
38=synth bass 1
39=synth bass 2
40=violin
41=viola
42=cello
43=contrabass
44=tremolo strings
45=pizzicato strings
46=orchestral harp
47=timpani
48=string ensemble 1
49=string ensemble 2
50=synthstrings 1
51=synthstrings 2
52=choir aahs
53=voice oohs
54=synth voice
55=orchestra hit
56=trumpet
57=trombone
58=tuba
59=muted trumpet
60=french horn
61=brass section
62=synthbrass 1
63=synthbrass 2
64=soprano sax
65=alto sax
66=tenor sax
67=baritone sax
68=oboe
69=english horn
70=bassoon
71=clarinet
72=piccolo
73=flute
74=recorder
75=pan flute
76=blown bottle
77=shakuhachi
78=whistle
79=ocarina
80=lead 1 (square)
81=lead 2 (sawtooth)
82=lead 3 (calliope)
83=lead 4 (chiff)
84=lead 5 (charang)
85=lead 6 (voice)
86=lead 7 (fifths)
87=lead 8 (bass + lead)
88=pad 1 (new age)
89=pad 2 (warm)
90=pad 3 (polysynth)
91=pad 4 (choir)
92=pad 5 (bowed)
93=pad 6 (metallic)
94=pad 7 (halo)
95=pad 8 (sweep)
96=fx 1 (rain)
97=fx 2 (soundtrack)
98=fx 3 (crystal)
99=fx 4 (atmosphere)
100=fx 5 (brightness)
101=fx 6 (goblins)
102=fx 7 (echoes)
103=fx 8 (sci-fi)
104=sitar
105=banjo
106=shamisen
107=koto
108=kalimba
109=bag pipe
110=fiddle
111=shanai
112=tinkle bell
113=agogo
114=steel drums
115=woodblock
116=taiko drum
117=melodic tom
118=synth drum
119=reverse cymbal
120=guitar fret noise
121=breath noise
122=seashore
123=bird tweet
124=telephone ring
125=helicopter
126=applause
127=gunshot