 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2001, <kouriakine@mail.ru>
 This unit provides procedures for performing fast fourier transforms
 and other utils.
 Modifications:
 20011218 - Creation (uses CRW16), should be tested
 ****************************************************************************
 }

unit _FFT; { Fast Fourier Transform }

{$I _sysdef}

interface

uses
 _alloc,
 _ef,
 _zm
 ;

 {
 Быстрое комплексное преобразование Фурье.
 Если NumPoints=степень двух,то применяется быстрое преобразование
 на основе алгоритма Кули-Тьюки; иначе-дискретное преобразование.
 Возвращает False при недопустимом вызове или нехватке памяти.
 }
function FFT(N:Integer; Re,Im:PDoubleArray; Inverse:Boolean):Boolean;

 {
 процедура преобразует фурье-преобразованние сигнала после FFT так что сетка
 w(n)=2*pi*n/N,n=0..N-1, w в интервале [0..2*pi] переходит в сетку
 w(n)=pi*n/int(N/2),n=-int(N/2)..int(N/2) ,w в интервале [-pi..pi]
 либо наоборот (invers=true) подготавливает данные,заданные на
 w=[-pi,pi] для проведения FFT.
 }
function FFTShift(N:Integer; Re,Im:PDoubleArray; Inverse:Boolean):Boolean;

 {
 процедура выполняет FFT с возможным сдвигом
 }
function ShiftedFFT(N:Integer; Re,Im:PDoubleArray; Inverse,ShiftIn,ShiftOut:Boolean):boolean;

 {
 Свертка Y(n)=X(k-n)*H(n).Результат возвращается в X.Вычисляется через FFT.
 Для реальных данных допустимо задать XIm=nil,HIm=nil
 Возвращает False при недопустимом вызове или нехватке памяти.
 }
function FFTConv(N:Integer; XRe,XIm,HRe,HIm:PDoubleArray):Boolean;

 {
 Фильтрация при помощи Фурье-преобразования с наложением аналогового
 фильтра,заданного функциями Fre,Fim на интервале Найквиста[-1,1].
 Допустимо Xim=nil или Fim=nil для реальных данных.
 }
function FFT_Filter(N:Integer; Re,Im:PDoubleArray; FRe,FIm:zmFunType):Boolean;

{
 Перевод номера фурье-гармоники в частоту Найквиста в [-1..1].
}
function FFT_Freq(index,NumPoints:Integer):double;

 {
 Комплексное умножение Z=X*Y элементов массива
 }
function VecMult(N:Integer; ZRe,ZIm,XRe,XIm,YRe,YIm:PDoubleArray):Boolean;

{
 Быстрое построение таблицы Sin,Cos,в массиве размера N.
 CosTable(i)=Cos(x0+(i-1)*dx),SinTable(i)=Sin(x0+(i-1)*dx),i=1..N
}
function GetSinCosTable(N:Integer; SinTable,CosTable:PDoubleArray; x0,dx:Extended):Boolean;

{
 Быстрое построение таблицы Sin,Cos,для FFT pазмера N.
}
function FFTSinCosTable(N:Integer; SinTable,CosTable:PDoubleArray):Boolean;

{
 Проверка на пригодность для быстрого Фурье-преобразования (степень 2).
}
function FFT_TestInput(N:Integer; var NumberOfBits:Byte):Boolean;

 {
 Базовые процедуры быстрого Фурье-преобразования.
 FFT реализует быстрый алгоритм Кули-Тьюки для числа точек 2^N.
 DFT реализует 'медленное' дискретное преобразование Фурье для любого
 числа точек.
 Перед использованием надо вызвать FFT_TestInput и FFTSinCosTable.
 BaseFFT допустимо,если FFT_TestInput=true.
 }
function BaseDFT(N:Integer; Inverse:boolean; Re,Im,SinTable,CosTable:PDoubleArray):Boolean;
function BaseFFT(N:Integer; Inverse:Boolean; Re,Im,SinTable,CosTable:PDoubleArray):Boolean;


implementation

function FFT(N:Integer; Re,Im:PDoubleArray; Inverse:Boolean):Boolean;
var NumBits:Byte; SinTable,CosTable:PDoubleArray;
begin
 Result:=false;
 if Assigned(Re) and Assigned(Im) and (N>=2) then begin
  SinTable:=Allocate(N*sizeof(double));
  CosTable:=Allocate(N*sizeof(double));
  if FFTSinCosTable(N,SinTable,CosTable) then begin
   if FFT_TestInput(N,NumBits)
   then Result:=BaseFFT(N,Inverse,Re,Im,SinTable,CosTable)
   else Result:=BaseDFT(N,Inverse,Re,Im,SinTable,CosTable);
  end;
  Deallocate(Pointer(SinTable));
  Deallocate(Pointer(CosTable));
 end;
