frmfft.pas

Delphi FFT Spectrum Analyzer

  GainLabel.Caption := format('Correction gain: %1.2f',[CoherentGain[WindowFunction]]);
end;


{ **************************************************************************** }
{ Params   : ....                                                              }
{ Return   : -                                                                 }
{                                                                              }
{ Descript : Callback function for Wave Input. This is the 'workhorse' part of }
{            of the application because this is called for every filled buffer.}
{ Notes    : See TFNDrvCallBack for definition.                                }
{ **************************************************************************** }
procedure Callback(hdrvr: HDRVR; uMsg: UINT; dwUser: DWORD;
                   dw1, dw2: DWORD) stdcall;
var
  TheBuffer   : smallint;
  i           : smallint;
  Temp        : single;
  TempH       : single;
  Max         : single;
  MaxHz       : single;
  MaxDbV      : single;
  Peak        : longint;
  PeakY       : longint;
  HzStr       : string;
  DbStr       : string;
  PeakLow     : single;
  PeakHigh    : single;
  LowHighIndex: integer;
begin
  case uMsg of
    MM_WIM_DATA  :
      begin
        { First determine which waverecording-buffer is full (we assume it is full...) }
        TheBuffer := PWaveHdr(dw1).dwUser;
        { Next release buffer for waverecording }
        WaveInUnPrepareHeader(WaveInhandle, @header[TheBuffer], sizeof(TWaveHdr));
        { Next give waverecording new buffer }
        header[FreeBuffer].lpData := pbuf[FreeBuffer];
        header[FreeBuffer].dwBufferLength := BufferLength;
        header[FreeBuffer].dwUser  := FreeBuffer;
        header[FreeBuffer].dwFlags := 0;
        header[FreeBuffer].dwLoops := 0;
        header[FreeBuffer].Reserved:= 0;
        WaveInPrepareHeader(WaveInhandle, @header[FreeBuffer], sizeof(TWaveHdr));
        WaveInAddBuffer(WaveInhandle, @header[FreeBuffer], sizeof(TWaveHdr));
        FreeBuffer := TheBuffer;                { Released buffer is now free }
        { Display wave-buffer }
        for i:=0 to FFTSize-1 do
        begin
          Lines[i].x := i;
          Temp := PFFTArray2(pbuf[TheBuffer])[i] * SourceScale;
          Lines[i].y := SourceHalfHeight - trunc(Temp);
        end;
        frmMain.WavePaintBox.Canvas.FillRect(frmMain.WavePaintBox.ClientRect);
        frmMain.WavePaintBox.Canvas.PolyLine(Slice(Lines, FFTSize));

        { Do FFT on wave-buffer, use integer input }
        Spectrum2(WindowFunction, FFTSize, pbuf[TheBuffer], OutRealFFT);
        { Determine min/max FFT for additional display and filter }
        Max      := 0;
        Peak     := 0;
        PeakY    := 0;
        PeakLow  := 0;
        PeakHigh := 0;
        LowHighIndex := trunc(FilterFreq/FreqMult);        { Low/high pass border }
        for i := 3 to MaxIndex do
        begin
          if i <= LowHighIndex then
          begin
            if OutRealFFT^[i] > PeakLow then PeakLow := OutRealFFT^[i];
          end
          else
          begin
            if OutRealFFT^[i] > PeakHigh then PeakHigh := OutRealFFT^[i];
          end;
          if OutRealFFT^[i]>Max then
          begin
            Max  := OutRealFFT^[i];
            Peak := i;
          end;
        end;
        { Display FFT as either spectrogram or frequency }
        if frmMain.SpectrogramBox.Checked then
        begin
          { If FFT to display as spectrogram }
          for i := 3 to MaxIndex do
          begin
            Temp := log10(OutRealFFT^[i]/MaxOutput) * SpectroCScale; {To color }
            if Temp>MaxColor then Temp := MaxColor;
            TempH := SpectroHScale * i;
            TempH := frmMain.FFTPaintBox.Height - TempH;
            { Capture out of bounds exceptions }
            try
              frmMain.FFTPaintBox.Canvas.Pixels[SpectrogramIndex, trunc(TempH)]:= ColorArray[trunc(Temp)];
            except
            end;
          end;
          inc(SpectrogramIndex);
          if SpectrogramIndex > frmMain.FFTPaintBox.Width then
            SpectrogramIndex := 0;
        end
        else
        begin
          { If FFT to display as frequency }
          for i := 0 to 2 do        { First 3 point are invalid (always some signal) }
          begin
            LinesFFT[i].x := i;
            LinesFFT[i].y := frmMain.FFTPaintBox.Height;
          end;
          for i := 3 to MaxIndex do
          begin
            LinesFFT[i].x := i;
            Temp := log10(OutRealFFT^[i]/MaxOutput) * FFTScale;
            LinesFFT[i].y := trunc(Temp);
            if i = Peak then PeakY := LinesFFT[i].y;
          end;
          frmMain.FFTPaintBox.Canvas.FillRect(frmMain.FFTPaintBox.ClientRect);
          frmMain.FFTPaintBox.Canvas.PolyLine(Slice(LinesFFT, MaxIndex));
        end;
        { Display low/high pass filter }
        if PeakLow=0 then PeakLow := 1;
        Temp := log10(PeakLow/MaxOutput) * FilterScale;

        frmMain.LowPassPaintBox.Canvas.Brush.Color := clYellow;
        frmMain.LowPassPaintBox.Canvas.Rectangle(0, trunc(Temp),
          frmMain.LowPassPaintBox.Width, frmMain.LowPassPaintBox.Height);
        frmMain.LowPassPaintBox.Canvas.Brush.Color := clBlack;
        frmMain.LowPassPaintBox.Canvas.Rectangle(0, 0,
          frmMain.LowPassPaintBox.Width, trunc(Temp));

        if PeakHigh=0 then PeakHigh := 1;
        Temp := log10(PeakHigh/MaxOutput) * FilterScale;
        frmMain.HighPassPaintBox.Canvas.Brush.Color := clYellow;
        frmMain.HighPassPaintBox.Canvas.Rectangle(0, trunc(Temp),
          frmMain.HighPassPaintBox.Width, frmMain.HighPassPaintBox.Height);
        frmMain.HighPassPaintBox.Canvas.Brush.Color := clBlack;
        frmMain.HighPassPaintBox.Canvas.Rectangle(0, 0, frmMain.HighPassPaintBox.Width, trunc(Temp));

        { Display max values }
        MaxHz := Peak * FreqMult;
        MaxDbV := 20 * log10(Max/MaxOutput);
        Peak := trunc(MaxHz);
        if (Peak<>0) and (abs(MaxDbV)<MaxDb) then
        begin
          Str(Peak, HzStr);
          Peak := trunc(MaxDbV);
          Str(Peak, DbStr);
        end
        else
        begin
          HzStr := '___';
          DbStr := '___';
        end;
        frmMain.HzLabel.Caption := HzStr;
        frmMain.dBLabel.Caption := dBStr;
        { Display max line for FFT as frequency }
        if not(frmMain.SpectrogramBox.Checked) then
        begin
          frmMain.FFTPaintBox.Canvas.Pen.Style := psDot;
          frmMain.FFTPaintBox.Canvas.MoveTo(0, PeakY);
          frmMain.FFTPaintBox.Canvas.LineTo(frmMain.FFTPaintBox.Width, PeakY);
          frmMain.FFTPaintBox.Canvas.Pen.Style := psSolid;
        end;
      end;
  end;
