#! /usr/bin/perl
#########################################################################
#        This Perl script is Copyright (c) 2007, Peter J Billam         #
#                c/o DPIW, Hobart, Tasmania, Australia                  #
#                                                                       #
#     This script is free software; you can redistribute it and/or      #
#            modify it under the same terms as Perl itself.             #
#########################################################################

# queries:
#  why can't a note have a midi.duty attribute ?  use dur.ges instead ?
#  Do artics stacc|ten|stacciss modify the duty, or are they just visual?
#  if the note tstamp is absent, what is IMPLIED ? (Sigma dur? dur.ges?)
#  are the Midi_channel and Midi_duty subroutines correct ?
#  tstamp is in "beats" - does this mean crochets, even in 5/8, 6/8, 2/2 etc ?
#  if the measure tstamp isn't specified, what is IMPLIED ?
#  MIDI values are 0..127 :-)  but MIDI channels are 1..16 :-(
#  how to handle <chord><note>.. that disagree about tstamp or dur
#  how does a tie="t" know which tie is is to finish? same pitch same stave?
#  tuplets are difficult. 
#    From the reading app's POV, the <tuplet* should be _before_ the events
#    Of the <tuplet2 startendid, one of the two (start or end) is redundant

my $Version       = '1.8';  # oct, dur and pname are propagated
my $VersionDate   = '27jun2007';
my $Debug         = 0;

eval 'require MIDI'; if ($@) {
   die "you'll need to install the MIDI-Perl module from www.cpan.org\n";
}
import MIDI;
eval 'require XML::Parser'; if ($@) {
   die "you'll need to install the XML::Parser module from www.cpan.org\n";
}
import XML::Parser;

