unitmiditrackstream.pas

Delphi的另一款钢琴软件

unit unitMidiTrackStream;

interface

uses classes, SysUtils, windows, unitVirtualMemory, unitMidiGlobals;

type
TFindEventType = (feFirst, feLast, feAny);

TMidiTrackStream = class (TVirtualMemoryStream)
  fEventCount : Integer;
  fTrackName : PMidiEventData;
  fPatch : TPatchNo;
  fBank : TBankNo;
  fChannel : TChannel;
  fChanges : boolean;
  fUpdateCount : Integer;

  function GetEvent (idx : Integer) : PMidiEventData;
  procedure SetTrackName (const value : string);
  function GetTrackName : string;
  procedure SetChannel (value : TChannel);
  procedure SetPatch (value : TPatchNo);

  public
  InstrumentName : string;
  TempPort : Integer;

  constructor Create (MaxEvents : Integer);
  destructor Destroy; override;
  procedure CalcOnOffPointers;
  procedure Init;

  procedure LoadFromSMFStream (SMFstream : TStream);
  procedure SaveToSMFStream (SMFStream : TStream);

  function FindEventNo (pos : Integer; tp : TFindEventType) : Integer;
  function FindEvent (pos : Integer; tp : TFindEventType) : PMidiEventData;
  function InsertEvent (pos : Integer; var data : TEventData; sysexSize : Integer) : PMidiEventData;
  function InsertMetaEvent (pos : Integer; metaEvent : byte; data : PChar; dataLen : Integer) : PMidiEventData;
  procedure DeleteEvent (eventNo : Integer);
  procedure EraseNonMetaEvents;
  function IndexOf (p : PMidiEventData) : Integer;
  procedure BeginUpdate;
  procedure EndUpdate;
  procedure CancelUpdate;

  // Clipboard support
  function GetEventRange (startPos, endPos : Integer; var startEvent, endEvent : Integer) : boolean;
  function CalcRangeDataSize (startEvent, endEvent, startPos, endPos : Integer) : Integer;
  procedure GetRangeData (buffer : PChar; startPos, startEvent, endEvent, endPos : Integer);
  procedure DeleteRange (startPos, endPos : Integer);
  procedure CopyToClipboard (startPos, endPos : Integer);
  procedure DeleteToClipboard (startPos, endPos : Integer);
  procedure CutToClipboard (startPos, endPos : Integer);
  procedure PasteFromClipboard (Pos : Integer);

  property EventCount : Integer read fEventCount;
  property Event [idx : Integer] : PMidiEventData read GetEvent;
  property TrackName : string read GetTrackName write SetTrackName;
  property Channel : TChannel read fChannel write SetChannel;
  property Patch : TPatchNo read fPatch write SetPatch;
  property Bank : TBankNo read fBank write fBank;
  property Changes : boolean read fChanges write fChanges;
end;

EMidiTrackStream = class (Exception);

implementation

uses clipbrd;

const
  chanType : array [0..15] of integer = (0, 0, 0, 0, 0, 0, 0, 0,
                                         2, 2, 2, 2, 1, 1, 2, 0);

var
  trackClipboardFormat : word;

constructor TMidiTrackStream.Create (maxEvents : Integer);
begin
  inherited Create (maxEvents * sizeof (TMidiEventData), 0);
end;

(*---------------------------------------------------------------------*
 | destructor TMidiTrackStream.Destroy;                                |
 |                                                                     |
 | Free the event data buffers.                                        |
 *---------------------------------------------------------------------*)
destructor TMidiTrackStream.Destroy;
var
  event : PMidiEventData;
  i : Integer;
begin
  event := Memory;
                            // Go thru the event buffer...
  for i := 0 to fEventCount - 1 do
  begin
                            // If its a sysex message ($f0); a sysex continuation ($f7)
                            // or a meta event ($ff), we need to free the sysex
                            // data
    if event^.data.status in [midiSysex, midiSysexCont, midiMeta] then
      FreeMem (event^.data.sysex);
    Inc (event)
  end;
  inherited
end;

(*---------------------------------------------------------------------*
 | procedure TMidiTrackStream.Init;                                    |
 |                                                                     |
 | Initialise a blank track by creating TrackStart, TrackName &        |
 | TrackEnd meta events.                                               |
 *---------------------------------------------------------------------*)
procedure TMidiTrackStream.Init;
begin
  InsertMetaEvent (0, metaTrackEnd, Nil, 0);
  InsertMetaEvent (0, metaTrackStart, Nil, 0);
  fTrackName := InsertMetaEvent (0, metaTrackName, Nil, 0);
end;

