Delphi控件源码

开发平台：
Delphi

MMStretch.pas：源码内容
							unit MMStretch;
(*-------------------------------------------------------------------
 * Time domain harmonic scaling by
 * Pointer Inteval Controled OverLap and ADD (PICOLA) Method
 *		C version by IKEDA Mikio
 *		original argolithm is developed by MORITA Naotaka
 *		about detail, see original paper.
 *-------------------------------------------------------------------
 * Usage
 *  PICOLA <source signal> <companded (destination) signal>
 *	   <compansion ratio>
 *         <window length> <pitch minimum> <pitch maximum>
 * Last three arguments can be abbriviated.
 *------------------------------------------------------------------*)
 // Does not work (horrible quality) leave it for now....
interface
uses
    SysUtils,
    Windows,
    Classes,
    MMSystem,
    MMRegs,
    MMObj,
    MMDSPObj,
    MMPCMSup,
    MMUtils;
type
   EMMTimeStretchError = class(Exception);
   {-- TMMTimeStretch ---------------------------------------------------------}
   TMMTimeStretch = class(TMMDSPComponent)
   private
      FEnabled       : Boolean;
      FOpen          : Boolean;
      FFirstRead     : Boolean;
//      FPitch         : Float;
      FWaveHdr       : TMMWaveHdr;
      FRealBufSize   : Longint;
      FBytesRead     : Longint;
      FMoreBuffers   : Boolean;
      FWriteBuffer   : PChar;
      FBytesWritten  : Longint;
      FDone          : Boolean;
      procedure SetEnabled(aValue: Boolean);
  //    procedure SetPitch(aValue: Float);
      function  ReadData(Buffer: PChar; dwLength: Longint; var MoreData: Boolean): Longint;
      function  WriteData(Buffer: PChar; dwLength: Longint): Longint;
      procedure ReadFromInput(lpwh: PWaveHdr; var MoreBuffers: Boolean);
   protected
      procedure SetPWaveFormat(aValue: PWaveFormatEx); override;
      procedure Opened; override;
      procedure Closed; override;
      procedure Started; override;
      procedure Reseting; override;
      procedure BufferReady(lpwh: PWaveHdr); override;
      procedure BufferLoad(lpwh: PWaveHdr; var MoreBuffers: Boolean); override;
   public
      constructor Create(aOwner: TComponent); override;
      destructor Destroy; override;
      procedure Open;
      procedure Close;
      procedure Reset;
   published
      property Input;
      property Output;
      property Enabled: Boolean read FEnabled write SetEnabled default True;
    //  property Pitch: Float read FPitch write SetPitch;
   end;
procedure StretchFile(SrcFile,DstFile: String);
implementation
{---- find maximum covariance  = pitch ----------------------------------------}
function covpitch(pitmin, pitmax, length: integer; _is: array of Smallint): integeR;
var
  i,j,pitch: integer;
  covst, covs0t, covmax, s: Float;
begin
   covmax := 0.0;
   pitch := pitmin;
   for i := pitmin to pitmax do
   begin
      covst := 0.0;
      covs0t := 0.0;
      for j := 0 to length-1 do
      begin
	 s := _is[i+j];
	 covs0t := covs0t + s * s;
	 covst  := covst + _is[j] * s;
      end;
      covst := covst / sqrt(covs0t);
      if (covst >= covmax) then
      begin
         covmax := covst;
         pitch := i;
      end;
   end;
   Result := pitch;
end;
{------------ PICOLA OverLap and Add (picOLA) stage ---------------------------}
procedure ola(pitch: integer; is1, is2: PSmallint);
var
   i: integer;
   s, w: Float;
begin
   for i := 0 to pitch-1 do
   begin
      w := i / (pitch - 1);
      s :=  is1^ * (1.0 - w) + is2^ * w;
      inc(is1);
      is2^ := Trunc(s);
      inc(is2);
   end;
