#!/usr/bin/env perl
# pbl2mid 1.0
# Greg Kennedy 2011
# convert Voyetra Music Write Plus .pbl files to standard .mid

use strict;

# Perl trim function to remove whitespace from the start and end of the string
sub trim($)
{
	my $string = shift;
	$string =~ s/^\s+//;
	$string =~ s/\s+$//;
	return $string;
}

my %note_l_type =
( 4 => 1,
  3 => 2,
  2 => 4,
  1 => 8,
  0 => 16);

my %pay_to_mid = 
(
  0x00 => 0,
  0x01 => 2,
  0x02 => 4,
  0x03 => 5,
  0x04 => 7,
  0x05 => 9,
  0x06 => 11
);

# read "b" bytes and return the result, or die if "b" bytes are not available
sub rb
{
  my $fh = shift;
  my $bytes_to_read = shift;
  my $buffer;
  my $bytes_read = read($fh,$buffer,$bytes_to_read);

  if ($bytes_read != $bytes_to_read)
  {
    die "Short read: asked for $bytes_to_read bytes, got $bytes_read back, buffer='$buffer'\n";
  }
  return $buffer;
}

# read a string from file: first byte tells strlen, then get string, then null
#  termination
sub rs
{
  my $fh = shift;
  my $strlen = ord(rb($fh,1));

  my $retstr = rb($fh,$strlen);

  if (ord (rb ($fh, 1)) != 0x00) { die "No null terminator on string $retstr at pos " . tell ($fh) . " in fh\n"; }

  return $retstr;
}

# Validate next byte: read a byte, compare to arg2, die if different
sub vb
{
  my $fh = shift;
  my $expected_val = shift;
  my $got_val = ord(rb($fh,1));
  if ($got_val != $expected_val) { die "Validation failed: expected $expected_val, got $got_val at pos " . tell ($fh) . " in fh\n"; }
}

# print debug message "unexpected tag"
sub ut
{
  my $dat = shift;
  my $dat2 = shift;
  my $expect = shift;
  my $fh = shift;

  printf("Unexpected tag %02x after %02x (expect: %02x) at fpos=%04x\n", $dat2, $dat, $expect, tell($fh));
}
#####
# MAIN PROGRAM

# some filehandles
my ($fp, $fpo);

# Open input .pbl file
open ($fp, "<$ARGV[0]") or die "Couldn't open: $!\n";
binmode($fp);

# Declare a buffer
my $buffer;

# First bytes in file are "magic number" identification
$buffer = rb($fp,4);
if ($buffer != 'VPub') { die "Does not look like a valid .pbl file: no VPub tag"; }
vb($fp,0x00); # This is probably a null-terminator for VPub tag

my $version = ord(rb($fp,1));
		# I've seen 1 and 2 here... could be "plus or non-plus"
vb($fp,0x00);

# Next up are stored song info
my $sng_title = rs($fp);
my $sng_composer = rs($fp);
my $sng_copyright = rs($fp);
my $sng_contributor = "";
my $sng_style_tempo = "";
if ($version == 2) {
 $sng_contributor = rs($fp);
 $sng_style_tempo = rs($fp);
}

vb($fp,0x01); # Unsure of what these mean, common to all PBLs
rb($fp,1); # Some PBLs have a 15 here instead of a 128
#vb($fp,0x80);
rb($fp,1); # Some PBLs have a 0 here instead of a 8
#vb($fp,0x08);
vb($fp,0x00);
rb($fp,1); # Some PBLs have a 0 here instead of 0x0B
#vb($fp,0x0B);
seek($fp,4,1); #advance an int, don't know what this is
my $beats_per_minute = unpack("v",rb($fp,2));
my $gm_instrument = unpack("v",rb($fp,2));

print "Song is " . $beats_per_minute . " BPM.  GM instrument=" . $gm_instrument . "\n";

print "At position " . sprintf("%02x",tell($fp)) . " in file.\n";

# AFAIK, a song _cannot_ start until 0E0C/D.
my $in_main = 0;

# Begin song data
# TODO : lots of decoding work : )
my @yoffset;

### Buffer of all MIDI events
# It is an "array of arrays", where each element is a subarray of:
# ( midi_time, event, param, <optional more params>)
my @midibuf_t;
my @midibuf_b;
my $midi_dat_len_t = 0;
my $midi_dat_len_b = 0;

my $next_len=0;

my $first_timesig_pos = -1;
my $num_staves = 1;

# HACK to determine Treb / Bass
my $clef = 1;

