{$A+,B-,D-,E-,F-,G+,I+,L-,N+,O-,P+,Q-,R-,S+,T-,V+,X+,Y-}
{$M 16384,0,655360}
(**Programm ist Public Domain************************************************)
(**Use it at Your Own Risk!**************************************************)
(**Bugs, nderungen, Kritik, etc..*******************************************)
(**Bitte wenden an ToSoft@FireMail.De****************************************)
(**URL: www.ToSoftWare.De****************************************************)
uses
    crt, dos;
type
    BPTR = ^byte;
    MIDIfile=Record
     ID:Array[0..3] of Char;
     Length:LongInt;
     Format:Word;
     NumTracks:Word;
     Division:Word;
     trackptr    : array[1..64] of pointer;
     trackSize   : array[1..64] of longint;
     tracks, deltaticks, freq : word;
    End;
const
     DRR = $40;
     DRS = $80;
     ACKmsg = $FE;
     ResetCmd = $FF;
     UartModeCmd = $3F;
     event_lens : array[$80..$FF] of longint = (
     3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
     3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
     2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
     3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,1,3,2,1,1,1,1,1,1,1,1,1,1,1,1);
var
   MIDtrackend    : array[1..64] of boolean;
   MIDoldcmd      : array[1..64] of byte;
   MIDplayptr     : array[1..64] of BPTR;
   MIDplaydelta   : array[1..64] of longint;
   Dataport, Statusport, Commandport,
   finished_t, tracks, freq, deltaticks : word;
   call08, tick, playmidi, midifinished : boolean;
   absDelta, il, jl : longint;
   oldint08 : pointer;
   (***********************)

procedure errorMIDI(s:byte);
begin
    case s of
     1: writeln('Kann MPU-401 nicht initialisieren.');
     2: writeln('Kann Datei nicht oeffnen.');
     3: writeln('Nicht genug Speicher frei.');
     4: writeln('Keine MIDI-Datei ("MTrk" fehlt).');
     5: writeln('Unerwartete Daten in MIDI-Datei.');
     6: writeln('MIDI Datei Typ 2 nicht untersttzt.');
     7: writeln('Kein "MTrk" am Track-Anfang.');
     8: writeln('Track ist zu gross ( > 65528 bytes).');
     9: writeln('zu viele Tracks (max. 64).');
    end;
end;

Procedure setfrequency(frames:longint);
begin
     asm cli end;
     port[$43]:=$36;
     port[$40]:=Lo(1193180 DIV frames);
     port[$40]:=Hi(1193180 DIV frames);
     asm sti end;
end;

procedure sendMidiByte(b : byte); assembler;
ASM
    MOV   DX,StatusPort
@@WaitLoop:
    IN    AL,DX
    AND   AL,DRR
    JNZ   @@WaitLoop
    MOV   AL,b
    DEC   DX
    OUT   DX,AL
end;

procedure playmidihandler; FORWARD;

{$F+}
procedure int08Handler(Flags, rCS, rIP, rAX, rBX, rCX, rDX,
                       rSI, rDI, rDS, rES, rBP: Word); interrupt;
begin
   tick:=true;
   if playmidi then
   begin
        inc(absDelta);
        if absDelta>$FFFFFE then absDelta:=0;
        playmidihandler;
   end;
   if call08 then
   begin
        asm
           pushf
           call oldint08;
        end;
   end else
   port[$20]:=$20;
end;
{$F-}

function ResetMIDI : boolean;
var
   junk : byte;
   retries : integer;
   timeout : word;
   foo : byte;
   blastertag:string;
