mmpeak.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/index.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: 17.11.98 - 22:06:17 $                                        =}
{========================================================================}
unit MMPeak;

{$I COMPILER.INC}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    Classes,
    Controls,
    MMSystem,
    MMRegs,
    MMObj,
    MMString,
    MMDSPObj,
    MMMath,
    MMUtils,
    MMMulDiv,
    MMWaveIO,
    MMPCMSup,
    MMFFT;

const
   {$IFDEF CBUILDER3} {$EXTERNALSYM MAX_FFTLEN} {$ENDIF}
    MAX_FFTLEN  = 16384; { Define the maximum FFT length. }

type
   EMMPeakError  = class(Exception);

   TMMPeakEvent  = procedure(Sender: TObject; index: integer; Value: Longint) of object;

   {-- TMMPeakDetect ---------------------------------------------------------}
   TMMPeakDetect = class(TMMDSPComponent)
   private
      FEnabled       : Boolean;
      FOpen          : Boolean;
      FStarted       : Boolean;
      FpFFT          : PFFTReal;    { the instance for the FFT               }
      FData          : PSmallArray; { Array for FFT data                     }
      FWinBuf        : PIntArray;   { Array storing windowing function       }
      FPeaks         : PLongArray;  { Array storing peak values              }
      FPeakLeft      : Smallint;    { Total left peak                        }
      FPeakRight     : Smallint;    { Total right peak                       }
      FFTLen         : integer;     { Number of points for FFT               }
      FWindow        : TMMFFTWindow;{ selected window function               }
      FChannel       : TMMChannel;  { chBoth, chLeft or chRigth              }
      FSilence       : Byte;
      FDetectPeaks   : Boolean;
      FOnPeak        : TMMPeakEvent;

      procedure CreateDataBuffers(Length: Cardinal);
      procedure FreeDataBuffers;

      procedure SetEnabled(aValue: Boolean);
      procedure SetFFTLen(aLength: integer);
      procedure SetWindow(aValue: TMMFFTWindow);
      procedure SetChannel(aValue: TMMChannel);
      function  GetNumPeaks: integer;
      function  Getpeaks(index: integer): Longint;
      function  GetResolution: Float;

   protected
      procedure SetPWaveFormat(aValue: PWaveFormatEx); override;
      procedure Opened; override;
      procedure Closed; override;
      procedure Started; override;
      procedure Stopped; override;
      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 Close;
      procedure Start;
      procedure Stop;
      procedure Process(Buffer: PChar; Length: integer);
      procedure ResetData;

      function  GetBytesPerFFT: Longint;

      function  GetPeakIndex(Freq: Float): integer;

      property  Resolution: Float read GetResolution;
      property  NumPeaks: integer read GetNumPeaks;
      property  Peaks[index: integer]: Longint read GetPeaks;

      property  PeakLeft : Smallint read FPeakLeft;
      property  PeakRight: Smallint read FPeakRight;

      property  IsOpen: Boolean read FOpen;

   published
      property Input;
      property Output;
      property OnPeakReady: TMMPeakEvent read FOnPeak write FOnPeak;
      property Enabled: Boolean read FEnabled write SetEnabled default True;
      property FFTLength: integer read FFTLen write SetFFTLen default 128;
      property Window: TMMFFTWindow read FWindow write SetWindow default fwHamming;
      property Channel: TMMChannel read FChannel write SetChannel default chBoth;
      property DetectPeaks: Boolean read FDetectPeaks write FDetectPeaks default True;
   end;

implementation

{== TMMPeakDetect ============================================================}
constructor TMMPeakDetect.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);

   CreateDataBuffers(MAX_FFTLEN);

   FEnabled     := True;
   FOpen        := False;
   FStarted     := False;
   FpFFT        := InitRealFFT(8);
   FEnabled     := True;
   FFTLen       := 8;
   FWindow      := fwHamming;
   FChannel     := chBoth;
   FSilence     := 0;
   FDetectPeaks := True;

   FFTLength    := 128;

   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMPeakDetect ------------------------------------------------------------}
destructor TMMPeakDetect.Destroy;
begin
   Close;

   FreeDataBuffers;

   DoneRealFFT(FpFFT);

   inherited Destroy;
end;

{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.CreateDataBuffers(Length: Cardinal);
begin
   if (Length > 0) then
   begin
      FData   := GlobalAllocMem(Length * 2*sizeOf(SmallInt));
      FWinBuf := GlobalAllocMem(Length * sizeOf(Integer));
      FPeaks  := GlobalAllocMem(Length div 2 * sizeOf(Longint));
   end;
end;

{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.FreeDataBuffers;
begin
   GlobalFreeMem(Pointer(FData));
   GlobalFreeMem(Pointer(FWinBuf));
   GlobalFreeMem(Pointer(FPeaks));
end;

{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.ResetData;
begin
   FPeakLeft  := FSilence;
   FPeakRight := FSilence;
   GlobalFillMem(FPeaks^,MAX_FFTLEN*sizeOf(Longint)div 2,0);
end;

{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.SetFFTLen(aLength: integer);
var
   Order: integer;

begin
   aLength := MinMax(aLength,8,MAX_FFTLEN);
   { Convert FFTLen to a power of 2 }
   Order := 0;
   while aLength > 1 do
   begin
      aLength := aLength shr 1;
      inc(Order);
   end;
   if (Order > 0) then aLength := aLength shl Order;

   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK1}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}

   if (aLength <> FFTLen) then
   begin
      { re-init the FFTObject with the new FFT-length }
      DoneRealFFT(FpFFT);
      FpFFT := InitRealFFT(Order);
      FFTLen := aLength;
      GenWindowTableInt(FWinBuf,Ord(FWindow),Trunc(Log2(FFTLen)));

      ResetData;
   end;
end;

{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.SetWindow(aValue: TMMFFTWindow);
begin
   if (aValue <> FWindow) then
   begin
      FWindow := aValue;
      GenWindowTableInt(FWinBuf,Ord(FWindow),Trunc(Log2(FFTLen)));
      ResetData;
   end;
end;

{-- TMMPeakDetect ------------------------------------------------------------}
Procedure TMMPeakDetect.SetChannel(aValue: TMMChannel);
begin
   if (aValue <> FChannel) then
   begin
      FChannel := aValue;
      ResetData;
   end;
end;

{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.SetEnabled(aValue: Boolean);
begin
   if (aValue <> FEnabled) then
   begin
      FEnabled := aValue;