ewsdr/SampleRateOverlay.pas

unit SampleRateOverlay;

{
  Bitmap overlay для выбора sample rate (span) спектра.
  Рисуется прямо в bitmap спектра, как AlertOverlay, поэтому фон под ним
  смешивается вручную через alpha.
}

{$IFDEF FPC}
  {$MODE Delphi}
{$ENDIF}

interface

uses
  Classes, SysUtils, Controls, Graphics, Types, Math;

type
  TSpanSelectEvent = procedure(SampleRate: Integer) of object;
  THidePanelEvent  = procedure of object;

  TSampleRateOverlay = class(TComponent)
  private
    FCurrentRate:    Integer;
    // Набор пресетов (зависит от бэкенда): HPSDR 48k..1536k или Pluto >560k.
    // До 10 слотов (Pluto может иметь 8: 576k..5760k).
    FRates:          array[0..9] of Integer;
    FNames:          array[0..9] of string;
    FRateCount:      Integer;
    FPanelHidden:    Boolean;
    FOnSpanSelect:   TSpanSelectEvent;
    FOnHidePanel:    THidePanelEvent;
    FOnInvalidate:   TNotifyEvent;
    FLeft:           Integer;
    FTop:            Integer;
    FWidth:          Integer;
    FHeight:         Integer;

    FHitRects:   array[0..10] of TRect;   // [0]=hide button, [1..]=span buttons
    FHitValues:  array[0..10] of Integer; // 0=hide, else sample rate
    FHitCount:   Integer;
    FHotIdx:     Integer;

    // Кэш отрисовки: панель кнопок (статичный текст) рендерится в bitmap с
    // попиксельной альфой и пересобирается только при смене состояния, а каждый
    // кадр лишь композитится поверх спектра. Без этого ~10 мс/кадр на Cocoa
    // уходило на TextOut/TextWidth (по результатам профилирования отрисовки).
    FCache:      TBitmap;
    FCacheW:     Integer;
    FCacheDirty: Boolean;
    FKeyRate:    Integer;
    FKeyHot:     Integer;
    FKeyHidden:  Boolean;
    FKeyLeft:    Integer;
    FKeyTop:     Integer;
    FKeyW:       Integer;
    FKeyH:       Integer;

    procedure DrawSelf(Target: TBitmap; C: TCanvas; OriginX, OriginY, W, H: Integer);
    procedure RegisterHit(const HR: TRect; Value: Integer);
    procedure RequestInvalidate;
    function  ComputeContentW(C: TCanvas; AvailW: Integer): Integer;
    procedure RebuildCache(C: TCanvas; W, H: Integer);
    procedure CompositeCache(Target: TBitmap);
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
    procedure DrawOverlay(Target: TBitmap; C: TCanvas; W, H: Integer);
    procedure DrawOverlayBitmap(Target: TBitmap; W, H: Integer);
    function HandleMouseMove(X, Y: Integer): Boolean;
    function HandleMouseDown(Button: TMouseButton; X, Y: Integer): Boolean;
    function HandleMouseLeave: Boolean;
    procedure SetCurrentRate(Rate: Integer);
    // Задаёт пресеты (Гц, до 6 шт.); имена формируются как '<kHz>k'.
    procedure SetRatePresets(const Rates: array of Integer);
    procedure SetRatePresetsDefault;   // HPSDR 48k..1536k
    procedure SetPanelHidden(Hidden: Boolean);
    property Left: Integer read FLeft;
    property Top: Integer read FTop;
    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
    property HotIdx: Integer read FHotIdx;
    property OnSpanSelect: TSpanSelectEvent read FOnSpanSelect write FOnSpanSelect;
    property OnHidePanel:  THidePanelEvent  read FOnHidePanel  write FOnHidePanel;
    property OnInvalidate: TNotifyEvent read FOnInvalidate write FOnInvalidate;
  end;

implementation

