Delphi控件源码

开发平台：
Delphi

MMFFTFlt.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: +0351-8012255                   =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
unit MMFFTFlt;
{$I COMPILER.INC}
interface
uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    MMSystem,
    MMRegs,
    MMUtils,
    MMMath,
    MMFFT;
{========================================================================}
const
     { constants for the DataType fields }
     DT_8BIT   = $00;  { x0 b }
     DT_16BIT  = $01;  { x1 b }
     DT_MONO   = $00;  { 0x b }
     DT_STEREO = $02;  { 1x b }
     { constants for channels }
     CH_BOTH   = $00;
     CH_LEFT   = $01;
     CH_RIGHT  = $02;
function GetDataType(pwfx: PWaveFormatEx): integer;
{========================================================================}
const
    {$IFDEF CBUILDER3} {$EXTERNALSYM DESM} {$ENDIF}
    DESM           = 8;
    {$IFDEF CBUILDER3} {$EXTERNALSYM MAX_FFTLEN} {$ENDIF}
    MAX_FFTLEN     = 1024;         { Define the maximum FFT buffer length.}
    {$IFDEF CBUILDER3} {$EXTERNALSYM MAX_CHANNELS} {$ENDIF}
    MAX_CHANNELS   = 2;
type
    PFFTCplxArray  = ^TFFTCplxArray;
    TFFTCplxArray  = array[0..MAX_FFTLEN+1] of TfCplx;
    TFFTLongArray  = array[0..MAX_FFTLEN+1] of Longint;
    TFFTFloatArray = array[0..MAX_FFTLEN+1] of Float;
    {-- TFilterParams ---------------------------------------------------------}
    PFilterParams  = ^TFilterParams;
    TFilterParams  = packed record
       Out_Buf     : TFFTLongArray;
       old_r       : TFFTFloatArray;
    end;
    {-- TFFTFilter ------------------------------------------------------------}
    PFFTFilter      = ^TFFTFilter;
    TFFTFilter      = packed record
       DataType     : integer;            { DT_8BIT,DT_16BIT,DT_MONO,DT_STEREO  }
       SampleRate   : Longint;            { SampleRate for the samples          }
       Channels     : integer;            { number of Channels                  }
       FFTLen       : integer;
       FFTLen_2     : integer;            { actual FFTlength                    }
       Order        : integer;
       pfft         : PFFTCplx;           { instance for FFT calculation        }
       BufIn        : PChar;
       BufIn_Bytes  : Longint;
       BufOut       : PChar;
       BufOut_Bytes : Longint;
       MaxBufferSize: Longint;
       WindowFunc   : Longint;
       Params       : array[0..MAX_CHANNELS-1] of TFilterParams;
       {-- var for FFT ------------}
       ampl         : TFFTFloatArray;
       fh           : TFFTCplxArray;
       fx           : TFFTCplxArray;
       DataSection  : TRtlCriticalSection;
    end;
function  InitFFTFilter(pwfx: PWaveFormatEx; FFTLength, MaxBufSize: integer): PFFTFilter;
procedure DoneFFTFilter(var pflt: PFFTFilter);
procedure SetFFTFilterWindow(pflt: PFFTFilter; Window: integer);
procedure SetFFTFilterBand(pflt: PFFTFilter; f1, f2, Gain: Float);
procedure ResetFFTFilter(pflt: PFFTFilter);
function  DoFFTFilter(pflt: PFFTFilter; Channel: TMMChannel; pIn: PChar; Len: Cardinal): Boolean;
implementation
uses
    MMAlloc;
var
   Allocator: TMMAllocator;
{==============================================================================}
function GetDataType(pwfx: PWaveFormatEx): Integer;
begin
   Result := -1;
   if (pwfx <> Nil) and (pwfx^.wFormatTag = WAVE_FORMAT_PCM) then
   begin
      Result := 0;
      if (pwfx^.wBitsPerSample = 16) then Result := Result or DT_16BIT;
      if (pwfx^.nChannels = 2) then Result := Result or DT_STEREO;
   end;
