main.pas

VCL component dsplab , STFT and SPECTRUM viewer, real time

{
  The simple demo of sound processing and visualization
  Author:  Eugen Tarasov

  This demo is based on the DelphiX sample and library.

  Last modified - January, 2004

  Please send all suggestions to author

  e-mail: [e-mail]
  http://www.teworks.com
}

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Wave, StdCtrls, ExtCtrls, DXClass, DXSounds, Buttons, TeEngine, Series,
  syncobjs, TeeProcs, Chart, Math, SpecList, dspFFT, dspTypes;

const
    cNumberOfChannels = 9;

type
  TOnDataRead = procedure (var Buffer; Count: Integer) of object;

  TdspSoundCaptureStream = class(TSoundCaptureStream)
  protected
    FBuffer: Pointer;
    FOnDataRead: TOnDataRead;
  public
    function Read(var Buffer; Count: Longint): Longint; override;
    destructor Destroy; override;

    procedure Start;
    procedure Stop;
  end;


  TMainForm = class(TForm)
    SaveDialog: TSaveDialog;
    DisplayPanel: TPanel;
    Panel1: TPanel;
    Bevel1: TBevel;
    SizeLabel: TLabel;
    StartButton: TButton;
    StopButton: TButton;
    FileNameEdit: TEdit;
    FormatBox: TComboBox;
    DriverBox: TComboBox;
    CloseButton: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    cbVisualizationOnly: TCheckBox;
    BrowseButton: TSpeedButton;
    Bevel2: TBevel;
    Timer1: TTimer;
    Chart1: TChart;
    BarSeries1: TBarSeries;
    Chart2: TChart;
    BarSeries2: TBarSeries;
    FFTSpectrum1: TdspFFT;
    FFTSpectrum2: TdspFFT;
    procedure StartButtonClick(Sender: TObject);
    procedure StopButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure DriverBoxChange(Sender: TObject);
    procedure BrowseButtonClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure CloseButtonClick(Sender: TObject);
    procedure DisplayPanelResize(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    FCapture: TdspSoundCaptureStream;
    FWaveStream: TWaveStream;
    SamplesPerSec, Channels: Integer;
    procedure CaptureFilledBuffer(Sender: TObject);

  private { the display }
    CS: TCriticalSection;
    SpectrumValues: TSpectrumList;
    DispValuesL, DispValuesR: TSpectrumArray;

    procedure SetupFilters;
    procedure OnDataRead(var Buffer; Count: Integer);
    procedure DispReset;
  end;

var
  MainForm: TMainForm;

implementation

{$R *.DFM}

destructor TdspSoundCaptureStream.Destroy;
begin
  FreeMem(FBuffer); FBuffer:= nil;
  inherited Destroy;
end;


procedure TdspSoundCaptureStream.Start;
begin
  FreeMem(FBuffer); FBuffer:= nil;
  inherited Start;
  GetMem(FBuffer, BufferLength * Integer(Format^.nAvgBytesPerSec) div 1000);
end;


procedure TdspSoundCaptureStream.Stop;
begin
  inherited Stop;
  FreeMem(FBuffer); FBuffer:= nil;
end;


function TdspSoundCaptureStream.Read(var Buffer; Count: Longint): Longint;
begin
  Result:= inherited Read(Buffer, Count);
  if Assigned(FOnDataRead) then FOnDataRead(Buffer, Count);
end;


procedure TMainForm.FormCreate(Sender: TObject);
var
  I: Integer;
  BrushBitmap, BrushBitmap2: TBitmap;
begin
  Application.Title:= 'DSPLab - ' + Caption;
  // Setup charts
  BrushBitmap:= TBitmap.Create;
  BrushBitmap.PixelFormat:= pf24bit;
  BrushBitmap.Width:= 8; BrushBitmap.Height:= 8;
  with BrushBitmap.Canvas do
  begin
    Pen.Width:= 2;
    Pen.Color:= BarSeries1.SeriesColor;
    Brush.Color:= Chart1.Color;
    FillRect(Rect(0, 0, 8, 8));
    MoveTo(-1, 1); LineTo(9, 1);
    MoveTo(-1, 4); LineTo(9, 4);
  end;

  BarSeries1.BarBrush.Bitmap:= BrushBitmap;

  BrushBitmap2:= TBitmap.Create;
  BrushBitmap2.Assign(BrushBitmap);
  BarSeries2.BarBrush.Bitmap:= BrushBitmap2;
  //

  CS:= TCriticalSection.Create;
  SpectrumValues:= TSpectrumList.Create;

  for I:=0 to TSoundCaptureStream.Drivers.Count-1 do
    DriverBox.Items.Add(TSoundCaptureStream.Drivers[i].Description);
  DriverBox.ItemIndex := 0;
  DriverBoxChange(nil);
  DispReset;
end;


procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  StopButtonClick(nil);
  FCapture.Free; FCapture := nil;
  SpectrumValues.Free;
  CS.Free;
end;


procedure TMainForm.CloseButtonClick(Sender: TObject);
begin
  Close;
end;


procedure TMainForm.DriverBoxChange(Sender: TObject);
const
  ChannelText: array[1..2] of string = ('Mono', 'Stereo');
var
  i: Integer;
  selectedindex, itemindex: Integer;
begin
  FCapture.Free;
  FCapture := TdspSoundCaptureStream.Create(nil);
  FCapture.FOnDataRead:= OnDataRead;

  selectedindex:= -1;
  FormatBox.Items.Clear;
  for i:=0 to FCapture.SupportedFormats.Count-1 do
    with FCapture.SupportedFormats[i] do
    begin
      if (SamplesPerSec <= 48000) and (BitsPerSample = 16) then
      begin
        itemindex:= FormatBox.Items.AddObject(Format('%dHz %dbit %s',
          [SamplesPerSec, BitsPerSample, ChannelText[Channels]]), TObject(i));
        if (SamplesPerSec = 44100) and (Channels = 2) then selectedindex:= itemindex;
      end;
    end;

  if selectedindex <> - 1 then FormatBox.ItemIndex := selectedindex
  else FormatBox.ItemIndex := FormatBox.Items.Count-1;
end;


procedure TMainForm.StartButtonClick(Sender: TObject);
  function GetFormatIndex: Integer;
  begin
    Result:= Integer(FormatBox.Items.Objects[FormatBox.ItemIndex]);
  end;
begin
  StopButtonClick(nil);
  try
    FWaveStream := TWaveFileStream.Create(FileNameEdit.Text, fmCreate);
    with FCapture.SupportedFormats[GetFormatIndex] do
    begin
      Self.SamplesPerSec:= SamplesPerSec;
      Self.Channels:= Channels;
      FWaveStream.SetPCMFormat(SamplesPerSec, BitsPerSample, Channels);
    end;

    FWaveStream.Open(True);

    StartButton.Enabled := False;
    DriverBox.Enabled := False;
    FormatBox.Enabled := False;
    StopButton.Enabled := True;
    BrowseButton.Enabled := False;

    FileNameEdit.Color := clBtnFace;
    FileNameEdit.ReadOnly := True;

    FCapture.OnFilledBuffer := CaptureFilledBuffer;

    SetupFilters;
    FCapture.CaptureFormat := GetFormatIndex;
    FCapture.Start;
  except
    StopButtonClick(nil);
    raise;
  end;
end;


procedure TMainForm.StopButtonClick(Sender: TObject);
begin
  if FCapture<>nil then FCapture.Stop;
  FWaveStream.Free; FWaveStream := nil;

  StartButton.Enabled := True;
  DriverBox.Enabled := True;
  FormatBox.Enabled := True;
  StopButton.Enabled := False;
  BrowseButton.Enabled := True;

  FileNameEdit.Color := clWindow;
  FileNameEdit.ReadOnly := False;
end;


procedure TMainForm.BrowseButtonClick(Sender: TObject);
begin
  if SaveDialog.Execute then
    FileNameEdit.Text := SaveDialog.FileName;
end;


procedure TMainForm.DisplayPanelResize(Sender: TObject);
begin
  Chart1.Width:= DisplayPanel.Width div 2;
end;


procedure TMainForm.SetupFilters;
var P: Integer;
begin
  case SamplesPerSec of
    11025: P:= 7;
    22050: P:= 8;
  else P:= 9;
  end;

  FFTSpectrum1.Power:= P;
  FFTSpectrum2.Power:= FFTSpectrum1.Power;
end;


procedure TMainForm.CaptureFilledBuffer(Sender: TObject);
var
  Count: Integer;
begin
  Count:= FCapture.FilledSize;
  FCapture.Read(FCapture.FBuffer^, Count);
  try
    if not cbVisualizationOnly.Checked then
    begin
      FWaveStream.Write(FCapture.FBuffer^, Count);
      SizeLabel.Caption := Format('%d byte', [FWaveStream.Size]);
    end;
  except
    StopButton.Click;
    raise;
  end;
end;


procedure TMainForm.OnDataRead(var Buffer; Count: Integer);
var
  PV: PSmallInt;

  procedure CalculateSpectrum(FFT: TdspFFT);
  var
    S: TdspSingle;
    I, N1, N2: Integer;
    SpectrumItem: PSpectrumItem;
    SpectrumData: PdspSingle;
  begin
    FFT.FFT;
    FFT.CalculateMagnitudes;

    CS.Acquire;
    try
      SpectrumItem:= SpectrumValues.Add;
      SpectrumItem.Channel:= FFT.Tag;
      SpectrumData:= PdspSingle(@SpectrumItem.Values[0]);
      N1:= 0; N2:= 1;
      while N1 < FFT.BufferSize2 do
      begin
        S:= 0;
        for I:= N1 to N2 - 1 do S:= S + FFT.RealOut[I];

        SpectrumData^:= S;
        Inc(SpectrumData);
        N1:= N2;
        N2:= N2 * 2;
      end;
    finally
      CS.Release;
    end;
  end;

  { Process Mono }
  procedure ProcessMono;
  var I: Integer;
  begin
    for I:= 0 to Min(Count div 2, FFTSpectrum1.BufferSize) - 1 do
    begin
      FFTSpectrum1.RealIn[I]:= PV^; Inc(PV);
    end;

    CalculateSpectrum(FFTSpectrum1);
  end;

  { Process Stereo }
  procedure ProcessStereo;
  var I: Integer;
  begin
    for I:= 0 to Min(Count div 4, FFTSpectrum1.BufferSize) - 1 do
    begin
      FFTSpectrum1.RealIn[I]:= PV^; Inc(PV);
      FFTSpectrum2.RealIn[I]:= PV^; Inc(PV);
    end;

    CalculateSpectrum(FFTSpectrum2);
    CalculateSpectrum(FFTSpectrum1);
  end;

begin
  PV:= PSmallInt(@Buffer);
  FFTSpectrum1.Clear; FFTSpectrum2.Clear;
  if Channels = 1 then ProcessMono else ProcessStereo;
end;


procedure TMainForm.DispReset;
var I: Integer;
begin
  for I:= Low(DispValuesL) to High(DispValuesL) do
  begin
    DispValuesL[I]:= -40;
    DispValuesR[I]:= -40;
  end;
end;


procedure TMainForm.Timer1Timer(Sender: TObject);
const
  cMaxAmp = High(SmallInt);
var
  I: Integer;
  K: TdspSingle;
  IsFound: Boolean;
  SpectrumItem: PSpectrumItem;
  DispValues: PSpectrumArray;
begin
  IsFound:= false;
  CS.Acquire;
  try
    if SpectrumValues.Count > 0 then
    begin
      while SpectrumValues.Count > 0 do
      begin
        SpectrumItem:= SpectrumValues[0];
        if SpectrumItem.Channel = 0 then DispValues:= @DispValuesL
        else DispValues:= @DispValuesR;

        for I:= 0 to FFTSpectrum1.Power - 1 do
        begin
          if DispValues[I] < SpectrumItem.Values[I] then K:= 1 else K:= 0.15;
          DispValues[I]:= DispValues[I] + (SpectrumItem.Values[I] - DispValues[I])* K;
        end;

        SpectrumValues.Delete(0);
        IsFound:= true;
      end;
    end else
    if (FCapture = nil) or (FCapture.Capturing = false) then
    begin
      // HideValues
      for I:= 0 to FFTSpectrum1.Power - 1 do
      begin
        DispValuesL[I]:= DispValuesL[I] * 0.8;
        DispValuesR[I]:= DispValuesR[I] * 0.8;
        IsFound:= IsFound or (DispValuesL[I] > 0.0001) or (DispValuesR[I] > 0.0001);
      end;
    end;
  finally
    CS.Release;
  end;

  if IsFound then
  begin
    BarSeries1.Clear; BarSeries2.Clear;
    for I:= 0 to FFTSpectrum1.Power - 1 do
    begin
      BarSeries1.AddXY(I, 40 + 20 * log10((DispValuesL[I] + 1) / cMaxAmp), '', clNavy);
      BarSeries2.AddXY(I, 40 + 20 * log10((DispValuesR[I] + 1) / cMaxAmp), '', clNavy);
    end;
  end;
end;

end.