path: root/VideoPreview/src/lib/midi/Midiin.pas

{ $Header: /MidiComp/Midiin.pas 2     10/06/97 7:33 Davec $ }

{ Written by David Churcher <dchurcher@cix.compulink.co.uk>,
  released to the public domain. }

unit MidiIn;

{
  Properties:
 DeviceID: 	Windows numeric device ID for the MIDI input device.
 Between 0 and NumDevs-1.
 Read-only while device is open, exception when changed while open

 MIDIHandle:	The input handle to the MIDI device.
 0 when device is not open
 Read-only, runtime-only

 MessageCount:	Number of input messages waiting in input buffer

 Capacity:	Number of messages input buffer can hold
 Defaults to 1024
 Limited to (64K/event size)
 Read-only when device is open (exception when changed while open)

 SysexBufferSize:	Size in bytes of each sysex buffer
 Defaults to 10K
 Minimum 0K (no buffers), Maximum 64K-1

 SysexBufferCount:	Number of sysex buffers
 Defaults to 16
 Minimum 0 (no buffers), Maximum (avail mem/SysexBufferSize)
 Check where these buffers are allocated?

 SysexOnly: True to ignore all non-sysex input events. May be changed while
 device is open. Handy for patch editors where you have lots of short MIDI
 events on the wire which you are always going to ignore anyway.

 DriverVersion: Version number of MIDI device driver. High-order byte is
 major version, low-order byte is minor version.

 ProductName: Name of product (e.g. 'MPU 401 In')

 MID and PID: Manufacturer ID and Product ID, see
 "Manufacturer and Product IDs" in MMSYSTEM.HLP for list of possible values.

  Methods:
 GetMidiEvent: Read Midi event at the head of the FIFO input buffer.
 Returns a TMyMidiEvent object containing MIDI message data, timestamp,
 and sysex data if applicable.
 This method automatically removes the event from the input buffer.
 It makes a copy of the received sysex buffer and puts the buffer back
 on the input device.
 The TMyMidiEvent object must be freed by calling MyMidiEvent.Free.

 Open: Opens device. Note no input will appear until you call the Start
 method.

 Close: Closes device. Any pending system exclusive output will be cancelled.

 Start: Starts receiving MIDI input.

 Stop: Stops receiving MIDI input.

  Events:
 OnMidiInput: Called when MIDI input data arrives. Use the GetMidiEvent to
 get the MIDI input data.

 OnOverflow: Called if the MIDI input buffer overflows. The caller must
 clear the buffer before any more MIDI input can be received.

 Notes:
 Buffering: Uses a circular buffer, separate pointers for next location
 to fill and next location to empty because a MIDI input interrupt may
 be adding data to the buffer while the buffer is being read. Buffer
 pointers wrap around from end to start of buffer automatically. If
 buffer overflows then the OnBufferOverflow event is triggered and no
 further input will be received until the buffer is emptied by calls
 to GetMidiEvent.

 Sysex buffers: There are (SysexBufferCount) buffers on the input device.
 When sysex events arrive these buffers are removed from the input device and
 added to the circular buffer by the interrupt handler in the DLL.  When the sysex events
 are removed from the circular buffer by the GetMidiEvent method the buffers are
 put back on the input. If all the buffers are used up there will be no
 more sysex input until at least one sysex event is removed from the input buffer.
 In other	words if you're expecting lots of sysex input you need to set the
 SysexBufferCount property high enough so that you won't run out of
 input buffers before you get a chance to read them with GetMidiEvent.

 If the synth sends a block of sysex that's longer than SysexBufferSize it
 will be received as separate events.
 TODO: Component derived from this one that handles >64K sysex blocks cleanly
 and can stream them to disk.

 Midi Time Code (MTC) and Active Sensing: The DLL is currently hardcoded
 to filter these short events out, so that we don't spend all our time
 processing them.
 TODO: implement a filter property to select the events that will be filtered
 out.
}

interface

{$IFDEF FPC}
  {$MODE Delphi}
  {$H+} // use long strings
{$ENDIF}

uses
  Classes,
  SysUtils,
  Messages,
  Windows,
  MMSystem,
  {$IFDEF FPC}
  WinAllocation,
  {$ENDIF}
  MidiDefs,
  MidiType,
  MidiCons,
  Circbuf,
  Delphmcb;

