unit AudioMidi;

interface

uses Windows, KOL, MMSystem;

type
  TPatchNo = 0..127;
  TBankNo = 0..127;
  TNote = 0..127;
  TController = 0..127;
  TChannel = 0..15;

  TEventData = packed record
  case Status: Byte of
    0:(b2, b3: Byte);
    1:(SysEx: PChar)
  end;

  PMidiEventData = ^TMidiEventData;
  TMidiEventData = packed record
    Pos: LongInt;
    SysExSize: word;
    Data: TEventData;           
    OnOfFEvent: PMidiEventData;
  end;
  PTrackEvents = ^PMidiEventData;

  TMidiPlayerState =(stStopped, stPaused, stPlaying);
  TFindEventType =(feFirst, feLast);
  TOnMIDIEvent = procedure(Sender: PObj; AState: TMidiPlayerState) of object;

  PMIDIPlayer = ^TKOLMIDIPlayer;
  PMidiData = ^TMidiData;
  PTrackOutputs = ^TTrackOutputs;
  PTrackOutput = ^TTrackOutput;
  PMidiIterator = ^TMidiIterator;
  PMidiTrackStream = ^TMidiTrackStream;
  PPhysicalOutputPort = ^TPhysicalOutputPort;
  PMidiOutputPort = ^TMidiOutputPort;

  TMIDIPlayer = PMIDIPlayer;
  TKOLMIDIPlayer = object(TObj)
  private
    FTrackOutputs, FTrackOut: PTrackOutputs;
    FMidiData: PMidiData;
    FIterator: PMidiIterator;
    FTimerPeriod: Integer;
    FTimerResolution: Integer;
    FInTimerProc: DWORD;
    FState: TMidiPlayerState;
    FTickCount: Integer;
    FTempoPercent: Integer;
    FOnMIDIEvent: TOnMIDIEvent;
    FBoostPriority: Boolean;
    FStopPosition: Integer;
    FNormalPriority: Integer;
    FTimerID: Integer;
    FMinTimerPeriod: Integer;
    function  GetPosition: Integer;
    procedure SetPosition(const Value: Integer);
    procedure SetTrackOutputs(Value: PTrackOutputs);
    procedure Reset;
    procedure ReCreateData;
  protected
    procedure SetState(Value: TMidiPlayerState);
    property TrackOutputs: PTrackOutputs read FTrackOutputs write SetTrackOutputs;
  public
    constructor Create;
    destructor Destroy; virtual;
    procedure Play;
    procedure Stop;
    procedure Pause;
    procedure Rewind;
    procedure CloseMIDI;
    function LoadFromFile(AFileName: KOLString): Boolean;
    function LoadFromStream(AStream: PStream): Boolean;
    property State: TMidiPlayerState read FState;
    property BoostPriority: Boolean read FBoostPriority write FBoostPriority;
    property Position: Integer read GetPosition write SetPosition;
    property TimerPeriod: Integer read FTimerPeriod;
    property TimerResolution: Integer read FTimerResolution;
    property TempoPercent: Integer read FTempoPercent write FTempoPercent;
    property OnMIDIEvent: TOnMIDIEvent read FOnMIDIEvent write FOnMIDIEvent;
  end;

  TMidiData = object(TObj)
  private
    FTrackList: PList;
    FHeaderExtra: PChar;
    FHeaderExtraSize: LongInt;
    FHeader: packed record
      Format: Word;
      nTracks: Word;
      PPQN: Word;
    end;
    function GetPPQN: Integer;
    function GetTrackCount: Integer;
    function GetTrack(Index: Integer): PMidiTrackStream;
  protected
    function ReadHeader(f: PStream): Boolean;
    function ReadTracks(f: PStream): Boolean;
  public
    constructor Create;
    destructor Destroy; virtual;
    function LoadFromFile(AFileName: KOLString): Boolean;
    function LoadFromStream(Data: PStream): Boolean;
    procedure Close;
    property TrackCount: Integer read GetTrackCount;
    property Tracks[Index: Integer]: PMidiTrackStream read GetTrack;
    property PPQN: Integer read GetPPQN;
  end;

  TTrackOutput = object(TObj)
  private
    FList: PList;
    FTrackData: PMidiTrackStream;
    FPort: PMidiOutputPort;
    FEventIndex: Integer;
    FMute: Boolean;
    FOwner: PTrackOutputs;
    procedure Open(Data: PMidiTrackStream; OutputPortNo: Integer);
    procedure Close;
    procedure SetPatchForPosition;
  public
    constructor Create(AOwner: PTrackOutputs);
    destructor Destroy; virtual;
    property Port: PMidiOutputPort read FPort;
    property EventIndex: Integer read FEventIndex write FEventIndex;
    property TrackData: PMidiTrackStream read FTrackData;
    property Mute: Boolean read FMute;
  end;

  TTrackOutputs = object(TObj)
  private
    FList: PList;
    FMidiData: PMidiData;
    FDefaultOutputPort: Integer;
    function GetNoTracks: Integer;
    function GetTrackOutput(Index: Integer): PTrackOutput;
    procedure SetMidiData(Value: PMidiData);
  public
    constructor Create;
    destructor Destroy; virtual;
    procedure Open;
    procedure Close;
    procedure AllNotesOff;
    property NoTracks: Integer read GetNoTracks;
    property TrackOutput [Index: Integer]: PTrackOutput read GetTrackOutput; default;
    procedure OpenTrack(Data: PMidiTrackStream; prtID: Integer);
    procedure ResetEventIndexes;
    procedure SetPatchForPosition;
    property DefaultOutputPort: Integer read FDefaultOutputPort write FDefaultOutputPort;
    property MidiData: PMidiData read FMidiData write SetMidiData;
  end;

  TMidiIterator = object(TObj)
  private
    FMidiData: PMidiData;
    FPosition, FTime: Integer;
    FPPQN: Integer;
    FTempo: Integer;
    FTempoPos, FTempoTime: Integer;
    FBeatDiv, FBeatsPerBar: Integer;
    FTimesigPos, FTimesigBar: Integer;
    FTicksPerBar, FTicksPerBeat: Integer;
    FBar, FBeat, FTick: Integer;
    FInputIndex: Integer;
    FTrack0Index: Integer;
    FPlayNotes: Boolean;
    FTrackOutputs: PTrackOutputs;
    FEndOfSong: Boolean;
    procedure SetMidiData(Value: PMidiData);
    procedure CalcTickConstants;
    procedure AdjustPositionsForTimesig(delta_pos: Integer);
    procedure CalcNewPosition(pos: Integer);
    procedure CalcPositionFromTime(tm: Integer);
    procedure SetBarPosition(ABar, ABeat, ATick: Integer);
    procedure SetPosition(pos: Integer);
    procedure SetTime(Value: Integer);
  protected
    procedure SkipToPosition;
    procedure SetTrackOutputs(Value: PTrackOutputs);
  public
    constructor Create;
    procedure Reset;
    property MidiData: PMidiData read FMidiData write SetMidiData;
    property Bar: Integer read FBar;
    property Beat: Integer read FBeat;
    property Tick: Integer read FTick;
    property Position: Integer read FPosition write SetPosition;
    property Time: Integer read FTime write SetTime;
    property BeatDiv: Integer read FBeatDiv;
    property BeatsPerBar: Integer read FBeatsPerBar;
    property TicksPerBar: Integer read FTicksPerBar;
    property Tempo: Integer read FTempo;
    procedure IterateByTime(delta_time: Integer);
    property TrackOutputs: PTrackOutputs read FTrackOutputs write SetTrackOutputs;
    property EndOfSong: Boolean read FEndOfSong;
  end;

  TMidiTrackStream = object(TObj)
    FStreamList: PList;
    FTrackName: PMidiEventData;
    FPatch: TPatchNo;
    FChannel: TChannel;
    function GetEvent(idx: Integer): PMidiEventData;
    function CalcOnOffPointers: Boolean;
    function LoadFromSMFStream(SMFstream: PStream): Boolean;
    function FindEventNo(pos: Integer; tp: TFindEventType): Integer;
    function InsertEvent(pos: Integer; var Data: TEventData; SysExSize: Integer): PMidiEventData;
    function InsertMetaEvent(pos: Integer; MetaEvent: Byte; Data: PChar; DataLen: Integer): PMidiEventData;
  public
    constructor Create;
    destructor Destroy; virtual;
    property Event [idx: Integer]: PMidiEventData read GetEvent;
    property Channel: TChannel read FChannel;
    property Patch: TPatchNo read FPatch;
  end;

  TPhysicalOutputPort = object(TObj)
  private
    Handle: HMIDIOUT;
    PortID: Integer;
    PortNo: Integer;
    UserList: PList;
    CurrentBank: array [TChannel] of TBankNo;
    CurrentPatch: array [TChannel] of TPatchNo;
    ControllerArray: array [TChannel, TController] of Integer;
    procedure ResetControllers;
    procedure PatchChange(Patch: TPatchNo; Channel: TChannel);
    procedure RemoveUser(User: PMidiOutputPort);
    procedure AddUser(User: PMidiOutputPort);
  public
    constructor Create(pID: Integer; User: PMidiOutputPort);
    destructor Destroy; virtual;
  end;

  TMidiOutputPort = object(TObj)
  private
    FOwner: PTrackOutput;
    FPortID: Integer;
    FPhysicalPort: PPhysicalOutputPort;
    FSysExHeaders: PList;
    UserNo: Integer;
    NoteArray: array [TChannel, TNote] of Integer;
    FSysExLatency: Integer;
    procedure SetPortId(Value: Integer);
    procedure SetActive(Value: Boolean);
    function GetActive: Boolean;
    function GetHandle: HMidiOut;
    procedure TidySysExHeaders;
  public
    constructor Create(AOwner: PTrackOutput);
    destructor Destroy; virtual;
    property Handle: HMIDIOUT read GetHandle;
    procedure OutEvent(const Event: TEventData);
    procedure AllNotesOff;
    procedure ResetControllers;
    procedure PatchChange(patch: TPatchNo; Channel: TChannel);
    procedure WaitForSysEx;
    property PortId: Integer read FPortID write SetPortId;
    property Active: Boolean read GetActive write SetActive;
    property SysExLatency: Integer read FSysExLatency write FSysExLatency default 50;
  end;

