1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:

unit FastFrT;
interface
const MaxFrameSize=262144;
      MaxBinPower=18;

type TComplex=record
               re,im:double;
              end;
     TSampleSet=array[0..MaxFrameSize-1]of TComplex;
     PSampleSet=^TSampleSet;
     TExtArray=array[0..999] of extended;
     PExtArray=^TExtArray;

//â㯮© ä¨«ìâà ¨¦¨å ç áâ®â
//ç áâ®â  á१  ¨ ¤¨áªà¥â¨§ æ¨¨ § ¤   ¯àאַ ¢ ª®¤¥ ¢¨§ã
//
procedure KillLow(var Buffer:TSampleSet;var Size:integer);

//¯à®æ¥¤ãà  ¤«ï ¯®¤£®â®¢ª¨ â ¡«¨æ ª®¬¯«¥ªáëå íªá¯®¥â
//¢ë§ë¢ ¥âáï ®¤¨ à § ¯¥à¥¤ ®¡à ¡®âª®© ¥áª®«ìª¨å  ¡®à®¢ ¤ ëå
//á ®¤¨ ª®¢ë¬ à §¬¥à®¬

//ª®«-¢® ®âáç¥â®¢ = 2^LogSize
//Mode - True  ®¡à â®¥
//Mode - False ¯àאַ¥
function  PreFFT(LogSize:byte;Mode:boolean):boolean;

//?ëáâ஥ ¯à¥®¡à §®¢ ¨¥ ”ãà쥠
//t- ¯¥à¨®¤ ®âáç¥â®¢
//Buffer - á®¡á⢥® ¤ ë¥ 
//Mode - True  ®¡à â®¥
//Mode - False ¯àאַ¥

procedure FFT(var Buffer:TSampleSet;Mode:boolean;t:double);

//¢ë¢®¤ ¢ ª®á®«ì á®¤¥à¦¨¬®£®  ¡®à  ¤ ëå
procedure Dump(const T:TSampleSet;Size:integer);

implementation
uses sysutils;
var ExpTable:TSampleSet;
    N:integer;
    LogN:integer;

procedure Dump(const T:TSampleSet;Size:integer);
var ims,res:string;
    i:integer;
begin
 ims:='im: ';
 res:='re: ';
 for i:=0 to Size-1 do begin
  res:=res+Format('%8.2g',[T[i].re]);
  ims:=ims+Format('%8.2g',[T[i].im]);
 end;
 Writeln(res);
 Writeln(ims);
end;

function BinPower(Log:byte):integer;assembler;
asm
 push ecx

 mov ecx,0
 mov cl,Log
 mov eax,1
@lp1: shl eax,1
 loop @lp1

 pop ecx
end;

function BinLog(Value:integer):word;assembler;
asm
 push ebx
 mov bx,0
 mov eax,Value
@lp1:inc bx
 shr eax,1
 jnz @lp1
 dec bx
 mov ax,bx
 pop ebx
end;

function PreFFT(LogSize:byte;Mode:boolean):boolean;
var i:integer;
    Sign:shortint;
begin
 Result:=False;
 if LogSize>MaxBinPower then Exit;
 Result:=True;
 N:=BinPower(LogSize);
 LogN:=LogSize;
 if Mode then
  Sign:=1 else
  Sign:=-1;
 for i:=0 to N-1 do
 begin
  ExpTable[i].Re:=Cos(2*pi*i/N);
  ExpTable[i].Im:=Sign*Sin(2*pi*i/N);
 end;
end;

procedure FFT(var Buffer:TSampleSet;Mode:boolean;t:double);
var i,mm,ll,k,kk,nn,jj,j,nv2{,nm1}:integer;
    c1,c2,c3:TComplex;
    c:double;
