aboutsummaryrefslogtreecommitdiffstats
path: root/Game/Code/lib/midi/Midiout.pas
blob: 0ad935916f762b9b701c4dbfe3fd38dd6cd95a5f (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
{ $Header: /MidiComp/MidiOut.pas 2     10/06/97 7:33 Davec $ }

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

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

unit MidiOut;

{
  MIDI Output component.

  Properties:
   DeviceID: 	Windows numeric device ID for the MIDI output device.
 Between 0 and (midioutGetNumDevs-1), or MIDI_MAPPER (-1).
    Special value MIDI_MAPPER specifies output to the Windows MIDI mapper
 Read-only while device is open, exception if changed while open

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

 ProductName: Name of the output device product that corresponds to the
 DeviceID property (e.g. 'MPU 401 out').
 You can write to this while the device is closed to select a particular
 output device by name (the DeviceID property will change to match).
 Exception if this property is changed while the device is open.

 Numdevs: Number of MIDI output devices installed on the system. This
 is the value returned by midiOutGetNumDevs. It's included for
 completeness.

    Technology: Type of technology used by the MIDI device. You can set this
    property to one of the values listed for OutportTech (below) and the component
    will find an appropriate MIDI device. For example:
     MidiOutput.Technology := opt_FMSynth;
    will set MidiInput.DeviceID to the MIDI device ID of the FM synth, if one
    is installed. If no such device is available an exception is raised,
    see MidiOutput.SetTechnology.

 See the MIDIOUTCAPS entry in MMSYSTEM.HLP for descriptions of the
 following properties:
  DriverVersion
  Voices
  Notes
  ChannelMask
  Support

 Error: The error code for the last MMSYSTEM error. See the MMSYSERR_
 entries in MMSYSTEM.INT for possible values.

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

 Close: Close device

 PutMidiEvent(Event:TMyMidiEvent): Output a note or sysex message to the
 device. This method takes a TMyMidiEvent object and transmits it.
 Notes:
   1. If the object contains a sysex event the OnMidiOutput event will
    be triggered when the sysex transmission is complete.
   2. You can queue up multiple blocks of system exclusive data for
    transmission by chucking them at this method; they will be
   transmitted as quickly as the device can manage.
   3. This method will not free the TMyMidiEvent object, the caller
    must do that. Any sysex data in the TMyMidiEvent is copied before
   transmission so you can free the TMyMidiEvent immediately after
   calling PutMidiEvent, even if output has not yet finished.

 PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte): Output a short
 MIDI message. Handy when you can't be bothered to build a TMyMidiEvent.
 If the message you're sending doesn't use Data1 or Data2, set them to 0.

 PutLong(TheSysex: Pointer; msgLength: Word): Output sysex data.
  SysexPointer: Pointer to sysex data to send
  msgLength: Length of sysex data.
 This is handy when you don't have a TMyMidiEvent.

 SetVolume(Left: Word, Right: Word): Set the volume of the
 left and right channels on the output device (only on internal devices?).
 0xFFFF is maximum volume. If the device doesn't support separate
 left/right volume control, the value of the Left parameter will be used.
 Check the Support property to see whether the device supports volume
 control. See also other notes on volume control under midiOutSetVolume()
 in MMSYSTEM.HLP.

  Events:
 OnMidiOutput: Procedure called when output of a system exclusive block
 is completed.

  Notes:
   I haven't implemented any methods for midiOutCachePatches and
  midiOutCacheDrumpatches, mainly 'cause I don't have any way of testing
  them. Does anyone really use these?
}

interface

{$IFDEF FPC}
  {$MODE Delphi}
{$ENDIF}

uses
  SysUtils,
  Windows,
  Messages,
  Classes,
  //Controls,
  MMSystem,
  {$IFDEF LCL}
  LCLIntf, // used for AllocateHWnd
  {$ENDIF}
  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.