Реализовать поиск путей алгоритмом Флойда

program graf1; 
 
const 
c=100; 
 
type dist=array[1..c,1..c,1..c] of integer; 
type length=array[1..c,1..c] of integer; 
 
type 
arc=record 
v1:integer; 
v2:integer; 
w:integer 
end; 
type 
graf=record 
v:array[1..c] of char; 
arc:array[1..c] of arc; 
lastv:integer; 
lastarc:integer; 
end; 
 
var 
g,ngr:graf; 
d,j,k,n,er:integer; 
x,x1,x2:char; 
 
procedure Creation(var g:graf); 
var 
i:integer; 
begin 
for i:=1 to c do begin 
g.v[i]:=' '; 
g.arc[i].v1:=0; 
g.arc[i].v2:=0; 
g.arc[i].w:=0; 
end; 
g.lastarc:=0; 
g.lastv:=0; 
end; 
 
function SearchV(var g:graf; v:char):integer; 
var 
i:integer; 
begin 
i:=1; 
while (i<>g.lastv+1) and (g.v[i]<>v) do 
inc(i); 
if i=g.lastv+1 then searchv:=0 
else searchv:=i; 
end; 
 
function VInsert(var g:graf; v:char):integer; 
begin 
if g.lastv<c+1 then begin 
inc(g.lastv); 
g.v[g.lastv]:=v; 
 
end 
else VInsert:=0; 
end; 
 
function XInsert(var g:graf; x1,x2:char; w:integer):integer; 
var 
k,j1,j2,i:integer; 
begin 
i:=1; 
if w=0 then XInsert:=-3 
else begin 
if g.lastarc<c+1 then begin 
j1:=searchv(g,x1); 
j2:=searchv(g,x2); 
if (j1=0) or (j2=0) then xinsert:=0 
else begin //net vershiny 
while (i<>g.lastarc+1)and ((g.arc[i].v1<j1) or ((g.arc[i].v1=j1)and(g.arc[i].v2<j2))) do 
inc(i); 
if ((g.arc[i].v1=j1) and (g.arc[i].v2=j2)) then XInsert:=-1 //est takaya duga 
else begin 
if (g.arc[i].v1>j1) or ((g.arc[i].v1=j1) and (g.arc[i].v2>j2)) then begin 
for k:=g.lastarc downto i do begin 
g.arc[k+1].v1:=g.arc[k].v1; 
g.arc[k+1].v2:=g.arc[k].v2; 
g.arc[k+1].w:=g.arc[k].w; 
end; 
end; 
g.arc[i].v1:=j1; 
g.arc[i].v2:=j2; 
g.arc[i].w:= w; 
inc(g.lastarc); 
end; 
end; 
end 
else XInsert:=-2; //polniy 
end; 
end; 
 
Function VLabelRead(g:graf; n:integer):char; 
var 
i:integer; 
begin 
i:=1; 
while (i<>g.lastv+1) and (i<>n) do 
inc(i); 
if i=g.lastv+1 then vlabelread:='0' //net elementa 
else vlabelread:=g.v[i]; 
end; 
 
function XLabelRead(g:graf; x1,x2:char):integer; 
var 
i,j1,j2:integer; 
 
begin 
i:=1; 
j1:=SearchV(g,x1); 
j2:=SearchV(g,x2); 
if (j1=0) or (j2=0) then XlabelRead:=-1 //net vershin 
else begin 
while (i<g.lastarc+1) do begin 
if(g.arc[i].v1<>j1) or(g.arc[i].v2<>j2) then 
inc(i) 
else begin 
xlabelread:=g.arc[i].w; break; 
end; 
end; 
if i=g.lastarc+1 then XLabelread:=0 //net dugi 
else 
end; 
end; 
 
function VDelete(var g:graf;v:char):integer; 
var 
i,k,s,j1:integer; 
begin 
i:=1; 
j1:=searchv(g,v); 
if j1=0 then Vdelete:=0 //net vershiny 
else begin 
while g.v[i]<>v do inc(i); 
for k:=i to g.lastv do begin 
g.v[k]:=g.v[k+1]; 
end; 
dec(g.lastv); 
for k:=1 to g.lastarc do begin 
while (i<>g.lastarc+1) and ((g.arc[i].v1<>j1)) do inc(i); 
if i<>g.lastarc+1 then begin 
for s:=i to g.lastarc do begin 
g.arc[s].v1:=g.arc[s+1].v1; 
g.arc[s].v2:=g.arc[s+1].v2; 
g.arc[s].w:=g.arc[s+1].w; 
end; 
dec(g.lastarc); 
end 
else inc(i); 
end; 
end; 
end; 
 
