//****************************************************************************/
//* Based on the MIDI device classes by Adrian Meyer
//* This File was taken from the ZIP archive 'demo_MidiDevices_D6.zip'
//****************************************************************************/
//* V1.1 Delphi 6 Windows 2000
//****************************************************************************/
//* V1.0 First release with simple MIDI Input/Output
//* V1.1 SysEx Input Event added, refactured error handling
//* V1.2 SysEx Output procedure added, changes sysex input for multiple ports
//* V1.3 Changes by BREAKOUTBOX 2009-07  (www.breakoutbox.de)
//* V1.4 Changes adapted from DAV_MidiIO.pas - see http://www.ohloh.net/p/DAV
//*      -
//*                  - latest changes 2010-07-22 -
//****************************************************************************/
//* Homepage: http://www.midimountain.com
//****************************************************************************/
//* If you get a hold of this source you may use it upon your own risk. Please
//* let me know if you have any questions: adrian.meyer@rocketmail.com.
//****************************************************************************/

unit Midi;
                                  
interface                      

uses
  {$IFDEF FPC} LCLIntf,
  {$ELSE} Windows,
  {$ENDIF}
  Forms, Classes, Messages, SysUtils, Math, Contnrs, MMSystem;

const
  // size of system exclusive buffer
  cSysExBufferSize = 2048;
type
  TMIDIChannel                = 1..16;
  TMIDIDataByte               = 0..$7F;           //  7 bits
  TMIDIDataWord               = 0..$3FFF;         // 14 bits
  TMIDIStatusByte             = $80..$FF;
  TMIDIVelocity               = TMIDIDataByte;
  TMIDIKey                    = TMIDIDataByte;
  TMIDINote                   = TMIDIKey;

type
  // event if data is received
  TOnMidiInData = procedure (const aDeviceIndex: integer; const aStatus, aData1, aData2: byte) of object;
  // event if system exclusive data is received
  TOnSysExData = procedure (const aDeviceIndex: integer; const aStream: TMemoryStream) of object;

  EMidiDevices = Exception;

  // base class for MIDI devices
  TMidiDevices = class
  private
    fDevices: TStringList;
    fMidiResult: MMResult;
    procedure SetMidiResult(const Value: MMResult);
  protected
    property MidiResult: MMResult read fMidiResult write SetMidiResult;
    function GetHandle(const aDeviceIndex: integer): THandle;
  public
    // create the MIDI devices
    constructor Create; virtual;
    // whack the devices
    destructor Destroy; override;
    // open a specific device
    procedure Open(const aDeviceIndex: integer); virtual; abstract;
    // close a specific device
    procedure Close(const aDeviceIndex: integer); virtual; abstract;
    // close all devices
    procedure CloseAll;
    // THE devices
    function IsOpen(ADeviceIndex: Integer): Boolean;                            // check if open
    property Devices: TStringList read fDevices;
  end;

  // MIDI input devices
  TMidiInput = class(TMidiDevices)
  private
    fOnMidiData: TOnMidiInData;
    fOnSysExData: TOnSysExData;
    fSysExData: TObjectList;
  protected
    procedure DoSysExData(const aDeviceIndex: integer);
  public
    // create an input device
    constructor Create; override;
    // what the input devices
    destructor Destroy; override;
    // open a specific input device
    procedure Open(const aDeviceIndex: integer); override;
    // close a specific device
    procedure Close(const aDeviceIndex: integer); override;
    // midi data event
    property OnMidiData: TOnMidiInData read fOnMidiData write fOnMidiData;
    // midi system exclusive is received
    property OnSysExData: TOnSysExData read fOnSysExData write fOnSysExData;
  end;

  // MIDI output devices
  TMidiOutput = class(TMidiDevices)
    constructor Create; override;
    // open a specific input device
    procedure Open(const aDeviceIndex: integer); override;
    // close a specific device
    procedure Close(const aDeviceIndex: integer); override;
    // send some midi data to the indexed device
    procedure Send(const aDeviceINdex: integer; const aStatus, aData1, aData2: byte);
    procedure SendSystemReset( const aDeviceIndex: integer);
    procedure SendAllSoundOff(const aDeviceIndex: integer; const channel: byte);
    // send system exclusive data to a device
    procedure SendSysEx(const aDeviceIndex: integer; const aStream: TMemoryStream); overload;
    procedure SendSysEx(const aDeviceIndex: integer; const aString: string); overload;
  end;

  // convert the stream into xx xx xx xx string
  function SysExStreamToStr(const aStream: TMemoryStream): string;
  // fill the string in a xx xx xx xx into the stream  
  procedure StrToSysExStream(const aString: string; const aStream: TMemoryStream);

  // MIDI input devices
  function MidiInput: TMidiInput;
  // MIDI output Devices
  function MidiOutput: TMidiOutput;

