unit uBafMenu;

// this code is under the BAF fair use license (BFUL) - https://bafbal.de/index.php?title=Bful
// the menu in the BAF Client

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.TabControl,
  FMX.Controls.Presentation, FMX.StdCtrls, FMX.ExtCtrls, FMX.Layouts,
  System.Contnrs, FMX.Objects, FMX.Edit, FMX.ComboEdit, uBafClientTab,
  FMX.ScrollBox, FMX.Memo, System.Math, FMX.Styles, uBafControls, FMX.TreeView,
  FMX.Menus, uStringIniFile, FMX.ListBox, uBafTypes, uBafComboHelper,
  System.StrUtils, FMX.Pickers, System.Rtti;

type
  TBafMenu = class;
  TBafMenuCategories = class;
  TBafMenuCategory = class;
  TBafMenuItems = class;
  TBafMenuItem = class;

  TBafMenuClick = procedure(ASender: TBafMenuItem; ACommand: string;
      AInNewTab: boolean) of object;

  TBafMenuParents = record
    Menu: TBafMenu;
    Categories: TBafMenuCategories;
    Category: TBafMenuCategory;
    Items: TBafMenuItems;
    Item: TBafMenuItem;
    procedure CreateFrom(AParents: TBafMenuParents);
  end;

  TBafMenuItem = class(TCollectionItem)
  private
    FParents: TBafMenuParents;
    FText: string;
    FCommand: string;
    FRect: TRectF;
    procedure SetText(const Value: string);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Paint(ACanvas: TCanvas);
    procedure MenuItemClick(AInNewTab: boolean);
    property Parents: TBafMenuParents read FParents;
  published
    property Text: string read FText write SetText;
    property Command: string read FCommand write FCommand;
  end;

  TBafMenuItems = class(TCollection)
  private
    FParents: TBafMenuParents;
    function GetItem(Index: Integer): TBafMenuItem;
    procedure SetItem(Index: Integer; const Value: TBafMenuItem);

  public
    constructor Create(ACategory: TBafMenuCategory);
    destructor Destroy; override;
    function Add: TBafMenuItem;
    function AddItem(Item: TBafMenuItem; Index: Integer): TBafMenuItem;
    function Insert(Index: Integer): TBafMenuItem;
    property Items[Index: Integer]: TBafMenuItem read GetItem write SetItem;
  published
    property Parents: TBafMenuParents read FParents;
  end;

  TBafMenuCategory = class(TCollectionItem)
  private
    FParents: TBafMenuParents;
    FExpanded: boolean;
    FText: string;
    FItems: TBafMenuItems;
    FRect: TRectF;
    FRectAll: TRectF;
    procedure SetExpaned(const Value: boolean);
    procedure SetText(const Value: string);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Paint(ACanvas: TCanvas);
    procedure ToggleExpanded;
    property Parents: TBafMenuParents read FParents;
  published
    property Text: string read FText write SetText;
    property Expanded: boolean read FExpanded write SetExpaned;
    property Items: TBafMenuItems read FItems;
  end;

  TBafMenuCategories = class(TCollection)
  private
    FParents: TBafMenuParents;
    function GetItem(Index: Integer): TBafMenuCategory;
    procedure SetItem(Index: Integer; const Value: TBafMenuCategory);
  public
    constructor Create(AMenu: TBafMenu);
    destructor Destroy; override;
    function Add: TBafMenuCategory;
    function AddItem(Item: TBafMenuCategory; Index: Integer): TBafMenuCategory;
    function Insert(Index: Integer): TBafMenuCategory;
    property Items[Index: Integer]: TBafMenuCategory read GetItem write SetItem;
  published
    property Parents: TBafMenuParents read FParents;
  end;

  TBafMenu = class(TBafVertScrollBox)
  private
    FCategories: TBafMenuCategories;
    FPanelDesk: TPanel;
    FPaintTop: single;
    FHoverObject: TObject;
    FOnMenuClick: TBafMenuClick;
  protected
    FColorBack, FColorFont: TAlphaColor;
    procedure LoadStyle;
    procedure PanelDeskMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
    procedure PanelDeskMouseUp(Sender: TObject; Button: TMouseButton;
        Shift: TShiftState; X, Y: Single);
    procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    class function Place(AOwner: TComponent; AParent: TControl): TBafMenu;
    procedure GridPaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
  published
    property Categories: TBafMenuCategories read FCategories;
    property PaintTop: single read FPaintTop write FPaintTop;
    property HoverObject: TObject read FHoverObject;
    property OnMenuClick: TBafMenuClick read FOnMenuClick write FOnMenuClick;
  end;