function NewMIDIPlayer: PMIDIPlayer;

implementation

uses ATLLib;

var PortList: PList = nil;

const
  PROCESS_SET_INFormatION = $200;

  midiNoteOff 	        = $80;
  midiNoteOn            = $90;
  midiStatusMask	= $f0;
  midiSysEx       	= $f0;
  midiSysExCont		= $f7;
  midiMeta		= $ff;
  midiStatus		= $80;
  midiChannelMask	= $0f;
  metaTrackName		= $03;
  metaText		= $01;
  metaTrackEnd		= $2f;
  midiController 	= $b0;
  midiProgramChange 	= $c0;

  chanType: array [0..15] of integer =(0, 0, 0, 0, 0, 0, 0, 0,
                                         2, 2, 2, 2, 1, 1, 2, 0);

  ControllerDefaults: array [TController] of Integer =(
   0, 0, 0, 0, 0, 0, 0, 90 {Volume} , 0, 0, 64 {Pan }, 127 {Expression}, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 40, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
  );

{ TKOLMIDIPlayer }

function NewMIDIPlayer: PMIDIPlayer;
begin
    New(Result, Create);
end;

constructor TKOLMIDIPlayer.Create;
var Caps: TTimeCaps;
    ProcessHandle: THandle;
begin
    inherited;
    FTrackOut:= nil; FMidiData:= nil;
    TimeGetDevCaps(@caps, sizeof(caps));
    FMinTimerPeriod:= caps.wPeriodMin;
    FTimerPeriod:= FMinTimerPeriod;
    FInTimerProc:= 0;
    FTimerResolution:= 4;
    FTempoPercent:= 100;
    New(FIterator, Create);
    ProcessHandle:= OpenProcess(PROCESS_SET_INFormatION, False, GetCurrentProcessID);
    FNormalPriority:= GetPriorityClass(ProcessHandle);
    CloseHandle(ProcessHandle);
end;

destructor TKOLMIDIPlayer.Destroy;
begin
    Stop;
    FIterator.Free;
    CloseMIDI;
    if FMidiData <> nil then FMidiData.Free;
    if FTrackOut <> nil then FTrackOut.Free;
    inherited;
end;

function TKOLMIDIPlayer.GetPosition: Integer;
begin
    Result:= FIterator.Position;
end;

procedure TimerProc(ID, Msg: UINT; Player: DWORD; DW1, DW2: DWORD); stdcall;
var NewTickCount: Integer;
    DeltaTime: Integer;
begin
      if PMidiPlayer(Player).FInTimerProc = 0 then begin
        Inc(PMidiPlayer(Player).FInTimerProc);
        if PMidiPlayer(Player).FState <> stPaused then begin
          NewTickCount:= timeGetTime;
          DeltaTime:= NewTickCount - PMidiPlayer(Player).FTickCount;
          PMidiPlayer(Player).FTickCount:= NewTickCount;
          PMidiPlayer(Player).FIterator.IterateByTime(Max(1, Round(DeltaTime * PMidiPlayer(Player).FTempoPercent / 100)));
          if PMidiPlayer(Player).FIterator.EndOfSong then PMidiPlayer(Player).Stop
        end;
        Dec(PMidiPlayer(Player).FInTimerProc)
      end
end;

procedure TKOLMIDIPlayer.Play;
var Pos: Integer;
    ProcessHandle: THandle;