const
  SPAN_RATES: array[0..5] of Integer = (48000, 96000, 192000, 384000, 768000, 1536000);

  HIDE_W  = 22;
  SPAN_H  = 18;
  PAD_X   = 4;
  PAD_Y   = 4;
  BTN_GAP = 3;

  CLR_TEXT     = TColor($00D8E6EE);
  CLR_BTN_BDR  = TColor($00685624);

procedure BlendRect(Target: TBitmap; const Rct: TRect; R, G, B, Alpha: Byte);
var
  Y, X, InvA: Integer;
  Row: PByte;
  RR: TRect;
begin
  if (Target = nil) or (Alpha = 0) then Exit;
  RR := Rct;
  if RR.Left < 0 then RR.Left := 0;
  if RR.Top < 0 then RR.Top := 0;
  if RR.Right > Target.Width then RR.Right := Target.Width;
  if RR.Bottom > Target.Height then RR.Bottom := Target.Height;
  if (RR.Right <= RR.Left) or (RR.Bottom <= RR.Top) then Exit;

  InvA := 255 - Alpha;
  Target.BeginUpdate(False);
  try
    for Y := RR.Top to RR.Bottom - 1 do
    begin
      Row := PByte(Target.ScanLine[Y]);
      if Row = nil then Continue;
      Inc(Row, RR.Left * 4);
      for X := RR.Left to RR.Right - 1 do
      begin
{$IFDEF DARWIN}
        Row[1] := Byte((Alpha * R + InvA * Row[1]) div 255);
        Row[2] := Byte((Alpha * G + InvA * Row[2]) div 255);
        Row[3] := Byte((Alpha * B + InvA * Row[3]) div 255);
{$ELSE}
        Row[0] := Byte((Alpha * B + InvA * Row[0]) div 255);
        Row[1] := Byte((Alpha * G + InvA * Row[1]) div 255);
        Row[2] := Byte((Alpha * R + InvA * Row[2]) div 255);
{$ENDIF}
        Inc(Row, 4);
      end;
    end;
  finally
    Target.EndUpdate(False);
  end;
end;

function SpanBtnWidth(const Name: string; C: TCanvas): Integer;
begin
  C.Font.Name  := 'Courier New';
  C.Font.Size  := 7;
  C.Font.Style := [];
  Result := C.TextWidth(Name) + 8;
  if Result < 30 then Result := 30;
end;

constructor TSampleRateOverlay.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCurrentRate := 192000;
  SetRatePresetsDefault;
  FPanelHidden := False;
  FHitCount := 0;
  FHotIdx := -1;
  FWidth := 320;
  FHeight := SPAN_H + PAD_Y * 2;
  FCache := TBitmap.Create;
  FCache.PixelFormat := pf32bit;
  FCacheW := 0;
  FCacheDirty := True;
  FKeyRate := -1; FKeyHot := -2; FKeyLeft := MaxInt; FKeyTop := MaxInt;
end;

destructor TSampleRateOverlay.Destroy;
begin
  FCache.Free;
  inherited Destroy;
end;

procedure TSampleRateOverlay.RequestInvalidate;
begin
  if Assigned(FOnInvalidate) then FOnInvalidate(Self);
end;

procedure TSampleRateOverlay.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if (FLeft = ALeft) and (FTop = ATop) and
     (FWidth = AWidth) and (FHeight = AHeight) then Exit;
  FLeft := ALeft;
  FTop := ATop;
  FWidth := AWidth;
  FHeight := AHeight;
  FCacheDirty := True;
  RequestInvalidate;
end;

procedure TSampleRateOverlay.RegisterHit(const HR: TRect; Value: Integer);
begin
  if FHitCount > High(FHitRects) then Exit;
  FHitRects[FHitCount] := HR;
  FHitValues[FHitCount] := Value;
  Inc(FHitCount);
end;

procedure TSampleRateOverlay.DrawSelf(Target: TBitmap; C: TCanvas;
  OriginX, OriginY, W, H: Integer);