my $maxpos;

while (!eof($fp))
{
  # Read a byte.
  my $dat = ord(rb($fp,1));
  if ($dat == 0x0E) {
    my $dat2 = ord(rb($fp,1));
    if ($dat2 == 0x0C || $dat2 == 0x0D) {
      if (!$in_main) { print "Located start of readable data at " . tell($fp) . "\n";
      $in_main = 1; }
# 0E0C (4 bytes start pos, 2 bytes orig val, 2 bytes
#  target val2, 4 bytes length(?) )

# This is a "measure" tag which denotes a measure's start
#  point, length, and a couple of range values which are
#  probably used to denote X coords on the page or something.

# I am unsure of diff between 0E0C and 0E0D.

      my $pos = unpack("V",rb($fp,4));
      my $val = unpack("v",rb($fp,2));
      my $val2 = unpack("v",rb($fp,2));
      my $pos2 = unpack("V",rb($fp,4));
      print sprintf("%02X%02X",$dat,$dat2) . ": MEASURE: position $pos, length $pos2, X start $val, X end $val2\n";
$yoffset[int($pos / 1920)] = $val2;
    } else {
      ut($dat,$dat2,0x0C,$fp);
    }
  } elsif ($in_main) {
  if ($dat == 0x16)
  {
    # Second byte into dat2.
#  0x16 is a line, I think.  It comes off a note and goes up or down.
    my $dat2 = ord(rb($fp,1));
    #if ($dat2 == 0x1C) {
      my $pos = unpack("V",rb($fp,4));
      my $x_pos = unpack("v",rb($fp,2));
      my $y_start = unpack("v",rb($fp,2));
      my $y_end = unpack("v",rb($fp,2));
      my $flip = ord(rb($fp,1));
      print sprintf("%02X%02X",$dat,$dat2) . " VERTICAL_LINE: sng_pos=" . $pos . ": x=$x_pos, y_start=$y_start, y_end=$y_end, flip=$flip\n";
    #} else {
    #  ut($dat,$dat2,0x1C,$fp);
    #}
  } elsif ($dat == 0x17)
  {
    # 8 byte payload on 171C...
    my $dat2 = ord(rb($fp,1));
    if ($dat2 == 0x1C) {
      my $pos = unpack("V",rb($fp,4));
      my $x_start = unpack("v",rb($fp,2));
      my $x_end = unpack("v",rb($fp,2));
      my $payload = rb($fp,2);
      my $y_end = unpack("v",rb($fp,2));
      print sprintf("%02X%02X",$dat,$dat2) . " HORIZONTAL_LINE: sng_pos=" . $pos . ": x=$x_start -> $x_end, y_end=$y_end, payload=" . unpack("H*",$payload) . "\n";
    } else {
      ut($dat,$dat2,0x1C,$fp);
    }
  } elsif ($dat == 0x12) {
    my $dat2 = ord(rb($fp,1));
    #if ($dat2 == 0x1C) {
      my $pos = unpack("V",rb($fp,4));
      my $note_smth = ord(rb($fp,1));
      my $x_pos = unpack("v",rb($fp,2));
      my $y_pos = unpack("v",rb($fp,2));
      my $note_l = ord(rb($fp,1));
      my $payload2 = unpack("c",(rb($fp,1)));
# last byte is NOTE NAME, in reference to BOTTOM LINE OF STAFF=0

      # 1C / 0E probably denotes "has flag" / "does not have flag"
      #  rests are typically 0E but do not confuse with a whole note!
      # note_smth is PROBABLY "image" / "character (from TTF)"
      #  45 = filled quarter/eigth/etc, 46 = unfilled (half note), 47=whole
      if ($dat2 == 0x0E && $note_smth != 47) {
if ($pos > $maxpos) { $maxpos = $pos; $clef = 1; } elsif ($pos < $maxpos) { $clef = 2; }

        print sprintf("%02X%02X",$dat,$dat2) . " REST: sng_pos=" . $pos . ": x=$x_pos, y=$y_pos, note_smth=$note_smth, note_l=$note_l, payload=$payload2\n";
      } elsif ($dat2 == 0x12) {
if ($pos > $maxpos) { $maxpos = $pos; $clef = 1; } elsif ($pos < $maxpos) { $clef = 2; }

        print sprintf("%02X%02X",$dat,$dat2) . " VOLUME: sng_pos=" . $pos . ": x=$x_pos, y=$y_pos, note_smth=$note_smth, note_l=$note_l, payload=$payload2\n";
      } elsif ($note_smth < 45 || $note_smth > 47) {
        print sprintf("%02X%02X",$dat,$dat2) . " ??? probably MISDETECTION: sng_pos=" . $pos . ": x=$x_pos, y=$y_pos, note_smth=$note_smth, note_l=$note_l, payload=$payload2\n";
      } else {
if ($pos > $maxpos) { $maxpos = $pos; $clef = 1; } elsif ($pos < $maxpos) { $clef = 2; }

        print sprintf("%02X%02X",$dat,$dat2) . " NOTE: sng_pos=" . $pos . ": x=$x_pos, y=$y_pos, note_smth=$note_smth, note_l=$note_l, payload=$payload2";

my ($octave, $noteval);
print " CLEF=" . $clef . ", ";

if ($clef == 1) { # || $num_staves == 1) {
  $octave = int(($payload2 + 2 + 35) / 7);
  $noteval = (($octave * 12) + $pay_to_mid{($payload2 + 2) % 7}) % 128;

# noteon
     push(@midibuf_t,[(int($pos / 120)), 0x90, $noteval]);
     $midi_dat_len_t += 4;
# noteoff
     push(@midibuf_t,[(int($pos / 120)) + $note_l_type{$next_len}, 0x80, $noteval]);
     $midi_dat_len_t += 4;
} else {
  $octave = int(($payload2 + 4 + 21) / 7);
  $noteval = (($octave * 12) + $pay_to_mid{($payload2 + 4) % 7}) % 128;
# noteon
     push(@midibuf_b,[(int($pos / 120)), 0x90, $noteval]);
     $midi_dat_len_b += 4;
# noteoff
     push(@midibuf_b,[(int($pos / 120)) + $note_l_type{$next_len}, 0x80, $noteval]);
     $midi_dat_len_b += 4;
}
print " $octave... ==> MIDI NOTE $noteval for " . $note_l_type{$next_len} . ".\n";
    }
  } elsif ($dat == 0x1C) {
    my $dat2 = ord(rb($fp,1));
    if ($dat2 == 0x0E) {
# Beats me... 1C0E , pos , 6 byte payload
      my $pos = unpack("V",rb($fp,4));
      $next_len = ord(rb($fp,1));
      my $payload = rb($fp,5);
      print "1C0E: note meta " . $pos . ": len=$next_len " . unpack("H*",$payload) . "\n";
    } else {
      ut($dat,$dat2,0x0E,$fp);
    }
  } elsif ($dat == 0x1A) {
    my $dat2 = ord(rb($fp,1));
    if ($dat2 == 0x0E) {
# Beats me... 1A0E , pos , 12 byte payload
#  I THINK this is a "flag" topper, which has
#  a from / to and probably a number of lines.
      my $pos = unpack("V",rb($fp,4));
      my $payload = rb($fp,2);
      my $start_x = unpack("v",rb($fp,2));
      my $start_y = unpack("v",rb($fp,2));
      my $end_x = unpack("v",rb($fp,2));
      my $end_y = unpack("v",rb($fp,2));
      my $payload2 = rb($fp,2);
      print sprintf("%02X%02X",$dat,$dat2) . ": FLAG: position $pos, X $start_x -> $end_x, Y $start_y -> $end_y, payload: " . unpack("H*",$payload) . " / " . unpack("H*",$payload2) . "\n";
    } else {
      ut($dat,$dat2,0x0E,$fp);
    }
  } elsif ($dat == 0x14) {
    my $dat2 = ord(rb($fp,1));
    if ($dat2 == 0x0E) {
#  140E:  Time signature
#    First 2 bytes (after POS that is) denote beats-per-measure, noteval-per-beat
#    Next up, ???
#    Then an ASCII number (font reference into Mozart.ttf)
#    Then, looks like a bounding-box for blitting
# 140E @ sng_pos=0: 0404 0200 3400 4501 0c01 5e01 de01 00 7501 02 00 3400 4501 3001 5e01 0202 00 9901

# No idea about this.  4 byte position then
#  32 byte unknown payload (?)
      my $pos = unpack("V",rb($fp,4));
      my $bpm = ord(rb($fp,1));
      my $npb = ord(rb($fp,1));
      my $pay1 = rb($fp,2);
      my $bpm_chr = chr(unpack("v",rb($fp,2)));
      my $xpos1 = unpack("v",rb($fp,2));
      my $xpos2 = unpack("v",rb($fp,2)); # really, ypos
      my $xpos3 = unpack("v",rb($fp,2));
      my $xpos4 = unpack("v",rb($fp,2));
      my $pay2 = ord(rb($fp,1));
      my $xpos5 = unpack("v",rb($fp,2));

      my $pay3 = rb($fp,2);
      my $npb_chr = chr(unpack("v",rb($fp,2)));
      my $xpos6 = unpack("v",rb($fp,2));
      my $xpos7 = unpack("v",rb($fp,2));
      my $xpos8 = unpack("v",rb($fp,2));
      my $xpos9 = unpack("v",rb($fp,2));
      my $pay4 = ord(rb($fp,1));
      my $xposA = unpack("v",rb($fp,2));
      print "140E TIMESIG: sng_pos=" . $pos . ": ts $bpm/$npb ($bpm_chr/$npb_chr): $xpos1, $xpos2, $xpos3, $xpos4 / $xpos5 / $xpos6, $xpos7, $xpos8, $xpos9 / $xposA pay=" . unpack("H*",$pay1) . "/$pay2, " . unpack("H*",$pay3) . "/$pay4\n";

# Hack Supreme
if ($first_timesig_pos < 0) { $first_timesig_pos = $pos; }
elsif ($pos == $first_timesig_pos) { $num_staves = 2; }
    } else {
      ut($dat,$dat2,0x0E,$fp);
    }
  } elsif ($dat == 0x06) {
    my $dat2 = ord(rb($fp,1));
    if ($dat2 == 0x00) {
      my $pos = unpack("V",rb($fp,4));
      # This is a weird one with some variable payload sizes.
      #  Seems to be controlled by what comes back in first int value.
      #  Just pack it up for now and stop at a sentinel value.
      # ALSO: Lyrics!
      # FYI: some c0 crops up repeatedly but the usage eludes me.
      my $len = unpack("v",rb($fp,2));
      my $payload = "";
      #my $payload = rb($fp,2);
      #if (unpack("H*",$payload) eq '00000000') {
      if ($len == 0x0001) {
        $payload = rb($fp,3);  # Generally, 01000000 reads 01.
        print "0600: ENDLINE: $len bytes: '" . unpack("H*",$payload) . "' at ($pos)\n";
      }
      else {
        if ($len != 0x0000) {
          $payload = rb($fp,$len-1);  # Next LEN-1 bytes are lyric
          vb($fp,0x00);               # LYRIC null-terminator
          print "0600: LYRIC: $len bytes: '$payload' at ($pos)\n";

# Super lyrics hackadoodle
          my $trim_text = trim($payload);
          print "\tTrimmed: " . length($trim_text) . " bytes: '$trim_text'\n";

# hack reposition
my $fixed_pos = $pos - 5180;
if ($fixed_pos < 0) { $fixed_pos = 0; }

my $offset = 0;
while (length($trim_text))
{
    my $under128 = substr($trim_text,0,127);
    $trim_text = substr($trim_text,127);
     push(@midibuf_t,[$offset + (int($fixed_pos / 120)), 0x05, $under128]);
     $midi_dat_len_t += (4 + length($under128));
   $offset ++;
}
          $payload = "";
          # after a LYRIC comes font and positional crap
        }
        # Sentinel values. c000c000 is at EOF,
        #  00800000 terminates the 0600 bytestream.
          while ((unpack("H*",substr($payload,-4) ) ne 'c000c000') &&
                 (unpack("H*",substr($payload,-4) ) ne '00800000') ) {
            $payload .= rb($fp,1);
        }
        print "0600: SPECIAL:   " . length($payload) . " bytes: " . unpack("H*",$payload) . " ($pos)\n";
      }
    } else {
      ut($dat,$dat2,0x00,$fp);
    }
  } elsif ($dat == 0x11) {
    my $dat2 = ord(rb($fp,1));
    if ($dat2 == 0x0E || $dat2 == 0x1C || $dat2 == 0x12) {
# This looks like a bar line.
      my $pos = unpack("V",rb($fp,4));
      my $pay1 = ord(rb($fp,1));
      my $x = unpack("v",rb($fp,2));
      my $y = unpack("v",rb($fp,2));
      my $pay2 = ord(rb($fp,1));
      print sprintf("%02X%02X",$dat,$dat2) . ": BARLINE: position $pos, X=$x,y=$y, payload: $pay1 / $pay2\n";
    } else {
      ut($dat,$dat2,0x0E,$fp);
    }
#  } elsif ($dat == 0xAC) {
#    my $dat2 = ord(rb($fp,1));
#    if ($dat2 == 0x01) {
#      my $pos = unpack("V",rb($fp,4));
#      print "AC01...! sng_pos=" . $pos . "\n";
#    } else {
#      ut($dat,$dat2,0x01,$fp);
#    }
#  } elsif ($dat == 0x00) {
#    my $dat2 = ord(rb($fp,1));
#    if ($dat2 == 0x00) { print "Missed a 0x0000 at " . sprintf("%04x",tell($fp)) . "\n"; } 
#    }
  } else {
    printf("Lost sync, unknown tag %02x at fpos=%04x in $ARGV[0]\n",$dat,tell($fp));
  }
  }

# SUPER DUUUPER CLEF HACKADOODLE
}

