aboutsummaryrefslogtreecommitdiffstats
path: root/Game/Code/lib/midi
diff options
context:
space:
mode:
authortobigun <tobigun@b956fd51-792f-4845-bead-9b4dfca2ff2c>2008-06-08 15:33:48 +0000
committertobigun <tobigun@b956fd51-792f-4845-bead-9b4dfca2ff2c>2008-06-08 15:33:48 +0000
commit46bb010ca7c5eb04551c030105f9999ca80e472f (patch)
tree3cb6a6bdd7e4e62623c6a83b5d22c1c0dfad73e8 /Game/Code/lib/midi
parentf4425b4558b7fd86de874035f81ea290c987e96d (diff)
downloadusdx-46bb010ca7c5eb04551c030105f9999ca80e472f.tar.gz
usdx-46bb010ca7c5eb04551c030105f9999ca80e472f.tar.xz
usdx-46bb010ca7c5eb04551c030105f9999ca80e472f.zip
- set svn:eol-style to native
- removed some svn:executable properties from non-executable files git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/trunk@1144 b956fd51-792f-4845-bead-9b4dfca2ff2c
Diffstat (limited to 'Game/Code/lib/midi')
-rw-r--r--Game/Code/lib/midi/CIRCBUF.PAS366
-rw-r--r--Game/Code/lib/midi/DELPHMCB.PAS276
-rw-r--r--Game/Code/lib/midi/MIDIDEFS.PAS110
-rw-r--r--Game/Code/lib/midi/MIDITYPE.PAS180
-rw-r--r--Game/Code/lib/midi/MidiFile.pas1928
-rw-r--r--Game/Code/lib/midi/MidiScope.pas396
-rw-r--r--Game/Code/lib/midi/Midicons.pas94
-rw-r--r--Game/Code/lib/midi/Midiin.pas1450
-rw-r--r--Game/Code/lib/midi/Midiout.pas1234
-rw-r--r--Game/Code/lib/midi/demo/MidiTest.pas498
-rw-r--r--Game/Code/lib/midi/demo/Project1.dpr26
-rw-r--r--Game/Code/lib/midi/midiComp.cfg70
-rw-r--r--Game/Code/lib/midi/readme.txt120
13 files changed, 3374 insertions, 3374 deletions
diff --git a/Game/Code/lib/midi/CIRCBUF.PAS b/Game/Code/lib/midi/CIRCBUF.PAS
index c741230e..77cb3643 100644
--- a/Game/Code/lib/midi/CIRCBUF.PAS
+++ b/Game/Code/lib/midi/CIRCBUF.PAS
@@ -1,183 +1,183 @@
-{ $Header: /MidiComp/CIRCBUF.PAS 2 10/06/97 7:33 Davec $ }
-
-{ Written by David Churcher <dchurcher@cix.compulink.co.uk>,
- released to the public domain. }
-
-
-{ A First-In First-Out circular buffer.
- Port of circbuf.c from Microsoft's Windows MIDI monitor example.
- I did do a version of this as an object (see Rev 1.1) but it was getting too
- complicated and I couldn't see any real benefits to it so I dumped it
- for an ordinary memory buffer with pointers.
-
- This unit is a bit C-like, everything is done with pointers and extensive
- use is made of the undocumented feature of the Inc() function that
- increments pointers by the size of the object pointed to.
- All of this could probably be done using Pascal array notation with
- range-checking turned off, but I'm not sure it's worth it.
-}
-
-Unit Circbuf;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
- {$H+} // use AnsiString
-{$ENDIF}
-
-Uses
- Windows,
- MMSystem;
-
-type
- { MIDI input event }
- TMidiBufferItem = record
- timestamp: DWORD; { Timestamp in milliseconds after midiInStart }
- data: DWORD; { MIDI message received }
- sysex: PMidiHdr; { Pointer to sysex MIDIHDR, nil if not sysex }
- end;
- PMidiBufferItem = ^TMidiBufferItem;
-
- { MIDI input buffer }
- TCircularBuffer = record
- RecordHandle: HGLOBAL; { Windows memory handle for this record }
- BufferHandle: HGLOBAL; { Windows memory handle for the buffer }
- pStart: PMidiBufferItem; { ptr to start of buffer }
- pEnd: PMidiBufferItem; { ptr to end of buffer }
- pNextPut: PMidiBufferItem; { next location to fill }
- pNextGet: PMidiBufferItem; { next location to empty }
- Error: Word; { error code from MMSYSTEM functions }
- Capacity: Word; { buffer size (in TMidiBufferItems) }
- EventCount: Word; { Number of events in buffer }
- end;
-
- PCircularBuffer = ^TCircularBuffer;
-
-function GlobalSharedLockedAlloc( Capacity: Word; var hMem: HGLOBAL ): Pointer;
-procedure GlobalSharedLockedFree( hMem: HGLOBAL; ptr: Pointer );
-
-function CircbufAlloc( Capacity: Word ): PCircularBuffer;
-procedure CircbufFree( PBuffer: PCircularBuffer );
-function CircbufRemoveEvent( PBuffer: PCircularBuffer ): Boolean;
-function CircbufReadEvent( PBuffer: PCircularBuffer; PEvent: PMidiBufferItem ): Boolean;
-{ Note: The PutEvent function is in the DLL }
-
-implementation
-
-{ Allocates in global shared memory, returns pointer and handle }
-function GlobalSharedLockedAlloc( Capacity: Word; var hMem: HGLOBAL ): Pointer;
-var
- ptr: Pointer;
-begin
- { Allocate the buffer memory }
- hMem := GlobalAlloc(GMEM_SHARE Or GMEM_MOVEABLE Or GMEM_ZEROINIT, Capacity );
-
- if (hMem = 0) then
- ptr := Nil
- else
- begin
- ptr := GlobalLock(hMem);
- if (ptr = Nil) then
- GlobalFree(hMem);
- end;
-
- GlobalSharedLockedAlloc := Ptr;
-end;
-
-procedure GlobalSharedLockedFree( hMem: HGLOBAL; ptr: Pointer );
-begin
- if (hMem <> 0) then
- begin
- GlobalUnlock(hMem);
- GlobalFree(hMem);
- end;
-end;
-
-function CircbufAlloc( Capacity: Word ): PCircularBuffer;
-var
- NewCircularBuffer: PCircularBuffer;
- NewMIDIBuffer: PMidiBufferItem;
- hMem: HGLOBAL;
-begin
- { TODO: Validate circbuf size, <64K }
- NewCircularBuffer :=
- GlobalSharedLockedAlloc( Sizeof(TCircularBuffer), hMem );
- if (NewCircularBuffer <> Nil) then
- begin
- NewCircularBuffer^.RecordHandle := hMem;
- NewMIDIBuffer :=
- GlobalSharedLockedAlloc( Capacity * Sizeof(TMidiBufferItem), hMem );
- if (NewMIDIBuffer = Nil) then
- begin
- { TODO: Exception here? }
- GlobalSharedLockedFree( NewCircularBuffer^.RecordHandle,
- NewCircularBuffer );
- NewCircularBuffer := Nil;
- end
- else
- begin
- NewCircularBuffer^.pStart := NewMidiBuffer;
- { Point to item at end of buffer }
- NewCircularBuffer^.pEnd := NewMidiBuffer;
- Inc(NewCircularBuffer^.pEnd, Capacity);
- { Start off the get and put pointers in the same position. These
- will get out of sync as the interrupts start rolling in }
- NewCircularBuffer^.pNextPut := NewMidiBuffer;
- NewCircularBuffer^.pNextGet := NewMidiBuffer;
- NewCircularBuffer^.Error := 0;
- NewCircularBuffer^.Capacity := Capacity;
- NewCircularBuffer^.EventCount := 0;
- end;
- end;
- CircbufAlloc := NewCircularBuffer;
-end;
-
-procedure CircbufFree( pBuffer: PCircularBuffer );
-begin
- if (pBuffer <> Nil) then
- begin
- GlobalSharedLockedFree(pBuffer^.BufferHandle, pBuffer^.pStart);
- GlobalSharedLockedFree(pBuffer^.RecordHandle, pBuffer);
- end;
-end;
-
-{ Reads first event in queue without removing it.
- Returns true if successful, False if no events in queue }
-function CircbufReadEvent( PBuffer: PCircularBuffer; PEvent: PMidiBufferItem ): Boolean;
-var
- PCurrentEvent: PMidiBufferItem;
-begin
- if (PBuffer^.EventCount <= 0) then
- CircbufReadEvent := False
- else
- begin
- PCurrentEvent := PBuffer^.PNextget;
-
- { Copy the object from the "tail" of the buffer to the caller's object }
- PEvent^.Timestamp := PCurrentEvent^.Timestamp;
- PEvent^.Data := PCurrentEvent^.Data;
- PEvent^.Sysex := PCurrentEvent^.Sysex;
- CircbufReadEvent := True;
- end;
-end;
-
-{ Remove current event from the queue }
-function CircbufRemoveEvent(PBuffer: PCircularBuffer): Boolean;
-begin
- if (PBuffer^.EventCount > 0) then
- begin
- Dec( Pbuffer^.EventCount);
-
- { Advance the buffer pointer, with wrap }
- Inc( Pbuffer^.PNextGet );
- If (PBuffer^.PNextGet = PBuffer^.PEnd) then
- PBuffer^.PNextGet := PBuffer^.PStart;
-
- CircbufRemoveEvent := True;
- end
- else
- CircbufRemoveEvent := False;
-end;
-
-end.
+{ $Header: /MidiComp/CIRCBUF.PAS 2 10/06/97 7:33 Davec $ }
+
+{ Written by David Churcher <dchurcher@cix.compulink.co.uk>,
+ released to the public domain. }
+
+
+{ A First-In First-Out circular buffer.
+ Port of circbuf.c from Microsoft's Windows MIDI monitor example.
+ I did do a version of this as an object (see Rev 1.1) but it was getting too
+ complicated and I couldn't see any real benefits to it so I dumped it
+ for an ordinary memory buffer with pointers.
+
+ This unit is a bit C-like, everything is done with pointers and extensive
+ use is made of the undocumented feature of the Inc() function that
+ increments pointers by the size of the object pointed to.
+ All of this could probably be done using Pascal array notation with
+ range-checking turned off, but I'm not sure it's worth it.
+}
+
+Unit Circbuf;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+ {$H+} // use AnsiString
+{$ENDIF}
+
+Uses
+ Windows,
+ MMSystem;
+
+type
+ { MIDI input event }
+ TMidiBufferItem = record
+ timestamp: DWORD; { Timestamp in milliseconds after midiInStart }
+ data: DWORD; { MIDI message received }
+ sysex: PMidiHdr; { Pointer to sysex MIDIHDR, nil if not sysex }
+ end;
+ PMidiBufferItem = ^TMidiBufferItem;
+
+ { MIDI input buffer }
+ TCircularBuffer = record
+ RecordHandle: HGLOBAL; { Windows memory handle for this record }
+ BufferHandle: HGLOBAL; { Windows memory handle for the buffer }
+ pStart: PMidiBufferItem; { ptr to start of buffer }
+ pEnd: PMidiBufferItem; { ptr to end of buffer }
+ pNextPut: PMidiBufferItem; { next location to fill }
+ pNextGet: PMidiBufferItem; { next location to empty }
+ Error: Word; { error code from MMSYSTEM functions }
+ Capacity: Word; { buffer size (in TMidiBufferItems) }
+ EventCount: Word; { Number of events in buffer }
+ end;
+
+ PCircularBuffer = ^TCircularBuffer;
+
+function GlobalSharedLockedAlloc( Capacity: Word; var hMem: HGLOBAL ): Pointer;
+procedure GlobalSharedLockedFree( hMem: HGLOBAL; ptr: Pointer );
+
+function CircbufAlloc( Capacity: Word ): PCircularBuffer;
+procedure CircbufFree( PBuffer: PCircularBuffer );
+function CircbufRemoveEvent( PBuffer: PCircularBuffer ): Boolean;
+function CircbufReadEvent( PBuffer: PCircularBuffer; PEvent: PMidiBufferItem ): Boolean;
+{ Note: The PutEvent function is in the DLL }
+
+implementation
+
+{ Allocates in global shared memory, returns pointer and handle }
+function GlobalSharedLockedAlloc( Capacity: Word; var hMem: HGLOBAL ): Pointer;
+var
+ ptr: Pointer;
+begin
+ { Allocate the buffer memory }
+ hMem := GlobalAlloc(GMEM_SHARE Or GMEM_MOVEABLE Or GMEM_ZEROINIT, Capacity );
+
+ if (hMem = 0) then
+ ptr := Nil
+ else
+ begin
+ ptr := GlobalLock(hMem);
+ if (ptr = Nil) then
+ GlobalFree(hMem);
+ end;
+
+ GlobalSharedLockedAlloc := Ptr;
+end;
+
+procedure GlobalSharedLockedFree( hMem: HGLOBAL; ptr: Pointer );
+begin
+ if (hMem <> 0) then
+ begin
+ GlobalUnlock(hMem);
+ GlobalFree(hMem);
+ end;
+end;
+
+function CircbufAlloc( Capacity: Word ): PCircularBuffer;
+var
+ NewCircularBuffer: PCircularBuffer;
+ NewMIDIBuffer: PMidiBufferItem;
+ hMem: HGLOBAL;
+begin
+ { TODO: Validate circbuf size, <64K }
+ NewCircularBuffer :=
+ GlobalSharedLockedAlloc( Sizeof(TCircularBuffer), hMem );
+ if (NewCircularBuffer <> Nil) then
+ begin
+ NewCircularBuffer^.RecordHandle := hMem;
+ NewMIDIBuffer :=
+ GlobalSharedLockedAlloc( Capacity * Sizeof(TMidiBufferItem), hMem );
+ if (NewMIDIBuffer = Nil) then
+ begin
+ { TODO: Exception here? }
+ GlobalSharedLockedFree( NewCircularBuffer^.RecordHandle,
+ NewCircularBuffer );
+ NewCircularBuffer := Nil;
+ end
+ else
+ begin
+ NewCircularBuffer^.pStart := NewMidiBuffer;
+ { Point to item at end of buffer }
+ NewCircularBuffer^.pEnd := NewMidiBuffer;
+ Inc(NewCircularBuffer^.pEnd, Capacity);
+ { Start off the get and put pointers in the same position. These
+ will get out of sync as the interrupts start rolling in }
+ NewCircularBuffer^.pNextPut := NewMidiBuffer;
+ NewCircularBuffer^.pNextGet := NewMidiBuffer;
+ NewCircularBuffer^.Error := 0;
+ NewCircularBuffer^.Capacity := Capacity;
+ NewCircularBuffer^.EventCount := 0;
+ end;
+ end;
+ CircbufAlloc := NewCircularBuffer;
+end;
+
+procedure CircbufFree( pBuffer: PCircularBuffer );
+begin
+ if (pBuffer <> Nil) then
+ begin
+ GlobalSharedLockedFree(pBuffer^.BufferHandle, pBuffer^.pStart);
+ GlobalSharedLockedFree(pBuffer^.RecordHandle, pBuffer);
+ end;
+end;
+
+{ Reads first event in queue without removing it.
+ Returns true if successful, False if no events in queue }
+function CircbufReadEvent( PBuffer: PCircularBuffer; PEvent: PMidiBufferItem ): Boolean;
+var
+ PCurrentEvent: PMidiBufferItem;
+begin
+ if (PBuffer^.EventCount <= 0) then
+ CircbufReadEvent := False
+ else
+ begin
+ PCurrentEvent := PBuffer^.PNextget;
+
+ { Copy the object from the "tail" of the buffer to the caller's object }
+ PEvent^.Timestamp := PCurrentEvent^.Timestamp;
+ PEvent^.Data := PCurrentEvent^.Data;
+ PEvent^.Sysex := PCurrentEvent^.Sysex;
+ CircbufReadEvent := True;
+ end;
+end;
+
+{ Remove current event from the queue }
+function CircbufRemoveEvent(PBuffer: PCircularBuffer): Boolean;
+begin
+ if (PBuffer^.EventCount > 0) then
+ begin
+ Dec( Pbuffer^.EventCount);
+
+ { Advance the buffer pointer, with wrap }
+ Inc( Pbuffer^.PNextGet );
+ If (PBuffer^.PNextGet = PBuffer^.PEnd) then
+ PBuffer^.PNextGet := PBuffer^.PStart;
+
+ CircbufRemoveEvent := True;
+ end
+ else
+ CircbufRemoveEvent := False;
+end;
+
+end.
diff --git a/Game/Code/lib/midi/DELPHMCB.PAS b/Game/Code/lib/midi/DELPHMCB.PAS
index 5d4ad75a..f7ceaa5e 100644
--- a/Game/Code/lib/midi/DELPHMCB.PAS
+++ b/Game/Code/lib/midi/DELPHMCB.PAS
@@ -1,138 +1,138 @@
-{ $Header: /MidiComp/DELPHMCB.PAS 2 10/06/97 7:33 Davec $ }
-
-{MIDI callback for Delphi, was DLL for Delphi 1}
-
-unit Delphmcb;
-
-{ These segment options required for the MIDI callback functions }
-{$C PRELOAD FIXED PERMANENT}
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
- {$H+} // use AnsiString
-{$ENDIF}
-
-uses
- Windows,
- MMsystem,
- Circbuf,
- MidiDefs,
- MidiCons;
-
-procedure midiHandler(
- hMidiIn: HMidiIn;
- wMsg: UINT;
- dwInstance: DWORD;
- dwParam1: DWORD;
- dwParam2: DWORD); stdcall; export;
-function CircbufPutEvent(PBuffer: PCircularBuffer; PTheEvent: PMidiBufferItem): Boolean; stdcall; export;
-
-implementation
-
-{ Add an event to the circular input buffer. }
-function CircbufPutEvent(PBuffer: PCircularBuffer; PTheEvent: PMidiBufferItem): Boolean; stdcall;
-begin
- If (PBuffer^.EventCount < PBuffer^.Capacity) Then
- begin
- Inc(Pbuffer^.EventCount);
-
- { Todo: better way of copying this record }
- with PBuffer^.PNextput^ do
- begin
- Timestamp := PTheEvent^.Timestamp;
- Data := PTheEvent^.Data;
- Sysex := PTheEvent^.Sysex;
- end;
-
- { Move to next put location, with wrap }
- Inc(Pbuffer^.PNextPut);
- If (PBuffer^.PNextPut = PBuffer^.PEnd) then
- PBuffer^.PNextPut := PBuffer^.PStart;
-
- CircbufPutEvent := True;
- end
- else
- CircbufPutEvent := False;
-end;
-
-{ This is the callback function specified when the MIDI device was opened
- by midiInOpen. It's called at interrupt time when MIDI input is seen
- by the MIDI device driver(s). See the docs for midiInOpen for restrictions
- on the Windows functions that can be called in this interrupt. }
-procedure midiHandler(
- hMidiIn: HMidiIn;
- wMsg: UINT;
- dwInstance: DWORD;
- dwParam1: DWORD;
- dwParam2: DWORD); stdcall;
-var
- thisEvent: TMidiBufferItem;
- thisCtlInfo: PMidiCtlInfo;
- thisBuffer: PCircularBuffer;
-Begin
- case wMsg of
-
- mim_Open: {nothing};
-
- mim_Error: {TODO: handle (message to trigger exception?) };
-
- mim_Data, mim_Longdata, mim_Longerror:
- { Note: mim_Longerror included because there's a bug in the Maui
- input driver that sends MIM_LONGERROR for subsequent buffers when
- the input buffer is smaller than the sysex block being received }
-
- begin
- { TODO: Make filtered messages customisable, I'm sure someone wants to
- do something with MTC! }
- if (dwParam1 <> MIDI_ACTIVESENSING) and
- (dwParam1 <> MIDI_TIMINGCLOCK) then
- begin
-
- { The device driver passes us the instance data pointer we
- specified for midiInOpen. Use this to get the buffer address
- and window handle for the MIDI control }
- thisCtlInfo := PMidiCtlInfo(dwInstance);
- thisBuffer := thisCtlInfo^.PBuffer;
-
- { Screen out short messages if we've been asked to }
- if ((wMsg <> mim_Data) or (thisCtlInfo^.SysexOnly = False))
- and (thisCtlInfo <> Nil) and (thisBuffer <> Nil) then
- begin
- with thisEvent do
- begin
- timestamp := dwParam2;
- if (wMsg = mim_Longdata) or
- (wMsg = mim_Longerror) then
- begin
- data := 0;
- sysex := PMidiHdr(dwParam1);
- end
- else
- begin
- data := dwParam1;
- sysex := Nil;
- end;
- end;
- if CircbufPutEvent( thisBuffer, @thisEvent ) then
- { Send a message to the control to say input's arrived }
- PostMessage(thisCtlInfo^.hWindow, mim_Data, 0, 0)
- else
- { Buffer overflow }
- PostMessage(thisCtlInfo^.hWindow, mim_Overflow, 0, 0);
- end;
- end;
- end;
-
- mom_Done: { Sysex output complete, dwParam1 is pointer to MIDIHDR }
- begin
- { Notify the control that its sysex output is finished.
- The control should call midiOutUnprepareHeader before freeing the buffer }
- PostMessage(PMidiCtlInfo(dwInstance)^.hWindow, mom_Done, 0, dwParam1);
- end;
-
- end; { Case }
-end;
-
-end.
+{ $Header: /MidiComp/DELPHMCB.PAS 2 10/06/97 7:33 Davec $ }
+
+{MIDI callback for Delphi, was DLL for Delphi 1}
+
+unit Delphmcb;
+
+{ These segment options required for the MIDI callback functions }
+{$C PRELOAD FIXED PERMANENT}
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+ {$H+} // use AnsiString
+{$ENDIF}
+
+uses
+ Windows,
+ MMsystem,
+ Circbuf,
+ MidiDefs,
+ MidiCons;
+
+procedure midiHandler(
+ hMidiIn: HMidiIn;
+ wMsg: UINT;
+ dwInstance: DWORD;
+ dwParam1: DWORD;
+ dwParam2: DWORD); stdcall; export;
+function CircbufPutEvent(PBuffer: PCircularBuffer; PTheEvent: PMidiBufferItem): Boolean; stdcall; export;
+
+implementation
+
+{ Add an event to the circular input buffer. }
+function CircbufPutEvent(PBuffer: PCircularBuffer; PTheEvent: PMidiBufferItem): Boolean; stdcall;
+begin
+ If (PBuffer^.EventCount < PBuffer^.Capacity) Then
+ begin
+ Inc(Pbuffer^.EventCount);
+
+ { Todo: better way of copying this record }
+ with PBuffer^.PNextput^ do
+ begin
+ Timestamp := PTheEvent^.Timestamp;
+ Data := PTheEvent^.Data;
+ Sysex := PTheEvent^.Sysex;
+ end;
+
+ { Move to next put location, with wrap }
+ Inc(Pbuffer^.PNextPut);
+ If (PBuffer^.PNextPut = PBuffer^.PEnd) then
+ PBuffer^.PNextPut := PBuffer^.PStart;
+
+ CircbufPutEvent := True;
+ end
+ else
+ CircbufPutEvent := False;
+end;
+
+{ This is the callback function specified when the MIDI device was opened
+ by midiInOpen. It's called at interrupt time when MIDI input is seen
+ by the MIDI device driver(s). See the docs for midiInOpen for restrictions
+ on the Windows functions that can be called in this interrupt. }
+procedure midiHandler(
+ hMidiIn: HMidiIn;
+ wMsg: UINT;
+ dwInstance: DWORD;
+ dwParam1: DWORD;
+ dwParam2: DWORD); stdcall;
+var
+ thisEvent: TMidiBufferItem;
+ thisCtlInfo: PMidiCtlInfo;
+ thisBuffer: PCircularBuffer;
+Begin
+ case wMsg of
+
+ mim_Open: {nothing};
+
+ mim_Error: {TODO: handle (message to trigger exception?) };
+
+ mim_Data, mim_Longdata, mim_Longerror:
+ { Note: mim_Longerror included because there's a bug in the Maui
+ input driver that sends MIM_LONGERROR for subsequent buffers when
+ the input buffer is smaller than the sysex block being received }
+
+ begin
+ { TODO: Make filtered messages customisable, I'm sure someone wants to
+ do something with MTC! }
+ if (dwParam1 <> MIDI_ACTIVESENSING) and
+ (dwParam1 <> MIDI_TIMINGCLOCK) then
+ begin
+
+ { The device driver passes us the instance data pointer we
+ specified for midiInOpen. Use this to get the buffer address
+ and window handle for the MIDI control }
+ thisCtlInfo := PMidiCtlInfo(dwInstance);
+ thisBuffer := thisCtlInfo^.PBuffer;
+
+ { Screen out short messages if we've been asked to }
+ if ((wMsg <> mim_Data) or (thisCtlInfo^.SysexOnly = False))
+ and (thisCtlInfo <> Nil) and (thisBuffer <> Nil) then
+ begin
+ with thisEvent do
+ begin
+ timestamp := dwParam2;
+ if (wMsg = mim_Longdata) or
+ (wMsg = mim_Longerror) then
+ begin
+ data := 0;
+ sysex := PMidiHdr(dwParam1);
+ end
+ else
+ begin
+ data := dwParam1;
+ sysex := Nil;
+ end;
+ end;
+ if CircbufPutEvent( thisBuffer, @thisEvent ) then
+ { Send a message to the control to say input's arrived }
+ PostMessage(thisCtlInfo^.hWindow, mim_Data, 0, 0)
+ else
+ { Buffer overflow }
+ PostMessage(thisCtlInfo^.hWindow, mim_Overflow, 0, 0);
+ end;
+ end;
+ end;
+
+ mom_Done: { Sysex output complete, dwParam1 is pointer to MIDIHDR }
+ begin
+ { Notify the control that its sysex output is finished.
+ The control should call midiOutUnprepareHeader before freeing the buffer }
+ PostMessage(PMidiCtlInfo(dwInstance)^.hWindow, mom_Done, 0, dwParam1);
+ end;
+
+ end; { Case }
+end;
+
+end.
diff --git a/Game/Code/lib/midi/MIDIDEFS.PAS b/Game/Code/lib/midi/MIDIDEFS.PAS
index e97a8627..fc8eed26 100644
--- a/Game/Code/lib/midi/MIDIDEFS.PAS
+++ b/Game/Code/lib/midi/MIDIDEFS.PAS
@@ -1,55 +1,55 @@
-{ $Header: /MidiComp/MIDIDEFS.PAS 2 10/06/97 7:33 Davec $ }
-
-{ Written by David Churcher <dchurcher@cix.compulink.co.uk>,
- released to the public domain. }
-
-
-{ Common definitions used by DELPHMID.DPR and the MIDI components.
- This must be a separate unit to prevent large chunks of the VCL being
- linked into the DLL. }
-unit Mididefs;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
- {$H+} // use AnsiString
-{$ENDIF}
-
-uses
- Windows,
- MMsystem,
- Circbuf;
-
-type
-
- {-------------------------------------------------------------------}
- { This is the information about the control that must be accessed by
- the MIDI input callback function in the DLL at interrupt time }
- PMidiCtlInfo = ^TMidiCtlInfo;
- TMidiCtlInfo = record
- hMem: THandle; { Memory handle for this record }
- PBuffer: PCircularBuffer; { Pointer to the MIDI input data buffer }
- hWindow: HWnd; { Control's window handle }
- SysexOnly: Boolean; { Only process System Exclusive input }
- end;
-
- { Information for the output timer callback function, also required at
- interrupt time. }
- PMidiOutTimerInfo = ^TMidiOutTimerInfo;
- TMidiOutTimerInfo = record
- hMem: THandle; { Memory handle for this record }
- PBuffer: PCircularBuffer; { Pointer to MIDI output data buffer }
- hWindow: HWnd; { Control's window handle }
- TimeToNextEvent: DWORD; { Delay to next event after timer set }
- MIDIHandle: HMidiOut; { MIDI handle to send output to
- (copy of component's FMidiHandle property) }
- PeriodMin: Word; { Multimedia timer minimum period supported }
- PeriodMax: Word; { Multimedia timer maximum period supported }
- TimerId: Word; { Multimedia timer ID of current event }
- end;
-
-implementation
-
-
-end.
+{ $Header: /MidiComp/MIDIDEFS.PAS 2 10/06/97 7:33 Davec $ }
+
+{ Written by David Churcher <dchurcher@cix.compulink.co.uk>,
+ released to the public domain. }
+
+
+{ Common definitions used by DELPHMID.DPR and the MIDI components.
+ This must be a separate unit to prevent large chunks of the VCL being
+ linked into the DLL. }
+unit Mididefs;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+ {$H+} // use AnsiString
+{$ENDIF}
+
+uses
+ Windows,
+ MMsystem,
+ Circbuf;
+
+type
+
+ {-------------------------------------------------------------------}
+ { This is the information about the control that must be accessed by
+ the MIDI input callback function in the DLL at interrupt time }
+ PMidiCtlInfo = ^TMidiCtlInfo;
+ TMidiCtlInfo = record
+ hMem: THandle; { Memory handle for this record }
+ PBuffer: PCircularBuffer; { Pointer to the MIDI input data buffer }
+ hWindow: HWnd; { Control's window handle }
+ SysexOnly: Boolean; { Only process System Exclusive input }
+ end;
+
+ { Information for the output timer callback function, also required at
+ interrupt time. }
+ PMidiOutTimerInfo = ^TMidiOutTimerInfo;
+ TMidiOutTimerInfo = record
+ hMem: THandle; { Memory handle for this record }
+ PBuffer: PCircularBuffer; { Pointer to MIDI output data buffer }
+ hWindow: HWnd; { Control's window handle }
+ TimeToNextEvent: DWORD; { Delay to next event after timer set }
+ MIDIHandle: HMidiOut; { MIDI handle to send output to
+ (copy of component's FMidiHandle property) }
+ PeriodMin: Word; { Multimedia timer minimum period supported }
+ PeriodMax: Word; { Multimedia timer maximum period supported }
+ TimerId: Word; { Multimedia timer ID of current event }
+ end;
+
+implementation
+
+
+end.
diff --git a/Game/Code/lib/midi/MIDITYPE.PAS b/Game/Code/lib/midi/MIDITYPE.PAS
index a4166c42..b1ec1bdd 100644
--- a/Game/Code/lib/midi/MIDITYPE.PAS
+++ b/Game/Code/lib/midi/MIDITYPE.PAS
@@ -1,90 +1,90 @@
-{ $Header: /MidiComp/MIDITYPE.PAS 2 10/06/97 7:33 Davec $ }
-
-{ Written by David Churcher <dchurcher@cix.compulink.co.uk>,
- released to the public domain. }
-
-
-unit Miditype;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
- {$H+} // use AnsiString
-{$ENDIF}
-
-uses
- Classes,
- Windows,
- Messages,
- MMSystem,
- MidiDefs,
- Circbuf;
-
-type
- {-------------------------------------------------------------------}
- { A MIDI input/output event }
- TMyMidiEvent = class(TPersistent)
- public
- MidiMessage: Byte; { MIDI message status byte }
- Data1: Byte; { MIDI message data 1 byte }
- Data2: Byte; { MIDI message data 2 byte }
- Time: DWORD; { Time in ms since midiInOpen }
- SysexLength: Word; { Length of sysex data (0 if none) }
- Sysex: PChar; { Pointer to sysex data buffer }
- destructor Destroy; override; { Frees sysex data buffer if nec. }
- end;
- PMyMidiEvent = ^TMyMidiEvent;
-
- {-------------------------------------------------------------------}
- { Encapsulates the MIDIHDR with its memory handle and sysex buffer }
- PMyMidiHdr = ^TMyMidiHdr;
- TMyMidiHdr = class(TObject)
- public
- hdrHandle: THandle;
- hdrPointer: PMIDIHDR;
- sysexHandle: THandle;
- sysexPointer: Pointer;
- constructor Create(BufferSize: Word);
- destructor Destroy; override;
- end;
-
-implementation
-
-{-------------------------------------------------------------------}
-{ Free any sysex buffer associated with the event }
-destructor TMyMidiEvent.Destroy;
-begin
- if (Sysex <> Nil) then
- Freemem(Sysex, SysexLength);
-
- inherited Destroy;
-end;
-
-{-------------------------------------------------------------------}
-{ Allocate memory for the sysex header and buffer }
-constructor TMyMidiHdr.Create(BufferSize:Word);
-begin
- inherited Create;
-
- if BufferSize > 0 then
- begin
- hdrPointer := GlobalSharedLockedAlloc(sizeof(TMIDIHDR), hdrHandle);
- sysexPointer := GlobalSharedLockedAlloc(BufferSize, sysexHandle);
-
- hdrPointer^.lpData := sysexPointer;
- hdrPointer^.dwBufferLength := BufferSize;
- end;
-end;
-
-{-------------------------------------------------------------------}
-destructor TMyMidiHdr.Destroy;
-begin
- GlobalSharedLockedFree( hdrHandle, hdrPointer );
- GlobalSharedLockedFree( sysexHandle, sysexPointer );
- inherited Destroy;
-end;
-
-
-
-end.
+{ $Header: /MidiComp/MIDITYPE.PAS 2 10/06/97 7:33 Davec $ }
+
+{ Written by David Churcher <dchurcher@cix.compulink.co.uk>,
+ released to the public domain. }
+
+
+unit Miditype;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+ {$H+} // use AnsiString
+{$ENDIF}
+
+uses
+ Classes,
+ Windows,
+ Messages,
+ MMSystem,
+ MidiDefs,
+ Circbuf;
+
+type
+ {-------------------------------------------------------------------}
+ { A MIDI input/output event }
+ TMyMidiEvent = class(TPersistent)
+ public
+ MidiMessage: Byte; { MIDI message status byte }
+ Data1: Byte; { MIDI message data 1 byte }
+ Data2: Byte; { MIDI message data 2 byte }
+ Time: DWORD; { Time in ms since midiInOpen }
+ SysexLength: Word; { Length of sysex data (0 if none) }
+ Sysex: PChar; { Pointer to sysex data buffer }
+ destructor Destroy; override; { Frees sysex data buffer if nec. }
+ end;
+ PMyMidiEvent = ^TMyMidiEvent;
+
+ {-------------------------------------------------------------------}
+ { Encapsulates the MIDIHDR with its memory handle and sysex buffer }
+ PMyMidiHdr = ^TMyMidiHdr;
+ TMyMidiHdr = class(TObject)
+ public
+ hdrHandle: THandle;
+ hdrPointer: PMIDIHDR;
+ sysexHandle: THandle;
+ sysexPointer: Pointer;
+ constructor Create(BufferSize: Word);
+ destructor Destroy; override;
+ end;
+
+implementation
+
+{-------------------------------------------------------------------}
+{ Free any sysex buffer associated with the event }
+destructor TMyMidiEvent.Destroy;
+begin
+ if (Sysex <> Nil) then
+ Freemem(Sysex, SysexLength);
+
+ inherited Destroy;
+end;
+
+{-------------------------------------------------------------------}
+{ Allocate memory for the sysex header and buffer }
+constructor TMyMidiHdr.Create(BufferSize:Word);
+begin
+ inherited Create;
+
+ if BufferSize > 0 then
+ begin
+ hdrPointer := GlobalSharedLockedAlloc(sizeof(TMIDIHDR), hdrHandle);
+ sysexPointer := GlobalSharedLockedAlloc(BufferSize, sysexHandle);
+
+ hdrPointer^.lpData := sysexPointer;
+ hdrPointer^.dwBufferLength := BufferSize;
+ end;
+end;
+
+{-------------------------------------------------------------------}
+destructor TMyMidiHdr.Destroy;
+begin
+ GlobalSharedLockedFree( hdrHandle, hdrPointer );
+ GlobalSharedLockedFree( sysexHandle, sysexPointer );
+ inherited Destroy;
+end;
+
+
+
+end.
diff --git a/Game/Code/lib/midi/MidiFile.pas b/Game/Code/lib/midi/MidiFile.pas
index 2da052f4..4279d305 100644
--- a/Game/Code/lib/midi/MidiFile.pas
+++ b/Game/Code/lib/midi/MidiFile.pas
@@ -1,964 +1,964 @@
-{
- Load a midifile and get access to tracks and events
- I did build this component to convert midifiles to wave files
- or play the files on a software synthesizer which I'm currenly
- building.
-
- version 1.0 first release
-
- version 1.1
- added some function
- function KeyToStr(key : integer) : string;
- function MyTimeToStr(val : integer) : string;
- Bpm can be set to change speed
-
- version 1.2
- added some functions
- function GetTrackLength:integer;
- function Ready: boolean;
-
- version 1.3
- update by Chulwoong,
- He knows how to use the MM timer, the timing is much better now, thank you
-
- for comments/bugs
- F.Bouwmans
- fbouwmans@spiditel.nl
-
- if you think this component is nice and you use it, sent me a short email.
- I've seen that other of my components have been downloaded a lot, but I've
- got no clue wether they are actually used.
- Don't worry because you are free to use these components
-
- Timing has improved, however because the messages are handled by the normal
- windows message loop (of the main window) it is still influenced by actions
- done on the window (minimize/maximize ..).
- Use of a second thread with higher priority which only handles the
- timer message should increase performance. If somebody knows such a component
- which is freeware please let me know.
-
- interface description:
-
- procedure ReadFile:
- actually read the file which is set in Filename
-
- function GetTrack(index: integer) : TMidiTrack;
-
- property Filename
- set/read filename of midifile
-
- property NumberOfTracks
- read number of tracks in current file
-
- property TicksPerQuarter: integer
- ticks per quarter, tells how to interpret the time value in midi events
-
- property FileFormat: TFileFormat
- tells the format of the current midifile
-
- property Bpm:integer
- tells Beats per minut
-
- property OnMidiEvent:TOnMidiEvent
- called while playing for each midi event
-
- procedure StartPlaying;
- start playing the current loaded midifile from the beginning
-
- procedure StopPlaying;
- stop playing the current midifile
-
- procedure PlayToTime(time : integer);
- if playing yourself then events from last time to this time are produced
-
-
- function KeyToStr(key : integer) : string;
- give note string on key value: e.g. C4
-
- function MyTimeToStr(val : integer) : string;
- give time string from msec time
-
- function GetTrackLength:integer;
- gives the track lenght in msec (assuming the bpm at the start oof the file)
-
- function Ready: boolean;
- now you can check wether the playback is finished
-
-}
-
-unit MidiFile;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
- {$H+} // use AnsiString
-{$ENDIF}
-
-uses
- Windows,
- //Forms,
- Messages,
- SysUtils,
- UCommon,
- Classes;
-
-type
- TChunkType = (illegal, header, track);
- TFileFormat = (single, multi_synch, multi_asynch);
- PByte = ^byte;
-
- TMidiEvent = record
- event: byte;
- data1: byte;
- data2: byte;
- str: string;
- dticks: integer;
- time: integer;
- mtime: integer;
- len: integer;
- end;
- PMidiEvent = ^TMidiEvent;
-
- TOnMidiEvent = procedure(event: PMidiEvent) of object;
- TEvent = procedure of object;
-
- TMidiTrack = class(TObject)
- protected
- events: TList;
- name: string;
- instrument: string;
- currentTime: integer;
- currentPos: integer;
- ready: boolean;
- trackLenght: integer;
- procedure checkReady;
- public
- OnMidiEvent: TOnMidiEvent;
- OnTrackReady: TEvent;
- constructor Create;
- destructor Destroy; override;
-
- procedure Rewind(pos: integer);
- procedure PlayUntil(pos: integer);
- procedure GoUntil(pos: integer);
-
- procedure putEvent(event: PMidiEvent);
- function getEvent(index: integer): PMidiEvent;
- function getName: string;
- function getInstrument: string;
- function getEventCount: integer;
- function getCurrentTime: integer;
- function getTrackLength: integer;
- function isReady:boolean;
- end;
-
- TMidiFile = class(TComponent)
- private
- { Private declarations }
- procedure MidiTimer(sender : TObject);
- procedure WndProc(var Msg : TMessage);
- protected
- { Protected declarations }
- midiFile: file of byte;
- chunkType: TChunkType;
- chunkLength: integer;
- chunkData: PByte;
- chunkIndex: PByte;
- chunkEnd: PByte;
- FPriority: DWORD;
-
- // midi file attributes
- FFileFormat: TFileFormat;
- numberTracks: integer;
- deltaTicks: integer;
- FBpm: integer;
- FBeatsPerMeasure: integer;
- FusPerTick: double;
- FFilename: string;
-
- Tracks: TList;
- currentTrack: TMidiTrack;
- FOnMidiEvent: TOnMidiEvent;
- FOnUpdateEvent: TNotifyEvent;
-
- // playing attributes
- playing: boolean;
- PlayStartTime: integer;
- currentTime: integer; // Current playtime in msec
- currentPos: Double; // Current Position in ticks
-
- procedure OnTrackReady;
- procedure setFilename(val: string);
- procedure ReadChunkHeader;
- procedure ReadChunkContent;
- procedure ReadChunk;
- procedure ProcessHeaderChunk;
- procedure ProcessTrackChunk;
- function ReadVarLength: integer;
- function ReadString(l: integer): string;
- procedure SetOnMidiEvent(handler: TOnMidiEvent);
- procedure SetBpm(val: integer);
- public
- { Public declarations }
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
-
- procedure ReadFile;
- function GetTrack(index: integer): TMidiTrack;
-
- procedure StartPlaying;
- procedure StopPlaying;
- procedure ContinuePlaying;
-
- procedure PlayToTime(time: integer);
- procedure GoToTime(time: integer);
- function GetCurrentTime: integer;
- function GetFusPerTick : Double;
- function GetTrackLength:integer;
- function Ready: boolean;
- published
- { Published declarations }
- property Filename: string read FFilename write setFilename;
- property NumberOfTracks: integer read numberTracks;
- property TicksPerQuarter: integer read deltaTicks;
- property FileFormat: TFileFormat read FFileFormat;
- property Bpm: integer read FBpm write SetBpm;
- property OnMidiEvent: TOnMidiEvent read FOnMidiEvent write SetOnMidiEvent;
- property OnUpdateEvent: TNotifyEvent read FOnUpdateEvent write FOnUpdateEvent;
- end;
-
-function KeyToStr(key: integer): string;
-function MyTimeToStr(val: integer): string;
-procedure Register;
-
-implementation
-
-uses mmsystem;
-
-type
-{$IFDEF FPC}
- TTimerProc = TTIMECALLBACK;
- TTimeCaps = TIMECAPS;
-{$ELSE}
- TTimerProc = TFNTimeCallBack;
-{$ENDIF}
-
-const TIMER_RESOLUTION=10;
-const WM_MULTIMEDIA_TIMER=WM_USER+127;
-
-var MIDIFileHandle : HWND;
- TimerProc : TTimerProc;
- MIDITimerID : Integer;
- TimerPeriod : Integer;
-
-procedure TimerCallBackProc(uTimerID,uMsg: Cardinal; dwUser,dwParam1,dwParam2:DWORD);stdcall;
-begin
- PostMessage(HWND(dwUser),WM_MULTIMEDIA_TIMER,0,0);
-end;
-
-procedure SetMIDITimer;
- var TimeCaps : TTimeCaps;
-begin
- timeGetDevCaps(@TimeCaps,SizeOf(TimeCaps));
- if TIMER_RESOLUTION < TimeCaps.wPeriodMin then
- TimerPeriod:=TimeCaps.wPeriodMin
- else if TIMER_RESOLUTION > TimeCaps.wPeriodMax then
- TimerPeriod:=TimeCaps.wPeriodMax
- else
- TimerPeriod:=TIMER_RESOLUTION;
-
- timeBeginPeriod(TimerPeriod);
- MIDITimerID:=timeSetEvent(TimerPeriod,TimerPeriod,TimerProc,
- DWORD(MIDIFileHandle),TIME_PERIODIC);
- if MIDITimerID=0 then
- timeEndPeriod(TimerPeriod);
-end;
-
-procedure KillMIDITimer;
-begin
- timeKillEvent(MIDITimerID);
- timeEndPeriod(TimerPeriod);
-end;
-
-constructor TMidiTrack.Create;
-begin
- inherited Create;
- events := TList.Create;
- currentTime := 0;
- currentPos := 0;
-end;
-
-destructor TMidiTrack.Destroy;
-var
- i: integer;
-begin
- for i := 0 to events.count - 1 do
- Dispose(PMidiEvent(events.items[i]));
- events.Free;
- inherited Destroy;
-end;
-
-procedure TMidiTRack.putEvent(event: PMidiEvent);
-var
- command: integer;
- i: integer;
- pevent: PMidiEvent;
-begin
- if (event.event = $FF) then
- begin
- if (event.data1 = 3) then
- name := event.str;
- if (event.data1 = 4) then
- instrument := event.str;
- end;
- currentTime := currentTime + event.dticks;
- event.time := currentTime; // for the moment just add dticks
- event.len := 0;
- events.add(TObject(event));
- command := event.event and $F0;
-
- if ((command = $80) // note off
- or ((command = $90) and (event.data2 = 0))) //note on with speed 0
- then
- begin
- // this is a note off, try to find the accompanion note on
- command := event.event or $90;
- i := events.count - 2;
- while i >= 0 do
- begin
- pevent := PMidiEvent(events[i]);
- if (pevent.event = command) and
- (pevent.data1 = event.data1)
- then
- begin
- pevent.len := currentTIme - pevent.time;
- i := 0;
- event.len := -1;
- end;
- dec(i);
- end;
- end;
-end;
-
-function TMidiTrack.getName: string;
-begin
- result := name;
-end;
-
-function TMidiTrack.getInstrument: string;
-begin
- result := instrument;
-end;
-
-function TMiditrack.getEventCount: integer;
-begin
- result := events.count;
-end;
-
-function TMiditrack.getEvent(index: integer): PMidiEvent;
-begin
- if ((index < events.count) and (index >= 0)) then
- result := events[index]
- else
- result := nil;
-end;
-
-function TMiditrack.getCurrentTime: integer;
-begin
- result := currentTime;
-end;
-
-procedure TMiditrack.Rewind(pos: integer);
-begin
- if currentPos = events.count then
- dec(currentPos);
- while ((currentPos > 0) and
- (PMidiEvent(events[currentPos]).time > pos))
- do
- begin
- dec(currentPos);
- end;
- checkReady;
-end;
-
-procedure TMiditrack.PlayUntil(pos: integer);
-begin
- if assigned(OnMidiEvent) then
- begin
- while ((currentPos < events.count) and
- (PMidiEvent(events[currentPos]).time < pos)) do
- begin
- OnMidiEvent(PMidiEvent(events[currentPos]));
- inc(currentPos);
- end;
- end;
- checkReady;
-end;
-
-procedure TMidiTrack.GoUntil(pos: integer);
-begin
- while ((currentPos < events.count) and
- (PMidiEvent(events[currentPos]).time < pos)) do
- begin
- inc(currentPos);
- end;
- checkReady;
-end;
-
-procedure TMidiTrack.checkReady;
-begin
- if currentPos >= events.count then
- begin
- ready := true;
- if assigned(OnTrackReady) then
- OnTrackReady;
- end
- else
- ready := false;
-end;
-
-function TMidiTrack.getTrackLength: integer;
-begin
- result := PMidiEvent(events[events.count-1]).time
-end;
-
-function TMidiTrack.isReady: boolean;
-begin
- result := ready;
-end;
-
-constructor TMidifile.Create(AOwner: TComponent);
-begin
- inherited Create(AOWner);
- MIDIFileHandle:=AllocateHWnd(WndProc);
- chunkData := nil;
- chunkType := illegal;
- Tracks := TList.Create;
- TimerProc:=@TimerCallBackProc;
- FPriority:=GetPriorityClass(MIDIFileHandle);
-end;
-
-destructor TMidifile.Destroy;
-var
- i: integer;
-begin
- if not (chunkData = nil) then FreeMem(chunkData);
- for i := 0 to Tracks.Count - 1 do
- TMidiTrack(Tracks.Items[i]).Free;
- Tracks.Free;
- SetPriorityClass(MIDIFileHandle,FPriority);
-
- if MIDITimerID<>0 then KillMIDITimer;
-
- DeallocateHWnd(MIDIFileHandle);
-
- inherited Destroy;
-end;
-
-function TMidiFile.GetTrack(index: integer): TMidiTrack;
-begin
- result := Tracks.Items[index];
-end;
-
-procedure TMidifile.setFilename(val: string);
-begin
- FFilename := val;
-// ReadFile;
-end;
-
-procedure TMidifile.SetOnMidiEvent(handler: TOnMidiEvent);
-var
- i: integer;
-begin
-// if not (FOnMidiEvent = handler) then
-// begin
- FOnMidiEvent := handler;
- for i := 0 to tracks.count - 1 do
- TMidiTrack(tracks.items[i]).OnMidiEvent := handler;
-// end;
-end;
-
-procedure TMidifile.MidiTimer(Sender: TObject);
-begin
- if playing then
- begin
- PlayToTime(GetTickCount - PlayStartTime);
- if assigned(FOnUpdateEvent) then FOnUpdateEvent(self);
- end;
-end;
-
-procedure TMidifile.StartPlaying;
-var
- i: integer;
-begin
- for i := 0 to tracks.count - 1 do
- TMidiTrack(tracks[i]).Rewind(0);
- playStartTime := getTickCount;
- playing := true;
-
- SetPriorityClass(MIDIFileHandle,REALTIME_PRIORITY_CLASS);
-
- SetMIDITimer;
- currentPos := 0.0;
- currentTime := 0;
-end;
-
-procedure TMidifile.ContinuePlaying;
-begin
- PlayStartTime := GetTickCount - currentTime;
- playing := true;
-
- SetPriorityClass(MIDIFileHandle,REALTIME_PRIORITY_CLASS);
-
- SetMIDITimer;
-end;
-
-procedure TMidifile.StopPlaying;
-begin
- playing := false;
- KillMIDITimer;
- SetPriorityClass(MIDIFileHandle,FPriority);
-end;
-
-function TMidiFile.GetCurrentTime: integer;
-begin
- Result := currentTime;
-end;
-
-procedure TMidifile.PlayToTime(time: integer);
-var
- i: integer;
- track: TMidiTrack;
- pos: integer;
- deltaTime: integer;
-begin
- // calculate the pos in the file.
- // pos is actually tick
- // Current FusPerTick is uses to determine the actual pos
-
- deltaTime := time - currentTime;
- currentPos := currentPos + (deltaTime * 1000) / FusPerTick;
- pos := round(currentPos);
-
- for i := 0 to tracks.count - 1 do
- begin
- TMidiTrack(tracks.items[i]).PlayUntil(pos);
- end;
- currentTime := time;
-end;
-
-procedure TMidifile.GoToTime(time: integer);
-var
- i: integer;
- track: TMidiTrack;
- pos: integer;
-begin
- // this function should be changed because FusPerTick might not be constant
- pos := round((time * 1000) / FusPerTick);
- for i := 0 to tracks.count - 1 do
- begin
- TMidiTrack(tracks.items[i]).Rewind(0);
- TMidiTrack(tracks.items[i]).GoUntil(pos);
- end;
-end;
-
-procedure TMidifile.SetBpm(val: integer);
-var
- us_per_quarter: integer;
-begin
- if not (val = FBpm) then
- begin
- us_per_quarter := 60000000 div val;
-
- FBpm := 60000000 div us_per_quarter;
- FusPerTick := us_per_quarter / deltaTicks;
- end;
-end;
-
-procedure TMidifile.ReadChunkHeader;
-var
- theByte: array[0..7] of byte;
-begin
- BlockRead(midiFile, theByte, 8);
- if (theByte[0] = $4D) and (theByte[1] = $54) then
- begin
- if (theByte[2] = $68) and (theByte[3] = $64) then
- chunkType := header
- else if (theByte[2] = $72) and (theByte[3] = $6B) then
- chunkType := track
- else
- chunkType := illegal;
- end
- else
- begin
- chunkType := illegal;
- end;
- chunkLength := theByte[7] + theByte[6] * $100 + theByte[5] * $10000 + theByte[4] * $1000000;
-end;
-
-procedure TMidifile.ReadChunkContent;
-begin
- if not (chunkData = nil) then
- FreeMem(chunkData);
- GetMem(chunkData, chunkLength + 10);
- BlockRead(midiFile, chunkData^, chunkLength);
- chunkIndex := chunkData;
- chunkEnd := PByte(integer(chunkIndex) + integer(chunkLength) - 1);
-end;
-
-procedure TMidifile.ReadChunk;
-begin
- ReadChunkHeader;
- ReadChunkContent;
- case chunkType of
- header:
- ProcessHeaderChunk;
- track:
- ProcessTrackCHunk;
- end;
-end;
-
-procedure TMidifile.ProcessHeaderChunk;
-begin
- chunkIndex := chunkData;
- inc(chunkIndex);
- if chunkType = header then
- begin
- case chunkIndex^ of
- 0: FfileFormat := single;
- 1: FfileFormat := multi_synch;
- 2: FfileFormat := multi_asynch;
- end;
- inc(chunkIndex);
- numberTracks := chunkIndex^ * $100;
- inc(chunkIndex);
- numberTracks := numberTracks + chunkIndex^;
- inc(chunkIndex);
- deltaTicks := chunkIndex^ * $100;
- inc(chunkIndex);
- deltaTicks := deltaTicks + chunkIndex^;
- end;
-end;
-
-procedure TMidifile.ProcessTrackChunk;
-var
- dTime: integer;
- event: integer;
- len: integer;
- str: string;
- midiEvent: PMidiEvent;
- i: integer;
- us_per_quarter: integer;
-begin
- chunkIndex := chunkData;
-// inc(chunkIndex);
- event := 0;
- if chunkType = track then
- begin
- currentTrack := TMidiTrack.Create;
- currentTrack.OnMidiEvent := FOnMidiEvent;
- Tracks.add(currentTrack);
- while integer(chunkIndex) < integer(chunkEnd) do
- begin
- // each event starts with var length delta time
- dTime := ReadVarLength;
- if chunkIndex^ >= $80 then
- begin
- event := chunkIndex^;
- inc(chunkIndex);
- end;
- // else it is a running status event (just the same event as before)
-
- if event = $FF then
- begin
-{ case chunkIndex^ of
- $00: // sequence number, not implemented jet
- begin
- inc(chunkIndex); // $02
- inc(chunkIndex);
- end;
- $01 .. $0f: // text events FF ty len text
- begin
- New(midiEvent);
- midiEvent.event := $FF;
- midiEvent.data1 := chunkIndex^; // type is stored in data1
- midiEvent.dticks := dtime;
-
- inc(chunkIndex);
- len := ReadVarLength;
- midiEvent.str := ReadString(len);
-
- currentTrack.putEvent(midiEvent);
- end;
- $20: // Midi channel prefix FF 20 01 cc
- begin
- inc(chunkIndex); // $01
- inc(chunkIndex); // channel
- inc(chunkIndex);
- end;
- $2F: // End of track FF 2F 00
- begin
- inc(chunkIndex); // $00
- inc(chunkIndex);
- end;
- $51: // Set Tempo FF 51 03 tttttt
- begin
- inc(chunkIndex); // $03
- inc(chunkIndex); // tt
- inc(chunkIndex); // tt
- inc(chunkIndex); // tt
- inc(chunkIndex);
- end;
- $54: // SMPTE offset FF 54 05 hr mn se fr ff
- begin
- inc(chunkIndex); // $05
- inc(chunkIndex); // hr
- inc(chunkIndex); // mn
- inc(chunkIndex); // se
- inc(chunkIndex); // fr
- inc(chunkIndex); // ff
- inc(chunkIndex);
- end;
- $58: // Time signature FF 58 04 nn dd cc bb
- begin
- inc(chunkIndex); // $04
- inc(chunkIndex); // nn
- inc(chunkIndex); // dd
- inc(chunkIndex); // cc
- inc(chunkIndex); // bb
- inc(chunkIndex);
- end;
- $59: // Key signature FF 59 02 df mi
- begin
- inc(chunkIndex); // $02
- inc(chunkIndex); // df
- inc(chunkIndex); // mi
- inc(chunkIndex);
- end;
- $7F: // Sequence specific Meta-event
- begin
- inc(chunkIndex);
- len := ReadVarLength;
- str := ReadString(len);
- end;
- else // unknown meta event
- }
- begin
- New(midiEvent);
- midiEvent.event := $FF;
- midiEvent.data1 := chunkIndex^; // type is stored in data1
- midiEvent.dticks := dtime;
-
- inc(chunkIndex);
- len := ReadVarLength;
- midiEvent.str := ReadString(len);
- currentTrack.putEvent(midiEvent);
-
- case midiEvent.data1 of
- $51:
- begin
- us_per_quarter :=
- (integer(byte(midiEvent.str[1])) shl 16 +
- integer(byte(midiEvent.str[2])) shl 8 +
- integer(byte(midiEvent.str[3])));
- FBpm := 60000000 div us_per_quarter;
- FusPerTick := us_per_quarter / deltaTicks;
- end;
- end;
- end;
-// end;
- end
- else
- begin
- // these are all midi events
- New(midiEvent);
- midiEvent.event := event;
- midiEvent.dticks := dtime;
-// inc(chunkIndex);
- case event of
- $80..$8F, // note off
- $90..$9F, // note on
- $A0..$AF, // key aftertouch
- $B0..$BF, // control change
- $E0..$EF: // pitch wheel change
- begin
- midiEvent.data1 := chunkIndex^; inc(chunkIndex);
- midiEvent.data2 := chunkIndex^; inc(chunkIndex);
- end;
- $C0..$CF, // program change
- $D0..$DF: // channel aftertouch
- begin
- midiEvent.data1 := chunkIndex^; inc(chunkIndex);
- end;
- else
- // error
- end;
- currentTrack.putEvent(midiEvent);
- end;
- end;
- end;
-end;
-
-
-function TMidifile.ReadVarLength: integer;
-var
- i: integer;
- b: byte;
-begin
- b := 128;
- i := 0;
- while b > 127 do
- begin
- i := i shl 7;
- b := chunkIndex^;
- i := i + b and $7F;
- inc(chunkIndex);
- end;
- result := i;
-end;
-
-function TMidifile.ReadString(l: integer): string;
-var
- s: PChar;
- i: integer;
-begin
- GetMem(s, l + 1); ;
- s[l] := chr(0);
- for i := 0 to l - 1 do
- begin
- s[i] := Chr(chunkIndex^);
- inc(chunkIndex);
- end;
- result := string(s);
-end;
-
-procedure TMidifile.ReadFile;
-var
- i: integer;
-begin
- for i := 0 to Tracks.Count - 1 do
- TMidiTrack(Tracks.Items[i]).Free;
- Tracks.Clear;
- chunkType := illegal;
-
- AssignFile(midiFile, FFilename);
- FileMode := 0;
- Reset(midiFile);
- while not eof(midiFile) do
- ReadChunk;
- CloseFile(midiFile);
- numberTracks := Tracks.Count;
-end;
-
-function KeyToStr(key: integer): string;
-var
- n: integer;
- str: string;
-begin
- n := key mod 12;
- case n of
- 0: str := 'C';
- 1: str := 'C#';
- 2: str := 'D';
- 3: str := 'D#';
- 4: str := 'E';
- 5: str := 'F';
- 6: str := 'F#';
- 7: str := 'G';
- 8: str := 'G#';
- 9: str := 'A';
- 10: str := 'A#';
- 11: str := 'B';
- end;
- Result := str + IntToStr(key div 12);
-end;
-
-function IntToLenStr(val: integer; len: integer): string;
-var
- str: string;
-begin
- str := IntToStr(val);
- while Length(str) < len do
- str := '0' + str;
- Result := str;
-end;
-
-function MyTimeToStr(val: integer): string;
- var
- hour: integer;
- min: integer;
- sec: integer;
- msec: integer;
-begin
- msec := val mod 1000;
- sec := val div 1000;
- min := sec div 60;
- sec := sec mod 60;
- hour := min div 60;
- min := min mod 60;
- Result := IntToStr(hour) + ':' + IntToLenStr(min, 2) + ':' + IntToLenStr(sec, 2) + '.' + IntToLenStr(msec, 3);
-end;
-
-function TMidiFIle.GetFusPerTick : Double;
-begin
- Result := FusPerTick;
-end;
-
-function TMidiFIle.GetTrackLength:integer;
-var i,length : integer;
- time : extended;
-begin
- length := 0;
- for i := 0 to Tracks.Count - 1 do
- if TMidiTrack(Tracks.Items[i]).getTrackLength > length then
- length := TMidiTrack(Tracks.Items[i]).getTrackLength;
- time := length * FusPerTick;
- time := time / 1000.0;
- result := round(time);
-end;
-
-function TMidiFIle.Ready: boolean;
-var i : integer;
-begin
- result := true;
- for i := 0 to Tracks.Count - 1 do
- if not TMidiTrack(Tracks.Items[i]).isready then
- result := false;
-end;
-
-procedure TMidiFile.OnTrackReady;
-begin
- if ready then
- if assigned(FOnUpdateEvent) then FOnUpdateEvent(self);
-end;
-
-procedure TMidiFile.WndProc(var Msg : TMessage);
-begin
- with MSG do
- begin
- case Msg of
- WM_MULTIMEDIA_TIMER:
- begin
- //try
- MidiTimer(self);
- //except
- // Note: HandleException() is called by default if exception is not handled
- // Application.HandleException(Self);
- //end;
- end;
- else
- begin
- Result := DefWindowProc(MIDIFileHandle, Msg, wParam, lParam);
- end;
- end;
- end;
-end;
-
-procedure Register;
-begin
- RegisterComponents('Synth', [TMidiFile]);
-end;
-
-end.
-
+{
+ Load a midifile and get access to tracks and events
+ I did build this component to convert midifiles to wave files
+ or play the files on a software synthesizer which I'm currenly
+ building.
+
+ version 1.0 first release
+
+ version 1.1
+ added some function
+ function KeyToStr(key : integer) : string;
+ function MyTimeToStr(val : integer) : string;
+ Bpm can be set to change speed
+
+ version 1.2
+ added some functions
+ function GetTrackLength:integer;
+ function Ready: boolean;
+
+ version 1.3
+ update by Chulwoong,
+ He knows how to use the MM timer, the timing is much better now, thank you
+
+ for comments/bugs
+ F.Bouwmans
+ fbouwmans@spiditel.nl
+
+ if you think this component is nice and you use it, sent me a short email.
+ I've seen that other of my components have been downloaded a lot, but I've
+ got no clue wether they are actually used.
+ Don't worry because you are free to use these components
+
+ Timing has improved, however because the messages are handled by the normal
+ windows message loop (of the main window) it is still influenced by actions
+ done on the window (minimize/maximize ..).
+ Use of a second thread with higher priority which only handles the
+ timer message should increase performance. If somebody knows such a component
+ which is freeware please let me know.
+
+ interface description:
+
+ procedure ReadFile:
+ actually read the file which is set in Filename
+
+ function GetTrack(index: integer) : TMidiTrack;
+
+ property Filename
+ set/read filename of midifile
+
+ property NumberOfTracks
+ read number of tracks in current file
+
+ property TicksPerQuarter: integer
+ ticks per quarter, tells how to interpret the time value in midi events
+
+ property FileFormat: TFileFormat
+ tells the format of the current midifile
+
+ property Bpm:integer
+ tells Beats per minut
+
+ property OnMidiEvent:TOnMidiEvent
+ called while playing for each midi event
+
+ procedure StartPlaying;
+ start playing the current loaded midifile from the beginning
+
+ procedure StopPlaying;
+ stop playing the current midifile
+
+ procedure PlayToTime(time : integer);
+ if playing yourself then events from last time to this time are produced
+
+
+ function KeyToStr(key : integer) : string;
+ give note string on key value: e.g. C4
+
+ function MyTimeToStr(val : integer) : string;
+ give time string from msec time
+
+ function GetTrackLength:integer;
+ gives the track lenght in msec (assuming the bpm at the start oof the file)
+
+ function Ready: boolean;
+ now you can check wether the playback is finished
+
+}
+
+unit MidiFile;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+ {$H+} // use AnsiString
+{$ENDIF}
+
+uses
+ Windows,
+ //Forms,
+ Messages,
+ SysUtils,
+ UCommon,
+ Classes;
+
+type
+ TChunkType = (illegal, header, track);
+ TFileFormat = (single, multi_synch, multi_asynch);
+ PByte = ^byte;
+
+ TMidiEvent = record
+ event: byte;
+ data1: byte;
+ data2: byte;
+ str: string;
+ dticks: integer;
+ time: integer;
+ mtime: integer;
+ len: integer;
+ end;
+ PMidiEvent = ^TMidiEvent;
+
+ TOnMidiEvent = procedure(event: PMidiEvent) of object;
+ TEvent = procedure of object;
+
+ TMidiTrack = class(TObject)
+ protected
+ events: TList;
+ name: string;
+ instrument: string;
+ currentTime: integer;
+ currentPos: integer;
+ ready: boolean;
+ trackLenght: integer;
+ procedure checkReady;
+ public
+ OnMidiEvent: TOnMidiEvent;
+ OnTrackReady: TEvent;
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure Rewind(pos: integer);
+ procedure PlayUntil(pos: integer);
+ procedure GoUntil(pos: integer);
+
+ procedure putEvent(event: PMidiEvent);
+ function getEvent(index: integer): PMidiEvent;
+ function getName: string;
+ function getInstrument: string;
+ function getEventCount: integer;
+ function getCurrentTime: integer;
+ function getTrackLength: integer;
+ function isReady:boolean;
+ end;
+
+ TMidiFile = class(TComponent)
+ private
+ { Private declarations }
+ procedure MidiTimer(sender : TObject);
+ procedure WndProc(var Msg : TMessage);
+ protected
+ { Protected declarations }
+ midiFile: file of byte;
+ chunkType: TChunkType;
+ chunkLength: integer;
+ chunkData: PByte;
+ chunkIndex: PByte;
+ chunkEnd: PByte;
+ FPriority: DWORD;
+
+ // midi file attributes
+ FFileFormat: TFileFormat;
+ numberTracks: integer;
+ deltaTicks: integer;
+ FBpm: integer;
+ FBeatsPerMeasure: integer;
+ FusPerTick: double;
+ FFilename: string;
+
+ Tracks: TList;
+ currentTrack: TMidiTrack;
+ FOnMidiEvent: TOnMidiEvent;
+ FOnUpdateEvent: TNotifyEvent;
+
+ // playing attributes
+ playing: boolean;
+ PlayStartTime: integer;
+ currentTime: integer; // Current playtime in msec
+ currentPos: Double; // Current Position in ticks
+
+ procedure OnTrackReady;
+ procedure setFilename(val: string);
+ procedure ReadChunkHeader;
+ procedure ReadChunkContent;
+ procedure ReadChunk;
+ procedure ProcessHeaderChunk;
+ procedure ProcessTrackChunk;
+ function ReadVarLength: integer;
+ function ReadString(l: integer): string;
+ procedure SetOnMidiEvent(handler: TOnMidiEvent);
+ procedure SetBpm(val: integer);
+ public
+ { Public declarations }
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+
+ procedure ReadFile;
+ function GetTrack(index: integer): TMidiTrack;
+
+ procedure StartPlaying;
+ procedure StopPlaying;
+ procedure ContinuePlaying;
+
+ procedure PlayToTime(time: integer);
+ procedure GoToTime(time: integer);
+ function GetCurrentTime: integer;
+ function GetFusPerTick : Double;
+ function GetTrackLength:integer;
+ function Ready: boolean;
+ published
+ { Published declarations }
+ property Filename: string read FFilename write setFilename;
+ property NumberOfTracks: integer read numberTracks;
+ property TicksPerQuarter: integer read deltaTicks;
+ property FileFormat: TFileFormat read FFileFormat;
+ property Bpm: integer read FBpm write SetBpm;
+ property OnMidiEvent: TOnMidiEvent read FOnMidiEvent write SetOnMidiEvent;
+ property OnUpdateEvent: TNotifyEvent read FOnUpdateEvent write FOnUpdateEvent;
+ end;
+
+function KeyToStr(key: integer): string;
+function MyTimeToStr(val: integer): string;
+procedure Register;
+
+implementation
+
+uses mmsystem;
+
+type
+{$IFDEF FPC}
+ TTimerProc = TTIMECALLBACK;
+ TTimeCaps = TIMECAPS;
+{$ELSE}
+ TTimerProc = TFNTimeCallBack;
+{$ENDIF}
+
+const TIMER_RESOLUTION=10;
+const WM_MULTIMEDIA_TIMER=WM_USER+127;
+
+var MIDIFileHandle : HWND;
+ TimerProc : TTimerProc;
+ MIDITimerID : Integer;
+ TimerPeriod : Integer;
+
+procedure TimerCallBackProc(uTimerID,uMsg: Cardinal; dwUser,dwParam1,dwParam2:DWORD);stdcall;
+begin
+ PostMessage(HWND(dwUser),WM_MULTIMEDIA_TIMER,0,0);
+end;
+
+procedure SetMIDITimer;
+ var TimeCaps : TTimeCaps;
+begin
+ timeGetDevCaps(@TimeCaps,SizeOf(TimeCaps));
+ if TIMER_RESOLUTION < TimeCaps.wPeriodMin then
+ TimerPeriod:=TimeCaps.wPeriodMin
+ else if TIMER_RESOLUTION > TimeCaps.wPeriodMax then
+ TimerPeriod:=TimeCaps.wPeriodMax
+ else
+ TimerPeriod:=TIMER_RESOLUTION;
+
+ timeBeginPeriod(TimerPeriod);
+ MIDITimerID:=timeSetEvent(TimerPeriod,TimerPeriod,TimerProc,
+ DWORD(MIDIFileHandle),TIME_PERIODIC);
+ if MIDITimerID=0 then
+ timeEndPeriod(TimerPeriod);
+end;
+
+procedure KillMIDITimer;
+begin
+ timeKillEvent(MIDITimerID);
+ timeEndPeriod(TimerPeriod);
+end;
+
+constructor TMidiTrack.Create;
+begin
+ inherited Create;
+ events := TList.Create;
+ currentTime := 0;
+ currentPos := 0;
+end;
+
+destructor TMidiTrack.Destroy;
+var
+ i: integer;
+begin
+ for i := 0 to events.count - 1 do
+ Dispose(PMidiEvent(events.items[i]));
+ events.Free;
+ inherited Destroy;
+end;
+
+procedure TMidiTRack.putEvent(event: PMidiEvent);
+var
+ command: integer;
+ i: integer;
+ pevent: PMidiEvent;
+begin
+ if (event.event = $FF) then
+ begin
+ if (event.data1 = 3) then
+ name := event.str;
+ if (event.data1 = 4) then
+ instrument := event.str;
+ end;
+ currentTime := currentTime + event.dticks;
+ event.time := currentTime; // for the moment just add dticks
+ event.len := 0;
+ events.add(TObject(event));
+ command := event.event and $F0;
+
+ if ((command = $80) // note off
+ or ((command = $90) and (event.data2 = 0))) //note on with speed 0
+ then
+ begin
+ // this is a note off, try to find the accompanion note on
+ command := event.event or $90;
+ i := events.count - 2;
+ while i >= 0 do
+ begin
+ pevent := PMidiEvent(events[i]);
+ if (pevent.event = command) and
+ (pevent.data1 = event.data1)
+ then
+ begin
+ pevent.len := currentTIme - pevent.time;
+ i := 0;
+ event.len := -1;
+ end;
+ dec(i);
+ end;
+ end;
+end;
+
+function TMidiTrack.getName: string;
+begin
+ result := name;
+end;
+
+function TMidiTrack.getInstrument: string;
+begin
+ result := instrument;
+end;
+
+function TMiditrack.getEventCount: integer;
+begin
+ result := events.count;
+end;
+
+function TMiditrack.getEvent(index: integer): PMidiEvent;
+begin
+ if ((index < events.count) and (index >= 0)) then
+ result := events[index]
+ else
+ result := nil;
+end;
+
+function TMiditrack.getCurrentTime: integer;
+begin
+ result := currentTime;
+end;
+
+procedure TMiditrack.Rewind(pos: integer);
+begin
+ if currentPos = events.count then
+ dec(currentPos);
+ while ((currentPos > 0) and
+ (PMidiEvent(events[currentPos]).time > pos))
+ do
+ begin
+ dec(currentPos);
+ end;
+ checkReady;
+end;
+
+procedure TMiditrack.PlayUntil(pos: integer);
+begin
+ if assigned(OnMidiEvent) then
+ begin
+ while ((currentPos < events.count) and
+ (PMidiEvent(events[currentPos]).time < pos)) do
+ begin
+ OnMidiEvent(PMidiEvent(events[currentPos]));
+ inc(currentPos);
+ end;
+ end;
+ checkReady;
+end;
+
+procedure TMidiTrack.GoUntil(pos: integer);
+begin
+ while ((currentPos < events.count) and
+ (PMidiEvent(events[currentPos]).time < pos)) do
+ begin
+ inc(currentPos);
+ end;
+ checkReady;
+end;
+
+procedure TMidiTrack.checkReady;
+begin
+ if currentPos >= events.count then
+ begin
+ ready := true;
+ if assigned(OnTrackReady) then
+ OnTrackReady;
+ end
+ else
+ ready := false;
+end;
+
+function TMidiTrack.getTrackLength: integer;
+begin
+ result := PMidiEvent(events[events.count-1]).time
+end;
+
+function TMidiTrack.isReady: boolean;
+begin
+ result := ready;
+end;
+
+constructor TMidifile.Create(AOwner: TComponent);
+begin
+ inherited Create(AOWner);
+ MIDIFileHandle:=AllocateHWnd(WndProc);
+ chunkData := nil;
+ chunkType := illegal;
+ Tracks := TList.Create;
+ TimerProc:=@TimerCallBackProc;
+ FPriority:=GetPriorityClass(MIDIFileHandle);
+end;
+
+destructor TMidifile.Destroy;
+var
+ i: integer;
+begin
+ if not (chunkData = nil) then FreeMem(chunkData);
+ for i := 0 to Tracks.Count - 1 do
+ TMidiTrack(Tracks.Items[i]).Free;
+ Tracks.Free;
+ SetPriorityClass(MIDIFileHandle,FPriority);
+
+ if MIDITimerID<>0 then KillMIDITimer;
+
+ DeallocateHWnd(MIDIFileHandle);
+
+ inherited Destroy;
+end;
+
+function TMidiFile.GetTrack(index: integer): TMidiTrack;
+begin
+ result := Tracks.Items[index];
+end;
+
+procedure TMidifile.setFilename(val: string);
+begin
+ FFilename := val;
+// ReadFile;
+end;
+
+procedure TMidifile.SetOnMidiEvent(handler: TOnMidiEvent);
+var
+ i: integer;
+begin
+// if not (FOnMidiEvent = handler) then
+// begin
+ FOnMidiEvent := handler;
+ for i := 0 to tracks.count - 1 do
+ TMidiTrack(tracks.items[i]).OnMidiEvent := handler;
+// end;
+end;
+
+procedure TMidifile.MidiTimer(Sender: TObject);
+begin
+ if playing then
+ begin
+ PlayToTime(GetTickCount - PlayStartTime);
+ if assigned(FOnUpdateEvent) then FOnUpdateEvent(self);
+ end;
+end;
+
+procedure TMidifile.StartPlaying;
+var
+ i: integer;
+begin
+ for i := 0 to tracks.count - 1 do
+ TMidiTrack(tracks[i]).Rewind(0);
+ playStartTime := getTickCount;
+ playing := true;
+
+ SetPriorityClass(MIDIFileHandle,REALTIME_PRIORITY_CLASS);
+
+ SetMIDITimer;
+ currentPos := 0.0;
+ currentTime := 0;
+end;
+
+procedure TMidifile.ContinuePlaying;
+begin
+ PlayStartTime := GetTickCount - currentTime;
+ playing := true;
+
+ SetPriorityClass(MIDIFileHandle,REALTIME_PRIORITY_CLASS);
+
+ SetMIDITimer;
+end;
+
+procedure TMidifile.StopPlaying;
+begin
+ playing := false;
+ KillMIDITimer;
+ SetPriorityClass(MIDIFileHandle,FPriority);
+end;
+
+function TMidiFile.GetCurrentTime: integer;
+begin
+ Result := currentTime;
+end;
+
+procedure TMidifile.PlayToTime(time: integer);
+var
+ i: integer;
+ track: TMidiTrack;
+ pos: integer;
+ deltaTime: integer;
+begin
+ // calculate the pos in the file.
+ // pos is actually tick
+ // Current FusPerTick is uses to determine the actual pos
+
+ deltaTime := time - currentTime;
+ currentPos := currentPos + (deltaTime * 1000) / FusPerTick;
+ pos := round(currentPos);
+
+ for i := 0 to tracks.count - 1 do
+ begin
+ TMidiTrack(tracks.items[i]).PlayUntil(pos);
+ end;
+ currentTime := time;
+end;
+
+procedure TMidifile.GoToTime(time: integer);
+var
+ i: integer;
+ track: TMidiTrack;
+ pos: integer;
+begin
+ // this function should be changed because FusPerTick might not be constant
+ pos := round((time * 1000) / FusPerTick);
+ for i := 0 to tracks.count - 1 do
+ begin
+ TMidiTrack(tracks.items[i]).Rewind(0);
+ TMidiTrack(tracks.items[i]).GoUntil(pos);
+ end;
+end;
+
+procedure TMidifile.SetBpm(val: integer);
+var
+ us_per_quarter: integer;
+begin
+ if not (val = FBpm) then
+ begin
+ us_per_quarter := 60000000 div val;
+
+ FBpm := 60000000 div us_per_quarter;
+ FusPerTick := us_per_quarter / deltaTicks;
+ end;
+end;
+
+procedure TMidifile.ReadChunkHeader;
+var
+ theByte: array[0..7] of byte;
+begin
+ BlockRead(midiFile, theByte, 8);
+ if (theByte[0] = $4D) and (theByte[1] = $54) then
+ begin
+ if (theByte[2] = $68) and (theByte[3] = $64) then
+ chunkType := header
+ else if (theByte[2] = $72) and (theByte[3] = $6B) then
+ chunkType := track
+ else
+ chunkType := illegal;
+ end
+ else
+ begin
+ chunkType := illegal;
+ end;
+ chunkLength := theByte[7] + theByte[6] * $100 + theByte[5] * $10000 + theByte[4] * $1000000;
+end;
+
+procedure TMidifile.ReadChunkContent;
+begin
+ if not (chunkData = nil) then
+ FreeMem(chunkData);
+ GetMem(chunkData, chunkLength + 10);
+ BlockRead(midiFile, chunkData^, chunkLength);
+ chunkIndex := chunkData;
+ chunkEnd := PByte(integer(chunkIndex) + integer(chunkLength) - 1);
+end;
+
+procedure TMidifile.ReadChunk;
+begin
+ ReadChunkHeader;
+ ReadChunkContent;
+ case chunkType of
+ header:
+ ProcessHeaderChunk;
+ track:
+ ProcessTrackCHunk;
+ end;
+end;
+
+procedure TMidifile.ProcessHeaderChunk;
+begin
+ chunkIndex := chunkData;
+ inc(chunkIndex);
+ if chunkType = header then
+ begin
+ case chunkIndex^ of
+ 0: FfileFormat := single;
+ 1: FfileFormat := multi_synch;
+ 2: FfileFormat := multi_asynch;
+ end;
+ inc(chunkIndex);
+ numberTracks := chunkIndex^ * $100;
+ inc(chunkIndex);
+ numberTracks := numberTracks + chunkIndex^;
+ inc(chunkIndex);
+ deltaTicks := chunkIndex^ * $100;
+ inc(chunkIndex);
+ deltaTicks := deltaTicks + chunkIndex^;
+ end;
+end;
+
+procedure TMidifile.ProcessTrackChunk;
+var
+ dTime: integer;
+ event: integer;
+ len: integer;
+ str: string;
+ midiEvent: PMidiEvent;
+ i: integer;
+ us_per_quarter: integer;
+begin
+ chunkIndex := chunkData;
+// inc(chunkIndex);
+ event := 0;
+ if chunkType = track then
+ begin
+ currentTrack := TMidiTrack.Create;
+ currentTrack.OnMidiEvent := FOnMidiEvent;
+ Tracks.add(currentTrack);
+ while integer(chunkIndex) < integer(chunkEnd) do
+ begin
+ // each event starts with var length delta time
+ dTime := ReadVarLength;
+ if chunkIndex^ >= $80 then
+ begin
+ event := chunkIndex^;
+ inc(chunkIndex);
+ end;
+ // else it is a running status event (just the same event as before)
+
+ if event = $FF then
+ begin
+{ case chunkIndex^ of
+ $00: // sequence number, not implemented jet
+ begin
+ inc(chunkIndex); // $02
+ inc(chunkIndex);
+ end;
+ $01 .. $0f: // text events FF ty len text
+ begin
+ New(midiEvent);
+ midiEvent.event := $FF;
+ midiEvent.data1 := chunkIndex^; // type is stored in data1
+ midiEvent.dticks := dtime;
+
+ inc(chunkIndex);
+ len := ReadVarLength;
+ midiEvent.str := ReadString(len);
+
+ currentTrack.putEvent(midiEvent);
+ end;
+ $20: // Midi channel prefix FF 20 01 cc
+ begin
+ inc(chunkIndex); // $01
+ inc(chunkIndex); // channel
+ inc(chunkIndex);
+ end;
+ $2F: // End of track FF 2F 00
+ begin
+ inc(chunkIndex); // $00
+ inc(chunkIndex);
+ end;
+ $51: // Set Tempo FF 51 03 tttttt
+ begin
+ inc(chunkIndex); // $03
+ inc(chunkIndex); // tt
+ inc(chunkIndex); // tt
+ inc(chunkIndex); // tt
+ inc(chunkIndex);
+ end;
+ $54: // SMPTE offset FF 54 05 hr mn se fr ff
+ begin
+ inc(chunkIndex); // $05
+ inc(chunkIndex); // hr
+ inc(chunkIndex); // mn
+ inc(chunkIndex); // se
+ inc(chunkIndex); // fr
+ inc(chunkIndex); // ff
+ inc(chunkIndex);
+ end;
+ $58: // Time signature FF 58 04 nn dd cc bb
+ begin
+ inc(chunkIndex); // $04
+ inc(chunkIndex); // nn
+ inc(chunkIndex); // dd
+ inc(chunkIndex); // cc
+ inc(chunkIndex); // bb
+ inc(chunkIndex);
+ end;
+ $59: // Key signature FF 59 02 df mi
+ begin
+ inc(chunkIndex); // $02
+ inc(chunkIndex); // df
+ inc(chunkIndex); // mi
+ inc(chunkIndex);
+ end;
+ $7F: // Sequence specific Meta-event
+ begin
+ inc(chunkIndex);
+ len := ReadVarLength;
+ str := ReadString(len);
+ end;
+ else // unknown meta event
+ }
+ begin
+ New(midiEvent);
+ midiEvent.event := $FF;
+ midiEvent.data1 := chunkIndex^; // type is stored in data1
+ midiEvent.dticks := dtime;
+
+ inc(chunkIndex);
+ len := ReadVarLength;
+ midiEvent.str := ReadString(len);
+ currentTrack.putEvent(midiEvent);
+
+ case midiEvent.data1 of
+ $51:
+ begin
+ us_per_quarter :=
+ (integer(byte(midiEvent.str[1])) shl 16 +
+ integer(byte(midiEvent.str[2])) shl 8 +
+ integer(byte(midiEvent.str[3])));
+ FBpm := 60000000 div us_per_quarter;
+ FusPerTick := us_per_quarter / deltaTicks;
+ end;
+ end;
+ end;
+// end;
+ end
+ else
+ begin
+ // these are all midi events
+ New(midiEvent);
+ midiEvent.event := event;
+ midiEvent.dticks := dtime;
+// inc(chunkIndex);
+ case event of
+ $80..$8F, // note off
+ $90..$9F, // note on
+ $A0..$AF, // key aftertouch
+ $B0..$BF, // control change
+ $E0..$EF: // pitch wheel change
+ begin
+ midiEvent.data1 := chunkIndex^; inc(chunkIndex);
+ midiEvent.data2 := chunkIndex^; inc(chunkIndex);
+ end;
+ $C0..$CF, // program change
+ $D0..$DF: // channel aftertouch
+ begin
+ midiEvent.data1 := chunkIndex^; inc(chunkIndex);
+ end;
+ else
+ // error
+ end;
+ currentTrack.putEvent(midiEvent);
+ end;
+ end;
+ end;
+end;
+
+
+function TMidifile.ReadVarLength: integer;
+var
+ i: integer;
+ b: byte;
+begin
+ b := 128;
+ i := 0;
+ while b > 127 do
+ begin
+ i := i shl 7;
+ b := chunkIndex^;
+ i := i + b and $7F;
+ inc(chunkIndex);
+ end;
+ result := i;
+end;
+
+function TMidifile.ReadString(l: integer): string;
+var
+ s: PChar;
+ i: integer;
+begin
+ GetMem(s, l + 1); ;
+ s[l] := chr(0);
+ for i := 0 to l - 1 do
+ begin
+ s[i] := Chr(chunkIndex^);
+ inc(chunkIndex);
+ end;
+ result := string(s);
+end;
+
+procedure TMidifile.ReadFile;
+var
+ i: integer;
+begin
+ for i := 0 to Tracks.Count - 1 do
+ TMidiTrack(Tracks.Items[i]).Free;
+ Tracks.Clear;
+ chunkType := illegal;
+
+ AssignFile(midiFile, FFilename);
+ FileMode := 0;
+ Reset(midiFile);
+ while not eof(midiFile) do
+ ReadChunk;
+ CloseFile(midiFile);
+ numberTracks := Tracks.Count;
+end;
+
+function KeyToStr(key: integer): string;
+var
+ n: integer;
+ str: string;
+begin
+ n := key mod 12;
+ case n of
+ 0: str := 'C';
+ 1: str := 'C#';
+ 2: str := 'D';
+ 3: str := 'D#';
+ 4: str := 'E';
+ 5: str := 'F';
+ 6: str := 'F#';
+ 7: str := 'G';
+ 8: str := 'G#';
+ 9: str := 'A';
+ 10: str := 'A#';
+ 11: str := 'B';
+ end;
+ Result := str + IntToStr(key div 12);
+end;
+
+function IntToLenStr(val: integer; len: integer): string;
+var
+ str: string;
+begin
+ str := IntToStr(val);
+ while Length(str) < len do
+ str := '0' + str;
+ Result := str;
+end;
+
+function MyTimeToStr(val: integer): string;
+ var
+ hour: integer;
+ min: integer;
+ sec: integer;
+ msec: integer;
+begin
+ msec := val mod 1000;
+ sec := val div 1000;
+ min := sec div 60;
+ sec := sec mod 60;
+ hour := min div 60;
+ min := min mod 60;
+ Result := IntToStr(hour) + ':' + IntToLenStr(min, 2) + ':' + IntToLenStr(sec, 2) + '.' + IntToLenStr(msec, 3);
+end;
+
+function TMidiFIle.GetFusPerTick : Double;
+begin
+ Result := FusPerTick;
+end;
+
+function TMidiFIle.GetTrackLength:integer;
+var i,length : integer;
+ time : extended;
+begin
+ length := 0;
+ for i := 0 to Tracks.Count - 1 do
+ if TMidiTrack(Tracks.Items[i]).getTrackLength > length then
+ length := TMidiTrack(Tracks.Items[i]).getTrackLength;
+ time := length * FusPerTick;
+ time := time / 1000.0;
+ result := round(time);
+end;
+
+function TMidiFIle.Ready: boolean;
+var i : integer;
+begin
+ result := true;
+ for i := 0 to Tracks.Count - 1 do
+ if not TMidiTrack(Tracks.Items[i]).isready then
+ result := false;
+end;
+
+procedure TMidiFile.OnTrackReady;
+begin
+ if ready then
+ if assigned(FOnUpdateEvent) then FOnUpdateEvent(self);
+end;
+
+procedure TMidiFile.WndProc(var Msg : TMessage);
+begin
+ with MSG do
+ begin
+ case Msg of
+ WM_MULTIMEDIA_TIMER:
+ begin
+ //try
+ MidiTimer(self);
+ //except
+ // Note: HandleException() is called by default if exception is not handled
+ // Application.HandleException(Self);
+ //end;
+ end;
+ else
+ begin
+ Result := DefWindowProc(MIDIFileHandle, Msg, wParam, lParam);
+ end;
+ end;
+ end;
+end;
+
+procedure Register;
+begin
+ RegisterComponents('Synth', [TMidiFile]);
+end;
+
+end.
+
diff --git a/Game/Code/lib/midi/MidiScope.pas b/Game/Code/lib/midi/MidiScope.pas
index 43efc4e8..42fc65fc 100644
--- a/Game/Code/lib/midi/MidiScope.pas
+++ b/Game/Code/lib/midi/MidiScope.pas
@@ -1,198 +1,198 @@
-{
- Shows a large black area where midi note/controller events are shown
- just to monitor midi activity (for the MidiPlayer)
-
- version 1.0 first release
-
- for comments/bugs
- F.Bouwmans
- fbouwmans@spiditel.nl
-
- if you think this component is nice and you use it, sent me a short email.
- I've seen that other of my components have been downloaded a lot, but I've
- got no clue wether they are actually used.
- Don't worry because you are free to use these components
-}
-
-unit MidiScope;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
- {$H+} // use AnsiString
-{$ENDIF}
-
-uses
- Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
-
-type
- TMidiScope = class(TGraphicControl)
- private
- { Private declarations }
- protected
- { Protected declarations }
- notes : array[0..15,0..127] of integer;
- controllers : array[0..15,0..17] of integer;
- aftertouch : array[0..15,0..127] of integer;
-
- selectedChannel : integer;
-
- procedure PaintSlide(ch,pos,val: integer);
-
- procedure NoteOn(channel, note, speed : integer);
- procedure Controller(channel,number,value : integer);
- procedure AfterTch(channel, note, value : integer);
-
- public
- { Public declarations }
- constructor Create(AOwner: TComponent); override;
- procedure MidiEvent(event,data1,data2 : integer);
- procedure Paint; override;
- published
- { Published declarations }
- end;
-
-
-procedure Register;
-
-const
- BarHeight = 16;
- BarHeightInc = BarHeight+2;
- BarWidth = 3;
- BarWidthInc = BarWidth+1;
- HeightDiv = 128 div BarHeight;
-
-implementation
-
-uses Midicons;
-
-procedure Register;
-begin
- RegisterComponents('Synth', [TMidiScope]);
-end;
-
-constructor TMidiScope.Create(AOwner: TComponent);
-var
- i,j : integer;
-begin
- inherited Create(AOwner);
- Height := BarHeightinc * 16 + 4;
- Width := 147*BarWidthInc + 4 + 20; // for channel number
- for i := 0 to 15 do
- begin
- for j := 0 to 127 do
- begin
- notes[i,j] := 0;
- aftertouch[i,j] := 0;
- end;
- end;
- for i := 0 to 17 do
- begin
- for j := 0 to 15 do
- controllers[i,j] := 0;
- end;
-end;
-
-procedure TMidiScope.PaintSlide(ch,pos,val: integer);
-var x,y:integer;
-begin
- Canvas.Brush.Color := clBlack;
- Canvas.Pen.color := clBlack;
- x := pos * BarWidthInc + 2;
- y := 2 + ch * BarHeightInc;
- Canvas.Rectangle(x, y, x+BarWidthInc, y+BarHeightInc);
- Canvas.Brush.Color := clGreen;
- Canvas.Pen.Color := clGreen;
- Canvas.Rectangle(x, y + (BarHeight - (val div HeightDiv )), x + BarWidth, y + BarHeight)
-end;
-
-procedure TMidiScope.Paint;
-var i,j : integer;
-x : integer;
-begin
- Canvas.Brush.color := clBlack;
- Canvas.Rectangle(0,0,Width,Height);
- Canvas.Pen.Color := clGreen;
- x := 128*BarWidthInc+2;
- Canvas.MoveTo(x,0);
- Canvas.LineTo(x,Height);
- x := 148*BarWIdthInc+2;
- canvas.Font.Color := clGreen;
- for i := 0 to 15 do
- Canvas.TextOut(x,((i+1)*BarHeightInc) - Canvas.font.size-3,IntToStr(i+1));
- canvas.Pen.color := clBlack;
- begin
- for j := 0 to 127 do
- begin
- PaintSlide(i,j,notes[i,j]);
- end;
- for j := 0 to 17 do
- begin
- PaintSlide(i,j+129,controllers[i,j]);
- end;
- end;
-end;
-procedure TMidiScope.NoteOn(channel, note, speed : integer);
-begin
- notes[channel,note] := speed;
- PaintSlide(channel,note,notes[channel,note]);
-end;
-procedure TMidiScope.AfterTch(channel, note, value : integer);
-begin
- aftertouch[channel,note] := value;
-end;
-
-procedure TMidiScope.Controller(channel,number,value : integer);
-var i : integer;
-begin
- if number < 18 then
- begin
- controllers[channel,number] := value;
- PaintSlide(channel,number+129,value);
- end
- else if number >= $7B then
- begin
- // all notes of for channel
- for i := 0 to 127 do
- begin
- if notes[channel,i] > 0 then
- begin
- notes[channel,i] := 0;
- PaintSlide(channel,i,0);
- end;
- end;
- end;
-end;
-
-procedure TMidiScope.MidiEvent(event,data1,data2 : integer);
-begin
- case (event AND $F0) of
- MIDI_NOTEON :
- begin
- NoteOn((event AND $F),data1,data2);
- end;
- MIDI_NOTEOFF:
- begin
- NoteOn((event AND $F),data1,0);
- end;
- MIDI_CONTROLCHANGE :
- begin
- Controller((event AND $F),data1,data2);
- end;
- MIDI_CHANAFTERTOUCH:
- begin
- Controller((Event AND $F),16,Data1);
- end;
- MIDI_PITCHBEND:
- begin
- begin
- Controller((Event AND $F),17,data2);
- end;
- end;
- MIDI_KEYAFTERTOUCH:
- begin
- end;
- end;
-end;
-end.
+{
+ Shows a large black area where midi note/controller events are shown
+ just to monitor midi activity (for the MidiPlayer)
+
+ version 1.0 first release
+
+ for comments/bugs
+ F.Bouwmans
+ fbouwmans@spiditel.nl
+
+ if you think this component is nice and you use it, sent me a short email.
+ I've seen that other of my components have been downloaded a lot, but I've
+ got no clue wether they are actually used.
+ Don't worry because you are free to use these components
+}
+
+unit MidiScope;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+ {$H+} // use AnsiString
+{$ENDIF}
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
+
+type
+ TMidiScope = class(TGraphicControl)
+ private
+ { Private declarations }
+ protected
+ { Protected declarations }
+ notes : array[0..15,0..127] of integer;
+ controllers : array[0..15,0..17] of integer;
+ aftertouch : array[0..15,0..127] of integer;
+
+ selectedChannel : integer;
+
+ procedure PaintSlide(ch,pos,val: integer);
+
+ procedure NoteOn(channel, note, speed : integer);
+ procedure Controller(channel,number,value : integer);
+ procedure AfterTch(channel, note, value : integer);
+
+ public
+ { Public declarations }
+ constructor Create(AOwner: TComponent); override;
+ procedure MidiEvent(event,data1,data2 : integer);
+ procedure Paint; override;
+ published
+ { Published declarations }
+ end;
+
+
+procedure Register;
+
+const
+ BarHeight = 16;
+ BarHeightInc = BarHeight+2;
+ BarWidth = 3;
+ BarWidthInc = BarWidth+1;
+ HeightDiv = 128 div BarHeight;
+
+implementation
+
+uses Midicons;
+
+procedure Register;
+begin
+ RegisterComponents('Synth', [TMidiScope]);
+end;
+
+constructor TMidiScope.Create(AOwner: TComponent);
+var
+ i,j : integer;
+begin
+ inherited Create(AOwner);
+ Height := BarHeightinc * 16 + 4;
+ Width := 147*BarWidthInc + 4 + 20; // for channel number
+ for i := 0 to 15 do
+ begin
+ for j := 0 to 127 do
+ begin
+ notes[i,j] := 0;
+ aftertouch[i,j] := 0;
+ end;
+ end;
+ for i := 0 to 17 do
+ begin
+ for j := 0 to 15 do
+ controllers[i,j] := 0;
+ end;
+end;
+
+procedure TMidiScope.PaintSlide(ch,pos,val: integer);
+var x,y:integer;
+begin
+ Canvas.Brush.Color := clBlack;
+ Canvas.Pen.color := clBlack;
+ x := pos * BarWidthInc + 2;
+ y := 2 + ch * BarHeightInc;
+ Canvas.Rectangle(x, y, x+BarWidthInc, y+BarHeightInc);
+ Canvas.Brush.Color := clGreen;
+ Canvas.Pen.Color := clGreen;
+ Canvas.Rectangle(x, y + (BarHeight - (val div HeightDiv )), x + BarWidth, y + BarHeight)
+end;
+
+procedure TMidiScope.Paint;
+var i,j : integer;
+x : integer;
+begin
+ Canvas.Brush.color := clBlack;
+ Canvas.Rectangle(0,0,Width,Height);
+ Canvas.Pen.Color := clGreen;
+ x := 128*BarWidthInc+2;
+ Canvas.MoveTo(x,0);
+ Canvas.LineTo(x,Height);
+ x := 148*BarWIdthInc+2;
+ canvas.Font.Color := clGreen;
+ for i := 0 to 15 do
+ Canvas.TextOut(x,((i+1)*BarHeightInc) - Canvas.font.size-3,IntToStr(i+1));
+ canvas.Pen.color := clBlack;
+ begin
+ for j := 0 to 127 do
+ begin
+ PaintSlide(i,j,notes[i,j]);
+ end;
+ for j := 0 to 17 do
+ begin
+ PaintSlide(i,j+129,controllers[i,j]);
+ end;
+ end;
+end;
+procedure TMidiScope.NoteOn(channel, note, speed : integer);
+begin
+ notes[channel,note] := speed;
+ PaintSlide(channel,note,notes[channel,note]);
+end;
+procedure TMidiScope.AfterTch(channel, note, value : integer);
+begin
+ aftertouch[channel,note] := value;
+end;
+
+procedure TMidiScope.Controller(channel,number,value : integer);
+var i : integer;
+begin
+ if number < 18 then
+ begin
+ controllers[channel,number] := value;
+ PaintSlide(channel,number+129,value);
+ end
+ else if number >= $7B then
+ begin
+ // all notes of for channel
+ for i := 0 to 127 do
+ begin
+ if notes[channel,i] > 0 then
+ begin
+ notes[channel,i] := 0;
+ PaintSlide(channel,i,0);
+ end;
+ end;
+ end;
+end;
+
+procedure TMidiScope.MidiEvent(event,data1,data2 : integer);
+begin
+ case (event AND $F0) of
+ MIDI_NOTEON :
+ begin
+ NoteOn((event AND $F),data1,data2);
+ end;
+ MIDI_NOTEOFF:
+ begin
+ NoteOn((event AND $F),data1,0);
+ end;
+ MIDI_CONTROLCHANGE :
+ begin
+ Controller((event AND $F),data1,data2);
+ end;
+ MIDI_CHANAFTERTOUCH:
+ begin
+ Controller((Event AND $F),16,Data1);
+ end;
+ MIDI_PITCHBEND:
+ begin
+ begin
+ Controller((Event AND $F),17,data2);
+ end;
+ end;
+ MIDI_KEYAFTERTOUCH:
+ begin
+ end;
+ end;
+end;
+end.
diff --git a/Game/Code/lib/midi/Midicons.pas b/Game/Code/lib/midi/Midicons.pas
index 45bae463..35dbb5f3 100644
--- a/Game/Code/lib/midi/Midicons.pas
+++ b/Game/Code/lib/midi/Midicons.pas
@@ -1,47 +1,47 @@
-{ $Header: /MidiComp/MIDICONS.PAS 2 10/06/97 7:33 Davec $ }
-
-{ Written by David Churcher <dchurcher@cix.compulink.co.uk>,
- released to the public domain. }
-
-
-{ MIDI Constants }
-unit Midicons;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
- {$H+} // use AnsiString
-{$ENDIF}
-
-uses Messages;
-
-const
- MIDI_ALLNOTESOFF = $7B;
- MIDI_NOTEON = $90;
- MIDI_NOTEOFF = $80;
- MIDI_KEYAFTERTOUCH = $a0;
- MIDI_CONTROLCHANGE = $b0;
- MIDI_PROGRAMCHANGE = $c0;
- MIDI_CHANAFTERTOUCH = $d0;
- MIDI_PITCHBEND = $e0;
- MIDI_SYSTEMMESSAGE = $f0;
- MIDI_BEGINSYSEX = $f0;
- MIDI_MTCQUARTERFRAME = $f1;
- MIDI_SONGPOSPTR = $f2;
- MIDI_SONGSELECT = $f3;
- MIDI_ENDSYSEX = $F7;
- MIDI_TIMINGCLOCK = $F8;
- MIDI_START = $FA;
- MIDI_CONTINUE = $FB;
- MIDI_STOP = $FC;
- MIDI_ACTIVESENSING = $FE;
- MIDI_SYSTEMRESET = $FF;
-
- MIM_OVERFLOW = WM_USER; { Input buffer overflow }
- MOM_PLAYBACK_DONE = WM_USER+1; { Timed playback complete }
-
-
-implementation
-
-end.
+{ $Header: /MidiComp/MIDICONS.PAS 2 10/06/97 7:33 Davec $ }
+
+{ Written by David Churcher <dchurcher@cix.compulink.co.uk>,
+ released to the public domain. }
+
+
+{ MIDI Constants }
+unit Midicons;
+
+interface
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+ {$H+} // use AnsiString
+{$ENDIF}
+
+uses Messages;
+
+const
+ MIDI_ALLNOTESOFF = $7B;
+ MIDI_NOTEON = $90;
+ MIDI_NOTEOFF = $80;
+ MIDI_KEYAFTERTOUCH = $a0;
+ MIDI_CONTROLCHANGE = $b0;
+ MIDI_PROGRAMCHANGE = $c0;
+ MIDI_CHANAFTERTOUCH = $d0;
+ MIDI_PITCHBEND = $e0;
+ MIDI_SYSTEMMESSAGE = $f0;
+ MIDI_BEGINSYSEX = $f0;
+ MIDI_MTCQUARTERFRAME = $f1;
+ MIDI_SONGPOSPTR = $f2;
+ MIDI_SONGSELECT = $f3;
+ MIDI_ENDSYSEX = $F7;
+ MIDI_TIMINGCLOCK = $F8;
+ MIDI_START = $FA;
+ MIDI_CONTINUE = $FB;
+ MIDI_STOP = $FC;
+ MIDI_ACTIVESENSING = $FE;
+ MIDI_SYSTEMRESET = $FF;
+
+ MIM_OVERFLOW = WM_USER; { Input buffer overflow }
+ MOM_PLAYBACK_DONE = WM_USER+1; { Timed playback complete }
+
+
+implementation
+
+end.
diff --git a/Game/Code/lib/midi/Midiin.pas b/Game/Code/lib/midi/Midiin.pas
index a122bcb0..3688d5c9 100644
--- a/Game/Code/lib/midi/Midiin.pas
+++ b/Game/Code/lib/midi/Midiin.pas
@@ -1,725 +1,725 @@
-{ $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 AnsiString
-{$ENDIF}
-
-uses
- Classes,
- SysUtils,
- Messages,
- Windows,
- MMSystem,
- UCommon,
- 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 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.
-
+{ $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 AnsiString
+{$ENDIF}
+
+uses
+ Classes,
+ SysUtils,
+ Messages,
+ Windows,
+ MMSystem,
+ UCommon,
+ 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 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.
+
diff --git a/Game/Code/lib/midi/Midiout.pas b/Game/Code/lib/midi/Midiout.pas
index 81b00e9f..2463ae8a 100644
--- a/Game/Code/lib/midi/Midiout.pas
+++ b/Game/Code/lib/midi/Midiout.pas
@@ -1,617 +1,617 @@
-{ $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
-
-{$IFDEF FPC}
- {$MODE Delphi}
- {$H+} // use AnsiString
-{$ENDIF}
-
-uses
- SysUtils,
- Windows,
- Messages,
- Classes,
- MMSystem,
- UCommon,
- Circbuf,
- MidiType,
- MidiDefs,
- Delphmcb;
-
-{$IFDEF FPC}
-type TmidioutCaps = MIDIOUTCAPS;
-{$ENDIF}
-
-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: Cardinal; { 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: MMVERSION; { 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: Cardinal);
- procedure SetProductName(NewProductName: string);
- procedure SetTechnology(NewTechnology: OutPortTech);
- function midioutErrorString(WError: Word): string;
-
- public
- { Properties }
- property MIDIHandle: Hmidiout read FMIDIHandle;
- property DriverVersion: MMVERSION { 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: Cardinal 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: Cardinal);
-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.
-
+{ $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
+
+{$IFDEF FPC}
+ {$MODE Delphi}
+ {$H+} // use AnsiString
+{$ENDIF}
+
+uses
+ SysUtils,
+ Windows,
+ Messages,
+ Classes,
+ MMSystem,
+ UCommon,
+ Circbuf,
+ MidiType,
+ MidiDefs,
+ Delphmcb;
+
+{$IFDEF FPC}
+type TmidioutCaps = MIDIOUTCAPS;
+{$ENDIF}
+
+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: Cardinal; { 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: MMVERSION; { 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: Cardinal);
+ procedure SetProductName(NewProductName: string);
+ procedure SetTechnology(NewTechnology: OutPortTech);
+ function midioutErrorString(WError: Word): string;
+
+ public
+ { Properties }
+ property MIDIHandle: Hmidiout read FMIDIHandle;
+ property DriverVersion: MMVERSION { 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: Cardinal 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: Cardinal);
+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.
+
diff --git a/Game/Code/lib/midi/demo/MidiTest.pas b/Game/Code/lib/midi/demo/MidiTest.pas
index 0cf3e302..793db730 100644
--- a/Game/Code/lib/midi/demo/MidiTest.pas
+++ b/Game/Code/lib/midi/demo/MidiTest.pas
@@ -1,249 +1,249 @@
-// Test application for TMidiFile
-
-unit MidiTest;
-
-interface
-
-uses
- Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
- StdCtrls, MidiFile, ExtCtrls, MidiOut, MidiType, MidiScope, Grids;
-type
- TMidiPlayer = class(TForm)
- OpenDialog1: TOpenDialog;
- Button1: TButton;
- Button3: TButton;
- Button4: TButton;
- MidiOutput1: TMidiOutput;
- cmbInput: TComboBox;
- MidiFile1: TMidiFile;
- MidiScope1: TMidiScope;
- Label3: TLabel;
- edtBpm: TEdit;
- Memo2: TMemo;
- edtTime: TEdit;
- Button2: TButton;
- TrackGrid: TStringGrid;
- TracksGrid: TStringGrid;
- edtLength: TEdit;
- procedure Button1Click(Sender: TObject);
- procedure MidiFile1MidiEvent(event: PMidiEvent);
- procedure Button3Click(Sender: TObject);
- procedure Button4Click(Sender: TObject);
- procedure FormCreate(Sender: TObject);
- procedure cmbInputChange(Sender: TObject);
- procedure MidiFile1UpdateEvent(Sender: TObject);
- procedure Button2Click(Sender: TObject);
- procedure edtBpmKeyPress(Sender: TObject; var Key: Char);
- procedure TracksGridSelectCell(Sender: TObject; Col, Row: Integer;
- var CanSelect: Boolean);
- procedure FormShow(Sender: TObject);
- private
- { Private declarations }
- MidiOpened : boolean;
- procedure SentAllNotesOff;
-
- procedure MidiOpen;
- procedure MidiClose;
-
- public
- { Public declarations }
- end;
-
-var
- MidiPlayer: TMidiPlayer;
-
-implementation
-
-{$R *.DFM}
-
-procedure TMidiPlayer.Button1Click(Sender: TObject);
-var
- i,j: integer;
- track : TMidiTrack;
- event : PMidiEvent;
-begin
- if opendialog1.execute then
- begin
- midifile1.filename := opendialog1.filename;
- midifile1.readfile;
-// label1.caption := IntToStr(midifile1.NumberOfTracks);
- edtBpm.text := IntToStr(midifile1.Bpm);
-// TracksGrid.cells.clear;
- for i := 0 to midifile1.NumberOfTracks-1 do
- begin
- track := midifile1.getTrack(i);
- TracksGrid.cells[0,i] := 'Tr: '+ track.getName + ' '+ track.getInstrument ;
- end;
- edtLength.Text := MyTimeToStr(MidiFile1.GetTrackLength);
- end;
-end;
-
-procedure TMidiPlayer.MidiFile1MidiEvent(event: PMidiEvent);
-var mEvent : TMyMidiEvent;
-begin
- mEvent := TMyMidiEvent.Create;
- if not (event.event = $FF) then
- begin
- mEvent.MidiMessage := event.event;
- mEvent.data1 := event.data1;
- mEvent.data2 := event.data2;
- midioutput1.PutMidiEvent(mEvent);
- end
- else
- begin
- if (event.data1 >= 1) and (event.data1 < 15) then
- begin
- memo2.Lines.add(IntToStr(event.data1) + ' '+ event.str);
- end
- end;
- midiScope1.MidiEvent(event.event,event.data1,event.data2);
- mEvent.Destroy;
-end;
-
-procedure TMidiPlayer.SentAllNotesOff;
-var mEvent : TMyMidiEvent;
-channel : integer;
-begin
- mEvent := TMyMidiEvent.Create;
- for channel:= 0 to 15 do
- begin
- mEvent.MidiMessage := $B0 + channel;
- mEvent.data1 := $78;
- mEvent.data2 := 0;
- if MidiOpened then
- midioutput1.PutMidiEvent(mEvent);
- midiScope1.MidiEvent(mEvent.MidiMessage,mEvent.data1,mEvent.data2);
- end;
- mEvent.Destroy;
-end;
-
-procedure TMidiPlayer.Button3Click(Sender: TObject);
-begin
- midifile1.StartPlaying;
-end;
-
-procedure TMidiPlayer.Button4Click(Sender: TObject);
-begin
- midifile1.StopPlaying;
- SentAllNotesOff;
-end;
-
-procedure TMidiPlayer.MidiOpen;
-begin
- if not (cmbInput.Text = '') then
- begin
- MidiOutput1.ProductName := cmbInput.Text;
- MidiOutput1.OPEN;
- MidiOpened := true;
- end;
-end;
-
-procedure TMidiPlayer.MidiClose;
-begin
- if MidiOpened then
- begin
- MidiOutput1.Close;
- MidiOpened := false;
- end;
-end;
-
-
-procedure TMidiPlayer.FormCreate(Sender: TObject);
-var thisDevice : integer;
-begin
- for thisDevice := 0 to MidiOutput1.NumDevs - 1 do
- begin
- MidiOutput1.DeviceID := thisDevice;
- cmbInput.Items.Add(MidiOutput1.ProductName);
- end;
- cmbInput.ItemIndex := 0;
- MidiOpened := false;
- MidiOpen;
-end;
-
-procedure TMidiPlayer.cmbInputChange(Sender: TObject);
-begin
- MidiClose;
- MidiOPen;
-end;
-
-procedure TMidiPlayer.MidiFile1UpdateEvent(Sender: TObject);
-begin
- edtTime.Text := MyTimeToStr(MidiFile1.GetCurrentTime);
- edtTime.update;
- if MidiFile1.ready then
- begin
- midifile1.StopPlaying;
- SentAllNotesOff;
- end;
-end;
-
-procedure TMidiPlayer.Button2Click(Sender: TObject);
-begin
- MidiFile1.ContinuePlaying;
-end;
-
-procedure TMidiPlayer.edtBpmKeyPress(Sender: TObject; var Key: Char);
-begin
- if Key = char(13) then
- begin
- MidiFile1.Bpm := StrToInt(edtBpm.Text);
- edtBpm.text := IntToStr(midifile1.Bpm);
- abort;
- end;
-
-end;
-
-procedure TMidiPlayer.TracksGridSelectCell(Sender: TObject; Col,
- Row: Integer; var CanSelect: Boolean);
-var
- MidiTrack : TMidiTrack;
- i : integer;
- j : integer;
- event : PMidiEvent;
-begin
- CanSelect := false;
- if Row < MidiFile1.NumberOfTracks then
- begin
- CanSelect := true;
- MidiTrack := MidiFile1.GetTrack(Row);
- TrackGrid.RowCount := 2;
- TrackGrid.RowCount := MidiTrack.getEventCount;
- j := 1;
- for i := 0 to MidiTrack.GetEventCount-1 do
- begin
- event := MidiTrack.getEvent(i);
- if not (event.len = -1) then
- begin // do not print when
- TrackGrid.cells[0,j] := IntToStr(i);
- TrackGrid.cells[1,j] := MyTimeToStr(event.time);
- TrackGrid.cells[2,j] := IntToHex(event.event,2);
- if not (event.event = $FF) then
- begin
- TrackGrid.cells[3,j] := IntToStr(event.len);
- TrackGrid.cells[4,j] := KeyToStr(event.data1);
- TrackGrid.cells[5,j] := IntToStr(event.data2);
- end
- else
- begin
- TrackGrid.cells[3,j] := IntToStr(event.data1);
- TrackGrid.cells[4,j] := '';
- TrackGrid.cells[5,j] := event.str;
- end;
- inc(j);
- end;
- end;
- TrackGrid.RowCount := j;
- end;
-end;
-
-procedure TMidiPlayer.FormShow(Sender: TObject);
-begin
- TrackGrid.ColWidths[0] := 30;
- TrackGrid.ColWidths[2] := 30;
- TrackGrid.ColWidths[3] := 30;
- TrackGrid.ColWidths[4] := 30;
- TrackGrid.ColWidths[5] := 100;
-end;
-
-end.
+// Test application for TMidiFile
+
+unit MidiTest;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ StdCtrls, MidiFile, ExtCtrls, MidiOut, MidiType, MidiScope, Grids;
+type
+ TMidiPlayer = class(TForm)
+ OpenDialog1: TOpenDialog;
+ Button1: TButton;
+ Button3: TButton;
+ Button4: TButton;
+ MidiOutput1: TMidiOutput;
+ cmbInput: TComboBox;
+ MidiFile1: TMidiFile;
+ MidiScope1: TMidiScope;
+ Label3: TLabel;
+ edtBpm: TEdit;
+ Memo2: TMemo;
+ edtTime: TEdit;
+ Button2: TButton;
+ TrackGrid: TStringGrid;
+ TracksGrid: TStringGrid;
+ edtLength: TEdit;
+ procedure Button1Click(Sender: TObject);
+ procedure MidiFile1MidiEvent(event: PMidiEvent);
+ procedure Button3Click(Sender: TObject);
+ procedure Button4Click(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure cmbInputChange(Sender: TObject);
+ procedure MidiFile1UpdateEvent(Sender: TObject);
+ procedure Button2Click(Sender: TObject);
+ procedure edtBpmKeyPress(Sender: TObject; var Key: Char);
+ procedure TracksGridSelectCell(Sender: TObject; Col, Row: Integer;
+ var CanSelect: Boolean);
+ procedure FormShow(Sender: TObject);
+ private
+ { Private declarations }
+ MidiOpened : boolean;
+ procedure SentAllNotesOff;
+
+ procedure MidiOpen;
+ procedure MidiClose;
+
+ public
+ { Public declarations }
+ end;
+
+var
+ MidiPlayer: TMidiPlayer;
+
+implementation
+
+{$R *.DFM}
+
+procedure TMidiPlayer.Button1Click(Sender: TObject);
+var
+ i,j: integer;
+ track : TMidiTrack;
+ event : PMidiEvent;
+begin
+ if opendialog1.execute then
+ begin
+ midifile1.filename := opendialog1.filename;
+ midifile1.readfile;
+// label1.caption := IntToStr(midifile1.NumberOfTracks);
+ edtBpm.text := IntToStr(midifile1.Bpm);
+// TracksGrid.cells.clear;
+ for i := 0 to midifile1.NumberOfTracks-1 do
+ begin
+ track := midifile1.getTrack(i);
+ TracksGrid.cells[0,i] := 'Tr: '+ track.getName + ' '+ track.getInstrument ;
+ end;
+ edtLength.Text := MyTimeToStr(MidiFile1.GetTrackLength);
+ end;
+end;
+
+procedure TMidiPlayer.MidiFile1MidiEvent(event: PMidiEvent);
+var mEvent : TMyMidiEvent;
+begin
+ mEvent := TMyMidiEvent.Create;
+ if not (event.event = $FF) then
+ begin
+ mEvent.MidiMessage := event.event;
+ mEvent.data1 := event.data1;
+ mEvent.data2 := event.data2;
+ midioutput1.PutMidiEvent(mEvent);
+ end
+ else
+ begin
+ if (event.data1 >= 1) and (event.data1 < 15) then
+ begin
+ memo2.Lines.add(IntToStr(event.data1) + ' '+ event.str);
+ end
+ end;
+ midiScope1.MidiEvent(event.event,event.data1,event.data2);
+ mEvent.Destroy;
+end;
+
+procedure TMidiPlayer.SentAllNotesOff;
+var mEvent : TMyMidiEvent;
+channel : integer;
+begin
+ mEvent := TMyMidiEvent.Create;
+ for channel:= 0 to 15 do
+ begin
+ mEvent.MidiMessage := $B0 + channel;
+ mEvent.data1 := $78;
+ mEvent.data2 := 0;
+ if MidiOpened then
+ midioutput1.PutMidiEvent(mEvent);
+ midiScope1.MidiEvent(mEvent.MidiMessage,mEvent.data1,mEvent.data2);
+ end;
+ mEvent.Destroy;
+end;
+
+procedure TMidiPlayer.Button3Click(Sender: TObject);
+begin
+ midifile1.StartPlaying;
+end;
+
+procedure TMidiPlayer.Button4Click(Sender: TObject);
+begin
+ midifile1.StopPlaying;
+ SentAllNotesOff;
+end;
+
+procedure TMidiPlayer.MidiOpen;
+begin
+ if not (cmbInput.Text = '') then
+ begin
+ MidiOutput1.ProductName := cmbInput.Text;
+ MidiOutput1.OPEN;
+ MidiOpened := true;
+ end;
+end;
+
+procedure TMidiPlayer.MidiClose;
+begin
+ if MidiOpened then
+ begin
+ MidiOutput1.Close;
+ MidiOpened := false;
+ end;
+end;
+
+
+procedure TMidiPlayer.FormCreate(Sender: TObject);
+var thisDevice : integer;
+begin
+ for thisDevice := 0 to MidiOutput1.NumDevs - 1 do
+ begin
+ MidiOutput1.DeviceID := thisDevice;
+ cmbInput.Items.Add(MidiOutput1.ProductName);
+ end;
+ cmbInput.ItemIndex := 0;
+ MidiOpened := false;
+ MidiOpen;
+end;
+
+procedure TMidiPlayer.cmbInputChange(Sender: TObject);
+begin
+ MidiClose;
+ MidiOPen;
+end;
+
+procedure TMidiPlayer.MidiFile1UpdateEvent(Sender: TObject);
+begin
+ edtTime.Text := MyTimeToStr(MidiFile1.GetCurrentTime);
+ edtTime.update;
+ if MidiFile1.ready then
+ begin
+ midifile1.StopPlaying;
+ SentAllNotesOff;
+ end;
+end;
+
+procedure TMidiPlayer.Button2Click(Sender: TObject);
+begin
+ MidiFile1.ContinuePlaying;
+end;
+
+procedure TMidiPlayer.edtBpmKeyPress(Sender: TObject; var Key: Char);
+begin
+ if Key = char(13) then
+ begin
+ MidiFile1.Bpm := StrToInt(edtBpm.Text);
+ edtBpm.text := IntToStr(midifile1.Bpm);
+ abort;
+ end;
+
+end;
+
+procedure TMidiPlayer.TracksGridSelectCell(Sender: TObject; Col,
+ Row: Integer; var CanSelect: Boolean);
+var
+ MidiTrack : TMidiTrack;
+ i : integer;
+ j : integer;
+ event : PMidiEvent;
+begin
+ CanSelect := false;
+ if Row < MidiFile1.NumberOfTracks then
+ begin
+ CanSelect := true;
+ MidiTrack := MidiFile1.GetTrack(Row);
+ TrackGrid.RowCount := 2;
+ TrackGrid.RowCount := MidiTrack.getEventCount;
+ j := 1;
+ for i := 0 to MidiTrack.GetEventCount-1 do
+ begin
+ event := MidiTrack.getEvent(i);
+ if not (event.len = -1) then
+ begin // do not print when
+ TrackGrid.cells[0,j] := IntToStr(i);
+ TrackGrid.cells[1,j] := MyTimeToStr(event.time);
+ TrackGrid.cells[2,j] := IntToHex(event.event,2);
+ if not (event.event = $FF) then
+ begin
+ TrackGrid.cells[3,j] := IntToStr(event.len);
+ TrackGrid.cells[4,j] := KeyToStr(event.data1);
+ TrackGrid.cells[5,j] := IntToStr(event.data2);
+ end
+ else
+ begin
+ TrackGrid.cells[3,j] := IntToStr(event.data1);
+ TrackGrid.cells[4,j] := '';
+ TrackGrid.cells[5,j] := event.str;
+ end;
+ inc(j);
+ end;
+ end;
+ TrackGrid.RowCount := j;
+ end;
+end;
+
+procedure TMidiPlayer.FormShow(Sender: TObject);
+begin
+ TrackGrid.ColWidths[0] := 30;
+ TrackGrid.ColWidths[2] := 30;
+ TrackGrid.ColWidths[3] := 30;
+ TrackGrid.ColWidths[4] := 30;
+ TrackGrid.ColWidths[5] := 100;
+end;
+
+end.
diff --git a/Game/Code/lib/midi/demo/Project1.dpr b/Game/Code/lib/midi/demo/Project1.dpr
index 4237e983..7aa4e512 100644
--- a/Game/Code/lib/midi/demo/Project1.dpr
+++ b/Game/Code/lib/midi/demo/Project1.dpr
@@ -1,13 +1,13 @@
-program Project1;
-
-uses
- Forms,
- MidiTest in 'MidiTest.pas' {MidiPlayer};
-
-{$R *.RES}
-
-begin
- Application.Initialize;
- Application.CreateForm(TMidiPlayer, MidiPlayer);
- Application.Run;
-end.
+program Project1;
+
+uses
+ Forms,
+ MidiTest in 'MidiTest.pas' {MidiPlayer};
+
+{$R *.RES}
+
+begin
+ Application.Initialize;
+ Application.CreateForm(TMidiPlayer, MidiPlayer);
+ Application.Run;
+end.
diff --git a/Game/Code/lib/midi/midiComp.cfg b/Game/Code/lib/midi/midiComp.cfg
index 2ee4ea3a..8b774c81 100644
--- a/Game/Code/lib/midi/midiComp.cfg
+++ b/Game/Code/lib/midi/midiComp.cfg
@@ -1,35 +1,35 @@
--$A+
--$B-
--$C+
--$D+
--$E-
--$F-
--$G+
--$H+
--$I+
--$J+
--$K-
--$L+
--$M-
--$N+
--$O+
--$P+
--$Q-
--$R-
--$S-
--$T-
--$U-
--$V+
--$W-
--$X+
--$Y-
--$Z1
--cg
--AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
--H+
--W+
--M
--$M16384,1048576
--K$00400000
--LE"d:\program files\borland\delphi5\Projects\Bpl"
--LN"d:\program files\borland\delphi5\Projects\Bpl"
+-$A+
+-$B-
+-$C+
+-$D+
+-$E-
+-$F-
+-$G+
+-$H+
+-$I+
+-$J+
+-$K-
+-$L+
+-$M-
+-$N+
+-$O+
+-$P+
+-$Q-
+-$R-
+-$S-
+-$T-
+-$U-
+-$V+
+-$W-
+-$X+
+-$Y-
+-$Z1
+-cg
+-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
+-H+
+-W+
+-M
+-$M16384,1048576
+-K$00400000
+-LE"d:\program files\borland\delphi5\Projects\Bpl"
+-LN"d:\program files\borland\delphi5\Projects\Bpl"
diff --git a/Game/Code/lib/midi/readme.txt b/Game/Code/lib/midi/readme.txt
index 5e4207f6..7112aecf 100644
--- a/Game/Code/lib/midi/readme.txt
+++ b/Game/Code/lib/midi/readme.txt
@@ -1,60 +1,60 @@
-
-Midi components
- TMidiFile, TMidiScope
- TMidiIn and TMidiOut of david Churcher are included because they are used in
- the demo application
-
-Freeware.
-
-100% source code, demo application.
-
-Included Components/Classes
-
-TMidiFile, read a midifile and have the contents available in memory
- list of Tracks, track is list of events
-
-
-TMidiScope, show all activity on a midi device
-
-TMidiIn and TMidiOut of David Churcher are included because they are used
-in the demo application
-
-Midiplayer is a demo application which plays a midifile on a midi output
- it is build fairly simple with the included components. The timer is used
- to time the midievents. The timing is therefor as good as the windows timer.
-
-
- The header of midifile,midiscope contains help information on the properties/functions
- The example Midiplayer gives a good idea how to use the components
-
-Installation
- open midiComp.dpk with file/open
- compile and install the package
- make sure that the directory where the files are located is in the library path
- (tools/environment options/library)
-
-to run the demo
- open project1.dpr in the demo directory and press run.
-
-
-
-history
-1.0 18-1-1999 first release
-
-1.1 5-3-1999 update
- added some functions for display purposes
- improved demo to include event viewer
- bpm can be changed
-
-1.2 24-2-2000 update
- added some functions to see the length of a song and ready function to know when playback is ready
-
-for comments/bugs in these components:
-
-Frans Bouwmans
-fbouwmans@spiditel.nl
-
-I'm busy building a software music synthesizer, which will be available in source
-to the public. If you are interrested in helping me with certain soundmodules
-(effects, filters, sound generators) just sent me an email.
-
+
+Midi components
+ TMidiFile, TMidiScope
+ TMidiIn and TMidiOut of david Churcher are included because they are used in
+ the demo application
+
+Freeware.
+
+100% source code, demo application.
+
+Included Components/Classes
+
+TMidiFile, read a midifile and have the contents available in memory
+ list of Tracks, track is list of events
+
+
+TMidiScope, show all activity on a midi device
+
+TMidiIn and TMidiOut of David Churcher are included because they are used
+in the demo application
+
+Midiplayer is a demo application which plays a midifile on a midi output
+ it is build fairly simple with the included components. The timer is used
+ to time the midievents. The timing is therefor as good as the windows timer.
+
+
+ The header of midifile,midiscope contains help information on the properties/functions
+ The example Midiplayer gives a good idea how to use the components
+
+Installation
+ open midiComp.dpk with file/open
+ compile and install the package
+ make sure that the directory where the files are located is in the library path
+ (tools/environment options/library)
+
+to run the demo
+ open project1.dpr in the demo directory and press run.
+
+
+
+history
+1.0 18-1-1999 first release
+
+1.1 5-3-1999 update
+ added some functions for display purposes
+ improved demo to include event viewer
+ bpm can be changed
+
+1.2 24-2-2000 update
+ added some functions to see the length of a song and ready function to know when playback is ready
+
+for comments/bugs in these components:
+
+Frans Bouwmans
+fbouwmans@spiditel.nl
+
+I'm busy building a software music synthesizer, which will be available in source
+to the public. If you are interrested in helping me with certain soundmodules
+(effects, filters, sound generators) just sent me an email.
+