pae2xml.pl

   1 #!/usr/bin/perl
   2
   3
   4 # Copyright (C) 2003 Rainer Typke
   5 # Copyright (C) 2010 Reinhold Kainhofer <reinhold@kainhofer.com>
   6 #pae2xml is licensed under the terms of the GNU General Public License Version
   7 #2 as published by the <a href="http://www.fsf.org/" target="_top">Free Software Foundation</a>.
   8 #This gives you legal permission to copy, distribute and/or modify <em>pae2xml</em> under
   9 #certain conditions. Read
  10 #the <a href="http://www.gnu.org/copyleft/gpl.html" target="_top">online version of the license</a>
  11 #for more details. pae2xml is provided AS IS with NO WARRANTY OF ANY KIND,
  12 #INCLUDING THE WARRANTY OF DESIGN, MERCHANTABILITY, AND FITNESS FOR A PARTICULAR PURPOSE.
  13
  14 our $script = "pae2xml.pl";
  15 our $version = "1.0";
  16
  17 ### Handle command-line options
  18
  19 # import module
  20 use Getopt::Long;
  21 use File::Basename;
  22
  23 our $format = 'rism';
  24
  25 sub print_help {
  26   print 'pae2xml.pl [OPTIONS...] FILE
  27
  28   Converts the Plaine & Easie file FILE to MusicXML. If FILE is -, STDIN is used.
  29
  30   Possible options:
  31     -h, --help          Prints out this help message
  32     --format=FORMAT, -f FORMAT
  33                         Interprets input file as FORMAT. Possible values are
  34                            rism, pae (default: rism)
  35     -v, -- version      Prints out version information
  36 ';
  37 }
  38 sub print_version {
  39   print "$script $version
  40   Copyright (C) 2003 Rainer Typke
  41   Copyright (C) 2010 Reinhold Kainhofer <reinhold\@kainhofer.com>
  42 ";
  43 }
  44 sub handle_options {
  45   my $print_help = 0;
  46   my $print_version = 0;
  47   my $result = GetOptions ("f|format=s" => \$format, "help|h" => \$print_help, "version|v" => \$print_version);
  48   if ($print_version) {
  49     print_version ();
  50     exit 0;
  51   }
  52   if ($print_help || (@ARGV == 0)) {
  53     print_help ();
  54     exit 0;
  55   }
  56 }
  57 handle_options ();
  58
  59
  60
  61 $divisions = 960;
  62 $old_duration = $divisions;
  63 $old_type = "";
  64 $old_octave = 4;
  65 $BEAM = 0;
  66 @rhythmic_model = ();
  67 $rhythmic_model_index = 0;
  68
  69 # Store all alterations already used in the current measure, so that e.g.
  70 # xCC also detects the second note as a Cis! Needs to be reset at the
  71 # beginning of a new bar.
  72 %active_alterations = {};
  73
  74 ($mday, $mon, $year) = (localtime()) [3..5];
  75 $encoding_date = sprintf("%4d-%02d-%02d", $year + 1900, $mon+1, $mday);
  76
  77 $TIE = 0;
  78
  79 foreach $a (@ARGV) {
  80   $p = read_file($a);
  81   $toprint = "";
  82   if ($format eq "rism") {
  83     $p =~ s/\s*\=\=+\s*(.*?)\s*\=\=+\s*/$1/sg;
  84     $p =~ s/\s*included.*?-------------*\s*(.*?)\s*/$1/s;
  85
  86     ($q, $r) = ($p, $p);
  87     if ($q !~ /^.*1\.1\.1.*$/gsx && $r =~ /^.*plain.*$/gsx) {
  88       print_error("$a contains 'plain', but not 1.1.1!\n");
  89     } else {
  90       if ($p =~ /^\s*([^\n]+)\n(.*?)\n((\d+\.\d+\.\d.*?plain.*?\n)+)(.*?)\n?([^\n]+)\n([^\n]+)\s*$/gs)    {
  91         my ($comp, $title, $incipits, $sonst, $libsig, $rismsig) = ($1, $2, $3, $5, $6, $7);
  92
  93         $toprint .= "
  94 COMPOSER:   $comp
  95 TITLE:      $title
  96 INCIPIT(S): $incipits
  97 OTHER INFO: $sonst
  98 LIB. SIGN.: $libsig
  99 RISM SIGN.: $rismsig\n\n";
 100         parse_rism_incipits($incipits, $comp, $title, $sonst, $libsig, $rismsig);
 101       }
 102       else {
 103         if (index($p,"plain&easy") > -1) {
 104           print_error("Ignoring the following text:\n\n\n$p\n\n\n");
 105         }
 106       }
 107     }
 108   } else {
 109     # Just a plaine & easie snippet, without any further RISM fields
 110     if ($a eq "-") {
 111       $filename = "out.xml";
 112     } else {
 113       $filename = basename ($a, ".pae") . ".xml";
 114     }
 115     parse_pe ($filename, $p, "", "", "", "", "", "", "");
 116   }
 117 }
 118
 119
 120 ##############################################################################
 121 ### RISM file parsing
 122 ##############################################################################
 123
 124 sub parse_rism_incipits {
 125   my ($incipits, $comp, $title, $sonst, $libsig, $rismsig) = @_;
 126
 127   $toprint .= "parsing:   $incipits\n";
 128
 129   while ($incipits =~ /^(\d+\.\d+\..+?)(\d+\.\d+\..*)$/gs) {
 130     my ($inc1) = $1;
 131     $incipits = $2;
 132     parse_rism_incipit($inc1, $comp, $title, $sonst, $libsig, $rismsig);
 133   }
 134   parse_rism_incipit($incipits, $comp, $title, $sonst, $libsig, $rismsig);
 135 }
 136
 137 sub parse_rism_incipit {
 138   my ($pe, $comp, $title, $sonst, $libsig, $rismsig) = @_;
 139
 140   if ($pe =~ /^\s*(\d+\.\d+\.\d)(\.|:)\s*(.*?)\nplain&easy:\s*(.*)$/gs) {
 141     my ($inr, $instr, $pecode) = ($1, $3, $4);
 142
 143     my $filename="$rismsig-$inr.xml";
 144     $filename =~ s/RISM\s*A\/II\s*:?\s*//gs;
 145
 146     foreach $_ ($rismsig,$title,$inr,$instr,$comp,$libsig,$sonst)
 147     {
 148         s/
 149 //;
 150     }
 151     $toprint .= "
 152 INCIPIT NO.:  $inr
 153 INSTR.:       $instr\n";
 154     parse_pe ($filename, $pecode, $inr, $instr, $comp, $title, $sonst, $libsig, $rismsig);
 155
 156   } else {
 157     print_error("could not parse $pe\n");
 158   }
 159 }
 160
 161
 162 ##############################################################################
 163 ### pure Plaine & Easie data parsing
 164 ##############################################################################
 165
 166 sub parse_pe {
 167   my ($filename, $pe, $inr, $instr, $comp, $title, $sonst, $libsig, $rismsig) = @_;
 168
 169   $pe =~ s/@ü/@0ü/gs; # make missing time signature explicit
 170   while ($pe =~ s/([^\-])(\d+)(\'|\,)(A|B|C|D|E|F|G)/$1$3$2$4/gs) {};  # octave first, then duration. Truly global.
 171
 172   if ($pe =~ /^\s*(%([\w\-\+\d]+))?(@([\d\w\/ ]+))?\s*&?\s*(\$([^ü]*))?ü(.*)$/gs) {
 173     my ($clef, $timesig, $keysig, $rest) = ($2, $4, $6, $7);
 174
 175     print "Writing $filename...\n";
 176     open(OUT, ">$filename");
 177
 178
 179     print OUT '<?xml version="1.0" encoding="iso-8859-1" standalone="no"?>
 180 <!DOCTYPE score-partwise PUBLIC "-//Recordare//DTD MusicXML 2.0 Partwise//EN" "http://www.musicxml.org/dtds/partwise.dtd">
 181 <score-partwise>
 182 ';
 183     print OUT " <work>\n" if ($rismsig || $title);
 184     print OUT "         <work-number>$rismsig</work-number>\n" if ($rismsig);
 185     print OUT "         <work-title>$title</work-title>\n" if ($title);
 186     print OUT " </work>\n" if ($rismsig || $title);
 187     print OUT " <movement-number>$inr</movement-number>\n" if ($inr);
 188     print OUT " <movement-title>$instr</movement-title>\n" if ($instr);
 189     print OUT " <identification>\n";
 190     print OUT "         <creator type=\"composer\">$comp</creator>\n" if ($comp);
 191     print OUT '         <encoding>
 192                         <software>pae2xml by R. Typke</software>
 193                         <encoding-date>'.$encoding_date.'</encoding-date>
 194                 </encoding>
 195 ';
 196     print OUT "         <source>$libsig</source>\n" if ($libsig);
 197     print OUT ' </identification>
 198         <part-list>
 199                 <score-part id="P1">
 200                         <part-name>'.$sonst.'</part-name>
 201                 </score-part>
 202         </part-list>
 203         <part id="P1">
 204                 <measure number="1">
 205                         <attributes>
 206                                 <divisions>'.$divisions.'</divisions>
 207 '.keysignature ($keysig)
 208 .timesignature ($timesig)
 209 .clef ($clef)
 210 .'                      </attributes>
 211 ';
 212
 213
 214     $toprint .= "
 215 CLEF:         $clef
 216 KEY SIG.:     $keysig
 217 TIME SIG.:    $timesig
 218 REST:         $rest\n";
 219     parse_notes($rest, $keysig);
 220   }
 221   else { print_error("could not parse $pe\n"); }
 222   print OUT "   </part>
 223 </score-partwise>\n";
 224   close OUT;
 225 }
 226
 227 # Repeat $1 by a count of $2
 228 sub repeat {
 229   (my $e, my $count) = @_;
 230   my $res = "";
 231   for (my $i=1; $i <= $count; ++$i)
 232   {
 233     $res .= $e;
 234   }
 235   return $res;
 236 }
 237
 238 sub parse_notes {
 239   my ($notes, $keysig) = @_;
 240   my $qq = 0; # in group of cue notes
 241
 242   my $meas = 2;   # measure number
 243   my $mopen = 1;  # measure tag still open
 244
 245   if ($notes =~ /^\s*(.*?)\s*$/) {
 246     $notes = $1;
 247   }
 248
 249   $notes =~ s/!([^!]*)!(f*)/repeat($1, length($2)+1)/gse;  # write out repetitions
 250   while ( $notes =~ s/(:?\/+:?|^)([^\/:]*)(:?\/+:?)i(:?\/+:?)/$1$2$3$2$4/gs) {}; # replace whole-measure repeats (i notation)
 251
 252   $notes =~ s/(\d+)\(([^;]+\))/\($1$2/gs;       # pull note lengths into fermatas or triplets
 253   $notes =~ s/(xx|x|bb|b|n)\(/\($1/gs;       # pull accidentals into tuplets or fermatas:
 254   $notes =~ s/(\d+)(xx|x|bb|b|n)(A|B|C|D|E|F|G)/$2$1$3/gs;  # accidentals first, then duration
 255
 256   $notes =~ s/(\.|\d|\,|\')qq/qq$1/gs; # pull beginning mark of group of grace notes in front of corresponding notes
 257   $notes =~ s/(xx|x|bb|b|n)qq/qq$1/gs;  # qq first, then parts of notes
 258   $notes =~ s/([\.\d,'xbn])+(q|g)/$2$1/gs; # q and g first, then parts of notes
 259
 260   # Beam starts/endings are handled by the first/last note of the beam, since
 261   # we need to know for the first note the <beam>begin</beam> and for the
 262   # last note that the <beam>end</beam> tag should be used!
 263   # Thus, the RegExp for a note contains the beam start/end tags { and }
 264   while ($notes ne "") {
 265     if ($notes =~ /^(\'+|\,+)(.*)$/) {  # Octave marks
 266       ($oct, $notes) = ($1, $2);
 267       octave($oct);
 268     } elsif ($notes =~ /^qq(.*)$/) {  # Begin grace
 269       $notes = $1;
 270       $qq = 1;
 271     } elsif ($notes =~ /^r(.*)$/) {  # End grace
 272       $notes = $1;
 273       $qq = 0;
 274     } elsif ($notes =~ /^([0-9]\.?(?:\s?[0-9]+\.?)+)\s*(.*)$/) {  # Rhythmic model
 275       ($model, $notes) = ($1, $2);
 276       @rhythmic_model = parse_rhythmic_model ($1);
 277       $rhythmic_model_index = -1;
 278     } elsif ($notes =~ /^\=(\d*)(\/.*)$/) {  # multi-measure rests
 279       $measrest = $1;
 280       $notes = $2;
 281       if ($measrest eq '') {
 282         $measrest = 1;
 283       }
 284       $toprint .= "$measrest measures of rest.\n";
 285       if ($measrest > 0) {
 286         # Create a real multi-bar rest
 287         print OUT '                     <attributes>
 288                                 <measure-style>
 289                                         <multiple-rest>'.$measrest.'</multiple-rest>
 290                                 </measure-style>
 291                         </attributes>
 292 ';
 293       }
 294       # Now create the measures
 295       for $n (1..$measrest) {
 296         print OUT '                     <note>
 297                                 <rest />
 298                                 <duration>'.($beats*$divisions*4/$beattype).'</duration>
 299                         </note>
 300 ';
 301         if ($n < $measrest) {
 302           print OUT "           </measure>\n";
 303           reset_measure_attributes ();
 304           if ($notes ne "") {
 305             print OUT '         <measure number="'.$meas.'">
 306 ';
 307             $meas++;
 308           } else {
 309             $mopen = 0;
 310           }
 311         }
 312       }
 313     } elsif ($notes =~ /^({?(\^)?(g|q)?(\,|\')*(x|xx|b|bb|n)?\d*\.*(\-|A|B|C|D|E|F|G)t?\+?}?)(.*)$/) {  # a note
 314       ($note, $notes) = ($1,$7);
 315       parse_note($note, $keysig, "", "", $qq);
 316     } elsif ($notes =~ /^({?\((g|q)?{?(\,|\')*(x|xx|b|bb|n)?\d*\.*(\-|A|B|C|D|E|F|G)[t\+]*\)[t\+}]*)(.*)$/) {  # one note with a fermata
 317       ($note, $notes) = ($1,$6);
 318       parse_note($note, $keysig, "", "", $qq);
 319     } elsif ($notes =~ /^(\(({?(\^)?(g|q)?(\,|\')*(x|xx|b|bb|n)?\d*\.*(\-|A|B|C|D|E|F|G)t?\+?}?){3}\))(.*)$/) {  # a triplet
 320       ($triplet, $notes) = ($1,$8);
 321       #      print "TRIPLET: ".$triplet." -> ";
 322       $triplet =~ /^\(({?(\^)?(g|q)?(\,|\')*(x|xx|b|bb|n)?\d*\.*(\-|A|B|C|D|E|F|G)t?\+?}?)(.*)\)$/gs;
 323       ($note, $triplet) = ($1,$7);
 324       #print "$note $triplet\n";
 325       parse_note($note, $keysig, '<tuplet type="start"/>', '                            <time-modification>
 326                                         <actual-notes>3</actual-notes>
 327                                         <normal-notes>2</normal-notes>
 328                                 </time-modification>', $qq);
 329       $triplet =~ /^({?(g|q)?(\,|\')*(x|xx|b|bb|n)?\d*\.*(\-|A|B|C|D|E|F|G)t?\+?}?)(.*)$/gs;
 330       ($note, $triplet) = ($1,$6);
 331       #print "$note $triplet\n";
 332       parse_note($note, $keysig,  '', '                         <time-modification>
 333                                         <actual-notes>3</actual-notes>
 334                                         <normal-notes>2</normal-notes>
 335                                 </time-modification>', $qq);
 336       parse_note($triplet,  $keysig, '<tuplet type="stop"/>',  '                                <time-modification>
 337                                         <actual-notes>3</actual-notes>
 338                                         <normal-notes>2</normal-notes>
 339                                 </time-modification>', $qq);
 340     } elsif ($notes =~ /^((\d+)\(({?(\^)?(g|q)?(\,|\')*(x|xx|b|bb|n)?\d*\.*(\-|A|B|C|D|E|F|G)t?\+?}?)+\;(\d+)\))(.*)$/)  {  # an n-tuplet
 341       ($tuplet, $notes) = ($1,$10);
 342       #      print "N-TUPLET: ".$tuplet." -> ";
 343       $tuplet =~ /^(\d+)\(({?(\,|\')*(x|xx|b|bb|n)?\d*\.*(g|q)?(\-|A|B|C|D|E|F|G)t?\+?}?)(.*);(\d)\)$/gs;
 344       ($combdur, $note, $tuplet, $numval) = ($1,$2,$7,$8);
 345       #print "i=$combdur, n=$numval; $note / $tuplet\n";
 346       my $ind_dur = duration($combdur)/$numval;
 347       # my $norm_notes =
 348       my $act_notes = $numval;
 349       parse_note($note, $keysig, '<tuplet type="start"/>', '                            <time-modification>
 350                                         <actual-notes>'.$act_notes.'</actual-notes>
 351                                         <normal-notes>1</normal-notes>
 352                                 </time-modification>', $qq);
 353       while ($tuplet =~ /^({?(g|q)?(\,|\')*(x|xx|b|bb|n)?\d*\.*(\-|A|B|C|D|E|F|G)t?\+?\}?)([^}]+}?)$/gs) {
 354         ($note, $tuplet) = ($1,$6);
 355         #print "$note / $tuplet\n";
 356         parse_note($note, $keysig,  '', '                               <time-modification>
 357                                         <actual-notes>'.$act_notes.'</actual-notes>
 358                                         <normal-notes>1</normal-notes>
 359                                 </time-modification>', $qq);
 360       }
 361       parse_note($tuplet,  $keysig, '<tuplet type="stop"/>',  '                         <time-modification>
 362                                         <actual-notes>'.$act_notes.'</actual-notes>
 363                                         <normal-notes>1</normal-notes>
 364                                 </time-modification>', $qq);
 365     } elsif ($notes =~ /^(%(\w(-|\+)\d))(.*)$/) {  # Clef change
 366       ($clef,$notes) = ($2,$4);
 367       print OUT "                       <attributes>\n";
 368       print OUT clef ($clef);
 369       print OUT "                       </attributes>\n";
 370     } elsif ($notes =~ /^@(c?\d+(\/\d+)?( \d+\/\d+)*|c\/?|o\.?)\s*(.*)$/) {  # time signatue change
 371       ($timesig,$notes) = ($1,$4);
 372       print OUT "                       <attributes>\n";
 373       print OUT timesignature($timesig);
 374       print OUT "                       </attributes>\n";
 375     } elsif ($notes =~ /^\$((b|x)[ABCDEFG]*)\s*(.*)$/) {  # key signature change
 376       ($keysig, $notes) = ($1, $3);
 377       print OUT "                       <attributes>\n";
 378       print OUT keysignature ($keysig);
 379       print OUT "                       </attributes>\n";
 380     } elsif ($notes =~ /^(:?\/+:?)(.*)$/) {  # Barline (and repeats)
 381       $barline = $1;
 382       $notes = $2;
 383       if ($barline =~ /^:\/\/:/) {
 384         print OUT '                     <barline location="right">
 385                                 <bar-style>light-light</bar-style>
 386                                 <repeat direction="backward"/>
 387                         </barline>
 388 ';
 389       } elsif ($barline =~ /^:\/\/$/ ) {
 390           print OUT '                   <barline location="right">
 391                                 <bar-style>light-heavy</bar-style>
 392                                 <repeat direction="backward"/>
 393                         </barline>
 394 ';
 395       } elsif ($barline =~ /^\/\/$/) {
 396         $type = "light-light";
 397         # At the end of a piece use a light-heavy barline
 398         if ($notes eq "") {
 399           $type = "light-heavy";
 400         }
 401         print OUT "                     <barline location=\"right\">
 402                                 <bar-style>$type</bar-style>
 403                         </barline>
 404 ";
 405       }
 406       print OUT "               </measure>\n";
 407       reset_measure_attributes ();
 408       if ($notes ne "") {
 409         print OUT '             <measure number="'.$meas.'">
 410 ';
 411         if ($barline =~ /^\/\/:$/) {
 412           print OUT '                   <barline location="left">
 413                                 <bar-style>heavy-light</bar-style>
 414                                 <repeat direction="forward"/>
 415                         </barline>
 416 ';
 417         } elsif ($barline =~ /^:\/\/:$/) {
 418           print OUT '                   <barline location="left">
 419                                 <repeat direction="forward"/>
 420                         </barline>
 421 ';
 422         }
 423         print OUT $clefattr;
 424         $meas++;
 425       } else {
 426         $mopen = 0;
 427       }
 428       $toprint .= "bar line\n";
 429     } #elsif ($notes =~ /^(\d*\.*\-)(.*)$/) {
 430       #($rst, $notes) = ($1, $2);
 431       #$toprint .= "rest: $rst\n";
 432       #$rst =~ /^(\d*)(\.*)\-$/;
 433       #($rst, $dots) =($1,$2);
 434       #print OUT '                      <note>
 435         #                       <rest />
 436         #                       <duration>'.duration($rst, $dots).'</duration>
 437 #'.#                            <type>quarter</type>
 438 #'
 439 #                       </note>
 440 #';
 441     elsif ($notes =~ /^\((\=)\)(.*)$/) {  # a bar of rest with a fermata
 442       ($rst, $notes) = ($1, $2);
 443       $toprint .= "rest: $rst\n";
 444       print OUT '                       <note>
 445                                 <rest />
 446                                 <duration>'.($beats*$divisions*4/$beattype).'</duration>
 447                                 <notations>
 448                                         <fermata type="upright"/>
 449                                 </notations>
 450                         </note>
 451 ';
 452     }
 453     elsif ($notes =~ s/(\d+\.*)\(({?(g|q)?(\,|\')*(x|xx|b|bb|n)?\d*\.*(\-|A|B|C|D|E|F|G)t?\+?}?)\)/\($1$2\)/gs) { # pull duration into fermata parentheses
 454       #      print "after replacement: $notes\n"; exit;
 455     }
 456     elsif ($notes =~ /^ +(.*)$/) {
 457       $notes = $1;
 458       print("Invalid space encountered in notes before $notes\n");
 459     }
 460     else {
 461       print_error("got stuck with $notes\n");
 462       $notes = "";
 463     }
 464   }
 465   if ($mopen) {
 466     print OUT "         </measure>\n";
 467     reset_measure_attributes ();
 468   }
 469 }
 470
 471
 472 sub parse_note {
 473   my($note, $keysig, $notation, $addition, $in_qq_group) = @_;
 474
 475   my ($fermata) = (0);
 476   my ($actualnotes, $normalnotes) = (1,1);
 477
 478   if ($addition =~ /^\s*<time-modification>\s*<actual-notes>\s*(\d+)\s*<\/actual-notes>\s*<normal-notes>\s*(\d+)\s*<\/normal-notes>\s*<\/time-modification>\s*$/) {
 479     ($actualnotes, $normalnotes) = ($1, $2);
 480   }
 481
 482   if ($note =~ /^\((.*)\)(.*)$/) {
 483     $note = "$1$2";
 484     $fermata = 1;
 485   }
 486
 487   $note =~ /^({)?(\^)?(g|q)?((\,|\')*)(x|xx|b|bb|n)?(\d*)(\.*)(\-|A|B|C|D|E|F|G)(t?)(\+?)(}?)$/;
 488   my ($beamstart, $chord, $gracecue, $oct, $acc, $dur, $dot, $pitch, $trill, $tie, $beamend) = ($1, $2, $3, $4, $6, $7, $8, $9, $10, $11, $12);
 489
 490   print OUT '                   <note>
 491 ';
 492   if ($gracecue eq "g") {
 493     print OUT '                         <grace slash="yes" steal-time-following="33"/>
 494 ';
 495   }
 496   if ($gracecue eq "q" || $in_qq_group) {
 497     print OUT '                         <grace/>
 498 ';
 499   }
 500   if ($pitch eq "-") {
 501     print OUT "                         <rest />\n";
 502   } else {
 503     if ($chord eq "^") {
 504       print OUT "                               <chord/>\n";
 505     }
 506     print OUT '                         <pitch>
 507                                         <step>'.$pitch.'</step>
 508 '.alter($pitch, $acc, $keysig)
 509 .'                                      <octave>'.octave($oct).'</octave>
 510                                 </pitch>
 511 ';
 512   }
 513   # We are using a rhythmic model, extract the correct duration
 514   $this_duration = "";
 515   $this_head = "";
 516   if (($dur.$dot eq "") && scalar(@rhythmic_model)) {
 517     if ($chord ne "^") {
 518       $rhythmic_model_index = ($rhythmic_model_index +1 ) % scalar(@rhythmic_model);
 519     }
 520     $this_duration = $rhythmic_model[$rhythmic_model_index][0];
 521     $this_head = $rhythmic_model[$rhythmic_model_index][1];
 522   } elsif ($dur.$dot ne "" && scalar(@rhythmic_model)) {
 523     # The rhythmic model ends when a new new rhythmic value appears!
 524     @rhythmic_model = ();
 525   }
 526   if ($gracecue ne "g") {
 527     if (!$this_duration) {
 528       $this_duration = duration ($dur, $dot);
 529     }
 530     print OUT '                         <duration>'.($this_duration*$normalnotes/$actualnotes).'</duration>
 531 ';
 532   }
 533
 534   $tienotation = "";
 535   if ($tie eq "+") {
 536     if ($TIE) {
 537       $tienotation = "                                  <tied type=\"stop\"/>\n";
 538     }
 539     $tienotation .= "                                   <tied type=\"start\"/>\n";
 540     if (!$TIE) {
 541       $TIE = 1;
 542       print OUT '                               <tie type="start"/>
 543 ';
 544     }
 545   } else {
 546     if ($TIE) {
 547       print OUT '                               <tie type="stop"/>
 548 ';
 549       $tienotation = "                                  <tied type=\"stop\"/>\n";
 550       $TIE = 0;
 551     }
 552   }
 553
 554   # Determine graphic notehead: acciaccaturas are always 8th, otherwise use duration
 555   if ($gracecue eq "g") {
 556     print OUT "                                 <type>eighth</type>\n";
 557   } else {
 558     if (!$this_head) {
 559       $this_head = notehead ($dur, $dot);
 560     }
 561     print OUT $this_head;
 562   }
 563   # If we have an explicit accidental on the note, print the <accidental> tag
 564   print OUT accidental_explicit ($acc);
 565
 566   # addition is typically empty or a time-modification tag
 567   print OUT $addition;
 568
 569   # print out beaming information if needed:
 570   if (($beamstart eq "{") && ($beamend eq "}")) {
 571     # Single-note beam means a hook
 572     print OUT "                         <beam>forward hook</beam>\n";
 573   } elsif ($beamstart eq "{") {
 574     ++$BEAM;
 575     print OUT "                         <beam number=\"$BEAM\">begin</beam>\n";
 576   } elsif (($BEAM > 0) && ($beamend eq "}")) {
 577     print OUT "                         <beam number=\"$BEAM\">end</beam>\n";
 578     --$BEAM;
 579   } elsif ($BEAM > 0) {
 580     print OUT "                         <beam number=\"$BEAM\">continue</beam>\n";
 581   }
 582
 583   my $notationbracket = $fermata || $tienotation || ($trill eq "t") || ($notation ne "");
 584   if ($notationbracket) {
 585     print OUT "                         <notations>\n";
 586   }
 587   if ($tienotation) {
 588     print OUT $tienotation;
 589   }
 590   if ($fermata) {
 591     print OUT "                                 <fermata type=\"upright\"/>\n";
 592   }
 593   if ($trill eq "t") {
 594     print OUT '                                 <ornaments>
 595                                                 <trill-mark/>
 596                                         </ornaments>
 597 ';
 598   }
 599   if ($notation ne "") {
 600     print OUT "                         $notation\n";
 601   }
 602   if ($notationbracket) {
 603     print OUT "                         </notations>\n";
 604   }
 605
 606   print OUT '                   </note>
 607 ';
 608
 609   $toprint .= "note: oct. $oct/acc. $acc/dur. $dur/dots $dot/grace,cue $gracecue/pitch $pitch\n";
 610 }
 611
 612 sub reset_measure_attributes {
 613   %active_alterations = {};
 614   # TODO: reset all measure-only attributes, like manual accidentals
 615 }
 616
 617 sub alter {
 618   my ($pitch, $acc, $keysig) = @_;
 619
 620   my $alt = 0;
 621   # If we had the same pitch with explicit alteration already in the current
 622   # measure, that alteration goes on, unless the current note has an explicit
 623   # alteration
 624   if ($acc eq "") {
 625     $acc = $active_alterations{$pitch};
 626   } else {
 627     # Store the explicit alteration of the current pitch!
 628     $active_alterations{$pitch} = $acc;
 629   }
 630
 631   if (index ($keysig,$pitch) > -1) {
 632     $keysig =~ /^(.).*$/gs;
 633     if ($1 eq 'x') {
 634       $alt = 1;
 635     } else {$alt = -1;}
 636   }
 637
 638   my %acc_alt = ("n", 0, "b", -1, "bb", -2, "x", 1, "xx", 2);
 639   if ($acc_alt{$acc} ne "") {
 640     $alt = $acc_alt{$acc};
 641   }
 642
 643   if ($alt != 0) {
 644     return "\t\t\t\t\t<alter>$alt</alter>\n";
 645   }
 646   return "";
 647 }
 648
 649 sub accidental_explicit {
 650   my ($acc) = @_;
 651   my %accidentals = ("xx", "double-sharp", "x", "sharp", "n", "natural", "b", "flat", "bb", "flat-flat");
 652   my $this_acc = $accidentals{$acc};
 653   if ($this_acc) {
 654     return "\t\t\t\t<accidental>$this_acc</accidental>\n";
 655   } else {
 656     return "";
 657   }
 658 }
 659
 660 sub raw_notehead {
 661   my ($duration, $dots) = @_;
 662   my %du=("0", "long", "9", "breve", "1", "whole", "2", "half", "4", "quarter",
 663           "8", "eighth", "6", "16th", "3", "32nd", "5", "64th", "7", "128th");
 664   if ($duration && $du{$duration}) {
 665     my $res = "                         <type>$du{$duration}</type>\n";
 666     $res .= repeat ("                           <dot/>\n", length ($dots));
 667     return $res;
 668   }
 669 }
 670 sub notehead {
 671   my ($duration, $dots) = @_;
 672   if ($duration.$dots ne "") {
 673     my $head = raw_notehead ($duration, $dots);
 674     $old_type = $head if $head;
 675   }
 676   return $old_type;
 677 }
 678
 679 sub parse_rhythmic_model {
 680   (my $model) = @_;
 681   my @m = ();
 682   while ($model =~ s/^([0-9])\s*(\.?)\s*([0-9\.\s]*)$/$3/) {
 683     my ($this_dur, $this_dots) = ($1, $2);
 684     my $dur = raw_duration ($this_dur, $this_dots);
 685     my $notehead = raw_notehead ($this_dur, $this_dots);
 686     push @m, [$dur, $notehead];
 687   }
 688   return @m;
 689 }
 690
 691
 692 sub raw_duration {
 693   my ($duration, $dots) = @_;
 694   my %du=("1",4*$divisions,"2",2*$divisions,"4",$divisions,
 695           "8",$divisions/2,"6",$divisions/4,"3",$divisions/8,
 696           "5",$divisions/16,"7",$divisions/32,
 697           "9",$divisions*8,"0",$divisions*16); # breve/long
 698   my $res = $du{$duration};
 699   if ($res) {
 700     my $add = $res;
 701     while ($dots ne "") {
 702       $add /= 2;
 703       $res += $add;
 704       $dots =~ /^.(.*)$/gs;
 705       $dots = $1;
 706     }
 707   }
 708   return $res;
 709 }
 710 sub duration {
 711   my ($duration, $dots) = @_;
 712   if ($duration.$dots eq "7.") {
 713     print_error ("Neumic notation is not supported by MusicXML!");
 714   }
 715
 716   if ($duration.$dots ne "") {
 717     $old_duration = raw_duration ($duration, $dots);
 718     if ($old_duration eq "") {
 719       print_error("strange duration '$duration'\n");
 720     }
 721   }
 722   return $old_duration;
 723 }
 724
 725 sub octave {
 726   my ($octave) = @_;
 727
 728   if ($octave ne "") {
 729     $octave =~ /^(.)(.*)$/gs;
 730     if ($1 eq ",") {
 731       $old_octave = 4 - length $octave;
 732     } else {
 733       $old_octave = 3 + length $octave;
 734     }
 735   }
 736   return $old_octave;
 737 }
 738
 739 sub clef {
 740   my ($clef) = @_;
 741   my $clefoctave = '';
 742   if ($clef =~ /^(\w)(\-|\+)(\d)$/) {
 743     ($clefsign, $clefline) = ($1, $3);
 744     if ($2 =~ /^\+$/) {
 745       print "Warning: Mensural clefs are not supported by MusicXML, using modern clef (input: $clef)\n";
 746     }
 747     if ($clefsign eq 'g') {
 748       $clefsign = "G";
 749       $clefoctave = "                                   <clef-octave-change>-1</clef-octave-change>\n";
 750     }
 751   } else {
 752     ($clefsign, $clefline) = ("G", 2);
 753   }
 754   return '                              <clef>
 755                                         <sign>'.$clefsign.'</sign>
 756                                         <line>'.$clefline.'</line>
 757 '.$clefoctave.'                         </clef>
 758 ';
 759 }
 760
 761 sub keysignature {
 762   my ($keysig) = @_;
 763
 764   # TODO: How is a change to C major represented? by "$ " or "$x " or "$b "?
 765   #       At the beginning, the $ part is left out, but mid-piece key changes
 766   #       need to way to clear all accidentals! We accept all three cases above!
 767   my %fif=("", 0, "x", 0, "b", 0, "xF", 1, "xFC", 2, "xFCG",3, "xFCGD",4, "xFCGDA",5, "xFCGDAE",6, "xFCGDAEB",7, "bB",-1, "bBE",-2, "bBEA",-3, "bBEAD",-4, "bBEADG",-5, "bBEADGC",-6, "bBEADGCF",-7);
 768   $keysig =~ s/(\s+)|&//gs;  # it is unclear what the & means, so we'll ignore it for now.
 769   $keysig =~ s/\[|\]//gs; # IGNORING brackets around a key sig.
 770   $fifths = $fif{$keysig};
 771   if ($fifths eq "") {
 772     $fifths = "0";
 773     print_error("Strange key signature '$keysig'.\n");
 774   }
 775   return '                              <key>
 776                                         <fifths>'.$fifths.'</fifths>
 777                                 </key>
 778 ';
 779 }
 780
 781
 782 sub timesignature {
 783   my ($timesig) = @_;
 784   my $symbol = "";
 785
 786   if ($timesig =~ /^(o(\.)?)$/) {
 787     if ($2 eq ".") {
 788       $timesig = "9/8";
 789     } else {
 790       $timesig = "3/4";
 791     }
 792     print "Mensural time signature \"$1\" not supported, using $timesig.\n";
 793   }
 794   if ($timesig =~ /^(\d+\/\d+)( \d+\/\d+)+$/ ) {
 795     print "Alternating time signature \"$timesig\" not supported by MusicXML, falling back to $1.\n";
 796     $timesig = $1;
 797   }
 798   if ($timesig =~ /^c((\d+)(\/(\d+))?)$/gs) {
 799     print "Time signature \"$timesig\" not supported by MusicXML, falling back to $1.\n";
 800     $timesig = "$1";  # TODO: it would be better to show the "C". Example: 451.023.814
 801   }
 802
 803   # For missing timesignature, fall back to "c"
 804   if ($timesig eq "0" || $timesig eq "" || $timesig eq "c" ) {
 805     $symbol = "common";
 806     ($beats, $beattype) = (4,4);
 807   } elsif ($timesig =~ /^c\/$/gi) {
 808     $symbol = "cut";
 809     ($beats, $beattype) = (2,2);
 810   } elsif ($timesig =~ /^(\d+)\/(\d+)$/gs) {
 811     ($beats, $beattype) = ($1, $2);
 812   } elsif ($timesig =~/^(\d+)$/gs) {
 813     $symbol = "single-number";
 814     ($beats, $beattype) = ($1,2);
 815   } else {
 816     print_error("Time signature '$timesig' looks strange, falling back to 4/4.\n");
 817     ($beats, $beattype) = (4,4);
 818   }
 819   if ($symbol) {
 820     $symbol = " symbol=\"$symbol\"";
 821   }
 822   $timesig = "                          <time$symbol>
 823                                         <beats>$beats</beats>
 824                                         <beat-type>$beattype</beat-type>
 825                                 </time>
 826 ";
 827   return $timesig;
 828 }
 829
 830 sub print_error {
 831   my ($msg) = @_;
 832
 833   print "\nAn error occurred; context:\n\n$toprint\n
 834 Error: $msg\n";
 835 }
 836
 837 sub read_file {
 838   my ($fn) = @_;
 839   my $res = "";
 840   if ($fn eq "-") {
 841       while (<STDIN>) { $res .= $_; } # read all lines
 842   } else {
 843     if (!(open FH, $fn)) {
 844       return "";
 845     }
 846     while (<FH>) { $res .= $_; } # read all lines
 847     close (FH);
 848   }
 849   return $res;
 850 }