mmfir.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]              =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 09.09.98 - 12:05:10 $                                        =}
{========================================================================}
unit MMFIR;

{$I COMPILER.INC}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    Messages,
    Classes,
    Graphics,
    Controls,
    Forms,
    Dialogs,
    ExtCtrls,
    Menus,
    MMSystem,
    MMObj,
    MMDSPObj,
    MMObjLst,
    MMRegs,
    MMPCMSup,
    MMWaveIO,
    MMUtils,
    MMMuldiv,
    MMMath,
    MMFFT,
    MMSpectr,
    MMFIRFlt;

const
    {$IFDEF CBUILDER3} {$EXTERNALSYM MAXFREQS} {$ENDIF}
    MAXFREQS = 256;
    {$IFDEF CBUILDER3} {$EXTERNALSYM MAXTAPS} {$ENDIF}
    MAXTAPS  = 400;

const
    {$IFDEF CBUILDER3} {$EXTERNALSYM defEnabled} {$ENDIF}
    defEnabled      = True;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defColor} {$ENDIF}
    defColor        = clWhite;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defGridColor} {$ENDIF}
    defGridColor    = clGray;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defAxisColor} {$ENDIF}
    defAxisColor    = clBlack;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defRespColor} {$ENDIF}
    defRespColor    = clRed;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defCoeffColor} {$ENDIF}
    defCoeffColor   = clBlue;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defScaleColor} {$ENDIF}
    defScaleColor   = clBlack;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defDBScale} {$ENDIF}
    defDBScale      = True;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defNormalized} {$ENDIF}
    defNormalized   = False;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defShowCoeffs} {$ENDIF}
    defShowCoeffs   = False;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defChannel} {$ENDIF}
    defChannel      = chBoth;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defOrder} {$ENDIF}
    defOrder        = 21;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defRate} {$ENDIF}
    defRate         = 4000;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defWindow} {$ENDIF}
    defWindow       = fwHamming;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defWidth} {$ENDIF}
    defWidth        = 300;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defHeight} {$ENDIF}
    defHeight       = 300;