end;
{==============================================================================}
{ -- FFT Filter --                                                             }
{==============================================================================}
function InitFFTFilter(pwfx: PWaveFormatEx; FFTLength,MaxBufSize: integer): PFFTFilter;
begin
   Result := Allocator.AllocBufferEx(GHND,SizeOf(TFFTFilter));
   if (Result <> nil) then
   with Result^ do
   begin
      DataType   := GetDataType(pwfx);
      SampleRate := pwfx^.nSamplesPerSec;
      Channels   := pwfx^.nChannels;
      FFTLength  := Min(FFTLength, MAX_FFTLEN);
      FFTLen     := 1;
      { Convert FFTLen to a power of 2 }
      Order := 0;
      while FFTLength > 1 do
      begin
         FFTLength := FFTLength shr 1;
         inc(Order);
      end;
      if (Order > 0) then FFTLen := FFTLen shl Order;
      FFTLen_2 := FFTlen div 2;
      WindowFunc := 1;
      pfft   := InitCplxFFT(Order);
      MaxBufferSize := MaxBufSize;
      BufIn  := Allocator.AllocBufferEx(GHND,2*MaxBufSize*sizeOf(Byte));
      BufOut := Allocator.AllocBufferEx(GHND,2*MaxBufSize*sizeOf(Byte));
      FillChar(DataSection, SizeOf(DataSection), 0);
      InitializeCriticalSection(DataSection);
      ResetFFTFilter(Result);
      SetFFTFilterBand(Result,0,SampleRate div 2,0);
   end;
end;
{==============================================================================}
procedure DoneFFTFilter(var pflt: PFFTFilter);
begin
   if (pflt <> nil) then
   begin
      DeleteCriticalSection(pflt^.DataSection);
      DoneCplxFFT(pflt^.pfft);
      Allocator.FreeBuffer(Pointer(pflt.BufIn));
      Allocator.FreeBuffer(Pointer(pflt.BufOut));
      Allocator.FreeBuffer(Pointer(pflt));
   end;
end;
{==============================================================================}
procedure re_im_Init(pflt: PFFTFilter; amp: PFloatArray);
var
   i: integer;
   ampl_1: TFFTFloatArray;
begin
   with pflt^ do
   begin
      for i := 0 to FFTLen_2 do
      begin
         ampl_1[i] := amp[i];
         ampl_1[FFTLen_2+1+i] := 0
      end;
      ampl_1[0] := ampl_1[0] * 0.5;
      ampl_1[FFTLen_2] := ampl_1[FFTLen_2] * 0.5;
      for i := 0 to FFTLen_2 do
      begin
         fx[i].re := ampl_1[i]*cos(2*M_PI*i/4.0);
         fx[i].im := ampl_1[i]*sin(2*M_PI*i/4.0);
         fx[FFTLen_2+1+i].re := 0;
         fx[FFTLen_2+1+i].im := 0;
      end;
      DoCplxFFTb(pfft,@fx,1);
      {-- OTOBRASENIE 1 -------------------------------------------------}
      for i := 0 to FFTLen-1 do
      begin
         ampl_1[i] := fx[i].re*CalcWindowFunc(WindowFunc, i, FFTLen_2);
         fx[i].re := 0;
         fx[i].im := 0;
      end;
      for i := 0 to FFTlen_2 do fx[i].re := ampl_1[i];
      doCplxFFTb(pfft,@fx,-2);
   end;
end;
{==== INIT IMP-REACTION =======================================================}
procedure InitImp(pflt: PFFTFilter; dx,dy: integer; Gain: Float);
var
   i: integer;
begin
   with pflt^ do
   begin
      EnterCriticalSection(DataSection);
      try
         for i := dx to dy do
         begin
            ampl[i] := pow(10.0,(Gain+6)/20.0);
         end;
         re_im_Init(pflt,@ampl);
         for i := 0 to FFTLen-1 do
         begin
            {-- No Normalization ---}
            fh[i].re := fx[i].re;
            fh[i].im := fx[i].im;
         end;
      finally
         LeaveCriticalSection(DataSection);
      end;
   end;
end;
{== SetFFTFilter ==============================================================}
procedure SetFFTFilterWindow(pflt: PFFTFilter; Window: integer);
var
   i: integer;
begin
   with pflt^ do
   begin
      EnterCriticalSection(DataSection);
      try
         WindowFunc := Window;
         re_im_Init(pflt,@ampl);
         for i := 0 to FFTLen-1 do
         begin
            {-- No Normalization ---}
            fh[i].re := fx[i].re;
            fh[i].im := fx[i].im;
         end;
      finally
         LeaveCriticalSection(DataSection);
      end;
   end;
end;
{== SetFFTFilter ==============================================================}
procedure SetFFTFilterBand(pflt: PFFTFilter; f1,f2,Gain: Float);
var
   dx,dy: integer;
   f,fshag: FLoat;
begin
   with pflt^ do
   begin
      if f1 >= SampleRate div 2 then f1 := SampleRate div 2-1;
      if f2 > SampleRate div 2 then f2 := SampleRate div 2;
      if f1 > f2 then
      begin
         f := f1;
         f1 := f2;
         f2 := f;
      end;
      if (f2 = f1) then f2 := f2+1;
      fshag:= SampleRate/FFTLen;
      dx := Trunc(f1/fshag);
      dy := Trunc(f2/fshag);
      InitImp(pflt,dx,dy,Gain);
   end;