while ($ARGV[$[] =~ /^-([a-z])/) {
   if ($1 eq 'v')      { shift;
		my $n = $0; $n =~ s{^.*/([^/]+)$}{$1};
		print "$n version $Version $VersionDate\n";
		exit 0;
   } elsif ($1 eq 'd') { $Debug = 1; shift;
   } else {
		print "usage:\n";  my $synopsis = 0;
		while (<DATA>) {
			if (/^=head1 SYNOPSIS/)     { $synopsis = 1; next; }
			if ($synopsis && /^=head1/) { last; }
			if ($synopsis && /\S/)      { s/^\s*/   /; print $_; next; }
		}
		exit 0;
	}
}

my %text;
my %attribute;
my $current_element = q{};
my $TPC = 480;
my $miditicksperbeat;
my $ticksatbarstart;
my $ticksthisbar;
my @ticks_chord_end;
my $bar_length;
my %pname2pitch;
my %id2channel;
my $part_id;
my $score_part_id;
my $score_instrument_id;
my $midi_instrument_id;
my $instrument_id;
my %part;          # Hash of Lists of score-events
my @midiscore;
my %started_tie;
my $timewise = 0;
my $within_an_element;
my $is_a_rest;
my $is_a_grace;
my $Propagated_dur = 4;
my $Propagated_oct = 4;
my $Propagated_pname = q{};
my %Dots2dur;
my $Score_key_sig;
my %Staff_key_sig;
my %Staff_num;
my $Layer_id;
my %Staff_TPC;
my %Acci2alter;
my $EventTstamp = 0;   # beats after start of measure
my %Staff_duty;        # default 80%
my $Score_duty;
my %Layer_channel;     # default 1
my %Staff_channel;     # default 1
my $Score_channel;
my $Total_Tuplet_ticks;

&initialise();
$p1 = new XML::Parser();
$p1->setHandlers( Start => \&start, Char => \&text, End => \&end, );
	
$p1->parsefile($ARGV[$[] || '-');
&midi_write() unless $Debug;
exit;

sub start { my ($e, $name, %attr) = @_;
	$current_element = $name;
	$within_an_element = 1;
	$text{$name} = q{};
	if ($name eq 'chord')       {
		@ticks_chord_end = (); $is_a_chord = 1; $attribute{tstamp}   = '';
	} elsif ($name eq 'grace')      { $is_a_grace = 1;
	} elsif ($name eq 'layer')      { $Layer_id = $attr{def};
	} elsif ($name eq 'measure')    {
		$EventTstamp = 0; $ticksthisbar = 0; $bar_length = 0;
		# PROPAGATED means from a previous event in the *same measure*
		$Propagated_dur = 4; $Propagated_oct = 4; $Propagated_pname = q{};
	} elsif ($name eq 'note')       {
		$attribute{dynamics} = 90;
		$attribute{acci}     = '';
		$attribute{tstamp}   = '';
		$attribute{tie}      = '';
		$attribute{tuplet}   = '';
		$is_a_rest =0;  $is_a_grace = 0;
	} elsif ($name eq 'part')       {
		$part_id = $attr{id};
		if ($timewise) { $ticksthisbar = 0; $bar_length = 0;
		} else { $ticksatbarstart = 0;
		}
	} elsif ($name eq 'rest')       {
		$is_a_rest = 1; $attribute{tstamp} = ''; $attribute{tuplet} = '';
	} elsif ($name eq 'scoredef') {
		if ($attr{'midi.tempo'}) {
			my $B = $ticksatbarstart + $ticksthisbar;
			if ($Debug) {
				print "       tempo=$attr{'midi.tempo'} "
				. "ticksatbarstart=$ticksatbarstart ticksthisbar=$ticksthisbar"
				. " B=$B\n";
			}
			my $miditempo = int (0.5 + 60000000/$attr{'midi.tempo'});
			push @midiscore, ['set_tempo', $B, $miditempo];
		}
	} elsif ($name eq 'sound')      {
		delete $attribute{pan}; delete $attribute{tempo};
	} elsif ($name eq 'staffdef')   { $Staff_num = $attr{'n'};
	} elsif ($name eq 'staff')      {
		$Staff_num = $attr{'def'};
		$ticksthisbar = 0;
	} elsif ($name eq 'tempo')       {
		$attribute{tstamp}   = '';
	}
	while (($k,$v)= each %attr) { $attribute{$k} = $v; }
	return;
}
sub text {
	return unless $within_an_element; return unless $current_element;
	my ($e, $text) = @_;
	# handle multiple calls from a single non-markup sequence of chars!
	$text{$current_element} .= $text;  
}
sub end { my ($e, $name) = @_;
	if ($Debug) { print "end $name\n"; }
	$within_an_element = 0;
	$text{$current_element} =~ s/^\s+//;
	$text{$current_element} =~ s/\s+$//;
	if ($name eq 'chord')           { &chord_(@_);
	} elsif ($name eq 'instrdef')   { &instrdef_(@_);
	} elsif ($name eq 'layer')      { $Layer_id = '';
	} elsif ($name eq 'layerdef')   { &layerdef_(@_);
	} elsif ($name eq 'measure')    { &measure_(@_);
	} elsif ($name eq 'note')       { &note_(@_);
	} elsif ($name eq 'rest')       { &rest_(@_);
	} elsif ($name eq 'scoredef')   { &scoredef_(@_);
	} elsif ($name eq 'staffdef')   { &staffdef_(@_);
	} elsif ($name eq 'tempo')      { &tempo_(@_);
	} elsif ($name eq 'time')       { &time_(@_);
	}
	$current_element = '';
}

# --------------- MusicXML-relevant end-of-element routines --------------

sub time_ { my ($e, $name) = @_;
	my $nn     = 0+$text{beats};
	my $bottom = 0+$text{'beat-type'};
	my $dd=0; while (1) { if (1<<$dd >= $bottom) { last; } $dd++; }
	if ($bottom==8) {
		if ($nn%3==0) {$cc=int(0.5+$TPC*1.5);} else {$cc=int(0.5+$TPC*0.5);}
	} elsif ($bottom == 16) {
		if ($nn%3==0) {$cc=int(.5+$TPC*0.75);} else {$cc=int(.5+$TPC*0.25);}
	} elsif ($bottom == 32) {
		if ($nn%3==0) {$cc=int(.5+$TPC*.375);} else {$cc=int(.5+$TPC*.125);}
	} else { $cc = $TPC * 4.0 / $bottom;
	}
	push @midiscore, ['time_signature', $ticksatbarstart,$nn,$dd,$cc,8];
	if ($Debug) { print "time: $nn/$bottom part_id=$part_id\n"; }
	$miditicksperbeat = $cc;
}

# ----------------- MEI-relevant end-of-element routines ----------------

sub chord_ { my ($e, $name) = @_;
	my $B;
	if ($attribute{tstamp}) { $B = $attribute{tstamp}*$TPC;
	} else { $B = $ticksthisbar;
	}
	if ($attribute{'dur.ges'} || $attribute{'dur'}) {  # dur in chord
		$ticksthisbar = $B + &dur2ticks(%attribute);
	} elsif (@ticks_chord_end) {  # dur in the notes
		my $shortest = 10000;
		foreach (@ticks_chord_end) {
			if ($_ < $shortest) { $shortest = $_; }
		}
		$ticksthisbar = $shortest;
	} else {   # default
		$ticksthisbar =  $B + $Propagated_dur*$TPC;
	}
	if ($Debug) { print "chord_: B=$B ticksthisbar=$ticksthisbar\n"; }
	@ticks_chord_end = ();
	$is_a_chord = 0;
}
sub instrdef_ { my ($e, $name) = @_;
	# midi.channel       '1'
	# midi.duty          specifies 'on' part of duty cycle as percent '80'
	# midi.instr         General MIDI instrument number '1'
	# midi.instrname     General MIDI instrument name 'Acoustic Piano'
	# midi.port          MIDI port number '1'
	# midi.track         MIDI track number '1'
	my $id = $attribute{id}; return unless $id;
	my $cha; my $patch;
	if ($attribute{'midi.channel'}) {
		$cha = $attribute{'midi.channel'} - 1;
		$Instr_channel{$id} = $cha;
	}
	if ($attribute{'midi.duty'}) {
		$Instr_duty{$id}    = $attribute{'midi.duty'};
	}
	if ($attribute{'midi.instr'}) {
		$patch = $attribute{'midi.instr'};
		$Instr_patch{$id} = $patch;
	}
	push @midiscore, ['patch_change', $ticksatbarstart, $cha, $patch];
	$ticksatbarstart += 5;
}

sub layerdef_ { my ($e, $name) = @_;   # multiple layers on a stave
	my $id = $attribute{id}; return unless $id;
	if ($attribute{'midi.channel'}) {
		$Layer_channel{$id}    = $attribute{'midi.channel'};
	}
}
sub measure_ { my ($e, $name) = @_;
	if ($Debug) {
		print "end of measure:"
		. " ticksatbarstart=$ticksatbarstart"
		. " bar_length=$bar_length ticksthisbar=$ticksthisbar\n";
	}
	# measure the maximum bar length of all the voices...
	if ($bar_length > $ticksthisbar) { $ticksatbarstart += $bar_length;
	} else { $ticksatbarstart += $ticksthisbar;
	}
	$ticksthisbar = 0;
	if ($Debug) {
		print "ready to start new bar with ticksatbarstart=$ticksatbarstart\n";
	}
}
sub note_ { my ($e, $name) = @_;
	my $D = &dur2ticks(%attribute);
	my $id = $instrument_id || $part_id;
	my $channel = &Midi_channel($Staff_num);
	my $B; if ($attribute{tstamp}) {
		$B = $ticksatbarstart + $attribute{tstamp}*$TPC;
	} else {
		$B = $ticksatbarstart + $ticksthisbar;
	}
	my $alter = 0;
	my $accidental = $attribute{'acci.ges'} || $attribute{'acci'};
	if ($accidental) { $alter = 0+$Acci2alter{$accidental}; }
	my $oct;
	if ($attribute{oct}) {
		$oct = $attribute{oct}; $Propagated_oct = $oct;
	} else { $oct = $Propagated_oct;
	}
	my $pname;
	if ($attribute{pname}) {
		$pname = $attribute{pname}; $Propagated_pname = $pname;
	} else { $pname = $Propagated_pname;
	}
	my $note = 12 + 12*$oct + $pname2pitch{$pname} + $alter;
	my $velocity = int (0.5 + 0.9 * $attribute{dynamics});
	if ($velocity > 127)    { $velocity = 127;
	} elsif ($velocity < 0) { $velocity = 0;
	}
	# should save-aside the whole measure, mine the <tuplet*, then process
	if ($attribute{tuplet} eq 'i1') {
		$Total_Tuplet_ticks = &dur2ticks(%attribute);
		$D = int(0.5 + .6667*$D);  # evil kludge only works for triplets
	} elsif ($attribute{tuplet} eq 'm1') {
		$Total_Tuplet_ticks += &dur2ticks(%attribute);
		$D = int(0.5 + .6667*$D);  # evil kludge only works for triplets
	} elsif ($attribute{tuplet} eq 't1') {
		$Total_Tuplet_ticks += &dur2ticks(%attribute);
		$D = int(0.5 + .6667*$D);  # evil kludge only works for triplets
		# "the default is to calculate the total duration of the
		#  included notes and use the next shorter un-dotted value."
		# but we might special-case 2 or 4 equal notes to the next shorter
		# dotted value?  or store them and wait for a <tuplet* element :-(
		# in which case this code will come at the measure's end
		my $tuplet_ticks = $TPC/32;
		my $new_try = $tuplet_ticks+$tuplet_ticks;
		foreach (1..7) {
			if ($new_try > $Total_Tuplet_ticks) { last; }
			$tuplet_ticks = $new_try;
			$new_try = $tuplet_ticks + $tuplet_ticks;
		}
		if ($Debug) {
			print "Total_Tuplet_ticks=$Total_Tuplet_ticks "
			 . "tuplet_ticks=$tuplet_ticks\n";
		}
	}
	my $tie_key = "$Staff_num $pname $oct";
	if ($Debug) {
		print "note: Staff_num=$Staff_num oct=$oct tie_key="
		. "'$tie_key' dur=$attribute{dur} B=$B D=$D\n"
		. " channel=$channel velocity=$velocity"
		. " note=$note id=$id\n";
	}
	if ($attribute{tie} eq 'i') {
		$started_tie{$tie_key} = $B;
		if ($Debug) { print "   starting tie '$tie_key'\n"; }
	} elsif ($attribute{tie} eq 'm') {
		if ($Debug) { print "   tie already started; prolonged\n"; }
	} elsif ($attribute{tie} eq 't') {
		my $end_time = $B + $D;
	 	$B = $started_tie{$tie_key};
		$D = $end_time - $B;
		if ($Debug) { print "   terminating tie '$tie_key' B=$B D=$D\n"; }
		push @midiscore, ['note',$B,$D,$channel,$note,$velocity];
	 	delete $started_tie{$tie_key};
	} else {
		push @midiscore, ['note', $B, $D, $channel, $note, $velocity];
	}
	if (! $is_a_grace) {
		if ($is_a_chord) {
			push @ticks_chord_end, $B+$D;
		} else {
			$ticksthisbar = $B + $D;
			if ($Debug) { print "   ticksthisbar=$ticksthisbar\n"; }
		}
	}
	$instrument_id = q{};
}
sub rest_ { my ($e, $name) = @_;
	my $D = &dur2ticks(%attribute);
	$ticksthisbar += $D;   # should respect tstamp
	if ($Debug) { print "rest: D=$D ticksthisbar=$ticksthisbar\n"; }
}
sub scoredef_ { my ($e, $name) = @_;
	# dur.default        default duration, '4'

	# grace              do grace notes get time from the current (acc) or
	#                    previous (unacc) main note? 'acc'
	# tune.pname         name of tuning reference pitch 'a'
	# tune.Hz            frequency of tuning reference pitch '440'
	# tune.temper        temperament 'equal'
	# key.sig            (7f|6f|5f|4f|3f|2f|1f|0|1s|2s|3s|4s|5s|6s|7s|mixed)
	# octave.default     when not specified on 1st note of the measure, '4'
	# midi.duty          specifies 'on' part of duty cycle as percent '80'
	if ($attribute{'dur.default'}) {
		$Propagated_dur = $attribute{'dur.default'};
	}
	if ($attribute{'key.sig'}) {
		$Score_key_sig = $attribute{'key.sig'};
	}
	if ($attribute{'midi.div'}) {
		$Score_TPC{$n} = $attribute{'midi.div'};
	}
}
sub staffdef_ { my ($e, $name) = @_;
	# n                  INTEGER, '1'
	# clef.line          position of the clef, '2'
	# clef.shape         clef, 'G'
	# clef.trans         octave shift indicated by the clef, (0|8va|8vb|15va)
	# midi.channel       '1'
	# midi.div           %INTEGER;             %INHERITED;
	# midi.duty          specifies 'on' part of duty cycle as percent '80'
	# midi.instr         General MIDI instrument number '1'
	# midi.instrname     General MIDI instrument name 'Acoustic Piano'
	# midi.port          MIDI port number '1'
	# midi.track         MIDI track number '1'
	my $n = $attribute{'n'} || 1;
	if ($attribute{'key.sig'}) {
		$Staff_key_sig{$n} = $attribute{'key.sig'};
	}
	if ($attribute{'midi.channel'}) {
		$Staff_channel{$n} = $attribute{'midi.channel'};
	}
	if ($attribute{'midi.div'}) {
		$Staff_TPC{$n} = $attribute{'midi.div'};
	}
	if ($attribute{'midi.duty'}) {
		$Staff_Midi_duty{$n} = $attribute{'midi.duty'};
	}
}
sub tempo_ { my ($e, $name) = @_;
	my $B = $ticksatbarstart + $attribute{tstamp}*$TPC;
	my $cro_per_min = $attribute{value};
	my $miditempo = int (0.5 + 60000000/$attribute{value});
	if ($Debug) {
		print "B=$B cro_per_min=$cro_per_min miditempo=$miditempo\n";
	}
	push @midiscore, ['set_tempo', $B, $miditempo];
}

# ------------------ mostly taken from muscript ---------------
sub initialise {
	$miditicksperbeat = $TPC;
	$ticksatbarstart  = 0;
	$tickspreviousbar = 0;
	$ticksthisbar     = 0;
	$midibarparts     = '2.4';  # default guesses 4/4 at 100 cro/min
	%pname2pitch = ( c=>0,d=>2,e=>4,f=>5,g=>7,a=>9,b=>11, );
	%Dots2dur    = ( 0=>1.0, 1=>1.5, 2=>1.75, 3=>1.875, 4=>1.9375, );
	%Acci2alter  = ( ff=>-2, f=>-1, s=>1, ss=>2, );
}

sub reset_accidentalled { my ($num,$sign) = $_[$[]=~/^([1-7])([sf])$/;
    if ($sign eq 's') {     @pitches = ('F','C','G','D','A','E','B');
    } elsif ($sign eq 'f') { @pitches = ('B','E','A','D','G','C','F');
    }
    %accidentalled = ();
    my $i = 0.5; while ($i < $num) {
        my $letter = shift @pitches;
        $accidentalled{"${letter}__"} = $sign;
        $accidentalled{"${letter}_"}  = $sign;
        $accidentalled{"${letter}"}   = $sign;
        $letter = lc $letter;
        $accidentalled{"${letter}"}   = $sign;
        $accidentalled{"${letter}~"}  = $sign;
        $accidentalled{"${letter}~~"} = $sign;
        $i+=1;
    }
}
sub local_TPC { my $staff_n = shift @_;
	my $tpc = $Staff_TPC{$Staff_num} || $Score_TPC || 96;
	if ($Debug) {
		print "local_TPC: Staff_TPC{$Staff_num}=$Staff_TPC{$Staff_num} "
		. "Score_TPC=$Score_TPC tpc=$tpc\n";
	}
	return $tpc;
}
sub Midi_channel { my $staff_n = shift @_;
	my $channel = $Layer_channel{$Layer_id}
	 || $Staff_channel{$Staff_num} || $Score_channel || 1;
	if ($Debug) { print
		"Midi_channel: Layer_channel{$Layer_id}=$Layer_channel{$Layer_id} "
		. "Staff_channel{$Staff_num}=$Staff_channel{$Staff_num} "
		. "Score_channel=$Score_channel channel=$channel\n";
	}
	return $channel - 1;
}
sub Midi_duty { my $staff_n = shift @_;
	my $duty = $Staff_duty{$Staff_num} || $Score_duty || 85;
	if ($Debug) { print
		"Midi_duty: Staff_duty{$Staff_num}=$Staff_duty{$Staff_num}"
		. " Score_duty=$Score_duty duty=$duty\n";
	}
	return $duty;
}
sub dur2ticks { my %attribute = @_;
	if ($attribute{'dur.ges'} =~ /^\d+$/) {
		return int(.5 + $attribute{'dur.ges'}*$TPC/&local_TPC($Staff_num)); 
	}
	my $dur = $attribute{'dur'};
	if ($dur) { $Propagated_dur = $dur;
	} else    { $dur = $Propagated_dur;
	}
	return 0 unless $dur;
	my $dots = $attribute{'dots'} || 0;
	if      ($dur eq 'breve') { $dur = 0.5;
	} elsif ($dur eq 'long')  { $dur = 0.25;
	}
	return int(0.5 + 4*$TPC*$Dots2dur{0+$dots}/$dur);
}
sub control_change { my ($id, $cha, $num, $percent) = @_;
	my $val = int (0.5 + $percent*1.27);  # 0..100 to 1..127
	if ($val>127) { $val=127; } elsif ($val<0) { $val=0; }
	push @midiscore,['control_change',$ticksatbarstart,$cha,$num,$val];
}
sub midi_write {
    my ($events_r,$ticks) = MIDI::Score::score_r_to_events_r(\@midiscore);
    if (!$events_r) { die "MIDI::Score::score_r_to_events_r failed\n"; }
    my $track = MIDI::Track->new( {'events'=>$events_r} );
    if (!$track) { die "MIDI::Track->new failed\n"; }
    my $opus=MIDI::Opus->new({'format'=>0,'ticks'=>$TPC,'tracks'=>[$track]});
    if (!$opus) { die "MIDI::Opus->new failed\n"; }
    $opus->write_to_file( '>-' );
}

#sub midi_write {
#	my @tracks;
#	foreach my $id (sort keys %part) {
#		my ($events_r,$ticks) = MIDI::Score::score_r_to_events_r($part{$id});
#		if (!$events_r) { die "MIDI::Score::score_r_to_events_r failed\n"; }
#		my $track = MIDI::Track->new( {'events'=>$events_r} );
#		if (!$track) { die "MIDI::Track->new failed\n"; }
#		push @tracks, $track;
#	}
#	my $format = 0; if (1 < scalar @tracks) { $format = 1; }
#	my $opus = MIDI::Opus->new({'format'=>$format,'ticks'=>$TPC});
#	$opus->tracks(@tracks);
#	if (!$opus) { die "MIDI::Opus->new failed\n"; }
#	$opus->write_to_file( '>-' );
#}

__END__

=pod

=head1 NAME

mei2mid - Perl script to convert MEI to MIDI

=head1 SYNOPSIS

 mei2mid Example.mei > Example.mid
 mei2mid Example.mei | aplaymidi -
 mei2mid -v      # prints version number

=head1 DESCRIPTION

This script converts a musical score in MEI format into a MIDI file.
It uses the XML::Parser module to read the MEI input,
and the MIDI-Perl module to put together the midi output.

It was written to assist in debugging "muscript -mei".

It seems to work correctly on all the sample MEI files
at http://www.lib.virginia.edu/digital/resndev/mei/
and in http://www.pjb.com.au/met/tests
and on all output from "muscript -mei".

=head1 OPTIONS

=over 3

=item I<-d>

Generates Debugging information on the standard-output.

=item I<-v>

Prints Version number.

=back

=head1 AUTHOR

Peter J Billam  http://www.pjb.com.au/comp/contact.html

=head1 CREDITS

Based on the CPAN modules XML::Parser and MIDI-Perl

=head1 SEE ALSO

MEI ( http://www.lib.virginia.edu/digital/resndev/mei/ ),
muscript ( http://www.pjb.com.au/muscript/ ),
XML::Parser, MIDI, MIDI-Perl

=cut