mmspectr.pas

一套及时通讯的原码

    { These values are round(log2(index/16)*8192) for index=0:31 }
    _ln: array[0..31] of Long = (-131072,-32768,-24576,-19784,-16384,
                                 -13747,-11592,-9770,-8192,-6800,-5555,
                                 -4428,-3400,-2454,-1578,-763,0,716,1392,
                                 2031,2637,3214,3764,4289,4792,5274,5738,
                                 6184,6614,7029,7429,7817);
{$ENDIF}
var
   { local variables for fast asm drawing }
   _DIB          : TMMDIBCanvas;
   _DIB_ORIENT   : integer;
   _biBits       : Longint;
   _biBPP        : Longint;
   _biWidth      : Longint;
   _biHeight     : Longint;
   _biScanWidth  : Longint;
   _biLineDiff   : Longint;
   _biColor      : Longint;
   _biSurface    : Pointer;
   _biPenPos     : TPoint;
   _biClipRect   : TRect;

   _Bar1Color    : Cardinal;
   _Bar2Color    : Cardinal;
   _Bar3Color    : Cardinal;
   _Inact1Color  : Cardinal;
   _Inact2Color  : Cardinal;
   _Inact3Color  : Cardinal;
   _NumSpots     : integer;
   _NumPeaks     : integer;
   _SpotHeight   : Longint;
   _SpotSpace    : Longint;
   _FirstSpace   : Longint;
   _Space        : Longint;
   _Point1Spot   : integer;
   _Point2Spot   : integer;
   _ActiveDoted  : Boolean;
   _InactiveDoted: Boolean;
   _DrawInactive : Boolean;
   _Offset       : integer;

const
   SaveDC        : HDC     = 0;
   SaveBitmap    : HBitmap = 0;
   SaveWidth     : integer = 0;
   SaveHeight    : integer = 0;
   SaveInfoPos   : TPoint  = (X:0;Y:0);
   OldBitmap     : HBitmap = 0;

{------------------------------------------------------------------------}
procedure TimeCallBack(uTimerID, dwUser: Longint);export;
var
   j: integer;

begin
  if (dwUser <> 0) then
  with TMMSpectrum(dwUser) do
  begin
     if (FNumPeaks < 1) or (FDrawVal = nil) or FShowInfoHint then exit;

     j := 0;
     while (FDrawVal^[j].Left <> -1) and (j < FWidth) do
     with FDrawVal^[j] do
     begin
        if (Peak > 0) then
        begin
           dec(PeakCnt);
           if PeakCnt <= 0 then
           begin
              if (FPeakSpeed = 0) then
              begin
                 Peak := 0;                 { clear the peak hold spot }
                 PeakCnt := 0;
              end
              else
              begin
                 dec(Peak);                       { dec the peak spot }
                 PeakCnt := FPeakSpeed;
              end;
           end;
        end;
        inc(j);
     end;
  end;
end;