implementation

{ TBafMenu }

constructor TBafMenu.Create(AOwner: TComponent);
begin
  inherited;
  FCategories := TBafMenuCategories.Create(Self);

  FPanelDesk := TPanel.Create(Self);
  FPanelDesk.Parent := Self;
  FPanelDesk.Align := TAlignLayout.Top;
  FPanelDesk.OnPaint := GridPaint;
  FPanelDesk.ClipChildren := true;
  FPanelDesk.OnMouseUp := PanelDeskMouseUp;
  FPanelDesk.OnMouseMove := PanelDeskMouseMove;
  FPanelDesk.StyleLookup := 'pushpanel';
  LoadStyle;
end;

destructor TBafMenu.Destroy;
begin
  FreeAndNil(FCategories);
  inherited;
end;

procedure TBafMenu.GridPaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
var
  LCat: integer;
  LRect: TRectF;
begin
  Canvas.BeginScene;
  try
//    LRect := ARect;
//    LRect.Inflate(1, 1);
//    Canvas.Fill.Color := FColorBack;
//    Canvas.FillRect(LRect, 0, 0, [], 1);
    FPaintTop := 0;
    Canvas.Fill.Color := FColorFont;
    for LCat := 0 to Categories.Count - 1 do
      Categories.Items[LCat].Paint(Canvas);
    FPanelDesk.Height := System.Math.Max(100, FPaintTop);
  finally
    Canvas.EndScene;
  end;
end;

procedure TBafMenu.LoadStyle;
var
  LObject, LObject2: TFmxObject;
  LRectangle: TRectangle;
  i: integer;
  s: string;

  function lokFindObject(AParent: TFmxObject; AName: string): TFmxObject;
  var
    i: integer;
    LChild: TFmxObject;
  begin
    result := nil;
    for i := 0 to AParent.ChildrenCount - 1 do begin
      LChild := AParent.Children.Items[i];
      if AnsiCompareText(LChild.StyleName, AName) = 0 then begin
        result := LChild;
        exit;
      end
      else begin
        result := lokFindObject(LChild, AName);
        if Assigned(result) then
          exit;
      end;
    end;
  end;

  function lokFarbe(AName: string): TAlphaColor;
  begin
    LObject2 := lokFindObject(LObject, AName);
    if Assigned(LObject2) and (LObject2 is TRectangle) then begin
      LRectangle := TRectangle(LObject2);
      result := LRectangle.Fill.Color;
    end;
  end;

begin
  LObject := FMX.Types.FindStyleResource('bafcolors');
  if Assigned(LObject) and (LObject is TLayout) then begin
    FColorBack := lokFarbe('backgroundcolor');
    FColorFont := lokFarbe('text');
  end;

//procedure TBafMenu.LoadStyle
end;

procedure TBafMenu.MouseMove(Shift: TShiftState; X, Y: Single);
begin
  if Assigned(FHoverObject) then begin
    FHoverObject := nil;
    Repaint;
  end;
end;

procedure TBafMenu.PanelDeskMouseMove(Sender: TObject; Shift: TShiftState;
    X, Y: Single);
var
  LCat, LItem: integer;
  LCategory: TBafMenuCategory;
  LMenuItem: TBafMenuItem;
  LPoint: TPointF;
  LHoverOld: TObject;