end;
{------------------------------------------------------------------------------}
function amdfpitch(pitmin, pitmax, length: integer; _is: array of Smallint): integer;
var
   i, j, diff, acc, accmin, pitch: integer;
begin
   pitch := pitmin;
   accmin := 0;
   for j := 0 to length-1 do
   begin
      diff := _is[j+pitmin] - _is[j];
      if (diff > 0) then
          accmin := accmin + diff
      else
          accmin := accmin - diff;
   end;
   for i := pitmin+1 to pitmax do
   begin
      acc := 0;
      for j := 0 to length-1 do
      begin
         diff := _is[i+j] - _is[j];
	 if (diff > 0) then
             acc := acc + diff
         else
	     acc := acc - diff;
      end;
      if (acc < accmin) then
      begin
	 accmin := acc;
	 pitch := i;
      end;
   end;
   Result := pitch;
end;
var
   _is : array[0..4096] of Smallint; // signal buffer
   rate: Float = 1.1;	// compansion rate
			//case of less than 1.0 compression,
			//case of greater than 1.0 expansion
   rcomp: Float;	// internal compansion ratio
   sl: Float;
   err: float = 0.0;	// compansion rate error estimate
   acclen: Float = 0.0;
   pitmin: integer = 32;  // minimal pitch period //
   pitmax: integer = 1024; // maximal pitch period //
   pitch : integer; 	  // detected pitch period */
   length: integer = 1024;
   total: integer;
   nread: integer;	// number of read samples (from file) */
   wantread: integer;	// desired number of read samples */
   lcp: integer;	// number of copy samples */
   point: integer;	// PICOLA's pointer */
//   i: integer;		// loop counter */
   lproc: integer = 0;	// processed speech samples */
   Src,Dst: THandle;
procedure StretchFile(SrcFile,DstFile: String);
var
   i: integer;
begin
   // length := atoi(argv[4]); option
   // pitmin := atoi(argv[5]); option
   // pitmax := atoi(argv[6]); option
   //-------------- error check and initialize ---------------------
   {
    if (rate <= 0.0 || rate == 1.0)
    begin
       printf("illeagal compansion rate !!n");
	exit(0);
    end;
    if (pitmin < 16)
    begin
        printf("pitch detection minimum threshold modified !!n");
	pitmin = 16;
    end;
    if (pitmax > 256)
    begin
        printf("pitch detection maximum threshold modified !!n");
	pitmax = 256;
    end;
    if (length <= 64 || length + pitmax >= 1024)
    begin
	printf("frame length out of range !!n");
	exit(0);
    end;
}
    total := length + pitmax;
    if (rate >= 1.0) then
    begin
       // TODO:rate darf nicht 1.0 sein, also bei rate := 1.0 skippen
       rcomp := 1.0  / (rate - 1.0);
    end
    else if (rate > 0) then
    begin
       rcomp := rate / (1.0 - rate);
    end
    else
    begin
       //	fprintf(stderr, "Error from %s: illeagal compansion rate!n", argv[0]);
       //	exit(0);
    end;
    Src := FileOpen(SrcFile,fmOpenRead);
    Dst := FileCreate(DstFile);
    //------------------- body ---------------
    wantread := total;  // total muss gesetzt werden !!!
    nread := FileRead(Src,_is, 2*wantread) div 2;
    while (nread = wantread) do
    begin
       //---- pitch extraction ----
       pitch := amdfpitch(pitmin, pitmax, length, _is);
       //---- PICOLA OverLap and ADD stage ----//
       if (rate < 1.0) then
       begin
           ola(pitch, @_is, @_is[pitch]);
           point := pitch;
       end
       else
       begin
          FileWrite(Dst,_is, 2*pitch);
          ola(pitch, @_is[pitch], @_is);
	  point := 0;
       end;
       //---- compensate compansion rate ----*/
       sl := pitch * rcomp;
       lcp := trunc(sl);
       err := err + lcp - sl;
       if (err >= 0.5) then
       begin
          dec(lcp);
          err := err - 1.0;
       end
       else if (err <= -0.5) then
       begin
       	  inc(lcp);
          err := err + 1.0;
       end;
       lproc := lproc + pitch;
       //---- PICOLA Pointer Interval Control (PIC) stage ----*/
	wantread := point + lcp;
	if (wantread > total) then
        begin
           wantread := total - point;
	   FileWrite(Dst,_is[point], 2*wantread);
	   lcp := lcp - wantread;
	   wantread := total;
	   while (lcp > 0) do
           begin
              if (lcp <= total) then
              begin
                 wantread := lcp;
	         nread := FileRead(Src,_is, 2*wantread)div 2;
	         FileWrite(Dst,_is, 2*nread);
	         if (nread <> wantread) then
                     break;
	    	 wantread := total;
	    	 nread := FileRead(Src,_is, 2*wantread)div 2;
              end
              else
              begin
                 nread := FileRead(Src,_is, 2*wantread)div 2;
	         FileWrite(Dst,_is, 2*nread);
	         if (nread <> wantread) then
	         break;
              end;
              lcp := lcp - total;
           end;
        end
        else
        begin
           FileWrite(Dst,_is[point], 2*lcp);
	   point := total - wantread;
	   // shift to next pitch period
           for i := 0 to point-1 do
           begin
              _is[i] := _is[i+wantread];
           end;
           nread := FileRead(Src,_is[point], 2*wantread)div 2;
        end;
    end;
    // write rest */
    FileWrite(Dst,_is, 2*(total - wantread + nread));
    FileClose(Src);
    FileClose(Dst);