{-- TMMSpectrum ---------------------------------------------------------}
constructor TMMSpectrum.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);

   ControlState := ControlState + [csCreating];

   FTimerID := 0;
   CreateDataBuffers(MAX_FFTLEN);
   FBarDIB := TMMDIBCanvas.Create(Self);

   {$IFDEF WIN32}
   FpFFT := InitRealFFT(8);
   {$ELSE}
   FFT := TMMFFT.Create;
   {$ENDIF}

   FFTLen := 8;

   FWindow := fwHamming;
   FSampleRate := 11025;
   FLogFreq := False;
   FLogAmp := False;
   FFreqScaleFactor := 1.0;
   FFreqBase := 1.0;
   Fys := 1.0;

   FLogBase := 6;
   FLogs := 0;

   FGain3db := 0;
   FDeriv := 0;
   FRefFreq := 1000;
   FDecay := 1;
   FDecayMode := dmNone;
   FDecayFactor := 0.0001;
   FDecayCount := 1;
   FDecayCntAct := 0;
   FDecayPtr := 0;
   FNumPeaks := 1;
   FPeakDelay := 20;
   FPeakSpeed := 0;
   FDisplayPeak := False;
   FKind := skBars;
   FEnabled := True;
   FBar1Color := clAqua;
   FBar2Color := clAqua;
   FBar3Color := clRed;
   FInact1Color := clTeal;
   FInact2Color := clTeal;
   FInact3Color := clMaroon;
   FScaleTextColor := clBlack;
   FScaleLineColor:= clBlack;
   FScaleBackColor:= clBtnFace;
   FGridColor := clGray;
   FPoint1 := 50;
   FPoint2 := 85;
   FInactiveDoted := False;
   FActiveDoted := False;
   FSpace := 1;
   FSpotSpace := 1;
   FSpotHeight := 1;
   FChannel := chBoth;
   FBits := b8bit;
   FMode := mMono;
   FGain := sgNone;
   FDrawInactive := True;
   FDrawFreqScale := False;
   FDrawAmpScale := False;
   FDrawGrid := False;
   FDrawVal := nil;
   FShowInfoHint := False;
   FShowInfo := True;

   Color := clBlack;
   SetBounds(0,0,194,89);

   Cursor := crCross;

   ControlState := ControlState - [csCreating];

   FFTLength := 128;

   if not (csDesigning in ComponentState) then
   begin
      { create the peak timer }
      FTimerID := MMTimeSetEvent(25,False,TimeCallBack,Longint(Self));
   end;

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

{-- TMMSpectrum ---------------------------------------------------------}
Destructor TMMSpectrum.Destroy;
begin
   if (FTimerID <> 0) then
   begin
      { destroy the peak timer }
      MMTimeKillEvent(FTimerID);
   end;

   FreeDataBuffers;
   FreeArrays;
   {$IFDEF WIN32}
   DoneRealFFT(FpFFT);
   {$ELSE}
   FFT.Free;
   {$ENDIF}
   FBarDIB.Free;

   inherited Destroy;
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.ChangeDesigning(aValue: Boolean);
begin
   inherited ChangeDesigning(aValue);

   if not (csDesigning in ComponentState) then
   begin
      { create the peak timer }
      if (FTimerID = 0) then
          FTimerID := MMTimeSetEvent(25,False,TimeCallBack,Longint(Self));
      InitializeData;
   end;
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.SetBPP(aValue: integer);
begin
   if (aValue <> BitsPerPixel) then
   begin
      if (aValue <> 8) and (aValue <> 24) then
         raise EMMDIBError.Create('Bitlength not supported yet');

      FBarDIB.BitsPerPixel := aValue;
      DIBCanvas.BitsPerPixel := aValue;
      DrawInactiveSpots;
      Invalidate;
   end;

//   inherited SetBPP(aValue);
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.GainOverflow;
begin
   if Assigned(FOnGainOverflow) then FOnGainOverflow(Self);
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.PcmOverflow;
begin
   if Assigned(FOnPcmOverflow) then FOnPcmOverflow(Self);
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.ResetDecayBuffers;
var
   i, j: integer;

begin
   FDecayPtr := 0;
   FDecayCntAct := 0; { Restart the count of number of samples taken }
   FillChar(FLastVal^, (FFTLen div 2)*sizeOf(Long),0);
   FillChar(FLastVal_F^, (FFTLen div 2)*sizeOf(Float),0);
   for i := 0 to FMaxDecayCount-1 do
       for j := 0 to (FFTLen div 2)-1 do FDataBuf^[i]^[j] := 0;
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.ResetPeakValues;
begin
   FillChar(FDrawVal^[0], FWidth * sizeOf(TDrawVal), 0);
   FillChar(FPeak, sizeOf(TPeak),0);
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.CreateDataBuffers(Length: integer);
begin
   if (Length > 0) then
   begin
      FFFTData   := GlobalAllocMem(Length * sizeOf(SmallInt));
      FWinBuf    := GlobalAllocMem(Length * sizeOf(Integer));
      FDisplayVal:= GlobalAllocMem((Length div 2) * sizeOf(Long));
      FLastVal   := GlobalAllocMem((Length div 2) * sizeOf(Long));
      FLastVal_F := GlobalAllocMem((Length div 2) * sizeOf(Float));
      FYBase     := GlobalAllocMem((Length div 2) * sizeOf(Long));
      FDataBuf   := GlobalAllocMem(MAXDECAYCOUNT * sizeOf(PLongArray));

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

      FMaxDecayCount := 0;
      while FMaxDecayCount < MAXDECAYCOUNT do
      begin
         FDataBuf^[FMaxDecayCount] := GlobalAllocMem((Length div 2) * sizeOf(Long));
         if FDataBuf^[FMaxDecayCount] = nil then break;
         inc(FMaxDecayCount);
      end;
      if (FMaxDecayCount < 1) then OutOfMemoryError;

      FDecayCount := Min(FDecayCount, FMaxDecayCount);

      { Clear out the memory buffers }
      ResetDecayBuffers;
   end;
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.FreeDataBuffers;
var
   i: integer;