implementation

{ TMidiBase }
type
  TSysExBuffer = array[0..cSysExBufferSize] of char;

  TSysExData = class
  private
    fSysExStream: TMemoryStream;
  public
    SysExHeader: {$IFDEF FPC}_midihdr{$ELSE}TMidiHdr{$ENDIF};
    SysExData: TSysExBuffer;
    constructor Create;
    destructor Destroy; override;
    property SysExStream: TMemoryStream read fSysExStream;
  end;

constructor TMidiDevices.Create;
begin
  FDevices:= TStringLIst.create;
end;

destructor TMidiDevices.Destroy;
begin
  FreeAndNil( FDevices);
  inherited;
end;

var
  gMidiInput: TMidiInput;
  gMidiOutput: TMidiOutput;

function MidiInput: TMidiInput;
begin
  if not assigned(gMidiInput) 
    then gMidiInput := TMidiInput.Create;
  Result := gMidiInput;
end;

function MidiOutput: TMidiOutput;
begin
  if not assigned(gMidiOutput) 
    then gMidiOutput := TMidiOutput.Create;
  Result := gMidiOutput;
end;

{ *** TMidiInput ************************************************************* }

type
{$IFDEF FPC}
  PHMIDIIN = ^HMIDIIN;
  TMidiOutCaps = TMidiOutCapsA;
{$ENDIF}

{ I don't know whatfor this RECORD is used in DAV_MidiIO.pas
  but I think this maybe allows renumeration / resorting of MIDI devices
  for use in Your application - I didn't use this until now
  so I didn't take over the implementation in my MIDI.PAS ... !

TMidiInputDeviceRecord = record
    MidiInput    : TMidiInput;
    DeviceNumber : Integer;
  end;
  PMidiInputDeviceRecord = ^TMidiInputDeviceRecord;
}

{ the CallBack-Procedure receives MIDI data on interrupt : }
procedure midiInCallback( aMidiInHandle: PHMIDIIN; aMsg: Integer; aInstance,
                          aMidiData, aTimeStamp: integer); stdcall;
begin
  case aMsg of
    MIM_DATA:
      begin
        if assigned(MidiInput.OnMidiData) then
          begin
            MidiInput.OnMidiData( aInstance, aMidiData and $000000FF,
              ( aMidiData and $0000FF00) shr 8, ( aMidiData and $00FF0000) shr 16);
            PostMessage( Application.MainForm.Handle, WM_USER +2, aInstance, aMidiData);
          end;
      end;

    MIM_LONGDATA:
      MidiInput.DoSysExData(aInstance);
    MIM_ERROR,
    MIM_LONGERROR: raise Exception.Create('Midi In Error!');
  end;
end;

procedure TMidiInput.Close(const aDeviceIndex: integer);
begin
  if GetHandle(aDeviceIndex) <> 0 then
  begin
    MidiResult := midiInStop(GetHandle(aDeviceIndex));
    MidiResult := midiInReset(GetHandle(aDeviceIndex));
    MidiResult := midiInUnprepareHeader(GetHandle(aDeviceIndex),
                  @TSysExData(fSysExData[aDeviceIndex]).SysExHeader, SizeOf(TMidiHdr));
    MidiResult := midiInClose(GetHandle(aDeviceIndex));
    FDevices.Objects[aDeviceIndex] := nil;
  end;
end;
                         
procedure TMidiDevices.CloseAll;
var
  i: integer;
begin
  for i:= 0 to FDevices.Count - 1 do Close(i);
end;

constructor TMidiInput.Create;
var i: integer;
    AvailableMIDIinputs : integer;
    lInCaps : TMidiInCaps;
begin
  inherited;
  fSysExData := TObjectList.Create(true);
  TRY   // TRY..EXCEPT was adapted from DAV_MidiIO.pas
    AvailableMIDIinputs:= midiInGetNumDevs;
  EXCEPT
    AvailableMIDIinputs:= 0;
  end;

  //ShowMessage( 'AvailableMIDIinputs = ' +IntToStr( AvailableMIDIinputs));
  if AvailableMIDIinputs > 0 then
  for i:= 0 to AvailableMIDIinputs - 1 do
  begin
    MidiResult := midiInGetDevCaps(i, @lInCaps, SizeOf(TMidiInCaps));
    if MidiResult = MMSYSERR_NOERROR then
      begin
        fDevices.Add(StrPas(lInCaps.szPname));
        fSysExData.Add(TSysExData.Create);
      end;
  end;