begin
 if N<0 then Exit;
 ll:=N+1;
 mm:=1;
 for k:=1 to LogN do
 begin
  nn:=ll div 2;
  jj:=mm;
  i:=0;
  while i<N do
  begin
   kk:=i+nn;

   c1.re:=Buffer[i].re+Buffer[kk].re;
   c1.im:=Buffer[i].im+Buffer[kk].im;
   Buffer[kk].re:=Buffer[i].re-Buffer[kk].re;
   Buffer[kk].im:=Buffer[i].im-Buffer[kk].im;
   Buffer[i].re:=c1.re;
   Buffer[i].im:=c1.im;
   i:=i+ll;

  end;
  if nn>1 then
  begin
   for j:=2 to nn do
   begin
    c2:=ExpTable[jj];
    i:=j-1;
    while i<N do
    begin
     kk:=i+nn;
     c1.re:=Buffer[i].re+Buffer[kk].re;
     c1.im:=Buffer[i].im+Buffer[kk].im;
     c3.re:=Buffer[i].re-Buffer[kk].re;
     c3.im:=Buffer[i].im-Buffer[kk].im;
     Buffer[kk].re:=c3.re*c2.re-c3.im*c2.im;
     Buffer[kk].im:=c3.re*c2.im+c3.im*c2.re;
     Buffer[i].re:=c1.re;
     Buffer[i].im:=c1.im;
     i:=i+ll;
    end;
    jj:=jj+mm;
   end;
   ll:=nn;
   mm:=mm*2;
  end;
 end;

 nv2:=N div 2;
 j:=0;

 for i:=0 to N-2 do
 begin
  if i<j then
  begin
   c1:=Buffer[j];
   Buffer[j]:=Buffer[i];
   Buffer[i]:=c1;
  end;
  k:=nv2;
  while k<j+1 do
  begin
   j:=j-k;
   k:=k div 2;
  end;
  j:=j+k;
 end;
 
 if mode then
  c:=1/(t*N)//îáðàòíûé - True
   else
  c:=t;
 for i:=0 to N-1 do
 with Buffer[i] do
 begin
  im:=im*c;
  re:=re*c;
 end;
end;


//’㯮© ä¨«ìâà ¨¦¨å ç áâ®â - ®â१ ¥â
const FRezatt=4.5;


procedure KillLow(var Buffer:TSampleSet;var Size:integer);
var i,j,bs:integer;
begin
 bs:=Trunc(ln(Size)/ln(2));
 if not PreFFT(bs,False) then
 begin
  Writeln('Žè¨¡ª  ¯à¥®¡à §®¢ ¨ï ”ãàì¥');
  Exit;
 end;
 Size:=BinPower(bs);
 FFT(Buffer,False,1);
 j:=Trunc(FRezatt*Size/2003);//2003 - ç áâ®â  ¤¨áªà¥â¨§ æ¨¨ 
 for i:=0 to j-1 do begin
  Buffer[i].re:=0;
  Buffer[i].im:=0;
  Buffer[Size-i-1].re:=0;
  Buffer[Size-i-1].im:=0;
 end;

 if not PreFFT(bs,True) then
 begin
  Writeln('Žè¨¡ª  ®¡à â®£® ¯à¥®¡à §®¢ ¨ï ”ãàì¥');
  Exit;
 end;
 FFT(Buffer,True,1);
end;

begin
 n:=-1;
end.                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:

(*==========================================================================

    fourier.pas  -  Don Cross <dcross@intersrv.com>

    Modified by Jean Debord <JDebord@compuserve.com> for use with TP Math.

    This is a Turbo Pascal Unit for calculating the Fast Fourier Transform
    (FFT) and the Inverse Fast Fourier Transform (IFFT).
    Visit the following URL for the latest version of this code.
    This page also has a C/C++ version, and a brief discussion of the
    theory behind the FFT algorithm.

       http://www.intersrv.com/~dcross/fft.html#pascal

    Revision history [most recent first]:

2002 January 20 [Jean Debord]
     Modified for use with Delphi 6:
    1. Renamed MaxPower as MaxPowerOfTwo. Interfaced this variable.
       Set its default value to 20.
    2. Changed vector type PVector to dynamic array type TVector.
    3. Used overloaded procedure FFT for both real and integer inputs.
    4. Removed procedure FFT_Integer_Cleanup which was no longer necessary.
    5. Slightly modified function NumberOfBitsNeeded so that Delphi does
       not complain that its value may be undefined.

1998 November 27 [Jean Debord]
     Replaced the constant MAXPOWER by a variable which is initialized
     according to the value of MAX_FLT defined in MATRICES.PAS

1997 March 1 [Jean Debord]
     Modifications for use with the TP Math library:
    1. Added a USES clause for the TP Math units.
    2. Set real type to Float (defined in FMATH.PAS)
    3. Added a constant MAXPOWER to define the maximum number of points.
       Modified functions IsPowerOfTwo and NumberOfBitsNeeded accordingly.
    4. Changed array types to those defined in TP Math. Modified array
       allocation, deallocation and reference accordingly.
    5. Removed compiler directives, which were no longer necessary.
    6. Modified some typographical and formatting options so that the
       code looks like the other TP Math units.
    No modification was made to the original algorithm.

1996 December 11 [Don Cross]
    Improved documentation of the procedure CalcFrequency.
    Fixed some messed up comments in procedure IFFT.

1996 December 6 [Don Cross]
    Made procedure 'fft_integer' more efficient when buffer size changes
    in successive calls:  the buffer is now only resized when the input
    has more samples, not a differing number of samples.
    Also changed the way 'fft_integer_cleanup' works so that it is
    more "bullet-proof".

1996 December 4 [Don Cross]
    Adding the procedure 'CalcFrequency', which calculates the FFT
    at a specific frequency index p=0..n-1, instead of the whole
    FFT.  This is O(n^2) instead of O(n*log(n)).

1996 November 30 [Don Cross]
    Adding a routine to allow FFT of an input array of integers.
    It is called 'fft_integer'.

1996 November 18 [Don Cross]
    Added some comments.

1996 November 17 [Don Cross]
    Wrote and debugged first version.

==========================================================================*)

