First multi platform version, works on Linux and Windows

git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/branches/1.1@855 b956fd51-792f-4845-bead-9b4dfca2ff2c

1 files changed, 600 insertions, 0 deletions

diff --git a/Game/Code/lib/midi/Midiout.pas b/Game/Code/lib/midi/Midiout.pas
new file mode 100644
index 00000000..91b75073
--- /dev/null
+++ b/Game/Code/lib/midi/Midiout.pas
@@ -0,0 +1,600 @@
+{ $Header: /MidiComp/MidiOut.pas 2     10/06/97 7:33 Davec $ }

+

+{ Written by David Churcher <dchurcher@cix.compulink.co.uk>,

+  released to the public domain. }

+

+{ Thanks very much to Fred Kohler for the Technology code. }

+

+unit MidiOut;

+

+{

+  MIDI Output component.

+

+  Properties:

+   DeviceID: 	Windows numeric device ID for the MIDI output device.

+ Between 0 and (midioutGetNumDevs-1), or MIDI_MAPPER (-1).

+    Special value MIDI_MAPPER specifies output to the Windows MIDI mapper

+ Read-only while device is open, exception if changed while open

+

+ MIDIHandle:	The output handle to the MIDI device.

+ 0 when device is not open

+ Read-only, runtime-only

+

+ ProductName: Name of the output device product that corresponds to the

+ DeviceID property (e.g. 'MPU 401 out').

+ You can write to this while the device is closed to select a particular

+ output device by name (the DeviceID property will change to match).

+ Exception if this property is changed while the device is open.

+

+ Numdevs: Number of MIDI output devices installed on the system. This

+ is the value returned by midiOutGetNumDevs. It's included for

+ completeness.

+

+    Technology: Type of technology used by the MIDI device. You can set this

+    property to one of the values listed for OutportTech (below) and the component

+    will find an appropriate MIDI device. For example:

+     MidiOutput.Technology := opt_FMSynth;

+    will set MidiInput.DeviceID to the MIDI device ID of the FM synth, if one

+    is installed. If no such device is available an exception is raised,

+    see MidiOutput.SetTechnology.

+

+ See the MIDIOUTCAPS entry in MMSYSTEM.HLP for descriptions of the

+ following properties:

+  DriverVersion

+  Voices

+  Notes

+  ChannelMask

+  Support

+

+ Error: The error code for the last MMSYSTEM error. See the MMSYSERR_

+ entries in MMSYSTEM.INT for possible values.

+

+  Methods:

+ Open: Open MIDI device specified by DeviceID property for output

+

+ Close: Close device

+

+ PutMidiEvent(Event:TMyMidiEvent): Output a note or sysex message to the

+ device. This method takes a TMyMidiEvent object and transmits it.

+ Notes:

+   1. If the object contains a sysex event the OnMidiOutput event will

+    be triggered when the sysex transmission is complete.

+   2. You can queue up multiple blocks of system exclusive data for

+    transmission by chucking them at this method; they will be

+   transmitted as quickly as the device can manage.

+   3. This method will not free the TMyMidiEvent object, the caller

+    must do that. Any sysex data in the TMyMidiEvent is copied before

+   transmission so you can free the TMyMidiEvent immediately after

+   calling PutMidiEvent, even if output has not yet finished.

+

+ PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte): Output a short

+ MIDI message. Handy when you can't be bothered to build a TMyMidiEvent.

+ If the message you're sending doesn't use Data1 or Data2, set them to 0.

+

+ PutLong(TheSysex: Pointer; msgLength: Word): Output sysex data.

+  SysexPointer: Pointer to sysex data to send

+  msgLength: Length of sysex data.

+ This is handy when you don't have a TMyMidiEvent.

+

+ SetVolume(Left: Word, Right: Word): Set the volume of the

+ left and right channels on the output device (only on internal devices?).

+ 0xFFFF is maximum volume. If the device doesn't support separate

+ left/right volume control, the value of the Left parameter will be used.

+ Check the Support property to see whether the device supports volume

+ control. See also other notes on volume control under midiOutSetVolume()

+ in MMSYSTEM.HLP.

+

+  Events:

+ OnMidiOutput: Procedure called when output of a system exclusive block

+ is completed.

+

+  Notes:

+   I haven't implemented any methods for midiOutCachePatches and

