src/editor/spectrum.pas

   1 unit spectrum;
   2
   3 {$INCLUDE ../shared/a_modes.inc}
   4
   5 interface
   6
   7 uses
   8   LCLIntf, LCLType, LMessages, Classes, Controls, Graphics
   9   {$IFNDEF NOSOUND}, fmod, fmodtypes;{$ELSE};{$ENDIF}
  10
  11 const
  12   N_SPECTRUM_VALUES = 512;
  13 {$IFDEF NOSOUND}
  14 // fuck my life
  15   FMOD_OK = 0;
  16
  17 type
  18   FMOD_CHANNEL = Pointer;
  19   FMOD_RESULT = Integer;
  20 {$ENDIF}
  21
  22 type
  23   TSpectrumStyle = (ssSmooth, ssBlock);
  24
  25   TMiniSpectrum = class (TGraphicControl)
  26   private
  27     FGradient: TBitmap;
  28     FBuffer: TBitmap;
  29     FScale: Single;
  30     FStyle: TSpectrumStyle;
  31     FValues: array [0..N_SPECTRUM_VALUES-1] of Single;
  32     FGradientCount: Word;
  33     FChannel: FMOD_CHANNEL;
  34     FRawData: System.PSingle;
  35
  36     procedure SetStyle(const Value: TSpectrumStyle);
  37
  38   protected
  39     procedure Paint(); override;
  40     procedure Resize(); override;
  41     procedure SetEnabled(Value: Boolean); override;
  42
  43   public
  44     constructor Create(AOwner: TComponent); override;
  45     destructor Destroy; override;
  46     procedure Draw();
  47     procedure SetChannel(ch: FMOD_CHANNEL);
  48
  49   published
  50     property Align;
  51     property Scale: Single read FScale write FScale;
  52     property Style: TSpectrumStyle read FStyle write SetStyle;
  53     property OnClick;
  54   end;
  55
  56 implementation
  57
  58 uses
  59   BinEditor, g_language;
  60
  61 { TMiniSpectrum }
  62
  63 constructor TMiniSpectrum.Create(AOwner: TComponent);
  64 var
  65   X, Y: Integer;
  66   R, G, B: Integer;
  67   C: TColor;
  68
  69 begin
  70   inherited;
  71
  72   Color := clBlack;
  73   Parent := AOwner as TWinControl;
  74   Width := Parent.Width;
  75   Height := Parent.Height;
  76   FScale := 64.0;
  77   FStyle := ssSmooth;
  78   Enabled := False;
  79   FChannel := nil;
  80   GetMem(FRawData, N_SPECTRUM_VALUES * SizeOf(Single));
  81
  82 // Create draw buffer:
  83   FBuffer := TBitmap.Create();
  84   FBuffer.PixelFormat := pf32bit;
  85   FBuffer.Width := Width;
  86   FBuffer.Height := Height;
  87
  88 // Create gradient bitmap:
  89   FGradientCount := 40;
  90   FGradient := TBitmap.Create();
  91   FGradient.PixelFormat := pf32bit;
  92   FGradient.Width := Width div FGradientCount;
  93   FGradient.Height := Height;
  94
  95   R := 255;
  96   G := 0;
  97   B := 0;
  98
  99   for Y := 0 to Height-1 do
 100   begin
 101     if Y > (Height div 2)-1 then
 102       Dec(R, 16)
 103     else
 104       Inc(G, 16);
 105     if R < 0 then
 106       R := 0;
 107     if G > 255 then
 108       G := 255;
 109     C := TColor(RGB(R, G, B));
 110     for X := 0 to Width-2 do
 111       FGradient.Canvas.Pixels[X, Y] := C;
 112     FGradient.Canvas.Pixels[Width-1, Y] := TColor(0);
 113   end;
 114 end;
 115
 116 destructor TMiniSpectrum.Destroy;
 117 begin
 118   FreeMem(FRawData);
 119   FGradient.Free;
 120   FBuffer.Free;
 121
 122   inherited;
 123 end;
 124
 125 type
 126   PSingleArray = ^TSingleArray;
 127   TSingleArray = array [0..0] of Single;
 128
 129 procedure TMiniSpectrum.Draw();
 130 var
 131   Data: PSingleArray;
 132   PeakData: Single;
 133   X, Y, a, nGC: Integer;
 134   ARect: TRect;
 135   res: FMOD_RESULT;
 136
 137 begin
 138 {$R-}
 139   FBuffer.Canvas.Brush.Color := Color;
 140   FBuffer.Canvas.FillRect(BoundsRect);
 141 {$IFNDEF NOSOUND}
 142   if Enabled then
 143     begin
 144       if FChannel <> nil then
 145         begin
 146           res := FMOD_Channel_GetSpectrum(FChannel, FRawData,
 147                    N_SPECTRUM_VALUES, 0, FMOD_DSP_FFT_WINDOW_MAX);
 148           if res <> FMOD_OK then
 149             begin
 150               ZeroMemory(@FValues, SizeOf(FValues));
 151             end
 152           else
 153             begin
 154               Data := PSingleArray(FRawData);
 155               for X := 0 to High(FValues) do
 156               begin
 157                 FValues[X] := Data^[X] * FScale;
 158                 if FValues[X] > 1.0 then
 159                   FValues[X] := 1.0;
 160               end;
 161             end;
 162         end
 163       else
 164         begin
 165           ZeroMemory(@FValues, SizeOf(FValues));
 166         end;
 167
 168       case FStyle of
 169         ssSmooth,
 170         ssBlock:
 171           begin
 172             PeakData := 0.0;
 173             nGC := N_SPECTRUM_VALUES div FGradientCount;
 174
 175             for X := 0 to FGradientCount do
 176             begin
 177               for a := X*nGC to (X+1)*nGC-1 do
 178                 if PeakData < FValues[a] then
 179                   PeakData := FValues[a];
 180
 181               if PeakData > 0.0 then
 182               begin
 183                 Y := Height - Trunc(PeakData*Height);
 184                 PeakData := 0;
 185                 FBuffer.Canvas.CopyRect(Rect(X*FGradient.Width+1, Y, (X+1)*FGradient.Width, Height),
 186                                  FGradient.Canvas, Rect(0, Y, FGradient.Width, FGradient.Height));
 187               end;
 188             end;
 189           end;
 190       end;
 191     end
 192   else // if Enabled ...
 193 {$ENDIF}
 194     begin
 195       FBuffer.Canvas.Font.Color := clWhite;
 196       ARect := BoundsRect;
 197       DrawText(FBuffer.Canvas.Handle, PChar(MsgLabSpectrum), -1, ARect,
 198                DT_WORDBREAK or DT_NOPREFIX or DT_VCENTER or DT_CENTER);
 199     end;
 200
 201   Canvas.Draw(0, 0, FBuffer);
 202 {$R+}
 203 end;
 204
 205 procedure TMiniSpectrum.SetChannel(ch: FMOD_CHANNEL);
 206 begin
 207   FChannel := ch;
 208 end;
 209
 210 procedure TMiniSpectrum.Paint;
 211 begin
 212   Draw();
 213 end;
 214
 215 procedure TMiniSpectrum.Resize;
 216 begin
 217   inherited;
 218
 219   if Assigned(FBuffer) then
 220   begin
 221     FBuffer.Width := Width;
 222     FBuffer.Height := Height;
 223   end;
 224 end;
 225
 226 procedure TMiniSpectrum.SetEnabled(Value: Boolean);
 227 begin
 228   inherited;
 229
 230   //FSOUND_DSP_SetActive(FSOUND_DSP_GetFFTUnit, Value);
 231 end;
 232
 233 procedure TMiniSpectrum.SetStyle(const Value: TSpectrumStyle);
 234 begin
 235   if FStyle <> Value then
 236   begin
 237     FStyle := Value;
 238     ZeroMemory(@FValues, SizeOf(FValues));
 239   end;
 240 end;
 241
 242 end.