begin
    case FState of
      stStopped: begin
        if not Assigned(FTrackOutputs) then begin
          FState:= stPlaying;
          SetState(stStopped);
          Exit;
        end;

        FIterator.MidiData:= FTrackOutputs.MidiData;
        Pos:= FIterator.Position;
        FIterator.Position:= FStopPosition;
        FState:= stPaused;
        FIterator.Position:= Pos;

        if TimeBeginPeriod(TimerPeriod) = TIMERR_NOERROR then begin
          if FBoostPriority then begin
            ProcessHandle:= OpenProcess(PROCESS_SET_INFormatION, False, GetCurrentProcessID);
            FNormalPriority:= GetPriorityClass(ProcessHandle);
            SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
            CloseHandle(ProcessHandle)
          end;
          FTickCount:= TimeGetTime;
          FTimerID:= TimeSetEvent(FTimerResolution, 0, TimerProc, DWORD(@Self), TIME_PERIODIC);
          if FTimerID <> 0 then SetState(stPlaying) else SetState(stStopped);
        end
        else SetState(stStopped);
      end;
      stPaused: SetState(stPlaying)
    end
end;

procedure TKOLMIDIPlayer.Stop;
var ProcessHandle: THandle;
begin
    if FState >= stPaused then begin
      TimeKillEvent(FTimerID);
      TimeEndPeriod(TimerPeriod);
      if Assigned(FTrackOutputs) then FTrackOutputs.AllNotesOff;
      ProcessHandle:= OpenProcess(PROCESS_SET_INFormatION, False, GetCurrentProcessID);
      SetPriorityClass(ProcessHandle, FNormalPriority);
      CloseHandle(ProcessHandle);
      FStopPosition:= Position;
    end;
    SetState(stStopped)
end;

procedure TKOLMIDIPlayer.Pause;
begin
    SetState(stPaused);
end;

procedure TKOLMIDIPlayer.Rewind;
begin
    Stop;
    FIterator.SetBarPosition(0, 0, 0);
end;

procedure TKOLMIDIPlayer.Reset;
begin
    Stop;
    if Assigned(FTrackOutputs) then begin
      FIterator.MidiData:= FTrackOutputs.MidiData;
      FIterator.Position:= 0;
    end
    else FIterator.MidiData:= nil;
end;

procedure TKOLMIDIPlayer.SetState(Value: TMidiPlayerState);
begin
    if Value <> FState then begin
      FState:= Value;
      if Assigned(FOnMIDIEvent) then FOnMIDIEvent(@Self, Value);
    end
end;

procedure TKOLMIDIPlayer.SetTrackOutputs(Value: PTrackOutputs);
begin
    if FTrackOutputs <> Value then begin
//      Rewind;
      FTrackOutputs:= Value;
      FIterator.TrackOutputs:= Value;
      Reset;
    end
end;

function TKOLMIDIPlayer.LoadFromFile(AFileName: KOLString): Boolean;
begin
    Result:= False;
    ReCreateData;
    Rewind;
    if not FMidiData.LoadFromFile(AFileName) then Exit;
    TrackOutputs.Open;
    Result:= True;
end;

function TKOLMIDIPlayer.LoadFromStream(AStream: PStream): Boolean;
begin
    Result:= False;
    ReCreateData;
    Rewind;
    if not FMidiData.LoadFromStream(AStream) then Exit;
    TrackOutputs.Open;
    Result:= True;
end;

procedure TKOLMIDIPlayer.ReCreateData;
begin
    CloseMIDI;
    if FMidiData <> nil then Free_And_nil(FMidiData);
    if FTrackOut <> nil then Free_And_nil(FTrackOut);
    New(FMidiData, Create);
    New(FTrackOut, Create);
    TrackOutputs:= FTrackOut;
    FTrackOut.MidiData:= FMidiData;
end;

procedure TKOLMIDIPlayer.CloseMIDI;
begin
    Stop;
    if Assigned(TrackOutputs) then begin
      TrackOutputs.Close;
      if Assigned(TrackOutputs.MidiData) then TrackOutputs.MidiData.Close;
    end;
end;

procedure TKOLMIDIPlayer.SetPosition(const Value: Integer);
begin
    FIterator.Position:= Value;
end;

{ TMidiData }

constructor TMidiData.Create;
begin
    inherited;
    FTrackList:= NewList;
    FHeader.PPQN:= System.swap(180); 
    FHeader.Format:= System.swap(1);
end;

destructor TMidiData.Destroy;
begin
    Close;
    FTrackList.Free;
    inherited;
end;

function TMidiData.GetPPQN: Integer;
begin
    Result:= System.Swap(FHeader.PPQN);
end;

function TMidiData.GetTrackCount: Integer;
begin
    Result:= FTrackList.Count
end;

procedure TMidiData.Close;
var i: Integer;
begin
    if FHeaderExtra <> nil then begin
      FreeMem(FHeaderExtra);
      FHeaderExtra:= nil
    end;
    for i:= 0 to FTrackList.Count - 1 do PObj(FTrackList.Items[i]).Free;
    FTrackList.Clear;
    FHeader.PPQN:= System.swap(180);
    FHeader.Format:= System.swap(1);
    FHeader.nTracks:= System.swap(0);
end;

function TMidiData.GetTrack(Index: Integer): PMidiTrackStream;
begin
    if Index < FTrackList.Count then Result:= FTrackList.Items[Index]
    else Result:= nil
end;

function TMidiData.ReadTracks(f: PStream): Boolean;
var nTracks, i: Integer;
    Track: PMidiTrackStream;
begin
    Result:= False;
    nTracks:= System.Swap(FHeader.nTracks);
    for i:= 0 to nTracks - 1 do begin
      New(Track, Create);
      try
        if not Track.LoadFromSMFStream(f) then Exit;
        FTrackList.Add(Track);
        Result:= True;
      except
        Track.Free;
      end
    end
end;

function TMidiData.ReadHeader(f: PStream): Boolean;
var hdr: array [0..3] of Char;
    hSize: LongInt;
begin
    Result:= False;
    f.Read(hdr, sizeof(hdr));
    if StrLComp(hdr, 'MThd', 4) <> 0 then Exit;
    f.Read(hSize, sizeof(hSize));
    hSize:= SwapOrder32(hSize);
    if hSize < sizeof(FHeader) then Exit;
    f.Read(FHeader, sizeof(FHeader));
    if hSize > sizeof(FHeader) then begin 
      FHeaderExtraSize:= hSize - sizeof(FHeader);
      GetMem(FHeaderExtra, FHeaderExtraSize);
      f.Read(FHeaderExtra^, FHeaderExtraSize);
    end
    else begin
     FHeaderExtraSize:= 0;
     FHeaderExtra:= nil;
    end;
    Result:= True;
end;

function RiffStreamDescend(Strm: PStream; const ChunkID: string; Flags: Integer): Boolean;
var fInfo: TMMCKInfo;
begin
    Result:= False;
    if Length(ChunkID) <> 4 then Exit;
    FillChar(fInfo, Sizeof(fInfo), 0);
    if(chunkID = 'LIST') or (chunkID = 'RIFF') then fInfo.fccType:= mmioStringToFourCC(PChar(chunkID), 0)
    else fInfo.ckid:= mmioStringToFourCC(PChar(chunkID), 0);
    if mmioDescend(Strm.Data.fHandle, @fInfo, nil, flags) = MMSYSERR_NOERROR then
    else Exit;
    Result:= True;