end;
{== TMMTimeStretch ============================================================}
constructor TMMTimeStretch.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);
   FEnabled     := True;
   FOpen        := False;
   FWriteBuffer := nil;
   FFirstRead   := True;
   //SetPitch(0.0);
end;
{-- TMMTimeStretch ------------------------------------------------------------}
destructor TMMTimeStretch.Destroy;
begin
   Close;
   inherited Destroy;
end;
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.SetEnabled(aValue: Boolean);
begin
   if (aValue <> FEnabled) then
   begin
      FEnabled := aValue;
      if FEnabled then Reset;
   end;
end;
(*
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.SetPitch(aValue: Float);
begin
//   FPitch := MinMaxR(aValue,-50.0,+50.0);
//   FPitchInc := Trunc((FPitch+50)*65536/100+32768);
end;
*)
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.SetPWaveFormat(aValue: PWaveFormatEx);
begin
   if (aValue <> nil) then
   begin
      if not (csDesigning in ComponentState) then
         if not pcmIsValidFormat(aValue) or (aValue^.wBitsPerSample = 8) then
            raise EMMTimeStretchError.Create(LoadResStr(IDS_INVALIDFORMAT));
   end;
   inherited SetPWaveFormat(aValue);
end;
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.Open;
begin
   if not FOpen then
   begin
      FRealBufSize               := Max(BufferSize,Max(QUEUE_READ_SIZE,BufferSize));
      FWaveHdr.wh.dwBufferLength := 2*FRealBufSize;
      FWaveHdr.wh.lpData         := GlobalAllocMem(FWaveHdr.wh.dwBufferLength);
      FWriteBuffer               := GlobalAllocMem(FRealBufSize);
      FFirstRead                 := True;
      FOpen                      := True;
   end;
end;
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.Close;
begin
   if FOpen then
   begin
      FOpen := False;
      GlobalFreeMem(Pointer(FWaveHdr.wh.lpData));
      GlobalFreeMem(Pointer(FWriteBuffer));
   end;
end;
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.Reset;
begin
   if FOpen then
   begin
      FWaveHdr.wh.dwBytesRecorded := 0;
      FWaveHdr.LoopRec.dwLooping  := False;
      FBytesRead    := 0;
      FBytesWritten := 0;
      FFirstRead    := True;
      FDone         := False;
   end;
end;
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.Opened;
begin
   Open;
   inherited Opened;
