Delphi控件源码

开发平台：
Delphi

MMPeak.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: +49(0)351-8037944               =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  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;
   end;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.SetPWaveFormat(aValue: PWaveFormatEx);
begin
   if (aValue <> nil) then
   begin
      if not (csDesigning in ComponentState) then
         if not pcmIsValidFormat(aValue) then
            raise EMMPeakError.Create(LoadResStr(IDS_INVALIDFORMAT));
      if (PWaveFormat <> nil) and (PWaveFormat^.wBitsPerSample = 8) then
          FSilence := 128
      else
          FSilence := 0;
      ResetData;
   end;
   inherited SetPWaveFormat(aValue);
end;
{-- TMMPeakDetect ------------------------------------------------------------}
function TMMPeakDetect.GetNumPeaks: integer;
begin
   Result := FFTLen div 2;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
function TMMPeakDetect.GetPeaks(index: integer): Longint;
begin
   if index < NumPeaks then
      Result := FPeaks[index]
   else
      Result := 0;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
function TMMPeakDetect.GetPeakIndex(Freq: Float): integer;
begin
   Result := Min(Trunc(Freq/Resolution),NumPeaks);
end;
{-- TMMPeakDetect ------------------------------------------------------------}
function TMMPeakDetect.GetResolution: Float;
begin
   Result := 0;
   if (PWaveFormat <> nil) then
       Result := PWaveFormat^.nSamplesPerSec/FFTLen;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.Open;
begin
   if not FOpen then
   begin
      if pcmIsValidFormat(PWaveFormat) then
      begin
         FOpen := True;
      end;
   end;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.Close;
begin
   if FOpen then
   begin
      FOpen := False;
   end;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.Start;
begin
   if FOpen and not FStarted then
   begin
      ResetData;
      FStarted := True;
   end;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.Stop;
begin
   if FStarted then
   begin
      FStarted := False;
   end;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
function TMMPeakDetect.GetBytesPerFFT: Longint;
begin
   if (PWaveFormat <> nil) then
       Result := PWaveformat^.nBlockAlign * FFTLen
   else
       Result := 0;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.Process(Buffer: PChar; Length: integer);
var
   Value,nBytes,nRead,reqBytes: Longint;
   i: Integer;
   ReIndex: integer;
   re,im,a2: Float;
   fTemp: array[0..MAX_FFTLEN-1] of Float;
begin
   if FOpen and FEnabled then
   begin
      FillChar(fTemp, sizeOf(fTemp),0);
      ResetData;
      if FDetectPeaks then
      begin
         pcmFindPeak(PWaveFormat, Buffer, Length, FPeakLeft, FPeakRight);
         FPeakLeft  := abs(FPeakLeft);
         FPeakRight := abs(FPeakRight);
      end
      else
      begin
         FPeakLeft  := 0;
         FPeakRight := 0;
      end;
      nRead := 0;
      reqBytes := GetBytesPerFFT;
      while (Length > 0) do
      begin
         nBytes := Min(Length,reqBytes);
         GlobalMoveMem((Buffer+nRead)^,FData^,nBytes);
         inc(nRead,nBytes);
         dec(Length,nBytes);
         if nBytes < reqBytes then
            GlobalFillMem((PChar(FData)+nBytes)^,reqBytes-nBytes,FSilence);
         ReIndex := Ord(FChannel)-1;
         { perform windowing on sample Data }
         if (PWaveFormat^.wBitsPerSample = 8) then
         begin
            if (PWaveFormat^.nChannels = 1) then
            for i := 0 to FFTLen-1 do
            begin
               Value := PByteArray(FData)^[i];
               fTemp[i] := MulDiv32(Value-128,FWinBuf^[i],128);
            end
            else if (FChannel = chBoth) then
            for i := 0 to FFTLen-1 do
            begin
               Value := (Word(PByteArray(FData)^[i+i])+PByteArray(FData)^[i+i+1])div 2;
               fTemp[i] := MulDiv32(Value-128,FWinBuf^[i],128);
            end
            else for i := 0 to FFTLen-1 do
            begin
               Value := PByteArray(FData)^[i+i+ReIndex];
               fTemp[i] := MulDiv32(Value-128,FWinBuf^[i],128);
            end;
         end
         else
         begin
            if (PWaveFormat^.nChannels = 1) then
            for i := 0 to FFTLen-1 do
            begin
               Value := PSmallArray(FData)^[i];
               fTemp[i] := MulDiv32(Value,FWinBuf^[i],32768);
            end
            else if (FChannel = chBoth) then
            for i := 0 to FFTLen-1 do
            begin
               Value := (Long(PSmallArray(FData)^[i+i])+PSmallArray(FData)^[i+i+1])div 2;
               fTemp[i] := MulDiv32(Value,FWinBuf^[i],32768);
            end
            else for i := 0 to FFTLen-1 do
            begin
               Value := PSmallArray(FData)^[i+i+ReIndex];
               fTemp[i] := MulDiv32(Value,FWinBuf^[i],32768);
            end;
         end;
         { calc the FFT }
         DoRealFFT(FpFFT,@fTemp,1);
         { calc the magnitude }
         for i := 0 to (FFTLen div 2)-1 do
         begin
            { Compute the magnitude }
            re := fTemp[i+i]/(FFTLen div 2);
            im := fTemp[i+i+1]/(FFTLen div 2);
            a2 := re*re+im*im;
            { Watch for possible overflow }
            if a2 < 0 then a2 := 0;
            Value := Trunc(sqrt(a2));
            if assigned(FOnPeak) then FOnPeak(Self,i,Value);
            if Value > FPeaks[i] then
               FPeaks[i] := Value;
         end;
      end;
   end;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.Opened;
begin
   Open;
   inherited Opened;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.Closed;
begin
   Close;
   inherited Closed;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.Started;
begin
   Start;
   inherited Started;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.Stopped;
begin
   Stop;
   inherited Stopped;
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.BufferReady(lpwh: PWaveHdr);
begin
   if Enabled and FOpen then
   begin
      Process(lpwh^.lpData, lpwh^.dwBytesRecorded);
   end;
   inherited BufferReady(lpwh);
end;
{-- TMMPeakDetect ------------------------------------------------------------}
procedure TMMPeakDetect.BufferLoad(lpwh: PWaveHdr; var MoreBuffers: Boolean);
begin
   inherited BufferLoad(lpwh, MoreBuffers);
   if Enabled and FOpen then
   begin
      Process(lpwh^.lpData, lpwh^.dwBytesRecorded);
   end;
end;
end.

						