close($fp);

print "===ALL DONE READING===\n\tWriting MIDI file...\n";
if (exists ($ARGV[1])) { open($fpo,">$ARGV[1]") or die "couldn't open output $ARGV[1]: $!\n"; } else {
open($fpo,">$ARGV[0].mid") or die "couldn't open output $ARGV[0].mid: $!\n";
}
binmode($fpo);

if ($num_staves == 2) {
  print $fpo "MThd" . pack("N",6) . pack("n",1) . pack("n",2) . pack("n!",4);
} else {
  print $fpo "MThd" . pack("N",6) . pack("n",0) . pack("n",1) . pack("n!",4);
}

### TREBLE / track1
print $fpo "MTrk" . pack("N",
 4 + length($sng_title) +
 4 + length($sng_composer) +
 4 + length($sng_copyright) +
 4 + length($sng_contributor) +
 4 + length($sng_style_tempo) +
 7 +
 3 +
 $midi_dat_len_t +
 4);

my $midipos = 0;

# dump text to MIDI as meta messages
print $fpo pack("CCCC",0x00, 0xFF, 0x03, length($sng_title)) . $sng_title;
print $fpo pack("CCCC",0x00, 0xFF, 0x02, length($sng_copyright)) . $sng_copyright;
print $fpo pack("CCCC",0x00, 0xFF, 0x01, length($sng_composer)) . $sng_composer;
print $fpo pack("CCCC",0x00, 0xFF, 0x01, length($sng_contributor)) . $sng_contributor;
print $fpo pack("CCCC",0x00, 0xFF, 0x01, length($sng_style_tempo)) . $sng_style_tempo;