begin
  ResetMIDI := true; foo:=1; Dataport:=0; Statusport:=0; Commandport:=0;
  blasterTAG:=GetEnv('BLASTER');
  if blasterTAG='' then begin resetMIDI:=false; exit; end;
  Repeat
    Case blasterTAG[foo] of
    'P': Repeat
           Inc(foo); DataPort:=DataPort*16+Ord(BlasterTAG[foo])-48;
         Until blasterTAG[foo+1]=' ';
    end; Inc(foo);
  Until foo>Length(blasterTAG);
  Statusport :=Dataport+1; CommandPort:=Dataport+1; timeout := 0;

  while (port[StatusPort] and DRS = 0) and (timeout < 10) do
  begin
       junk := port[Dataport]; inc(timeout);
  end;
  { small bug!!! :)
  if (junk <> ACKmsg) then begin resetMIDI:=false; exit; end;
  }
  for retries := 1 to 2 do
  begin
       timeout := 0;
       while (port[StatusPort] and DRR <> 0)and
             (timeout < 3000) do inc(timeout);
       if (timeout < 3000) then
       begin
            port[StatusPort] := ResetCmd;  timeout := 0;
            while (TimeOut < 3000) do
            begin
                 if (port[StatusPort]and DRS = 0) and
                    (port[Dataport] = ACKmsg) then exit;
                 inc(timeout);
            end;
       end;
  end;
end;

procedure doneMIDI;
var i:word;
begin
     { reset interrupt }
     asm cli end;
     Port[$40] := $FF;
     Port[$40] := $FF;
     SetIntVec($08, oldint08);
     asm sti  end;
     for i:=0 to 15 do begin
         { All notes off }
         sendMidiByte($B0+i);
         sendMidiByte($7B);
         sendMidiByte($00);
         { All sounds off }
         sendMidiByte($B0+i);
         sendMidiByte($78);
         sendMidiByte($00);
         { Reset all controllers }
         sendMidiByte($B0+i);
         sendMidiByte($79);
         sendMidiByte($00);
     end;
     { reset timer }
     asm
       XOR     AL,AL
       OUT     70h,AL
       IN      AL,71h
       MOV     DH,AL
       AND     DH,15
       SHR     AL,4
       MOV     DL,10
       MUL     DL
       ADD     DH,AL
       MOV     AL,2
       OUT     70h,AL
       IN      AL,71h
       MOV     CL,AL
       AND     CL,15
       SHR     AL,4
       MOV     DL,10
       MUL     DL
       ADD     CL,AL
       MOV     AL,4
       OUT     70h,AL
       IN      AL,71h
       MOV     CH,AL
       AND     CH,15
       SHR     AL,4
       MOV     DL,10
       MUL     DL
       ADD     CH,AL
       XOR     DL,DL
       MOV     AH,2Dh
       INT     21h
       MOV     AL,7
       OUT     70h,AL
       IN      AL,71h
       MOV     DL,AL
       AND     DL,15
       SHR     AL,4
       MOV     CH,10
       MUL     CH
       ADD     DL,AL
       MOV     AL,8
       OUT     70h,AL
       IN      AL,71h
       MOV     DH,AL
       AND     DH,15
       SHR     AL,4
       MOV     CH,10
       MUL     CH
       ADD     DH,AL
       MOV     AL,4
       OUT     70h,AL
       IN      AL,71h
       MOV     CL,AL
       AND     CL,15
       SHR     AL,4
       MOV     CH,10
       MUL     CH
       ADD     CL,AL
       XOR     CH,CH
       ADD     CX,1900
       MOV     AH,2Bh
       INT     21h
     end;
end;

Function IntelLong(Motorolla:LongInt):LongInt; Assembler;
ASM
   MOV  AX,[WORD PTR Motorolla]
   MOV  DX,[WORD PTR Motorolla+2]
   XCHG AL,AH
   XCHG DL,DH
   XCHG AX,DX
End;

Function IntelWord(Motorolla:Word):Word; Assembler;
ASM
   MOV  AX,[Motorolla]
   XCHG AL,AH
End;

function loadMIDI(MIDFile:String;var MIDheader:MIDIfile):byte;
type
    MIDITrackRec=Record
     ID:Array[0..3] Of Char;
     Length:LongInt;
    End;
var
   MIDTrack:MIDITrackRec;
   MID:file;
   i:byte;