unit fourier;

interface

uses
  fmath, matrices;

var
  MaxPowerOfTwo : Integer;

(*---------------------------------------------------------------------------
  procedure FFT

  Calculates the Fast Fourier Transform of the array of complex numbers
  represented by 'RealIn' and 'ImagIn' to produce the output complex
  numbers in 'RealOut' and 'ImagOut'.
---------------------------------------------------------------------------*)
procedure FFT(NumSamples                       : Integer;
              RealIn, ImagIn, RealOut, ImagOut : TVector); overload;

(*---------------------------------------------------------------------------
  procedure FFT for integer input arrays.
---------------------------------------------------------------------------*)
procedure FFT(NumSamples       : Integer;
              RealIn, ImagIn   : TIntVector;
              RealOut, ImagOut : TVector); overload;

(*---------------------------------------------------------------------------
  procedure IFFT

  Calculates the Inverse Fast Fourier Transform of the array of complex
  numbers represented by 'RealIn' and 'ImagIn' to produce the output complex
  numbers in 'RealOut' and 'ImagOut'.
---------------------------------------------------------------------------*)
procedure IFFT(NumSamples                       : Integer;
               RealIn, ImagIn, RealOut, ImagOut : TVector);

(*--------------------------------------------------------------------------
   procedure CalcFrequency

   This procedure calculates the complex frequency sample at a given
   index directly.  Use this instead of 'FFT' when you only need one
   or two frequency samples, not the whole spectrum.

   It is also useful for calculating the Discrete Fourier Transform (DFT)
   of a number of data which is not an integer power of 2. For example,
   you could calculate the DFT of 100 points instead of rounding up to
   128 and padding the extra 28 array slots with zeroes.
--------------------------------------------------------------------------*)
procedure CalcFrequency(NumSamples, FrequencyIndex : Integer;
                        RealIn, ImagIn             : TVector;
                        var RealOut, ImagOut       : Float);