type
  MidiInputState = (misOpen, misClosed, misCreating, misDestroying);
  EMidiInputError = class(Exception);

 {-------------------------------------------------------------------}
  TMidiInput = class(TComponent)
  private
    Handle: THandle; { Window handle used for callback notification }
    FDeviceID: Word; { MIDI device ID }
    FMIDIHandle: HMIDIIn; { Handle to input device }
    FState: MidiInputState; { Current device state }

    FError: Word;
    FSysexOnly: Boolean;

 { Stuff from MIDIINCAPS }
    FDriverVersion: MMVERSION;
    FProductName: string;
    FMID: Word; { Manufacturer ID }
    FPID: Word; { Product ID }

 { Queue }
    FCapacity: Word; { Buffer capacity }
    PBuffer: PCircularBuffer; { Low-level MIDI input buffer created by Open method }
    FNumdevs: Word; { Number of input devices on system }

 { Events }
    FOnMIDIInput: TNotifyEvent; { MIDI Input arrived }
    FOnOverflow: TNotifyEvent; { Input buffer overflow }
 { TODO: Some sort of error handling event for MIM_ERROR }

 { Sysex }
    FSysexBufferSize: Word;
    FSysexBufferCount: Word;
    MidiHdrs: Tlist;

    PCtlInfo: PMidiCtlInfo; { Pointer to control info for DLL }

  protected
    procedure Prepareheaders;
    procedure UnprepareHeaders;
    procedure AddBuffers;
    procedure SetDeviceID(DeviceID: Word);
    procedure SetProductName(NewProductName: string);
    function GetEventCount: Word;
    procedure SetSysexBufferSize(BufferSize: Word);
    procedure SetSysexBufferCount(BufferCount: Word);
    procedure SetSysexOnly(bSysexOnly: Boolean);
    function MidiInErrorString(WError: Word): string;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    property MIDIHandle: HMIDIIn read FMIDIHandle;

    property DriverVersion: MMVERSION read FDriverVersion;
    property MID: Word read FMID; { Manufacturer ID }
    property PID: Word read FPID; { Product ID }

    property Numdevs: Word read FNumdevs;

    property MessageCount: Word read GetEventCount;
 { TODO: property to select which incoming messages get filtered out }

    procedure Open;
    procedure Close;
    procedure Start;
    procedure Stop;
 { Get first message in input queue }
    function GetMidiEvent: TMyMidiEvent;
    procedure MidiInput(var Message: TMessage);

   { Some functions to decode and classify incoming messages would be good }

  published

 { TODO: Property editor with dropdown list of product names }
    property ProductName: string read FProductName write SetProductName;

    property DeviceID: Word read FDeviceID write SetDeviceID default 0;
    property Capacity: Word read FCapacity write FCapacity default 1024;
    property Error: Word read FError;
    property SysexBufferSize: Word
      read FSysexBufferSize
      write SetSysexBufferSize
      default 10000;
    property SysexBufferCount: Word
      read FSysexBufferCount
      write SetSysexBufferCount
      default 16;
    property SysexOnly: Boolean
      read FSysexOnly
      write SetSysexOnly
      default False;

 { Events }
    property OnMidiInput: TNotifyEvent read FOnMidiInput write FOnMidiInput;
    property OnOverflow: TNotifyEvent read FOnOverflow write FOnOverflow;

  end;

procedure Register;

{====================================================================}
implementation

uses Controls,
     Graphics;

(* Not used in Delphi 3
{ This is the callback procedure in the external DLL.
  It's used when midiInOpen is called by the Open method.
  There are special requirements and restrictions for this callback
  procedure (see midiInOpen in MMSYSTEM.HLP) so it's impractical to
  make it an object method }
{$IFDEF MSWINDOWS}
function midiHandler(
    hMidiIn: HMidiIn;
    wMsg: UINT;
    dwInstance: DWORD;
    dwParam1: DWORD;
    dwParam2: DWORD): Boolean; stdcall; external 'DELMID32.DLL';
{$ENDIF}
*)
{-------------------------------------------------------------------}

constructor TMidiInput.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FState := misCreating;

  FSysexOnly := False;
  FNumDevs := midiInGetNumDevs;
  MidiHdrs := nil;

 { Set defaults }
  if  (FNumDevs > 0) then
    SetDeviceID(0);
  FCapacity := 1024;
  FSysexBufferSize := 4096;
  FSysexBufferCount := 16;

 { Create the window for callback notification }
  if not (csDesigning in ComponentState) then
  begin
    Handle := AllocateHwnd(MidiInput);
  end;

  FState := misClosed;

end;