type
    TMMFIRFilter    = class;
    TMMFIRResponse  = class;
    EMMFIRError     = class(Exception);

    {-- TMMFIRFilterItem ------------------------------------------------------}
    TMMFIRFilterItem = class(TObject)
    private
       Ff1      : Float;
       FGain    : Float;
       FOnChange: TNotifyEvent;

       procedure SetValue(index: integer; aValue: Float);

       procedure Store(S: TStream); virtual;
       procedure Load(S: TStream); virtual;

    protected
       procedure Changed; virtual;

    public
       constructor Create;
       constructor CreateEx(af1,aGain: Float);

       procedure Assign(Source: TObject);

       procedure SetParams(af1, aGain: Float);

       property OnChange: TNotifyEvent read FOnChange write FOnChange;

       property f1: Float index 0 read Ff1 write SetValue;
       property Gain: Float index 1 read FGain write SetValue;
    end;

    {-- TMMFIRFilterList ------------------------------------------------------}
    TMMFIRFilterList = class(TObjectList)
    private
       FFIRFilter: TMMFIRFilter;

       procedure SetFilter(Index: integer; Filter: TMMFIRFilterItem);
       function  GetFilter(Index: integer): TMMFIRFilterItem;

    protected
       procedure DefineProperties(Filer: TFiler); override;
       procedure ReadData(S: TStream); override;
       procedure WriteData(S: TStream); override;

    public
       function  AddObject(Item: TObject): TOLSize; override;
       procedure Sort;

       procedure Assign(Source: TPersistent); override;
       property  Items[Index: integer]: TMMFIRFilterItem read GetFilter write SetFilter; default;
    end;

    {-- TMMFIRFilter ----------------------------------------------------------}
    TMMFIRFilter    = class(TMMDSPComponent)
    private
       FOpen          : Boolean;
       FEnabled       : Boolean;
       FUpdating      : Boolean;
       FDescription   : String;
       Fncoeffs       : integer;
       Fcoeffs        : array[0..MAXTAPS-1] of Float;
       Ffs            : Longint;
       FFilters       : TMMFIRFilterList;
       FWindow        : TMMFFTWindow;
       FCleanup       : Longint;
       FPFIR          : PFIRFilter;
       FPTempFIR      : PFIRFilter;
       FChannel       : TMMChannel;
       FTempBuffer    : PChar;

       FResponse      : TMMFIRResponse;
       FSpectrum      : TMMSpectrum;

       FOnChange      : TNotifyEvent;
       FOnPcmOverflow : TNotifyEvent;

       procedure SetWindow(aValue: TMMFFTWindow);
       procedure SetChannel(aValue: TMMChannel);
       procedure SetSampleRate(aValue: Longint);
       procedure SetNCoeffs(aValue: integer);
       procedure SetDescription(aValue: String);
       procedure SetFilters(aValue: TMMFIRFilterList);
       procedure SetResponse(aValue: TMMFIRResponse);
       procedure SetSpectrum(aValue: TMMSpectrum);
       procedure NotifyResponse(Operation: TOperation);
       procedure NotifySpectrum;
       procedure SpectrumNeedData(Sender: TObject);
       procedure FiltersChanged(Sender: TObject);
       procedure FilterChanged(Sender: TObject);
       procedure UpdateTempFilter(Init: Boolean);

       procedure CalcFilter;
       procedure UpdateFilter;

    protected
       procedure Change; virtual;
       procedure Loaded; override;
       procedure Notification(AComponent: TComponent; Operation: TOperation); override;
       procedure SetPWaveFormat(aValue: PWaveFormatEx); override;
       procedure Assign(Source: TPersistent); override;

       procedure Opened; override;
       procedure Started; override;
       procedure Closed; override;

       procedure PcmOverflow; dynamic;
       procedure BufferReady(lpwh: PWaveHdr); override;
       procedure BufferLoad(lpwh: PWaveHdr; var MoreBuffers: Boolean); override;

    public
       constructor Create(aOwner: TComponent); override;
       destructor  Destroy; override;

       procedure  Open;
       procedure  Start;
       procedure  Close;
       procedure  Process(Buffer: PChar; nBytes: Longint);
       function   CleanUp(Buffer: PChar; Length: integer): Longint;

       procedure  SetCoeffs(pCoeffs: PFloatArray; nCoeffs: integer);
       function   GetCoeffs: PFloatArray;

       function   LoadCoeffs(FName: TFileName): Boolean;
       function   SaveCoeffs(FName: TFileName): Boolean;

       procedure  SaveToIniFile(IniFile: TFileName; Section: string);
       procedure  ReadFromIniFile(IniFile: TFileName; Section: string);

    published
       property OnChange: TNotifyEvent read FOnChange write FOnChange;
       property OnPcmOverflow: TNotifyEvent read FOnPcmOverflow write FOnPcmOverflow;

       property Input;
       property Output;
       property Enabled: Boolean read FEnabled write FEnabled default defEnabled;
       property SampleRate: Longint read Ffs write SetSampleRate default defRate;
       property Order: integer read FnCoeffs write SetNCoeffs default defOrder;
       property Description: String read FDescription write SetDescription stored False;
       property Filters: TMMFIRFilterList read FFilters write SetFilters;
       property Response: TMMFIRResponse read FResponse write SetResponse;
       property Spectrum: TMMSpectrum read FSpectrum write SetSpectrum;
       property Channel: TMMChannel read FChannel write SetChannel default defChannel;
       property Window: TMMFFTWindow read FWindow write SetWindow default defWindow;
    end;

    {-- TMMFIRResponse --------------------------------------------------------}
    TMMFIRResponse = class(TMMGraphicControl)
    private
       FClient    : TRect;
       FDBScale   : Boolean;
       FNormalized: Boolean;
       FShowCoeffs: Boolean;
       FGridColor : TColor;
       FAxisColor : TColor;
       FRespColor : TColor;
       FCoeffColor: TColor;
       FScaleColor: TColor;

       FnCoeffs   : integer;
       FCoeffs    : array[0..MAXTAPS-1] of Float;
       Ffs        : Longint;

       procedure SetColors(index: integer; aValue: TColor);
       procedure SetBoolean(index: integer; aValue: Boolean);
       procedure SetSampleRate(aValue: Longint);

       procedure AdjustClientSize;
       procedure VLineDoted(aCanvas: TCanvas; x, y1, y2: integer; Clr: TColorRef);
       procedure HLineDoted(aCanvas: TCanvas; x1, x2, y: integer; Clr: TColorRef);
       procedure DrawBackground(Canvas: TCanvas; Client: TRect);
       procedure DrawImpulseResponse(Canvas: TCanvas; Client: TRect);

    protected
       procedure   Paint; override;
       procedure   Changed; override;
       procedure   SetBounds(aLeft, aTop, aWidth, aHeight: integer); override;

    public
       constructor Create(aOwner: TComponent); override;
       destructor  Destroy; override;

       procedure SetCoeffs(pCoeffs: PFloatArray; nCoeffs: integer);

    published
       property Color default defColor;
       property ParentColor;
       property Align;
       property Bevel;
       property Font;
       property ParentFont;
       property Visible;

       property Width default defWidth;
       property Height default defHeight;

       property GridColor: TColor index 0 read FGridColor write SetColors default defGridColor;
       property AxisColor: TColor index 1 read FAxisColor write SetColors default defAxisColor;
       property ResponseColor: TColor index 2 read FRespColor write SetColors default defRespColor;
       property CoeffColor: TColor index 3 read FCoeffColor write SetColors default defCoeffColor;
       property ScaleColor: TColor index 4 read FScaleColor write SetColors default defScaleColor;
       property ShowCoeffs: Boolean index 0 read FShowCoeffs write SetBoolean default defShowCoeffs;
       property DBScale: Boolean index 1 read FDBScale write SetBoolean default defDBScale;
       property Normalized: Boolean index 2 read FNormalized write SetBoolean default defNormalized;
       property SampleRate: Longint read Ffs write SetSampleRate default defRate;
    end;

