ewsdr/FlatPopupMenu.pas

unit FlatPopupMenu;

{
  TFlatPopupMenu — кастомное popup-меню в стиле приложения (не нативное
  TPopupMenu, чтобы одинаково выглядело на всех платформах и жило в цветовой
  теме). Реализовано как ДОЧЕРНИЙ контрол верхнеуровневой формы (а не отдельное
  окно): Wayland не позволяет клиенту позиционировать свои top-level окна —
  они центрируются компоновщиком. Дочерний контрол позиционируется в клиентских
  координатах формы и работает на всех платформах (тот же приём, что у
  выпадающего списка TFlatComboBox).

  Owner-draw список: hover-подсветка, галка текущего пункта, клавиатура
  (↑↓/Enter/Esc), закрытие по клику вне (MouseCapture) и по потере фокуса.

  Использование:
    Menu.SetTheme(T);
    Menu.Clear;
    Menu.AddItem('20m', BandIdx, Checked);
    Menu.OnSelect := Handler;          // Handler(Tag)
    Menu.PopupBelow(AnchorControl);    // выпадает под якорем

  Селекторы диапазона/samplerate панадаптеров (этап 3.6).
}

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

interface

uses
  Classes, SysUtils, Math, Types, Controls, Graphics, Forms, LCLType, LCLIntf,
  AppTheme, DpiUtils;

type
  TFlatMenuSelect = procedure(Tag: Integer) of object;

  TFlatPopupMenu = class(TCustomControl)
  private
    FCaptions: array of string;
    FTags:     array of Integer;
    FChecked:  array of Boolean;
    FEnabled:  array of Boolean;
    FHot:      Integer;
    FItemH:    Integer;
    FTheme:    TAppTheme;
    FOnSelect: TFlatMenuSelect;
    function  ItemAt(Y: Integer): Integer;
    procedure Commit(Idx: Integer);
  protected
    procedure Paint; override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseLeave; override;
    procedure DoExit; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Clear;
    procedure AddItem(const ACaption: string; ATag: Integer;
      AChecked: Boolean = False; AEnabled: Boolean = True);
    procedure SetTheme(const T: TAppTheme);
    procedure PopupBelow(Anchor: TControl);   // выпадает под контролом-якорем
    procedure ClosePopup;
    property OnSelect: TFlatMenuSelect read FOnSelect write FOnSelect;
  end;

implementation

const
{$IFDEF WINDOWS}
  UI_FONT = 'Segoe UI';
{$ELSE}
  UI_FONT = 'Sans';
{$ENDIF}
  BASE_ITEM_H = 22;
  BASE_PAD    = 10;   // левый отступ текста
  BASE_CHECKW = 16;   // колонка галки слева
  BASE_MINW   = 96;

constructor TFlatPopupMenu.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  TabStop   := True;
  Visible   := False;
  Font.Name := UI_FONT;
  Font.Size := 9;
  FHot      := -1;
  FTheme    := DarkTheme;
end;

procedure TFlatPopupMenu.SetTheme(const T: TAppTheme);
begin
  FTheme := T;
  Font.Color := T.Text;
  Invalidate;
end;

procedure TFlatPopupMenu.Clear;
begin
  SetLength(FCaptions, 0);
  SetLength(FTags, 0);
  SetLength(FChecked, 0);
  SetLength(FEnabled, 0);
  FHot := -1;
end;

procedure TFlatPopupMenu.AddItem(const ACaption: string; ATag: Integer;
  AChecked: Boolean; AEnabled: Boolean);
var n: Integer;
begin
  n := Length(FCaptions);
  SetLength(FCaptions, n + 1);
  SetLength(FTags,     n + 1);
  SetLength(FChecked,  n + 1);
  SetLength(FEnabled,  n + 1);
  FCaptions[n] := ACaption;
  FTags[n]     := ATag;
  FChecked[n]  := AChecked;
  FEnabled[n]  := AEnabled;
end;

function TFlatPopupMenu.ItemAt(Y: Integer): Integer;
begin
  if FItemH <= 0 then Exit(-1);
  Result := (Y - 1) div FItemH;   // -1: верхняя 1px-рамка
  if (Result < 0) or (Result >= Length(FCaptions)) then Result := -1;
end;

procedure TFlatPopupMenu.Paint;
var
  i, Y, TextY, TextX, W, H: Integer;
  R: TRect;