Begin
    for i:=1 to 64 do MIDheader.trackptr[i]:=nil;
    fillchar(MIDheader.tracksize,sizeof(MIDheader.tracksize),0);
    filemode:=0; Assign(MID,MIDFile);
    {$i+}Reset(MID,1);{$i-} If IOResult<>0 then exit;
    BlockRead(MID,MIDHeader,14);
    With MIDHeader do
    Begin
      Length:=IntelLong(Length);
      Format:=IntelWord(Format);
      NumTracks:=IntelWord(NumTracks);
      Division:=IntelWord(Division);
    End;
    With MIDheader do begin
    if ID<>'MThd' then begin LoadMidi:=4; exit; end;
    if Length<>6 then begin close(MID); LoadMidi:=5; exit; end;
    If (Format>1) then {Typ 2 nicht untersttzt}
    begin close(MID); LoadMidi:=6; exit; end;
    if Numtracks>64 then begin close(MID); LoadMidi:=9; exit; end;
    end;
    for i:=1 to MIDheader.Numtracks do
    begin
         BlockRead(MID,MIDTrack,SizeOf(MIDTrack));
         if MIDtrack.ID<>'MTrk' then begin close(MID);LoadMidi:=7;exit;end;
         MIDtrack.length:=IntelLong(MIDtrack.Length);
         if MemAvail<MIDtrack.Length then begin close(MID);LoadMidi:=3;exit;end;
         if MIDtrack.Length>65528 then begin close(MID);LoadMidi:=8;exit;end;
         MIDheader.trackSize[i]:=MIDtrack.Length;
         GetMem(midheader.trackptr[i],MIDtrack.Length);
         blockread(MID,midheader.trackptr[i]^,MIDtrack.Length);
    end;
    LoadMidi:=0; close(MID);
    MIDheader.tracks:=MIDheader.numtracks;
    MIDheader.deltaticks:=MIDheader.Division;
End;

procedure initMIDI;
var i:byte;
begin
     if not ResetMIDI then begin errorMIDI(1); halt; end else
     { MPU in UART-mode bringen }
     repeat until (port[StatusPort] and DRR) = 0;
     port[CommandPort] := UartModeCmd;
     while port[StatusPort] and DRS <> 0 DO;
     { set interrupt }
     call08 := false;
     GetIntVec($08, oldint08);
     SetIntVec($08, Addr(int08Handler));
     while not tick do;
     absDelta:=0;
end;

procedure playMIDIhandler;
var i,bpm:word; bp:BPTR; b,meta:byte;
begin
     if not midifinished then
     begin
          for i:=1 to tracks do
          begin
               while ((not(MIDtrackend[i])) and
                     (MIDplaydelta[i]<=absDelta)) do
               begin
                    bp:=MIDplayptr[i];
                    if bp^<$80 then b:=MIdoldcmd[i] else
                    begin
                         b:=bp^;
                         inc(bp);
                    end;
                    MIdoldcmd[i]:=b;
                    if b=$ff then
                    begin
                         meta:=bp^;
                         inc(bp);
                         il:=ord(bp^) AND $7F;
                         while ord(bp^)>127 do
                         begin
                              il:=il SHL 7;
                              inc(bp);
                              il:=il+(ord(bp^) AND $7F);
                         end;
                         inc(bp);
                         case meta of
                         $2f: begin { track ende }
                                   MIdtrackend[i]:=true;
                                   inc(finished_t);
                                   if finished_t=tracks then
                                   midifinished:=true;
                              end;
                         $51: begin { set tempo }
                                   il:=ord(bp^); inc(bp);
                                   il:=(il SHL 8)+ord(bp^);
                                   inc(bp);
                                   il:=(il SHL 8)+ord(bp^);
                                   inc(bp);
                                   bpm:=word(60000000 DIV il);
                                   freq:=word((longint(deltaticks)*
                                         longint(bpm)) div 60);
                                   setfrequency(longint(freq));
                               end;
                         $03: begin { Trackname }
                                   for jl:=1 to il do inc(bp);
                              end;
                         else for jl:=1 to il do inc(bp);
                    end;
               end else
               begin
                    il:=event_lens[b];
                    if ((b=$f0) or (b=$f7)) then
                    begin
                         il:=ord(bp^) AND $7F;
                         while ord(bp^)>127 do
                         begin
                              il:=il SHL 7; inc(bp);
                              il:=il+(ord(bp^) AND $7F);
                         end;
                         inc(bp);
                         if b=$f0 then
                         begin
                              while port[StatusPort] and DRR <> 0 do;
                              port[Dataport] := $0f0;
                         end;
                         for jl:=1 to il do
                         begin
                              while port[StatusPort] and DRR <> 0 do;
                              port[Dataport] := bp^;
                              inc(bp);
                         end;
                    end else
                    begin
                         sendmidibyte(b);
                         if il>=2 then
                         begin
                              b:=bp^;
                              sendmidibyte(b);
                              inc(bp);
                              if il=3 then
                              begin
                                   b:=bp^;
                                   sendmidibyte(b);
                                   inc(bp);
                              end;
                         end;
                    end;
               end;
               if not MIDtrackend[i] then
               begin
                    il:=ord(bp^) AND $7F;
                    while ord(bp^)>127 do
                    begin
                         il:=il SHL 7;
                         inc(bp);
                         il:=il+(ord(bp^) AND $7F);
                    end;
                    inc(bp);
                    MIDplaydelta[i]:=MIDplaydelta[i]+il;
                    MIDplayptr[i]:=bp;
               end;
          end;
     end;
