mmfftflt.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: [phone]                   =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  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