function XDelete(var g:graf; x1,x2:char):integer; 
var 
i,j1,j2:integer; 
begin 
i:=1; 
j1:=SearchV(g,x1); 
j2:=SearchV(g,x2); 
if (j1=0) or (j2=0) then XDelete:=0 //нет таких вершин 
else begin 
while (i<>g.lastarc+1) and ((g.arc[i].v1<>j1) or (g.arc[i].v2<>j2)) do inc(i); 
if i=g.lastarc+1 then XDelete:=-1 //нет такой дуги 
else begin 
for k:=i to g.lastarc do begin 
g.arc[k].v1:=g.arc[k+1].v1; 
g.arc[k].v2:=g.arc[k+1].v2; 
g.arc[k].w:=g.arc[k+1].w; 
end; 
dec(g.lastarc); 
end; 
end; 
end; 
 
function VFirst(g:graf; x:char):integer; 
var 
i,j:integer; 
begin 
j:=SearchV(g,x); 
i:=1; 
if (j=0) then VFirst:=0 //нет такого элемента 
else begin 
while (i<g.lastarc+1) and (g.arc[i].v1<>j) do 
inc(i); 
if i=g.lastarc+1 then VFirst:=-1 //нет дуги 
else 
VFirst:=g.arc[i].v2; 
end; 
end; 
 
function VNext(g:graf;x:char):integer; 
var 
i,j:integer; 
begin 
i:=1; 
j:=SearchV(g,x); 
if j=0 then VNext:=-1 else begin //нет такой вершины 
while (i<>g.lastarc+1) and (g.arc[i].v1<>j) do inc (i); 
if i=g.lastarc+1 then VNext:=0 //нет смежных вершин 
else begin 
if g.arc[i+1].v1=j then 
VNext:=g.arc[i+1].v2 
else VNext:=-2; //только одна смежная вершина 
end; 
end; 
end;
function VNode(g:graf;x:char;n:integer):integer; 
var 
i,j:integer; 
begin 
i:=1; 
j:=SearchV(g,x); 
if j=0 then VNode:=0 //нет такой вершины 
else begin 
while (i<>g.lastarc+1) and (g.arc[i].v1<>j) do inc(i); 
if i=g.lastarc+1 then VNode:=-1 //нет смежных вершин 
else begin 
if g.arc[i+n-1].v1=j then 
VNode:=g.arc[i+n-1].v2 
else VNode:=-2 //нет смежной вершины с таким индексом 
end; 
end; 
end; 
procedure War(var ngr:graf;g:graf); 
var 
k,i,j,w:integer; 
begin 
ngr:=g; 
for i:=1 to g.lastarc+1 do 
if ngr.arc[i].w<>0 then ngr.arc[i].w:=1; 
for k:=1 to g.lastv do 
for i:=1 to g.lastv do 
for j:=1 to g.lastv do 
if xlabelread(ngr,ngr.v[i],ngr.v[j])=0 then begin 
if (xlabelread(ngr,ngr.v[i],ngr.v[k])<>0) and (xlabelread(ngr,ngr.v[k],ngr.v[j])<>0) then begin 
w:=1; 
xinsert(ngr,ngr.v[i],ngr.v[j],w); 
end; 
end; 
end; 
 
{procedure War(g:graf); 
var 
k,i,j,p,s,r:integer; 
dis: dist; 
l:length; 
begin 
for k:=1 to g.lastv do 
for i:=1 to g.lastv do 
for j:=1 to g.lastv do begin 
if i=j then dis[i,j,k]:=0 
else begin 
s:= xlabelread(g,g.v[i],g.v[j]); 
p:= xlabelread(g,g.v[i],g.v[k]); 
r:= xlabelread(g,g.v[k],g.v[j]); 
if (k<>i) and(k<>j) and(xlabelread(g,g.v[i],g.v[k])<>0) and (xlabelread(g,g.v[k],g.v[j])<>0) then begin 
if (s>p+r) or(s=0) then 
dis[i,j,k]:=p+r; 
end 
else dis[i,j,k]:=s; 
end; 
end; 
for i:=1 to g.lastv do 
for j:=1 to g.lastv do 
for k:=1 to g.lastv do begin 
if (dis[i,j,k]<>0) then begin 
if (dis[i,j,k+1]<>0) then begin 
if l[i,j]=0 then 
if (dis[i,j,k]<dis[i,j,k+1]) then l[i,j]:=dis[i,j,k] 
else l[i,j]:=dis[i,j,k+1] 
else if l[i,j]>dis[i,j,k] then l[i,j]:=dis[i,j,k] 
end; 
end 
else l[i,j]:=0; 
end; 
write(' '); 
for i:=1 to g.lastv do 
write(' ',g.v[i]); 
writeln; 
for i:=1 to g.lastv do begin 
write(g.v[i], ' '); 
for j:=1 to g.lastv do begin 
write(l[i,j],' '); 
end; 
writeln; 
end; 
end;} 
 
 
procedure PRINT(g:graf); 
var 
i,j:integer; 
begin 
write(' '); 
for i:=1 to g.lastv do 
write(' ',g.v[i]); 
writeln; 
for i:=1 to g.lastv do begin 
write(g.v[i], ' '); 
for j:=1 to g.lastv do begin 
k:=xlabelread(g,g.v[i],g.v[j]); 
write(k,' '); 
end; 
writeln; 
end; 
end; 
 