end;
{== ResetFFTFilter ============================================================}
procedure ResetFFTFilter(pflt: PFFTFilter);
var
   i: integer;
begin
   with pflt^ do
   begin
      BufIn_Bytes := 0;
      BufOut_Bytes:= 0;
      for i := 0 to Channels-1 do
      with Params[i] do
      begin
         FillChar(Out_Buf, sizeOf(Out_Buf),0);
         FillChar(Old_r, sizeOf(Old_r),0);
      end;
   end;
end;
{== FFT Filter ================================================================}
procedure FFT_Filter(pflt: PFFTFilter; pIn, pOut: PLongArray; channel: integer);
var
   i: integer;
begin
   with pflt^,pflt^.Params[channel] do
   begin
      EnterCriticalSection(DataSection);
      try
         {-- ZApolnenie dlya fft --}
         for i := 0 to FFTLen_2-1 do
         begin
            fx[i].re := pIn[i];
            fx[i].im := pIn[FFTLen_2+i];
            fx[FFTLen_2+i].re :=0;
            fx[FFTLen_2+i].im :=0;
         end;
         {-- DIRECT FFT SIGNAL --}
         DoCplxFFTb(pfft,@fx,1);
         {-- PEREMNOSENIE Na Impl. Reaction --}
         fvecMul2(@fh, @fx, FFTLen);
         {-- IFFT ---------------}
         DoCplxFFTb(pfft,@fx,-1);
         {-- SUMMIR s Hvostom IMPuls reactsi --}
         for i := 0 to FFTLen_2-1 do
         begin
            pOut[i] := Trunc(fx[i].re+old_r[i]);
            pOut[FFTLen_2+i] := Trunc(fx[FFTLen_2+i].re+fx[i].im);
            old_r[i] := fx[FFTLen_2+i].im;
         end;
      finally
         LeaveCriticalSection(DataSection);
      end;
   end;
end;
{== GetSignal =================================================================}
procedure GetSignal(pflt: PFFTFilter; pIn: PSmallint; pOut: PIntArray);
{$IFNDEF USEASM}
var
   i: integer;
begin
   with pflt^ do
   for i := 0 to FFTlen-1 do
   begin
      pOut[i] := pIn^;
      inc(pIn,Channels);
   end;
{$ELSE}
const
   ParmSize = sizeOf(TFilterParams);
asm
   // EAX = pflt
   // EDX = pIn
   // ECX = pOut
   push  ebx
   push  esi
   push  edi
   mov   esi, TFFTFilter(eax).Channels
   mov   edi, TFFTFilter(eax).FFTLen
   shl   esi, 1
   xor   ebx, ebx
@@loop:
   movsx eax, word ptr [edx]
   add   edx, esi
   mov   [ecx+4*ebx], eax
   movsx eax, word ptr [edx]
   add   edx, esi
   mov   [ecx+4*ebx+4], eax
   movsx eax, word ptr [edx]
   add   edx, esi
   mov   [ecx+4*ebx+8], eax
   movsx eax, word ptr [edx]
   add   edx, esi
   mov   [ecx+4*ebx+12], eax
   add   ebx, 4
   cmp   ebx, edi
   jl    @@loop
@@exit:
   pop   edi
   pop   esi
   pop   ebx
{$ENDIF}
end;
{== Clip Output ===============================================================}
function ClipOutput(pflt: PFFTFilter; pOut: PSmallArray; channel: integer): Boolean;
{$IFNDEF USEASM}
var
   i: integer;
   outval: Longint;
   pS: PSmallint;
begin
   Result := False;
   with pflt^,pflt^.Params[channel] do
   begin
      pS := Pointer(pOut);
      for i := 0 to FFTLen-1 do
      begin
         outval := Out_Buf[i];
         if outval > 32767 then
         begin
            Result := True;
            pS^ := 32767;
         end
         else if outval < -32767 then
         begin
            Result := True;
            pS^ := -32767;
         end
         else
            pS^ := outval;
         inc(pS,Channels);
      end;
   end;
{$ELSE}
const
   ParmSize = sizeOf(TFilterParams);
asm
   // EAX = pflt
   // EDX = pOut
   // ECX = channel
   push  ebx
   push  edi
   push  esi
   push  ebp
   imul  ecx, ParmSize/8
   lea   esi, TFFTFilter(eax).Params+8*ecx
   mov   ebx, TFFTFilter(eax).Channels
   shl   ebx, 1
   mov   ebp, TFFTFilter(eax).FFTLen
   xor   eax, eax
   xor   ecx, ecx
@@loop:
   {--- 1. sample ---}
   mov   edi, dword ptr TFilterParams(esi).Out_Buf[4*ecx]
   cmp   edi, 32767
   jle   @@skip1
   mov   di, 32767
   mov   eax, True
   jmp   @@set1