var
  X, I, TW, TH, BtnW, ContentW: Integer;
  HR, FullR: TRect;
  IsAct, IsHot: Boolean;
  Cap: string;
begin
  if (Target = nil) or (C = nil) then Exit;
  FHitCount := 0;

  C.Font.Name := 'Courier New';
  C.Font.Size := 7;
  C.Font.Style := [];
  TH := C.TextHeight('A');

  ContentW := PAD_X + HIDE_W + BTN_GAP;
  for I := 0 to FRateCount-1 do
  begin
    Inc(ContentW, SpanBtnWidth(FNames[I], C));
    if I < FRateCount-1 then Inc(ContentW, BTN_GAP);
  end;
  Inc(ContentW, PAD_X);
  if ContentW > W then ContentW := W;

  FullR := Rect(OriginX, OriginY, OriginX + ContentW, OriginY + H);
  BlendRect(Target, FullR, $14, $14, $14, 104);
  BlendRect(Target, Rect(FullR.Left, FullR.Top, FullR.Right, FullR.Top + 1),
    $80, $80, $80, 56);
  BlendRect(Target, Rect(FullR.Left, FullR.Bottom - 1, FullR.Right, FullR.Bottom),
    $00, $00, $00, 48);
  BlendRect(Target, Rect(FullR.Left, FullR.Top, FullR.Left + 1, FullR.Bottom),
    $80, $80, $80, 42);
  BlendRect(Target, Rect(FullR.Right - 1, FullR.Top, FullR.Right, FullR.Bottom),
    $00, $00, $00, 42);

  X := OriginX + PAD_X;

  HR := Rect(X, OriginY + PAD_Y, X + HIDE_W, OriginY + PAD_Y + SPAN_H);
  IsHot := FHotIdx = 0;
  if IsHot then BlendRect(Target, HR, $1D, $4B, $62, 206)
  else          BlendRect(Target, HR, $18, $3F, $54, 182);
  C.Pen.Style := psSolid;
  C.Pen.Color := CLR_BTN_BDR;
  C.Brush.Style := bsClear;
  C.Rectangle(HR);
  C.Font.Size := 8;
  if FPanelHidden then Cap := '>' else Cap := '<';
  TW := C.TextWidth(Cap);
  C.Font.Color := CLR_TEXT;
  C.Brush.Style := bsClear;
  C.TextOut(HR.Left + (HIDE_W - TW) div 2,
            HR.Top + (SPAN_H - TH) div 2, Cap);
  C.Font.Size := 7;
  RegisterHit(HR, 0);
  Inc(X, HIDE_W + BTN_GAP);

  for I := 0 to FRateCount-1 do
  begin
    BtnW := SpanBtnWidth(FNames[I], C);
    HR := Rect(X, OriginY + PAD_Y, X + BtnW, OriginY + PAD_Y + SPAN_H);
    IsAct := FRates[I] = FCurrentRate;
    IsHot := FHotIdx = I + 1;

    if IsAct then       BlendRect(Target, HR, $20, $5A, $78, 220)
    else if IsHot then  BlendRect(Target, HR, $1D, $4B, $62, 206)
    else                BlendRect(Target, HR, $18, $3F, $54, 182);
    C.Pen.Style := psSolid;
    C.Pen.Color := CLR_BTN_BDR;
    C.Brush.Style := bsClear;
    C.Rectangle(HR);

    TW := C.TextWidth(FNames[I]);
    C.Font.Color := CLR_TEXT;
    C.Brush.Style := bsClear;
    C.TextOut(HR.Left + (BtnW - TW) div 2,
              HR.Top + (SPAN_H - TH) div 2, FNames[I]);

    RegisterHit(HR, FRates[I]);
    Inc(X, BtnW + BTN_GAP);
  end;
end;