{-- Coeff generation and response --}
type
    TMMFIRFunction  = (ffLowPass,ffHighPass,ffBandPass,ffBandStop);

    PMMFilterPoint  = ^TMMFilterPoint;
    TMMFilterPoint  = record
       Freq: Float;
       Amp : Float;
    end;

    PMMFilterPoints = ^TMMFilterPoints;
    TMMFilterPoints = array[0..0] of TMMFilterPoint;

procedure FIR_Coeffs(FIRType: TMMFIRFunction; SRate: integer;
                     f1,f2: Float; N: integer; hh: PFloatArray);
procedure FIR_CoeffsEx(Points: PMMFilterPoints; nPoints, SRate, N: integer;
                       hh: PFloatArray);
procedure FIR_Window(Window: TMMFFTWindow; N: integer; hh: PFloatArray);
procedure FIR_Response (FirType,N: integer; hh: PFloatArray; dBScale: Boolean;
		       numPoints: integer; points: PFloatArray);
procedure FIR_NormaliseResponse(dbscale: Boolean; NumPoints: integer; points: PFloatArray);

{$O-}

implementation

uses IniFiles;

const
   STREAMKENNUNG : Longint = $00524946; { 'FIR ' }

{==============================================================================}
{ note: delay occurs by ~ncoeff/2 samples                                      }
{==============================================================================}
procedure FIR_Filter(pcoeffs: PFloatArray; ncoeffs: integer;
                     DLine: PLongArray; Data: PSmallArray; samples: integer);
var
   i,j,ki: integer;
   y: Float;
   idx: integer;
   mask: integer;

begin
   mask := MAXTAPS-1;
   idx := MAXTAPS-nCoeffs;

   for i := 0 to samples-1 do
   begin
      ki := idx;
      DLine[idx] := Data[i];
      idx := (idx+1) and mask;

      y := 0.0;
      for j := 0 to ncoeffs-1 do
      begin
         ki := (ki-1) and mask;
      	 y := y + DLine[ki] * pcoeffs[j];
      end;
      Data[i] := MinMax(Trunc(y),-32767,32767);
   end;
end;

{==============================================================================}
{ interpolate to a y_value for a x_val using a table of points for x and y     }
{ returns the y_val or FALSE if error, extrapolates if x_val is outside data   }
function FIR_Interpolate(ind_x, dep_y: PFloatArray; nPnts: integer;
                         x_val: Float; var y_val: Float): Boolean;

var
   i: integer;
   xrange: Float;

begin
   Result := False;

   if (nPnts <= 0) then exit;

   if (nPnts = 1) then
   begin
      y_val := dep_y[0];
      Result := True;
      exit;
   end;

   i := 0;
   while (i < nPnts) and (x_val > ind_x[i]) do inc(i); // get to pair

   if (i = nPnts) then                                 // extrapolate at end
   begin
      dec(i);
      xrange := ind_x[i] - ind_x[i-1];
      if (xrange = 0) then exit;

      y_val := dep_y[i]+(x_val-ind_x[i])*(dep_y[i]-dep_y[i-1])/xrange;
      Result := True;
      exit;
   end;

   if (x_val = ind_x[i]) then
   begin
      y_val := dep_y[i];
      Result := True;
      exit;
   end;

   if (i = 0) then                                  // extrapolate at begining
   begin
      xrange := ind_x[i+1] - ind_x[i];
      if (xrange = 0) then exit;

      y_val := dep_y[i] - (ind_x[i]-x_val)*(dep_y[i+1]-dep_y[i]) /xrange;
      Result := True;
      exit;
   end;

   xrange := ind_x[i] - ind_x[i-1];
   if (xrange = 0) then exit;

   y_val :=  dep_y[i-1]+(x_val-ind_x[i-1])*(dep_y[i]-dep_y[i-1])/xrange;
   Result := True;
end;

{==============================================================================}
procedure FIR_CoeffsEx(Points: PMMFilterPoints; nPoints, SRate,
                       N: integer; hh: PFloatArray);
var
   xt, q: Float;
   m, i, j: integer;
   freq,amp,dnpi: array [0..MAXFREQS-1] of Float;
   a: array [0..MAXTAPS-1] of Float;

begin

   if (nPoints > MAXFREQS) then nPoints := MAXFREQS;

   for i := 0 to nPoints-1 do
   begin
      freq[i] := Points[i].Freq/SRate;
      amp[i]  := pow(10.0,Points[i].Amp/20.0);
   end;

   m := (N + 1) div 2;
   q := 2 * M_PI / N;

   for i := 0 to nPoints-1 do           // find positions of freqs in window
   begin
      dnpi[i] := N * freq[i] + 1.0;
      if (dnpi[i] < 0) then dnpi[i] := 0;
      if (dnpi[i] > N) then dnpi[i] := N;
   end;

   // set a[] array to the amp[] vals at each npi[] position