begin
   GlobalFreeMem(Pointer(FFFTData));
   GlobalFreeMem(Pointer(FWinBuf));
   GlobalFreeMem(Pointer(FDisplayVal));
   GlobalFreeMem(Pointer(FLastVal));
   GlobalFreeMem(Pointer(FLastVal_F));
   GlobalFreeMem(Pointer(FYBase));

   if FDataBuf <> nil then
   begin
      for i := 0 to FMaxDecayCount-1 do
          if FDataBuf^[i] <> nil then GlobalFreeMem(Pointer(FDataBuf^[i]));
      GlobalFreeMem(Pointer(FDataBuf));
   end;
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.CreateArrays(Size: integer);
begin
   if (Size > 0) then
   begin
      MMTimeSuspendEvent(FTimerID);
      Fx1     := GlobalAllocMem((Size+10) * sizeOf(Integer));
      Fx2     := GlobalAllocMem((Size+10) * sizeOf(Integer));
      FYScale := GlobalAllocMem(Size * sizeOf(Integer));
      FDrawVal:= GlobalAllocMem((Size+1) * sizeOf(TDrawVal));
      FDrawVal^[Size].Left := -1; { mark the end }
      MMTimeResumeEvent(FTimerID);
   end;
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.FreeArrays;
begin
   MMTimeSuspendEvent(FTimerID);
   GlobalFreeMem(Pointer(Fx1));
   GlobalFreeMem(Pointer(Fx2));
   GlobalFreeMem(Pointer(FYScale));
   GlobalFreeMem(Pointer(FDrawVal));
   MMTimeResumeEvent(FTimerID);
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.InitializeData;
Var
   i: integer;
begin
   FillChar(FDisplayVal^[0], FFTLen div 2 * sizeOf(Long), 0);
   FillChar(FFFTData^[0], FFTLen * sizeOf(SmallInt), 0);
   ResetPeakValues;
   ResetDecayBuffers;

   if Enabled then
   begin
      if assigned(FOnNeedData) then FOnNeedData(Self)
      else if (csDesigning in ComponentState) then
      begin
         Randomize;
         for i := 0 to FFTLen div 2-1 do
         begin                                         { create random data }
            FDisplayVal^[i] := Long(Random(32767));
         end;
      end;
   end;
end;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.ResetData;
var
   P: TPoint;
begin
   if FShowInfoHint then
   begin
      GetCursorPos(P);
      P := ScreenToClient(P);
      Perform(WM_LBUTTONUP, 0, Longint(PointToSmallPoint(P)));
   end;
   InitializeData;
   Refresh;
end;

const
    inHandler: Longint = 0;

{-- TMMSpectrum ---------------------------------------------------------}
procedure TMMSpectrum.NeedData;
begin
   inc(inHandler);
   try
      if (inHandler = 1)
      {$IFDEF BUILD_ACTIVEX}
      and not Selected
      {$ENDIF} then
      begin
         if (csLoading in ComponentState) or
            (csReading in ComponentState) then exit;

         InitializeData;
      end;
   finally
      dec(inHandler);
   end;
end;