Quellcode-Bibliothek© Kompilation durch diese Firma[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]Datei: sdl008.mco Sprache: Delphi |
|
||||||
|
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 --> -------------------- ¤ Dauer der Verarbeitung: 0.55 Sekunden (vorverarbeitet) ¤ |
Haftungshinweis
Die Informationen auf dieser Webseite wurden
nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit,
noch Qualität der bereit gestellten Informationen zugesichert.
Bemerkung:Die farbliche Syntaxdarstellung ist noch experimentell.Bot Zugriff |