end;
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.Closed;
begin
   Close;
   inherited Closed;
end;
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.Reseting;
begin
   Reset;
   inherited Reseting;
end;
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.Started;
begin
   Reset;
   inherited Started;
end;
{-- TMMTimeStretch ------------------------------------------------------------}
function TMMTimeStretch.ReadData(Buffer: PChar; dwLength: Longint; var MoreData: Boolean): Longint;
Label _Again;
var
   nRead,nBytes: Longint;
begin
   nRead := 0;
   MoreData := False;
   with FWaveHdr.wh do
   begin
_Again:
      nBytes := dwBytesRecorded - FBytesRead;
      if (nBytes > 0) then
      begin
         nBytes := Min(nBytes,dwLength);
         GlobalMoveMem((FWaveHdr.wh.lpData+FBytesRead)^,(Buffer+nRead)^,nBytes);
         inc(nRead,nBytes);
         inc(FBytesRead,nBytes);
         dec(dwLength,nBytes);
      end;
      { do we need more data ? }
      if (dwLength > 0) and not FDone then
      begin
         dwBytesRecorded := 0;
         (*
         // TODO: LoopHandling !!!!
         if FWaveHdr.LoopRec.dwLooping then
         begin
            PMMWaveHdr(lpwh)^.LoopRec.dwLooping := True;
            PMMWaveHdr(lpwh)^.LoopRec.dwLoopTmpCnt := FWaveHdr.LoopRec.dwLoopTmpCnt;
            FWaveHdr.LoopRec.dwLooping := False;
         end;
         FWaveHdr.LoopRec.dwLoop := PMMWaveHdr(lpwh)^.LoopRec.dwLoop;
         if FWaveHdr.LoopRec.dwLoop then
         begin
            FWaveHdr.LoopRec.dwLoopCnt    := PMMWaveHdr(lpwh)^.LoopRec.dwLoopCnt;
            FWaveHdr.LoopRec.dwLoopTmpCnt := PMMWaveHdr(lpwh)^.LoopRec.dwLoopTmpCnt;
            FWaveHdr.LoopRec.dwLooping    := False;
         end;
         *)
         FMoreBuffers := False;
         inherited BufferLoad(@FWaveHdr,FMoreBuffers);
         if not FMoreBuffers or (dwBytesRecorded <= 0) then FDone := True;
         FBytesRead := 0;
         if (dwBytesRecorded > 0) then goto _Again;
      end;
      MoreData := FMoreBuffers or (dwBytesRecorded-FBytesRead > 0);
   end;
   Result := nRead;
end;
{-- TMMTimeStretch ------------------------------------------------------------}
function TMMTimeStretch.WriteData(Buffer: PChar; dwLength: Longint): Longint;
begin
   GlobalMoveMem(Buffer^,(FWriteBuffer+FBytesWritten)^,dwLength);
   inc(FBytesWritten,dwlength);
   Result := FBytesWritten;
end;
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.ReadFromInput(lpwh: PWaveHdr; var MoreBuffers: Boolean);
var
   i: integer;
   nBytes: Longint;
   HasMoreData: Boolean;
