frmfft.pas

Delphi FFT Spectrum Analyzer

{ **************************************************************************** }
{ FileName............: frmFFT.PAS                                             }
{ Project.............: FFT                                                    }
{ Author(s)...........: M.Majoor                                               }
{ Version.............: 2.00                                                   }
{ Last revision date..: 24 January, 2001                                       }
{ ---------------------------------------------------------------------------- }
{ Fast Fourier Transform application.                                          }
{                                                                              }
{ Version  Date      Comment                                                   }
{ 1.00     19980502  - Initial release                                         }
{ 2.00     20010124  - Recompiled for Delphi 3 and made it up-to-date          }
{                    - For Windows 98/ME we don't seem to get wave data, this  }
{                      was backtraced to the fact that DIGITAL PLAYBACK was set}
{                      ON.                                                     }
{                    - Added MediaPlayer component to control CD (which has    }
{                      the testfiles).                                         }
{                    - Selectable samplerate                                   }
{ BUG: DIVISION BY ZERO SOMETIMES AT 44100 AND POSSIBLE OTHER SAMPLERATE       }
{                                                                              }
{ Note: If using the CD-ROM player make sure you set the DIGITAL PLAYBACK      }
{       option OFF otherwise no data is recorded (although you can hear        }
{       back).                                                                 }
{       MediaPlayer can get into the way ('killed' sound) (shareable?).        }
{ **************************************************************************** }


 // ........... STEREO !!!!!!!!!!!!!!




unit frmfft;

interface

uses
  WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, FFTSpec, ExtCtrls, MMSystem, Mask,
  Math, MPlayer;

type
  TfrmMain = class(TForm)
    btnExit: TBitBtn;
    CBoxWind: TComboBox;
    WeightLabel: TLabel;
    PeakHzText: TLabel;
    HzLabel: TLabel;
    HzText: TLabel;
    AlphaLabel: TLabel;
    BetaLabel: TLabel;
    GammaLabel: TLabel;
    AlphaEdit: TMaskEdit;
    BetaEdit: TMaskEdit;
    GammaEdit: TMaskEdit;
    GainLabel: TLabel;
    WavePaintBox: TPaintBox;
    FFTPaintBox: TPaintBox;
    FreqBarPaintBox: TPaintBox;
    LogBarPaintBox: TPaintBox;
    PeakDbText: TLabel;
    DbText: TLabel;
    DbLabel: TLabel;
    WaveLabel: TLabel;
    FFTLabel: TLabel;
    DbLogLabel: TLabel;
    FreqLabel: TLabel;
    FilterPanel: TPanel;
    LowPassPaintBox: TPaintBox;
    HighPassPaintBox: TPaintBox;
    FreqFilterLabel: TLabel;
    FreqScrollBar: TScrollBar;
    LowLabel: TLabel;
    HighLabel: TLabel;
    FilterText: TLabel;
    SpectrogramBox: TCheckBox;
    SpectrogramHLabel: TLabel;
    SpectrogramVLabel: TLabel;
    MediaPlayer1: TMediaPlayer;
    lblCD: TLabel;
    Label2: TLabel;
    CBoxSamplerate: TComboBox;
    Label1: TLabel;
    CBoxFFTSize: TComboBox;
    procedure btnExitClick(Sender: TObject);
    procedure CBoxWindChange(Sender: TObject);
    procedure StartRecording;
    procedure StopRecording;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure AlphaEditChange(Sender: TObject);
    procedure BetaEditChange(Sender: TObject);
    procedure GammaEditChange(Sender: TObject);
    procedure FreqBarPaintBoxPaint(Sender: TObject);
    procedure LogBarPaintBoxPaint(Sender: TObject);
    procedure FreqScrollBarChange(Sender: TObject);
    procedure SpectrogramBoxClick(Sender: TObject);
    procedure CreateColorPalette;
    procedure CBoxSamplerateChange(Sender: TObject);
  private
  public
    { Public declarations }
  end;

const
  MaxDb         = 70;                                      { Display max db }
  num_buf       = 8;                                       { Number of buffers  }
//  SampleRate    = 44100;//8000;
  Channels      = 1;
  BitsPerSample = 16;
//  BufferLength  = cbBuf * Channels * (BitsPerSample div 8);
//  FreqMult      = SampleRate/cbBuf;
//  MaxIndex      = trunc((SampleRate div 2)/FreqMult);      { Max index for max freq determination }
  MaxInput      = $7FFF;                                   { Max input FFT }
//  MaxOutput     = (MaxInput * cbBuf) div 2;                { 0 db Value = max output FFT }

var
  FFTSize         : word;
  cbBuf           : word;
  BufferLength    : longint;
  MaxOutput       : longint;
  Samplerate      : DWORD;
  FreqMult        : single;
  MaxIndex        : word;
  frmMain         : TfrmMain;
  ColorArray      : array[0..255] of TColor;
  GoingUp         : boolean;
  WaveInHandle    : HWAVEIN;
  WaveFormat      : TWAVEFORMATEX;
  pBuf            : array[1..num_buf] of pointer;          { Pool of buffers }
  header          : array[1..num_buf] of TWaveHdr;         { Pool of headers }
  FreeBuffer      : smallint;
  WindowFunction  : SpectrumWindows;
  OutRealFFT      : PFFTArray;
  SourceHalfHeight: integer;                               { Wave display half height }
  SourceScale     : single;                                { Multiplier to fit window }
  FFTHeight       : integer;                               { FFT display height }
  FFTScale        : single;                                { Multiplier to fit window FFT }
  SpectroCScale   : single;                                { Multiplier to translate result FFT to color }
  SpectroHScale   : single;                                { Multiplier to fit window Spectrogram }
  FilterScale     : single;                                { Multiplier to fit window }
  FilterFreq      : integer;
  SpectrogramIndex: integer;                               { Horizontal position spectrogram }
  MaxColor        : integer;

  Lines       : array[0..$FFFF] of TPoint;
  LinesFFT    : array[0..$FFFF] of TPoint;
  
implementation

{$R *.DFM}


{ **************************************************************************** }
{ Params   : <Sender>  Sender object                                           }
{ Return   : -                                                                 }
{                                                                              }
{ Descript : Exit button.                                                      }
{ Notes    :                                                                   }
{ **************************************************************************** }
procedure TfrmMain.btnExitClick(Sender: TObject);
begin
  Application.Terminate;
end;


{ **************************************************************************** }
{ Params   : -                                                                 }
{ Return   : -                                                                 }
{                                                                              }
{ Descript : Create 6*6*6 rainbow color palette.                               }
{ Notes    :                                                                   }
{ **************************************************************************** }
procedure TfrmMain.CreateColorPalette;
var
  Chunks    : integer;
  ColorChunk: integer;
  r,g,b     : BYTE;
  i         : integer;
begin
  Chunks := 6;
  ColorChunk := (6*6*6) div Chunks;

  r := 255;                                                { Red to Yellow }
  b := 0;
  for i := 0 to ColorChunk do
  begin
    g:= (255 div ColorChunk) * i;
    ColorArray[i] := RGB(r, g, b);
  end;
  g:=255;                                                  { Yellow to Green }
  b:=0;
  for i := ColorChunk  to (ColorChunk * 2) do
  begin
    r := 255 - (255 div ColorChunk) * (i - ColorChunk);
    ColorArray[i] := RGB(r, g, b);
  end;
  r:=0;                                                    { Green to Cyan }
  g:=255;
  for i:= (ColorChunk * 2) to (ColorChunk * 3) do
  begin
    b := (255 div ColorChunk)*(i - ColorChunk * 2);
    ColorArray[i] := RGB(r, g, b);
  end;
  r := 0;                                                  { Cyan to Blue }
  b := 255;
  for i:= (ColorChunk * 3) to (ColorChunk * 4) do
  begin
    g := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3));
    ColorArray[i] := RGB(r, g, b);
  end;
  g := 0;                                                  { Blue to Magenta }
  b := 255;
  for i:= (ColorChunk * 4) to (ColorChunk * 5) do
  begin
    r := (255 div ColorChunk) * (i - ColorChunk * 4);
    ColorArray[i] := RGB(r, g, b);
  end;