end;

procedure TMidiInput.Open(const aDeviceIndex: integer);
var
  lHandle: THandle;
  lSysExData: TSysExData;
begin
  if GetHandle(aDeviceIndex) <> 0 then Exit;

  MidiResult := midiInOpen( @lHandle, aDeviceIndex, cardinal(@midiInCallback),
                            aDeviceIndex, CALLBACK_FUNCTION);

  fDevices.Objects[ aDeviceIndex ] := TObject(lHandle);
  lSysExData := TSysExData(fSysExData[aDeviceIndex]);

  lSysExData.SysExHeader.dwFlags := 0;

  MidiResult := midiInPrepareHeader(lHandle, @lSysExData.SysExHeader, SizeOf(TMidiHdr));
  MidiResult := midiInAddBuffer( lHandle, @lSysExData.SysExHeader, SizeOf(TMidiHdr));
  MidiResult := midiInStart( lHandle);
end;

{ ***** TMidiInput - SysEx *************************************************** }
procedure TMidiInput.DoSysExData(const aDeviceIndex: integer);
var
  lSysExData: TSysExData;
begin
  lSysExData := TSysExData(fSysExData[aDeviceIndex]);
  if lSysExData.SysExHeader.dwBytesRecorded = 0 then Exit;

  lSysExData.SysExStream.Write( lSysExData.SysExData,
                                lSysExData.SysExHeader.dwBytesRecorded);
  if lSysExData.SysExHeader.dwFlags and MHDR_DONE = MHDR_DONE then
  begin
    lSysExData.SysExStream.Position := 0;
    if assigned(fOnSysExData)
      then fOnSysExData(aDeviceIndex, lSysExData.SysExStream);
    lSysExData.SysExStream.Clear;
  end;

  lSysExData.SysExHeader.dwBytesRecorded := 0;
  MidiResult := midiInPrepareHeader( GetHandle(aDeviceIndex),
                                     @lSysExData.SysExHeader, SizeOf(TMidiHdr));
  MidiResult := midiInAddBuffer( GetHandle(aDeviceIndex), @lSysExData.SysExHeader,
                                 SizeOf( TMidiHdr));
end;

destructor TMidiInput.Destroy;
begin
  FreeAndNil( fSysExData);
  inherited;
end;


{ *** TMidiOutput ************************************************************ }
constructor TMidiOutput.Create;
var
  AvailableMIDIoutputs : integer;
  i : integer;
  lOutCaps: TMidiOutCaps;
begin
  inherited;
try
  AvailableMIDIoutputs := midiOutGetNumDevs;
except
  AvailableMIDIoutputs := 0;
end;

  for i:= 0 to AvailableMIDIoutputs - 1 do
  begin
    MidiResult := midiOutGetDevCaps( i, @lOutCaps, SizeOf(TMidiOutCaps));
    fDevices.Add( lOutCaps.szPname);
  end;
end;

procedure TMidiOutput.Open(const aDeviceIndex: integer);
var
  lHandle: THandle;
begin
  //inherited;  // Lazarus doesn't like this - so:  commented out
  // device already open;
  if GetHandle(aDeviceIndex) <> 0 then exit;

  MidiResult := midiOutOpen( @lHandle, aDeviceIndex, 0, 0, CALLBACK_NULL);
  fDevices.Objects[ aDeviceIndex ]:= TObject( lHandle);
end;

procedure TMidiOutput.Close(const aDeviceIndex: integer);
begin
  //inherited;  // Lazarus doesn't like this - so:  commented out
  if GetHandle(aDeviceIndex) <> 0 then // 'if .. then' added by BREAKOUTBOX 2009-07-15
    begin
      MidiResult := midiOutClose(GetHandle(aDeviceIndex));
      fDevices.Objects[ aDeviceIndex ] := nil;
    end;
end;

procedure TMidiOutput.Send( const aDeviceINdex: integer; const aStatus,
                            aData1, aData2: byte);
var
  lMsg: cardinal;
begin
  // open if the device is not open
  if not assigned(fDevices.Objects[ aDeviceIndex ])
    then exit;  // Open( aDeviceIndex);  // Breakoutbox changed 2008-07-01

  //lMsg := aStatus + (aData1 * $100) + (aData2 * $10000);
  lMsg:= aStatus or (aData1 shl 8) or (aData2 shl 16); // better ?
  MidiResult := midiOutShortMsg(GetHandle(aDeviceIndex), lMSG);
end;

{ --- common MIDI Out messages ----------------------------------------------- }
{ System Reset = Status Byte FFh }
procedure TMidiOutput.SendSystemReset( const aDeviceIndex: integer);
begin
  self.Send( aDeviceIndex, $FF, $0, $0);
