mmlight.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: [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: 03.03.98 - 18:51:13 $                                        =}
{========================================================================}
Unit MMLight;

{$I COMPILER.INC}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    Messages,
    Classes,
    Graphics,
    Controls,
    Forms,
    Menus,
    MMSystem,
    MMUtils,
    MMObj,
    MMString,
    MMMath,
    MMMulDiv,
    MMFFT,
    MMRegs,
    MMPCMSup,
    MMDIBCv;

const
    MAX_FFTLEN      = 4096; { Define the maximum FFT buffer length.        }
    MAXDECAYCOUNT   = 32;   { Maximum amount of temporal averaging allowed }

type
    TMMLightKind    = (lkCircle,lkSphere);
    TMMLightArrange = (laLine,laTriangle);
    TMMLightPeakMode= (pmRMS,pmPeak,pmAverage);

const
    {$IFDEF CBUILDER3} {$EXTERNALSYM defRealize} {$ENDIF}
    defRealize          = True;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defEnabled} {$ENDIF}
    defEnabled          = True;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defHeight} {$ENDIF}
    defHeight           = 90;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defWidth} {$ENDIF}
    defWidth            = 194;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defMode} {$ENDIF}
    defMode             = mMono;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defBitLength} {$ENDIF}
    defBitLength        = b8bit;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defChannel} {$ENDIF}
    defChannel          = chBoth;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defSampleRate} {$ENDIF}
    defSampleRate       = 11025;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defFFTLen} {$ENDIF}
    defFFTLen           = 128;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defWindow} {$ENDIF}
    defWindow           = fwHamming;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defDecayMode} {$ENDIF}
    defDecayMode        = dmNone;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defDecay} {$ENDIF}
    defDecay            = 1;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defPeakMode} {$ENDIF}
    defPeakMode         = pmPeak;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defKind} {$ENDIF}
    defKind             = lkCircle;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defArrange} {$ENDIF}
    defArrange          = laLine;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defTriangleDist} {$ENDIF}
    defTriangleDist     = 10;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defSphereHorz} {$ENDIF}
    defSphereHorz       = 1.0;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defSphereVert} {$ENDIF}
    defSphereVert       = 1.0;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defZoneCount} {$ENDIF}
    defZoneCount        = 60;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defColor} {$ENDIF}
    defColor            = clBlack;