end;


{ **************************************************************************** }
{ Params   : -                                                                 }
{ Return   : -                                                                 }
{                                                                              }
{ Descript : Start recording.                                                  }
{ Notes    :                                                                   }
{ **************************************************************************** }
procedure TfrmMain.StartRecording;
const
  TheFunction : TFNDrvCallBack = Callback;
var
  OpenResult: MMRESULT;
  Loop      : integer;
  ErrorText : string;
begin
  if OutRealFFT<>nil then FreeMem(OutRealFFT);

  val(CBoxFFTSize.Text, FFTSize, Loop);
{  if Loop<>0 then FFTSize := 1024;}
  if Loop<>0 then FFTSize := 512; {2005.3.7. kys}
  cbBuf := FFTSize;
  BufferLength := cbBuf * Channels * (BitsPerSample div 8);
  MaxOutput    := (MaxInput * cbBuf) div 2;

  CalcWindowFunctions(FFTSize);
  { Make sure combo box shows correct }
  CBoxWindChange(nil);
  GainLabel.Caption := format('Correction gain: %1.2f',[CoherentGain[WindowFunction]]);

  GetMem(OutRealFFT, FFTSize * sizeof(single));
  val(CBoxSamplerate.Text, Samplerate, Loop);
{  if Loop<>0 then Samplerate := 8000;  }
  if Loop<>0 then Samplerate := 441000;  {2005.3.7. kys}
  FreqMult   := SampleRate/cbBuf;
  MaxIndex   := trunc((SampleRate div 2)/FreqMult);
  frmMain.Caption := format('Realtime FFT (%d points), %d Hz sampling',[cbBuf, SampleRate]);
  FreqScrollBar.Max := SampleRate div 2;
  FilterFreq :=FreqScrollBar.Max-FreqScrollBar.Position;
  FreqFilterLabel.Caption := format('%d Hz',[FilterFreq]);

  FFTPaintBox.Canvas.Pen.Color := clYellow;
  WavePaintBox.Canvas.Pen.Color := clWhite;
  SpectrogramIndex := 0;


  { Setup scales for displaying properly }
  SourceHalfHeight := WavePaintBox.Height div 2;
  SourceScale := SourceHalfHeight / MaxInput;
  FFTHeight := FFTPaintBox.Height;
  FFTScale  := (FFTPaintBox.Height / -MaxDb) * 20;         { 20*log in/out = actual value and dB is actually negative}

  SpectroCScale  := ((6*6*6) / -MaxDb) * 20;               { Intensity to color }
  SpectroHScale  := FFTPaintBox.Height / MaxIndex;         { Frequency to height }

  FilterScale := (LowPassPaintBox.Height / -MaxDb) * 20;   { 20*log in/out = actual value and dB is actually negative}
  { Setup waverecording parameters }
  with WaveFormat do
  begin
    wFormatTag      := WAVE_FORMAT_PCM;
    nChannels       := Channels;
    nSamplesPerSec  := SampleRate;
    nAvgBytesPerSec := SampleRate * Channels * (BitsPerSample div 8);
    nBlockAlign     := Channels * (BitsPerSample div 8);
    wBitsPerSample  := BitsPerSample;
    cbSize          := 0;
  end;
  OpenResult := WaveInOpen (@WaveInHandle, WAVE_MAPPER, @WaveFormat,
                            DWORD(@TheFunction), 0, CALLBACK_FUNCTION);
  if OpenResult=MMSYSERR_NOERROR then
  begin
    { Set width of displays to half the recording frequency }
    FFTPaintBox.Width  := MaxIndex;
    WavePaintBox.Width := FFTPaintBox.Width + LogBarPaintBox.Width;
    FreeBuffer := num_buf;                                 { Last buffer initially free }
    { Make all but one buffers available for waverecording }
    for Loop := 1 to num_buf do
      begin
        GetMem(pbuf[Loop], BufferLength);
        header[Loop].lpData         := pbuf[Loop];
        header[Loop].dwBufferLength := BufferLength;
        header[Loop].dwUser         := Loop;
        header[Loop].dwFlags        := 0;
        header[Loop].dwLoops        := 0;
        header[Loop].dwLoops        := 0;
        if Loop<FreeBuffer then                            { Don't use last buffer yet }
        begin
          OpenResult := WaveInPrepareHeader(WaveInhandle, @header[Loop], sizeof(TWaveHdr));
          if OpenResult=MMSYSERR_NOERROR
            then WaveInAddBuffer(WaveInhandle, @header[Loop], sizeof(TWaveHdr))
            else
            begin
              case OpenResult of
                MMSYSERR_INVALHANDLE  : ErrorText := 'device handle is invalid';
                MMSYSERR_NODRIVER     : ErrorText := 'no device driver present';
                MMSYSERR_NOMEM        : ErrorText := 'memory allocation error, could be incorrect samplerate';
                else                    ErrorText := 'unknown error';
              end;
              MessageDlg(format('Error adding buffer %d device (%s)',[Loop, ErrorText]), mtError, [mbOk], 0);
            end;
        end;
      end;
    WaveInStart(WaveInHandle);                             { Start recording }
  end
  else
  begin
    case OpenResult of
      MMSYSERR_ERROR        : ErrorText := 'unspecified error';
      MMSYSERR_BADDEVICEID  : ErrorText := 'device ID out of range';
      MMSYSERR_NOTENABLED   : ErrorText := 'driver failed enable';
      MMSYSERR_ALLOCATED    : ErrorText := 'device already allocated';
      MMSYSERR_INVALHANDLE  : ErrorText := 'device handle is invalid';
      MMSYSERR_NODRIVER     : ErrorText := 'no device driver present';
      MMSYSERR_NOMEM        : ErrorText := 'memory allocation error, could be incorrect samplerate';
      MMSYSERR_NOTSUPPORTED : ErrorText := 'function isn''t supported';
      MMSYSERR_BADERRNUM    : ErrorText := 'error value out of range';
      MMSYSERR_INVALFLAG    : ErrorText := 'invalid flag passed';
      MMSYSERR_INVALPARAM   : ErrorText := 'invalid parameter passed';
      MMSYSERR_HANDLEBUSY   : ErrorText := 'handle being used simultaneously on another thread (eg callback)';
      MMSYSERR_INVALIDALIAS : ErrorText := 'specified alias not found';
      MMSYSERR_BADDB        : ErrorText := 'bad registry database';
      MMSYSERR_KEYNOTFOUND  : ErrorText := 'registry key not found';
      MMSYSERR_READERROR    : ErrorText := 'registry read error';
      MMSYSERR_WRITEERROR   : ErrorText := 'registry write error';
      MMSYSERR_DELETEERROR  : ErrorText := 'registry delete error';
      MMSYSERR_VALNOTFOUND  : ErrorText := 'registry value not found';
      MMSYSERR_NODRIVERCB   : ErrorText := 'driver does not call DriverCallback';
      else                    ErrorText := 'unknown error';
    end;
    MessageDlg(format('Error opening wave input device (%s)',[ErrorText]), mtError, [mbOk], 0);
    Application.Terminate;
  end;
  LogBarPaintBox.Repaint;                                  { Make sure other paintboxes adjusted }
  FreqBarPaintBox.Repaint;
end;


{ **************************************************************************** }