end;

function FFTShift(N:Integer; Re,Im:PDoubleArray; Inverse:Boolean):Boolean;
var Dummy:PDoubleArray; i,N21,N2:Integer;
begin
 Result:=false;
 if N>=2 then begin
  if Inverse then begin
   N2:=N shr 1;
   N21:=N-N2;
  end else begin
   N21:=N shr 1;
   N2:=N-N21;
  end;
  Dummy:=Allocate(N2*sizeof(double));
  if Assigned(Dummy) then begin
   if Assigned(Re) then begin
    for i:=0 to N2-1 do dummy[i]:=Re[i];
    for i:=0 to N21-1 do Re[i]:=Re[N2+i];
    for i:=0 to N2-1 do Re[N21+i]:=dummy[i];
   end;
   if Assigned(Im) then begin
    for i:=0 to N2-1 do dummy[i]:=Im[i];
    for i:=0 to N21-1 do Im[i]:=Im[N2+i];
    for i:=0 to N2-1 do Im[N21+i]:=dummy[i];
   end;
   Result:=true;
  end;
  Deallocate(Pointer(dummy));
 end;
end;

function ShiftedFFT(N:Integer; Re,Im:PDoubleArray; Inverse,ShiftIn,ShiftOut:Boolean):Boolean;
begin
 Result:=true;
 if ShiftIn then Result:=Result and FFTShift(N,Re,Im,true);
 Result:=Result and FFT(N,Re,Im,Inverse);
 if ShiftOut then Result:=Result and FFTShift(N,Re,Im,false);
end;

function FFTConv(N:Integer; XRe,XIm,HRe,HIm:PDoubleArray):Boolean;
var x,h:boolean;
begin
 Result:=false;
 if (N>=2) then begin
  x:=not Assigned(XIm);
  h:=not Assigned(HIm);
  if x then XIm:=Allocate(N*sizeof(double));
  if h then HIm:=Allocate(N*sizeof(double));
  FFTConv:=FFT(N,XRe,XIm,false) and
           FFT(N,HRe,HIm,false) and
           VecMult(N,XRe,XIm,XRe,XIm,HRe,HIm) and
           FFT(N,XRe,XIm,true);
  if x then Deallocate(Pointer(XIm));
  if h then Deallocate(Pointer(HIm));
 end;
end;

function FFT_Filter(N:Integer; Re,Im:PDoubleArray; FRe,FIm:zmFunType):boolean;
var i:Integer; tmp,f,fr,fi:double; bi:boolean;
begin
 Result:=false;
 if Assigned(Re) and Assigned(Im) and (N>=2) then begin
  bi:=not Assigned(Im);
  if bi then Im:=Allocate(N*sizeof(double));
  if FFT(N,Re,Im,false) then begin
   for i:=0 to N-1 do begin
    f:=fft_freq(i,N);
    if Assigned(FRe) then fr:=FRe(f,nil) else fr:=0;
    if Assigned(Fim) then fi:=FIm(f,nil) else fi:=0;
    tmp:=Re[i]*fr-Im[i]*fi;
    Im[i]:=Im[i]*fr+Re[i]*fi;
    Re[i]:=tmp;
   end;
   Result:=FFT(N,Re,Im,true);
  end;
  if bi then Deallocate(Pointer(Im));
 end;
end;

function FFT_Freq(index,NumPoints:Integer):double;
var Half:Integer;
begin
 Half:=NumPoints shr 1;
 if index<=Half then Result:=index/Half else Result:=index/(Half-NumPoints);
end;

function VecMult(N:Integer; ZRe,ZIm,XRe,XIm,YRe,YIm:PDoubleArray):Boolean;
var i:Integer; Dummy:Double;
begin
 Result:=false;
 if (ZRe=nil) or (XRe=nil) or (YRe=nil) or (N<1) then exit;
 if (ZIm<>nil) and ( (XIm=nil) or (YIm=nil) ) then exit;
 if (ZIm<>nil) then begin
  for i:=0 to N-1 do begin
   Dummy:=XRe[i]*YRe[i]-XIm[i]*YIm[i];
   ZIm[i]:=XRe[i]*YIm[i]+XIm[i]*YRe[i];
   ZRe[i]:=Dummy;
  end;
 end else for i:=0 to N-1 do ZRe[i]:=XRe[i]*YRe[i];
 Result:=true;
end;