type
    EMMLightError   = class(Exception);

    { array for uniform decay mode values }
    PDataBuf        = ^TDataBuf;
    TDataBuf        = array[0..MAXDECAYCOUNT-1] of PLongArray;

    { struct to hold pre-calculated values for every band }
    Values          = record
       OldValue: Longint;
       CurValue: Longint;
    end;
    PValues         = ^TValues;
    TValues         = array[0..0] of Values;

    {-- TMMLight --------------------------------------------------------}
    TMMLight = class(TMMDIBGraphicControl)
    private
      {$IFDEF WIN32}
      FpFFT           : PFFTReal;   { the instance for FFT calculation    }
      {$ELSE}
      FFT             : TMMFFT;     { the FFT object                      }
      {$ENDIF}
      FFFTData        : PSmallArray;{ Array for FFT data                  }
      FWinBuf         : PIntArray;  { Array storing windowing function    }
      FDataBuf        : PDataBuf;   { Memory for averaging mode           }
      FDisplayVal     : PLongArray; { Array storing display values        }
      FValues         : PValues;    { array with precalculted bin values  }
      FLastVal_F      : PFloatArray;{ Last value buffer for exp decay mode}
      FLastVal        : PLongArray; { Last value buffer for uniform avg   }
      Fx1             : PIntArray;  { Array of bin #'s displayed          }
      Fx2             : PIntArray;  { Array of terminal bin #'s           }

      FDecay          : integer;    { the current Decay value             }
      FDecayMode      : TMMDecayMode;{ indicating decay mode on/off       }
      FDecayFactor    : Float;      { Geometric decay factor              }
      FDecayCount     : integer;    { Temporal averaging parameter        }
      FDecayCntAct    : integer;    { Total number of bins averaged so far}
      FMaxDecayCount  : integer;    { Maximum value for the decay count   }
      FDecayPtr       : integer;    { index for cur. averag. buffer location}

      FFTLen          : integer;    { Number of points for FFT            }
      FSampleRate     : Longint;    { A/D sampling rate                   }
      FAmpScale       : Float;      { scaling factor for amplitude scaling}
      FGainBass       : Float;      { gain factor for bass frequency light}
      FGainMiddle     : Float;      { gain factor for middle freq. light  }
      FGainTreble     : Float;      { gain factor for treble freq. light  }
      FWindow         : TMMFFTWindow;{ selected window function           }
      FEnabled        : Boolean;    { Enable or disable Light             }
      FBits           : TMMBits;    { b8bit or b16bit                     }
      FChannel        : TMMChannel; { chBoth, chLeft or chRigth           }
      FMode           : TMMMode;    { mMono, mStereo or mQuadro           }
      FBytes          : Longint;    { calculated data bytes p. Light}
      FWidth          : integer;    { calculated width without border     }
      FHeight         : integer;    { calculated height without border    }
      FClientRect     : TRect;      { calculated beveled Rect             }
      FPeakMode       : TMMLightPeakMode;
      FKind           : TMMLightKind;
      FArrange        : TMMLightArrange;
      FTriangleDist   : Integer;
      FSphereHorz     : Float;
      FSphereVert     : Float;
      FZoneCount      : Integer;

      { Events }
      FOnPcmOverflow  : TNotifyEvent;

      procedure CreateDataBuffers(Length: Cardinal);
      procedure FreeDataBuffers;
      procedure CreateArrays(Size: Cardinal);
      procedure FreeArrays;
      procedure ResetDecayBuffers;
      procedure ResetValues;
      procedure InitializeData;
      procedure SetBytesPerLight;
      procedure SetupScale;
      procedure CalcMagnitude(MagnitudeForm: Boolean);
      procedure CalcDisplayValues;
      procedure DrawLight;

      procedure AdjustCtrlSize(var W, H: Integer);
      procedure SetFFTLen(aLength: integer);
      procedure SetDecayMode(aValue: TMMDecayMode);
      procedure SetDecay(aValue: integer);
      procedure SetWindow(aValue: TMMFFTWindow);
      procedure SetAmpScale(index: integer; aValue: integer);
      function  GetAmpScale(index: integer): integer;
      procedure SetEnabled(aValue: Boolean);
      procedure SetPCMWaveFormat(wf: TPCMWaveFormat);
      function  GetPCMWaveFormat: TPCMWaveFormat;
      procedure SetBits(aValue: TMMBits);
      procedure SetChannel(aValue: TMMChannel);
      procedure SetMode(aValue: TMMMode);
      procedure SetSampleRate(aValue: Longint);
      procedure SetPeakMode(aValue: TMMLightPeakMode);
      procedure SetKind(aValue: TMMLightKind);
      procedure SetArrange(aValue: TMMLightArrange);
      procedure SetTriangleDist(Value: Integer);
      procedure SetSphereHorz(Value: Float);
      procedure SetSphereVert(Value: Float);
      procedure SetZoneCount(Value: Integer);

    protected
      procedure Paint; override;
      procedure Loaded; override;
      procedure PcmOverflow; dynamic;
      procedure Changed; override;

      procedure InitDIB;
      procedure DrawInitData;
      procedure DrawCurrentData;
      function  GetPalette: HPALETTE; override;

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

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

      procedure RefreshPCMData(PCMData: Pointer);
      procedure RefreshFFTData(FFTData: Pointer);
      procedure RefreshMagnitudeData(MagData: Pointer);
      procedure ResetData;

      property  BytesPerLight: Longint read FBytes;
      property  PCMWaveFormat: TPCMWaveFormat read GetPCMWaveFormat write SetPCMWaveFormat;

    published
      { Events }
      property OnClick;
      property OnDblClick;
      property OnMouseDown;
      property OnMouseMove;
      property OnMouseUp;
      property OnDragDrop;
      property OnDragOver;
      property OnEndDrag;
      property OnStartDrag;
      property OnPcmOverflow: TNotifyEvent read FOnPcmOverflow write FOnPcmOverflow;

      property Align;
      property Bevel;
      property Color default defColor;
      property ParentShowHint;
      property ShowHint;
      property Visible;
      property PopupMenu;
      property PaletteRealize default defRealize;
      property PaletteMapped;

      property Enabled: Boolean read FEnabled write SetEnabled default defEnabled;
      property Height default defHeight;
      property Width default defWidth;
      property Mode: TMMMode read FMode write SetMode default defMode;
      property BitLength: TMMBits read FBits write SetBits default defBitLength;
      property Channel: TMMChannel read FChannel write SetChannel default defChannel;
      property SampleRate: Longint read FSampleRate write SetSampleRate default defSampleRate;
      property FFTLength: integer read FFTLen write SetFFTLen default defFFTLen;
      property Window: TMMFFTWindow read FWindow write SetWindow default defWindow;
      property DecayMode: TMMDecayMode read FDecayMode write SetDecayMode default defDecayMode;
      property Decay: integer read FDecay write SetDecay default defDecay;

      property AmplitudeScale: integer index 0 read GetAmpScale write SetAmpScale;
      property GainBass: integer index 1 read GetAmpScale write SetAmpScale;
      property GainMiddle: integer index 2 read GetAmpScale write SetAmpScale;
      property GainTreble: integer index 3 read GetAmpScale write SetAmpScale;
      property PeakMode: TMMLightPeakMode read FPeakMode write SetPeakMode default defPeakMode;
      property Kind: TMMLightKind read FKind write SetKind default defKind;
      property Arrange: TMMLightArrange read FArrange write SetArrange default defArrange;
      property TriangleDist: Integer read FTriangleDist write SetTriangleDist default defTriangleDist;
      property SphereHorz: Float read FSphereHorz write SetSphereHorz;
      property SphereVert: Float read FSphereVert write SetSphereVert;
      property ZoneCount: Integer read FZoneCount write SetZoneCount default defZoneCount;
    end;

implementation

uses
    Consts;

const
     NumLights = 3;
     { Here we have the Center Frequencys from the different bands }
     CenterFreq: array[0..NumLights-1] of integer = (150,750,1750);

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

   CreateDataBuffers(MAX_FFTLEN);
   CreateArrays(NumLights);

   PaletteRealize := defRealize;

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

   FFTLen := 8;
   FDecay := defDecay;
   FDecayMode := defDecayMode;

   FDecayFactor := 0.0001;
   FDecayCount := 1;
   FDecayCntAct := 0;
   FDecayPtr := 0;

   FSampleRate := defSampleRate;
   FChannel := defChannel;
   FBits := defBitLength;
   FMode := defMode;
   FWindow := defWindow;

   FAmpScale := 1.0;
   FGainBass := 0.05;
   FGainMiddle := 0.05;
   FGainTreble := 0.05;

   FEnabled := defEnabled;
   FPeakMode := defPeakMode;
   FKind := defKind;
   FArrange := defArrange;

   FTriangleDist := defTriangleDist;
   FSphereHorz := defSphereHorz;
   FSphereVert := defSphereVert;
   FZoneCount := defZoneCount;
   FFTLength := defFFTLen;

   Color := defColor;

   Height := defHeight;
   Width := defWidth;

   InitDIB;

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

{-- TMMLight ------------------------------------------------------------}
Destructor TMMLight.Destroy;
begin
   FreeDataBuffers;
   FreeArrays;
   {$IFDEF WIN32}
   DoneRealFFT(FpFFT);
   {$ELSE}
   FFT.Free;
   {$ENDIF}

   inherited Destroy;
end;

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

{-- TMMLight ------------------------------------------------------------}
procedure TMMLight.CreateDataBuffers(Length: Cardinal);
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));
      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;

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

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

   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;

{-- TMMLight ------------------------------------------------------------}
procedure TMMLight.CreateArrays(Size: Cardinal);
begin
   if (Size > 0) then
   begin
      Fx1     := GlobalAllocMem(Size * sizeOf(Integer));
      Fx2     := GlobalAllocMem(Size * sizeOf(Integer));
      FValues := GlobalAllocMem(Size * sizeOf(TValues));
   end;
end;

{-- TMMLight ------------------------------------------------------------}
procedure TMMLight.FreeArrays;
begin
   GlobalFreeMem(Pointer(Fx1));
   GlobalFreeMem(Pointer(Fx2));
   GlobalFreeMem(Pointer(FValues));
end;

{-- TMMLight ------------------------------------------------------------}
procedure TMMLight.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;