+  midiOutCacheDrumpatches, mainly 'cause I don't have any way of testing

+  them. Does anyone really use these?

+}

+

+interface

+

+uses

+  SysUtils, WinTypes, WinProcs, Messages, Classes, Controls, Forms,

+  MMSystem, Circbuf, MidiType, MidiDefs, Delphmcb;

+

+type

+  midioutputState = (mosOpen, mosClosed);

+  EmidioutputError = class(Exception);

+

+ { These are the equivalent of constants prefixed with mod_

+   as defined in MMSystem. See SetTechnology }

+  OutPortTech = (

+    opt_None, { none }

+    opt_MidiPort, { output port }

+    opt_Synth, { generic internal synth }

+    opt_SQSynth, { square wave internal synth }

+    opt_FMSynth, { FM internal synth }

+    opt_Mapper); { MIDI mapper }

+  TechNameMap = array[OutPortTech] of string[18];

+

+

+const

+  TechName: TechNameMap = (

+    'None', 'MIDI Port', 'Generic Synth', 'Square Wave Synth',

+    'FM Synth', 'MIDI Mapper');

+

+{-------------------------------------------------------------------}

+type

+  TMidiOutput = class(TComponent)

+  protected

+    Handle: THandle; { Window handle used for callback notification }

+    FDeviceID: Integer; { MIDI device ID }

+    FMIDIHandle: Hmidiout; { Handle to output device }

+    FState: midioutputState; { Current device state }

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

+

+    PBuffer: PCircularBuffer; { Output queue for PutTimedEvent, set by Open }

+

+    FError: Word; { Last MMSYSTEM error }

+

+ { Stuff from midioutCAPS }

+    FDriverVersion: Version; { Driver version from midioutGetDevCaps }

+    FProductName: string; { product name }

+    FTechnology: OutPortTech; { Type of MIDI output device }

+    FVoices: Word; { Number of voices (internal synth) }

+    FNotes: Word; { Number of notes (internal synth) }

+    FChannelMask: Word; { Bit set for each MIDI channels that the

+          device responds to (internal synth) }

+    FSupport: DWORD; { Technology supported (volume control,

+          patch caching etc. }

+    FNumdevs: Word; { Number of MIDI output devices on system }

+

+

+    FOnMIDIOutput: TNotifyEvent; { Sysex output finished }

+

+    procedure MidiOutput(var Message: TMessage);

+    procedure SetDeviceID(DeviceID: Integer);

+    procedure SetProductName(NewProductName: string);

+    procedure SetTechnology(NewTechnology: OutPortTech);

+    function midioutErrorString(WError: Word): string;

+

+  public

+ { Properties }

+    property MIDIHandle: Hmidiout read FMIDIHandle;

+    property DriverVersion: Version { Driver version from midioutGetDevCaps }

+    read FDriverVersion;

+    property Technology: OutPortTech { Type of MIDI output device }

+    read FTechnology

+      write SetTechnology

+      default opt_Synth;

+    property Voices: Word { Number of voices (internal synth) }

+    read FVoices;

+    property Notes: Word { Number of notes (internal synth) }

+    read FNotes;

+    property ChannelMask: Word { Bit set for each MIDI channels that the }

+    read FChannelMask; { device responds to (internal synth) }

+    property Support: DWORD { Technology supported (volume control, }

+    read FSupport; { patch caching etc. }

+    property Error: Word read FError;

+    property Numdevs: Word read FNumdevs;

+

+ { Methods }

+    function Open: Boolean; virtual;

+    function Close: Boolean; virtual;

+    procedure PutMidiEvent(theEvent: TMyMidiEvent); virtual;

+    procedure PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte); virtual;

+    procedure PutLong(TheSysex: Pointer; msgLength: Word); virtual;

+    procedure SetVolume(Left: Word; Right: Word);

+    constructor Create(AOwner: TComponent); override;

+    destructor Destroy; override;

+

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

+

+  published

+ { TODO: Property editor with dropdown list of product names }

+    property ProductName: string read FProductName write SetProductName;

+

+    property DeviceID: Integer read FDeviceID write SetDeviceID default 0;

+ { TODO: midiOutGetVolume? Or two properties for Left and Right volume?

+   Is it worth it??

+     midiOutMessage?? Does anyone use this? }

+

+ { Events }

+    property Onmidioutput: TNotifyEvent

+      read FOnmidioutput

+      write FOnmidioutput;

+  end;

+

+procedure Register;

+

+{-------------------------------------------------------------------}

+implementation

+

+(* Not used in Delphi 3

+

+{ This is the callback procedure in the external DLL.

+  It's used when midioutOpen is called by the Open method.

+  There are special requirements and restrictions for this callback

+  procedure (see midioutOpen in MMSYSTEM.HLP) so it's impractical to

+  make it an object method }

+{$IFDEF WIN32}

+function midiHandler(

+    hMidiIn: HMidiIn;

+    wMsg: UINT;

+    dwInstance: DWORD;

+    dwParam1: DWORD;

+    dwParam2: DWORD): Boolean; stdcall; external 'DELMID32.DLL';

+{$ELSE}

+function midiHandler(

+    hMidiIn: HMidiIn;

+    wMsg: Word;

+    dwInstance: DWORD;

+    dwParam1: DWORD;

+    dwParam2: DWORD): Boolean; far; external 'DELPHMID.DLL';

+{$ENDIF}

+*)

+

+{-------------------------------------------------------------------}

+

+constructor Tmidioutput.Create(AOwner: TComponent);

+begin

+  inherited Create(AOwner);

+  FState := mosClosed;

+  FNumdevs := midiOutGetNumDevs;

+

+ { Create the window for callback notification }

+  if not (csDesigning in ComponentState) then

+  begin

+    Handle := AllocateHwnd(MidiOutput);

+  end;

+

+end;

+

+{-------------------------------------------------------------------}

+

+destructor Tmidioutput.Destroy;

+begin

+  if FState = mosOpen then

+    Close;

+  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 midioutGetErrorText. TODO: These errors aren't very helpful

+  (e.g. "an invalid parameter was passed to a system function") so

+  some proper error strings would be nice. }

