|
unit Graphs;
//----------------------------------------------------------------------------
//
//----------------------------------------------------------------------------
interface
uses
//----------------------------------------------------------------------------
//local
//----------------------------------------------------------------------------
OwnUtils,GenDefs,Utilities,OptionClass,language,
//----------------------------------------------------------------------------
//global
//----------------------------------------------------------------------------
Types,Graphics,Printers,ExtCtrls;
//----------------------------------------------------------------------------
//
//----------------------------------------------------------------------------
type
TGraphShape=(shRectangle,shRoundRectAngle,shElipse,shCircle,shRhombus,
shSquare,shHuman,shDatabase,shMonitor,shBar);
//----------------------------------------------------------------------------
TArcOrientation=(aoSouthWest,aoSouthEast,aoNorthEast,aoNorthWest);
//----------------------------------------------------------------------------
PGraphVertice=^TGraphVertice;
TGraphVertice= record
Tree:integer;
Target:boolean;
Shape:TGraphShape;
Position:TPoint;
NodeWeight:integer;
StartNode:boolean;
FinalNode:boolean;
CircleNode:boolean;
DecisionNode:integer;
Visited:boolean;
end;
//----------------------------------------------------------------------------
TGraphEdge= record
Side: array [1..2] of integer;
Labeled:JStringKeyMax;
MultipleEdge:boolean;
EdgePos:TPoint;
EdgeFil:StringFilemax;
end;
//----------------------------------------------------------------------------
PGraphMap=^TGraphMap;
TGraphMap= record
Nodes: array of integer;
Types: array of NType;
Map:PGraphMap;
MaxWeight,SumWeight:integer;
MaxLeft,MaxRight,MaxTop,MaxBottom:integer;
end;
//----------------------------------------------------------------------------
TGraph= Class(TObject)
Vertices: array of TGraphVertice;
Edges: array of TGraphEdge;
Map:PGraphMap;
CStream:PAnsiChar;
Bezeichnung:JStringKeyMax;
Beznr:integer;
Verticecount,EdgeCount:integer;
LastMarked:integer;//for marking
MaxWeight,SumWeight:integer;
Width,Height:integer;//virtual size
VWidth,VHeight:integer;//virtual size
VTop,VLeft:integer;//virtual size
Content:PLongTexts;//Pointer to Tree
B:TBitmap;
Im,Imclear:TImage;
diameter:variant;//dia of Node
Sidelength:variant;//sidelength of square
//fontsize:variant;//
XBorder:integer;//border horizontal
YBorder:integer;//border vertical
Selected:integer;
MaxLeft,MaxRight,MaxTop,MaxBottom:integer;
Hint:JString;
Hintpos:TPoint;
LastSim:Tcolor;
PI:real;
//
Linethickness:integer;
//FontColor,BackgroundColor:Tcolor;
//FontName:JString;
//FontStyle:TFontStyles;
//
constructor Create(FontSiz,Lineth:integer;FontCol,BackgroundCol:Tcolor;
FontNam:JString;FontStyl:TFontStyles;nr:integer;Txt:JString);
destructor Destroy;override;
procedure ImproveGraph();
procedure SortGraph();
procedure ScaleGraph();
function GraphOrientation():TPrinterOrientation;
function crossing(var S:TPoint;P1,P2,Q1,Q2:TPoint):boolean;
function Maps(i:integer):PGraphVertice;
function GraphCirclesCompress():boolean;
function GraphWeightsCompress():boolean;
function CollapsNode(var GM:PGraphMap;other:integer):boolean;
function GraphStubShow(Tm:integer):boolean;
procedure GraphWeights(OM:PGraphMap);
procedure GraphExpand();
procedure GraphCircles(n:integer);
function AddVertex(n:integer):integer;
procedure AddEdge(S:JString);
function FindNode(n:integer):integer;
procedure DeleteNode(n:integer);
function PointCoordinates(n:integer):TPoint;
function GetNodeTyp(S:JString;var ini:integer):NType;
function getgraph(var TVL:LongTexts):boolean;
procedure DrawGraph();
procedure PCo(r:TRect;n:integer;O:boolean);
procedure DetermineGraphSize();
procedure Edge(O,G:TPoint;T:JString;multiple:boolean);
procedure Vertex(Typ:NType;P:TPoint;T:JString;Mark:boolean;
ou,pebbles:integer);
procedure Grid(P:TPoint;DrawGrid:boolean);
procedure Recreate(var Img:TImage;var B:TBitmap);
procedure LabelEdge(O,G:TPoint;T:JString);
procedure Arrowend(var B:TBitmap;P:TPoint;A:real;L:integer);
procedure DrawConnectArc(O,G:TPoint;angle:variant);
procedure DrawConnectLine(O,G:TPoint;angle:variant);
procedure DrawConnectParallelLine(O,G:TPoint;angle:variant);
procedure DrawConnectCircle(P:TPoint);
procedure DrawArc(const Canvas:TCanvas;const color:Tcolor;
const orientation:TArcOrientation;const x1,y1,x2,y2:integer;
const BoundRect:TRect);
procedure Arrowstart(var B:TBitmap;P:TPoint;A:real;L:integer);
function FindGraphNode(Im:TImage;P:TPoint):integer;
procedure GraphPositbyText(TF:JString;var Img:TImage);
procedure GraphPositbyNode(Tm:integer;var Img:TImage);
procedure GraphSimulate();
procedure GraphSimulateRepeated();
procedure GraphTraverse(n:integer);
procedure ReDraw();
end;
//----------------------------------------------------------
//
//----------------------------------------------------------
implementation
uses
Messages,SysUtils,Variants,Classes,Controls,Forms,Dialogs,
StdCtrls,jpeg,Menus,ToolWin,Buttons,Math,StrUtils,
ImgList,Chart,CheckLst,Clipbrd,ComCtrls,DateUtils;
//----------------------------------------------------------
//
//----------------------------------------------------------
constructor TGraph.Create(FontSiz,Lineth:integer;FontCol,BackgroundCol:Tcolor;
FontNam:JString;FontStyl:TFontStyles;nr:integer;Txt:JString);
begin
inherited Create();
//fontsize:=FontSiz;
Linethickness:=Lineth;
//FontColor:=FontCol;
//BackgroundColor:=BackgroundCol;
//FontName:=FontNam;
//FontStyle:=FontStyl;
PI:=2*arcsin(1);
BezNr:=Nr;
setl(Bezeichnung,Txt);
end;
//----------------------------------------------------------
//
//----------------------------------------------------------
destructor TGraph.Destroy;
var P,Q:PGraphMap;
begin
P:=Map;
while (P<>nil) do begin
Q:=P;
P:=P.Map;
Dispose(Q);
end;
inherited Free;
end;
//----------------------------------------------------------
//
//----------------------------------------------------------
function TGraph.Maps(i:integer):PGraphVertice;
var
M:PGraphMap;
begin
if Map<>nil then begin
M:=Map;
while (M.Map<>nil) do
M:=M.Map;
end
else begin
M:=nil;
end;
if M<>nil then
Maps:=@Vertices[M.Nodes[i]]
else
Maps:=@Vertices[i];
end;
//----------------------------------------------------------------------------
//
//----------------------------------------------------------------------------
procedure TGraph.ImproveGraph();
begin
SortGraph();
end;
//----------------------------------------------------------------------------
//
//----------------------------------------------------------------------------
function TGraph.GraphOrientation():TPrinterOrientation;
var
Orient:TPrinterOrientation;
GM:PGraphMap;
mr,ml,mt,mb:integer;
begin
ScaleGraph();
GM:=Map;
if GM=nil then begin
ml:=MaxLeft;
mr:=MaxRight;
mt:=MaxTop;
mb:=MaxBottom;
end
else begin
while GM.Map<>nil do
GM:=GM.Map;
ml:=GM.MaxLeft;
mr:=GM.MaxRight;
mt:=GM.MaxTop;
mb:=GM.MaxBottom;
end;
if abs(mr-ml)>abs(mb-mt) then
Orient:=poLandscape
else
Orient:=poPortrait;
GraphOrientation:=Orient;
end;
//------------------------------------------------------------------
//--
//On mouse down in Graph --
//--
//------------------------------------------------------------------
function TGraph.FindGraphNode(Im:TImage;P:TPoint):integer;
var
Tm,i,dc,dsm:integer;
CP:TPoint;
begin
Tm:=-1;
dsm:=8000*8000;
for i:=1 to Verticecount do begin //search for min x**2+y**2
CP:=Maps(i).Position;
dc:=sqr(P.X-CP.X)+sqr(P.Y-CP.Y);
if (dc<dsm) then begin
dsm:=dc;
Tm:=i;
end;
end;
//if dsm>Sidelength*G.Sidelength then
//tm:=-1;
FindGraphNode:=Tm
end;
//------------------------------------------------------------------
//--
//scale width and height of graph --
//--
//------------------------------------------------------------------
procedure TGraph.ScaleGraph();
var
i:integer;
GM:PGraphMap;
begin
GM:=Map;
if GM<>nil then begin
While GM.Map<>nil do
GM:=GM.Map;
GM.MaxLeft:=2000;
GM.MaxRight:=0;
GM.MaxTop:=2000;
GM.MaxBottom:=0;
for i:=1 to Verticecount do begin //get coordinates of nodes
If Maps(i).Position.X<MaxLeft then
MaxLeft:=Maps(i).Position.X;
If Maps(i).Position.X>MaxRight then
MaxRight:=Maps(i).Position.X;
If Maps(i).Position.Y<MaxTop then
MaxTop:=Maps(i).Position.Y;
If Maps(i).Position.Y>MaxBottom then
MaxBottom:=Maps(i).Position.Y;
end;
end
else begin
MaxLeft:=8000;
MaxRight:=-1;
MaxTop:=8000;
MaxBottom:=-1;
for i:=1 to Verticecount do begin //get coordinates of nodes
If Vertices[i].Position.X<MaxLeft then
MaxLeft:=Vertices[i].Position.X;
If Vertices[i].Position.X>MaxRight then
MaxRight:=Vertices[i].Position.X;
If Vertices[i].Position.Y<MaxTop then
MaxTop:=Vertices[i].Position.Y;
If Vertices[i].Position.Y>MaxBottom then
MaxBottom:=Vertices[i].Position.Y;
end;
end;
end;
//------------------------------------------------------------------
//--
//sort graph by Position --
//--
//------------------------------------------------------------------
procedure TGraph.SortGraph();
var
i,j,k,pb,pe:integer;
P:TPoint;
function nodeisgreater(P1:TPoint;w1:integer;P2:TPoint;w2:integer):boolean;
var
ig:boolean;
rd1,rd2,gw,gh:integer;
begin
gw:=max(Width,VWidth);
gh:=max(Height,VHeight);
with P1 do
rd1:=abs(min(min(X,gw-X),min(Y,gh-Y)));
with P2 do
rd2:=abs(min(min(X,gw-X),min(Y,gh-Y)));
ig:=(rd1>rd2)and(w1<=w2);
nodeisgreater:=ig
end;
procedure exchange;
begin
P:=Maps(pb).Position;
Maps(pb).Position:=Maps(pe).Position;
Maps(pe).Position:=P;
end;
begin
for i:=1 to EdgeCount do begin //sort Nodes by Weight
for j:=i+1 to EdgeCount do begin //sort Nodes by Weight
for k:=1 to 2 do begin
pb:=Edges[i].Side[k];
pe:=Edges[j].Side[k];
if nodeisgreater(Maps(pe).Position,Maps(pe).NodeWeight,
Maps(pb).Position,Maps(pb).NodeWeight) then
exchange
end;
end;
end;
end;
//------------------------------------------------------------------
//--
//find circles in graph --
//--
//------------------------------------------------------------------
procedure TGraph.GraphCircles(n:integer);
var
i,j,newlength:integer;
recurrent:boolean;
begin
if VerticeStp>=Length(VerticeStack) then begin
newlength:=Floor(Length(VerticeStack)*3/2);
if VerticeStp>5 then
errorn(92,'Setze neue Länge VerticeStack');
SetLength(VerticeStack,newlength);
end;
VerticeStp:=VerticeStp+1;
VerticeStack[VerticeStp]:=n;
for j:=1 to EdgeCount do
if Edges[j].Side[1]=n then begin
recurrent:=false;
for i:=1 to VerticeStp do
if VerticeStack[i]=Edges[j].Side[2] then
recurrent:=true;
if not recurrent then
GraphCircles(Edges[j].Side[2])
else
Maps(n).CircleNode:=true;
end;
VerticeStp:=VerticeStp-1
end;
//------------------------------------------------------------------
//--
//does an edge cros another adge? --
//--
//------------------------------------------------------------------
function TGraph.crossing(var S:TPoint;P1,P2,Q1,Q2:TPoint):boolean;
var
waage1,waage2,senke1,senke2:boolean;
tana1,tana2,alpha1,alpha2,d1,d2:real;
begin
S.X:=0;
S.Y:=0;
waage1:=false;
waage2:=false;
senke1:=false;
senke2:=false;
alpha1:=0;
alpha2:=0;
d1:=0;
d2:=0;
crossing:=false;
if (P2.X-P1.X<>0)and(P2.Y-P1.Y<>0) then begin
//P1.Y = alpha1*P1.X+d1
//-> d1 = P1.Y - alpha*P1.X
tana1:=(P2.Y-P1.Y)/(P2.X-P1.X);
alpha1:=arctan(tana1);
d1:=P1.Y-alpha1*P1.X;
//P1.Y.=alpha1*P1.x+d1
end
else begin
//ist waagerecht oder senkrecht
if (P2.X-P1.X=0) then
waage1:=true;
if (P2.Y-P1.Y=0) then
senke1:=true;
end;
if (Q2.X-Q1.X<>0)and(Q2.Y-Q1.Y<>0) then begin
tana2:=(Q2.Y-Q1.Y)/(Q2.X-Q1.X);
alpha2:=arctan(tana2);
d2:=Q1.Y-alpha2*Q1.X;
//Q1.Y=alpha2*Q1.x+d2
end
else begin
//ist waagerecht oder senkrecht
if (Q2.X-Q1.X=0) then
waage2:=true;
if (Q2.Y-Q1.Y=0) then
senke2:=true;
end;
if not(waage1 or waage2 or senke1 or senke2) then begin
//alpha1*x+d1=alpha2*x+d2
//-> x(alpha1-alpha2)=d2-d1
//-> x=(d2-d1)/(alpha1-alpha2)
if abs(alpha1)<>abs(alpha2) then begin
S.X:=Floor((d2-d1)/(alpha1-alpha2));
S.Y:=Floor(alpha1*S.X+d1);
crossing:=true;
end
else if d1=d2 then begin
S.X:=P1.X;
S.Y:=Floor(alpha1*S.X+d1);
crossing:=true;
end;
end
else if not senke1 and not senke2 and not waage1 and waage2 then begin
S.X:=Q1.X;
S.Y:=Floor(alpha1*S.X+d1);
crossing:=true;
end
else if not senke1 and not senke2 and waage1 and not waage2 then begin
S.X:=P1.X;
S.Y:=Floor(alpha2*S.X+d2);
crossing:=true;
end
else if not senke1 and not senke2 and waage1 and waage2 then begin
S.X:=P1.X;
S.Y:=P2.X;
crossing:=P1.X=Q1.X;
end
else if not senke1 and senke2 and not waage1 and not waage2 then begin
S.Y:=Q1.Y;
S.X:=Floor((S.Y-d1)/alpha1);
crossing:=true;
end
else if not senke1 and senke2 and not waage1 and waage2 then begin
//impossible
end
else if not senke1 and senke2 and waage1 and not waage2 then begin
S.X:=Q1.X;
S.Y:=P1.Y;
crossing:=true;
end
else if not senke1 and senke2 and waage1 and waage2 then begin
//impossible
end
else if senke1 and not senke2 and not waage1 and not waage2 then begin
S.Y:=P1.Y;
S.X:=Floor((S.Y-d2)/alpha2);
crossing:=true;
end
else if senke1 and not senke2 and not waage1 and waage2 then begin
S.X:=Q1.X;
S.Y:=P1.Y;
crossing:=true;
end
else if senke1 and not senke2 and waage1 and not waage2 then begin
//impossible
end
else if senke1 and not senke2 and waage1 and waage2 then begin
//impossible
end
else if senke1 and senke2 and not waage1 and not waage2 then begin
if P1.Y=Q1.Y then begin
S.X:=P1.X;
S.Y:=P1.Y;
crossing:=true;
end
end
else if senke1 and senke2 and not waage1 and waage2 then begin
//impossible
end
else if senke1 and senke2 and waage1 and not waage2 then begin
//impossible
end
else if senke1 and senke2 and waage1 and waage2 then begin
//impossible
end;
end;
//------------------------------------------------------------------
//--
//compress circles of graph --
//--
//------------------------------------------------------------------
function TGraph.GraphCirclesCompress():boolean;
var
node,i,left,right:integer;
GM,OM:PGraphMap;
ret:boolean;
procedure Single(this:integer);
var
vert,i,newlength:integer;
recptr,nod,newnod:integer;
begin
if VerticeStp>=Length(VerticeStack) then begin
newlength:=Floor(Length(VerticeStack)*3/2);
if VerticeStp>5 then
errorn(93,'Setze neue Länge VerticeStack');
SetLength(VerticeStack,newlength);
end;
VerticeStp:=VerticeStp+1;
VerticeStack[VerticeStp]:=this;
for vert:=1 to EdgeCount do begin
left:=Edges[vert].Side[1];
right:=Edges[vert].Side[2];
if (left=this)and(left<>right) then begin
recptr:=0;
for i:=1 to VerticeStp-1 do
if VerticeStack[i]=Edges[vert].Side[2] then
recptr:=i;
if recptr=0 then begin
Single(right)
end
else begin
ret:=true;
nod:=VerticeStack[recptr];//create a new mapping
newnod:=nod;
for i:=recptr to VerticeStp do begin
nod:=VerticeStack[i];
GM.Nodes[nod]:=newnod;
GM.Types[nod]:=loopitem;
end;
end;
end;
end;
VerticeStp:=VerticeStp-1;
end;
begin
ret:=false;
SetLength(VerticeStack,max(3,2*Verticecount));
VerticeStp:=0;
if Map<>nil then begin
GM:=Map;
while (GM.Map<>nil) do
GM:=GM.Map;
new(GM.Map);
OM:=GM;
GM:=GM.Map;
end
else begin
new(Map);
OM:=nil;
GM:=Map;
end;
SetLength(GM.Nodes,max(3,2*Verticecount));
SetLength(GM.Types,max(3,2*Verticecount));
GM.Map:=nil;
for i:=1 to Verticecount do begin
GM.Nodes[i]:=i;
GM.Types[i]:=noitem;
end;
//noch komprimierbar?
if (OM=nil)and(MaxWeight>2)or(OM<>nil)and(OM.MaxWeight>2) then begin
for node:=1 to Verticecount do
if Vertices[node].StartNode then
Single(node);
if ret then begin
//Gewichte neu berechnen
GM.MaxWeight:=0;
GM.SumWeight:=0;
for i:=1 to Verticecount do
Vertices[i].NodeWeight:=0;
for i:=1 to EdgeCount do begin
left:=Edges[i].Side[1];
right:=Edges[i].Side[2];
Vertices[left].NodeWeight:=Vertices[left].NodeWeight+1;
Vertices[right].NodeWeight:=Vertices[right].NodeWeight+1;
GM.SumWeight:=GM.SumWeight+2;
GM.MaxWeight:=max(GM.MaxWeight,Maps(left).NodeWeight);
GM.MaxWeight:=max(GM.MaxWeight,Maps(right).NodeWeight);
end;
end
else if OM<>nil then begin
dispose(OM.Map);
OM.Map:=nil;
end
else begin
dispose(Map);
Map:=nil;
end;
end;
GraphCirclesCompress:=ret;
end;
//------------------------------------------------------------------
//--
//compress weights --
//--
//------------------------------------------------------------------
function TGraph.GraphWeightsCompress():boolean;
var
node,i,left,right:integer;
reducibleweight:integer;
GM,OM:PGraphMap;
ret:boolean;
procedure Single(this:integer);
var
vert,i,newlength:integer;
nod,newnod:integer;
begin
if (Vertices[this].NodeWeight>=reducibleweight)and(GM.Nodes[this]=this)
then begin
VerticeStp:=1;
VerticeStack[VerticeStp]:=this;
for vert:=1 to EdgeCount do begin
left:=Edges[vert].Side[1];
right:=Edges[vert].Side[2];
if ((right=this)or(left=this))and(left<>right) then begin
if VerticeStp>=Length(VerticeStack) then begin
newlength:=Floor(Length(VerticeStack)*3/2);
if VerticeStp>5 then
errorn(94,'Setze neue Länge VerticeStack');
SetLength(VerticeStack,newlength);
end;
if (left=this) then begin
ret:=true;
VerticeStp:=VerticeStp+1;
VerticeStack[VerticeStp]:=Edges[vert].Side[2]
end;
if (right=this) then begin
ret:=true;
VerticeStp:=VerticeStp+1;
VerticeStack[VerticeStp]:=Edges[vert].Side[1]
end;
end;
newnod:=GM.Nodes[this];
for i:=1 to VerticeStp do begin
nod:=VerticeStack[i];
GM.Nodes[nod]:=newnod;
GM.Types[nod]:=subtreeitem;
end;
end;
end;
end;
begin
ret:=false;
SetLength(VerticeStack,max(3,2*Verticecount));
if Map<>nil then begin
GM:=Map;
while (GM.Map<>nil) do
GM:=GM.Map;
new(GM.Map);
OM:=GM;
GM:=GM.Map;
reducibleweight:=OM.MaxWeight;
end
else begin
new(Map);
OM:=nil;
GM:=Map;
reducibleweight:=MaxWeight;
end;
SetLength(GM.Nodes,max(3,2*Verticecount));
SetLength(GM.Types,max(3,2*Verticecount));
GM.Map:=nil;
for i:=1 to Verticecount do begin
GM.Nodes[i]:=i;
GM.Types[i]:=noitem;
end;
//noch komprimierbar?
if (OM=nil)and(MaxWeight>2)or(OM<>nil)and(OM.MaxWeight>2) then begin
for node:=1 to Verticecount do
Single(node);
if ret then begin
//Gewichte neu berechnen
GM.MaxWeight:=0;
GM.SumWeight:=0;
for i:=1 to Verticecount do
Vertices[i].NodeWeight:=0;
for i:=1 to EdgeCount do begin
left:=Edges[i].Side[1];
right:=Edges[i].Side[2];
Maps(left).NodeWeight:=Maps(left).NodeWeight+1;
Maps(right).NodeWeight:=Maps(right).NodeWeight+1;
GM.SumWeight:=GM.SumWeight+2;
GM.MaxWeight:=max(GM.MaxWeight,Maps(left).NodeWeight);
GM.MaxWeight:=max(GM.MaxWeight,Maps(right).NodeWeight);
end;
end;
if (OM<>nil) then
if (OM.MaxWeight<=GM.MaxWeight) then //no gain ??
ret:=false;
end;
if not ret then begin
if OM<>nil then begin
dispose(OM.Map);
OM.Map:=nil;
end
else begin
dispose(Map);
Map:=nil;
end;
end;
GraphWeightsCompress:=ret;
end;
//------------------------------------------------------------------
//--
//collapse node --
//--
//------------------------------------------------------------------
function TGraph.CollapsNode(var GM:PGraphMap;other:integer):boolean;
var
ove,ovr,ovl,i,newlength,newnod,nod:integer;
ret:boolean;
begin
VerticeStp:=0;
ret:=false;
for ove:=1 to EdgeCount do begin
ovl:=Edges[ove].Side[1];
ovr:=Edges[ove].Side[2];
if ((ovl=other)or(ovr=other))and(ovl<>ovr) then begin
if VerticeStp+2>=Length(VerticeStack) then begin
newlength:=Floor(Length(VerticeStack)*3/2);
if VerticeStp>5 then
errorn(95,'Setze neue Länge VerticeStack');
SetLength(VerticeStack,newlength);
end;
if (ovl=other) then begin
VerticeStp:=VerticeStp+1;
VerticeStack[VerticeStp]:=ovr;
ret:=true;
end;
if (ovr=other) then begin
VerticeStp:=VerticeStp+1;
VerticeStack[VerticeStp]:=ovl;
ret:=true;
end;
end;
end;
newnod:=GM.Nodes[other];
GM.Types[other]:=noitem;
for i:=1 to VerticeStp do begin
if GM.Types[i]=noitem then begin
nod:=VerticeStack[i];
GM.Nodes[nod]:=newnod;
GM.Types[nod]:=subtreeitem;
end;
end;
CollapsNode:=ret;
end;
//------------------------------------------------------------------
//--
//show only stubs --
//--
//------------------------------------------------------------------
function TGraph.GraphStubShow(Tm:integer):boolean;
var
i,left,right:integer;
GM,OM:PGraphMap;
ret:boolean;
procedure Single(this:integer);
var
vert,other,firstother:integer;
begin
firstother:=0;
if (Vertices[this].NodeWeight>1) then begin
for vert:=1 to EdgeCount do begin
left:=Edges[vert].Side[1];
right:=Edges[vert].Side[2];
if (left=this)or(right=this) then begin
other:=this;
if (left=this) then
other:=right;
if (right=this) then
other:=left;
if other<>this then begin
ret:=ret or CollapsNode(GM,other);
end;
end
else begin //left<>this and right<> this
if firstother=0 then
firstother:=left;
ret:=ret or CollapsNode(GM,left);
ret:=ret or CollapsNode(GM,right);
end;
end;
end;
end;
begin
ret:=false;
SetLength(VerticeStack,max(3,2*Verticecount));
if Map<>nil then begin
GM:=Map;
while (GM.Map<>nil) do
GM:=GM.Map;
new(GM.Map);
OM:=GM;
GM:=GM.Map;
end
else begin
new(Map);
OM:=nil;
GM:=Map;
end;
if (OM<>nil)and(Tm<=Verticecount)and(Tm>=1)and(OM.Types[Tm]<>noitem) then
begin
SetLength(GM.Nodes,max(3,2*Verticecount));
SetLength(GM.Types,max(3,2*Verticecount));
GM.Map:=nil;
for i:=1 to Verticecount do begin //identity
GM.Nodes[i]:=i;
GM.Types[i]:=noitem;
end;
//noch komprimierbar?
if (OM=nil)and(MaxWeight>2)or(OM<>nil)and(OM.MaxWeight>2) then begin
if (OM<>nil)and(OM.Types[Tm]<>noitem) then
Single(Tm);
if ret then begin
//Gewichte neu berechnen
GM.MaxWeight:=0;
GM.SumWeight:=0;
for i:=1 to Verticecount do
Vertices[i].NodeWeight:=0;
for i:=1 to EdgeCount do begin
left:=Edges[i].Side[1];
right:=Edges[i].Side[2];
Vertices[left].NodeWeight:=Vertices[left].NodeWeight+1;
Vertices[right].NodeWeight:=Vertices[right].NodeWeight+1;
GM.SumWeight:=GM.SumWeight+2;
GM.MaxWeight:=max(GM.MaxWeight,Maps(left).NodeWeight);
GM.MaxWeight:=max(GM.MaxWeight,Maps(right).NodeWeight);
end;
end
end;
end;
if not ret then begin
if OM<>nil then begin
dispose(OM.Map);
OM.Map:=nil;
end
else begin
dispose(Map);
Map:=nil;
end;
end;
GraphStubShow:=ret;
end;
//------------------------------------------------------------------
//--
//compute weights of nodes/Edges --
//--
//------------------------------------------------------------------
procedure TGraph.GraphWeights(OM:PGraphMap);
var
i,left,right:integer;
begin
if OM<>nil then begin
//Gewichte neu berechnen
OM.MaxWeight:=0;
OM.SumWeight:=0;
for i:=1 to Verticecount do
Vertices[i].NodeWeight:=0;
for i:=1 to EdgeCount do begin
left:=Edges[i].Side[1];
right:=Edges[i].Side[2];
Vertices[left].NodeWeight:=Vertices[left].NodeWeight+1;
Vertices[right].NodeWeight:=Vertices[right].NodeWeight+1;
OM.SumWeight:=OM.SumWeight+2;
OM.MaxWeight:=max(OM.MaxWeight,Maps(left).NodeWeight);
OM.MaxWeight:=max(OM.MaxWeight,Maps(right).NodeWeight);
end;
end
else begin
//Gewichte neu berechnen
MaxWeight:=0;
SumWeight:=0;
for i:=1 to Verticecount do
Vertices[i].NodeWeight:=0;
for i:=1 to EdgeCount do begin
left:=Edges[i].Side[1];
right:=Edges[i].Side[2];
Vertices[left].NodeWeight:=Vertices[left].NodeWeight+1;
Vertices[right].NodeWeight:=Vertices[right].NodeWeight+1;
SumWeight:=SumWeight+2;
MaxWeight:=max(MaxWeight,Maps(left).NodeWeight);
MaxWeight:=max(MaxWeight,Maps(right).NodeWeight);
end;
end;
end;
//------------------------------------------------------------------
//--
//expand graph --
//--
//------------------------------------------------------------------
procedure TGraph.GraphExpand();
var
P,L:PGraphMap;
begin
P:=Map;
if P<>nil then begin
L:=P;
while P.Map<>nil do begin
L:=P;
P:=P.Map
end;
if L.Map<>nil then begin
dispose(L.Map);
L.Map:=nil;
GraphWeights(L);
end
else begin
dispose(L);
Map:=nil;
GraphWeights(nil);
end;
end
else begin
if Map<>nil then begin
dispose(Map);
Map:=nil;
GraphWeights(nil);
end;
end;
end;
//------------------------------------------------------------------
//--
//find node or create new --
//--
//------------------------------------------------------------------
function TGraph.FindNode(n:integer):integer;
var
i,r,RN:integer;
found:boolean;
begin
r:=1;
RN:=n-1;
found:=false;
if n=0 then
errorn(96,'node not found:'+IntToStr(n));
for i:=1 to Verticecount do
if Vertices[i].Tree=RN then begin
found:=true;
r:=i
end;
if not found then
r:=AddVertex(RN);
FindNode:=r
end;
//------------------------------------------------------------------
//--
//create new node --
//--
//------------------------------------------------------------------
function TGraph.AddVertex(n:integer):integer;
var
newlength:integer;
begin
if Verticecount+1>=Length(Vertices) then begin
newlength:=Floor((Verticecount*3)div 2+2);
if Verticecount>5 then
errorn(97,'Setze neue Länge vertices');
SetLength(Vertices,newlength);
end;
//catcher(Verticecount=11);
Verticecount:=Verticecount+1;
Vertices[Verticecount].Tree:=n;
Vertices[Verticecount].Target:=false;
Vertices[Verticecount].Shape:=shRectangle;
Vertices[Verticecount].Position.X:=0;
Vertices[Verticecount].Position.Y:=0;
Vertices[Verticecount].StartNode:=true;
Vertices[Verticecount].FinalNode:=true;
Vertices[Verticecount].CircleNode:=false;
Vertices[Verticecount].DecisionNode:=0;
Vertices[Verticecount].Visited:=false;
AddVertex:=Verticecount
end;
//------------------------------------------------------------------
//--
//delete node --
//--
//------------------------------------------------------------------
procedure TGraph.DeleteNode(n:integer);
var
i:integer;
begin
if n=0 then
errorn(98,'Löschung falsch');
for i:=n to Verticecount-1 do
Vertices[i]:=Vertices[i+1];
Verticecount:=Verticecount-1;
for i:=1 to EdgeCount do begin
if Edges[i].Side[1]>n then
Edges[i].Side[1]:=Edges[i].Side[1]-1;
if Edges[i].Side[2]>n then
Edges[i].Side[2]:=Edges[i].Side[2]-1;
end;
end;
//------------------------------------------------------------------
//--
//create vertex --
//--
//------------------------------------------------------------------
procedure TGraph.AddEdge(S:JString);
var
newlength:integer;
Line,Col:integer;
Fil:JString;
begin
if EdgeCount>=Length(Edges) then begin
newlength:=Floor(EdgeCount*3/2);
if EdgeCount>5 then
errorn(99,'Setze neue Länge Edges');
SetLength(Edges,newlength);
end;
EdgeCount:=EdgeCount+1;
Line:=StrToInt(getpar(S_Lin,S));
Col:=StrToInt(getpar(S_col,S));
Fil:=getpar(S_Fil,S);
Edges[EdgeCount].EdgePos.X:=Line;
Edges[EdgeCount].EdgePos.Y:=Col;
setl(Edges[EdgeCount].EdgeFil,Fil);
Edges[EdgeCount].MultipleEdge:=false;
setl(Edges[EdgeCount].Labeled,getpar(S_Lab,S));
end;
//------------------------------------------------------------------
//--
//load Graph from Stream/String --
//--
//------------------------------------------------------------------
function TGraph.getgraph(var TVL:LongTexts):boolean;
var
L,i1,i2,P,k,Org,Dest,FromNode,ToNode,ll:integer;
S,sl,sr:JString;
SLINT,SRINT:integer;
Point:TPoint;
r:TRect;
function slen():integer;
var
i:integer;
begin
i:=0;
repeat
GetNextRec(CStream);
i:=i+1;
until (errorcount>0)or eofs;
i:=i+1;
result:=i
end;
function xpos(F:Char;S:JString):integer;
var
i,P,O:integer;
begin
i:=Length(S);
P:=-1;
O:=0;
while i>0 do begin
if MidStr(S,i,1)=F then begin
P:=i;
O:=O+1;
if O=2 then
i:=0
end;
i:=i-1
end;
xpos:=P;
end;
begin
Point.X:=0;
Point.Y:=0;
OpenStream(CStream);
//count edges
ll:=slen();
//now process
try
OpenStream(CStream);
Content:=@TVL;
SetLength(Vertices,2*ll);
SetLength(Edges,ll);
EdgeCount:=0;
Verticecount:=0;
Width:=0;
Height:=0;
VWidth:=0;
VHeight:=0;
VTop:=0;
VLeft:=0;
Map:=nil;
B:=nil;
diameter:=0;
Sidelength:=0;
XBorder:=0;
YBorder:=0;
MaxLeft:=0;
MaxRight:=0;
MaxTop:=0;
MaxBottom:=0;
Selected:=0;
repeat
S:=GetNextRec(CStream);
if (MidStr(S,1,Length(S_LVert))=S_LVert) then begin
//recordc contains only edges
//<Edge Lin=8 Col=19 Fil=0 Typ=data.charitem from=1 to=2 Lab=SPACE>10,9</Edge>'
AddEdge(S);
sl:=getattribute(S_Left,S);
TryStrtoInt(sl,SLINT);
Edges[EdgeCount].Side[1]:=SLINT;
sr:=getattribute(S_Right,S);
TryStrtoInt(SR,SRINT);
Edges[EdgeCount].Side[2]:=SRINT;
FromNode:=Edges[EdgeCount].Side[1];
Org:=FindNode(FromNode);
Edges[EdgeCount].Side[1]:=Org;
Vertices[Org].DecisionNode:=Vertices[Org].DecisionNode+1;
ToNode:=Edges[EdgeCount].Side[2];
Dest:=FindNode(ToNode);
Edges[EdgeCount].Side[2]:=Dest;
Vertices[Dest].StartNode:=false;
if (Org<>Dest) then
Vertices[Org].FinalNode:=false;
//find overlapping Edges
for k:=1 to EdgeCount-1 do
if (Edges[k].Side[1]=Edges[EdgeCount].Side[2])and
(Edges[k].Side[2]=Edges[EdgeCount].Side[1]) then begin
Edges[EdgeCount].MultipleEdge:=true;
Edges[k].MultipleEdge:=true;
end
end
until (errorcount>0)or eofs;
except
On E:Exception do begin
errorn(6,'Block Fehler, '+E.Message);
end
end;
//calculate weights
MaxWeight:=0;
SumWeight:=0;
for L:=1 to Verticecount do
Vertices[L].NodeWeight:=0;
for L:=1 to EdgeCount do begin
i1:=Edges[L].Side[1];
i2:=Edges[L].Side[2];
Vertices[i1].NodeWeight:=Vertices[i1].NodeWeight+1;
Vertices[i2].NodeWeight:=Vertices[i2].NodeWeight+1;
SumWeight:=SumWeight+2;
MaxWeight:=max(MaxWeight,Vertices[i1].NodeWeight);
MaxWeight:=max(MaxWeight,Vertices[i2].NodeWeight);
end;
getgraph:=true;
//now find coordinates
r.left:=0;//left;
r.top:=0;//top;
r.right:=Width;
r.bottom:=Height;
PCo(r,Verticecount,false);
end;
//------------------------------------------------------------------
//--
//draw Graph --
//--
//------------------------------------------------------------------
procedure TGraph.DrawGraph();
var
i,co,pb,pe:integer;
NodeTyp:NType;
ini:integer;
TX,Nodei:JString;
fontfact:extended;
Framei:boolean;
GM:PGraphMap;
function w():integer;
begin
w:=VLeft+(PointCoordinates(1).X-Sidelength div 2)*Width div VWidth
end;
function h():integer;
begin
h:=VTop+(PointCoordinates(1).Y-Sidelength div 2)*Height div VHeight
end;
begin
fontfact:=VWidth/Width;
if fontfact=0 then
fontfact:=1;
if (self.Width>10)and(self.Height>10) then begin
if Verticecount>0 then begin
DetermineGraphSize();
with B.Canvas do begin
font.Name:=opt.R.FontName;
font.color:=opt.R.FontColor;
font.Style:=opt.R.FontStyle;
font.Size:=opt.R.FontSize;
Pen.color:=opt.R.FontColor;
font.Size:=round(fontfact*opt.R.FontSize);
TextOut(w(),h(),Bezeichnung);
end;
//Txt:=' w='+inttostr(Width)+' h='+inttostr(Height);B.Canvas.TextOut(8,15,Txt);
//Txt:=' vw='+inttostr(VWidth)+' vh='+inttostr(VHeight);B.Canvas.TextOut(8,30,Txt);
if errorcount=0 then
with self do begin
for i:=1 to Verticecount do //get coordinates of nodes
Maps(i).Position:=PointCoordinates(i);
GM:=Map;
if GM<>nil then
while GM.Map<>nil do
GM:=GM.Map;
ImproveGraph();
for i:=1 to EdgeCount do
if errorcount=0 then begin
pb:=Edges[i].Side[1];
pe:=Edges[i].Side[2];
Edge(Maps(pb).Position,Maps(pe).Position,Edges[i].Labeled,
Edges[i].MultipleEdge)
end;
if GM<>nil then begin
GM.MaxLeft:=Width;
GM.MaxRight:=0;
GM.MaxTop:=Height;
GM.MaxBottom:=0;
end;
for i:=1 to Verticecount do
if (errorcount=0)and(Length(Content^.items)>0) then begin
catcher(i=11);
co:=Maps(i).Tree;
Nodei:='';
NodeTyp:=noitem;
Framei:=false;
if (co>=0)and(co<=Length(Content^.items)) then begin
TX:=Content^.items[co].Text;
Nodei:=Functor(TX);
NodeTyp:=GetNodeTyp(TX,ini);
Framei:=false;
if GM<>nil then begin
if GM.Types[i]<>noitem then begin
NodeTyp:=GM.Types[i];
Nodei:='#'+Nodei+'#';
end;
end
end
else if (errorcount=0) then begin
errorn(7,
'Zuordnung falsch: '+IntToStr(co)+' von '+IntToStr
(Length(Content^.items)));
end;
Vertex(NodeTyp,Maps(i).Position,Nodei,Framei,
Maps(i).DecisionNode,ini);
Grid(Maps(i).Position,Opt.r.DrawGrid);//draw dotted grid
end;
end;
Recreate(Im,B);
Recreate(Imclear,B);
end;
//G.selected:=0;
LastMarked:=0;
end;
end;
//----------------------------------------------------------------------------
//
//----------------------------------------------------------------------------
procedure TGraph.ReDraw();
const
border=20;
var
SB:TScrollBox;
begin
if (Length(CStream)>0) then begin
Height:=Height-border;
Width:=Width-border;
if VWidth<Width then
VWidth:=Width;
if VHeight<Width then
VHeight:=Height;
//ScrollBox1.HorzScrollBar.Range:=GR.VWidth;//Opt.r.cfa.Sheet.Width;
SB:=Im.parent as TScrollBox;
SB.VertScrollBar.Range:=VHeight;//Opt.r.cfa.Sheet.Height;
DrawGraph();
SB.Realign;
if Selected>0 then
GraphPositbyNode(Selected,Im);
end
else
Opt.r.CFA.Sheet.Hide
end;
//------------------------------------------------------------------
//--
//recreate Image --
//--
//------------------------------------------------------------------
procedure TGraph.Recreate(var Img:TImage;var B:TBitmap);
begin
try
Img.Picture.Bitmap.FreeImage;
Img.Picture.Bitmap.Assign(B);
Img.Repaint;
except
On E:Exception do
errorn(8,'Bitmap fehlerhaft, '+E.Message);
end;
end;
//------------------------------------------------------------------
//--
//draw Grid --
//--
//------------------------------------------------------------------
procedure TGraph.Grid(P:TPoint;DrawGrid:boolean);
var
sl,Sh:integer;
begin
if DrawGrid then begin //frame
sl:=Sidelength div 2;
Sh:=Sidelength div 2;
B.Canvas.Pen.Style:=psDashDot;
B.Canvas.Pen.Mode:=pmCopy;
B.Canvas.Pen.color:=clLtGray;
//B.Canvas.TextOut(P.X,P.Y,'x');
B.Canvas.MoveTo(P.X-sl,P.Y-Sh);
B.Canvas.LineTo(P.X-sl,P.Y+Sh);
B.Canvas.LineTo(P.X+sl,P.Y+Sh);
B.Canvas.LineTo(P.X+sl,P.Y-Sh);
B.Canvas.LineTo(P.X-sl,P.Y-Sh);
end;
end;
//------------------------------------------------------------------
//--
//draw Node --
//--
//------------------------------------------------------------------
procedure TGraph.Vertex(Typ:NType;P:TPoint;T:JString;Mark:boolean;
ou,pebbles:integer);
var
Txt:JString;
i,ww,hh,cpl,Lines,verHeight,verwidth,normalwidth,normalheight:integer;
overwidth,overheight:integer;
Sh:TGraphShape;
Rhomb: array [0..3] of TPoint;
Ce:TPoint;
ll,ci,ne:integer;
fs:integer;
lab:TPoint;
fontfact:extended;
//--------------------------------------------
procedure placepebbles(PL,PT,PR,pb,num:integer;ofs:real;fs:integer);
var
i,L,T,w,h,fsh,maxc,maxu,rad:integer;
phi:real;
oc:Tcolor;
begin
oc:=B.Canvas.font.color;
B.Canvas.font.color:=clRed;
fs:=fs+1;
repeat
fs:=fs-1;
fsh:=fs div 2;
w:=(PR-PL);
h:=(pb-PT);
rad:=w div 2-fs;
maxc:=rad div fs;
maxu:=Floor(2*PI*rad/fs);
until num<=maxc*maxu;
if num>=0 then begin
if num=1 then begin
L:=PL+w div 2-fsh;
T:=PT+h div 2-(3*fsh)div 2;
B.Canvas.font.Size:=fs;
B.Canvas.TextOut(L,T,'*');
end
else if num<=4 then begin
phi:=ofs;
for i:=1 to num do begin
L:=PL+Floor(rad*sin(phi)/2)+(3*rad)div 2-fsh;
T:=PT+Floor(rad*cos(phi)/2)+rad+fsh;
B.Canvas.font.Size:=fs;
B.Canvas.TextOut(L,T,'*');
phi:=phi+2*PI/num;
end;
end
else if num<=maxc*maxu+1 then begin
phi:=ofs;
for i:=1 to maxu do begin
L:=PL+Floor(rad*sin(phi))+(3*rad)div 2-fsh;
T:=PT+Floor(rad*cos(phi))+rad+fsh;
B.Canvas.font.Size:=fs;
B.Canvas.TextOut(L,T,'*');
phi:=phi+2*PI/maxu;
end;
PL:=PL+fs;
PR:=PR-fs;
PT:=PT+fs;
pb:=pb-fs;
placepebbles(PL,PT,PR,pb,num-maxu,PI/maxu,fs);
end
else begin
L:=PL+w div 2-fsh;
T:=PT+h div 2-(3*fsh)div 2;
B.Canvas.TextOut(L,T,'mehr');
end;
end;
B.Canvas.font.color:=oc;
end;
//--------------------------------------------
begin
fontfact:=VWidth/Width;
normalwidth:=4*diameter div 3;
normalheight:=3*diameter div 4;
overwidth:=3*normalwidth div 2;
overheight:=3*normalheight div 2;
if VWidth<Width then begin
P.X:=P.X+VLeft;
P.Y:=P.Y+VTop;
end;
Sh:=shElipse;
lab.X:=P.X;
lab.Y:=P.Y;
//pen for frame of shape
B.Canvas.Pen.Style:=psSolid;
B.Canvas.Pen.Width:=Linethickness;
B.Canvas.Pen.Mode:=pmCopy;
B.Canvas.Pen.color:=opt.R.FontColor;
B.Canvas.font.Size:=opt.R.FontSize;
//brush for inside
B.Canvas.Brush.Style:=bsSolid;
//size of shape
if Mark then begin
verwidth:=overwidth;
verHeight:=overheight;
end
else begin
verwidth:=normalwidth;
verHeight:=normalheight;
end;
case Typ of
noitem:begin
B.Canvas.Brush.color:=clOlive;
Sh:=shElipse;
end;
numericitem:begin
B.Canvas.Brush.color:=clBlue;
Sh:=shRectangle;
end;
charitem:begin
B.Canvas.Brush.color:=clRed;
Sh:=shRectangle;
end;
functionitem,block:begin
B.Canvas.Brush.color:=clFuchsia;
if ou>1 then begin
Sh:=shRhombus;
B.Canvas.Brush.color:=clBlue
end
else begin
Sh:=shRoundRectAngle;
B.Canvas.Brush.color:=clRed
end
end;
symbol:begin
B.Canvas.Brush.color:=clNavy;
if T=S_Human then
Sh:=shHuman
else if T=S_Database then
Sh:=shDatabase
else if T=S_Monitor then
Sh:=shMonitor
else
Sh:=shRectangle;
end;
loopitem:begin
B.Canvas.Brush.color:=clTeal;
Sh:=shSquare;
end;
subtreeitem:begin
B.Canvas.Brush.color:=clMaroon;
Sh:=shElipse;
end;
assumedfunction:begin
B.Canvas.Brush.color:=clRed;
Sh:=shRoundRectAngle;
end;
assumedData:begin
B.Canvas.Brush.color:=clRed;
Sh:=shRectangle;
end;
transition:begin
B.Canvas.Brush.color:=clBlack;
Sh:=shBar;
end;
place:begin
B.Canvas.Brush.color:=clBlack;
Sh:=shCircle;
end;
end;
if Typ=selection then begin
ww:=5*diameter div 2;
hh:=5*diameter div 2;
B.Canvas.Brush.Style:=bsClear;
B.Canvas.Pen.color:=clTeal;
B.Canvas.Pen.Style:=psDash;
B.Canvas.Pen.Mode:=pmXor;
B.Canvas.Ellipse(P.X-ww,P.Y-hh,P.X+ww,P.Y+hh);
end
else if Typ=deselection then begin
ww:=5*diameter div 2;
hh:=5*diameter div 2;
B.Canvas.Brush.Style:=bsClear;
B.Canvas.Pen.color:=clTeal;
B.Canvas.Pen.Style:=psDash;
B.Canvas.Pen.Mode:=pmXor;
B.Canvas.Ellipse(P.X-ww,P.Y-hh,P.X+ww,P.Y+hh);
end
else if Typ in [simstart,simwithin,simend,simcircle] then begin
ww:=5*diameter div 2;
hh:=5*diameter div 2;
B.Canvas.Brush.Style:=bsClear;
if Typ=simstart then
B.Canvas.Pen.color:=clGreen
else if Typ=simend then
B.Canvas.Pen.color:=clRed
else if Typ=simcircle then
B.Canvas.Pen.color:=clPurple
else
B.Canvas.Pen.color:=clYellow;
if Typ=simstart then
B.Canvas.Pen.color:=clLime;
B.Canvas.Pen.color:=B.Canvas.Pen.color xor opt.R.BackgroundColor;
LastSim:=B.Canvas.Pen.color;
B.Canvas.Pen.Style:=psDash;
B.Canvas.Pen.Mode:=pmXor;
B.Canvas.Pen.Width:=2*Linethickness;
B.Canvas.Ellipse(P.X-ww,P.Y-hh,P.X+ww,P.Y+hh);
end
else if Typ=desimulation then begin
ww:=5*diameter div 2;
hh:=5*diameter div 2;
B.Canvas.Brush.Style:=bsClear;
B.Canvas.Pen.color:=LastSim;
B.Canvas.Pen.Style:=psDash;
B.Canvas.Pen.Mode:=pmXor;
B.Canvas.Pen.Width:=2*Linethickness;
B.Canvas.Ellipse(P.X-ww,P.Y-hh,P.X+ww,P.Y+hh);
end
else
case Sh of
shRectangle:begin
ww:=3*verwidth div 4;
hh:=3*verHeight div 4;
lab.Y:=lab.Y+hh;
B.Canvas.Brush.Style:=bsFDiagonal;
B.Canvas.Rectangle(P.X-ww,P.Y-hh,P.X+ww,P.Y+hh);
end;
shRoundRectAngle:begin
ww:=5*verwidth div 6;
hh:=5*verHeight div 6;
lab.Y:=lab.Y+hh;
B.Canvas.Brush.Style:=bsFDiagonal;
B.Canvas.RoundRect(P.X-ww,P.Y-hh,P.X+ww,P.Y+hh,ww,hh);
end;
shBar:begin
ww:=verwidth div 6;
hh:=3*verHeight div 2;
lab.Y:=lab.Y+hh;
B.Canvas.Brush.Style:=bsSolid;
B.Canvas.Rectangle(P.X-ww,P.Y-hh,P.X+ww,P.Y+hh);
end;
shSquare:begin
ww:=3*verwidth div 4;
lab.Y:=lab.Y+ww;
B.Canvas.Brush.Style:=bsFDiagonal;
B.Canvas.Rectangle(P.X-ww,P.Y-ww,P.X+ww,P.Y+ww);
end;
shElipse:begin
lab.Y:=lab.Y+verHeight;
B.Canvas.Brush.Style:=bsCross;
B.Canvas.Ellipse(P.X-verwidth,P.Y-verHeight,P.X+verwidth,
P.Y+verHeight);
end;
shCircle:begin
lab.Y:=lab.Y+verwidth;
B.Canvas.Brush.Style:=bsClear;
B.Canvas.Ellipse(P.X-verwidth,P.Y-verwidth,P.X+verwidth,
P.Y+verwidth);
placepebbles(P.X-verwidth,P.Y-verwidth,P.X+verwidth,P.Y+verwidth,
pebbles,0,B.Canvas.font.Size);
end;
shRhombus:begin
B.Canvas.Brush.Style:=bsCross;
lab.Y:=lab.Y+verHeight;
Rhomb[0].X:=P.X;
Rhomb[0].Y:=P.Y+verHeight;
Rhomb[1].X:=P.X+verwidth;
Rhomb[1].Y:=P.Y;
Rhomb[2].X:=P.X;
Rhomb[2].Y:=P.Y-verHeight;
Rhomb[3].X:=P.X-verwidth;
Rhomb[3].Y:=P.Y;
B.Canvas.Polygon(Rhomb);
end;
shHuman:begin
ll:=max(verwidth,verHeight)div 3;
ci:=2*ll div 3;//circle
ne:=ll div 5;//neck
Ce.X:=P.X;
Ce.Y:=P.Y-ll;
lab.Y:=lab.Y+ne+3*ll;
B.Canvas.Brush.Style:=bsClear;
//head
B.Canvas.Ellipse(Ce.X-ci,Ce.Y-ci,Ce.X+ci,Ce.Y+ci);
//neck
B.Canvas.MoveTo(Ce.X,Ce.Y+ci);
B.Canvas.LineTo(Ce.X,Ce.Y+ci+ne);
//body
B.Canvas.MoveTo(Ce.X,Ce.Y+ci+ne);
B.Canvas.LineTo(Ce.X,Ce.Y+ne+2*ll);
//arms
B.Canvas.MoveTo(Ce.X-ll,Ce.Y+ci+ne);
B.Canvas.LineTo(Ce.X+ll,Ce.Y+ci+ne);
//legs
B.Canvas.MoveTo(Ce.X,Ce.Y+ne+2*ll);
B.Canvas.LineTo(Ce.X-ll,Ce.Y+ne+3*ll);
B.Canvas.MoveTo(Ce.X,Ce.Y+ne+2*ll);
B.Canvas.LineTo(Ce.X+ll,Ce.Y+ne+3*ll);
end;
shDatabase:begin
ww:=verwidth;
hh:=verHeight;
ll:=min(2*ww,2*hh)div 2;
lab.Y:=lab.Y+ll div 2;
B.Canvas.Brush.Style:=bsClear;
//top
B.Canvas.Ellipse(P.X-ll,P.Y-3*ll div 2,P.X+ll,P.Y-ll div 2);
//left
B.Canvas.MoveTo(P.X-ll,P.Y-ll);
B.Canvas.LineTo(P.X-ll,P.Y+ll);
//right
B.Canvas.MoveTo(P.X+ll,P.Y-ll);
B.Canvas.LineTo(P.X+ll,P.Y+ll);
//bottom
B.Canvas.Ellipse(P.X-ll,P.Y+3*ll div 2,P.X+ll,P.Y+ll div 2);
end;
shMonitor:begin
ll:=min(2*verwidth,2*verHeight)div 2;
hh:=2*ll div 3;
lab.Y:=lab.Y+2*hh div 3;
B.Canvas.Brush.Style:=bsClear;
//screen
B.Canvas.Rectangle(P.X-ll,P.Y-ll,P.X+ll,P.Y+ll);
B.Canvas.RoundRect(P.X-3*ll div 4,P.Y-3*ll div 4,P.X+3*ll div 4,
P.Y+3*ll div 4,3*ll div 4,3*ll div 4);
//keyboard
B.Canvas.MoveTo(P.X-ll,P.Y+ll);
B.Canvas.LineTo(P.X-2*ll,P.Y+ll+hh);
B.Canvas.MoveTo(P.X+ll,P.Y+ll);
B.Canvas.LineTo(P.X,P.Y+ll+hh);
B.Canvas.MoveTo(P.X-2*ll,P.Y+ll+hh);
B.Canvas.LineTo(P.X,P.Y+ll+hh);
B.Canvas.MoveTo(P.X-2*ll div 3,P.Y+ll+hh div 3);
B.Canvas.LineTo(P.X,P.Y+ll+hh div 3);
B.Canvas.MoveTo(P.X-2*2*ll div 3,P.Y+ll+2*hh div 3);
B.Canvas.LineTo(P.X,P.Y+ll+2*hh div 3);
end;
end;
//pen
B.Canvas.Pen.Style:=psSolid;
B.Canvas.Pen.color:=opt.R.FontColor;
B.Canvas.Pen.Width:=Linethickness;
B.Canvas.Pen.Mode:=pmBlack;
//brush
B.Canvas.Brush.color:=opt.r.BackgroundColor;
B.Canvas.Brush.Style:=bsSolid;
//font and characters per line
//B.Canvas.font.Name:=FontName;
//B.Canvas.font.color:=FontColor;
//B.Canvas.font.Style:=FontStyle;
fs:=min(round(fontfact*opt.r.fontsize),2*diameter div 3);
B.Canvas.font.Size:=fs;
cpl:=diameter div 2;//characters per line
if (not(Typ in [selection,deselection,desimulation,simstart,simwithin,
simend,simcircle]))and(Length(T)>0) then begin
i:=1;
Lines:=1;
while (i<=Length(T))and(Lines<=2) do begin
while (T[i]=' ')and(i<Length(T)-1) do
i:=i+1;
if Lines=2 then
cpl:=cpl-3;
Txt:=Trim(MidStr(T,i,cpl));
if (Lines=2)and(i+cpl<Length(T)) then
Txt:=Txt+'...';
i:=i+cpl;
B.Canvas.TextOut(lab.X+fs div 2,lab.Y+(Lines-1)*6*fs div 4,Txt);
Lines:=Lines+1;
end;
end;
B.Canvas.font.Size:=opt.r.fontsize;
end;
//------------------------------------------------------------------
//--
//determine Coordinates --
//--
//------------------------------------------------------------------
function TGraph.PointCoordinates(n:integer):TPoint;
var
X,Y,YM,XM:variant;
P:TPoint;
begin
XM:=max(1,(VWidth-2*XBorder)div Sidelength);
YM:=max(1,(VHeight-2*YBorder)div Sidelength);
X:=Sidelength div 2+((n-1)mod XM)*Sidelength;
Y:=Sidelength div 2+((n-1)div XM)*Sidelength;
P.X:=X+XBorder;
P.Y:=Y+YBorder;
PointCoordinates:=P
end;
//------------------------------------------------------------------
//--
//get Type of Node --
//--
//------------------------------------------------------------------
function TGraph.GetNodeTyp(S:JString;var ini:integer):NType;
var
NTyp,j:NType;
NDur,L:NDuration;
Sea:JString;
NBas:NBase;
k:NBase;
begin
NTyp:=noitem;
Sea:=getattribute(S_Typ,S);
for j:= Low(NType) to High(NType) do
if Pos(S_Ntype[j],Sea)>0 then
NTyp:=j;
NDur:=static;
Sea:=getattribute(S_Dur,S);
for L:= Low(NDuration) to High(NDuration) do
if Pos(S_NDurations[L],Sea)>0 then
NDur:=L;
if NDur=firing then begin
NTyp:=place;
Sea:=getattribute(S_Init,S);
TryStrtoInt(Sea,ini);
end
else if NDur=synchronized then
NTyp:=transition
else if (NTyp=numericitem)or(NTyp=charitem) then begin
Sea:=getattribute(S_Bas,S);
NBas:=nobase;
for k:= Low(NBase) to High(NBase) do
if Pos(S_NBases[k],Sea)>0 then
NBas:=k;
if NBas=octet then
NTyp:=charitem
else
NTyp:=numericitem;
end;
GetNodeTyp:=NTyp
end;
//------------------------------------------------------------------
//--
//determine Graph Size --
//--
//------------------------------------------------------------------
procedure TGraph.DetermineGraphSize();
const
minsize=100;
minsidelength=6;
var
Corrector:variant;
XM,YM,Rest:integer;
fontfact,sl:extended;
P:TPoint;
begin
fontfact:=VWidth/Width;
if fontfact=0 then
fontfact:=1;
B:=TBitmap.Create;
B.Canvas.Brush.color:=opt.r.BackgroundColor;
if (VWidth<minsize) then
VWidth:=minsize;
if (VHeight<minsize) then
VHeight:=minsize;
B.Width:=VWidth;
B.Height:=VHeight;
Corrector:=-1;
XBorder:=VWidth div 20;
YBorder:=VHeight div 20;
if fontfact<0.9 then begin
XBorder:=XBorder+(Width-VWidth)div 2;
YBorder:=YBorder+(Height-VHeight)div 2;
end;
Repeat
Corrector:=Corrector+1;
sl:=VWidth*VHeight-2*VWidth*YBorder-2*VHeight*XBorder;
if Verticecount>0 then begin
sl:=max(3,sl/Verticecount);
Sidelength:=sqrt(sl)-Corrector
end
else
Sidelength:=VWidth-2*XBorder;
Sidelength:=min(Sidelength,min(VWidth div 2,VHeight div 2));
Sidelength:=max(minsidelength,Sidelength);
diameter:=Sidelength/6;
diameter:=max(1,diameter);
XM:=max(1,(VWidth-2*XBorder)div Sidelength);
YM:=max(1,(VHeight-2*YBorder)div Sidelength)
until (XM*YM>=Verticecount)or(Corrector>2*Sidelength);
P:=PointCoordinates(Verticecount);
if (P.X-Sidelength div 2>max(VWidth,Width))or
(P.Y-Sidelength div 2>max(VHeight,Height)) then begin
VWidth:=2*max(VWidth,Width);
VHeight:=2*max(VHeight,Height);
//errorn(5,'Graph hat zuviele Elemente');
end;
Sidelength:=min(Sidelength,2*7*opt.r.fontsize);
diameter:=Sidelength/6;
//correct small graphs
if (VWidth<Width)and(VHeight<Height) then begin
XBorder:=XBorder+(VWidth-VWidth)div 2;
YBorder:=YBorder+(VHeight-VHeight)div 2;
end;
//another corrector
if (VWidth>=Width)and(VHeight>=Height) then begin
Rest:=(VWidth-2*XBorder)-XM*Sidelength;
if Rest>Sidelength then
XBorder:=XBorder+Rest div 2;
Rest:=(VHeight-2*YBorder)-YM*Sidelength;
if Rest>Sidelength then
YBorder:=YBorder+Rest div 2;
end;
//minimum?
if Sidelength<minsize div 2 then
Linethickness:=1;
//B.Canvas.font.Name:=FontName;
B.Canvas.font.Size:=opt.r.fontsize;
end;
//------------------------------------------------------------------
//--
//draw Edge --
//--
//------------------------------------------------------------------
procedure TGraph.Edge(O,G:TPoint;T:JString;multiple:boolean);
var
dist,dx,dy,angle,Cathy:variant;
Org,Goal:TPoint;
begin
Org:=O;
Goal:=G;
//O=origin G=goal
dist:=sqrt(sqr(G.Y-O.Y)+sqr(G.X-O.X));
if (dist>0) then begin
dx:=diameter*(G.X-O.X)/dist/2;
dy:=diameter*(G.Y-O.Y)/dist/2;
if (G.Y<>O.Y) then begin
O.X:=O.X+dx+VLeft;
G.X:=G.X-dx+VLeft
end
else begin
if G.X>O.X then begin
O.X:=O.X+diameter+VLeft;
G.X:=G.X-diameter+VLeft
end
else begin
O.X:=O.X-diameter+VLeft;
G.X:=G.X+diameter+VLeft;
end
end;
if (G.X<>O.X) then begin
O.Y:=O.Y+dy+VTop;
G.Y:=G.Y-dy+VTop;
end
else begin
if G.Y>O.Y then begin
O.Y:=O.Y+diameter+VTop;
G.Y:=G.Y-diameter+VTop
end
else begin
O.Y:=O.Y-diameter+VTop;
G.Y:=G.Y+diameter+VTop
end
end;
dist:=sqrt(sqr(G.Y-O.Y)+sqr(G.X-O.X));
Cathy:=G.Y-O.Y;
angle:=arcsin(-(Cathy)/dist);
//---------------
//
//Q2 Q1
//
//Q3 Q4
//
//---------------
//zuerst die schrägen Winkel
if (G.Y<O.Y)and(G.X>O.X) then
angle:=angle+PI/2//Q1
else if (G.Y<O.Y)and(G.X<O.X) then
angle:=3*PI/2-angle//Q2
else if (G.Y>O.Y)and(G.X<O.X) then
angle:=-angle-PI/2//Q3
else if (G.Y>O.Y)and(G.X>O.X) then
angle:=angle+2*PI+PI/2//Q4
//dann die rechten Winkel
else if (G.Y=O.Y)and(G.X<=O.X) then
angle:=angle-PI/2//Y links
else if (G.Y=O.Y)and(G.X>O.X) then
angle:=angle+PI/2//Y rechts
else if (G.X=O.X)and(G.Y>=O.Y) then
angle:=angle+PI/2//X oben
else if (G.X=O.X)and(G.Y<O.Y) then
angle:=angle+PI/2;//X unten
LabelEdge(Org,Goal,T);
if multiple then
DrawConnectParallelLine(Org,Goal,angle)
else
DrawConnectLine(O,G,angle);
end
else begin
LabelEdge(Org,Org,T);
DrawConnectCircle(Org)
end;
end;
//------------------------------------------------------------------
//--
//draw Grid --
//--
//------------------------------------------------------------------
procedure TGraph.LabelEdge(O,G:TPoint;T:JString);
var
i,fs,cpl,Lines:integer;
Txt:JString;
Ce:TPoint;
fontfact:extended;
bgcolor,diff:Tcolor;
dist:integer;
begin
if Length(T)>0 then begin
fontfact:=(VWidth/Width)*8/10;
//compute color
diff:=40;
bgcolor:=clLtGray+(diff+256*(diff+256*diff));
//pen
B.Canvas.Pen.Style:=psSolid;
B.Canvas.Pen.color:=clWhite;
B.Canvas.Pen.Width:=Linethickness;
B.Canvas.Pen.Mode:=pmWhite;
//brush
B.Canvas.Brush.color:=bgcolor;
B.Canvas.Brush.Style:=bsSolid;
//font and characters per line
//B.Canvas.font.Name:=FontName;
//B.Canvas.font.color:=FontColor;
//B.Canvas.font.Style:=FontStyle;
fs:=min(round(fontfact*opt.r.fontsize),2*diameter div 2);
B.Canvas.font.Size:=fs;
cpl:=diameter div 2;//characters per line
dist:=10;
if (O.X=G.X)and(O.Y=G.Y) then begin
Ce.X:=O.X+10;
Ce.Y:=O.Y+10;
end
else begin
if G.X>O.X then
Ce.X:=O.X+(G.X-O.X)div 2
else
Ce.X:=G.X+(O.X-G.X)div 2;
if G.Y>O.Y then
Ce.Y:=O.Y+(G.Y-O.Y)div 2
else
Ce.Y:=G.Y+(O.Y-G.Y)div 2;
if G.Y>O.Y then begin
Ce.Y:=Ce.Y-fs;
Ce.X:=Ce.X-Length(T)*fs div 2
end;
Ce.X:=Ce.X+dist;
Ce.Y:=Ce.Y+dist;
end;
i:=1;
Lines:=1;
while (i<=Length(T))and(Lines<=2) do begin
while (T[i]=' ')and(i<Length(T)-1) do
i:=i+1;
if Lines=2 then
cpl:=cpl-3;
Txt:=Trim(MidStr(T,i,cpl));
if (Lines=2)and(i+cpl<Length(T)) then
Txt:=Txt+'...';
i:=i+cpl;
B.Canvas.TextOut(Ce.X+fs div 2,Ce.Y+(Lines-1)*6*fs div 4,Txt);
Lines:=Lines+1;
end;
end;
end;
//------------------------------------------------------------------
//--
//determine Coordinates --
//--
//------------------------------------------------------------------
procedure TGraph.PCo(r:TRect;n:integer;O:boolean);
var
i,P:integer;
RS:TRect;
begin
i:=n-1;
P:=0;
while (i>0)and(P=0) do begin
if (n mod i=0) then
if Prime(i) then
P:=i;
i:=i-1
end;//p = largest prime
RS:=r;
if P>1 then begin
if O then begin
RS.left:=0;
RS.right:=r.right div P;
end
else begin
RS.top:=0;
RS.bottom:=r.bottom div P
end;
PCo(RS,n div P,not O);
end;
end;
//------------------------------------------------------------------
//--
//draw beginning of Arrow --
//--
//------------------------------------------------------------------
procedure TGraph.Arrowstart(var B:TBitmap;P:TPoint;A:real;L:integer);
var
r,Q:TPoint;
A1,A2,A3,S:variant;
begin
A1:=A;
A2:=A1-PI/9;
A3:=A1+PI/9;
S:=sqrt(L*L/2+L*L/2);
r.X:=P.X-S*sin(A2);
r.Y:=P.Y-S*cos(A2);
Q.X:=P.X-S*sin(A3);
Q.Y:=P.Y-S*cos(A3);
B.Canvas.Pen.Width:=Linethickness;
B.Canvas.MoveTo(P.X,P.Y);
B.Canvas.LineTo(r.X,r.Y);
B.Canvas.MoveTo(P.X,P.Y);
B.Canvas.LineTo(Q.X,Q.Y);
//B.Canvas.LineTo(P.X,P.Y);
end;
//------------------------------------------------------------------
//--
//draw End of Arrow --
//--
//------------------------------------------------------------------
procedure TGraph.Arrowend(var B:TBitmap;P:TPoint;A:real;L:integer);
var
r,Q:TPoint;
A1,A2,A3,S:variant;
begin
A1:=A;
A2:=A1-PI/9;
A3:=A1+PI/9;
S:=sqrt(L*L/2+L*L/2);
r.X:=P.X-S*sin(A2);
r.Y:=P.Y-S*cos(A2);
Q.X:=P.X-S*sin(A3);
Q.Y:=P.Y-S*cos(A3);
B.Canvas.Pen.Width:=Linethickness;
B.Canvas.MoveTo(P.X,P.Y);
B.Canvas.LineTo(r.X,r.Y);
B.Canvas.LineTo(Q.X,Q.Y);
B.Canvas.LineTo(P.X,P.Y);
end;
//------------------------------------------------------------------
//--
//draw Arc --
//--
//------------------------------------------------------------------
procedure TGraph.DrawConnectArc(O,G:TPoint;angle:variant);
const
bow=5/2;
var
P1,P2,P3,P4,P5,CC:TPoint;
BoundRect:TRect;
dist,radius:integer;
procedure Correct;
var
sect:integer;
begin
sect:=diameter div 2;
if P4.X=P3.X then begin
if P4.Y>=P3.Y then begin
P3.X:=P3.X-sect;
P4.X:=P4.X-sect;
P3.Y:=P3.Y+sect;
P4.Y:=P4.Y-sect
end
else begin
P3.X:=P3.X+sect;
P4.X:=P4.X+sect;
P3.Y:=P3.Y-sect;
P4.Y:=P4.Y+sect
end;
end
else if P4.Y=P3.Y then begin
if P4.X>=P3.X then begin
P3.Y:=P3.Y+sect div 2;
P4.Y:=P4.Y+sect;
P3.X:=P3.X+sect;
P4.X:=P4.X-sect
end
else begin
P3.Y:=P3.Y-sect;
P4.Y:=P4.Y-sect;
P3.X:=P3.X-sect;
P4.X:=P4.X+sect
end
end
else if P4.X>P3.X then begin
P3.X:=P3.X+sect;
P4.X:=P4.X;
if P4.Y>P3.Y then begin
P3.Y:=P3.Y+sect;
P4.Y:=P4.Y-sect
end
else begin
P3.Y:=P3.Y;
P4.Y:=P4.Y
end
end
else if P4.X<P3.X then begin
P3.X:=P3.X-sect;
P4.X:=P4.X;
if P4.Y>P3.Y then begin
P3.Y:=P3.Y;
P4.Y:=P4.Y
end
else begin
P3.Y:=P3.Y-sect;
--> --------------------
--> maximum size reached
--> --------------------
[ Normaldarstellung0.55Diashow
(vorverarbeitet)
]
|