end;
end;

procedure play_midi(MIDh:MIDIfile); {load and play midi}
var i:byte; bp : BPTR;
begin
   for i:=1 to 64 do MIDplayptr[i]:=nil;
   fillchar(MIDplaydelta,sizeof(MIDplaydelta),0);
   fillchar(MIDoldcmd,sizeof(MIDoldcmd),0);
   for i:=1 to MIDh.numtracks do begin
      bp:=MIDh.trackptr[i];
      il:=ord(bp^) AND $7F;
      while ord(bp^)>127 do
       begin
        il:=il SHL 7; inc(bp);
        il:=il+(ord(bp^) AND $7F);
       end;
      inc(bp);
      MIDplaydelta[i]:=il+1;
      MIDplayptr[i]:=bp;
      MIDtrackend[i]:=false;
     end;
     freq:=word((longint(120)*longint(MIDh.division)) div 60);
     Midh.freq:=freq; tracks:=MIDh.numtracks; deltaticks:=MIDh.Division;
     setfrequency(freq);
     midifinished:=false; finished_t:=0; tick:=false; absdelta:=0;
     playmidi:=true;
end;

procedure resume_midi; {you can use after stop_midi}
begin
     playmidi:=true;
end;

procedure stop_midi;
var i:word;
begin
     playmidi:=false;
     for i:=0 to 15 do
     begin
          sendMidiByte($B0+i);
          sendMidiByte($7B);
          sendMidiByte($00);
     end;
end;

procedure free_MIDI(MIDh:MIDIfile);
var i :byte;
begin
     for i:=1 to 64 do
      if MIDh.trackptr[i]<>nil then
        FreeMem(MIDh.trackptr[i],MIDh.tracksize[i]);
end;

(*****************************************************************)

var
    MID1,MID2:Midifile;
    res:byte;
begin
     clrscr;
     writeln('Midi - Player ... (test for multiple midi play!)');
     initMIDI;
     res:=loadMidi('earth.mid',MID1);
     if res>0 then begin errorMIDI(res); doneMIDI; halt; end;
     res:=loadMidi('ksong.mid',MID2);

     if res>0 then begin errorMIDI(res); doneMIDI; halt; end;
     writeln('Playing...');
     play_midi(MID2);

     write('Enter... to stop that song!'); readln; stop_midi;
     write('Enter... to play new song!'); readln; play_midi(MID1);
     write('Any key...to leave');
     repeat until (keypressed) or (midifinished);
     free_midi(MID1);
     free_midi(MID2);
     doneMidi;
end.




