else begin
New(p2^.Next);
p2^.Next^.Inf:=m;
p2^.Next^.Next:=Nil;
WriteLn('Дуга добавлена!!!');
end;
end;
end;
end;
end
end;
{--удаляем список дуг--}
procedure DelList(p:TUk1);
var p1:TUk1;
begin
while (p<>Nil) do
begin
p1:=p;
p:=p^.Next;
Dispose(p1);
end;
end;
{---------удаляем вершину из графа---------}
procedure DelVer(n:integer);
var
p,p1:TUk;
p2,p3:TUk1;
begin
if (Head=Nil) then WriteLn('В графе нет ни одной вершины!!!')
else begin
p:=Head;
if (p^.Inf=n) then
begin
Head:=Head^.Down;
DelList(p^.Left);
Dispose(p);
end else begin
while ((p^.Down^.Inf<>n)and(p^.Down<>Nil)) do p:=p^.Down;
if (p^.Down=Nil) then WriteLn('В графе нет указанной вершины!!!')
else begin
DelList(p^.Down^.Left);
p1:=p^.Down;
p^.Down:=p^.Down^.Down;
Dispose(p1);
end;
end;
p:=Head;
while (p<>Nil) do
begin
if (p^.Left^.Inf=n) then
begin
p2:=p^.Left;
p^.Left:=p^.Left^.Next;
Dispose(p2);
end else begin
p2:=p^.Left;
while ((p2^.Next<>Nil)and(p2^.Next^.Inf=n)) do p2:=p2^.Next;
if(p2^.Next^.Inf=n) then
begin
p3:=p2^.Next;
p2^.Next:=p2^.Next^.Next;
Dispose(p3);
end;
end;
p:=p^.Down;
end;
end;
end;
{------удаляем дугу графа--------}
procedure DelDug(n,m:integer);
var
p,p1:TUk;
p2,p3:TUk1;
begin
if (Head=Nil) then WriteLn('В графе нет ни одной вершины!!!')
else begin
p:=Head;
while ((p^.Inf<>n)and(p<>Nil)) do p:=p^.Down;
if (p=Nil) then WriteLn('В графе отсутствует указанная вершина источник')
else begin
p1:=Head;
while ((p1<>Nil)and(p1^.Inf<>m)) do p1:=p1^.Down;
if (p1=Nil) then WriteLn('В графе отсутствует указанная вершина сток!!!')
else begin
p2:=p^.Left;
if (p^.Left^.Inf=m) then
begin
p3:=p^.Left;
p^.Left:=p^.Left^.Next;
Dispose(p3);
end else begin
while ((p2^.Next^.Inf<>m)and(p2^.Next<>Nil)) do p2:=p2^.Next;
if (p2=Nil) then WriteLn('Указанного ребра нет в графе!!!')
else begin
p3:=p2^.Next;
p2^.Next:=p2^.Next^.Next;
Dispose(p3);
end;
end;
end;
end;
end;
end;
{---Вывод графа в виде матрицы смежности------}
procedure PrintGraph;
var
i,j,n:integer;
M:array [1..max,1..max] of byte;
p:TUk;
p2:TUk1;
begin
for i:=1 to max do
for j:=1 to max do M[i,j]:=0;
n:=0;
if (Head=Nil) then WriteLn('В графе нет ни одной вершины!!!')
else begin
p:=Head;
while (p<>Nil) do
begin
inc(n);
p2:=p^.Left;
while (p2<>Nil) do
begin
M[p^.Inf,p2^.Inf]:=1;
p2:=p2^.Next;
end;
p:=p^.Down;
end;
end;
for i:=1 to n do
begin
for j:=1 to n do Write(M[i,j]:2);
WriteLn;
end;
end;
{-----находим все источники орграфа----}
procedure FindIstok;
var
f:boolean;
i,k:integer;
Is:array[1..max*max] of byte;
p,p1:TUk;
p2:TUk1;
begin
for i:=1 to max*max do Is[i]:=0;
if (Head=Nil) then WriteLn('В графе нет ни одной вершины!!!')
else begin
k:=0;
p:=Head;
while (p<>Nil) do
begin
if (p^.Left<>Nil) then
begin
f:=true;
p1:=Head;
while (p1<>Nil) do
begin
p2:=p1^.Left;
while ((f)and(p2<>Nil)) do
begin
if p2^.Inf=p^.Inf then f:=false;
p2:=p2^.Next;
end;
p1:=p1^.Down;
end;
if (f=true) then
begin
inc(k);
Is[k]:=p^.Inf;
end;
end;
p:=p^.Down;
end;
end;
for i:=1 to k do Write(Is[i]:2);
end;
procedure Menu;
begin
WriteLn('1-Показать матрицу смежности графа');
WriteLn('2-Добавить вершину в граф');
WriteLn('3-Добавить дугу в граф');
WriteLn('4-Удалить вершину графа');
WriteLn('5-Удалить дугу графа');
WriteLn('6-Найти источники орграфа');
WriteLn('7-Выход');
end;
{--------основная программа--------}
begin
ClrScr;
repeat
clrscr;
Menu;
c:=ReadKey;
case c of
'1': begin
ClrScr; PrintGraph; ReadKey;
end;
'2': begin
ClrScr;
Write('Введите добавляемую вершину : ');
ReadLn(n); AddVer(n);
end;
'3': begin
ClrScr;
Write('Введите вершину источник дуги : ');
ReadLn(n);
Write('Введите вершину сток дуги : ');
ReadLn(m); AddDug(n,m);
end;
'4': begin
ClrScr;
Write('Введите удаляемую вершину : ');
ReadLn(n); DelVer(n);
end;
'5': begin
ClrScr;
Write('Введите вершину источник удаляемой дуги : ');
ReadLn(n);
Write('Введите вершину сток удаляемой дуги : ');
ReadLn(m); DelDug(n,m);
end;
'6': begin
ClrScr; FindIstok; ReadKey;
end;
'7': begin
halt;
end;
end;
until ord(c)=27;
end.