From 46bb010ca7c5eb04551c030105f9999ca80e472f Mon Sep 17 00:00:00 2001 From: tobigun Date: Sun, 8 Jun 2008 15:33:48 +0000 Subject: - 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 --- Game/Code/lib/midi/CIRCBUF.PAS | 366 +++---- Game/Code/lib/midi/DELPHMCB.PAS | 276 ++--- Game/Code/lib/midi/MIDIDEFS.PAS | 110 +- Game/Code/lib/midi/MIDITYPE.PAS | 180 ++-- Game/Code/lib/midi/MidiFile.pas | 1928 +++++++++++++++++----------------- Game/Code/lib/midi/MidiScope.pas | 396 +++---- Game/Code/lib/midi/Midicons.pas | 94 +- Game/Code/lib/midi/Midiin.pas | 1450 ++++++++++++------------- Game/Code/lib/midi/Midiout.pas | 1234 +++++++++++----------- Game/Code/lib/midi/demo/MidiTest.pas | 498 ++++----- Game/Code/lib/midi/demo/Project1.dpr | 26 +- Game/Code/lib/midi/midiComp.cfg | 70 +- Game/Code/lib/midi/readme.txt | 120 +-- 13 files changed, 3374 insertions(+), 3374 deletions(-) (limited to 'Game/Code/lib/midi') 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 , - 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 , + 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 , - 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 , + 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 , - 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 , + 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 , - 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 , + 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 , - 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 , + 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 , - 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 , + 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. + -- cgit v1.2.3