Сравнение двух графов на равенство
Предлагаю Вам программу чисто теоретического характера. Язык: Borland Pascal 7.0
Сравниваем два графа на равенство.
{Version 1.0}
{Курсовая работа по курсу "Структуры данных и их обработка"}
{Шарова Е.Н.}
{Тема работы : "Сравнение двух графов на равенство"}
Program Kursovik;
Uses
Crt;
Const
n = 170;
Type
stack = array [1..n] of byte;
mas = array [1..n,1..n] of shortint;
{Значения ячеек массива :
1 - существует дуга из вершины i В j
-1 - существует дуга из вершины j В i
0 - вершины i и j не соединены дугой.}
mm = array [1..n,1..2] of byte;
{Значения ячеек массива : [i,N] и [i,N] , где N=1,2
В ячейке 1 хранится кол-во выходящих дуг из i-той вершины.
В ячейке 2 хранится кол-во входящих дуг в i-тую вершину.}
Var
f : text; {Файл с графом}
key : char; {Сканирует клавиатуру}
i,j,k,x,count1,count2 : integer;
m1,m2 : mas; {Матрицы инциндентности графов}
stop : boolean;
t1,t2 : mm; {Вспомогательные массивы второго уровня}
Procedure Ramka ;
begin
TextColor(0);
TextBackGround(0);
window(23,8,61,18);
clrscr;
TextColor(11);
TextColor(3);
TextBackGround(3);
window(21,7,59,17);
clrscr;
TextColor(11);
end;
Procedure Menu; {Основное меню программы.}
begin
textcolor(1);
textbackground(1);
clrscr;
Ramka;
textcolor(11);
gotoxy(13,2);
write('Курсовая работа');
textcolor(10);
gotoxy(5,3);
write('"Сравнение графов на равенство"');
textcolor(White);
gotoxy(4,5);
write('Создать граф "A"................1');
gotoxy(4,6);
write('Создать граф "B"................2');
gotoxy(4,7);
write('Посмотреть на графы.............3');
gotoxy(4,8);
write('Сравнить графы..................4');
gotoxy(4,9);
write('О программе.....................5');
gotoxy(3,10);
write('Завершение работы программы.....ESC');
TextColor(1);
TextBackGround(1);
window(1,1,80,25)
end;
{Инициализация матриц инциндентности для графов и вспомогательных массивов,}
{где zz - номер графа (1 или 2).}
Procedure Clr(zz:byte);
begin
for i:=1 to n do
for j:=1 to n do
if zz=1
then m1[i,j]:=0
else m2[i,j]:=0;
for i:=1 to n do
if zz=1
then begin t1[i,1]:=0; t1[i,2]:=0 end
else begin t2[i,1]:=0; t2[i,2]:=0 end
end;
{Открытие файла с графом, где z - номер графа (1 или 2).}
Procedure OpenFile(z:byte);
var
ss,s1,s2,fn: string[40];
count: integer;
begin
clrscr;
textcolor(11);
if z=1
then clr(1)
else clr(2);
count:=0;
write('Введите имя файла : ');
textcolor(10);
readln(fn);
assign(f,fn);
{$i-}
reset(f);
{$i+}
if ioresult<>0
then
begin
textcolor(15);
writeln('Ошибка...');
key:=readkey;
menu;
exit
end;
readln(f,ss);
val(ss,count,i);
while not eof (f) do
begin
readln(f,ss);
s1:='';
s2:='';
i:=1;
while ss[i]<>'-' do
begin
s1:=s1+ss[i];
inc(i)
end;
inc(i);
while i<=length(ss) do
begin
s2:=s2+ss[i];
inc(i)
end;
val(s1,i,x);
val(s2,j,x);
if z=1
then
begin
m1[i,j]:=1;
m1[j,i]:=-1;
inc(t1[i,1]);
inc(t1[j,2])
end
else
begin
m2[i,j]:=1;
m2[j,i]:=-1;
inc(t2[i,1]);
inc(t2[j,2])
end
end;
close (f);
if z=1
then count1:=count
else count2:=count;
textcolor(15);
writeln('Загрузка графа из файла завершена !');
key:=readkey;
menu
end;
{Ввод графа с клавиатуры, где z - номер графа (1 или 2).}
Procedure NewGr(z:byte);
var ss : string[30];
count: integer;
begin
clrscr;
textcolor(11);
if z=1
then clr(1)
else clr(2);
count:=0;
write('Введите количество вершин : ');
textcolor(10);
readln(count);
if (count <=0) OR (count>n)
then
begin
write('Ошибочный ввод !!');
if z=1
then count1:=0
else count2:=0;
key:=readkey;
menu;
exit
end;
i:=1;
j:=1;
while (j<>0) and (i<>0) do
begin
readln(i,j);
if (i>0) and(j>0) and (j<=n) and (i<=n)
then
begin
if i<>j
then
begin
if z=1
then
begin
m1[i,j]:=1;
m1[j,i]:=-1;
inc(t1[i,1]);
inc(t1[j,2])
end
else
begin
m2[i,j]:=1;
m2[j,i]:=-1;
inc(t2[i,1]);
inc(t2[j,2])
end
end
else
writeln('Ошибка...');
end
end;
textcolor(15);
writeln('Граф введен !');
if z=1
then count1:=count
else count2:=count;
key:=readkey;
menu
end;
{Показать граф, где z - номер графа (1 или 2).}
Procedure LookGr(z:byte);
var
count: integer;
begin
if z=1
then count:=count1
else count:=count2;
if count<>0
then
begin
textcolor(10);
write('Граф ');
if z=1
then writeln('"A" ')
else writeln('"B" ');
textcolor(11);
write('Количество вершин : ');
textcolor(15);
writeln(count);
textcolor(11);
writeln('Дуги :');
textcolor(10);
write('');
for i:=1 to count do
begin
write('');
j:=1;
while j<=count do
begin
if z=1
then
begin
if m1[i,j]=1
then
if wherex>70
then
begin
writeln;
write('(',i,',',j,') ')
end
else
write('(',i,',',j,') ')
end
else
begin
if m2[i,j]=1
then
if wherex>70
then
begin
writeln;
write('(',i,',',j,') ')
end
else
write('(',i,',',j,') ')
end;
inc(j)
end
end;
writeln;
textcolor(14);
write('Изолированные вершины : ');
textcolor(10);
for i:=1 to count do
begin
k:=0;
for j:=1 to count do
if z=1
then
begin
if m1[i,j]<>0 then inc(k)
end
else
begin
if m2[i,j]<>0 then inc(k)
end;
if k = 0
then
if wherexv
then
begin
writeln;
write(i,' ')
end
else
write(i,' ')
end;
writeln;
writeln
end
else
begin
textcolor(10);
write('Граф ');
if z=1
then write('"A" ')
else write('"B" ');
writeln('не найден...')
end;
end;
{Впомогательное меню.}
Procedure menu1;
var
sig : boolean;
i : byte;
begin
clrscr;
textbackground(0);
window(25,10,59,16);
clrscr;
TextColor(3);
TextBackGround(3);
window(23,9,57,15);
clrscr;
textcolor(11);
gotoxy(14,2);
write('Граф "');
if key='1'
then write('A"')
else write('B"');
textcolor(15);
gotoxy(4,4);
write('1..........Загрузить из файла');
gotoxy(4,5);
write('2.........Ввести с клавиатуры');
gotoxy(4,6);
write('ESC......Выход в главное меню');
TextBackGround(1);
window(1,1,80,25);
sig:ъlse;
i:=ord(key)-48;
while not sig do
begin
key:=readkey;
if key =#0 then key:=readkey
else
case key of
'1': begin Openfile(i); sig:=true end;
'2': begin Newgr(i); sig:=true end;
#27: sig:=true
end;
end;
Menu
end;
Function OutNet(r:byte;var m:mas;var t:mm;level:integer):integer;
var
e1,e2,e3:byte; Res : integer;
begin
res:=0;
if level>0
then
begin
e1:=t[r,1];
e2:=0;
e3:=1;
while e2<>e1 do
begin
if m[r,e3]= 1
then
begin
res:=resКz(e3,m,t,level-1)+1;
inc(e2)
end;
inc(e3)
end
end;
OutNet:=res
end;
Function InNet(r:byte;var m:mas;var t:mm;level:integer):integer;
var
e1,e2,e3:byte; Res : integer;
begin
res:=0;
if level>0
then
begin
e1:=t[r,2];
e2:=0;
e3:=1;
while e2<>e1 do
begin
if m[r,e3]= -1
then
begin
res:=ress(e3,m,t,level-1)+1;
inc(e2)
end;
inc(e3)
end
end;
InNet:=res
end;
Function Present (r:byte;var st:stack):boolean;
var
e1: integer;
res : boolean;
begin
res:ъlse;
e1:=1;
while e1<=count1 do
begin
if st[e1]= r then
begin
res:=true;
e1:=count1
end;
inc(e1)
end;
Present:=Res
end;
{Главная процедура : Сравнение двух графов.}
Procedure Compare;
var
i,j,k,l,x,x1,x2 : integer; {Впомогательные переменные}
ok,stop2 : boolean; {Ok-признак корректности сравнения}
{Как только Okъlse, так сразу же
произойдет преостановка дальнейшего
сравнения графов}
st1,st2,st3 : stack; {Вспомогательные массивы}
begin
ok:=true;
clrscr;
textcolor(14);
If (count1=0) and (count2=0)
then
begin
Writeln('Графы не созданы.');
key:=readkey;
Menu;
Exit
end;
If (count1=0) or (count2=0)
then
begin
Write('Граф "');
if count1=0 then write('A')
else write('B');
writeln('" не создан.');
key:=readkey;
Menu;
Exit
end;
writeln('Пожалуйста, подождите...');
textcolor(11);
writeln('Сравниваются графы...');
textcolor(15);
for i:=1 to n do
begin
st1[i]:=0;
st2[i]:=0;
st3[i]:=0
end;
if (count1<>count2) or (count1=0) or (count2=0)
then
ok:ъlse;
x:=t1[1,1]+t1[1,2];
for i:=1 to count1 do
if (t1[i,1]+t1[i,2])>x
then
x:=t1[i,1]+t1[i,2];
i:=0;
while (i<=x) and ok do
begin
x1:=0;
for j:=1 to count1 do
if i = (t1[j,1]+t1[j,2])
then
begin
inc(x1);
st1[x1]:=j
end;
x2:=0;
for j:=1 to count1 do
if i = (t2[j,1]+t2[j,2])
then
begin
inc(x2);
st2[x2]:=j
end;
inc(i);
if x1<>x2
then
ok:ъlse
else
begin
j:=x1;
l:=x1;
while (j>0) and ok do
begin
k:=x2;
while k>0 do
if (InNet(st1[j],m1,t1,Count1)=InNet(st2[k],m2,t2,Count1))
and
(OutNet(st1[j],m1,t1,Count1)=OutNet(st2[k],m2,t2,Count1))
then
begin
st3[st1[j]]:=st2[k];
st2[k]:=st2[x2];
dec(x2);
dec(l);
k:=0
end
else
dec(k);
dec(j);
if j<>l
then
ok:ъlse
end
end
end;
if ok
then
{ Каркасные структуры графов равны.
Проводим переименование вершин.}
begin
for i:=1 to n do
begin
st1[i]:=0;
st2[i]:=0;
st3[i]:=0
end;
{ Проверка соответствия статуса вершин с одинаковыми полями }
For i:=1 to count1 do
begin if (InNet(i,m1,t1,Count1)=InNet(i,m2,t2,Count2))
and
(OutNet(i,m1,t1,Count1)=OutNet(i,m2,t2,Count2))
then st3[i]:=i;
end;
i:=0;
while i<=x do
begin
x1:=0;
for j:=1 to Count1 do
if i = (t1[j,1]+t1[j,2])
then
begin
inc(x1); St1[x1]:=j
end;
x2:=0;
for j:=1 to Count1 do
if i = (t2[j,1]+t2[j,2])
then
begin
inc(x2); St2[x2]:=j
end;
for j:=1 to x1 do
if st3[st1[j]]<>0 then st1[j]:=0;
for j:=1 to x1 do
if Present(st2[j],st3) then st2[j]:=0;
{Подсчитываем новое количество элементов в списках St1 и St2.}
j:=0;
for k:=1 to x1 do
if st1[k]<>0
then inc(j);
x1:=j;
j:=0;
for k:=1 to x2 do
if st2[k]<>0
then inc(j);
x2:=j;
j:=0;
k:=0;
while k<>x1 do
begin
inc(j);
if st1[j]<>0
then
begin
inc(k);
st1[k]:=st1[j];
if k<>j
then st1[j]:=0;
end;
end;
j:=0;
k:=0;
while k<>x2 do
begin
inc(j);
if st2[j]<>0
then
begin
inc(k);
st2[k]:=st2[j];
if k<>j
then st2[j]:=0;
end;
end;
if (x1=1) and (x2=1)
then
st3[st1[1]]:=st2[1]
else
begin
j:=x1;
while j>0 do
begin
k:=x2;
while k>0 do
if (InNet(st1[j],m1,t1,Count1)=InNet(st2[k],m2,t2,Count1))
and
(OutNet(st1[j],m1,t1,Count1)=OutNet(st2[k],m2,t2,Count1))
then
begin
st3[st1[j]]:=st2[k];
st2[k]:=st2[x2];
dec(x2);
k:=0
end
else
dec(k);
dec(j)
end;
end;
inc(i)
end;
j:=0;
for i:=1 to count1 do
if st3[i]<>i then inc(j);
if j=0
then
writeln('Графы равны !')
else
begin
j:=1;
writeln('Чтобы свести граф "А" к графу "В",'+
' надо переименовать вершины в графе "А":');
for i:=1 to count1 do
begin
if i <> st3[i]
then writeln(i:3,' -> ',st3[i]);
{ inc(j);
if j# then
begin
textcolor(13);
gotoxy(10,25);
write('<<< Нажмите любую клавишу для продолжения >>>');
gotoxy(10,25);
key:=readkey;
if key = #0
then
key:=readkey;
textcolor(15);
write(' ');
gotoxy(1,25);
j:=1
end; }
end;
end;
textcolor(13);
writeln('Процесс окончен !')
end
else
begin
textcolor(15);
writeln('Графы не могут быть сведены друг к другу.')
end;
key:=readkey;
if key= #0
then
key:=readkey;
menu
end;
Procedure Autor;
begin
clrscr;
textbackground(0);
window(23,10,61,16);
clrscr;
TextColor(3);
TextBackGround(3);
window(21,9,59,15);
clrscr;
textcolor(11);
gotoxy(3,2);
writeln('Программа написана студентом группы ',' ':18,'ПА-97');
gotoxy(6,4);
textcolor(10);
writeln('Шаровым Евгением Николаевичем');
gotoxy(11,6);
textcolor(14);
writeln('All rights reserved');
key:=readkey;
if key = #0
then
key:=readkey;
menu
end;
begin
stop:=false;
menu;
while not stop do
begin
key:=readkey;
if key = #0 then begin Sound(60); Delay(20); NoSound; key:=readkey end
else case key of
'1':menu1;
'2':menu1;
'3': begin
textcolor(1);
clrscr;
lookgr(1);
key:=readkey;
if key= #0
then
key:=readkey;
lookgr(2);
key:=readkey;
if key =#0 then key:=readkey;
menu
end;
'4': Compare;
'5': Autor;
#27: stop:=true
end
end;
textmode(3)
end.
Prolog — это язык логического программирования. Он является декларативным языком: вся стуктура программы представлена в виде правил и фактов. На нем можно строить экспертные системы, генерирующие ответы вида true (истина) или false (ложь). Пролог хорошо подходит для автоматического перебора вариантов решений с возвратами. Язык не требует написания большого объемного кода и позволяет получать отличные результаты.
|
|
Интересные материалы на сайте:
|
|
Автор, разработчик: Шаров Евгений (gcmsite@yandex.ru)
(c) 2000-2020 GCM-Site - системное и веб-программирование
Цитирование материалов сайта возможно только при наличии гиперссылки
|