+

+

+function Tmidioutput.midioutErrorString(WError: Word): string;

+var

+  errorDesc: PChar;

+begin

+  errorDesc := nil;

+  try

+    errorDesc := StrAlloc(MAXERRORLENGTH);

+    if midioutGetErrorText(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 output device ID and change the other properties to match }

+

+procedure Tmidioutput.SetDeviceID(DeviceID: Integer);

+var

+  midioutCaps: TmidioutCaps;

+begin

+  if FState = mosOpen then

+    raise EmidioutputError.Create('Change to DeviceID while device was open')

+  else

+    if (DeviceID >= midioutGetNumDevs) and (DeviceID <> MIDI_MAPPER) then

+      raise EmidioutputError.Create('Invalid device ID')

+    else

+    begin

+      FDeviceID := DeviceID;

+

+   { Set the name and other midioutCAPS properties to match the ID }

+      FError :=

+        midioutGetDevCaps(DeviceID, @midioutCaps, sizeof(TmidioutCaps));

+      if Ferror > 0 then

+        raise EmidioutputError.Create(midioutErrorString(FError));

+

+      with midiOutCaps do

+      begin

+        FProductName := StrPas(szPname);

+        FDriverVersion := vDriverVersion;

+        FTechnology := OutPortTech(wTechnology);

+        FVoices := wVoices;

+        FNotes := wNotes;

+        FChannelMask := wChannelMask;

+        FSupport := dwSupport;

+      end;

+

+    end;

+end;

+

+{-------------------------------------------------------------------}

+{ Set the product name property and put the matching output device number

+  in FDeviceID.

+  This is handy if you want to save a configured output/output device

+  by device name instead of device number, because device numbers may

+  change if users install or remove MIDI devices.

+  Exception if output device with matching name not found,

+  or if output device is open }

+

+procedure Tmidioutput.SetProductName(NewProductName: string);

+var

+  midioutCaps: TmidioutCaps;

+  testDeviceID: Integer;

+  testProductName: string;

+begin

+  if FState = mosOpen then

+    raise EmidioutputError.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

+    { Loop uses -1 to test for MIDI_MAPPER as well }

+      for testDeviceID := -1 to (midioutGetNumDevs - 1) do

+      begin

+        FError :=

+          midioutGetDevCaps(testDeviceID, @midioutCaps, sizeof(TmidioutCaps));

+        if Ferror > 0 then