end;

function RiffStreamSeek(Strm: PStream; MoveTo: Integer; MoveMethod: TMoveMethod ): DWORD;
var mmOrigin: Integer;
begin
    case MoveMethod of
      spBegin: mmOrigin:= SEEK_SET;
      spEnd: mmOrigin:= SEEK_END;
      spCurrent: mmOrigin:= SEEK_CUR;
      else mmOrigin:= SEEK_SET
    end;
    Result:= mmioSeek(Strm.Data.fHandle, MoveTo, mmOrigin);
end;

function RiffStreamRead( Strm: PStream; var Buffer; Count: DWORD ): DWORD;
begin
    Result:= mmioRead(Strm.Data.fHandle, @Buffer, Count);
    if Integer(Result) = -1 then Result:= 0
end;

procedure RiffStreamClose( Strm: PStream );
begin
    mmioClose(Strm.Data.fHandle, 0);
end;

const
  RiffFileStream: TStreamMethods =(
    fSeek: RiffStreamSeek;
    fGetSiz: nil;
    fSetSiz: nil;
    fRead: RiffStreamRead;
    fWrite: nil;
    fClose: RiffStreamClose;
    fCustom: nil;
  );

type
  PStreamData = ^TStreamData;

function TMidiData.LoadFromFile(AFileName: KOLString): Boolean;
var F: PStream;
    ext: KOLstring;
begin
    Close;
    Result:= False;
    ext:= UpperCase(ExtractFileExt(AFileName));
    if (ext = '.RMI') or (ext = '.RIFF') then begin
      F:= _NewStream( RiffFileStream );
      PStreamData(@(F.Data)).fHandle:= mmioOpen(PChar(AFileName), nil, MMIO_READ and MMIO_DENYREAD);
      if PStreamData(@(F.Data)).fHandle = 0 then Exit;
      if not RiffStreamDescend(F, 'RMID', MMIO_FINDRIFF) then Exit;
      if not RiffStreamDescend(F, 'Data', MMIO_FINDCHUNK) then Exit;
    end
    else F:= NewReadFileStream(AFileName);
    try
      try
        if not ReadHeader(F) then Exit;
        if not ReadTracks(F) then Exit;
        Result:= True;
      except
        Close;
      end
    finally
      F.Free;
    end;
    Result:= True;
end;

function TMidiData.LoadFromStream(Data: PStream): Boolean;
var F, S: PStream;
    id: array [0..4] of Char;
    info: TMMIOInfo;
begin
    Close;
    Result:= False;
    if Data.Size > 4 then begin
      Data.Read(id, 4);
      id[4]:= #0;
      if StrComp(id, 'RIFF') = 0 then begin
        f:= nil;
        s:= NewMemoryStream;
        try
          Data.Seek(0, spBegin);
          Stream2Stream(s, Data, Data.Size);
          f:= _NewStream( RiffFileStream );
          FillChar(info, SizeOf(info), 0);
          info.fccIOProc:= FOURCC_MEM;
          info.pchBuffer:= s.Memory;
          info.cchBuffer:= s.Size;
          PStreamData(@(f.Data)).fHandle:= mmioOpen(nil, @info, MMIO_READ);
          if not RiffStreamDescend(F, 'RMID', MMIO_FINDRIFF) then Exit;
          if not RiffStreamDescend(F, 'Data', MMIO_FINDCHUNK) then Exit;
          try
            if not ReadHeader(f) then Exit;
            if not ReadTracks(f) then Exit;
            Result:= True;
          except
            Close;
          end
        finally
          s.Free;
          f.Free
        end
      end
      else begin
        try
          Data.Seek(0, spBegin);
          if not ReadHeader(Data) then Exit;
          if not ReadTracks(Data) then Exit;
          Result:= True;
        except
          Close;
        end
      end
    end;
end;

{ TTrackOutputs }

constructor TTrackOutputs.Create;
begin
    inherited;
    FList:= NewList;
end;

destructor TTrackOutputs.Destroy;
var i: Integer;
begin
    for i:= FList.Count-1 downto 0 do PObj(FList.Items[i]).Free;
    FList.Free;
    inherited;
end;

function TTrackOutputs.GetNoTracks: Integer;
begin
    Result:= FList.Count;
end;

function TTrackOutputs.GetTrackOutput(Index: Integer): PTrackOutput;
begin
    Result:= FList.Items[Index];
end;

procedure TTrackOutputs.SetMidiData(Value: PMidiData);
begin
    if Value <> FMidiData then FMidiData:= Value;
end;

procedure TTrackOutputs.Open;
var i: Integer;
begin
    for i:= 0 to FMidiData.TrackCount - 1 do
      OpenTrack(FMidiData.Tracks[i], DefaultOutputPort)
end;

procedure TTrackOutputs.OpenTrack(Data: PMidiTrackStream; prtID: Integer);
var TrackOut: PTrackOutput;
begin
    New(TrackOut, Create(@self));
    TrackOut.Open(Data, prtID);
end;

procedure TTrackOutputs.Close;
var i: Integer;
begin
    for i:= FList.Count - 1 downto 0 do PObj(FList.Items[i]).Free;
    FList.Clear;
end;

procedure TTrackOutputs.AllNotesOff;
var i: Integer;
begin
    for i:= 0 to NoTracks - 1 do TrackOutput[i].Port.AllNotesOff;
end;

procedure TTrackOutputs.ResetEventIndexes;
var i: Integer;
begin
    for i:= 0 to NoTracks - 1 do TrackOutput[i].EventIndex:= 0
end;

procedure TTrackOutputs.SetPatchForPosition;
var i: Integer;
begin
    for i:= 0 to NoTracks - 1 do TrackOutput[i].SetPatchForPosition
end;

{ TTrackOutput }

constructor TTrackOutput.Create(AOwner: PTrackOutputs);
begin
    inherited Create;
    FOwner:= AOwner;
    if FOwner <> nil then AOwner.FList.Add(@Self);
    FList:= NewList;
end;

destructor TTrackOutput.Destroy;
var i: Integer;
begin
    Close;
    for i:= FList.Count-1 downto 0 do PObj(FList.Items[i]).Free;
    FList.Free;
    if FOwner <> nil then FOwner.FList.Remove(@Self);
    inherited
end;

procedure TTrackOutput.Open(Data: PMidiTrackStream; OutputPortNo: Integer);
begin
    New(FPort, Create(@Self));
    FTrackData:= Data;
    FEventIndex:= 0;
    FPort.PortID:= OutputPortNo;
    FPort.Active:= True;
end;

procedure TTrackOutput.Close;
begin
    FPort.Free
end;