begin 
CREATION(g); 
writeln('1 - Add vert'); 
writeln('2 - Add arc'); 
writeln('3 - Read vert'); 
writeln('4 - Read arc'); 
writeln('5 - Delete vert'); 
writeln('6 - Delete arc'); 
writeln('7 - Print'); 
writeln('8 - First vertex'); 
writeln('9- Next vertex'); 
writeln('10-Node'); 
writeln('11-WAR'); 
writeln('0 - EXIT'); 
for j:=1 to 100 do begin 
writeln('Your choice:'); 
readln(d); 
case d of 
1 : begin 
writeln('vertex:'); 
read(x); 
if VINSERT(G,x)=0 then writeln('Array is full'); 
end; 
2 : begin 
writeln('vertex 1:'); 
readln(x1); 
writeln('vertex 2:'); 
readln(x2); 
writeln('weight:'); 
readln(k); 
er:=XINSERT(G,x1,x2,k); 
if er=0 then 
writeln('Such vertex doesnt exist'); 
if er=-1 then 
writeln('It is already exist'); 
if er=-2 then 
writeln('Arr is ful'); 
if er=-3 then 
writeln('Impossible to create arc with 0 weight') 
end; 
3: begin 
writeln('vertex number:'); 
read(d); 
x:=VLABELREAD(G,d); 
if x='0' then writeln('Such vertex doesnt exist') 
else 
writeln('Vertex:',x); 
end; 
4 : begin 
writeln('vertex 1:'); 
readln(x1); 
writeln('vertex 2:'); 
readln(x2); 
n:=XLABELREAD(G,x1,x2); 
if n=-1 then writeln('Such vertex doesnt exist') 
else 
if n=0 then writeln('Such arc doesnt exist') 
else writeln('Label:',n); 
end; 
5 : begin 
writeln('vertex:'); 
read(x); 
er:=VDELETE(G,x); 
if er=0 then 
writeln('Such vertex doesnt exist'); 
end; 
6 : begin 
writeln('vertex 1:'); 
readln(x1); 
writeln('vertex 2:'); 
readln(x2); 
er:=XDELETE(G,x1,x2); 
if er=0 then 
writeln('Such vertex doesnt exist'); 
if er=-1 then 
writeln('Such arc doesnt exist'); 
end; 
7 : PRINT(g); 
 
8 : begin 
writeln('vertex:'); 
read(x); 
k:=VFIRST(G,x); 
if k=0 then 
writeln('Such vertex doesnt exist') 
else 
if k=-1 then writeln('No adjacent vertices') 
else writeln ('First adjacent vertex:',k); 
end; 
9 :
begin 
writeln('vertex:'); 
read(x); 
k:=VNEXT(G,x); 
if k=0 then 
writeln('Such vertex doesnt exist') 
else 
if k=-1 then writeln('No adjacent vertices') 
else if k=-2 then writeln('Only one adjacent vertex') 
else 
writeln ('Next adjacent vertex:',k); 
end; 
10 : begin 
writeln('Vertex:'); 
read(x); 
writeln('Number:'); 
read(n); 
k:=VNODE(G,x,n); 
if k=0 then 
writeln('Such vertex doesnt exist') 
else 
if k=-1 then writeln('No adjacent vertices') 
else if k=-2 then writeln('No such adjacent vertice') 
else writeln ('Adjacent vertex:',k); 
end; 
11: begin 
war(ngr,g); 
print(ngr); 
end; 
0: exit; 
end; 
end; 
readln; 
end.