Ast Playground 1. visualization
This commit is contained in:
Michael Schimmel
@@ -0,0 +1,264 @@
|
||||
unit DraggablePanel;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
System.SysUtils,
|
||||
System.Classes,
|
||||
System.UITypes,
|
||||
System.Types,
|
||||
FMX.Types,
|
||||
FMX.Controls,
|
||||
FMX.StdCtrls,
|
||||
FMX.Graphics,
|
||||
FMX.Objects;
|
||||
|
||||
type
|
||||
/// <summary>
|
||||
/// A panel that can contain other controls and can be moved by dragging its background.
|
||||
/// It custom-paints its own border and title.
|
||||
/// </summary>
|
||||
TAuraNode = class(TStyledControl)
|
||||
private
|
||||
// Flag to indicate if the control is currently being dragged.
|
||||
FIsDragging: Boolean;
|
||||
// Stores the mouse coordinates at the beginning of the drag operation.
|
||||
FDownPos: TPointF;
|
||||
// Properties for the custom-drawn border.
|
||||
FBorderColor: TAlphaColor;
|
||||
FBorderWidth: Single;
|
||||
FBorderRadius: Single;
|
||||
// Properties for the title
|
||||
FTitle: string;
|
||||
FTitleFont: TFont;
|
||||
FTitleFontColor: TAlphaColor;
|
||||
|
||||
procedure SetBorderColor(const Value: TAlphaColor);
|
||||
procedure SetBorderWidth(const Value: Single);
|
||||
procedure SetBorderRadius(const Value: Single);
|
||||
procedure SetTitle(const Value: string);
|
||||
procedure SetTitleFont(const Value: TFont);
|
||||
procedure SetTitleFontColor(const Value: TAlphaColor);
|
||||
procedure TitleFontChanged(Sender: TObject);
|
||||
protected
|
||||
procedure Paint; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
published
|
||||
// Custom border properties
|
||||
property BorderColor: TAlphaColor read FBorderColor write SetBorderColor;
|
||||
property BorderWidth: Single read FBorderWidth write SetBorderWidth;
|
||||
property BorderRadius: Single read FBorderRadius write SetBorderRadius;
|
||||
|
||||
// Title properties
|
||||
property Title: string read FTitle write SetTitle;
|
||||
property TitleFont: TFont read FTitleFont write SetTitleFont;
|
||||
property TitleFontColor: TAlphaColor read FTitleFontColor write SetTitleFontColor;
|
||||
|
||||
// Standard control properties
|
||||
property Align;
|
||||
property Anchors;
|
||||
property ClipChildren default True;
|
||||
property Cursor default crDefault;
|
||||
property DragMode default TDragMode.dmManual;
|
||||
property Enabled;
|
||||
property Height;
|
||||
property HelpContext;
|
||||
property HelpKeyword;
|
||||
property HelpType;
|
||||
property Hint;
|
||||
property HitTest default True;
|
||||
property Locked;
|
||||
property Margins;
|
||||
property Opacity;
|
||||
property Padding;
|
||||
property PopupMenu;
|
||||
property Position;
|
||||
property RotationAngle;
|
||||
property RotationCenter;
|
||||
property Scale;
|
||||
property Size;
|
||||
property StyleLookup;
|
||||
property Visible;
|
||||
property Width;
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TAuraNode }
|
||||
|
||||
constructor TAuraNode.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FIsDragging := False;
|
||||
|
||||
// Default border settings
|
||||
FBorderColor := TAlphaColors.Gray;
|
||||
FBorderWidth := 1;
|
||||
FBorderRadius := 0; // Sharp corners by default
|
||||
|
||||
// Default title settings
|
||||
FTitle := 'Node';
|
||||
FTitleFont := TFont.Create;
|
||||
FTitleFont.Family := 'Segoe UI';
|
||||
FTitleFont.Size := 11;
|
||||
FTitleFont.Style := [TFontStyle.fsBold];
|
||||
FTitleFont.OnChanged := TitleFontChanged;
|
||||
FTitleFontColor := TAlphaColors.Black;
|
||||
|
||||
Width := 80;
|
||||
Height := 45;
|
||||
|
||||
// The panel must be able to receive mouse events.
|
||||
HitTest := True;
|
||||
// Clip children to the panel's bounds.
|
||||
ClipChildren := True;
|
||||
end;
|
||||
|
||||
destructor TAuraNode.Destroy;
|
||||
begin
|
||||
FTitleFont.Free;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetBorderColor(const Value: TAlphaColor);
|
||||
begin
|
||||
if FBorderColor <> Value then
|
||||
begin
|
||||
FBorderColor := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetBorderWidth(const Value: Single);
|
||||
begin
|
||||
if FBorderWidth <> Value then
|
||||
begin
|
||||
FBorderWidth := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetBorderRadius(const Value: Single);
|
||||
begin
|
||||
if FBorderRadius <> Value then
|
||||
begin
|
||||
FBorderRadius := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetTitle(const Value: string);
|
||||
begin
|
||||
if FTitle <> Value then
|
||||
begin
|
||||
FTitle := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetTitleFont(const Value: TFont);
|
||||
begin
|
||||
FTitleFont.Assign(Value);
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetTitleFontColor(const Value: TAlphaColor);
|
||||
begin
|
||||
if FTitleFontColor <> Value then
|
||||
begin
|
||||
FTitleFontColor := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.TitleFontChanged(Sender: TObject);
|
||||
begin
|
||||
Repaint;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.Paint;
|
||||
var
|
||||
LRect, LTitleRect: TRectF;
|
||||
begin
|
||||
inherited; // Allow styled painting to occur first (if any)
|
||||
|
||||
// Custom painting for the border
|
||||
if (FBorderWidth > 0) and (FBorderColor <> TAlphaColors.Null) then
|
||||
begin
|
||||
LRect := TRectF.Create(0, 0, Width, Height);
|
||||
// Inflate inwards so the border is fully visible within the control's bounds
|
||||
LRect.Inflate(-FBorderWidth / 2, -FBorderWidth / 2);
|
||||
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
Canvas.Stroke.Color := FBorderColor;
|
||||
Canvas.Stroke.Thickness := FBorderWidth;
|
||||
|
||||
// Use DrawRoundRect to support both sharp and rounded corners
|
||||
Canvas.DrawRect(LRect, FBorderRadius, FBorderRadius, AllCorners, 1.0, TCornerType.Round);
|
||||
end;
|
||||
|
||||
// Draw the title
|
||||
if not FTitle.IsEmpty then
|
||||
begin
|
||||
// Define the rectangle for the title at the top of the control
|
||||
LTitleRect := TRectF.Create(0, FBorderWidth, Width, FBorderWidth + FTitleFont.Size * 1.8);
|
||||
|
||||
Canvas.Font.Assign(FTitleFont);
|
||||
Canvas.Fill.Color := FTitleFontColor;
|
||||
|
||||
// Draw the text centered horizontally and vertically within the title rectangle
|
||||
Canvas.FillText(LTitleRect, FTitle, False, 1.0, [], TTextAlign.Center, TTextAlign.Center);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if (Button = TMouseButton.mbLeft) then
|
||||
begin
|
||||
if (ObjectAtPoint(LocalToScreen(TPointF.Create(X, Y))) = Self as IControl) then
|
||||
begin
|
||||
FIsDragging := True;
|
||||
FDownPos := TPointF.Create(X, Y);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.MouseMove(Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if FIsDragging then
|
||||
begin
|
||||
var deltaX := X - FDownPos.X;
|
||||
var deltaY := Y - FDownPos.Y;
|
||||
|
||||
Position.X := Position.X + deltaX;
|
||||
Position.Y := Position.Y + deltaY;
|
||||
|
||||
if ParentControl <> nil then
|
||||
ParentControl.Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if (Button = TMouseButton.mbLeft) and (FIsDragging) then
|
||||
begin
|
||||
FIsDragging := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user