procedure TTrackOutput.SetPatchForPosition;
begin
    FPort.PatchChange(FTrackData^.Patch, FTrackData^.Channel)
end;

{ TMidiIterator }

constructor TMidiIterator.Create;
begin
    inherited;
    Reset;
end;

procedure TMidiIterator.SetMidiData(Value: PMidiData);
var oldPos: Integer;
begin
    if FMidiData <> Value then begin
      FMidiData:= Value;
      oldPos:= Position;
      Reset;
      SetPosition(oldPos)
    end
end;

procedure TMidiIterator.Reset;
var i: Integer;
begin
    inherited;
    if not Assigned(FMidiData) then FPPQN:= 180 else FPPQN:= FMidiData.PPQN;
    FPosition:= 0;
    FTime:= 0;
    FTempo:= 600;
    FTempoPos:= 0;
    FTempoTime:= 0;
    FBeatDiv:= 2;
    FBeatsPerBar:= 4;
    FTimesigPos:= 0;
    FTimesigBar:= 0;
    FBar:= 0;
    FBeat:= 0;
    FTick:= 0;
    FTrack0Index:= 0;
    FInputIndex:= 0;
    CalcTickConstants;
    FEndOfSong:= True;
    if Assigned(TrackOutputs) then begin
      TrackOutputs.ResetEventIndexes;
      TrackOutputs.SetPatchForPosition;
      for i:= 0 to TrackOutputs.NoTracks - 1 do
        if TrackOutputs.TrackOutput[i].TrackData.FStreamList.Count > 0 then begin
          FEndOfSong:= False;
          Break
        end
    end;
end;

procedure TMidiIterator.CalcTickConstants;
begin
    if FBeatDiv > 2 then FTicksPerBeat:= FPPQN shr(FBeatDiv - 2)
    else
      if FBeatDiv < 2 then FTicksPerBeat:= FPPQN shl(2 - FBeatDiv)
      else FTicksPerBeat:= FPPQN;
    FTicksPerBar:= FTicksPerBeat * FBeatsPerBar;
end;