function TSampleRateOverlay.ComputeContentW(C: TCanvas; AvailW: Integer): Integer;
var I, CW: Integer;
begin
  C.Font.Name := 'Courier New'; C.Font.Size := 7; C.Font.Style := [];
  CW := PAD_X + HIDE_W + BTN_GAP;
  for I := 0 to FRateCount-1 do
  begin
    Inc(CW, SpanBtnWidth(FNames[I], C));
    if I < FRateCount-1 then Inc(CW, BTN_GAP);
  end;
  Inc(CW, PAD_X);
  if CW > AvailW then CW := AvailW;
  Result := CW;
end;

// Перерисовывает панель в FCache с попиксельной альфой. Метод двух фонов:
// рендерим оверлей на чёрном (B0) и белом (B1) фоне; для пикселя
//   alpha = 255 - (B1 - B0),  color = B0 / alpha
// что точно восстанавливает результат любого числа src-over слоёв (включая
// сглаженный текст). Затем композит FCache поверх спектра даёт тот же вид.
procedure TSampleRateOverlay.RebuildCache(C: TCanvas; W, H: Integer);
var
  availW, availH, ContentW, X, Y, I, d, A: Integer;
  B0, B1: TBitmap;
  R0, R1, RC: PByte;
begin
  availW := Min(FWidth, W - FLeft);
  availH := Min(FHeight, H - FTop);
  FCacheW := 0;
  if (availW <= 0) or (availH <= 0) then begin FCacheDirty := False; Exit; end;

  B0 := TBitmap.Create;
  B1 := TBitmap.Create;
  try
    B0.PixelFormat := pf32bit; B0.SetSize(8, 8);
    ContentW := ComputeContentW(B0.Canvas, availW);
    if ContentW <= 0 then begin FCacheDirty := False; Exit; end;

    B0.SetSize(ContentW, availH);
    B1.PixelFormat := pf32bit; B1.SetSize(ContentW, availH);
    B0.Canvas.Brush.Style := bsSolid; B0.Canvas.Brush.Color := clBlack;
    B0.Canvas.FillRect(Rect(0, 0, ContentW, availH));
    B1.Canvas.Brush.Style := bsSolid; B1.Canvas.Brush.Color := clWhite;
    B1.Canvas.FillRect(Rect(0, 0, ContentW, availH));

    DrawSelf(B0, B0.Canvas, 0, 0, ContentW, availH);
    DrawSelf(B1, B1.Canvas, 0, 0, ContentW, availH);  // итоговые hit-rect отсюда
    for I := 0 to FHitCount - 1 do
      OffsetRect(FHitRects[I], FLeft, FTop);

    FCache.SetSize(ContentW, availH);
    B0.BeginUpdate(False); B1.BeginUpdate(False); FCache.BeginUpdate(False);
    try
      for Y := 0 to availH - 1 do
      begin
        R0 := PByte(B0.ScanLine[Y]);
        R1 := PByte(B1.ScanLine[Y]);
        RC := PByte(FCache.ScanLine[Y]);
        if (R0 = nil) or (R1 = nil) or (RC = nil) then Continue;
        for X := 0 to ContentW - 1 do
        begin
{$IFDEF DARWIN}
          d := (EnsureRange(R1[1]-R0[1],0,255) + EnsureRange(R1[2]-R0[2],0,255) +
                EnsureRange(R1[3]-R0[3],0,255)) div 3;
          A := 255 - d;
          if A <= 0 then begin RC[0]:=0; RC[1]:=0; RC[2]:=0; RC[3]:=0; end
          else begin
            RC[0] := A;
            RC[1] := EnsureRange(R0[1]*255 div A, 0, 255);
            RC[2] := EnsureRange(R0[2]*255 div A, 0, 255);
            RC[3] := EnsureRange(R0[3]*255 div A, 0, 255);
          end;
{$ELSE}
          d := (EnsureRange(R1[0]-R0[0],0,255) + EnsureRange(R1[1]-R0[1],0,255) +
                EnsureRange(R1[2]-R0[2],0,255)) div 3;
          A := 255 - d;
          if A <= 0 then begin RC[0]:=0; RC[1]:=0; RC[2]:=0; RC[3]:=0; end
          else begin
            RC[0] := EnsureRange(R0[0]*255 div A, 0, 255);
            RC[1] := EnsureRange(R0[1]*255 div A, 0, 255);
            RC[2] := EnsureRange(R0[2]*255 div A, 0, 255);
            RC[3] := A;
          end;
{$ENDIF}
          Inc(R0, 4); Inc(R1, 4); Inc(RC, 4);
        end;
      end;
    finally
      FCache.EndUpdate(False); B1.EndUpdate(False); B0.EndUpdate(False);
    end;
    FCacheW := ContentW;
  finally
    B0.Free; B1.Free;
  end;

  FKeyRate := FCurrentRate; FKeyHot := FHotIdx; FKeyHidden := FPanelHidden;
  FKeyLeft := FLeft; FKeyTop := FTop; FKeyW := W; FKeyH := H;
  FCacheDirty := False;