procedure TMidiTrackStream.LoadFromSMFStream (SMFstream : TStream);
var
  hdr : array [0..3] of char;
  trackSize : LongInt;
  buffer : TMemoryStream;
  gotEndOfTrack : boolean;
  divi : Integer;

  // return no of events.
  function DoPass (pass2 : boolean) : Integer;
  var
    sysexFlag : boolean;
    l, pos : Integer;
    c, c1, status, runningStatus, mess : byte;
    events : PMidiEventData;
    notGotPatch, notGotChannel, newStatus : boolean;
    eventCount : Integer;
  //-----------------------------------------------------------------------
  //  function GetFVariNum : Integer;
  //
  //  Get a variable length integer from the SMF data.  The first byte is
  // the most significant.  Use onlu the lower 7 bits of each bytes - the
  // eigth is set if there are more bytes.

    function GetFVariNum : Integer;
    var
      l : Integer;
      b : byte;
    begin
      l := 0;
      repeat
        b := PByte (Integer (buffer.Memory) + pos)^;
        Inc (pos);
        l := (l shl 7) + (b and $7f);  // Add it to what we've already got
      until (b and $80) = 0;           // Finish when the 8th bit is clear.
      result := l
    end;

  //-----------------------------------------------------------------------
  //  function GetFChar : Integer;
  //
  // Get a byte from the SMF stream

    function GetFChar : byte;
    begin
      result := PByte (Integer (buffer.Memory) + pos)^;
      Inc (pos);
    end;

  begin
    events := Memory;
    eventCount := 0;
    runningStatus := 0;              // Clear 'running status'
    divi := 0;                       // Current position (in ticks) is zero
    newStatus := False;
    pos := 0;                        // Start at the beginning of the buffer
    sysexFlag := False;              // Clear flag - we're not in the middle of
                                     // a sysex message

    notGotChannel := True;
    notGotPatch := True;

    while pos < trackSize do
    begin
      Inc (divi, GetFVariNum);       // Get event position

      c := GetFChar;                 // Get first byte of event status if it's >= $80

                                     // If we're in the middle of a sysex msg, this
                                     // must be a sysex continuation event
      if sysexFlag and (c <> midiSysexCont) then
        raise EMidiTrackStream.Create ('Error in Sysex');

      if (c and midiStatus) <> 0 then
      begin                          // It's a 'status' byte
        status := c;
        newStatus := True;           // Get the first data byte
      end
      else
      begin
        status := runningStatus;
        if status = 0 then
                                     // byte indicates 'running status' but we don't
                                     // know the status
          raise EMidiTrackStream.Create ('Error in Running Status')
      end;

      if pass2 then
      begin
        events^.pos := divi;
        events^.data.status := status
      end;

      if status < midiSysex then           // Is it a 'channel' message
      begin
        if NewStatus then
        begin
          c := GetFChar;
          NewStatus := False;
          runningStatus := status
        end;

        mess := (status shr 4);      // the top four bits of the status
                                     // Get the second data byte if there is one.
        if chanType [mess] > 1 then c1 := GetFChar else c1 := 0;

        if not pass2 then
        begin
          if notGotPatch and (mess = $c) then
          begin                         // It's  the first 'patch change' message
            notGotPatch := False;
            fPatch := c
          end;

          if notGotChannel then
          begin                         // It's the first 'channel' message
            notGotChannel := False;
            fChannel := status and midiChannelMask;
          end
        end
        else
          with events^ do
          begin
            data.b2 := c;              // Save the data bytes
            data.b3 := c1
          end
      end
      else
      begin                          // It's a meta event or sysex.
        newStatus := False;
        case status of
          midiMeta :                      // Meta event
            begin
              c1 := GetFChar;        // Get meta type
              l := GetFVariNum;      // Get data len

                                     // Allocate space for message (including meta type)
              if pass2 then
              begin
                events^.sysexSize := l + 1;
                GetMem (events^.data.sysex, events^.sysexSize);

                events^.data.sysex [0] := char (c1);
                Move (pointer (Integer (buffer.Memory) + pos)^, events^.data.sysex [1], l);
                case c1 of             // Save 'track name' event
                  metaTrackName :
                    fTrackName := events;
                  metaText : if fTrackName = Nil then fTrackName := events;
                end
              end
              else
                if c1 = metaTrackEnd then
                  if not gotEndOfTrack then
                    gotEndOfTrack := True;

              Inc (pos, l);

            end;

          midiSysex, midiSysexCont:  // Sysex event
            begin
              l := GetFVariNum;     // Get length of sysex data

              if pass2 then
              begin
                                    // Allocate a buffer, and copy it in.
                events^.sysexSize := l;
                GetMem (events^.data.sysex, l);
                Move (pointer (Integer (buffer.Memory) + pos)^, events^.data.sysex [0], l);
              end;
              Inc (pos, l);
                                    // Set flag if the message doesn't end with f7
              sysexFlag := PChar (Integer (buffer.Memory) + pos - 1)^ <> char (midiSysexCont);
            end
        end
      end;
      Inc (eventCount);
      Inc (events);
    end;
    result := eventCount
  end;