+          raise EmidioutputError.Create(midioutErrorString(FError));

+        testProductName := StrPas(midioutCaps.szPname);

+        if testProductName = NewProductName then

+        begin

+          FProductName := NewProductName;

+          Break;

+        end;

+      end;

+      if FProductName <> NewProductName then

+        raise EmidioutputError.Create('MIDI output Device ' +

+          NewProductName + ' not installed')

+      else

+        SetDeviceID(testDeviceID);

+    end;

+end;

+

+{-------------------------------------------------------------------}

+{ Set the output technology property and put the matching output device

+ number in FDeviceID.

+  This is handy, for example, if you want to be able to switch between a

+  sound card and a MIDI port }

+

+procedure TMidiOutput.SetTechnology(NewTechnology: OutPortTech);

+var

+  midiOutCaps: TMidiOutCaps;

+  testDeviceID: Integer;

+  testTechnology: OutPortTech;

+begin

+  if FState = mosOpen then

+    raise EMidiOutputError.Create(

+      'Change to Product Technology while device was open')

+  else

+  begin

+       { Loop uses -1 to test for MIDI_MAPPER as well }

+    for testDeviceID := -1 to (midiOutGetNumDevs - 1) do

+    begin

+      FError :=

+        midiOutGetDevCaps(testDeviceID,

+        @midiOutCaps, sizeof(TMidiOutCaps));

+      if Ferror > 0 then

+        raise EMidiOutputError.Create(MidiOutErrorString(FError));

+      testTechnology := OutPortTech(midiOutCaps.wTechnology);

+      if testTechnology = NewTechnology then

+      begin

+        FTechnology := NewTechnology;

+        Break;

+      end;

+    end;

+    if FTechnology <> NewTechnology then

+      raise EMidiOutputError.Create('MIDI output technology ' +

+        TechName[NewTechnology] + ' not installed')

+    else

+      SetDeviceID(testDeviceID);

+  end;

+end;

+

+{-------------------------------------------------------------------}

+

+function Tmidioutput.Open: Boolean;

+var

+  hMem: THandle;

+begin

+  Result := False;

+  try

+  { Create the control info for the DLL }

+    if (PCtlInfo = nil) then

+    begin

+      PCtlInfo := GlobalSharedLockedAlloc(Sizeof(TMidiCtlInfo), hMem);

+      PctlInfo^.hMem := hMem;

+    end;

+

+    Pctlinfo^.hWindow := Handle; { Control's window handle }

+

+    FError := midioutOpen(@FMidiHandle, FDeviceId,

+      DWORD(@midiHandler),

+      DWORD(PCtlInfo),

+      CALLBACK_FUNCTION);

+{                FError := midioutOpen(@FMidiHandle, FDeviceId,

+      Handle,

+      DWORD(PCtlInfo),

+      CALLBACK_WINDOW); }

+    if (FError <> 0) then

+   { TODO: use CreateFmtHelp to add MIDI device name/ID to message }

+      raise EmidioutputError.Create(midioutErrorString(FError))

+    else

+    begin

+      Result := True;

+      FState := mosOpen;

+    end;

+

+  except

+    if PCtlInfo <> nil then

+    begin

+      GlobalSharedLockedFree(PCtlInfo^.hMem, PCtlInfo);

+      PCtlInfo := nil;

+    end;

+  end;

+

+end;

+

+{-------------------------------------------------------------------}

+

+procedure TMidiOutput.PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte);

+var

+  thisMsg: DWORD;

+begin

+  thisMsg := DWORD(MidiMessage) or

+    (DWORD(Data1) shl 8) or

+    (DWORD(Data2) shl 16);

+

+  FError := midiOutShortMsg(FMidiHandle, thisMsg);

+  if Ferror > 0 then

+    raise EmidioutputError.Create(midioutErrorString(FError));

+end;

+

+{-------------------------------------------------------------------}

+

+procedure TMidiOutput.PutLong(TheSysex: Pointer; msgLength: Word);

+{ Notes: This works asynchronously; you send your sysex output by

+calling this function, which returns immediately. When the MIDI device

+driver has finished sending the data the MidiOutPut function in this

+component is called, which will in turn call the OnMidiOutput method

+if the component user has defined one. }

+{ TODO: Combine common functions with PutTimedLong into subroutine }