//  g := 0;                                                { Magenta to Black }
//  b := 255;
  for i:= (ColorChunk * 5) to (ColorChunk * 6) do
  begin
    r := 255 - (255 div ColorChunk) * (i - ColorChunk * 5);
    ColorArray[i] := RGB(r, 0, r);
  end;
  MaxColor := ColorChunk * 6;
end;


{ **************************************************************************** }
{ Params   : <Sender>  Sender object                                           }
{ Return   : -                                                                 }
{                                                                              }
{ Descript : Change of windowing function.                                     }
{ Notes    :                                                                   }
{ **************************************************************************** }
procedure TfrmMain.CBoxWindChange(Sender: TObject);
begin
  if CBoxWind.Text = 'None' then
    WindowFunction := idRectangle;
  if CBoxWind.Text = 'Rectangle' then
    WindowFunction := idRectangle;
  if CBoxWind.Text = 'Triangle' then
    WindowFunction := idTriangle;
  if CBoxWind.Text = 'Gaussian' then
    WindowFunction := idGaussian;
  if CBoxWind.Text = 'Hamming' then
    WindowFunction := idHamming;
  if CBoxWind.Text = 'Blackman' then
    WindowFunction := idBlackman;
  if CBoxWind.Text = 'Cos2' then
    WindowFunction := idCos2;
  if CBoxWind.Text = 'CosineBell' then
    WindowFunction := idCos2;
  if CBoxWind.Text = 'VonHann' then
    WindowFunction := idCos2;
  if CBoxWind.Text = 'Kaiser-Bessel' then
    WindowFunction := idKaiser;
  case WindowFunction of
    idBlackman : begin
                   AlphaEdit.Text := format('%1.2f',[BlackmanAlpha]);
                   AlphaEdit.Visible := true;
                   BetaEdit.Text  := format('%1.2f',[BlackmanBeta]);
                   BetaEdit.Visible  := true;
                   GammaEdit.Text := format('%1.2f',[BlackmanGamma]);
                   GammaEdit.Visible := true;
                   AlphaLabel.Visible := true;
                   BetaLabel.Visible  := true;
                   GammaLabel.Visible := true;
                 end;
    idGaussian : begin
                   AlphaEdit.Text := format('%1.2f',[GaussianAlpha]);
                   AlphaEdit.Visible := true;
                   BetaEdit.Visible  := false;
                   GammaEdit.Visible := false;
                   AlphaLabel.Visible := true;
                   BetaLabel.Visible  := false;
                   GammaLabel.Visible := false;
                 end;
    idHamming  : begin
                   AlphaEdit.Text := format('%1.2f',[HammingAlpha]);
                   AlphaEdit.Visible := true;
                   BetaEdit.Visible  := false;
                   GammaEdit.Visible := false;
                   AlphaLabel.Visible := true;
                   BetaLabel.Visible  := false;
                   GammaLabel.Visible := false;
                 end;
    idKaiser   : begin
                   AlphaEdit.Text := format('%1.2f',[KaiserAlpha]);
                   AlphaEdit.Visible := true;
                   BetaEdit.Visible  := false;
                   GammaEdit.Visible := false;
                   AlphaLabel.Visible := true;
                   BetaLabel.Visible  := false;
                   GammaLabel.Visible := false;
                 end;
    else begin
           AlphaEdit.Visible := false;
           BetaEdit.Visible  := false;
           GammaEdit.Visible := false;
           AlphaLabel.Visible := false;
           BetaLabel.Visible  := false;
           GammaLabel.Visible := false;
         end;
  end;