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;
P4.Y:=P4.Y-sect
end
end;
end;
begin
P3.X:=O.X;
P3.Y:=O.Y;
P4.X:=G.X;
P4.Y:=G.Y;
dist:=Floor(sqrt(sqr(P4.X-P3.X)+sqr(P4.Y-P3.Y)));
B.Canvas.Pen.Style:=psSolid;
B.Canvas.Pen.color:=clGray;
B.Canvas.Pen.Width:=Linethickness;
B.Canvas.Pen.Mode:=pmCopy;
if P4.X=P3.X
then begin //on same line
CC.Y:=Floor(P3.Y+(P4.Y-P3.Y)/
2);
if P4.Y>P3.Y
then begin
CC.X:=Floor(P3.X+dist/bow);
radius:=Floor(sqrt(sqr(CC.X-P3.X)+sqr(CC.Y-P3.Y)));
P1.X:=CC.X-radius;
P1.Y:=CC.Y-radius;
P2.X:=CC.X+radius;
P2.Y:=CC.Y+radius;
end
else begin
CC.X:=Floor(P3.X-dist/bow);
radius:=Floor(sqrt(sqr(CC.X-P3.X)+sqr(CC.Y-P3.Y)));
P1.X:=CC.X-radius;
P1.Y:=CC.Y-radius;
P2.X:=CC.X+radius;
P2.Y:=CC.Y+radius;
end;
Correct;
if P4.Y<P3.Y
then
P5.X:=Floor(P3.X+dist*sin(angle)/
5)+diameter
else
P5.X:=Floor(P3.X+dist*sin(angle)/
5)-diameter;
P5.Y:=Floor(P3.Y+dist*cos(angle)/
5);
B.Canvas.Arc(P1.X,P1.Y,P2.X,P2.Y,P3.X,P3.Y,P4.X,P4.Y);
Arrowstart(B,P5,angle-PI/
8-PI/
16,diameter);
Arrowend(B,P4,angle+PI/
8+PI/
16,diameter)
end
else if P4.Y=P3.Y
then begin //on same axis
CC.X:=Floor(P3.X+(P4.X-P3.X)/
2);
if P4.X<=P3.X
then begin
CC.Y:=Floor(P3.Y+dist/bow);
radius:=Floor(sqrt(sqr(CC.X-P3.X)+sqr(CC.Y-P3.Y)));
P1.X:=CC.X-radius;
P1.Y:=CC.Y-radius;
P2.X:=CC.X+radius;
P2.Y:=CC.Y+radius;
end
else begin
CC.Y:=Floor(P3.Y-dist/bow);
radius:=Floor(sqrt(sqr(CC.X-P3.X)+sqr(CC.Y-P3.Y)));
P1.X:=CC.X-radius;
P1.Y:=CC.Y-radius;
P2.X:=CC.X+radius;
P2.Y:=CC.Y+radius;
end;
Correct;
if P4.X>P3.X
then begin
P5.X:=P3.X+
3*diameter
div 2;
P5.Y:=P3.Y+
3*diameter
div 2
end
else begin
P5.X:=P3.X-
3*diameter
div 2;
P5.Y:=P3.Y-
3*diameter
div 2
end;
B.Canvas.Arc(P1.X,P1.Y,P2.X,P2.Y,P3.X,P3.Y,P4.X,P4.Y);
Arrowstart(B,P5,angle-PI/
8-PI/
16,diameter);
Arrowend(B,P4,angle+PI/
8+PI/
16,diameter)
end
else if P4.X>P3.X
then begin //schräge Linien
BoundRect:=RECT(P3.X,P3.Y,P4.X,P4.Y);
Correct;
if P4.Y>P3.Y
then begin
P5.X:=P3.X-
2*diameter;
P5.Y:=P3.Y-diameter
div 3
end
else begin
P5.X:=P3.X+
2*diameter;
P5.Y:=P3.Y-diameter
div 3
end;
if P4.Y>=P3.Y
then begin
DrawArc(B.Canvas,clGray,aoSouthWest,P3.X,P3.Y,P4.X,P4.Y,BoundRect);
end
else if P4.Y<P3.Y
then begin //OK
DrawArc(B.Canvas,clGray,aoNorthEast,P3.X,P3.Y,P4.X,P4.Y,BoundRect);
end;
Arrowstart(B,P5,angle-PI/
8-PI/
16-PI/
32,diameter);
Arrowend(B,P4,angle+PI/
8+PI/
16+PI/
32,diameter)
end
else if P4.X<P3.X
then begin
BoundRect:=RECT(P3.X,P3.Y,P4.X,P4.Y);
Correct;
if P4.Y>P3.Y
then begin
P5.X:=P3.X-
2*diameter;
P5.Y:=P3.Y+diameter
div 3
end
else begin
P5.X:=P3.X+
2*diameter;
P5.Y:=P3.Y+diameter
div 3
end;
if P4.Y>=P3.Y
then begin //OK
DrawArc(B.Canvas,clGray,aoNorthEast,P3.X,P3.Y,P4.X,P4.Y,BoundRect);
end
else if P4.Y<P3.Y
then begin
DrawArc(B.Canvas,clGray,aoSouthWest,P3.X,P3.Y,P4.X,P4.Y,BoundRect)
end;
Arrowstart(B,P5,angle-PI/
8-PI/
16-PI/
32,diameter);
Arrowend(B,P4,angle+PI/
8+PI/
16+PI/
32,diameter)
end;
end;
//------------------------------------------------------------------
//--
//draw Line --
//--
//------------------------------------------------------------------
procedure TGraph.DrawConnectLine(O,G:TPoint;angle:variant);
var
dist:
real;
dx,dy:
integer;
PS:TPoint;
begin
//draw line from O to G
dist:=sqrt(sqr(G.Y-O.Y)+sqr(G.X-O.X));
dx:=diameter*(G.X-O.X)/(
2*dist);
dy:=diameter*(G.Y-O.Y)/(
2*dist);
B.Canvas.Pen.Style:=psSolid;
B.Canvas.Pen.color:=clGray;
B.Canvas.Pen.Width:=Linethickness;
B.Canvas.Pen.Mode:=pmCopy;
O.X:=O.X+
2*dx
div 2;
O.Y:=O.Y+
2*dy
div 2;
PS.X:=O.X+(G.X-O.X)
div 7;
PS.Y:=O.Y+(G.Y-O.Y)
div 7;
Arrowstart(B,PS,angle,diameter);
G.X:=G.X-
2*dx
div 2;
G.Y:=G.Y-
2*dy
div 2;
PS.X:=G.X+(O.X-G.X)
div 7;
PS.Y:=G.Y+(O.Y-G.Y)
div 7;
Arrowend(B,PS,angle,diameter);
B.Canvas.MoveTo(O.X,O.Y);
B.Canvas.LineTo(G.X,G.Y);
end;
//------------------------------------------------------------------
//--
//draw parallel Line --
//--
//------------------------------------------------------------------
procedure TGraph.DrawConnectParallelLine(O,G:TPoint;angle:variant);
var
OD,gd:TPoint;
diff:
integer;
begin
//correct borders
O.X:=O.X+VLeft;
O.Y:=O.Y+VTop;
G.X:=G.X+VLeft;
G.Y:=G.Y+VTop;
//move points a little
diff:=diameter/
10;
if G.Y>O.Y
then begin
OD.X:=O.X+diff;
OD.Y:=O.Y;
gd.X:=G.X+diff;
gd.Y:=G.Y;
end
else begin
OD.X:=O.X-diff;
OD.Y:=O.Y;
gd.X:=G.X-diff;
gd.Y:=G.Y
end;
DrawConnectLine(OD,gd,angle)
end;
//------------------------------------------------------------------
//--
//draw Circle --
//--
//------------------------------------------------------------------
procedure TGraph.DrawConnectCircle(P:TPoint);
begin
//correct borders
P.X:=P.X+VLeft;
P.Y:=P.Y+VTop;
//the same node, draw circle
with B.Canvas
do begin
Pen.Style:=psDashDot;
Pen.color:=clGray;
Pen.Width:=Linethickness;
Pen.Mode:=pmNotXor;
MoveTo(P.X+diameter,P.Y+diameter);
Brush.color:=opt.r.BackgroundColor;
Ellipse(P.X+
2*diameter,P.Y-
2*diameter,P.X-diameter
div 2,P.Y);
end;
P.X:=P.X+diameter;
Arrowend(B,P,-PI/
4,diameter);
end;
//------------------------------------------------------------------
//--
//draw Arc --
//--
//------------------------------------------------------------------
procedure TGraph.DrawArc(
const Canvas:TCanvas;
const color:Tcolor;
const orientation:TArcOrientation;
const x1,y1,x2,y2:
integer;
const BoundRect:TRect);
var
iMin:
integer;
iMax:
integer;
jMin:
integer;
jMax:
integer;
begin
case orientation
of
aoSouthWest:
begin
iMin:=BoundRect.left;
iMax:=BoundRect.right+(BoundRect.right-BoundRect.left);
jMin:=BoundRect.top-(BoundRect.bottom-BoundRect.top);
jMax:=BoundRect.bottom;
end;
aoSouthEast:
begin
iMin:=BoundRect.left-(BoundRect.right-BoundRect.left);
iMax:=BoundRect.right;
jMin:=BoundRect.top-(BoundRect.bottom-BoundRect.top);
jMax:=BoundRect.bottom;
end;
aoNorthEast:
begin
iMin:=BoundRect.left-(BoundRect.right-BoundRect.left);
iMax:=BoundRect.right;
jMin:=BoundRect.top;
jMax:=BoundRect.bottom+(BoundRect.bottom-BoundRect.top);
end;
aoNorthWest:
begin
iMin:=BoundRect.left;
iMax:=BoundRect.right+(BoundRect.right-BoundRect.left);
jMin:=BoundRect.top;
jMax:=BoundRect.bottom+(BoundRect.bottom-BoundRect.top);
end;
else
iMin:=BoundRect.left;
iMax:=BoundRect.right;
jMin:=BoundRect.top;
jMax:=BoundRect.bottom
end;
Canvas.Pen.color:=color;
Canvas.Arc(iMin,jMin,iMax,jMax,x1,y1,x2,y2)
end { DrawArc } ;
//------------------------------------------------------------------
//--
//Posit Graph --
//--
//------------------------------------------------------------------
procedure TGraph.GraphPositbyText(TF:JString;
var Img:TImage);
var
Tm,i,P:
integer;
nod:PGraphVertice;
Fu,S:JString;
begin
if (TF<>
'')
and(Verticecount>
0)
and(Content<>
nil)
then begin
Screen.Cursor:=crHourGlass;
Fu:=TF;
Tm:=-
1;
i:=
0;
while (Tm<
0)
and(i<Verticecount)
do begin
i:=i+
1;
nod:=Maps(i);
P:=
0;
if nod.Tree<=Length(Content^.items)
then begin
S:=Functor(Content^.items[nod.Tree].Text);
P:=Pos(Fu,S);
end;
if P>
0 then
Tm:=i;
end;
if Tm>
0 then
GraphPositbyNode(Tm,Img);
Screen.Cursor:=crDefault;
end;
end;
//------------------------------------------------------------------
//--
//Posit Graph --
//--
//------------------------------------------------------------------
procedure TGraph.GraphPositbyNode(Tm:
integer;
var Img:TImage);
var
TX:JString;
begin
if Tm>
0 then begin
Screen.Cursor:=crHourGlass;
B:=Img.Picture.Bitmap;
if (LastMarked>
0)
then begin
TX:=Content^.items[LastMarked].Text;
Vertex(deselection,Maps(LastMarked).Position,
'',true,
0,
0);
end;
Vertex(selection,Maps(Tm).Position,
'',true,
0,
0);
Hint:=HintBox(Functor(Content^.items[Maps(Tm).Tree].Text));
Hintpos:=Maps(Tm).Position;
LastMarked:=Tm;
Screen.Cursor:=crDefault;
end;
end;
//------------------------------------------------------------------
//--
//simulate Graph --
//--
//------------------------------------------------------------------
procedure TGraph.GraphSimulateRepeated();
begin
Sleep(
2000);
LastMousePos.X:=Mouse.CursorPos.X;
LastMousePos.Y:=Mouse.CursorPos.Y;
B:=Im.Picture.Bitmap;
//assign context
while Eq(Mouse.CursorPos,LastMousePos)
do
GraphSimulate();
end;
//------------------------------------------------------------------
//--
//simulate Graphtrace --
//--
//------------------------------------------------------------------
procedure TGraph.GraphSimulate();
var
i:
integer;
begin
SetLength(VerticeStack,
2*Verticecount);
VerticeStp:=
0;
LastMousePos:=Mouse.CursorPos;
for i:=
1 to Verticecount
do
Maps(i).Visited:=false;
for i:=
1 to Verticecount
do
GraphCircles(i);
i:=
1;
while i<=Verticecount
do begin
if not Eq(Mouse.CursorPos,LastMousePos)
then begin
inform(
144,
'Wegen Mausbewegung beendet',
'');
i:=Verticecount+
1
end
else if Maps(i).StartNode
and(
not Maps(i).Visited)
then
GraphTraverse(i);
i:=i+
1;
end;
end;
//------------------------------------------------------------------
//--
//Traverse Graph --
//--
//------------------------------------------------------------------
procedure TGraph.GraphTraverse(n:
integer);
const
dur=
300;
var
i,j,k,co:
integer;
TX:JString;
recurrent:
integer;
one,second:
boolean;
procedure VisitNode(n:
integer;adur:
integer);
begin
if not Maps(n).Visited
and Eq(Mouse.CursorPos,LastMousePos)
then begin
co:=Maps(n).Tree;
//GraphPositbyNode(n,Gf,Im);
if (co>=
0)
and(co<=Length(Content^.items))
then begin
TX:=Content^.items[co].Text;
TX:=Functor(TX);
end
else
TX:=
'';
if Maps(n).CircleNode
then
Vertex(simcircle,Maps(n).Position,TX,true,
0,
0)
else if Maps(n).StartNode
then
Vertex(simstart,Maps(n).Position,TX,true,
0,
0)
else if Maps(n).FinalNode
then
Vertex(simend,Maps(n).Position,TX,true,
0,
0)
else
Vertex(simwithin,Maps(n).Position,TX,true,
0,
0);
Im.Repaint;
if Maps(n).StartNode
then
Sleep(
2*adur)
else if Maps(n).FinalNode
then
Sleep(
2*adur)
else
Sleep(adur);
Vertex(desimulation,Maps(n).Position,
'',true,
0,
0);
Im.Repaint;
Maps(n).Visited:=true;
end;
end;
begin
VerticeStp:=VerticeStp+
1;
VerticeStack[VerticeStp]:=n;
one:=false;
second:=false;
for j:=
1 to EdgeCount
do
if Edges[j].Side[
1]=n
then begin
VisitNode(n,dur);
one:=true;
recurrent:=
0;
for i:=
1 to VerticeStp
do
if VerticeStack[i]=Edges[j].Side[
2]
then
recurrent:=i;
if recurrent=
0 then begin
if second
then
for i:=
1 to VerticeStp
do
VisitNode(VerticeStack[i],dur);
second:=true;
GraphTraverse(Edges[j].Side[
2]);
end
else begin
for k:=
1 to 3 do begin
for i:=recurrent
to VerticeStp
do
Maps(VerticeStack[i]).Visited:=false;
for i:=recurrent
to VerticeStp
do
VisitNode(VerticeStack[i],dur);
for i:=VerticeStp
downto recurrent
do
Maps(VerticeStack[i]).Visited:=false;
for i:=VerticeStp
downto recurrent
do
VisitNode(VerticeStack[i],dur);
end
end
end;
if not one
then
VisitNode(n,dur);
VerticeStp:=VerticeStp-
1;
end;
//------------------------------------------------------------------
//--
//Ende dieser Quelle --
//--
//------------------------------------------------------------------
end.
