diff options
Diffstat (limited to '')
| -rw-r--r-- | Game/Code/lib/midi/Midiin.pas | 712 |
1 files changed, 0 insertions, 712 deletions
diff --git a/Game/Code/lib/midi/Midiin.pas b/Game/Code/lib/midi/Midiin.pas deleted file mode 100644 index 32a17c51..00000000 --- a/Game/Code/lib/midi/Midiin.pas +++ /dev/null @@ -1,712 +0,0 @@ -{ $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
-
-uses
- Classes, SysUtils, WinTypes, Messages, WinProcs, MMSystem, 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: Version;
- 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: Version 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,
- Forms,
- 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 WIN32}
-function midiHandler(
- hMidiIn: HMidiIn;
- wMsg: UINT;
- dwInstance: DWORD;
- dwParam1: DWORD;
- dwParam2: DWORD): Boolean; stdcall; external 'DELMID32.DLL';
-{$ELSE}
-procedure midiHandler(
- hMidiIn: HMidiIn;
- wMsg: Word;
- dwInstance: DWORD;
- dwParam1: DWORD;
- dwParam2: DWORD); far; external 'DELPHMID';
-{$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.
-
|