Witam
Mam taki programik, który rysuje i znajduje najkrótszą drogę do wierzchołka w grafie skierowanym (według algorytmu forda bellmana) -- jednak problem pojawia się gdy do szukanego wierzchołka nie da się dojść --> wtedy program się wysypuje. Czy ma ktoś jakiś pomysł jak obsłużyć taki błąd lub jak zmodyfikować kod, żeby wykrył, że nie da się dotrzeć do danego wierzchołka ?
unit grafy1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, ExtCtrls, Spin;
type
TForm1 = class(TForm)
Start: TBitBtn;
Koniec: TBitBtn;
ColorBox1: TColorBox;
LabeledEdit1: TLabeledEdit;
LabeledEdit2: TLabeledEdit;
PaintBox1: TPaintBox;
BOblicz_droge: TButton;
Memo1: TMemo;
Edit1: TEdit;
Edit2: TEdit;
Label1: TLabel;
Label2: TLabel;
procedure KoniecClick(Sender: TObject);
procedure StartClick(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormCreate(Sender: TObject);
procedure BOblicz_drogeClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
vertex = record
x,y,r: Integer; lab: Char; kol: TColor;
{ x,y = wspolrzedne, r = promien }
{ lab = etykieta, kol = kolor }
end;
edge = record
src,trg,val,thn: Integer; kol: TColor;
{ src = nr.wierzch.zrodlowego }
{ trg = nr.wierzch.docelowego }
{ val = waga, thn = grubosc, kol = kolor }
end;
graph = record
lw,lk: Integer; { liczba wierzcholkow i krawedzi }
zw: array of vertex ; { zbior wierzcholkow }
zk: array of edge; { zbior krawedzi }
end ;
var
Form1: TForm1;
xmn,ymn,xmx,ymx: Integer;
//////////////////////////////////////////////////
mamut:integer; //
source: array [1..100] of integer; //
target: array [1..100] of integer; //
Value : array [1..100] of integer; //
s, t : integer;
wynik: string; //
//////////////////////////////////////////////////
gg: graph;
bw1,bw2: Integer; { numery bliskich wierzcholkow }
//tablice mamuta
///////////////////////////////////////////////////
dist:array[1..100] of real; //
w:array[1..100,1..100] of real; //
pre:array[1..100] of integer; //
vis:array[1..100] of boolean; //
//////////////////////////////////////////////////
{$R *.dfm}
implementation
function pointin ( x,y: Integer ): Boolean; //zwraca true kiedy x&y sa w polu
begin {========================== pointin }
pointin := (xmn<x) and (x<xmx)
and (ymn<y) and (y<ymx)
end ; {========================== pointin }
function de( x1,y1,x2,y2: Integer ): Real; //zwraca dlugosc danej krawedzi
begin { odleglosc euklidesowa ======= de }
de := Sqrt(Sqr(x1-x2)+Sqr(y1-y2))
end ; { odleglosc euklidesowa ======= de }
procedure bellford;
var
i,j:integer;
change:boolean;
begin
for i:=1 to gg.lw do
dist[i]:=1e38;
dist[s]:=0;
repeat
change:=false;
for i:=1 to gg.lw do
for j:=1 to gg.lw do
if dist[i]+w[i,j]<dist[j]
then begin
dist[j]:=dist[i]+w[i,j];
pre[j]:=i;
change:=true;
end;
until not change;
end;{bellford}
procedure out(s,t:integer);
var
k,length,i:integer;
path:array[1..100] of integer;
k1: real;
begin
Wynik:='';
if ((dist[t])>1e38)
then Wynik:='brak rozwiazania'
else begin
length:=0;
k:=t;
while (k<>s) do
begin
inc(length);
path[length]:=k;
k:=pre[k];
end;
Wynik:=Wynik+'dlugosc='; k1:=dist[t]; //k1:=InToStr(dist[t]);
Wynik:=Wynik+FloatToStr(k1);
Wynik:=Wynik+' droga: ';
Wynik:=Wynik+IntToStr(s);
for i:=length downto 1 do
Wynik:=Wynik+'->'+IntToStr(path[i]);
Wynik:=Wynik+#13;
end;
end;{out}
//***********************************************************************
procedure ColorChange(const mode: integer; var vv: vertex);
var
Color:TColor;
R, G, B:integer;
max: char; // kolor dominujący - niezmienny
begin
Color:=vv.kol;
R := Color and $FF;
G := (Color shr 8) and $FF;
B := (Color shr 16) and $FF;
if mode=1 then
begin
if R-20>=0 then R:=R-20;
if G-20>=0 then G:=G-20;
if B-20>=0 then B:=B-20;
end
else
begin
if R+20<=255 then R:=R+20;
if G+20<=255 then G:=G+20;
if B+20<=255 then B:=B+20;
end;
Color:=RGB(R,G,B);
vv.kol:=Color;
end;
//***********************************************************************
procedure newvert (xx,yy: Integer; var vv: vertex) ;
{ uzupelnienie gg o nowy wierzcholek }
var s: string;
begin {=================================== newvert }
vv.x := xx; vv.y := yy; vv.r := 12;
s := Form1.LabeledEdit1.Text;
vv.lab := s[1];
vv.kol := Form1.ColorBox1.Selected;
gg.lw := gg.lw+1;
SetLength ( gg.zw , gg.lw );
gg.zw[gg.lw-1] := vv;
s[1] := Succ(s[1]);
Form1.LabeledEdit1.Text := s;
end ; {=================================== newvert }
procedure rysvert ( vv: vertex ) ; //rysowanie wierzcholkow
begin {================= rysvert }
with Form1.PaintBox1.Canvas do begin
Pen.Width := 2;{1;}
Brush.Color := vv.kol;
Ellipse(vv.x-vv.r,vv.y-vv.r,vv.x+vv.r,vv.y+vv.r);
TextOut(vv.x-5,vv.y-8,vv.lab);
end
end ; {================= rysvert }
procedure newedge ( s,t: Integer; var ee: edge) ;
begin {================================ newedge }
ee.src := s; ee.trg := t;
//ShowMessage(IntToStr(ee.src)); ///////////////////////////tu dodac zapisywanie danych krawedzi
// ShowMessage(IntToStr(ee.trg));
//ShowMessage(IntToStr(gg.lk+1));
//////////////////////////////////////////////////////////
Source[mamut]:=ee.src+1; //
Target[mamut]:=ee.trg+1; //
//////////////////////////////////////////////////////////
ee.thn := 2; ee.kol := clBlack;
ee.val := StrToInt(Form1.LabeledEdit2.Text);
Value[mamut]:=ee.val;
gg.lk := gg.lk+1; SetLength ( gg.zk , gg.lk );
gg.zk[gg.lk-1] := ee;
ColorChange(1,gg.zw[s]);
ColorChange(1,gg.zw[t]);
inc(mamut); //zwiekszamy mamuta
end ; {================================ newedge }
(*procedure deledge ( nre: Integer );
{ wyrzucenie krawedzi numer 'nre' }
var n: Integer;
begin {================== deledge }
ColorChange(0,gg.zw[gg.zk[nre].src]);
ColorChange(0,gg.zw[gg.zk[nre].trg]);
n := nre+1;
while n<gg.lk do begin
gg.zk[n-1] := gg.zk[n];
n := n+1
end;
gg.lk := gg.lk-1;
end ; {================== deledge }
procedure delvert ( nrv: Integer );
{ usuwanie wierzchołka z incydentnymi krawedziami }
var i,ost: integer;
begin {================================== delvert }
ost := gg.lw-1;
{ zamieniamy wierzchołek nrv z ost w krawedziach }
if nrv<ost then begin
gg.zw[nrv] := gg.zw[ost];
i := 0;
while i<gg.lk do begin
if gg.zk[i].src = ost then
gg.zk[i].src := nrv else
if gg.zk[i].src = nrv then
gg.zk[i].src := ost ;
if gg.zk[i].trg = ost then
gg.zk[i].trg := nrv else
if gg.zk[i].trg = nrv then
gg.zk[i].trg := ost ;
i := i+1
end
end;
{ wyrzucamy krawedzie incydentne z ost }
i := 0;
while i<gg.lk do begin
if (gg.zk[i].src=ost) or
(gg.zk[i].trg=ost) then
deledge(i) else i:=i+1
end;
{ usuwamy ost }
gg.lw := ost
end ; {================================== delvert }
procedure del2edge ;
{ usuwanie podwojnych krawedzi jakiejs i ostatniej }
{ !!! rowne gdy nieskierowan (src,trg) = (trg,src) }
var nre,ost: Integer; jest: Boolean;
begin {================================== del2edge }
if gg.lk>1 then begin
nre:=-1; ost:=gg.lk-1;
repeat
nre:=nre+1;
jest:=(gg.zk[nre].src = gg.zk[ost].src)
and (gg.zk[nre].trg = gg.zk[ost].trg)
// or (gg.zk[nre].src = gg.zk[ost].trg)
// and (gg.zk[nre].trg = gg.zk[ost].src)
until (nre=(ost-1)) or jest;
if jest then begin
ColorChange(0,gg.zw[gg.zk[nre].src]);
ColorChange(0,gg.zw[gg.zk[nre].trg]);
deledge(nre);
gg.lk := gg.lk-1
end
end
end ; {================================== del2edge } *)
//****************************************************************************
procedure DrawArrow(Canvas: TCanvas;
x1,y1, x2,y2: integer;
HeadLength: integer;
HeadFill: boolean;
color: TColor);
var
Triangle : array[0..2] of TPoint;
xbase : INTEGER;
xLineDelta : INTEGER;
xLineUnitDelta : Double;
xMiddle : INTEGER;
xNormalDelta : INTEGER;
xNormalUnitDelta: Double;
ybase : INTEGER;
yLineDelta : INTEGER;
yLineUnitDelta : Double;
yMiddle : INTEGER;
yNormalDelta : INTEGER;
yNormalUnitDelta: Double;
begin
Canvas.Pen.Color := color;
Canvas.Brush.Style := bsSolid;
Canvas.MoveTo(x1,y1);
Canvas.LineTo(x2,y2);
//roznica wspolrzednych
xLineDelta := x2 - x1;
yLineDelta := y2 - y1;
//
xLineUnitDelta := xLineDelta / SQRT( SQR(xLineDelta) + SQR(yLineDelta));
yLineUnitDelta := yLineDelta / SQRt( SQR(xLineDelta) + SQR(yLineDelta));
// baza strzalki, miejsce prostopadle do linii
xBase := x2 - 4*(ROUND(HeadLength * xLineUnitDelta));
yBase := y2 - 4*(ROUND(HeadLength * yLineUnitDelta));
xNormalDelta := yLineDelta;
yNormalDelta := -xLineDelta;
xNormalUnitDelta := xNormalDelta / SQRT( SQR(xNormalDelta) + SQR(yNormalDelta) );
yNormalUnitDelta := yNormalDelta / SQRt( SQR(xNormalDelta) + SQR(yNormalDelta) );
//budowa trojkata -> strzalki
Triangle[0] := Point(x2 - 2*(ROUND(HeadLength * xLineUnitDelta)),y2 - 2*(ROUND(HeadLength * yLineUnitDelta)));
Triangle[1] := Point(xBase + ROUND(HeadLength*xNormalUnitDelta),
yBase + ROUND(HeadLength*yNormalUnitDelta));
Triangle[2] := Point(xBase - ROUND(HeadLength*xNormalUnitDelta),
yBase - ROUND(HeadLength*yNormalUnitDelta));
// rysowanie strzalki
Canvas.Polygon(Triangle);
// wypelnienie strzalki, jezeli true
if HeadFill
then begin
xMiddle := (Triangle[0].x + Triangle[1].x + Triangle[2].x) div 3;
yMiddle := (Triangle[0].y + Triangle[1].y + Triangle[2].y) div 3;
Canvas.Brush.Color := color;
Canvas.FloodFill(xMiddle,yMiddle,
color,
fsBorder);
end;
end {DrawArrow};
//****************************************************************************
procedure rysedge ( ee: edge );
var xs,ys,xt,yt: Integer;
xhalf, yhalf: Integer;
begin {============== rysedge }
{ val,thn: Integer; kol: TColor }
{ ustaw kolor i grubosc, wpisz wage }
Form1.PaintBox1.Canvas.Pen.Width := ee.thn;
Form1.PaintBox1.Canvas.Pen.Color := clBlack;
Form1.PaintBox1.Canvas.Pen.Style := psSolid;
Form1.PaintBox1.Canvas.Brush.Style := bsClear;
xs := gg.zw[ee.src].x;
ys := gg.zw[ee.src].y;
xt := gg.zw[ee.trg].x;
yt := gg.zw[ee.trg].y;
DrawArrow(Form1.PaintBox1.Canvas, xs,ys, xt,yt, 6, true,clBlack);
//wypisywanie wag **********************************************************
Form1.PaintBox1.Canvas.Font.Color := clAqua;
xhalf:=xs+((xt-xs)div 2);
yhalf:=ys+((yt-ys)div 2);
Form1.PaintBox1.Canvas.TextOut(xhalf,yhalf, IntToStr(ee.val));
Form1.PaintBox1.Canvas.Font.Color := clBlack;
//**************************************************************************
end ; {============== rysedge }
procedure rysgraf ;
{ krawedzie i wierzcholki gg }
var n: Integer;
begin {============= rysgraf }
Form1.PaintBox1.Refresh; {Invalidate}
n:=0;
while n<gg.lk do begin
rysedge ( gg.zk[n] );
n := n+1
end;
n:=0;
while n<gg.lw do begin
rysvert ( gg.zw[n] );
n := n+1
end;
end ; {============= rysgraf }
procedure szukaj(X,Y:Integer; var nw:Integer; var mnd:Real);
{ w grafie 'gg' poszukuje sie najblizszego wierzcholka 'nw'}
var anw: Integer; ad: Real;
begin {============================================ szukaj }
mnd:=de(0,0,Form1.PaintBox1.Height,Form1.PaintBox1.Width);
nw:=-1; anw:=0;
while anw<gg.lw do begin
ad:=de(X,Y,gg.zw[anw].x,gg.zw[anw].y);
if ad<mnd then begin mnd:=ad; nw:=anw end;
anw:=anw+1
end;
end ; {============================================ szukaj }
procedure TForm1.KoniecClick(Sender: TObject);
var
Ico_i_Klaw, Wynik: Integer;
Tytul, Napis: PChar;
begin
Ico_i_Klaw := mb_YesNo or mb_IconQuestion;
Tytul := 'Koniec ?';
Napis := 'Czy chcesz zakonczyc?';
Wynik := MessageBox(0, Napis, Tytul, Ico_i_Klaw);
if (Wynik = Id_Yes) then Close;
end;
procedure TForm1.StartClick(Sender: TObject);
var s: string;
begin
xmn := Paintbox1.Left + 15;
ymn := Paintbox1.Top + 15;
xmx := Paintbox1.Left + PaintBox1.Width - 15;
ymx := Paintbox1.Top + PaintBox1.Height - 15;
PaintBox1.Invalidate;
ColorBox1.Selected := clRed;
LabeledEdit1.Text := '1';
gg.lw := 0; SetLength ( gg.zw , 0 );
gg.lk := 0; SetLength ( gg.zk , 0 );
bw1 := -1; bw2 := -1;
s := '';
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button:
TMouseButton; Shift: TShiftState; X, Y: Integer);
var vv: vertex; ee: edge; mnd: Real; nw: Integer;
begin
if pointin(X,Y) then
begin
szukaj ( X,Y,nw,mnd );
if (mnd>24) then { 24 = r+r }
begin { daleki }
if bw1>=0 then { poprzedni byl bliski }
begin { przesuniecie }
gg.zw[bw1].x := X;
gg.zw[bw1].y := Y;
bw1 := -1;
rysgraf;
end else { poprzednio nie bylo }
begin { nowy wierzcholek }
newvert(X,Y,vv);
rysvert(vv);
end
end else
if (mnd<gg.zw[nw].r) then
begin { bliski }
if bw1>=0 then { poprzedni byl bliski }
begin bw2 := nw;
if bw1<>bw2 then { usun wierzcholek }
{ wstaw/usun krawedz }
begin
newedge(bw1,bw2,ee);
bw1:=-1; bw2:=-1;
rysgraf;
end
end else bw1:=nw { poprzednio nie bylo }
end else { nijaki }
end else { komunikat 1 }
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
mamut:=1;
Form1.Top := 200;
Form1.Left := 300;
Form1.Height := 700;
Form1.Width := 900;
Form1.PaintBox1.Top := 16;
Form1.PaintBox1.Left := 16;
Form1.PaintBox1.Height := 560;
Form1.PaintBox1.Width := 680;
end;
procedure TForm1.BOblicz_drogeClick(Sender: TObject);
var u,v,i :integer;
begin
//if (gg.lw>(gg.lk-1)) then begin ShowMessage('Jakis wierzcholek nie zostal polaczony'); end
//ShowMessage(IntToStr(gg.lw));
//ShowMessage(IntToStr(gg.lk));
//ShowMessage(IntToStr(mamut));
for u:=1 to gg.lw do
for v:=1 to gg.lw do
w[u,v]:=1e38; //wypelnienie tablicy
for i:=1 to gg.lk do
w[source[i],target[i]]:=Value[i]; // w wirtualna tablica zapisujaca graf do tabelicy
s:=StrToInt(Form1.Edit1.Text); //szukana droga od
t:=StrToInt(Form1.Edit2.Text); //szukana droga do
bellford;
out(s,t);
Memo1.Lines.add(Wynik);
end;
end.