function GetTimesig(p: PMidiEventData; var newBeatsPerBar, newBeatDiv: Integer): Boolean;
begin
    if(p^.Data.status = $ff) and(p^.Data.SysEx [0] = #$58) then begin
      newBeatsPerBar:= Integer(p^.Data.SysEx [1]);
      newBeatDiv:= Integer(p^.Data.SysEx [2]);
      Result:= True;
    end
    else Result:= False;
end;

function GetTempo(p: PMidiEventData; var newTempo: Integer): Boolean;
begin
    if(p^.Data.status = $ff) and(p^.Data.SysEx [0] = #$51) then begin
      newTempo:=(LongInt(p^.Data.SysEx [3]) + 256 * LongInt(p^.Data.SysEx [2]) + 65536 * LongInt(p^.Data.SysEx [1])) div 1000;
      Result:= True;
    end
    else Result:= False
end;

procedure TMidiIterator.AdjustPositionsForTimesig(delta_pos: Integer);
begin
    FPosition:= FTimesigPos + delta_pos;
    FBeat:= delta_pos div FTicksPerBeat;
    FTick:= delta_pos mod FTicksPerBeat;
    FBar:= FTimesigBar + FBeat div FBeatsPerBar;
    FBeat:= FBeat mod FBeatsPerBar;
end;

procedure TMidiIterator.SkipToPosition;
var Event, i, c, n: Integer;
    p: PMidiEventData;
    Track: PMidiTrackStream;
    TrackOutput: PTrackOutput;
begin
    FEndOfSong:= True;
    if Assigned(TrackOutputs) then
      for i:= 0 to TrackOutputs.NoTracks - 1 do begin
        TrackOutput:= TrackOutputs.TrackOutput[i];
        Track:= TrackOutput.TrackData;
        c:= Track.FStreamList.Count;
        n:= TrackOutput.EventIndex;
        while n < c do begin
          p:= Track.Event [n];
          if p^.pos < FPosition then begin
            Event:= p^.Data.status and midiStatusMask;
            if (FPlayNotes and not TrackOutput.Mute) or ((Event <> midiNoteOn) and (Event <> midiNoteOff)) then
              if Event < midiSysEx then TrackOutput.Port.OutEvent(p^.Data);
//            if Event < midiSysEx then
//              TrackOutput.Port.OutEvent(p^.Data);
            Inc(n);
          end
          else Break;
        end;
        TrackOutput.EventIndex:= n;
        if n < c then FEndOfSong:= False;
      end
end;

procedure TMidiIterator.CalcNewPosition(pos: Integer);
var p: PMidiEventData;
    newBeatsperBar, newBeatDiv, newTempo: Integer;
    delta_b, deltaPos: Integer;
begin
    if pos < FPosition then Reset;

    DeltaPos:= pos - FTimesigPos;
    if DeltaPos < 0 then Exit;
    if Assigned(FMidiData) then
      if Assigned(FMidiData.Tracks[0]) then
        while FTrack0Index < FMidiData.Tracks[0].FStreamList.Count do begin
          p:= FMidiData.Tracks[0].Event[FTrack0Index];
          if p^.pos > FTimesigPos + deltaPos then Break;
          Inc(FTrack0Index);
          if GetTimesig(p, newBeatsPerBar, newBeatDiv) then begin
            delta_b:=(p^.pos - FTimesigPos) div FTicksPerBar;
            Dec(deltaPos,(p^.pos - FTimesigPos));
            if((p^.pos - FTimesigPos) mod FTicksPerBar) > 0 then Inc(delta_b);
            FTimesigPos:= p^.pos;
            FTimesigBar:= FTimesigBar + delta_b;
            FBeatDiv:= newBeatDiv;
            FBeatsPerBar:= newBeatsPerBar;
            CalcTickConstants;
          end
          else
            if GetTempo(p, newTempo) then begin
              FTempoTime:= FTempoTime +((p^.pos - FTempoPos) * FTempo) div FPPQN;
              FTempoPos:= p^.pos;
              FTempo:= newTempo
            end
        end;
    AdjustPositionsForTimesig(deltaPos);
    FTime:= FTempoTime +((FPosition - FTempoPos) * FTempo) div FPPQN;
end;

procedure TMidiIterator.SetPosition(pos: Integer);
begin
    CalcNewPosition(pos);
    SkipToPosition
end;

procedure TMidiIterator.CalcPositionFromTime(tm: Integer);
var p: PMidiEventData;
    delta_p, newTempo, newBeatsPerBar, newBeatDiv, delta_b: Integer;
begin
    if tm < FTime then Reset;
    FTime:= tm;
    delta_p:=((FTime - FTempoTime) * FPPQN) div FTempo;
    if Assigned(FMidiData) then begin
      if Assigned(FMidiData.Tracks[0]) then begin
        while FTrack0Index < FMidiData.Tracks[0].FStreamList.Count do begin
          p:= FMidiData.Tracks[0].Event[FTrack0Index];
          if p^.pos > FTempoPos + delta_p then Break;
          Inc(FTrack0Index);
          if GetTempo(p, newTempo) then begin
            FTempoTime:= FTempoTime +((p^.pos - FTempoPos) * FTempo) div FPPQN;
            FTempoPos:= p^.pos;
            FTempo:= newTempo;
            delta_p:=((FTime - FTempoTime) * FPPQN) div FTempo;
          end
          else
            if GetTimesig(p, newBeatsPerBar, newBeatDiv) then begin
              delta_b:=(p^.pos - FTimesigPos) div FTicksPerBar;
              if((p^.pos - FTimesigPos) mod FTicksPerBar) > 0 then Inc(delta_b);
              FTimesigPos:= p^.pos;
              FTimesigBar:= FTimesigBar + delta_b;
              FBeatDiv:= newBeatDiv;
              FBeatsPerBar:= newBeatsPerBar;
              CalcTickConstants;
            end
        end;
      end;
      delta_p:=(FTempoPos + delta_p)- FTimesigPos;
      AdjustPositionsForTimesig(delta_p);
    end
end;

procedure TMidiIterator.SetTime(Value: Integer);
begin
    CalcPositionFromTime(Value);
    SkipToPosition;
end;

procedure TMidiIterator.SetBarPosition(ABar, ABeat, ATick: Integer);
var p: PMidiEventData;
    newBeatsperBar, newBeatDiv, newTempo: Integer;
    deltaPos, delta_b: Integer;
begin
    if(ABar < FBar) or((ABar = FBar) and(ABeat < FBeat)) or((ABar = FBar) and(ABeat = FBeat) and(ATick < FTick)) then Reset;
    deltaPos:=(ABar - FTimesigBar) * FTicksPerBar + ABeat * FTicksPerBeat + ATick;
    if deltaPos < 0 then exit;

    if Assigned(FMidiData) and (FMidiData.TrackCount > 0) then 
      if  Assigned(FMidiData.Tracks[0]) then
        while FTrack0Index < FMidiData.Tracks[0].FStreamList.Count do begin
          p:= FMidiData.Tracks[0].Event[FTrack0Index];
          if p^.pos > FTimesigPos + deltaPos then Break;
          Inc(FTrack0Index);
          if GetTimesig(p, newBeatsPerBar, newBeatDiv) then begin
            delta_b:=(p^.pos - FTimesigPos) div FTicksPerBar;
            if((p^.pos - FTimesigPos) mod FTicksPerBar) > 0 then Inc(delta_b);
            FTimesigPos:= p^.pos;
            FTimesigBar:= FTimesigBar + delta_b;
            FBeatDiv:= newBeatDiv;
            FBeatsPerBar:= newBeatsPerBar;
            CalcTickConstants;
            deltaPos:=(ABar - FTimesigBar) * FTicksPerBar + ABeat * FTicksPerBeat + ATick
          end
          else
            if GetTempo(p, newTempo) then begin
              FTempoTime:= FTempoTime +((p^.pos - FTempoPos) * FTempo) div FPPQN;
              FTempoPos:= p^.pos;
              FTempo:= newTempo
            end
        end;
    AdjustPositionsForTimesig(deltaPos);
    FTime:= FTempoTime +((FPosition - FTempoPos) * FTempo) div FPPQN;
    SkipToPosition;
end;

procedure TMidiIterator.SetTrackOutputs(Value: PTrackOutputs);
begin
    FTrackOutputs:= Value;
    FTrackOutputs.ResetEventIndexes;
    FTrackOutputs.SetPatchForPosition
end;

procedure TMidiIterator.IterateByTime(delta_time: Integer);
begin
    FPlayNotes:= True;
    SetTime(FTime + delta_time);
    FPlayNotes:= False;
end;

{ TMidiTrackStream }

constructor TMidiTrackStream.Create;
begin
    inherited;
    FStreamList:= NewList;
end;

destructor TMidiTrackStream.Destroy;
var i: Integer;
begin
    for i:= 0 to FStreamList.Count - 1 do begin
      if PMidiEventData(FStreamList.Items[i])^.Data.status in [midiSysEx, midiSysExCont, midiMeta] then FreeMem(PMidiEventData(FStreamList.Items[i])^.Data.SysEx);
      FreeMem(FStreamList.Items[i]);
    end;
    FStreamList.Free;
    inherited;
end;

function TMidiTrackStream.LoadFromSMFStream(SMFstream: PStream): Boolean;
var hdr: array [0..3] of Char;
    TrackSize: LongInt;
    Buffer: PStream;
    GotEndOFTrack: Boolean;
    DivI: Integer;

  function DoPass: Boolean;
  var SysExFlag: Boolean;
      l, Pos: Integer;
      c, c1, Status, RunningStatus, Mess: Byte;
      Event: PMidiEventData;
      NotGotPatch, NotGotChannel, NewStatus: Boolean;
    function GetFVariNum: Integer;
    var b: Byte;
    begin
        Result:= 0;
        repeat
          b:= PByte(Integer(Buffer.Memory) + pos)^;
          Inc(pos);
          Result:=(Result shl 7) + (b and $7f);
        until (b and $80) = 0;
    end;
    function GetFChar: Byte;
    begin
      Result:= PByte(Integer(Buffer.Memory) + Pos)^;
      Inc(Pos);
    end;
  begin
      Result:= False;
      RunningStatus:= 0;
      DivI:= 0;
      NewStatus:= False;
      Pos:= 0;
      SysExFlag:= False;
      NotGotChannel:= True;
      NotGotPatch:= True;
      while Pos < TrackSize do begin
        Inc(DivI, GetFVariNum);
        c:= GetFChar;

        if SysExFlag and(c <> midiSysExCont) then Exit;

        if (c and midiStatus) <> 0 then begin
          Status:= c;
          NewStatus:= True;
        end
        else begin
          Status:= RunningStatus;
          if Status = 0 then Exit;
        end;

        New(Event);
        Event.Pos:= DivI;
        Event.Data.Status:= Status;
        FStreamList.Add(Event);

        if Status < midiSysEx then begin
          if NewStatus then begin
            c:= GetFChar;
            NewStatus:= False;
            RunningStatus:= Status;
          end;
          Mess:= Status shr 4;
          if ChanType [Mess] > 1 then c1:= GetFChar else c1:= 0;
          if NotGotPatch and(mess = $c) then begin
            NotGotPatch:= False;
            FPatch:= c;
          end;
          if NotGotChannel then begin
            NotGotChannel:= False;
            FChannel:= Status and midiChannelMask;
          end;
          Event.Data.b2:= c;
          Event.Data.b3:= c1
        end
        else begin
          NewStatus:= False;
          case status of
            midiMeta: begin
              c1:= GetFChar;
              l:= GetFVariNum;
              Event^.SysExSize:= l + 1;
              GetMem(Event^.Data.SysEx, Event^.SysExSize);
              Event^.Data.SysEx[0]:= Char(c1);
              Move(pointer(Integer(Buffer.Memory) + pos)^, Event^.Data.SysEx [1], l);
              case c1 of
                metaTrackName: FTrackName:= Event;
                metaText: if FTrackName = nil then FTrackName:= Event;
              end;
              GotEndOFTrack:= GotEndOFTrack or (c1 = metaTrackEnd);
              Inc(pos, l);
            end;
            midiSysEx, midiSysExCont: begin
              l:= GetFVariNum;
              Event^.SysExSize:= l;
              GetMem(Event^.Data.SysEx, l);
              Move(pointer(Integer(Buffer.Memory) + pos)^, Event^.Data.SysEx[0], l);
              Inc(pos, l);
              SysExFlag:= PChar(Integer(Buffer.Memory) + pos - 1)^ <> Char(midiSysExCont);
            end
          end
        end;
      end;
      Result:= True;
  end;

begin
    Result:= False;
    SMFStream.Read(hdr, sizeof(hdr));
    if StrLComp(hdr, 'MTrk', sizeof(hdr)) <> 0 then Exit;
    SMFStream.Read(TrackSize, sizeof(TrackSize));
    TrackSize:= SwapOrder32(TrackSize);

    Buffer:= NewMemoryStream;
    try
      Stream2Stream(Buffer, SMFstream, TrackSize);
      gotEndOFTrack:= False;
      if not DoPass then Exit;
      if not GotEndOFTrack then InsertMetaEvent(divi, metaTrackEnd, nil, 0);
    finally
      Buffer.Free
    end;
    if not CalcOnOffPointers then Exit;
    Result:= True;
end;

function TMidiTrackStream.GetEvent(idx: Integer): PMidiEventData;
begin
    Result:= FStreamList.Items[Idx];
end;

function TMidiTrackStream.FindEventNo(pos: Integer; tp: TFindEventType): Integer;
var i: Integer;
begin
    Result:= -1;
    if tp = feLast then begin
      for i:= FStreamList.Count-1 downto 0 do
        if PMidiEventData(FStreamList.Items[i])^.pos = pos then begin
          Result:= i; Break;
        end;
    end
    else
      for i:= 0 to FStreamList.Count-1 do
        if PMidiEventData(FStreamList.Items[i])^.pos = pos then begin
          Result:= i; Break;
        end;
end;

function TMidiTrackStream.InsertEvent(pos: Integer; var Data: TEventData; SysExSize: Integer): PMidiEventData;
var Num: Integer;
    p: PMidiEventData;
begin
    New(Result);
    Result^.pos:= pos;
    Result^.SysExSize:= SysExSize;
    Result^.Data:= Data;

    Num:= -1;
    if FStreamList.Count > 0 then begin
      p:= Event[FStreamList.Count - 1];
      if (p <> nil) and (p^.Data.status = midiMeta) and (p^.Data.SysEx [0] = Char(metaTrackEnd)) and (p^.pos < pos) then p^.pos:= pos;
      Num:= FindEventNo(pos, feLast);
    end;

    if Num = -1 then FStreamList.Add(Result) else FStreamList.Insert(Num, Result);
    if Event[FStreamList.Count - 1] <> Result then CalcOnOffPointers;
end;

function TMidiTrackStream.InsertMetaEvent(pos: Integer; MetaEvent: Byte; Data: PChar; DataLen: Integer): PMidiEventData;
var Evnt: TEventData;
begin
    Evnt.Status:= midiMeta;
    GetMem(Evnt.SysEx, DataLen + 1);
    Evnt.SysEx [0]:= Char(MetaEvent);
    if DataLen > 0 then Move(Data [0], Evnt.SysEx [1], DataLen);
    Result:= InsertEvent(pos, Evnt, DataLen + 1);
end;

function TMidiTrackStream.CalcOnOffPointers: Boolean;
var i, t, s, b, n: Integer;
    sp: PMidiEventData;
    NoteOns: array [0..4, TNote] of PMidiEventData;
    NoteOnCount: array [TNote] of Byte;
begin
    Result:= False;
    ZeroMemory(@noteOnCount, SizeOf(NoteOnCount));
    for i:= 0 to FStreamList.Count - 1 do begin
      t:= 0;
      sp:= FStreamList.Items[i];
      s:= sp^.Data.status and midiStatusMask;
      if s = midiNoteOn then
        if sp^.Data.b3 <> 0 then t:= 1
        else t:= 2
      else
        if s = midiNoteOff then t:= 2;
      case t of
        1: begin
          b:= sp^.Data.b2;
          n:= NoteOnCount [b];
          if n < 5 then begin
            noteOns [n, b]:= sp;
            NoteOnCount [b]:= n + 1
          end
        end;
        2: begin
          b:= sp^.Data.b2;
          n:= NoteOnCount [b];
          if n > 0 then begin
            Dec(n);
            sp^.OnOfFEvent:= NoteOns [n, b];
            NoteOns [n, b]^.OnOfFEvent:= sp;
            NoteOnCount [b]:= n
          end
        end
      end;
    end;
    try
      for i:= Low(TNote) to High(TNote) do if NoteOnCount [i] <> 0 then Exit;
    except
    end;
    Result:= True;
end;

{ TPhysicalOutputPort }

constructor TPhysicalOutputPort.Create(pID: Integer; User: PMidiOutputPort);
var chan: TChannel;
begin
    inherited Create;
    portID:= pID;
    if not Assigned(PortList) then PortList:= NewList;
    PortNo:= PortList.Count;
    PortList.Add(@self);
    UserList:= NewList;
    AddUser(User);
    for chan:= Low(TChannel) to High(TChannel) do begin
      Move(ControllerDefaults [0], ControllerArray [chan, 0], sizeof(Integer) * High(TController));
      CurrentPatch [chan]:= 0;
      CurrentBank [chan]:= 127;
    end;
    midiOutOpen(@Handle, portID, 0, MAKELONG(word(PortNo), word(User.UserNo)), CALLBACK_NULL){ = MMSYSERR_NOERROR};
end;

destructor TPhysicalOutputPort.Destroy;
var i: Integer;
    KeepList: Boolean;
begin
    midiOutReset(Handle);
  //  Applet.ProcessMessages;
    midiOutClose(Handle);
  //  Applet.ProcessMessages;
    KeepList:= False;
    PortList.Items[PortNo]:= nil;
    for i:= 0 to PortList.Count - 1 do
      if PortList.items [i] <> nil then begin
        KeepList:= True;
        Break;
      end;
    if not KeepList then begin
      PortList.Free;
      PortList:= nil
    end;
    UserList.Free;
    inherited;
end;

procedure TPhysicalOutputPort.PatchChange(Patch: TPatchNo; Channel: TChannel);
var Event: TEventData;
begin
    if patch <> CurrentPatch [Channel] then begin
      Event.status:= midiProgramChange + Channel;
      Event.b2:= Patch;
      Event.b3:= 0;
      CurrentPatch [Channel]:= Patch;
      midiOutShortMsg(handle, PInteger(@Event.status)^);
    end
end;

procedure TPhysicalOutputPort.RemoveUser(User: PMidiOutputPort);
var stillInUse: Boolean;
    i: Integer;
begin
    stillInUse:= False;
    for i:= 0 to UserList.Count - 1 do
      if(UserList.items [i] <> nil) and(i <> User.UserNo) then begin
        stillInUse:= True;
        Break;
      end;
    if not stillInUse then begin
      if User.UserNo <> 0 then UserList.Items [0]:= UserList.Items [User.UserNo];
      Free;
    end
    else UserList.Items [User.UserNo]:= nil;
end;

procedure TPhysicalOutputPort.AddUser(User: PMidiOutputPort);
var slotNo, i: Integer;
begin
    slotNo:= -1;
    for i:= 0 to UserList.Count - 1 do
      if not Assigned(UserList.Items [i]) then begin
        slotNo:= i;
        Break;
      end;
    if slotNo <> -1 then begin
      UserList.Items [slotNo]:= User;
      User.UserNo:= slotNo;
    end
    else begin
      User.UserNo:= UserList.Count;
      UserList.Add(User);
    end
end;

procedure TPhysicalOutputPort.ResetControllers;
var Channel: TChannel;
    Controller: TController;
    Event: TEventData;
begin
    for Channel:= Low(TChannel) to High(TChannel) do begin
      Event.Status:= midiController + Channel;
      for Controller:= Low(TController) to High(TController) do
        if ControllerArray [Channel, controller] <> ControllerDefaults [controller] then begin
          Event.b2:= controller;
          Event.b3:= ControllerDefaults [controller];
          midiOutShortMsg(handle,PInteger(@Event.status)^);
          ControllerArray [Channel, controller]:= ControllerDefaults [controller];
        end
    end
end;

procedure CloseAllPhysicalPorts;
var i: Integer;
begin
  if Assigned(PortList) then
    for i:= 0 to PortList.Count - 1 do
      if PortList.items [i] <> nil then PPhysicalOutputPort(PortList.items[i]).Free;
end;

{ TMidiOutputPort }

constructor TMidiOutputPort.Create(AOwner: PTrackOutput);
begin
    inherited Create;
    FOwner:= AOwner;
    if FOwner <> nil then AOwner.FList.Add(@Self);
    FSysExHeaders:= NewList;
    FSysExLatency:= 50;
end;

destructor TMidiOutputPort.Destroy;
begin
    Active:= False;
    WaitForSysEx;
    if FOwner <> nil then FOwner.FList.Remove(@Self);
    FSysExHeaders.Free;
    inherited;
end;

procedure TMidiOutputPort.SetPortId(Value: Integer);
var oldActive: Boolean;
begin
    if Value <> FPortID then begin
      oldActive:= Active;
      Active:= False;
      FPortID:= Value;
      Active:= oldActive
    end
end;

function TMidiOutputPort.GetActive: Boolean;
begin
    Result:= Assigned(FPhysicalPort);
end;

procedure TMidiOutputPort.SetActive(Value: Boolean);
var i: Integer;
begin
    if Value <> Active then
    if Value then begin
      if Assigned(PortList) then
        for i:= 0 to PortList.Count - 1 do
          if Assigned(PortList.Items [i]) then
            if PPhysicalOutputPort(PortList.Items[i]).PortID = self.PortID then begin
              FPhysicalPort:= PPhysicalOutputPort(PortList.Items[i]);
              Break;
            end;
      if not Assigned(FPhysicalPort) then New(FPhysicalPort, Create(FPortID, @self))
      else FPhysicalPort.AddUser(@self)
    end
    else begin
      AllNotesOff;
      ResetControllers;
      FPhysicalPort.RemoveUser(@self);
      FPhysicalPort:= nil
    end
end;

function TMidiOutputPort.GetHandle: HMidiOut;
begin
    if Active then Result:= FPhysicalPort.Handle
    else Result:= 0;
end;

procedure TMidiOutputPort.OutEvent(const Event: TEventData);
var Channel: Byte;
begin
    if Assigned(FPhysicalPort) then begin
      if Event.status < midiSysEx then begin
        midiOutShortMsg(handle, PInteger(@Event.status)^);
        Channel:= Event.status and midiChannelMask;
        case Event.status and midiStatusMask of
          midiNoteOn: begin
            if Event.b3 = 0 then begin
              if NoteArray[Channel, Event.b2] > 0 then Dec(NoteArray[Channel, Event.b2])
            end
            else Inc(NoteArray[Channel, Event.b2]);
          end;
          midiNoteOff: if NoteArray[Channel, Event.b2] > 0 then Dec(NoteArray[Channel, Event.b2]);
          midiController: FPhysicalPort.ControllerArray[Channel, Event.b2]:= Event.b3;
          midiProgramChange: FPhysicalPort.CurrentPatch[Channel]:= Event.b2
        end
      end
    end
end;

procedure TMidiOutputPort.AllNotesOff;
var Channel: TChannel;
    Note: TNote;
    Event: TEventData;
begin
    for Channel:= Low(TChannel) to High(TChannel) do begin
      Event.Status:= midiNoteOff + Channel;
      Event.b3:= 0;
      for Note:= Low(TNote) to High(TNote) do begin
        Event.b2:= note;
        while NoteArray [Channel, note] > 0 do OutEvent(Event);
      end
    end;
    if Assigned(FPhysicalPort) then
      for Channel:= Low(TChannel) to High(TChannel) do
        if FPhysicalPort.ControllerArray [Channel, 64] <> ControllerDefaults [64] then begin
          Event.b3:= ControllerDefaults [64];
          Event.Status:= midiController + Channel; 
          Event.b2:= 64;
          OutEvent(Event)
        end
end;

procedure TMidiOutputPort.ResetControllers;
begin
    if Active then FPhysicalPort.ResetControllers
end;

procedure TMidiOutputPort.PatchChange(patch: TPatchNo; Channel: TChannel);
begin
    if Active then FPhysicalPort.PatchChange(patch, Channel);
end;

procedure TMidiOutputPort.TidySysExHeaders;
var i: Integer;
    hdr: PMidiHdr;
begin
    i:= 0;
    while i < FSysExHeaders.Count do begin
      hdr:= PMidiHdr(FSysExHeaders.Items[i]);
      if(hdr^.dwFlags and MHDR_DONE) = MHDR_DONE then begin
        MidiOutUnprepareHeader(handle, hdr, sizeof(hdr^));
        FreeMem(hdr^.lpData);
        FSysExHeaders.Delete(i);
      end
      else Inc(i)
    end
end;

procedure TMidiOutputPort.WaitForSysEx;
begin
    repeat
      TidySysExHeaders;
      Sleep(FSysExLatency);
    until FSysExHeaders.Count = 0;
end;

initialization

finalization
    CloseAllPhysicalPorts;
end.
