Pienso que mejor hacer objecto para toda esquema.
Aproximamante así:
Código Delphi
[-]
unit Schem;
interface
uses
Windows, Classes, Messages, Controls, Graphics, Contnrs,
Fig, Elem;
type
TCreateFigureFunc = function(): TFigure of object;
TScheme = class(TCustomControl)
private
FRoot: TFigure;
FAddNewFigureMode: Boolean;
FCreateNewFigureFunc: TCreateFigureFunc;
procedure DrawGrid;
protected
function CreateRoot: TFigure; virtual; abstract;
public
property Root: TFigure read FRoot;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure AddNewFigureNextClick(ACreateNewFigureFunc: TCreateFigureFunc);
procedure AddFigure(Figure: TFigure); virtual;
end;
implementation
uses SysUtils;
constructor TScheme.Create(AOwner: TComponent);
begin
inherited;
DoubleBuffered := True;
ControlStyle := ControlStyle + [csOpaque];
FRoot := CreateRoot;
end;
destructor TScheme.Destroy;
begin
FRoot.Free;
inherited;
end;
procedure TScheme.AddNewFigureNextClick(ACreateNewFigureFunc: TCreateFigureFunc);
begin
FAddNewFigureMode := True;
FCreateNewFigureFunc := ACreateNewFigureFunc;
end;
procedure TScheme.AddFigure(Figure: TFigure);
begin
if FRoot is TFigureList then
(FRoot as TFigureList).Add(Figure)
else
raise Exception.Create('You nee to override AddFigure');
end;
procedure TScheme.DrawGrid;
var i, j, H, W: Integer;
R: TRect;
begin
R := ClientRect;
W := R.Right - R.Left;
H := R.Bottom - R.Top;
Canvas.Pen.Color := clBlack;
for i := 0 to W div SNAP_SIZE do
for j := 0 to H div SNAP_SIZE do
Canvas.Pixels[i*SNAP_SIZE, j*SNAP_SIZE] := clBlack;
end;
procedure TScheme.Paint;
begin
inherited;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := clWhite;
Canvas.Pen.Mode := pmCopy;
Canvas.Rectangle(ClientRect);
DrawGrid;
FRoot.DoDraw(Canvas);
end;
procedure TScheme.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
FRoot.DoKeyDown(Key, Shift);
Invalidate;
end;
type
THackFigure = class(TFigure);
procedure TScheme.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var Handled: Boolean;
NewFigure: TFigure;
R: TRect;
begin
inherited;
Handled := False;
if FAddNewFigureMode then
begin
if Assigned(FCreateNewFigureFunc) then
begin
NewFigure := FCreateNewFigureFunc;
R := NewFigure.Rect;
OffsetRect(R, X - R.Left, Y - R.Top);
NewFigure.Rect := R;
AddFigure(NewFigure);
end;
FAddNewFigureMode := False;
Handled := True;
THackFigure(FRoot).SetAgent(nil);
Invalidate;
Exit;
end;
FRoot.DoMouseDown(Button, Shift, X, Y, Handled);
Invalidate;
end;
procedure TScheme.MouseMove(Shift: TShiftState; X, Y: Integer);
var cr: TCursor;
begin
inherited;
FRoot.DoMouseMove(Shift, X, Y, cr);
Invalidate;
end;
procedure TScheme.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
FRoot.DoMouseUp(Button, Shift, X, Y, GlobalMouseCaptured);
Invalidate;
end;
end.
unit main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, Buttons,
Fig, Elem, Schem;
type
TBlockScheme = class;
TForm1 = class(TForm)
BNew2x2: TSpeedButton;
procedure FormCreate(Sender: TObject);
procedure BNew2x2Click(Sender: TObject);
private
FScheme: TBlockScheme;
FLast2x2Index: Integer;
public
function CreateBlock2x2: TFigure;
end;
TBlockScheme = class(TScheme)
private
function GetRoot: TBlockList;
protected
function CreateRoot: TFigure; override;
public
property Root: TBlockList read GetRoot;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function TBlockScheme.CreateRoot: TFigure;
begin
Result := TBlockList.Create;
end;
function TBlockScheme.GetRoot: TBlockList;
begin
Result := inherited Root as TBlockList;
end;
procedure TForm1.FormCreate(Sender: TObject);
var bl: TBlock;
begin
BNew2x2.GroupIndex := 1;
BNew2x2.AllowAllUp := True;
FScheme := TBlockScheme.Create(Self);
FScheme.Parent := Self;
FScheme.BoundsRect := Rect(30, 50, 650, 420);
end;
function TForm1.CreateBlock2x2: TFigure;
var bl: TBlock;
begin
Inc(FLast2x2Index);
bl := TBlock.Create;
bl.Rect := Rect(420, 120, 480+1, 165+1);
bl.Name := 'Test Block 3';
TContact.Create(bl, ckInput);
TContact.Create(bl, ckInput);
TContact.Create(bl, ckOutput);
TContact.Create(bl, ckOutput);
bl.Name := 'Block 2x2 - ' + IntToStr(FLast2x2Index);
Result := bl;
BNew2x2.Down := False;
end;
procedure TForm1.BNew2x2Click(Sender: TObject);
begin
BNew2x2.Down := True;
FScheme.AddNewFigureNextClick(CreateBlock2x2);
end;
end.