end;

// Альфа-композит FCache поверх Target в точке (FLeft, FTop) — один проход/кадр.
procedure TSampleRateOverlay.CompositeCache(Target: TBitmap);
// Дворд-блендинг (два 16-битных лейна на умножение, /256 вместо /255) —
// per-pixel альфа из альфа-байта кэша. Альфа-байт цели добивается до $FF.
var
  X, Y, h: Integer;
  A256, I256, S, D: LongWord;
  RS, RD: PLongWord;
begin
  if (Target = nil) or (FCacheW <= 0) then Exit;
  h := FCache.Height;
  Target.BeginUpdate(False);
  FCache.BeginUpdate(False);
  try
    for Y := 0 to h - 1 do
    begin
      if (FTop + Y < 0) or (FTop + Y >= Target.Height) then Continue;
      RS := PLongWord(FCache.ScanLine[Y]);
      RD := PLongWord(Target.ScanLine[FTop + Y]);
      if (RS = nil) or (RD = nil) then Continue;
      Inc(RD, FLeft);
      for X := 0 to FCacheW - 1 do
      begin
        if (FLeft + X >= 0) and (FLeft + X < Target.Width) then
        begin
          S := RS^;
{$IFDEF DARWIN}
          A256 := S and $FF;            // ARGB: альфа в байте 0
{$ELSE}
          A256 := S shr 24;             // BGRA: альфа в байте 3
{$ENDIF}
          if A256 > 0 then
          begin
            A256 := A256 + (A256 shr 7);   // 0..256
            I256 := 256 - A256;
            D := RD^;
            RD^ := ((((S and $00FF00FF) * A256 + (D and $00FF00FF) * I256)
                      shr 8) and $00FF00FF)
                or ((((S shr 8) and $00FF00FF) * A256 +
                     ((D shr 8) and $00FF00FF) * I256) and $FF00FF00)
{$IFDEF DARWIN}
                or $000000FF;
{$ELSE}
                or $FF000000;
{$ENDIF}
          end;
        end;
        Inc(RS); Inc(RD);
      end;
    end;
  finally
    FCache.EndUpdate(False);
    Target.EndUpdate(False);
  end;
end;

procedure TSampleRateOverlay.DrawOverlay(Target: TBitmap; C: TCanvas; W, H: Integer);
begin
  if (FWidth <= 0) or (FHeight <= 0) then Exit;
  if (FLeft >= W) or (FTop >= H) then Exit;
  if FCacheDirty or (FKeyRate <> FCurrentRate) or (FKeyHot <> FHotIdx) or
     (FKeyHidden <> FPanelHidden) or (FKeyLeft <> FLeft) or (FKeyTop <> FTop) or
     (FKeyW <> W) or (FKeyH <> H) then
    RebuildCache(C, W, H);
  CompositeCache(Target);
end;

procedure TSampleRateOverlay.DrawOverlayBitmap(Target: TBitmap; W, H: Integer);
var
  HitTarget: TBitmap;
  I, ContentW: Integer;