@@skip1:
   cmp   edi, -32768
   jge   @@set1
   mov   di, -32768
   mov   eax, True
@@set1:
   mov   word ptr [edx], di
   add   edx, ebx
   {--- 2. sample ---}
   mov   edi, dword ptr TFilterParams(esi).Out_Buf[4*ecx+4]
   cmp   edi, 32767
   jle   @@skip2
   mov   di, 32767
   mov   eax, True
   jmp   @@set2
@@skip2:
   cmp   edi, -32768
   jge   @@set2
   mov   di, -32768
   mov   eax, True
@@set2:
   mov   word ptr [edx], di
   add   edx, ebx
   {--- 3. sample ---}
   mov   edi, dword ptr TFilterParams(esi).Out_Buf[4*ecx+8]
   cmp   edi, 32767
   jle   @@skip3
   mov   di, 32767
   mov   eax, True
   jmp   @@set3
@@skip3:
   cmp   edi, -32768
   jge   @@set3
   mov   di, -32768
   mov   eax, True
@@set3:
   mov   word ptr [edx], di
   add   edx, ebx
   {--- 4. sample ---}
   mov   edi, dword ptr TFilterParams(esi).Out_Buf[4*ecx+12]
   cmp   edi, 32767
   jle   @@skip4
   mov   di, 32767
   mov   eax, True
   jmp   @@set4
@@skip4:
   cmp   edi, -32768
   jge   @@set4
   mov   di, -32768
   mov   eax, True
@@set4:
   mov   word ptr [edx], di
   add   edx, ebx
   add   ecx, 4
   cmp   ecx, ebp
   jl    @@loop
   pop   ebp
   pop   esi
   pop   edi
   pop   ebx
{$ENDIF}
end;
var
   p: PFFTFilter;
{== FFT Filter ================================================================}
function DoFFTFilter(pflt: PFFTFilter; Channel: TMMChannel; pIn: PChar; Len: Cardinal): Boolean;
var
   i,ch,KOL,Count,chMin,chMax,BytesDone,nBytes: integer;
   pW,pS: PSmallArray;
begin
   Result := False;
   if (pflt <> nil) then
   with pflt^ do
   begin
      p := pflt;
      GlobalMoveMem(pIn^,(BufIn+BufIn_Bytes)^,Len);
      inc(BufIn_Bytes,Len);
      KOL := BufIn_Bytes div (Channels*sizeOf(Smallint)) div FFTlen;
      chMax := Channels;
      if (Channel = chLeft) then chMax := 1;
      chMin := 0;
      if (Channels = 2) and (Channel = chRight) then chMin := 1;
      for ch := chMin to chMax-1 do
      with Params[ch] do
      begin
         Count := 0;
         while (Count < KOL) do
         begin
            pW := @PSmallArray(BufIn)^[FFTLen*Count*Channels+ch];
            {-- get signal -------------------------------------------------}
            GetSignal(pflt,PSmallint(pW),@Out_Buf);
            {-- filter ---}
            FFT_Filter(pflt,@Out_Buf,@Out_Buf,ch);
            pW := @PSmallArray(PChar(BufOut+BufOut_Bytes))^[FFTLen*Count*Channels+ch];
            {-- formirov vixod signala -------------------------------------}
            if ClipOutput(pflt,pW,ch) then Result := True;
            inc(count);
         end;
      end;
      // TODO: Alles nochmal pr黤en
      BytesDone := KOL * (Channels*sizeOf(Smallint)) * FFTlen;
      if (BytesDone > 0) then
      begin
         inc(BufOut_Bytes,BytesDone);
         dec(BufIn_Bytes,BytesDone);
         GlobalMoveMem((BufIn+BytesDone)^,BufIn^,BufIn_Bytes);
      end;
      nBytes := Min(Len,BufOut_Bytes);
      GlobalFillMem(pIn^,Len-nBytes,0);
      if (Channels = 2) and (Channel <> chBoth) then
      begin
         pS := Pointer(BufOut+(Len-nBytes)+2*chMin);
         pW := Pointer(pIn+(Len-nBytes)+2*chMin);
         i := 0;
         while i < nBytes div 2 do
         begin
            pW^[i] := pS^[i];
            inc(i,2);
         end;
      end
      else GlobalMoveMem((BufOut+(Len-nBytes))^,(pIn+(Len-nBytes))^,nBytes);
      dec(BufOut_Bytes,nBytes);
      GlobalMoveMem((BufOut+nBytes)^,BufOut^,BufOut_Bytes);
   end;
end;
initialization
   Allocator := TMMAllocator.Create;
finalization
   Allocator.Free;
end.

						