+

+var

+  MyMidiHdr: TMyMidiHdr;

+begin

+ { Initialize the header and allocate buffer memory }

+  MyMidiHdr := TMyMidiHdr.Create(msgLength);

+

+ { Copy the data over to the MidiHdr buffer

+   We can't just use the caller's PChar because the buffer memory

+   has to be global, shareable, and locked. }

+  StrMove(MyMidiHdr.SysexPointer, TheSysex, msgLength);

+

+ { Store the MyMidiHdr address in the header so we can find it again quickly

+      (see the MidiOutput proc) }

+  MyMidiHdr.hdrPointer^.dwUser := DWORD(MyMidiHdr);

+

+ { Get MMSYSTEM's blessing for this header }

+  FError := midiOutPrepareHeader(FMidiHandle, MyMidiHdr.hdrPointer,

+    sizeof(TMIDIHDR));

+  if Ferror > 0 then

+    raise EMidiOutputError.Create(MidiOutErrorString(FError));

+

+ { Send it }

+  FError := midiOutLongMsg(FMidiHandle, MyMidiHdr.hdrPointer,

+    sizeof(TMIDIHDR));

+  if Ferror > 0 then

+    raise EMidiOutputError.Create(MidiOutErrorString(FError));

+

+end;

+

+{-------------------------------------------------------------------}

+

+procedure Tmidioutput.PutMidiEvent(theEvent: TMyMidiEvent);

+begin

+  if FState <> mosOpen then

+    raise EMidiOutputError.Create('MIDI Output device not open');

+

+  with theEvent do

+  begin

+    if Sysex = nil then

+    begin

+      PutShort(MidiMessage, Data1, Data2)

+    end

+    else

+      PutLong(Sysex, SysexLength);

+  end;

+end;

+

+{-------------------------------------------------------------------}

+

+function Tmidioutput.Close: Boolean;

+begin

+  Result := False;

+  if FState = mosOpen then

+  begin

+

+        { Note this sends a lot of fast control change messages which some synths can't handle.

+          TODO: Make this optional. }

+{		FError := midioutReset(FMidiHandle);

+  if Ferror <> 0 then

+   raise EMidiOutputError.Create(MidiOutErrorString(FError)); }

+

+    FError := midioutClose(FMidiHandle);

+    if Ferror <> 0 then

+      raise EMidiOutputError.Create(MidiOutErrorString(FError))

+    else

+      Result := True;

+  end;

+

+  FMidiHandle := 0;

+  FState := mosClosed;

+

+end;

+

+{-------------------------------------------------------------------}

+

+procedure TMidiOutput.SetVolume(Left: Word; Right: Word);

+var

+  dwVolume: DWORD;

+begin

+  dwVolume := (DWORD(Left) shl 16) or Right;

+  FError := midiOutSetVolume(DeviceID, dwVolume);

+  if Ferror <> 0 then

+    raise EMidiOutputError.Create(MidiOutErrorString(FError));

+end;

+

+{-------------------------------------------------------------------}

+

+procedure Tmidioutput.midioutput(var Message: TMessage);

+{ Triggered when sysex output from PutLong is complete }

+var

+  MyMidiHdr: TMyMidiHdr;

+  thisHdr: PMidiHdr;

+begin

+  if Message.Msg = Mom_Done then

+  begin

+  { Find the MIDIHDR we used for the output. Message.lParam is its address }

+    thisHdr := PMidiHdr(Message.lParam);

+

+  { Remove it from the output device }

+    midiOutUnprepareHeader(FMidiHandle, thisHdr, sizeof(TMIDIHDR));

+

+  { Get the address of the MyMidiHdr object containing this MIDIHDR structure.

+   We stored this address in the PutLong procedure }

+    MyMidiHdr := TMyMidiHdr(thisHdr^.dwUser);

+

+  { Header and copy of sysex data no longer required since output is complete }

+    MyMidiHdr.Free;

+

+  { Call the user's event handler if any }

+    if Assigned(FOnmidioutput) then

+      FOnmidioutput(Self);

+  end;

+ { TODO: Case for MOM_PLAYBACK_DONE }

+end;

+

+{-------------------------------------------------------------------}

+

+procedure Register;

+begin

+  RegisterComponents('Synth', [Tmidioutput]);

+end;

+

+end.

+