begin
  if (Target = nil) or (W <= 0) or (H <= 0) then Exit;
  Target.PixelFormat := pf32bit;

  Target.SetSize(8, 8);
  Target.Canvas.Font.Name := 'Courier New';
  Target.Canvas.Font.Size := 7;
  Target.Canvas.Font.Style := [];
  ContentW := PAD_X + HIDE_W + BTN_GAP;
  for I := 0 to FRateCount-1 do
  begin
    Inc(ContentW, SpanBtnWidth(FNames[I], Target.Canvas));
    if I < FRateCount-1 then Inc(ContentW, BTN_GAP);
  end;
  Inc(ContentW, PAD_X);
  ContentW := Min(ContentW, W);

  Target.SetSize(ContentW, H);
  Target.Canvas.Brush.Color := TColor($00141414);
  Target.Canvas.Brush.Style := bsSolid;
  Target.Canvas.Pen.Style := psClear;
  Target.Canvas.FillRect(Rect(0, 0, ContentW, H));
  DrawSelf(Target, Target.Canvas, 0, 0, ContentW, H);

  HitTarget := TBitmap.Create;
  try
    HitTarget.PixelFormat := pf32bit;
    HitTarget.SetSize(Max(1, FLeft + ContentW), Max(1, FTop + H));
    HitTarget.Canvas.Brush.Color := TColor($00141414);
    HitTarget.Canvas.FillRect(Rect(0, 0, HitTarget.Width, HitTarget.Height));
    DrawSelf(HitTarget, HitTarget.Canvas, FLeft, FTop, ContentW, H);
  finally
    HitTarget.Free;
  end;
end;

function TSampleRateOverlay.HandleMouseMove(X, Y: Integer): Boolean;
var
  I, OldHot: Integer;
begin
  Result := False;
  OldHot := FHotIdx;
  FHotIdx := -1;
  for I := 0 to FHitCount - 1 do
    if PtInRect(FHitRects[I], Point(X, Y)) then
    begin
      FHotIdx := I;
      Break;
    end;
  if FHotIdx <> OldHot then
  begin
    RequestInvalidate;
    Result := True;
  end;
end;

function TSampleRateOverlay.HandleMouseDown(Button: TMouseButton; X, Y: Integer): Boolean;
var
  I: Integer;
begin
  Result := False;
  if Button <> mbLeft then Exit;
  for I := 0 to FHitCount - 1 do
    if PtInRect(FHitRects[I], Point(X, Y)) then
    begin
      if FHitValues[I] = 0 then
      begin
        if Assigned(FOnHidePanel) then FOnHidePanel;
      end
      else
      begin
        if Assigned(FOnSpanSelect) then FOnSpanSelect(FHitValues[I]);
      end;
      Result := True;
      Break;
    end;
end;

function TSampleRateOverlay.HandleMouseLeave: Boolean;
begin
  Result := False;
  if FHotIdx >= 0 then
  begin
    FHotIdx := -1;
    RequestInvalidate;
    Result := True;
  end;
end;

procedure TSampleRateOverlay.SetRatePresets(const Rates: array of Integer);
var i, n: Integer;
begin
  n := Length(Rates);
  if n > 10 then n := 10;
  FRateCount := n;
  for i := 0 to n - 1 do
  begin
    FRates[i] := Rates[i];
    FNames[i] := IntToStr(Rates[i] div 1000) + 'k';
  end;
  FCacheDirty := True;
  RequestInvalidate;
end;

procedure TSampleRateOverlay.SetRatePresetsDefault;
begin
  SetRatePresets(SPAN_RATES);
end;

procedure TSampleRateOverlay.SetCurrentRate(Rate: Integer);
begin
  if FCurrentRate = Rate then Exit;
  FCurrentRate := Rate;
  RequestInvalidate;
end;

procedure TSampleRateOverlay.SetPanelHidden(Hidden: Boolean);
begin
  if FPanelHidden = Hidden then Exit;
  FPanelHidden := Hidden;
  RequestInvalidate;
end;

end.