implementation

  function IsPowerOfTwo(X : Integer) : Boolean;
  var
    I, Y : Integer;
  begin
    Y := 2;
    for I := 1 to Pred(MaxPowerOfTwo) do
      begin
        if X = Y then
          begin
            IsPowerOfTwo := True;
            Exit;
          end;
        Y := Y shl 1;
      end;
    IsPowerOfTwo := False;
  end;

  function NumberOfBitsNeeded(PowerOfTwo : Integer) : Integer;
  var
    I : Integer;
  begin
    for I := 0 to MaxPowerOfTwo do
      begin
        if (PowerOfTwo and (1 shl I)) <> 0 then
          begin
            NumberOfBitsNeeded := I;
            Exit;
          end;
      end;
    NumberOfBitsNeeded := 0;
  end;

  function ReverseBits(Index, NumBits : Integer) : Integer;
  var
    I, Rev : Integer;
  begin
    Rev := 0;
    for I := 0 to NumBits - 1 do
      begin
        Rev := (Rev shl 1) or (Index and 1);
        Index := Index shr 1;
      end;
    ReverseBits := Rev;
  end;

  procedure FourierTransform(AngleNumerator                   : Float;
                             NumSamples                       : Integer;
                             RealIn, ImagIn, RealOut, ImagOut : TVector);
  var
    NumBits, I, J, K, N, BlockSize, BlockEnd : Integer;
    Delta_angle, Delta_ar                    : Float;
    Alpha, Beta                              : Float;
    Tr, Ti, Ar, Ai                           : Float;
  begin
    if not IsPowerOfTwo(NumSamples) or (NumSamples < 2) then
      begin
        Write('Error in procedure Fourier:  NumSamples=', NumSamples);
        WriteLn(' is not a positive integer power of 2.');
        Halt;
      end;

    NumBits := NumberOfBitsNeeded(NumSamples);
    for I := 0 to NumSamples - 1 do
      begin
        J := ReverseBits(I, NumBits);
        RealOut[J] := RealIn[I];
        ImagOut[J] := ImagIn[I];
      end;

    BlockEnd := 1;
    BlockSize := 2;
    while BlockSize <= NumSamples do
      begin
        Delta_angle := AngleNumerator / BlockSize;
        Alpha := Sin(0.5 * Delta_angle);
        Alpha := 2.0 * Alpha * Alpha;
        Beta := Sin(Delta_angle);

        I := 0;
        while I < NumSamples do 
          begin
            Ar := 1.0;    (* cos(0) *)
            Ai := 0.0;    (* sin(0) *)

            J := I;
            for N := 0 to BlockEnd - 1 do
              begin
                K := J + BlockEnd;
                Tr := Ar * RealOut[K] - Ai * ImagOut[K];
                Ti := Ar * ImagOut[K] + Ai * RealOut[K];
                RealOut[K] := RealOut[J] - Tr;
                ImagOut[K] := ImagOut[J] - Ti;
                RealOut[J] := RealOut[J] + Tr;
                ImagOut[J] := ImagOut[J] + Ti;
                Delta_ar := Alpha * Ar + Beta * Ai;
                Ai := Ai - (Alpha * Ai - Beta * Ar);
                Ar := Ar - Delta_ar;
                Inc(J);
              end;

            I := I + BlockSize;
          end;

        BlockEnd := BlockSize;
        BlockSize := BlockSize shl 1;
      end;
  end;

  procedure FFT(NumSamples                       : Integer;
                RealIn, ImagIn, RealOut, ImagOut : TVector);
  begin
    FourierTransform(2 * PI, NumSamples, RealIn, ImagIn, RealOut, ImagOut);
  end;

  procedure IFFT(NumSamples                       : Integer;
                 RealIn, ImagIn, RealOut, ImagOut : TVector);
  var
    I : Integer;
  begin
    FourierTransform(- 2 * PI, NumSamples, RealIn, ImagIn, RealOut, ImagOut);

    { Normalize the resulting time samples }
    for I := 0 to NumSamples - 1 do
      begin
        RealOut[I] := RealOut[I] / NumSamples;
        ImagOut[I] := ImagOut[I] / NumSamples;
      end;
  end;

var
  RealTemp, ImagTemp : TVector;
  TempArraySize      : Integer;

  procedure FFT(NumSamples       : Integer;
                RealIn, ImagIn   : TIntVector;
                RealOut, ImagOut : TVector); overload;
  var
    I : Integer;
  begin
    if NumSamples > TempArraySize then
      begin
        DimVector(RealTemp, NumSamples);
        DimVector(ImagTemp, NumSamples);
        TempArraySize := NumSamples;
      end;

    for I := 0 to NumSamples - 1 do
      begin
        RealTemp[I] := RealIn[I];
        ImagTemp[I] := ImagIn[I];
      end;

    FourierTransform(2 * PI, NumSamples, RealTemp, ImagTemp, RealOut, ImagOut);
  end;

  procedure CalcFrequency(NumSamples, FrequencyIndex : Integer;
                          RealIn, ImagIn             : TVector;
                          var RealOut, ImagOut       : Float);
  var
    K                             : Integer;
    Cos1, Cos2, Cos3, Theta, Beta : Float;
    Sin1, Sin2, Sin3              : Float;
  begin
    RealOut := 0.0;
    ImagOut := 0.0;
    Theta := 2 * PI * FrequencyIndex / NumSamples;
    Sin1 := Sin(- 2 * Theta);
    Sin2 := Sin(- Theta);
    Cos1 := Cos(- 2 * Theta);
    Cos2 := Cos(- Theta);
    Beta := 2 * Cos2;
    for K := 0 to NumSamples - 1 do
      begin
        { Update trig values }
        Sin3 := Beta * Sin2 - Sin1;
        Sin1 := Sin2;
        Sin2 := Sin3;

        Cos3 := Beta * Cos2 - Cos1;
        Cos1 := Cos2;
        Cos2 := Cos3;

        RealOut := RealOut + RealIn[K] * Cos3 - ImagIn[K] * Sin3;
        ImagOut := ImagOut + ImagIn[K] * Cos3 + RealIn[K] * Sin3;
      end;
  end;

begin
  MaxPowerOfTwo := 20;
  TempArraySize := 0;   { Flag that buffers RealTemp, ImagTemp not allocated }
end.