mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-11 13:37:45 +02:00
cody: circlediagram: create categories
git-svn-id: trunk@40011 -
This commit is contained in:
mattias
parent
d3275a4488
commit
b8da2cafab
@ -5,14 +5,20 @@ unit CodyUnitDepWnd;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, AVL_Tree, contnrs, FileUtil, lazutf8classes, LazLogger,
|
||||
TreeFilterEdit, CTUnitGraph, CodeToolManager, DefineTemplates, Forms,
|
||||
Controls, Graphics, Dialogs, ExtCtrls, Buttons, ComCtrls, LazIDEIntf,
|
||||
ProjectIntf, IDEWindowIntf;
|
||||
Classes, SysUtils, types, AVL_Tree, contnrs, FileUtil, lazutf8classes,
|
||||
LazLogger, TreeFilterEdit, CTUnitGraph, CodeToolManager, DefineTemplates,
|
||||
Forms, Controls, Graphics, Dialogs, ExtCtrls, Buttons, ComCtrls,
|
||||
LCLType, LazIDEIntf, ProjectIntf, IDEWindowIntf;
|
||||
|
||||
resourcestring
|
||||
a='';
|
||||
rsSelectAUnit = 'Select a unit';
|
||||
rsClose = 'Close';
|
||||
|
||||
const
|
||||
DefaultCategoryGap = 0.04;
|
||||
DefaultFirstCategory = 0;
|
||||
DefaultCategoryMinSize = 0.05;
|
||||
type
|
||||
TCustomCircleDiagramControl = class;
|
||||
TCircleDiagramCategory = class;
|
||||
@ -40,21 +46,28 @@ type
|
||||
TCircleDiagramCategory = class(TPersistent)
|
||||
private
|
||||
FCaption: TCaption;
|
||||
FColor: TColor;
|
||||
FDiagram: TCustomCircleDiagramControl;
|
||||
FMinSize: single;
|
||||
fItems: TObjectList; // list of TCircleDiagramItem
|
||||
function GetItems(Index: integer): TCircleDiagramItem;
|
||||
procedure SetCaption(AValue: TCaption);
|
||||
procedure SetColor(AValue: TColor);
|
||||
procedure SetMinSize(AValue: single);
|
||||
procedure UpdateLayout;
|
||||
procedure Invalidate;
|
||||
procedure InternalRemoveItem(Item: TCircleDiagramItem);
|
||||
public
|
||||
constructor Create(TheDiagram: TCustomCircleDiagramControl);
|
||||
destructor Destroy; override;
|
||||
function InsertItem(Index: integer; aCaption: string): TCircleDiagramItem;
|
||||
function AddItem(aCaption: string): TCircleDiagramItem;
|
||||
property Diagram: TCustomCircleDiagramControl read FDiagram;
|
||||
property Caption: TCaption read FCaption write SetCaption;
|
||||
property MinSize: single read FMinSize write SetMinSize;
|
||||
property MinSize: single read FMinSize write SetMinSize default DefaultCategoryMinSize;
|
||||
function Count: integer;
|
||||
property Items[Index: integer]: TCircleDiagramItem read GetItems;
|
||||
property Color: TColor read FColor write SetColor;
|
||||
end;
|
||||
|
||||
TCircleDiagramCtrlFlag = (
|
||||
@ -68,6 +81,7 @@ type
|
||||
private
|
||||
FCategoryGap: single;
|
||||
FCenterCaption: TCaption;
|
||||
FCenterCaptionRect: TRect;
|
||||
FFirstCategory: single;
|
||||
fCategories: TObjectList; // list of TCircleDiagramCategory
|
||||
fUpdateLock: integer;
|
||||
@ -76,26 +90,98 @@ type
|
||||
procedure SetCategoryGap(AValue: single);
|
||||
procedure SetCenterCaption(AValue: TCaption);
|
||||
procedure SetFirstCategory(AValue: single);
|
||||
procedure InternalRemoveCategory(Category: TCircleDiagramCategory);
|
||||
protected
|
||||
//procedure WMVScroll(var Msg: TLMScroll); message LM_VSCROLL;
|
||||
//procedure WMMouseWheel(var Message: TLMMouseEvent); message LM_MOUSEWHEEL;
|
||||
procedure CreateWnd; override;
|
||||
procedure UpdateScrollBar;
|
||||
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); 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 HandleStandardKeys(var Key: Word; Shift: TShiftState); virtual;
|
||||
//procedure HandleKeyUp(var Key: Word; Shift: TShiftState); virtual;
|
||||
|
||||
procedure Paint; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
property CenterCaption: TCaption read FCenterCaption write SetCenterCaption;
|
||||
procedure Clear;
|
||||
procedure BeginUpdate; virtual;
|
||||
procedure EndUpdate; virtual;
|
||||
procedure UpdateLayout;
|
||||
procedure EraseBackground({%H-}DC: HDC); override;
|
||||
function InsertCategory(Index: integer; aCaption: TCaption): TCircleDiagramCategory;
|
||||
function AddCategory(aCaption: TCaption): TCircleDiagramCategory;
|
||||
function IndexOfCategory(aCaption: TCaption): integer;
|
||||
function FindCategory(aCaption: TCaption): TCircleDiagramCategory;
|
||||
property CategoryGap: single read FCategoryGap write SetCategoryGap default DefaultCategoryGap; // in part of a full circle
|
||||
property FirstCategory: single read FFirstCategory write SetFirstCategory default DefaultFirstCategory; // in part of a full circle starting at top
|
||||
function CategoryCount: integer;
|
||||
property Categories[Index: integer]: TCircleDiagramCategory read GetCategories;
|
||||
property Color default clWhite;
|
||||
property CenterCaptionRect: TRect read FCenterCaptionRect;
|
||||
end;
|
||||
|
||||
{ TCircleDiagramControl }
|
||||
|
||||
TCircleDiagramControl = class(TCustomCircleDiagramControl)
|
||||
published
|
||||
|
||||
property Align;
|
||||
property Anchors;
|
||||
property BorderSpacing;
|
||||
property BorderStyle;
|
||||
property BorderWidth;
|
||||
property Color;
|
||||
property Constraints;
|
||||
property DragKind;
|
||||
property DragCursor;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property Font;
|
||||
property ParentColor default False;
|
||||
property ParentFont;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property ShowHint;
|
||||
property TabOrder;
|
||||
property TabStop default True;
|
||||
property Tag;
|
||||
property Visible;
|
||||
property OnClick;
|
||||
property OnContextPopup;
|
||||
property OnDblClick;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDrag;
|
||||
property OnEnter;
|
||||
property OnExit;
|
||||
property OnKeyDown;
|
||||
property OnKeyPress;
|
||||
property OnKeyUp;
|
||||
property OnMouseDown;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnShowHint;
|
||||
property OnStartDrag;
|
||||
property OnUTF8KeyPress;
|
||||
end;
|
||||
|
||||
TUDDUsesType = (
|
||||
uddutInterfaceUses,
|
||||
uddutImplementationUses,
|
||||
uddutUsedByInterface,
|
||||
uddutUsedByImplementation
|
||||
);
|
||||
TUDDUsesTypes = set of TUDDUsesType;
|
||||
|
||||
{ TUnitDependenciesDialog }
|
||||
|
||||
TUnitDependenciesDialog = class(TForm)
|
||||
@ -118,14 +204,17 @@ type
|
||||
FCurrentUnit: TUGUnit;
|
||||
FIdleConnected: boolean;
|
||||
FUsesGraph: TUsesGraph;
|
||||
fCircleCategories: array[TUDDUsesType] of TCircleDiagramCategory;
|
||||
procedure SetCurrentUnit(AValue: TUGUnit);
|
||||
procedure SetIdleConnected(AValue: boolean);
|
||||
procedure AddStartAndTargetUnits;
|
||||
procedure UpdateAll;
|
||||
procedure UpdateCurUnitDiagram;
|
||||
procedure UpdateCurUnitTreeView;
|
||||
function NodeTextToUnit(NodeText: string): TUGUnit;
|
||||
function UGUnitToNodeText(UGUnit: TUGUnit): string;
|
||||
public
|
||||
CurUnitDiagram: TCircleDiagramControl;
|
||||
property IdleConnected: boolean read FIdleConnected write SetIdleConnected;
|
||||
property UsesGraph: TUsesGraph read FUsesGraph;
|
||||
property CurrentUnit: TUGUnit read FCurrentUnit write SetCurrentUnit;
|
||||
@ -181,18 +270,76 @@ begin
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.InternalRemoveCategory(
|
||||
Category: TCircleDiagramCategory);
|
||||
begin
|
||||
fCategories.Remove(Category);
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.CreateWnd;
|
||||
begin
|
||||
inherited CreateWnd;
|
||||
UpdateScrollBar;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.UpdateScrollBar;
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.DoSetBounds(ALeft, ATop, AWidth,
|
||||
AHeight: integer);
|
||||
begin
|
||||
inherited DoSetBounds(ALeft, ATop, AWidth, AHeight);
|
||||
UpdateScrollBar;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.Paint;
|
||||
begin
|
||||
inherited Paint;
|
||||
if cdcNeedUpdateLayout in fFlags then
|
||||
UpdateLayout;
|
||||
|
||||
// background
|
||||
Canvas.Brush.Style:=bsSolid;
|
||||
Canvas.Brush.Color:=Color;
|
||||
Canvas.FillRect(ClientRect);
|
||||
|
||||
// center caption
|
||||
Canvas.TextOut(FCenterCaptionRect.Left,FCenterCaptionRect.Top,CenterCaption);
|
||||
end;
|
||||
|
||||
constructor TCustomCircleDiagramControl.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
fCategories:=TObjectList.create(true);
|
||||
BeginUpdate;
|
||||
try
|
||||
inherited Create(AOwner);
|
||||
fCategories:=TObjectList.create(true);
|
||||
Color:=clWhite;
|
||||
finally
|
||||
EndUpdate;
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TCustomCircleDiagramControl.Destroy;
|
||||
begin
|
||||
BeginUpdate; // disable updates
|
||||
FreeAndNil(fCategories);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.Clear;
|
||||
begin
|
||||
BeginUpdate;
|
||||
try
|
||||
while CategoryCount>0 do
|
||||
Categories[0].Free;
|
||||
finally
|
||||
EndUpdate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.BeginUpdate;
|
||||
begin
|
||||
inc(fUpdateLock);
|
||||
@ -210,19 +357,32 @@ begin
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.UpdateLayout;
|
||||
var
|
||||
aSize: TSize;
|
||||
begin
|
||||
if fUpdateLock>0 then begin
|
||||
if (fUpdateLock>0) or (not IsVisible) or (not HandleAllocated) then begin
|
||||
Include(fFlags,cdcNeedUpdateLayout);
|
||||
exit;
|
||||
end;
|
||||
Exclude(fFlags,cdcNeedUpdateLayout);
|
||||
|
||||
// center caption
|
||||
aSize:=Canvas.TextExtent(CenterCaption);
|
||||
FCenterCaptionRect:=Bounds((ClientWidth-aSize.cx) div 2,
|
||||
(ClientHeight-aSize.cy) div 2,aSize.cx,aSize.cy);
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.EraseBackground(DC: HDC);
|
||||
begin
|
||||
// do not erase background, Paint will paint the whole area
|
||||
end;
|
||||
|
||||
function TCustomCircleDiagramControl.InsertCategory(Index: integer;
|
||||
aCaption: TCaption): TCircleDiagramCategory;
|
||||
begin
|
||||
|
||||
Result:=TCircleDiagramCategory.Create(Self);
|
||||
Result.Caption:=aCaption;
|
||||
fCategories.Insert(Index,Result);
|
||||
end;
|
||||
|
||||
function TCustomCircleDiagramControl.AddCategory(aCaption: TCaption
|
||||
@ -231,6 +391,28 @@ begin
|
||||
Result:=InsertCategory(CategoryCount,aCaption);
|
||||
end;
|
||||
|
||||
function TCustomCircleDiagramControl.IndexOfCategory(aCaption: TCaption
|
||||
): integer;
|
||||
begin
|
||||
Result:=CategoryCount-1;
|
||||
while Result>=0 do begin
|
||||
if Categories[Result].Caption=aCaption then exit;
|
||||
dec(Result);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TCustomCircleDiagramControl.FindCategory(aCaption: TCaption
|
||||
): TCircleDiagramCategory;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
i:=IndexOfCategory(aCaption);
|
||||
if i>=0 then
|
||||
Result:=Categories[i]
|
||||
else
|
||||
Result:=nil;
|
||||
end;
|
||||
|
||||
function TCustomCircleDiagramControl.CategoryCount: integer;
|
||||
begin
|
||||
Result:=fCategories.Count;
|
||||
@ -244,6 +426,13 @@ begin
|
||||
FCaption:=AValue;
|
||||
end;
|
||||
|
||||
procedure TCircleDiagramCategory.SetColor(AValue: TColor);
|
||||
begin
|
||||
if FColor=AValue then Exit;
|
||||
FColor:=AValue;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
function TCircleDiagramCategory.GetItems(Index: integer): TCircleDiagramItem;
|
||||
begin
|
||||
Result:=TCircleDiagramItem(fItems[Index]);
|
||||
@ -261,6 +450,18 @@ begin
|
||||
Diagram.UpdateLayout;
|
||||
end;
|
||||
|
||||
procedure TCircleDiagramCategory.Invalidate;
|
||||
begin
|
||||
if Diagram<>nil then
|
||||
Diagram.Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCircleDiagramCategory.InternalRemoveItem(Item: TCircleDiagramItem);
|
||||
begin
|
||||
fItems.Remove(Item);
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
constructor TCircleDiagramCategory.Create(
|
||||
TheDiagram: TCustomCircleDiagramControl);
|
||||
begin
|
||||
@ -270,10 +471,25 @@ end;
|
||||
|
||||
destructor TCircleDiagramCategory.Destroy;
|
||||
begin
|
||||
if Diagram<>nil then
|
||||
Diagram.InternalRemoveCategory(Self);
|
||||
FreeAndNil(fItems);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TCircleDiagramCategory.InsertItem(Index: integer; aCaption: string
|
||||
): TCircleDiagramItem;
|
||||
begin
|
||||
Result:=TCircleDiagramItem.Create(Self);
|
||||
Result.Caption:=aCaption;
|
||||
fItems.Insert(Index,Result);
|
||||
end;
|
||||
|
||||
function TCircleDiagramCategory.AddItem(aCaption: string): TCircleDiagramItem;
|
||||
begin
|
||||
Result:=InsertItem(Count,aCaption);
|
||||
end;
|
||||
|
||||
function TCircleDiagramCategory.Count: integer;
|
||||
begin
|
||||
Result:=fItems.Count;
|
||||
@ -308,6 +524,8 @@ end;
|
||||
|
||||
destructor TCircleDiagramItem.Destroy;
|
||||
begin
|
||||
if Category<>nil then
|
||||
Category.InternalRemoveItem(Self);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
@ -341,8 +559,23 @@ begin
|
||||
ProgressBar1.Style:=pbstMarquee;
|
||||
AddStartAndTargetUnits;
|
||||
|
||||
Caption:='Unit Dependencies';
|
||||
CloseBitBtn.Caption:=rsClose;
|
||||
|
||||
IDEDialogLayoutList.ApplyLayout(Self,600,400);
|
||||
|
||||
CurUnitDiagram:=TCircleDiagramControl.Create(Self);
|
||||
with CurUnitDiagram do begin
|
||||
Name:='CurUnitDiagram';
|
||||
Align:=alClient;
|
||||
fCircleCategories[uddutInterfaceUses]:=AddCategory('Interface uses');
|
||||
fCircleCategories[uddutImplementationUses]:=AddCategory('Implementation uses');
|
||||
fCircleCategories[uddutUsedByInterface]:=AddCategory('Used by interfaces');
|
||||
fCircleCategories[uddutUsedByImplementation]:=AddCategory('Used by implementations');
|
||||
CenterCaption:=rsSelectAUnit;
|
||||
Parent:=Self;
|
||||
end;
|
||||
|
||||
IdleConnected:=true;
|
||||
end;
|
||||
|
||||
@ -385,7 +618,7 @@ procedure TUnitDependenciesDialog.SetCurrentUnit(AValue: TUGUnit);
|
||||
begin
|
||||
if FCurrentUnit=AValue then Exit;
|
||||
FCurrentUnit:=AValue;
|
||||
|
||||
UpdateCurUnitDiagram;
|
||||
end;
|
||||
|
||||
procedure TUnitDependenciesDialog.AddStartAndTargetUnits;
|
||||
@ -408,6 +641,56 @@ begin
|
||||
UpdateCurUnitTreeView;
|
||||
end;
|
||||
|
||||
procedure TUnitDependenciesDialog.UpdateCurUnitDiagram;
|
||||
|
||||
procedure UpdateCircleCategory(List: TFPList; t: TUDDUsesType);
|
||||
// List is CurrentUnit.UsesUnits or CurrentUnit.UsedByUnits
|
||||
var
|
||||
i: Integer;
|
||||
CurUses: TUGUses;
|
||||
Item: TCircleDiagramItem;
|
||||
CurUnit: TUGUnit;
|
||||
Cnt: Integer;
|
||||
s: String;
|
||||
begin
|
||||
Cnt:=0;
|
||||
for i:=0 to List.Count-1 do begin
|
||||
CurUses:=TUGUses(List[i]);
|
||||
if CurUses.InImplementation<>(t in [uddutImplementationUses,uddutUsedByImplementation])
|
||||
then continue;
|
||||
if t in [uddutInterfaceUses,uddutImplementationUses] then
|
||||
CurUnit:=CurUses.Owner
|
||||
else
|
||||
CurUnit:=CurUses.UsesUnit;
|
||||
s:=ExtractFileName(CurUnit.Filename);
|
||||
if fCircleCategories[t].Count>Cnt then begin
|
||||
Item:=fCircleCategories[t].Items[Cnt];
|
||||
Item.Caption:=s
|
||||
end else
|
||||
Item:=fCircleCategories[t].AddItem(s);
|
||||
inc(Cnt);
|
||||
end;
|
||||
while fCircleCategories[t].Count>Cnt do
|
||||
fCircleCategories[t].Items[Cnt].Free;
|
||||
end;
|
||||
|
||||
begin
|
||||
CurUnitDiagram.BeginUpdate;
|
||||
try
|
||||
if CurrentUnit<>nil then begin
|
||||
CurUnitDiagram.CenterCaption:=ExtractFilename(CurrentUnit.Filename);
|
||||
UpdateCircleCategory(CurrentUnit.UsesUnits,uddutInterfaceUses);
|
||||
UpdateCircleCategory(CurrentUnit.UsesUnits,uddutImplementationUses);
|
||||
UpdateCircleCategory(CurrentUnit.UsedByUnits,uddutUsedByInterface);
|
||||
UpdateCircleCategory(CurrentUnit.UsedByUnits,uddutUsedByImplementation);
|
||||
end else begin
|
||||
CurUnitDiagram.CenterCaption:=rsSelectAUnit;
|
||||
end;
|
||||
finally
|
||||
CurUnitDiagram.EndUpdate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TUnitDependenciesDialog.UpdateCurUnitTreeView;
|
||||
var
|
||||
AVLNode: TAVLTreeNode;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user