begin
  LHoverOld := FHoverObject;
  FHoverObject := nil;
  LPoint := PointF(X, Y);
  if x < (FPanelDesk.Width - 30) then begin
    for LCat := 0 to Categories.Count - 1 do begin
      LCategory := Categories.Items[LCat];
      if LCategory.FRectAll.Contains(LPoint) then begin
        if not LCategory.Expanded or LCategory.FRect.Contains(LPoint) then begin
          FHoverObject := LCategory;
          if FHoverObject <> LHoverOld then
            Repaint;
          exit;
        end
        else begin
          for LItem := 0 to LCategory.Items.Count - 1 do begin
            LMenuItem := LCategory.Items.Items[LItem];
            if LMenuItem.FRect.Contains(LPoint) then begin
              FHoverObject := LMenuItem;
              if FHoverObject <> LHoverOld then
                Repaint;
              exit;
            end;
          end;
        end;
      end;
    end;
  end;
  if FHoverObject <> LHoverOld then
    Repaint;
end;

procedure TBafMenu.PanelDeskMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Single);
begin
  if Assigned(FHoverObject) then begin
    if FHoverObject is TBafMenuCategory then
      TBafMenuCategory(FHoverObject).ToggleExpanded;
    if FHoverObject is TBafMenuItem then
      TBafMenuItem(FHoverObject).MenuItemClick(ssCtrl in Shift);
  end;
end;

class function TBafMenu.Place(AOwner: TComponent; AParent: TControl): TBafMenu;
begin
  result := TBafMenu.Create(AOwner);
  result.Parent := AParent;
  result.Align := TAlignLayout.Client;
  result.Margins.Left := 8;
  result.Margins.Top := 8;
  result.Margins.Right := 8;
  result.Margins.Bottom := 8;
end;


{ TBafMenuParents }

procedure TBafMenuParents.CreateFrom(AParents: TBafMenuParents);
begin
  Menu := AParents.Menu;
  Categories := AParents.Categories;
  Category := AParents.Category;
  Items := AParents.Items;
  Item := AParents.Item;
end;

{ TBafMenuCategory }

constructor TBafMenuCategory.Create(Collection: TCollection);
begin
  inherited;
  FParents.CreateFrom((Collection as TBafMenuCategories).FParents);
  FParents.Category := Self;
  FItems := TBafMenuItems.Create(Self);
end;

destructor TBafMenuCategory.Destroy;
begin

  inherited;
end;

procedure TBafMenuCategory.Paint(ACanvas: TCanvas);
var
  LTop: single;
  LItem: integer;
begin
  ACanvas.Font.Style := [TFontStyle.fsBold];
  if Parents.Menu.HoverObject = self then
    ACanvas.Fill.Color := $FFDDDDFF
  else
    ACanvas.Fill.Color := $FF777777;
  LTop := FParents.Menu.PaintTop;
  FRect := RectF(2, LTop, ACanvas.Width - 2, LTop + 25);
  FRectAll := FRect;
  ACanvas.FillText(FRect, FText, false, 1, [], TTextAlign.Leading);
  ACanvas.Font.Style := [];
  FParents.Menu.PaintTop := LTop + 25;

  if FExpanded then begin
    for LItem := 0 to Items.Count - 1 do
      Items.Items[LItem].Paint(ACanvas);
    FRectAll.Bottom := FParents.Menu.PaintTop;
  end;
end;

procedure TBafMenuCategory.SetExpaned(const Value: boolean);
begin
  if FExpanded <> Value then begin
    FExpanded := Value;
    FParents.Menu.Repaint;
    Application.ProcessMessages;
    FParents.Menu.Repaint;     // needs double to refesh really
  end;
end;

procedure TBafMenuCategory.SetText(const Value: string);
begin
  FText := Value;
end;