function GetSinCosTable(N:Integer;SinTable,CosTable:PDoubleArray; x0,dx:Extended):Boolean;
var i:Integer; Sine,Cosine,NextSine,NextCosine,RealFactor,ImagFactor:Extended;
begin
 Result:=false;
 if Assigned(CosTable) and Assigned(SinTable) and (N>=2) then begin
  Result:=true;
  RealFactor:=Cos(dx);
  ImagFactor:=Sin(dx);
  Cosine:=Cos(x0);
  Sine:=Sin(x0);
  for i:=0 to N-1 do  begin
   CosTable[i]:=Cosine;
   SinTable[i]:=Sine;
   NextCosine:=Cosine*RealFactor-Sine*ImagFactor;
   NextSine:=Cosine*ImagFactor+Sine*RealFactor;
   Cosine:=NextCosine;
   Sine:=NextSine;
  end;
 end;
end;

function FFTSinCosTable(N:Integer;SinTable,CosTable:PDoubleArray):boolean;
begin
 FFTSinCosTable:=GetSinCosTable(N,SinTable,CosTable,0,-2*Pi/N);
end;

function FFT_TestInput(N:Integer; var NumberOfBits:Byte):Boolean;
var Term:Byte; Num:Integer;
begin
 Result:=false;
 if N>=2 then begin
  Num:=2;
  for Term:=1 to 31 do begin
   if N = Num then  begin
    NumberOfBits := Term;
    Result:= true;
    break;
   end;
   Num:=Num shl 1;
  end;
 end;
end;

function BaseDFT(N:Integer; Inverse:Boolean; Re,Im,SinTable,CosTable:PDoubleArray):boolean;
var i,k,index:Integer; Id,Rd:Double; YRe,YIm:PDoubleArray;
begin
 Result:=false;
 if (N>=2) and Assigned(Re) and Assigned(Im) and Assigned(SinTable) and Assigned(CosTable) then begin
  YRe:=Allocate(N*sizeof(Double));
  YIm:=Allocate(N*sizeof(Double));
  if Assigned(YRe) and Assigned(YIm) then begin
   Result:=true;
   Rd:=1/sqrt(N);
   Id:=Rd;
   if Inverse then begin
    Id:=-Id;{complex conjugate output}
    for i:=0 to N-1 do Im[i]:=-Im[i]; {complex conjugate input}
   end;
   for i:=0 to N-1 do begin
    YRe[i]:=0;
    YIm[i]:=0;
    for k:=0 to N-1 do begin
     index:=(i*k) mod N;
     YRe[i]:=YRe[i]+Re[k]*CosTable[index]-Im[k]*SinTable[index];
     YIm[i]:=YIm[i]+Re[k]*SinTable[index]+Im[k]*CosTable[index];
    end;
   end;
   for i:=0 to N-1 do begin
    Re[i]:=YRe[i]*Rd;
    Im[i]:=YIm[i]*Id;
   end;
  end;
  Deallocate(Pointer(YRe));
  Deallocate(Pointer(YIm));
 end;
end;

function BaseFFT(N:Integer; Inverse:Boolean; Re,Im,SinTable,CosTable:PDoubleArray):boolean;
const
 RootTwoOverTwo = 0.707106781186548;
var
 NumberOfBits : Byte;
 Term, CellSeparation, NumberOfCells, NumElementsInCell, NumElInCellLess1,
 NumElInCellSHR1, NumElInCellSHR2, Element, CellElements,ElementInNextCell,
 Index : Integer;
 RealRootOfUnity, ImagRootOfUnity, RealDummy, ImagDummy : double;
 {
 BitInvert
 ----------------------------------------------------------
 Input: NumberOfBits, N
 Output: Re, Im

 This procedure bit inverts the order of data in the
 vector X.  Bit inversion reverses the order of the
 binary representation of the indices; thus 2 indices
 will be switched.  For example, if there are 16 points,
 Index 7 (binary 0111) would be switched with Index 14
 (binary 1110).  It is necessary to bit invert the order
 of the data so that the transformation comes out in the
 correct order.
 ----------------------------------------------------------
 }
 procedure BitInvert(NumberOfBits : integer;
                     N    : integer;
                 var Re        : array of double;
                 var Im        : array of double);
 var
   Term, Invert, NumPointsDiv2, K : integer;
   Hold : double;
 begin
   NumPointsDiv2 := N shr 1;
   Invert := 0;
   for Term := 0 to N - 2 do begin
     if Term < Invert then begin { Switch these two indices  }
       Hold := Re[Invert];
       Re[Invert] := Re[Term];
       Re[Term] := Hold;
       Hold := Im[Invert];
       Im[Invert] := Im[Term];
       Im[Term] := Hold;
     end;
     K := NumPointsDiv2;
     while K <= Invert do begin
       Invert := Invert - K;
       K := K shr 1;
     end;
     Invert := Invert + K;
   end;
 end;
