unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, sysutils, Forms, Controls, Graphics, Menus, ExtCtrls, ComCtrls;
type
{ VisualTree }
TVTComponentType = (Box, Circle, Connection);
TVTComponent = record
ComponentType : TVTComponentType;
ComponentImage : TShape;
Connection1 : TShape;
Connection2 : TShape;
end;
{ TForm1 }
TForm1 = class(TForm)
mniClearConnections: TMenuItem;
mniConnectTo: TMenuItem;
mniClearAll: TMenuItem;
mniSep: TMenuItem;
mniNewCircle: TMenuItem;
mniNewBox: TMenuItem;
mnuNew: TPopupMenu;
mnuComponent: TPopupMenu;
StatusBar1: TStatusBar;
procedure FormCreate(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormPaint(Sender: TObject);
procedure mniClearAllClick(Sender: TObject);
procedure mniClearConnectionsClick(Sender: TObject);
procedure mniConnectToClick(Sender: TObject);
procedure mniNewBoxClick(Sender: TObject);
procedure mniNewCircleClick(Sender: TObject);
private
VTComponents: array of TVTComponent;
procedure VTCreateConnection(ConnectTo: TShape);
// TShape events
var
TSMouseClicked: Boolean;
TSMouseClickedX: Integer;
TSMouseClickedY: Integer;
TSMouseConnectionStart: TShape;
TSMouseSelected: TShape;
procedure TSMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure TSMouseEnter(Sender: TObject);
procedure TSMouseLeave(Sender: TObject);
procedure TSMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure TSMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
SetLength(VTComponents, 0);
TSMouseClicked := False;
TSMouseConnectionStart := nil;
end;
// Show a popup menu
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if (TSMouseConnectionStart <> nil) then Exit;
mnuNew.PopUp(Left + X, Top + Y);
end;
// Draw all connections
procedure TForm1.FormPaint(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Length(VTComponents)-1 do
with VTComponents[i] do begin
if ComponentType <> Connection then Continue;
Self.Canvas.Line(Connection1.Left+30, Connection1.Top+30,
Connection2.Left+30, Connection2.Top+30);
end;
end;
// Remove all VTComponents
procedure TForm1.mniClearAllClick(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Length(VTComponents)-1 do
VTComponents[i].ComponentImage.Free;
SetLength(VTComponents, 0);
Invalidate;
end;
// Remove connections of the selected component
procedure TForm1.mniClearConnectionsClick(Sender: TObject);
var
Index : Integer;
i : Integer;
begin
repeat
Index := -1;
for i := 0 to Length(VTComponents)-1 do
with VTComponents[i] do begin
if ComponentType = Connection then
if (Connection1 = TSMouseSelected) or (Connection2 = TSMouseSelected) then begin
Index := i;
Break;
end;
end;
if (index >= 0) then begin
for i := Index to Length(VTComponents)-2 do
VTComponents[i] := VTComponents[i+1];
SetLength(VTComponents, Length(VTComponents) - 1);
end;
until (Index = -1);
Invalidate;
end;
// Start a new connection
procedure TForm1.mniConnectToClick(Sender: TObject);
begin
TSMouseConnectionStart := TSMouseSelected;
TSMouseConnectionStart.Brush.Color := clGreen;
StatusBar1.SimpleText := 'Click the target component or the green one to cancel.';
end;
// Create a box component
procedure TForm1.mniNewBoxClick(Sender: TObject);
var
NewBox : TShape;
Index : Integer;
begin
NewBox := TShape.Create(Self);
with NewBox do begin
Left := Mouse.CursorPos.x - Self.ClientOrigin.x;
Top := Mouse.CursorPos.y - Self.ClientOrigin.y;
Width := 60;
Height := 60;
Parent := Self;
OnMouseDown := @TSMouseDown;
OnMouseEnter := @TSMouseEnter;
OnMouseLeave := @TSMouseLeave;
OnMouseMove := @TSMouseMove;
OnMouseUp := @TSMouseUp;
end;
Index := Length(VTComponents);
SetLength(VTComponents, Index + 1);
with VTComponents[Index] do begin
ComponentType := Box;
ComponentImage := NewBox;
Connection1 := nil;
Connection2 := nil;
end;
end;
// Create a circle component
procedure TForm1.mniNewCircleClick(Sender: TObject);
var
NewCircle : TShape;
Index : Integer;
begin
NewCircle := TShape.Create(Self);
with NewCircle do begin
Left := Mouse.CursorPos.x - Self.ClientOrigin.x;
Top := Mouse.CursorPos.y - Self.ClientOrigin.y;
Width := 60;
Height := 60;
Shape := stCircle;
Parent := Self;
OnMouseDown := @TSMouseDown;
OnMouseEnter := @TSMouseEnter;
OnMouseLeave := @TSMouseLeave;
OnMouseMove := @TSMouseMove;
OnMouseUp := @TSMouseUp;
end;
Index := Length(VTComponents);
SetLength(VTComponents, Index + 1);
with VTComponents[Index] do begin
ComponentType := Box;
ComponentImage := NewCircle;
Connection1 := nil;
Connection2 := nil;
end;
end;
// Create a new connection
procedure TForm1.VTCreateConnection(ConnectTo: TShape);
var
Count, i, j: Integer;
begin
TSMouseConnectionStart.Brush.Color := clWhite;
StatusBar1.SimpleText := '';
Count := Length(VTComponents);
// Make sure the connection hasn't already created
for i := 0 to Count-1 do
for j := 0 to Count-1 do
if ((VTComponents[i].Connection1 = TSMouseConnectionStart) and (VTComponents[j].Connection2 = ConnectTo)) or
((VTComponents[j].Connection1 = TSMouseConnectionStart) and (VTComponents[i].Connection2 = ConnectTo)) then begin
TSMouseConnectionStart := nil;
Exit;
end;
SetLength(VTComponents, Count + 1);
with VTComponents[Count] do begin
ComponentType := Connection;
ComponentImage := nil;
Connection1 := TSMouseConnectionStart;
Connection2 := ConnectTo;
end;
TSMouseConnectionStart := nil;
Invalidate;
end;
// Show a popup menu or create a new connection or start dragging
procedure TForm1.TSMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if not(Sender is TShape) then Exit;
TSMouseSelected := (Sender as TShape);
// Right click
if (Shift = [ssRight]) and (TSMouseConnectionStart = nil) and (Length(VTComponents) > 1) then
mnuComponent.PopUp(Mouse.CursorPos.x, Mouse.CursorPos.y);
// Left click
if (Shift = [ssLeft]) then begin
if (TSMouseConnectionStart <> nil) then
VTCreateConnection(TSMouseSelected);
TSMouseClickedX := X;
TSMouseClickedY := Y;
TSMouseClicked := True;
end;
end;
// Highlight the TShape
procedure TForm1.TSMouseEnter(Sender: TObject);
begin
if not(Sender is TShape) then Exit;
if (Sender = TSMouseConnectionStart) then Exit;
(Sender as TShape).Brush.Color := clRed;
end;
// Remove the highlight
procedure TForm1.TSMouseLeave(Sender: TObject);
begin
if not(Sender is TShape) then Exit;
if (Sender = TSMouseConnectionStart) then Exit;
(Sender as TShape).Brush.Color := clWhite;
end;
// Dragging a TShape
procedure TForm1.TSMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer
);
begin
if not(Sender is TShape) or not(TSMouseClicked) then Exit;
(Sender as TShape).Left := (Sender as TShape).Left + X - TSMouseClickedX;
(Sender as TShape).Top := (Sender as TShape).Top + Y - TSMouseClickedY;
if (TSMouseClicked) then Invalidate; // Redraw connections
end;
// Mouse release
procedure TForm1.TSMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
TSMouseClicked := False;
end;
end.
Recent