my $mqpn = int(60000000 / $beats_per_minute);
my $t1 = $mqpn % 256;
my $t2 = ($mqpn / 256) % 256;
my $t3 = (($mqpn / 256) / 256) % 256;
  print $fpo pack("CCCCCCC",0x00,0xFF,0x51,0x03, $t3, $t2, $t1);
  print $fpo pack("CCC",0x00,0xC0,$gm_instrument);

# sort MIDI events by song position
foreach my $event_ref (sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1]} @midibuf_t )
{
  my @event = @{$event_ref};

# printf ("%02X: %02X, %s\n", ($event[0] - $midipos) % 128,$event[1],$event[2]);
  if ($event[1] != 0x05) {
    print $fpo pack("CCCC",($event[0] - $midipos) % 128,$event[1],$event[2],0x7f);
  } else {
    print $fpo pack("CCCC",($event[0] - $midipos) % 128,0xFF,0x05,length($event[2])) . $event[2];
  }

  $midipos = $event[0]; # advance midi pos
                             # not technically correct: any len should work
                             # but I don't want to get into variable len
                             # delta-t : )
}

print $fpo pack("CCCC",0x00,0xFF,0x2F,0x00);

if ($num_staves > 1) {
print $fpo "MTrk" . pack("N",
 3 +
 $midi_dat_len_b +
 4);

# reset midipos
$midipos = 0;

  print $fpo pack("CCC",0x00,0xC0,$gm_instrument);

# sort MIDI events by song position
foreach my $event_ref (sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @midibuf_b )
{
  my @event = @{$event_ref};

# printf ("%02X: %02X, %s\n", ($event[0] - $midipos) % 128,$event[1],$event[2]);
    print $fpo pack("CCCC",($event[0] - $midipos) % 128,$event[1],$event[2],0x7f);

  $midipos = $event[0]; # advance midi pos
                             # not technically correct: any len should work
                             # but I don't want to get into variable len
                             # delta-t : )
}

print $fpo pack("CCCC",0x00,0xFF,0x2F,0x00);
}
close($fpo);