end;

{ All Sound Off = Status + Channel Byte Bnh, n = Channel number  }
{                 Controller-ID = Byte 78h,  2nd Data-Byte = 00h }
procedure TMidiOutput.SendAllSoundOff(const aDeviceIndex: integer; const channel: byte);
begin
  self.Send( aDeviceIndex, $b0 +channel, $78, $0);
end;


procedure TMidiDevices.SetMidiResult(const Value: MMResult);
var
  lError: array[0..MAXERRORLENGTH] of char;
begin
  fMidiResult := Value;
  if fMidiResult <> MMSYSERR_NOERROR then
    if midiInGetErrorText(fMidiResult, @lError, MAXERRORLENGTH) = MMSYSERR_NOERROR
      then raise EMidiDevices.Create(StrPas(lError));
end;

function TMidiDevices.GetHandle(const aDeviceIndex: integer): THandle;
begin
try
  if not InRange(aDeviceIndex, 0, fDevices.Count - 1) then
    raise EMidiDevices.CreateFmt('%s: Device index out of bounds! (%d)', [ClassName,aDeviceIndex]);

  Result:= THandle(fDevices.Objects[ aDeviceIndex ]);
except
  Result:= 0;
end;
end;

function TMidiDevices.IsOpen(ADeviceIndex: Integer): boolean;
begin
 Result := GetHandle(ADeviceIndex) <> 0;
end;

{ ***** TMidiOutput - SysEx ************************************************** }
procedure TMidiOutput.SendSysEx(const aDeviceIndex: integer;
  const aString: string);
var
  lStream: TMemoryStream;
begin
  lStream := TMemoryStream.Create;
  try
    StrToSysExStream(aString, lStream);
    SendSysEx(aDeviceIndex, lStream);
  finally
    FreeAndNil(lStream);
  end;
end;

procedure TMidiOutput.SendSysEx(const aDeviceIndex: integer;
  const aStream: TMemoryStream);
var
  lSysExHeader: TMidiHdr;
begin
  aStream.Position := 0;
  lSysExHeader.dwBufferLength := aStream.Size;
  lSysExHeader.lpData := aStream.Memory;
  lSysExHeader.dwFlags := 0;

  MidiResult := midiOutPrepareHeader(GetHandle(aDeviceIndex), @lSysExHeader, SizeOf(TMidiHdr));
  MidiResult := midiOutLongMsg( GetHandle(aDeviceIndex), @lSysExHeader, SizeOf(TMidiHdr));
  MidiResult := midiOutUnprepareHeader(GetHandle(aDeviceIndex), @lSysExHeader, SizeOf(TMidiHdr));
end;

{ TSysExData }

constructor TSysExData.Create;
begin
  SysExHeader.dwBufferLength := cSysExBufferSize;
  SysExHeader.lpData := SysExData;
  fSysExStream := TMemoryStream.Create;
end;

destructor TSysExData.Destroy;
begin
  FreeAndNil( fSysExStream);
end;

function SysExStreamToStr(const aStream: TMemoryStream): string;
var
  i: integer;
begin
  result := '';
  aStream.Position:= 0;
  for i:=0 to aStream.Size - 1 do
    Result := Result + Format('%.2x ', [ byte(pchar(aStream.Memory)[i]) ]);
end;

procedure StrToSysExStream(const aString: string; const aStream: TMemoryStream);
const
  cHex = '123456789ABCDEF';
var
  i: integer;
  lStr: string;
  L: integer;
begin
  // check on errors  - added by BREAKOUTBOX 2009-07-30
  L := length( aString);
  if not (L mod 2 = 0) // as HEX every byte must be two chars long, for example '0F'
    then raise EMidiDevices.Create( 'SysEx string corrupted')
    else if l < 10  // shortest System Exclusive Message = 5 bytes = 10 hex chars
           then raise EMidiDevices.Create( 'SysEx string too short');

  lStr := StringReplace(AnsiUpperCase(aString), ' ', '', [rfReplaceAll]);
  aStream.Size := Length(lStr) div 2; // ' - 1' removed by BREAKOUTBOX 2009-07-15
  aStream.Position := 0;

  for i:=1 to aStream.Size do
    pchar(aStream.Memory)[i-1] :=
      char(AnsiPos(lStr[ i*2 - 1], cHex) shl 4 + AnsiPos(lStr[i*2], cHex));
end;


initialization
  gMidiInput := nil;
  gMidiOutput := nil;

finalization
  FreeAndNil(gMidiInput);
  FreeAndNil(gMidiOutput);

end.