begin
   if (Input <> nil) then
   begin
      // TODO: wenn geskippt wird weil keine pitch 膎derung dann aufpassen das MoreBuffers richtig gesetzt wird
      HasMoreData := True;
   //   lpwh.dwBytesRecorded := ReadData(lpwh^.lpData,lpwh.dwBufferLength,MoreBuffers);
      total := length + pitmax;
      if (rate >= 1.0) then
      begin
         // TODO:rate darf nicht 1.0 sein, also bei rate := 1.0 skippen
         rcomp := 1.0  / (rate - 1.0);
      end
      else if (rate > 0) then
      begin
         rcomp := rate / (1.0 - rate);
      end
      else
      begin
         //	fprintf(stderr, "Error from %s: illeagal compansion rate!n", argv[0]);
         //	exit(0);
      end;
      //------------------- body ---------------
      // Todo: nur bei Initial read
      if FFirstRead then
      begin
         wantread := total;
         nread := ReadData(@_is, 2*wantread, HasMoreData) div 2;
         FFirstRead := False;
      end;
      while (nread = wantread) and (FBytesWritten < lpwh.dwBufferLength) do
      begin
         //---- pitch extraction ----
         pitch := amdfpitch(pitmin, pitmax, length, _is);
         //---- PICOLA OverLap and ADD stage ----//
         if (rate < 1.0) then
         begin
            ola(pitch, @_is, @_is[pitch]);
            point := pitch;
         end
         else
         begin
            WriteData(@_is, 2*pitch);
            ola(pitch, @_is[pitch], @_is);
	    point := 0;
         end;
         //---- compensate compansion rate ----*/
         sl := pitch * rcomp;
         lcp := trunc(sl);
         err := err + lcp - sl;
         if (err >= 0.5) then
         begin
            dec(lcp);
            err := err - 1.0;
         end
         else if (err <= -0.5) then
         begin
       	    inc(lcp);
            err := err + 1.0;
         end;
         lproc := lproc + pitch;
         //---- PICOLA Pointer Interval Control (PIC) stage ----*/
	 wantread := point + lcp;
	 if (wantread > total) then
         begin
            wantread := total - point;
	    WriteData(@_is[point], 2*wantread);
	    lcp := lcp - wantread;
	    wantread := total;
	    while (lcp > 0) do
            begin
               if (lcp <= total) then
               begin
                  wantread := lcp;
	          nread := ReadData(@_is, 2*wantread,HasMoreData)div 2;
	          WriteData(@_is, 2*nread);
	          if (nread <> wantread) then
                      break;
	    	  wantread := total;
	    	  nread := ReadData(@_is, 2*wantread,HasMoreData)div 2;
               end
               else
               begin
                  nread := ReadData(@_is, 2*wantread,HasMoreData)div 2;
	          WriteData(@_is, 2*nread);
	          if (nread <> wantread) then
	              break;
               end;
               lcp := lcp - total;
            end;
         end
         else
         begin
            WriteData(@_is[point], 2*lcp);
	    point := total - wantread;
	    // shift to next pitch period
	    for i := 0 to point-1 do
            begin
               _is[i] := _is[i+wantread];
            end;
            nread := ReadData(@_is[point], 2*wantread,HasMoreData)div 2;
         end;
      end;
      if not HasMoreData then
      begin
         // write rest */
         WriteData(@_is, 2*(total - wantread + nread));
      end;
      nBytes := Min(FBytesWritten,lpwh.dwBufferLength);
      GlobalMoveMem(FWriteBuffer^,lpwh^.lpData^,nBytes);
      GlobalMoveMem((FWriteBuffer+nBytes)^,FWriteBuffer^,FBytesWritten-nBytes);
      dec(FBytesWritten,nBytes);
      lpwh^.dwBytesRecorded := nBytes;
      MoreBuffers := HasMoreData or (FBytesWritten > 0);
   end
   else lpwh^.dwBytesRecorded := 0;
end;
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.BufferReady(lpwh: PWaveHdr);
begin
   if Enabled and FOpen then
   begin
      { TODO: Pitch f黵 recording schreiben }
   end;
   inherited BufferReady(lpwh);
end;
{-- TMMTimeStretch ------------------------------------------------------------}
procedure TMMTimeStretch.BufferLoad(lpwh: PWaveHdr; var MoreBuffers: Boolean);
begin
   // TODO: wenn Enabled auf False gesetzt wird dann ev. noch im Puffer befindliche Daten abspielen.
   if Enabled and FOpen {and ((FPitchInc <> $10000) or (FWaveHdr.wh.dwBytesRecorded - FBytesRead > 0))} then
   begin
      ReadFromInput(lpwh,MoreBuffers);
   end
   else inherited BufferLoad(lpwh, MoreBuffers);
end;
end.

						