{-------------------------------------------------------------------}
{ Close the device if it's open }

destructor TMidiInput.Destroy;
begin
  if (FMidiHandle <> 0) then
  begin
    Close;
    FMidiHandle := 0;
  end;

  if (PCtlInfo <> nil) then
    GlobalSharedLockedFree(PCtlinfo^.hMem, PCtlInfo);

  DeallocateHwnd(Handle);
  inherited Destroy;
end;

{-------------------------------------------------------------------}
{ Convert the numeric return code from an MMSYSTEM function to a string
  using midiInGetErrorText. TODO: These errors aren't very helpful
  (e.g. "an invalid parameter was passed to a system function") so
  sort out some proper error strings. }

function TMidiInput.MidiInErrorString(WError: Word): string;
var
  errorDesc: PChar;
begin
  errorDesc := nil;
  try
    errorDesc := StrAlloc(MAXERRORLENGTH);
    if midiInGetErrorText(WError, errorDesc, MAXERRORLENGTH) = 0 then
      result := StrPas(errorDesc)
    else
      result := 'Specified error number is out of range';
  finally
    if errorDesc <> nil then StrDispose(errorDesc);
  end;
end;

{-------------------------------------------------------------------}
{ Set the sysex buffer size, fail if device is already open }

procedure TMidiInput.SetSysexBufferSize(BufferSize: Word);
begin
  if FState = misOpen then
    raise EMidiInputError.Create('Change to SysexBufferSize while device was open')
  else
  { TODO: Validate the sysex buffer size. Is this necessary for WIN32? }
    FSysexBufferSize := BufferSize;
end;

{-------------------------------------------------------------------}
{ Set the sysex buffer count, fail if device is already open }

procedure TMidiInput.SetSysexBuffercount(Buffercount: Word);
begin
  if FState = misOpen then
    raise EMidiInputError.Create('Change to SysexBuffercount while device was open')
  else
  { TODO: Validate the sysex buffer count }
    FSysexBuffercount := Buffercount;
end;

{-------------------------------------------------------------------}
{ Set the Sysex Only flag to eliminate unwanted short MIDI input messages }

procedure TMidiInput.SetSysexOnly(bSysexOnly: Boolean);
begin
  FSysexOnly := bSysexOnly;
 { Update the interrupt handler's copy of this property }
  if PCtlInfo <> nil then
    PCtlInfo^.SysexOnly := bSysexOnly;
end;

{-------------------------------------------------------------------}
{ Set the Device ID to select a new MIDI input device
  Note: If no MIDI devices are installed, throws an 'Invalid Device ID' exception }

procedure TMidiInput.SetDeviceID(DeviceID: Word);
var
  MidiInCaps: TMidiInCaps;
begin
  if FState = misOpen then
    raise EMidiInputError.Create('Change to DeviceID while device was open')
  else
    if (DeviceID >= midiInGetNumDevs) then
      raise EMidiInputError.Create('Invalid device ID')
    else
    begin
      FDeviceID := DeviceID;

   { Set the name and other MIDIINCAPS properties to match the ID }
      FError :=
        midiInGetDevCaps(DeviceID, @MidiInCaps, sizeof(TMidiInCaps));
      if Ferror <> MMSYSERR_NOERROR then
        raise EMidiInputError.Create(MidiInErrorString(FError));

      FProductName := StrPas(MidiInCaps.szPname);
      FDriverVersion := MidiInCaps.vDriverVersion;
      FMID := MidiInCaps.wMID;
      FPID := MidiInCaps.wPID;

    end;
end;

{-------------------------------------------------------------------}
{ Set the product name and put the matching input device number in FDeviceID.
  This is handy if you want to save a configured input/output device
  by device name instead of device number, because device numbers may
  change if users add or remove MIDI devices.
  Exception if input device with matching name not found,
  or if input device is open }

procedure TMidiInput.SetProductName(NewProductName: string);
var
  MidiInCaps: TMidiInCaps;
  testDeviceID: Word;
  testProductName: string;
begin
  if FState = misOpen then
    raise EMidiInputError.Create('Change to ProductName while device was open')
  else
  { Don't set the name if the component is reading properties because
 the saved Productname will be from the machine the application was compiled
 on, which may not be the same for the corresponding DeviceID on the user's
 machine. The FProductname property will still be set by SetDeviceID }
    if not (csLoading in ComponentState) then
    begin
      begin
        for testDeviceID := 0 to (midiInGetNumDevs - 1) do
        begin
          FError :=
            midiInGetDevCaps(testDeviceID, @MidiInCaps, sizeof(TMidiInCaps));
          if Ferror <> MMSYSERR_NOERROR then
            raise EMidiInputError.Create(MidiInErrorString(FError));
          testProductName := StrPas(MidiInCaps.szPname);
          if testProductName = NewProductName then
          begin
            FProductName := NewProductName;
            Break;
          end;
        end;
        if FProductName <> NewProductName then
          raise EMidiInputError.Create('MIDI Input Device ' +
            NewProductName + ' not installed ')
        else
          SetDeviceID(testDeviceID);
      end;
    end;
end;


{-------------------------------------------------------------------}
{ Get the sysex buffers ready }

procedure TMidiInput.PrepareHeaders;
var
  ctr: Word;
  MyMidiHdr: TMyMidiHdr;
begin
  if (FSysexBufferCount > 0) and (FSysexBufferSize > 0)
    and (FMidiHandle <> 0) then
  begin
    Midihdrs := TList.Create;
    for ctr := 1 to FSysexBufferCount do
    begin
   { Initialize the header and allocate buffer memory }
      MyMidiHdr := TMyMidiHdr.Create(FSysexBufferSize);

   { Store the address of the MyMidiHdr object in the contained MIDIHDR
              structure so we can get back to the object when a pointer to the
              MIDIHDR is received.
              E.g. see TMidiOutput.Output method }
      MyMidiHdr.hdrPointer^.dwUser := DWORD(MyMidiHdr);

   { Get MMSYSTEM's blessing for this header }
      FError := midiInPrepareHeader(FMidiHandle, MyMidiHdr.hdrPointer,
        sizeof(TMIDIHDR));
      if Ferror <> MMSYSERR_NOERROR then
        raise EMidiInputError.Create(MidiInErrorString(FError));

   { Save it in our list }
      MidiHdrs.Add(MyMidiHdr);
    end;
  end;

end;

{-------------------------------------------------------------------}
{ Clean up from PrepareHeaders }

procedure TMidiInput.UnprepareHeaders;
var
  ctr: Word;
begin
  if (MidiHdrs <> nil) then { will be Nil if 0 sysex buffers }
  begin
    for ctr := 0 to MidiHdrs.Count - 1 do
    begin
      FError := midiInUnprepareHeader(FMidiHandle,
        TMyMidiHdr(MidiHdrs.Items[ctr]).hdrPointer,
        sizeof(TMIDIHDR));
      if Ferror <> MMSYSERR_NOERROR then
        raise EMidiInputError.Create(MidiInErrorString(FError));
      TMyMidiHdr(MidiHdrs.Items[ctr]).Free;
    end;
    MidiHdrs.Free;
    MidiHdrs := nil;
  end;
end;

{-------------------------------------------------------------------}
{ Add sysex buffers, if required, to input device }

procedure TMidiInput.AddBuffers;
var
  ctr: Word;
begin
  if MidiHdrs <> nil then { will be Nil if 0 sysex buffers }
  begin
    if MidiHdrs.Count > 0 then
    begin
      for ctr := 0 to MidiHdrs.Count - 1 do
      begin
        FError := midiInAddBuffer(FMidiHandle,
          TMyMidiHdr(MidiHdrs.Items[ctr]).hdrPointer,
          sizeof(TMIDIHDR));
        if FError <> MMSYSERR_NOERROR then
          raise EMidiInputError.Create(MidiInErrorString(FError));
      end;
    end;
  end;
end;

{-------------------------------------------------------------------}

procedure TMidiInput.Open;
var
  hMem: THandle;
begin
  try
  { Create the buffer for the MIDI input messages }
    if (PBuffer = nil) then
      PBuffer := CircBufAlloc(FCapacity);

  { Create the control info for the DLL }
    if (PCtlInfo = nil) then
    begin
      PCtlInfo := GlobalSharedLockedAlloc(Sizeof(TMidiCtlInfo), hMem);
      PctlInfo^.hMem := hMem;
    end;
    PctlInfo^.pBuffer := PBuffer;
    Pctlinfo^.hWindow := Handle; { Control's window handle }
    PCtlInfo^.SysexOnly := FSysexOnly;
    FError := midiInOpen(@FMidiHandle, FDeviceId,
      DWORD(@midiHandler),
      DWORD(PCtlInfo),
      CALLBACK_FUNCTION);

    if (FError <> MMSYSERR_NOERROR) then
   { TODO: use CreateFmtHelp to add MIDI device name/ID to message }
      raise EMidiInputError.Create(MidiInErrorString(FError));

  { Get sysex buffers ready }
    PrepareHeaders;

  { Add them to the input }
    AddBuffers;

    FState := misOpen;

  except
    if PBuffer <> nil then
    begin
      CircBufFree(PBuffer);
      PBuffer := nil;
    end;

    if PCtlInfo <> nil then
    begin
      GlobalSharedLockedFree(PCtlInfo^.hMem, PCtlInfo);
      PCtlInfo := nil;
    end;

  end;

end;

{-------------------------------------------------------------------}

function TMidiInput.GetMidiEvent: TMyMidiEvent;
var
  thisItem: TMidiBufferItem;
begin
  if (FState = misOpen) and
    CircBufReadEvent(PBuffer, @thisItem) then
  begin
    Result := TMyMidiEvent.Create;
    with thisItem do
    begin
      Result.Time := Timestamp;
      if (Sysex = nil) then
      begin
    { Short message }
        Result.MidiMessage := LoByte(LoWord(Data));
        Result.Data1 := HiByte(LoWord(Data));
        Result.Data2 := LoByte(HiWord(Data));
        Result.Sysex := nil;
        Result.SysexLength := 0;
      end
      else
             { Long Sysex message }
      begin
        Result.MidiMessage := MIDI_BEGINSYSEX;
        Result.Data1 := 0;
        Result.Data2 := 0;
        Result.SysexLength := Sysex^.dwBytesRecorded;
        if Sysex^.dwBytesRecorded <> 0 then
        begin
     { Put a copy of the sysex buffer in the object }
          GetMem(Result.Sysex, Sysex^.dwBytesRecorded);
          StrMove(Result.Sysex, Sysex^.lpData, Sysex^.dwBytesRecorded);
        end;

    { Put the header back on the input buffer }
        FError := midiInPrepareHeader(FMidiHandle, Sysex,
          sizeof(TMIDIHDR));
        if Ferror = 0 then
          FError := midiInAddBuffer(FMidiHandle,
            Sysex, sizeof(TMIDIHDR));
        if Ferror <> MMSYSERR_NOERROR then
          raise EMidiInputError.Create(MidiInErrorString(FError));
      end;
    end;
    CircbufRemoveEvent(PBuffer);
  end
  else
  { Device isn't open, return a nil event }
    Result := nil;
end;

{-------------------------------------------------------------------}

function TMidiInput.GetEventCount: Word;
begin
  if FState = misOpen then
    Result := PBuffer^.EventCount
  else
    Result := 0;
end;

{-------------------------------------------------------------------}

procedure TMidiInput.Close;
begin
  if FState = misOpen then
  begin
    FState := misClosed;

  { MidiInReset cancels any pending output.
  Note that midiInReset causes an MIM_LONGDATA callback for each sysex
  buffer on the input, so the callback function and Midi input buffer
  should still be viable at this stage.
  All the resulting MIM_LONGDATA callbacks will be completed by the time
  MidiInReset returns, though. }
    FError := MidiInReset(FMidiHandle);
    if Ferror <> MMSYSERR_NOERROR then
      raise EMidiInputError.Create(MidiInErrorString(FError));

  { Remove sysex buffers from input device and free them }
    UnPrepareHeaders;

  { Close the device (finally!) }
    FError := MidiInClose(FMidiHandle);
    if Ferror <> MMSYSERR_NOERROR then
      raise EMidiInputError.Create(MidiInErrorString(FError));

    FMidiHandle := 0;

    if (PBuffer <> nil) then
    begin
      CircBufFree(PBuffer);
      PBuffer := nil;
    end;
  end;
end;

{-------------------------------------------------------------------}

procedure TMidiInput.Start;
begin
  if FState = misOpen then
  begin
    FError := MidiInStart(FMidiHandle);
    if Ferror <> MMSYSERR_NOERROR then
      raise EMidiInputError.Create(MidiInErrorString(FError));
  end;
end;

{-------------------------------------------------------------------}

procedure TMidiInput.Stop;
begin
  if FState = misOpen then
  begin
    FError := MidiInStop(FMidiHandle);
    if Ferror <> MMSYSERR_NOERROR then
      raise EMidiInputError.Create(MidiInErrorString(FError));
  end;
end;

{-------------------------------------------------------------------}

procedure TMidiInput.MidiInput(var Message: TMessage);
{ Triggered by incoming message from DLL.
  Note DLL has already put the message in the queue }
begin
  case Message.Msg of
    mim_data:
  { Trigger the user's MIDI input event, if they've specified one and
  we're not in the process of closing the device. The check for
  GetEventCount > 0 prevents unnecessary event calls where the user has
  already cleared all the events from the input buffer using a GetMidiEvent
  loop in the OnMidiInput event handler }
      if Assigned(FOnMIDIInput) and (FState = misOpen)
        and (GetEventCount > 0) then
        FOnMIDIInput(Self);

    mim_Overflow: { input circular buffer overflow }
      if Assigned(FOnOverflow) and (FState = misOpen) then
        FOnOverflow(Self);
  end;
end;

{-------------------------------------------------------------------}

procedure Register;
begin
  RegisterComponents('Synth', [TMIDIInput]);
end;

end.