mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-02 08:39:41 +01:00
codetools: added unit groups graph
git-svn-id: trunk@40045 -
This commit is contained in:
mattias
parent
4b4469364c
commit
f4074a842f
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -639,6 +639,7 @@ components/codetools/codetoolsstructs.pas svneol=native#text/pascal
|
||||
components/codetools/codetree.pas svneol=native#text/pascal
|
||||
components/codetools/ctloadlaz.pas svneol=native#text/plain
|
||||
components/codetools/ctunitgraph.pas svneol=native#text/plain
|
||||
components/codetools/ctunitgroupgraph.pas svneol=native#text/plain
|
||||
components/codetools/ctxmlfixfragment.pas svneol=native#text/plain
|
||||
components/codetools/customcodetool.pas svneol=native#text/pascal
|
||||
components/codetools/definetemplates.pas svneol=native#text/pascal
|
||||
|
||||
@ -29,7 +29,7 @@
|
||||
<License Value="GPL-2
|
||||
"/>
|
||||
<Version Major="1" Release="1"/>
|
||||
<Files Count="59">
|
||||
<Files Count="60">
|
||||
<Item1>
|
||||
<Filename Value="Makefile"/>
|
||||
<Type Value="Text"/>
|
||||
@ -267,6 +267,10 @@
|
||||
<Filename Value="ctloadlaz.pas"/>
|
||||
<UnitName Value="ctloadlaz"/>
|
||||
</Item59>
|
||||
<Item60>
|
||||
<Filename Value="ctunitgroupgraph.pas"/>
|
||||
<UnitName Value="ctunitgroupgraph"/>
|
||||
</Item60>
|
||||
</Files>
|
||||
<LazDoc Paths="docs"/>
|
||||
<i18n>
|
||||
|
||||
@ -18,7 +18,8 @@ uses
|
||||
PascalReaderTool, PPUCodeTools, PPUGraph, PPUParser, ResourceCodeTool,
|
||||
SourceChanger, SourceLog, StdCodeTools, OtherIdentifierTree,
|
||||
CodeToolsCfgScript, CTXMLFixFragment, CTUnitGraph, ChangeDeclarationTool,
|
||||
CodeToolsFPCMsgs, UnitDictionary, ctloadlaz, LazarusPackageIntf;
|
||||
CodeToolsFPCMsgs, UnitDictionary, ctloadlaz, CTUnitGroupGraph,
|
||||
LazarusPackageIntf;
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
@ -131,8 +131,8 @@ type
|
||||
property TargetFilesTree: TAVLTree read FTargetFiles; // tree of TUGUnit sorted for Filename
|
||||
property TargetAll: boolean read FTargetAll write FTargetAll;
|
||||
|
||||
property UnitClass: TUGUnitClass read FUnitClass;
|
||||
property UsesClass: TUGUsesClass read FUsesClass;
|
||||
property UnitClass: TUGUnitClass read FUnitClass write FUnitClass;
|
||||
property UsesClass: TUGUsesClass read FUsesClass write FUsesClass;
|
||||
end;
|
||||
|
||||
function CompareUGUnitFilenames(UGUnit1, UGUnit2: Pointer): integer;
|
||||
|
||||
202
components/codetools/ctunitgroupgraph.pas
Normal file
202
components/codetools/ctunitgroupgraph.pas
Normal file
@ -0,0 +1,202 @@
|
||||
{
|
||||
***************************************************************************
|
||||
* *
|
||||
* This source is free software; you can redistribute it and/or modify *
|
||||
* it under the terms of the GNU General Public License as published by *
|
||||
* the Free Software Foundation; either version 2 of the License, or *
|
||||
* (at your option) any later version. *
|
||||
* *
|
||||
* This code is distributed in the hope that it will be useful, but *
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
||||
* General Public License for more details. *
|
||||
* *
|
||||
* A copy of the GNU General Public License is available on the World *
|
||||
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
||||
* obtain it by writing to the Free Software Foundation, *
|
||||
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
|
||||
* *
|
||||
***************************************************************************
|
||||
|
||||
Author: Mattias Gaertner
|
||||
|
||||
Abstract:
|
||||
Functions and classes to build dependency graphs for groups of pascal units.
|
||||
}
|
||||
unit CTUnitGroupGraph;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, AVL_Tree, CTUnitGraph;
|
||||
|
||||
type
|
||||
TUGGroup = class;
|
||||
TUGGroups = class;
|
||||
|
||||
{ TUGGroupUnit }
|
||||
|
||||
TUGGroupUnit = class(TUGUnit)
|
||||
public
|
||||
Group: TUGGroup;
|
||||
end;
|
||||
|
||||
TUGGroup = class
|
||||
private
|
||||
FGroups: TUGGroups;
|
||||
FName: string;
|
||||
FUnits: TAVLTree;
|
||||
procedure SetName(AValue: string);
|
||||
public
|
||||
constructor Create(aName: string; TheGroups: TUGGroups);
|
||||
destructor Destroy; override;
|
||||
procedure Clear;
|
||||
procedure AddUnit(anUnit: TUGGroupUnit);
|
||||
procedure RemoveUnit(anUnit: TUGGroupUnit);
|
||||
property Name: string read FName write SetName;
|
||||
property Groups: TUGGroups read FGroups;
|
||||
property Units: TAVLTree read FUnits; // tree of TUGGroupUnit sorted for Filename
|
||||
end;
|
||||
|
||||
{ TUGGroups }
|
||||
|
||||
TUGGroups = class
|
||||
private
|
||||
fClearing: boolean;
|
||||
FGroups: TAVLTree;
|
||||
public
|
||||
constructor Create(Graph: TUsesGraph);
|
||||
destructor Destroy; override;
|
||||
procedure Clear;
|
||||
function GetGroup(Name: string; CreateIfNotExists: boolean): TUGGroup;
|
||||
property Groups: TAVLTree read FGroups; // tree of TUGGroup sorted for Name
|
||||
end;
|
||||
|
||||
function CompareUGGroupNames(UGGroup1, UGGroup2: Pointer): integer;
|
||||
function CompareNameAndUGGroup(NameAnsistring, UGGroup: Pointer): integer;
|
||||
|
||||
implementation
|
||||
|
||||
function CompareUGGroupNames(UGGroup1, UGGroup2: Pointer): integer;
|
||||
var
|
||||
Group1: TUGGroup absolute UGGroup1;
|
||||
Group2: TUGGroup absolute UGGroup2;
|
||||
begin
|
||||
Result:=SysUtils.CompareText(Group1.Name,Group2.Name);
|
||||
end;
|
||||
|
||||
function CompareNameAndUGGroup(NameAnsistring, UGGroup: Pointer): integer;
|
||||
var
|
||||
Group: TUGGroup absolute UGGroup;
|
||||
Name: String;
|
||||
begin
|
||||
Name:=AnsiString(NameAnsistring);
|
||||
Result:=SysUtils.CompareText(Name,Group.Name);
|
||||
end;
|
||||
|
||||
{ TUGGroups }
|
||||
|
||||
constructor TUGGroups.Create(Graph: TUsesGraph);
|
||||
begin
|
||||
FGroups:=TAVLTree.Create(@CompareUGGroupNames);
|
||||
if (not Graph.UnitClass.InheritsFrom(TUGGroup))
|
||||
and ((Graph.FilesTree.Count>0) or (Graph.QueuedFilesTree.Count>0)
|
||||
or (Graph.TargetFilesTree.Count>0))
|
||||
then
|
||||
raise Exception.Create('TUGGroups.Create Create TUGGroups before adding units');
|
||||
Graph.UnitClass:=TUGGroupUnit;
|
||||
end;
|
||||
|
||||
destructor TUGGroups.Destroy;
|
||||
begin
|
||||
Clear;
|
||||
FreeAndNil(FGroups);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TUGGroups.Clear;
|
||||
begin
|
||||
fClearing:=true;
|
||||
try
|
||||
FGroups.FreeAndClear;
|
||||
finally
|
||||
fClearing:=false;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TUGGroups.GetGroup(Name: string; CreateIfNotExists: boolean): TUGGroup;
|
||||
var
|
||||
Node: TAVLTreeNode;
|
||||
begin
|
||||
Node:=FGroups.FindKey(Pointer(Name),@CompareNameAndUGGroup);
|
||||
if Node<>nil then begin
|
||||
Result:=TUGGroup(Node.Data);
|
||||
end else if CreateIfNotExists then begin
|
||||
Result:=TUGGroup.Create(Name,Self);
|
||||
FGroups.Add(Result);
|
||||
end else
|
||||
Result:=nil;
|
||||
end;
|
||||
|
||||
{ TUGGroup }
|
||||
|
||||
procedure TUGGroup.SetName(AValue: string);
|
||||
begin
|
||||
if FName=AValue then Exit;
|
||||
if Groups.GetGroup(AValue,false)<>nil then
|
||||
raise Exception.Create('TUGGroup.SetName name already exists');
|
||||
Groups.fGroups.Remove(Self);
|
||||
FName:=AValue;
|
||||
Groups.fGroups.Add(Self);
|
||||
end;
|
||||
|
||||
constructor TUGGroup.Create(aName: string; TheGroups: TUGGroups);
|
||||
begin
|
||||
FGroups:=TheGroups;
|
||||
FUnits:=TAVLTree.Create(@CompareUGUnitFilenames);
|
||||
end;
|
||||
|
||||
destructor TUGGroup.Destroy;
|
||||
begin
|
||||
Clear;
|
||||
if not Groups.fClearing then
|
||||
Groups.FGroups.Remove(Self);
|
||||
fGroups:=nil;
|
||||
FreeAndNil(FUnits);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TUGGroup.Clear;
|
||||
var
|
||||
Node: TAVLTreeNode;
|
||||
begin
|
||||
Node:=FUnits.FindLowest;
|
||||
while Node<>nil do begin
|
||||
TUGGroupUnit(Node.Data).Group:=nil;
|
||||
Node:=FUnits.FindSuccessor(Node);
|
||||
end;
|
||||
FUnits.Clear;
|
||||
end;
|
||||
|
||||
procedure TUGGroup.AddUnit(anUnit: TUGGroupUnit);
|
||||
begin
|
||||
if anUnit.Group<>nil then begin
|
||||
anUnit.Group.FUnits.Remove(anUnit);
|
||||
anUnit.Group:=nil;
|
||||
end;
|
||||
FUnits.Add(anUnit);
|
||||
anUnit.Group:=Self;
|
||||
end;
|
||||
|
||||
procedure TUGGroup.RemoveUnit(anUnit: TUGGroupUnit);
|
||||
begin
|
||||
if (anUnit.Group<>nil) and (anUnit.Group<>Self) then
|
||||
raise Exception.Create('TUGGroup.RemoveUnit inconsistency');
|
||||
FUnits.Remove(anUnit);
|
||||
anUnit.Group:=nil;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -30,7 +30,8 @@ unit CodyCtrls;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, ComCtrls, Controls;
|
||||
types, math, contnrs, Classes, SysUtils, FPCanvas,
|
||||
LazLogger, ComCtrls, Controls, Graphics, LCLType;
|
||||
|
||||
type
|
||||
|
||||
@ -41,8 +42,195 @@ type
|
||||
procedure FreeNodeData;
|
||||
end;
|
||||
|
||||
const
|
||||
FullCircle16 = 360*16;
|
||||
DefaultCategoryGapDegree16 = 0.02*FullCircle16;
|
||||
DefaultFirstCategoryDegree16 = 0;
|
||||
DefaultCategoryMinSize = 1.0;
|
||||
DefaultItemSize = 1.0;
|
||||
type
|
||||
TCustomCircleDiagramControl = class;
|
||||
TCircleDiagramCategory = class;
|
||||
|
||||
{ TCircleDiagramItem }
|
||||
|
||||
TCircleDiagramItem = class(TPersistent)
|
||||
private
|
||||
FCaption: TCaption;
|
||||
FCategory: TCircleDiagramCategory;
|
||||
FEndDegree16: single;
|
||||
FSize: single;
|
||||
FStartDegree16: single;
|
||||
procedure SetCaption(AValue: TCaption);
|
||||
procedure SetSize(AValue: single);
|
||||
procedure UpdateLayout;
|
||||
public
|
||||
constructor Create(TheCategory: TCircleDiagramCategory);
|
||||
destructor Destroy; override;
|
||||
property Category: TCircleDiagramCategory read FCategory;
|
||||
property Caption: TCaption read FCaption write SetCaption;
|
||||
property Size: single read FSize write SetSize default DefaultItemSize; // scaled to fit
|
||||
property StartDegree16: single read FStartDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
property EndDegree16: single read FEndDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
end;
|
||||
|
||||
{ TCircleDiagramCategory }
|
||||
|
||||
TCircleDiagramCategory = class(TPersistent)
|
||||
private
|
||||
FCaption: TCaption;
|
||||
FColor: TColor;
|
||||
FDiagram: TCustomCircleDiagramControl;
|
||||
FEndDegree16: single;
|
||||
FMinSize: single;
|
||||
fItems: TObjectList; // list of TCircleDiagramItem
|
||||
FSize: single;
|
||||
FStartDegree16: single;
|
||||
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 default DefaultCategoryMinSize; // scaled to fit
|
||||
function Count: integer;
|
||||
property Items[Index: integer]: TCircleDiagramItem read GetItems; default;
|
||||
property Color: TColor read FColor write SetColor;
|
||||
property Size: single read FSize;
|
||||
property StartDegree16: single read FStartDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
property EndDegree16: single read FEndDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
end;
|
||||
|
||||
TCircleDiagramCtrlFlag = (
|
||||
cdcNeedUpdateLayout
|
||||
);
|
||||
TCircleDiagramCtrlFlags = set of TCircleDiagramCtrlFlag;
|
||||
|
||||
{ TCustomCircleDiagramControl }
|
||||
|
||||
TCustomCircleDiagramControl = class(TCustomControl)
|
||||
private
|
||||
FCategoryGapDegree16: single;
|
||||
FCenter: TPoint;
|
||||
FCenterCaption: TCaption;
|
||||
FCenterCaptionRect: TRect;
|
||||
FFirstCategoryDegree16: single;
|
||||
fCategories: TObjectList; // list of TCircleDiagramCategory
|
||||
FInnerRadius: single;
|
||||
FOuterRadius: single;
|
||||
fUpdateLock: integer;
|
||||
fFlags: TCircleDiagramCtrlFlags;
|
||||
function GetCategories(Index: integer): TCircleDiagramCategory;
|
||||
procedure SetCategoryGapDegree16(AValue: single);
|
||||
procedure SetCenterCaption(AValue: TCaption);
|
||||
procedure SetFirstCategoryDegree16(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;
|
||||
procedure DrawCategory(i: integer);
|
||||
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 CategoryGapDegree16: single read FCategoryGapDegree16 write SetCategoryGapDegree16 default DefaultCategoryGapDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
property FirstCategoryDegree16: single read FFirstCategoryDegree16 write SetFirstCategoryDegree16 default DefaultFirstCategoryDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
function CategoryCount: integer;
|
||||
property Categories[Index: integer]: TCircleDiagramCategory read GetCategories; default;
|
||||
property Color default clWhite;
|
||||
// computed values
|
||||
property CenterCaptionRect: TRect read FCenterCaptionRect;
|
||||
property Center: TPoint read FCenter;
|
||||
property InnerRadius: single read FInnerRadius;
|
||||
property OuterRadius: single read FOuterRadius;
|
||||
|
||||
// debugging
|
||||
procedure WriteDebugReport(Msg: string);
|
||||
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;
|
||||
|
||||
procedure FreeTVNodeData(TV: TCustomTreeView);
|
||||
|
||||
procedure RingSector(Canvas: TFPCustomCanvas; x1, y1, x2, y2: integer;
|
||||
InnerSize: single; StartAngle16, EndAngle16: integer); overload;
|
||||
procedure RingSector(Canvas: TFPCustomCanvas; x1, y1, x2, y2,
|
||||
InnerSize, StartAngle, EndAngle: single); overload;
|
||||
|
||||
implementation
|
||||
|
||||
procedure FreeTVNodeData(TV: TCustomTreeView);
|
||||
@ -61,6 +249,53 @@ begin
|
||||
TV.EndUpdate;
|
||||
end;
|
||||
|
||||
procedure RingSector(Canvas: TFPCustomCanvas; x1, y1, x2, y2: integer;
|
||||
InnerSize: single; StartAngle16, EndAngle16: integer);
|
||||
begin
|
||||
RingSector(Canvas,single(x1),single(y1),single(x2),single(y2),InnerSize,
|
||||
single(StartAngle16)/16,single(EndAngle16)/16);
|
||||
end;
|
||||
|
||||
procedure RingSector(Canvas: TFPCustomCanvas; x1, y1, x2, y2, InnerSize, StartAngle,
|
||||
EndAngle: single);
|
||||
var
|
||||
OuterCnt: integer;
|
||||
centerx, centery: single;
|
||||
i: Integer;
|
||||
Ang: single;
|
||||
OuterRadiusX, OuterRadiusY, InnerRadiusX, InnerRadiusY: single;
|
||||
Points: array of TPoint;
|
||||
j: Integer;
|
||||
begin
|
||||
OuterCnt:=Round(SQRT((Abs(x2-x1)+Abs(y2-y1))*Abs(EndAngle-StartAngle)/FullCircle16)+0.5);
|
||||
centerx:=(x1+x2)/2;
|
||||
centery:=(y1+y2)/2;
|
||||
OuterRadiusX:=(x2-x1)/2;
|
||||
OuterRadiusY:=(y2-y1)/2;
|
||||
InnerRadiusX:=OuterRadiusX*InnerSize;
|
||||
InnerRadiusY:=OuterRadiusY*InnerSize;
|
||||
SetLength(Points,OuterCnt*2+2);
|
||||
j:=0;
|
||||
// outer arc
|
||||
for i:=0 to OuterCnt do begin
|
||||
Ang:=StartAngle+((EndAngle-StartAngle)/OuterCnt)*single(i);
|
||||
Ang:=(Ang/FullCircle16)*2*pi;
|
||||
Points[j].x:=round(centerx+cos(Ang)*OuterRadiusX);
|
||||
Points[j].y:=round(centery-sin(Ang)*OuterRadiusY);
|
||||
inc(j);
|
||||
end;
|
||||
// inner arc
|
||||
for i:=OuterCnt downto 0 do begin
|
||||
Ang:=StartAngle+((EndAngle-StartAngle)/OuterCnt)*single(i);
|
||||
Ang:=(Ang/FullCircle16)*2*pi;
|
||||
Points[j].x:=round(centerx+cos(Ang)*InnerRadiusX);
|
||||
Points[j].y:=round(centery-sin(Ang)*InnerRadiusY);
|
||||
inc(j);
|
||||
end;
|
||||
Canvas.Polygon(Points);
|
||||
SetLength(Points,0);
|
||||
end;
|
||||
|
||||
{ TCodyTreeView }
|
||||
|
||||
procedure TCodyTreeView.FreeNodeData;
|
||||
@ -68,5 +303,403 @@ begin
|
||||
FreeTVNodeData(Self);
|
||||
end;
|
||||
|
||||
{ TCustomCircleDiagramControl }
|
||||
|
||||
procedure TCustomCircleDiagramControl.SetCategoryGapDegree16(AValue: single);
|
||||
begin
|
||||
if AValue<0 then AValue:=0;
|
||||
if AValue>0.3 then AValue:=0.3;
|
||||
if FCategoryGapDegree16=AValue then Exit;
|
||||
FCategoryGapDegree16:=AValue;
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
function TCustomCircleDiagramControl.GetCategories(Index: integer
|
||||
): TCircleDiagramCategory;
|
||||
begin
|
||||
Result:=TCircleDiagramCategory(fCategories[Index]);
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.SetCenterCaption(AValue: TCaption);
|
||||
begin
|
||||
if FCenterCaption=AValue then Exit;
|
||||
FCenterCaption:=AValue;
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.SetFirstCategoryDegree16(AValue: single);
|
||||
begin
|
||||
if FFirstCategoryDegree16=AValue then Exit;
|
||||
FFirstCategoryDegree16:=AValue;
|
||||
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;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
inherited Paint;
|
||||
if cdcNeedUpdateLayout in fFlags then
|
||||
UpdateLayout;
|
||||
|
||||
// background
|
||||
Canvas.Brush.Style:=bsSolid;
|
||||
Canvas.Brush.Color:=Color;
|
||||
Canvas.FillRect(ClientRect);
|
||||
|
||||
Canvas.Brush.Color:=clRed;
|
||||
|
||||
// draw categories
|
||||
for i:=0 to CategoryCount-1 do
|
||||
DrawCategory(i);
|
||||
|
||||
// center caption
|
||||
Canvas.Brush.Style:=bsSolid;
|
||||
Canvas.Brush.Color:=clNone;
|
||||
Canvas.TextOut(FCenterCaptionRect.Left,FCenterCaptionRect.Top,CenterCaption);
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.DrawCategory(i: integer);
|
||||
var
|
||||
Cat: TCircleDiagramCategory;
|
||||
begin
|
||||
Cat:=Categories[i];
|
||||
Canvas.Brush.Color:=Cat.Color;
|
||||
RingSector(Canvas,Center.X-OuterRadius,Center.Y-OuterRadius,
|
||||
Center.X+OuterRadius,Center.Y+OuterRadius,
|
||||
single(InnerRadius)/single(OuterRadius),
|
||||
Cat.StartDegree16,Cat.EndDegree16);
|
||||
end;
|
||||
|
||||
constructor TCustomCircleDiagramControl.Create(AOwner: TComponent);
|
||||
begin
|
||||
BeginUpdate;
|
||||
try
|
||||
inherited Create(AOwner);
|
||||
fCategories:=TObjectList.create(true);
|
||||
FFirstCategoryDegree16:=DefaultFirstCategoryDegree16;
|
||||
FCategoryGapDegree16:=DefaultCategoryGapDegree16;
|
||||
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);
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.EndUpdate;
|
||||
begin
|
||||
if fUpdateLock=0 then
|
||||
raise Exception.Create('TCustomCircleDiagramControl.EndUpdate');
|
||||
dec(fUpdateLock);
|
||||
if fUpdateLock=0 then begin
|
||||
if cdcNeedUpdateLayout in fFlags then
|
||||
UpdateLayout;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.UpdateLayout;
|
||||
var
|
||||
aSize: TSize;
|
||||
aCategory: TCircleDiagramCategory;
|
||||
i: Integer;
|
||||
j: Integer;
|
||||
TotalSize: Single;
|
||||
CurCategoryDegree: Single;
|
||||
GapDegree: Single;
|
||||
TotalItemDegree: Single;
|
||||
Item: TCircleDiagramItem;
|
||||
CurItemDegree: Single;
|
||||
begin
|
||||
if (fUpdateLock>0) or (not IsVisible) or (not HandleAllocated) then begin
|
||||
Include(fFlags,cdcNeedUpdateLayout);
|
||||
exit;
|
||||
end;
|
||||
Exclude(fFlags,cdcNeedUpdateLayout);
|
||||
|
||||
// center caption
|
||||
FCenter:=Point(ClientWidth div 2,ClientHeight div 2);
|
||||
aSize:=Canvas.TextExtent(CenterCaption);
|
||||
FCenterCaptionRect:=Bounds(FCenter.X-(aSize.cx div 2),FCenter.Y-(aSize.cy div 2)
|
||||
,aSize.cx,aSize.cy);
|
||||
|
||||
// radius
|
||||
fInnerRadius:=0.25*Min(ClientWidth,ClientHeight);
|
||||
fOuterRadius:=1.1*InnerRadius;
|
||||
|
||||
// degrees
|
||||
TotalSize:=0.0;
|
||||
CurCategoryDegree:=FirstCategoryDegree16;
|
||||
if CategoryCount>0 then begin
|
||||
// calculate TotalSize
|
||||
for i:=0 to CategoryCount-1 do begin
|
||||
aCategory:=Categories[i];
|
||||
aCategory.FSize:=0;
|
||||
for j:=0 to aCategory.Count-1 do
|
||||
aCategory.FSize+=aCategory[j].Size;
|
||||
aCategory.FSize:=Max(aCategory.FSize,aCategory.MinSize);
|
||||
TotalSize+=aCategory.FSize;
|
||||
end;
|
||||
|
||||
// calculate degrees
|
||||
GapDegree:=Min(CategoryGapDegree16,(0.8/CategoryCount)*FullCircle16);
|
||||
TotalItemDegree:=FullCircle16-(GapDegree*CategoryCount);
|
||||
for i:=0 to CategoryCount-1 do begin
|
||||
aCategory:=Categories[i];
|
||||
aCategory.FStartDegree16:=CurCategoryDegree;
|
||||
if TotalSize>0 then
|
||||
CurCategoryDegree+=TotalItemDegree*aCategory.Size/TotalSize;
|
||||
aCategory.FEndDegree16:=CurCategoryDegree;
|
||||
|
||||
// item degrees
|
||||
CurItemDegree:=aCategory.StartDegree16;
|
||||
for j:=0 to aCategory.Count-1 do begin
|
||||
Item:=aCategory[j];
|
||||
|
||||
Item.FStartDegree16:=CurItemDegree;
|
||||
if aCategory.Size>0 then
|
||||
CurItemDegree+=(aCategory.EndDegree16-aCategory.StartDegree16)*Item.Size/aCategory.Size;
|
||||
Item.FEndDegree16:=CurItemDegree;
|
||||
end;
|
||||
|
||||
CurCategoryDegree+=GapDegree;
|
||||
end;
|
||||
end;
|
||||
|
||||
WriteDebugReport('TCustomCircleDiagramControl.UpdateLayout');
|
||||
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
|
||||
): TCircleDiagramCategory;
|
||||
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;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.WriteDebugReport(Msg: string);
|
||||
var
|
||||
aCat: TCircleDiagramCategory;
|
||||
i: Integer;
|
||||
j: Integer;
|
||||
Item: TCircleDiagramItem;
|
||||
begin
|
||||
DebugLn([Msg,' CategoryCount=',CategoryCount]);
|
||||
for i:=0 to CategoryCount-1 do begin
|
||||
aCat:=Categories[i];
|
||||
debugln([' Category: ',i,'/',CategoryCount,' ',aCat.Caption,
|
||||
' MinSize=',aCat.MinSize,
|
||||
' Size=',aCat.Size,
|
||||
' Start=',round(aCat.StartDegree16),' End=',round(aCat.EndDegree16)]);
|
||||
for j:=0 to aCat.Count-1 do begin
|
||||
Item:=aCat.Items[j];
|
||||
debugln([' Item: ',j,'/',aCat.Count,' ',Item.Caption,
|
||||
' Size=',Item.Size,
|
||||
' Start=',round(Item.StartDegree16),
|
||||
' End=',round(Item.EndDegree16)]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TCircleDiagramCategory }
|
||||
|
||||
procedure TCircleDiagramCategory.SetCaption(AValue: TCaption);
|
||||
begin
|
||||
if FCaption=AValue then Exit;
|
||||
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]);
|
||||
end;
|
||||
|
||||
procedure TCircleDiagramCategory.SetMinSize(AValue: single);
|
||||
begin
|
||||
if AValue<0 then AValue:=0;
|
||||
if FMinSize=AValue then Exit;
|
||||
FMinSize:=AValue;
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
procedure TCircleDiagramCategory.UpdateLayout;
|
||||
begin
|
||||
if Diagram<>nil then
|
||||
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
|
||||
FDiagram:=TheDiagram;
|
||||
fItems:=TObjectList.Create(true);
|
||||
FMinSize:=DefaultCategoryMinSize;
|
||||
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;
|
||||
end;
|
||||
|
||||
{ TCircleDiagramItem }
|
||||
|
||||
procedure TCircleDiagramItem.SetCaption(AValue: TCaption);
|
||||
begin
|
||||
if FCaption=AValue then Exit;
|
||||
FCaption:=AValue;
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
procedure TCircleDiagramItem.SetSize(AValue: single);
|
||||
begin
|
||||
if AValue<0 then AValue:=0;
|
||||
if FSize=AValue then Exit;
|
||||
FSize:=AValue;
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
procedure TCircleDiagramItem.UpdateLayout;
|
||||
begin
|
||||
if Category<>nil then
|
||||
Category.UpdateLayout;
|
||||
end;
|
||||
|
||||
constructor TCircleDiagramItem.Create(TheCategory: TCircleDiagramCategory);
|
||||
begin
|
||||
FCategory:=TheCategory;
|
||||
FSize:=DefaultItemSize;
|
||||
end;
|
||||
|
||||
destructor TCircleDiagramItem.Destroy;
|
||||
begin
|
||||
if Category<>nil then
|
||||
Category.InternalRemoveItem(Self);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
|
||||
@ -5,198 +5,18 @@ unit CodyUnitDepWnd;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, types, math, typinfo, AVL_Tree, contnrs, FPCanvas,
|
||||
FileUtil, lazutf8classes, LazLogger, TreeFilterEdit, CTUnitGraph,
|
||||
CodeToolManager, DefineTemplates, Forms, Controls, Graphics, Dialogs,
|
||||
ExtCtrls, Buttons, ComCtrls, LCLType, LazIDEIntf, ProjectIntf, IDEWindowIntf;
|
||||
Classes, SysUtils, typinfo, AVL_Tree, FPCanvas,
|
||||
FileUtil, lazutf8classes, LazLogger,
|
||||
TreeFilterEdit, Forms, Controls, Graphics, Dialogs, ExtCtrls, Buttons,
|
||||
ComCtrls, LCLType,
|
||||
LazIDEIntf, ProjectIntf, IDEWindowIntf,
|
||||
CTUnitGraph, CodeToolManager, DefineTemplates, CTUnitGroupGraph,
|
||||
CodyCtrls;
|
||||
|
||||
resourcestring
|
||||
a='';
|
||||
rsSelectAUnit = 'Select an unit';
|
||||
rsClose = 'Close';
|
||||
|
||||
const
|
||||
FullCircle16 = 360*16;
|
||||
DefaultCategoryGapDegree16 = 0.02*FullCircle16;
|
||||
DefaultFirstCategoryDegree16 = 0;
|
||||
DefaultCategoryMinSize = 1.0;
|
||||
DefaultItemSize = 1.0;
|
||||
type
|
||||
TCustomCircleDiagramControl = class;
|
||||
TCircleDiagramCategory = class;
|
||||
|
||||
{ TCircleDiagramItem }
|
||||
|
||||
TCircleDiagramItem = class(TPersistent)
|
||||
private
|
||||
FCaption: TCaption;
|
||||
FCategory: TCircleDiagramCategory;
|
||||
FEndDegree16: single;
|
||||
FSize: single;
|
||||
FStartDegree16: single;
|
||||
procedure SetCaption(AValue: TCaption);
|
||||
procedure SetSize(AValue: single);
|
||||
procedure UpdateLayout;
|
||||
public
|
||||
constructor Create(TheCategory: TCircleDiagramCategory);
|
||||
destructor Destroy; override;
|
||||
property Category: TCircleDiagramCategory read FCategory;
|
||||
property Caption: TCaption read FCaption write SetCaption;
|
||||
property Size: single read FSize write SetSize default DefaultItemSize; // scaled to fit
|
||||
property StartDegree16: single read FStartDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
property EndDegree16: single read FEndDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
end;
|
||||
|
||||
{ TCircleDiagramCategory }
|
||||
|
||||
TCircleDiagramCategory = class(TPersistent)
|
||||
private
|
||||
FCaption: TCaption;
|
||||
FColor: TColor;
|
||||
FDiagram: TCustomCircleDiagramControl;
|
||||
FEndDegree16: single;
|
||||
FMinSize: single;
|
||||
fItems: TObjectList; // list of TCircleDiagramItem
|
||||
FSize: single;
|
||||
FStartDegree16: single;
|
||||
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 default DefaultCategoryMinSize; // scaled to fit
|
||||
function Count: integer;
|
||||
property Items[Index: integer]: TCircleDiagramItem read GetItems; default;
|
||||
property Color: TColor read FColor write SetColor;
|
||||
property Size: single read FSize;
|
||||
property StartDegree16: single read FStartDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
property EndDegree16: single read FEndDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
end;
|
||||
|
||||
TCircleDiagramCtrlFlag = (
|
||||
cdcNeedUpdateLayout
|
||||
);
|
||||
TCircleDiagramCtrlFlags = set of TCircleDiagramCtrlFlag;
|
||||
|
||||
{ TCustomCircleDiagramControl }
|
||||
|
||||
TCustomCircleDiagramControl = class(TCustomControl)
|
||||
private
|
||||
FCategoryGapDegree16: single;
|
||||
FCenter: TPoint;
|
||||
FCenterCaption: TCaption;
|
||||
FCenterCaptionRect: TRect;
|
||||
FFirstCategoryDegree16: single;
|
||||
fCategories: TObjectList; // list of TCircleDiagramCategory
|
||||
FInnerRadius: single;
|
||||
FOuterRadius: single;
|
||||
fUpdateLock: integer;
|
||||
fFlags: TCircleDiagramCtrlFlags;
|
||||
function GetCategories(Index: integer): TCircleDiagramCategory;
|
||||
procedure SetCategoryGapDegree16(AValue: single);
|
||||
procedure SetCenterCaption(AValue: TCaption);
|
||||
procedure SetFirstCategoryDegree16(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;
|
||||
procedure DrawCategory(i: integer);
|
||||
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 CategoryGapDegree16: single read FCategoryGapDegree16 write SetCategoryGapDegree16 default DefaultCategoryGapDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
property FirstCategoryDegree16: single read FFirstCategoryDegree16 write SetFirstCategoryDegree16 default DefaultFirstCategoryDegree16; // 360*16 = one full circle, 0 at 3o'clock
|
||||
function CategoryCount: integer;
|
||||
property Categories[Index: integer]: TCircleDiagramCategory read GetCategories; default;
|
||||
property Color default clWhite;
|
||||
// computed values
|
||||
property CenterCaptionRect: TRect read FCenterCaptionRect;
|
||||
property Center: TPoint read FCenter;
|
||||
property InnerRadius: single read FInnerRadius;
|
||||
property OuterRadius: single read FOuterRadius;
|
||||
|
||||
// debugging
|
||||
procedure WriteDebugReport(Msg: string);
|
||||
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,
|
||||
@ -227,6 +47,7 @@ type
|
||||
FCurrentUnit: TUGUnit;
|
||||
FIdleConnected: boolean;
|
||||
FUsesGraph: TUsesGraph;
|
||||
FGroups: TUGGroups;
|
||||
fCircleCategories: array[TUDDUsesType] of TCircleDiagramCategory;
|
||||
procedure SetCurrentUnit(AValue: TUGUnit);
|
||||
procedure SetIdleConnected(AValue: boolean);
|
||||
@ -240,6 +61,7 @@ type
|
||||
CurUnitDiagram: TCircleDiagramControl;
|
||||
property IdleConnected: boolean read FIdleConnected write SetIdleConnected;
|
||||
property UsesGraph: TUsesGraph read FUsesGraph;
|
||||
property Groups: TUGGroups read FGroups;
|
||||
property CurrentUnit: TUGUnit read FCurrentUnit write SetCurrentUnit;
|
||||
end;
|
||||
|
||||
@ -248,10 +70,6 @@ var
|
||||
|
||||
procedure ShowUnitDependenciesDialog(Sender: TObject);
|
||||
|
||||
procedure RingSector(Canvas: TFPCustomCanvas; x1, y1, x2, y2: integer;
|
||||
InnerSize: single; StartAngle16, EndAngle16: integer); overload;
|
||||
procedure RingSector(Canvas: TFPCustomCanvas; x1, y1, x2, y2, InnerSize, StartAngle, EndAngle: single); overload;
|
||||
|
||||
function dbgs(t: TUDDUsesType): string; overload;
|
||||
|
||||
implementation
|
||||
@ -268,456 +86,11 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure RingSector(Canvas: TFPCustomCanvas; x1, y1, x2, y2: integer;
|
||||
InnerSize: single; StartAngle16, EndAngle16: integer);
|
||||
begin
|
||||
RingSector(Canvas,single(x1),single(y1),single(x2),single(y2),InnerSize,
|
||||
single(StartAngle16)/16,single(EndAngle16)/16);
|
||||
end;
|
||||
|
||||
procedure RingSector(Canvas: TFPCustomCanvas; x1, y1, x2, y2, InnerSize, StartAngle,
|
||||
EndAngle: single);
|
||||
var
|
||||
OuterCnt: integer;
|
||||
centerx, centery: single;
|
||||
i: Integer;
|
||||
Ang: single;
|
||||
OuterRadiusX, OuterRadiusY, InnerRadiusX, InnerRadiusY: single;
|
||||
Points: array of TPoint;
|
||||
j: Integer;
|
||||
begin
|
||||
OuterCnt:=Round(SQRT((Abs(x2-x1)+Abs(y2-y1))*Abs(EndAngle-StartAngle)/FullCircle16)+0.5);
|
||||
centerx:=(x1+x2)/2;
|
||||
centery:=(y1+y2)/2;
|
||||
OuterRadiusX:=(x2-x1)/2;
|
||||
OuterRadiusY:=(y2-y1)/2;
|
||||
InnerRadiusX:=OuterRadiusX*InnerSize;
|
||||
InnerRadiusY:=OuterRadiusY*InnerSize;
|
||||
SetLength(Points,OuterCnt*2+2);
|
||||
j:=0;
|
||||
// outer arc
|
||||
for i:=0 to OuterCnt do begin
|
||||
Ang:=StartAngle+((EndAngle-StartAngle)/OuterCnt)*single(i);
|
||||
Ang:=(Ang/FullCircle16)*2*pi;
|
||||
Points[j].x:=round(centerx+cos(Ang)*OuterRadiusX);
|
||||
Points[j].y:=round(centery-sin(Ang)*OuterRadiusY);
|
||||
inc(j);
|
||||
end;
|
||||
// inner arc
|
||||
for i:=OuterCnt downto 0 do begin
|
||||
Ang:=StartAngle+((EndAngle-StartAngle)/OuterCnt)*single(i);
|
||||
Ang:=(Ang/FullCircle16)*2*pi;
|
||||
Points[j].x:=round(centerx+cos(Ang)*InnerRadiusX);
|
||||
Points[j].y:=round(centery-sin(Ang)*InnerRadiusY);
|
||||
inc(j);
|
||||
end;
|
||||
Canvas.Polygon(Points);
|
||||
SetLength(Points,0);
|
||||
end;
|
||||
|
||||
function dbgs(t: TUDDUsesType): string;
|
||||
begin
|
||||
Result:=GetEnumName(typeinfo(TUDDUsesType),ord(t));
|
||||
end;
|
||||
|
||||
{ TCustomCircleDiagramControl }
|
||||
|
||||
procedure TCustomCircleDiagramControl.SetCategoryGapDegree16(AValue: single);
|
||||
begin
|
||||
if AValue<0 then AValue:=0;
|
||||
if AValue>0.3 then AValue:=0.3;
|
||||
if FCategoryGapDegree16=AValue then Exit;
|
||||
FCategoryGapDegree16:=AValue;
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
function TCustomCircleDiagramControl.GetCategories(Index: integer
|
||||
): TCircleDiagramCategory;
|
||||
begin
|
||||
Result:=TCircleDiagramCategory(fCategories[Index]);
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.SetCenterCaption(AValue: TCaption);
|
||||
begin
|
||||
if FCenterCaption=AValue then Exit;
|
||||
FCenterCaption:=AValue;
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.SetFirstCategoryDegree16(AValue: single);
|
||||
begin
|
||||
if FFirstCategoryDegree16=AValue then Exit;
|
||||
FFirstCategoryDegree16:=AValue;
|
||||
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;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
inherited Paint;
|
||||
if cdcNeedUpdateLayout in fFlags then
|
||||
UpdateLayout;
|
||||
|
||||
// background
|
||||
Canvas.Brush.Style:=bsSolid;
|
||||
Canvas.Brush.Color:=Color;
|
||||
Canvas.FillRect(ClientRect);
|
||||
|
||||
Canvas.Brush.Color:=clRed;
|
||||
|
||||
// draw categories
|
||||
for i:=0 to CategoryCount-1 do
|
||||
DrawCategory(i);
|
||||
|
||||
// center caption
|
||||
Canvas.Brush.Style:=bsSolid;
|
||||
Canvas.Brush.Color:=clNone;
|
||||
Canvas.TextOut(FCenterCaptionRect.Left,FCenterCaptionRect.Top,CenterCaption);
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.DrawCategory(i: integer);
|
||||
var
|
||||
Cat: TCircleDiagramCategory;
|
||||
begin
|
||||
Cat:=Categories[i];
|
||||
Canvas.Brush.Color:=Cat.Color;
|
||||
RingSector(Canvas,Center.X-OuterRadius,Center.Y-OuterRadius,
|
||||
Center.X+OuterRadius,Center.Y+OuterRadius,
|
||||
single(InnerRadius)/single(OuterRadius),
|
||||
Cat.StartDegree16,Cat.EndDegree16);
|
||||
end;
|
||||
|
||||
constructor TCustomCircleDiagramControl.Create(AOwner: TComponent);
|
||||
begin
|
||||
BeginUpdate;
|
||||
try
|
||||
inherited Create(AOwner);
|
||||
fCategories:=TObjectList.create(true);
|
||||
FFirstCategoryDegree16:=DefaultFirstCategoryDegree16;
|
||||
FCategoryGapDegree16:=DefaultCategoryGapDegree16;
|
||||
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);
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.EndUpdate;
|
||||
begin
|
||||
if fUpdateLock=0 then
|
||||
raise Exception.Create('TCustomCircleDiagramControl.EndUpdate');
|
||||
dec(fUpdateLock);
|
||||
if fUpdateLock=0 then begin
|
||||
if cdcNeedUpdateLayout in fFlags then
|
||||
UpdateLayout;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.UpdateLayout;
|
||||
var
|
||||
aSize: TSize;
|
||||
aCategory: TCircleDiagramCategory;
|
||||
i: Integer;
|
||||
j: Integer;
|
||||
TotalSize: Single;
|
||||
CurCategoryDegree: Single;
|
||||
GapDegree: Single;
|
||||
TotalItemDegree: Single;
|
||||
Item: TCircleDiagramItem;
|
||||
CurItemDegree: Single;
|
||||
begin
|
||||
if (fUpdateLock>0) or (not IsVisible) or (not HandleAllocated) then begin
|
||||
Include(fFlags,cdcNeedUpdateLayout);
|
||||
exit;
|
||||
end;
|
||||
Exclude(fFlags,cdcNeedUpdateLayout);
|
||||
|
||||
// center caption
|
||||
FCenter:=Point(ClientWidth div 2,ClientHeight div 2);
|
||||
aSize:=Canvas.TextExtent(CenterCaption);
|
||||
FCenterCaptionRect:=Bounds(FCenter.X-(aSize.cx div 2),FCenter.Y-(aSize.cy div 2)
|
||||
,aSize.cx,aSize.cy);
|
||||
|
||||
// radius
|
||||
fInnerRadius:=0.25*Min(ClientWidth,ClientHeight);
|
||||
fOuterRadius:=1.1*InnerRadius;
|
||||
|
||||
// degrees
|
||||
TotalSize:=0.0;
|
||||
CurCategoryDegree:=FirstCategoryDegree16;
|
||||
if CategoryCount>0 then begin
|
||||
// calculate TotalSize
|
||||
for i:=0 to CategoryCount-1 do begin
|
||||
aCategory:=Categories[i];
|
||||
aCategory.FSize:=0;
|
||||
for j:=0 to aCategory.Count-1 do
|
||||
aCategory.FSize+=aCategory[j].Size;
|
||||
aCategory.FSize:=Max(aCategory.FSize,aCategory.MinSize);
|
||||
TotalSize+=aCategory.FSize;
|
||||
end;
|
||||
|
||||
// calculate degrees
|
||||
GapDegree:=Min(CategoryGapDegree16,(0.8/CategoryCount)*FullCircle16);
|
||||
TotalItemDegree:=FullCircle16-(GapDegree*CategoryCount);
|
||||
for i:=0 to CategoryCount-1 do begin
|
||||
aCategory:=Categories[i];
|
||||
aCategory.FStartDegree16:=CurCategoryDegree;
|
||||
if TotalSize>0 then
|
||||
CurCategoryDegree+=TotalItemDegree*aCategory.Size/TotalSize;
|
||||
aCategory.FEndDegree16:=CurCategoryDegree;
|
||||
|
||||
// item degrees
|
||||
CurItemDegree:=aCategory.StartDegree16;
|
||||
for j:=0 to aCategory.Count-1 do begin
|
||||
Item:=aCategory[j];
|
||||
|
||||
Item.FStartDegree16:=CurItemDegree;
|
||||
if aCategory.Size>0 then
|
||||
CurItemDegree+=(aCategory.EndDegree16-aCategory.StartDegree16)*Item.Size/aCategory.Size;
|
||||
Item.FEndDegree16:=CurItemDegree;
|
||||
end;
|
||||
|
||||
CurCategoryDegree+=GapDegree;
|
||||
end;
|
||||
end;
|
||||
|
||||
WriteDebugReport('TCustomCircleDiagramControl.UpdateLayout');
|
||||
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
|
||||
): TCircleDiagramCategory;
|
||||
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;
|
||||
end;
|
||||
|
||||
procedure TCustomCircleDiagramControl.WriteDebugReport(Msg: string);
|
||||
var
|
||||
aCat: TCircleDiagramCategory;
|
||||
i: Integer;
|
||||
j: Integer;
|
||||
Item: TCircleDiagramItem;
|
||||
begin
|
||||
debugln([Msg,' CategoryCount=',CategoryCount]);
|
||||
for i:=0 to CategoryCount-1 do begin
|
||||
aCat:=Categories[i];
|
||||
debugln([' Category: ',i,'/',CategoryCount,' ',aCat.Caption,
|
||||
' MinSize=',aCat.MinSize,
|
||||
' Size=',aCat.Size,
|
||||
' Start=',round(aCat.StartDegree16),' End=',round(aCat.EndDegree16)]);
|
||||
for j:=0 to aCat.Count-1 do begin
|
||||
Item:=aCat.Items[j];
|
||||
debugln([' Item: ',j,'/',aCat.Count,' ',Item.Caption,
|
||||
' Size=',Item.Size,
|
||||
' Start=',round(Item.StartDegree16),
|
||||
' End=',round(Item.EndDegree16)]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TCircleDiagramCategory }
|
||||
|
||||
procedure TCircleDiagramCategory.SetCaption(AValue: TCaption);
|
||||
begin
|
||||
if FCaption=AValue then Exit;
|
||||
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]);
|
||||
end;
|
||||
|
||||
procedure TCircleDiagramCategory.SetMinSize(AValue: single);
|
||||
begin
|
||||
if AValue<0 then AValue:=0;
|
||||
if FMinSize=AValue then Exit;
|
||||
FMinSize:=AValue;
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
procedure TCircleDiagramCategory.UpdateLayout;
|
||||
begin
|
||||
if Diagram<>nil then
|
||||
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
|
||||
FDiagram:=TheDiagram;
|
||||
fItems:=TObjectList.Create(true);
|
||||
FMinSize:=DefaultCategoryMinSize;
|
||||
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;
|
||||
end;
|
||||
|
||||
{ TCircleDiagramItem }
|
||||
|
||||
procedure TCircleDiagramItem.SetCaption(AValue: TCaption);
|
||||
begin
|
||||
if FCaption=AValue then Exit;
|
||||
FCaption:=AValue;
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
procedure TCircleDiagramItem.SetSize(AValue: single);
|
||||
begin
|
||||
if AValue<0 then AValue:=0;
|
||||
if FSize=AValue then Exit;
|
||||
FSize:=AValue;
|
||||
UpdateLayout;
|
||||
end;
|
||||
|
||||
procedure TCircleDiagramItem.UpdateLayout;
|
||||
begin
|
||||
if Category<>nil then
|
||||
Category.UpdateLayout;
|
||||
end;
|
||||
|
||||
constructor TCircleDiagramItem.Create(TheCategory: TCircleDiagramCategory);
|
||||
begin
|
||||
FCategory:=TheCategory;
|
||||
FSize:=DefaultItemSize;
|
||||
end;
|
||||
|
||||
destructor TCircleDiagramItem.Destroy;
|
||||
begin
|
||||
if Category<>nil then
|
||||
Category.InternalRemoveItem(Self);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TUnitDependenciesDialog }
|
||||
|
||||
procedure TUnitDependenciesDialog.CloseBitBtnClick(Sender: TObject);
|
||||
@ -745,6 +118,7 @@ end;
|
||||
procedure TUnitDependenciesDialog.FormCreate(Sender: TObject);
|
||||
begin
|
||||
FUsesGraph:=CodeToolBoss.CreateUsesGraph;
|
||||
FGroups:=TUGGroups.Create(FUsesGraph);
|
||||
ProgressBar1.Style:=pbstMarquee;
|
||||
AddStartAndTargetUnits;
|
||||
|
||||
@ -776,6 +150,7 @@ end;
|
||||
procedure TUnitDependenciesDialog.FormDestroy(Sender: TObject);
|
||||
begin
|
||||
IdleConnected:=false;
|
||||
FreeAndNil(FGroups);
|
||||
FreeAndNil(FUsesGraph);
|
||||
end;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user