begin
 Result:=false;
 if FFT_TestInput(N,NumberOfBits) and Assigned(Re) and Assigned(Im) and
    Assigned(SinTable) and Assigned(CosTable)
 then begin
  Result:=true;
  {
  The data must be entered in bit inverted order for the transform
  to come out in proper order
  }
  BitInvert(NumberOfBits, N, Re[0], Im[0]);
  {
  Conjugate the input ?
  }
  if Inverse then
  for Element := 0 to N - 1 do Im[Element] := -Im[Element];

  NumberOfCells := N;
  CellSeparation := 1;
  for Term := 1 to NumberOfBits do begin
    { NumberOfCells halves; equals 2^(NumberOfBits - Term)  }
    NumberOfCells := NumberOfCells shr 1;
    { NumElementsInCell doubles; equals 2^(Term-1)  }
    NumElementsInCell := CellSeparation;
    { CellSeparation doubles; equals 2^Term  }
    CellSeparation := CellSeparation SHL 1;
    NumElInCellLess1 := NumElementsInCell - 1;
    NumElInCellSHR1 := NumElementsInCell shr 1;
    NumElInCellSHR2 := NumElInCellSHR1 shr 1;

    { Special case: RootOfUnity = EXP(-i 0)  }
    Element := 0;
    while Element < N do begin
      { Combine the X[Element] with the element in the identical
      location in the next cell }
      ElementInNextCell := Element + NumElementsInCell;
      RealDummy := Re[ElementInNextCell];
      ImagDummy := Im[ElementInNextCell];
      Re[ElementInNextCell] := Re[Element] - RealDummy;
      Im[ElementInNextCell] := Im[Element] - ImagDummy;
      Re[Element] := Re[Element] + RealDummy;
      Im[Element] := Im[Element] + ImagDummy;
      Element := Element + CellSeparation;
    end;

    for CellElements := 1 to NumElInCellSHR2 - 1 do begin
      Index := CellElements * NumberOfCells;
      RealRootOfUnity := CosTable[Index];
      ImagRootOfUnity := SinTable[Index];
      Element := CellElements;

      while Element < N do begin
        { Combine the X[Element] with the element in  }
        { the identical location in the next cell     }
        ElementInNextCell := Element + NumElementsInCell;
        RealDummy := Re[ElementInNextCell] * RealRootOfUnity -
                     Im[ElementInNextCell] * ImagRootOfUnity;
        ImagDummy := Re[ElementInNextCell] * ImagRootOfUnity +
                     Im[ElementInNextCell] * RealRootOfUnity;
        Re[ElementInNextCell] := Re[Element] - RealDummy;
        Im[ElementInNextCell] := Im[Element] - ImagDummy;
        Re[Element] := Re[Element] + RealDummy;
        Im[Element] := Im[Element] + ImagDummy;
        Element := Element + CellSeparation;
      end;
    end;

    { Special case: RootOfUnity = EXP(-i PI/4)  }
    if Term > 2 then begin
      Element := NumElInCellSHR2;
      while Element < N do begin
        { Combine the X[Element] with the element in the identical
        location in the next cell }
        ElementInNextCell := Element + NumElementsInCell;
        RealDummy := RootTwoOverTwo * (Re[ElementInNextCell] +
                     Im[ElementInNextCell]);
        ImagDummy := RootTwoOverTwo * (Im[ElementInNextCell] -
                     Re[ElementInNextCell]);
        Re[ElementInNextCell] := Re[Element] - RealDummy;
        Im[ElementInNextCell] := Im[Element] - ImagDummy;
        Re[Element] := Re[Element] + RealDummy;
        Im[Element] := Im[Element] + ImagDummy;
        Element := Element + CellSeparation;
      end;
    end;

    for CellElements := NumElInCellSHR2 + 1 to NumElInCellSHR1 - 1 do
    begin
      Index := CellElements * NumberOfCells;
      RealRootOfUnity := CosTable[Index];
      ImagRootOfUnity := SinTable[Index];
      Element := CellElements;
      while Element < N do begin
        { Combine the X[Element] with the element in the identical
        location in the next cell }
        ElementInNextCell := Element + NumElementsInCell;
        RealDummy := Re[ElementInNextCell] * RealRootOfUnity -
                     Im[ElementInNextCell] * ImagRootOfUnity;
        ImagDummy := Re[ElementInNextCell] * ImagRootOfUnity +
                     Im[ElementInNextCell] * RealRootOfUnity;
        Re[ElementInNextCell] := Re[Element] - RealDummy;
        Im[ElementInNextCell] := Im[Element] - ImagDummy;
        Re[Element] := Re[Element] + RealDummy;
        Im[Element] := Im[Element] + ImagDummy;
        Element := Element + CellSeparation;
      end;
    end;

    { Special case: RootOfUnity = EXP(-i PI/2)  }
    if Term > 1 then begin
      Element := NumElInCellSHR1;
      while Element < N do begin
        { Combine the X[Element] with the element in  }
        { the identical location in the next cell     }
        ElementInNextCell := Element + NumElementsInCell;
        RealDummy :=  Im[ElementInNextCell];
        ImagDummy := -Re[ElementInNextCell];
        Re[ElementInNextCell] := Re[Element] - RealDummy;
        Im[ElementInNextCell] := Im[Element] - ImagDummy;
        Re[Element] := Re[Element] + RealDummy;
        Im[Element] := Im[Element] + ImagDummy;
        Element := Element + CellSeparation;
      end;
    end;

    for CellElements := NumElInCellSHR1 + 1 to
                        NumElementsInCell - NumElInCellSHR2 - 1 do
    begin
      Index := CellElements * NumberOfCells;
      RealRootOfUnity := CosTable[Index];
      ImagRootOfUnity := SinTable[Index];
      Element := CellElements;
      while Element < N do begin
        { Combine the X[Element] with the element in the identical
        location in the next cell }
        ElementInNextCell := Element + NumElementsInCell;
        RealDummy := Re[ElementInNextCell] * RealRootOfUnity -
                     Im[ElementInNextCell] * ImagRootOfUnity;
        ImagDummy := Re[ElementInNextCell] * ImagRootOfUnity +
                     Im[ElementInNextCell] * RealRootOfUnity;
        Re[ElementInNextCell] := Re[Element] - RealDummy;
        Im[ElementInNextCell] := Im[Element] - ImagDummy;
        Re[Element] := Re[Element] + RealDummy;
        Im[Element] := Im[Element] + ImagDummy;
        Element := Element + CellSeparation;
      end;
    end;

    { Special case: RootOfUnity = EXP(-i 3PI/4)  }
    if Term > 2 then begin
      Element := NumElementsInCell - NumElInCellSHR2;
      while Element < N do begin
        { Combine the X[Element] with the element in  }
        { the identical location in the next cell     }
        ElementInNextCell := Element + NumElementsInCell;
        RealDummy := -RootTwoOverTwo * (Re[ElementInNextCell] -
                                        Im[ElementInNextCell]);
        ImagDummy := -RootTwoOverTwo * (Re[ElementInNextCell] +
                                        Im[ElementInNextCell]);
        Re[ElementInNextCell] := Re[Element] - RealDummy;
        Im[ElementInNextCell] := Im[Element] - ImagDummy;
        Re[Element] := Re[Element] + RealDummy;
        Im[Element] := Im[Element] + ImagDummy;
        Element := Element + CellSeparation;
      end;
    end;

    for CellElements := NumElementsInCell - NumElInCellSHR2 + 1 to
                                            NumElInCellLess1 do
    begin
      Index := CellElements * NumberOfCells;
      RealRootOfUnity := CosTable[Index];
      ImagRootOfUnity := SinTable[Index];
      Element := CellElements;
      while Element < N do begin
        { Combine the X[Element] with the element in the identical
        location in the next cell }
        ElementInNextCell := Element + NumElementsInCell;
        RealDummy := Re[ElementInNextCell] * RealRootOfUnity -
                     Im[ElementInNextCell] * ImagRootOfUnity;
        ImagDummy := Re[ElementInNextCell] * ImagRootOfUnity +
                     Im[ElementInNextCell] * RealRootOfUnity;
        Re[ElementInNextCell] := Re[Element] - RealDummy;
        Im[ElementInNextCell] := Im[Element] - ImagDummy;
        Re[Element] := Re[Element] + RealDummy;
        Im[Element] := Im[Element] + ImagDummy;
        Element := Element + CellSeparation;
      end;
    end;
  end;
  {
  ---------------------------------------------------
    Divide all the values of the transformation
    by the square root of N. If taking the
    inverse, conjugate the output.
  ---------------------------------------------------
  }
  if Inverse then ImagDummy:=-1/Sqrt(N) else ImagDummy:=+1/Sqrt(N);
  RealDummy:=ABS(ImagDummy);
  for Element:=0 to N-1 do begin
   Re[Element]:=Re[Element]*RealDummy;
   Im[Element]:=Im[Element]*ImagDummy;
  end;
 end;
end;

end.