begin
  W := ClientWidth;
  H := ClientHeight;
  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := FTheme.Panel;
  Canvas.Pen.Style   := psClear;
  Canvas.FillRect(0, 0, W, H);
  Canvas.Font.Assign(Font);

  for i := 0 to High(FCaptions) do
  begin
    Y := 1 + i * FItemH;
    R := Rect(1, Y, W - 1, Y + FItemH);
    if i = FHot then
    begin
      Canvas.Brush.Style := bsSolid;
      Canvas.Brush.Color := FTheme.BtnActive;
      Canvas.Pen.Style   := psClear;
      Canvas.FillRect(R);
    end;
    // Галка текущего пункта.
    Canvas.Brush.Style := bsClear;
    if FChecked[i] then
    begin
      Canvas.Font.Color := FTheme.BtnTextActive;
      Canvas.TextOut(DpiScale(BASE_PAD) - DpiScale(2),
        Y + (FItemH - Canvas.TextHeight('Ag')) div 2, '✓');
    end;
    // Текст пункта.
    if FEnabled[i] then Canvas.Font.Color := FTheme.Text
    else               Canvas.Font.Color := FTheme.TextDim;
    TextX := DpiScale(BASE_PAD) + DpiScale(BASE_CHECKW);
    TextY := Y + (FItemH - Canvas.TextHeight('Ag')) div 2;
    Canvas.TextOut(TextX, TextY, FCaptions[i]);
  end;

  // Рамка.
  Canvas.Brush.Style := bsClear;
  Canvas.Pen.Style   := psSolid;
  Canvas.Pen.Color   := FTheme.Border;
  Canvas.Rectangle(0, 0, W, H);
end;

procedure TFlatPopupMenu.MouseMove(Shift: TShiftState; X, Y: Integer);
var Idx: Integer;
begin
  inherited MouseMove(Shift, X, Y);
  if PtInRect(ClientRect, Point(X, Y)) then Idx := ItemAt(Y) else Idx := -1;
  if Idx = FHot then Exit;
  FHot := Idx;
  Invalidate;
end;

procedure TFlatPopupMenu.MouseLeave;
begin
  inherited MouseLeave;
  if FHot <> -1 then begin FHot := -1; Invalidate; end;
end;

procedure TFlatPopupMenu.Commit(Idx: Integer);
var T: Integer;
begin
  if (Idx < 0) or (Idx > High(FCaptions)) or not FEnabled[Idx] then
  begin
    ClosePopup;
    Exit;
  end;
  T := FTags[Idx];
  ClosePopup;
  if Assigned(FOnSelect) then FOnSelect(T);
end;

procedure TFlatPopupMenu.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  // Клик вне списка (MouseCapture доставляет сюда координаты вне ClientRect) —
  // просто закрыть.
  if (Button <> mbLeft) or not PtInRect(ClientRect, Point(X, Y)) then
  begin
    ClosePopup;
    Exit;
  end;
  Commit(ItemAt(Y));
end;

procedure TFlatPopupMenu.DoExit;
begin
  inherited DoExit;
  ClosePopup;
end;

procedure TFlatPopupMenu.KeyDown(var Key: Word; Shift: TShiftState);
var n: Integer;
begin
  inherited KeyDown(Key, Shift);
  n := Length(FCaptions);
  case Key of
    VK_ESCAPE: begin ClosePopup; Key := 0; end;
    VK_RETURN: begin Commit(FHot); Key := 0; end;
    VK_UP:
      begin
        if n > 0 then FHot := EnsureRange(FHot - 1, 0, n - 1);
        Invalidate; Key := 0;
      end;
    VK_DOWN:
      begin
        if n > 0 then
        begin
          if FHot < 0 then FHot := 0
          else FHot := EnsureRange(FHot + 1, 0, n - 1);
        end;
        Invalidate; Key := 0;
      end;
  end;
end;

procedure TFlatPopupMenu.ClosePopup;
begin
  if not Visible then Exit;
  MouseCapture := False;
  Visible := False;
end;

procedure TFlatPopupMenu.PopupBelow(Anchor: TControl);
var
  Root: TCustomForm;
  bmp: TBitmap;
  i, maxTW, W, H, L, T: Integer;
  ScreenPt, Cl: TPoint;
begin
  if (Anchor = nil) or (Length(FCaptions) = 0) then Exit;
  Root := GetParentForm(Anchor);
  if Root = nil then Exit;

  // Размеры по временному холсту (у контрола Canvas может быть ещё невалиден).
  bmp := TBitmap.Create;
  try
    bmp.Canvas.Font.Assign(Font);
    FItemH := Max(DpiScale(BASE_ITEM_H),
                  bmp.Canvas.TextHeight('Ag') + DpiScale(8));
    maxTW := 0;
    for i := 0 to High(FCaptions) do
      maxTW := Max(maxTW, bmp.Canvas.TextWidth(FCaptions[i]));
  finally
    bmp.Free;
  end;
  W := DpiScale(BASE_PAD) + DpiScale(BASE_CHECKW) + maxTW + DpiScale(BASE_PAD);
  W := Max(W, DpiScale(BASE_MINW));
  H := Length(FCaptions) * FItemH + 2;

  // Позиция под якорем в КЛИЕНТСКИХ координатах формы.
  ScreenPt := Anchor.ClientToScreen(Point(0, Anchor.Height + 1));
  Cl := Root.ScreenToClient(ScreenPt);
  L := Cl.X;
  T := Cl.Y;
  if L + W > Root.ClientWidth  then L := Root.ClientWidth - W;
  if L < 0 then L := 0;
  if T + H > Root.ClientHeight then
    T := Root.ScreenToClient(Anchor.ClientToScreen(Point(0, 0))).Y - H;  // вверх
  if T < 0 then T := 0;

  FHot := -1;
  Parent := Root;
  SetBounds(L, T, W, H);
  Visible := True;
  BringToFront;
  SetFocus;
  MouseCapture := True;
end;

end.