procedure TBafMenuCategory.ToggleExpanded;
begin
  Expanded := not Expanded;
end;

{ TBafMenuCategories }

function TBafMenuCategories.Add: TBafMenuCategory;
begin
  Result := AddItem(nil, -1);
end;

function TBafMenuCategories.AddItem(Item: TBafMenuCategory;
  Index: Integer): TBafMenuCategory;
begin
  if Item = nil then
    Result := TBafMenuCategory.Create(Self)
  else
  begin
    Result := Item;
    if Assigned(Item) then
    begin
      Result.Collection := Self;
      if Index < Count then
        Index := Count - 1;
      Result.Index := Index;
    end;
  end;
end;

constructor TBafMenuCategories.Create(AMenu: TBafMenu);
begin
  inherited Create(TBafMenuCategory);
  FParents.Menu := AMenu;
  FParents.Categories := Self;
end;

destructor TBafMenuCategories.Destroy;
begin

  inherited;
end;

function TBafMenuCategories.GetItem(Index: Integer): TBafMenuCategory;
begin
  Result := TBafMenuCategory(inherited GetItem(Index));
end;

function TBafMenuCategories.Insert(Index: Integer): TBafMenuCategory;
begin
  Result := AddItem(nil, Index);
end;

procedure TBafMenuCategories.SetItem(Index: Integer;
  const Value: TBafMenuCategory);
begin
  inherited SetItem(Index, Value);
end;

{ TBafMenuItems }

function TBafMenuItems.Add: TBafMenuItem;
begin
  Result := AddItem(nil, -1);
end;

function TBafMenuItems.AddItem(Item: TBafMenuItem;
  Index: Integer): TBafMenuItem;
begin
  if Item = nil then
    Result := TBafMenuItem.Create(Self)
  else
  begin
    Result := Item;
    if Assigned(Item) then
    begin
      Result.Collection := Self;
      if Index < Count then
        Index := Count - 1;
      Result.Index := Index;
    end;
  end;
end;

constructor TBafMenuItems.Create(ACategory: TBafMenuCategory);
begin
  inherited Create(TBafMenuItem);
  FParents.CreateFrom(ACategory.FParents);
  FParents.Items := Self;
end;

destructor TBafMenuItems.Destroy;
begin

  inherited;
end;

function TBafMenuItems.GetItem(Index: Integer): TBafMenuItem;
begin
  Result := TBafMenuItem(inherited GetItem(Index));
end;

function TBafMenuItems.Insert(Index: Integer): TBafMenuItem;
begin
  Result := AddItem(nil, Index);
end;

procedure TBafMenuItems.SetItem(Index: Integer; const Value: TBafMenuItem);
begin
  inherited SetItem(Index, Value);
end;

{ TBafMenuItem }

constructor TBafMenuItem.Create(Collection: TCollection);
begin
  inherited;
  FParents.CreateFrom((Collection as TBafMenuItems).FParents);
  FParents.Item := Self;
end;

destructor TBafMenuItem.Destroy;
begin

  inherited;
end;

procedure TBafMenuItem.MenuItemClick(AInNewTab: boolean);
begin
  if Assigned(FParents.Menu.FOnMenuClick) then
    FParents.Menu.FOnMenuClick(Self, FCommand, AInNewTab);
end;

procedure TBafMenuItem.Paint(ACanvas: TCanvas);
var
  LTop: single;
begin
  if Parents.Menu.HoverObject = self then
    ACanvas.Fill.Color := $FFDDDDFF
  else
    ACanvas.Fill.Color := $FF777777;
  LTop := FParents.Menu.PaintTop;
  FRect := RectF(12, LTop, ACanvas.Width - 2, LTop + 25);
  ACanvas.FillText(FRect, FText, false, 1, [], TTextAlign.Leading);
  FParents.Menu.PaintTop := LTop + 25;
end;

procedure TBafMenuItem.SetText(const Value: string);
begin
  FText := Value;
end;

end.