begin // LoadFromSMFStream
  SMFStream.Read (hdr, sizeof (hdr));      // Read the track header
  if StrLComp (hdr, 'MTrk', sizeof (hdr)) <> 0 then
    raise EMidiTrackStream.Create ('Invalid track start ID');

  SMFStream.ReadBuffer (trackSize, sizeof (trackSize));
  trackSize := SwapLong (trackSize);

  buffer := TMemoryStream.Create;
  try
    buffer.CopyFrom (SMFStream, trackSize);

    gotEndOfTrack := False;
    fEventCount := DoPass (False);
                                     // We now know how many events there are.
                                     // Set the buffer size (commits the memory)
    Size := fEventCount * sizeof (TMidiEventData);
    DoPass (True);

    if not GotEndOfTrack then       // Add end of track if not found
      InsertMetaEvent (divi, metaTrackEnd, Nil, 0);
  finally
    buffer.Free
  end;
  Seek (EventCount * sizeof (TMidiEventData), soFromBeginning);
  CalcOnOffPointers;
end;

procedure TMidiTrackStream.SaveToSMFStream (SMFStream : TStream);
var
  trackSize, ts : Integer;
  buffer : TMemoryStream;

//-----------------------------------------------------------------------
//  function DoPass.  Returns the track size
//
  function DoPass (pass2 : boolean) : Integer;
  var
    p : PMidiEventData;
    i, lastPos : Integer;
    c, status : byte;
    pos : Integer;

  //-----------------------------------------------------------------------
  //  procedure SetByte (b : byte);
  //
  // Set a byte of SMF data
    procedure SetByte (b : byte);
    begin
     if pass2 then
       pByte (Integer (buffer.Memory) + pos)^ := b;
     Inc (pos);
    end;

  //-----------------------------------------------------------------------
  //  procedure SetVariNum (n : LongInt; mask : byte);
  //
  // Set a variable length integer.  See GetFVariNum above
    procedure SetVariNum (n : LongInt; mask : byte);
    var
      b : byte;
      r : Longint;
    begin
      b := n and $7f;
      r := n shr 7;
      if r > 0 then
        SetVariNum (r, $80);
      SetByte (b or mask)
    end;

  //-----------------------------------------------------------------------
  // procedure SetBlock (data : PChar; size : LongInt);
  //
  // Set a sysex or meta block.
    procedure SetBlock (data : PChar; size : LongInt);
    begin
      SetVariNum (size, 0);
      if pass2 then
        Move (data^, Pointer (Integer (buffer.Memory) + pos)^, size);
      Inc (pos, size);
    end;

  //-----------------------------------------------------------------------
  // procedure SetMeta (data : PChar; size : LongInt);
  //
  // Set a meta block.  Meta event type first then size, then meta event data
    procedure SetMeta (data : PChar; size : LongInt);
    begin
      SetByte (byte (data [0]));
      SetBlock (data + 1, size - 1)
    end;

  begin // DoPass
    p := Memory;
    pos := 0;
    lastPos := 0;
    status := 0;                      // Initialise running status.

    for i := 0 to fEventCount - 1 do
    begin
      SetVariNum (p^.pos - lastPos, 0);
      lastPos := p^.pos;
                                     // Save the event position
      c := p^.data.status;           // Get the status

      if c < midiSysex then          // Channel message ?
      begin
        if c <> status then          // If the status is the same as before,
        begin                        // don't save it.
          status := c;
          SetByte (status)
        end;
                                     // Save the first data byte
        SetByte (p^.data.b2);
                                     // Save the optional second data byte
        if chanType [status shr 4] = 2 then
          SetByte (p^.data.b3);
      end
      else
      begin                          // Sysex or meta event
        SetByte (c);                 // Save the status byte
        if (c = midiMeta) then       // Save the data.
          SetMeta (p^.data.sysex, p^.sysexSize)
        else
          SetBlock (p^.data.sysex, p^.sysexSize);
        Status := 0;                 // Clear running status
      end;

      Inc (p)
    end;
    result := pos;
  end;

begin
  trackSize := DoPass (False);