IPB
ЛогинПароль:

> Прочтите прежде чем задавать вопрос!

1. Заголовок темы должен быть информативным. В противном случае тема удаляется ...
2. Все тексты программ должны помещаться в теги [code=pas] ... [/code], либо быть опубликованы на нашем PasteBin в режиме вечного хранения.
3. Прежде чем задавать вопрос, см. "FAQ", если там не нашли ответа, воспользуйтесь ПОИСКОМ, возможно такую задачу уже решали!
4. Не предлагайте свои решения на других языках, кроме Паскаля (исключение - только с согласия модератора).
5. НЕ используйте форум для личного общения, все что не относится к обсуждению темы - на PM!
6. Одна тема - один вопрос (задача)
7. Проверяйте программы перед тем, как разместить их на форуме!!!
8. Спрашивайте и отвечайте четко и по существу!!!

 
 Ответить  Открыть новую тему 
> Эйлеров цикл в графе, Графически изобразить
сообщение
Сообщение #1


Новичок
*

Группа: Пользователи
Сообщений: 45
Пол: Мужской

Репутация: -  0  +


Задание: построение Эйлерова цикла в неориентированном графе, заданном матрицей инцидентности.
Проблема: процедуру Эйлерова цикла нам дали готовую (она перечисляет вершины), вот только не могу графически на экране изобразить преобразованный граф.

Program Lab;

Uses Crt,Graph;

const Qt = 20;

var st : string;
k1 : integer;
{-------------------------- Begin Stack -------------------------------}

const NL = 1000;

Type Number = 0..NL;
Type Stack = object
Elements: array [1..NL] of integer;
Last: Number;
Constructor Init;
Function Push (Dn : integer) : boolean;
Function Empty : boolean;
Function Pop (var Dn:integer): boolean;
Procedure Print;
end;

Constructor Stack.Init;
begin
Last:=0;
end;

Function Stack.Push(Dn : integer): boolean;
begin
If Last < NL then
begin
Inc(Last);
Elements[Last] := Dn;
Push := true;
end
else Push := false;
end;

Function Stack.Empty : boolean;
begin
If Last = 0
then Empty := TRuE
else Empty := false;
end;

Function Stack.Pop (var Dn : integer): boolean;
var I : Number;
begin
If Empty then Pop := false
else
begin
Dn := Elements[Last];
Dec(Last);
Pop := true;
end;
end;

Procedure Stack.Print;
var I : Number;
begin
For I := 1 to Last do write(Elements[I]:3);
writeln;
end;


{----------------------------- Begin Graf -----------------------------}

const MaxVertex = 100;
MaxEdges = 500;
x0 = 320;
y0 = 240;
R = 200;

Type
Edge = record
From, Into : integer;
end;

Graf = object
KolVertex : 0..MaxVertex;
KolEdges : 0..MaxEdges;
Edges:array [1..MaxEdges] of Edge;
Used: array [1..MaxVertex] of boolean;
Numbers: array [1..MaxVertex] of integer;
coordX: array [1..MaxVertex] of integer;
coordY: array [1..MaxVertex] of integer;
Constructor Init(KV, KE : integer);
Function Get(var s : string) : string;
Procedure Print; {VbIvod grafa na ekran}
end;

Constructor Graf.Init(KV, KE : integer);
var i : integer;
begin
KolVertex := KV;
KolEdges := KE;
For i := 1 to KolVertex do
begin
Used[i] := false;
Numbers[i] := MaxInt;
coordX[i] := round(x0 + R*cos(2*pi*(i-1)/KolVertex));
coordY[i] := round(y0 - R*sin(2*pi*(i-1)/KolVertex));
end;
end;

Function Graf.Get(var s : string) : string;
begin
Get := s;
end;

Procedure Graf.Print;
var i, j, rad, rad1, vert,
x1, y1,
grDriver, grMode : integer;
f : boolean;
s : string;

const x0 = 460;
y0 = 80;
dins = 20;

begin
rad := 5;
rad1 := 8;
grDriver := Detect;
InitGraph(grDriver, grMode, '');
SetColor(15);
For i := 1 to KolVertex do
begin
Circle(coordX[i], coordY[i], rad);
str(i, s);
SetColor(Yellow);
OutTextXY(coordX[i] + round(13*cos(2*pi*(i-1)/KolVertex)),
coordY[i] - round(13*sin(2*pi*(i-1)/KolVertex)), s);
SetColor(15);
end;
For i := 1 to KolEdges do
For j := 1 to KolVertex do
begin
f := true;
If Edges[i].From = j
then vert := Edges[i].Into
else
If Edges[i].Into = j
then vert := Edges[i].From
else f := false;
If f then
begin
SetColor(9);
Line(coordX[j], coordY[j], coordX[vert], coordY[vert]);
end;
SetColor(15);
end;
readln;
CloseGraph;
end;

{--------------------------------------------------------------------------}
var Gra : Graf;

Function Another(NE, First : integer; var Second : integer) : boolean;
begin
Another := true;
with Gra.Edges[NE] do
begin
If From = First then Second := Into
else
If Into = First then Second := From
else Another := false;
end;
end;

Procedure DeleteEdge(Number : integer);
var i : integer;
begin
with Gra do
begin
dec(KolEdges);
For i := Number to KolEdges do Edges[i] := Edges[i + 1];
end;
end;

Function Euler(var Sta : Stack) : boolean;

Function SearchEdge(var Vertex, NumberEdge : integer) : boolean;
var I : integer;
begin
with Gra do
begin
SearchEdge := true;
For I := 1 to KolEdges do
If Another(I, Vertex, Vertex) then
begin
NumberEdge := I;
exit;
end;
SearchEdge := false;
end;
end;

var Sta1 : Stack;
Vertex, NumberEdge: integer;
s : string;

begin
Euler := false;
Sta.Init;
Sta1.Init;
Vertex := Gra.Edges[1].From;
write(Gra.Edges[1].Into);
While Gra.KolEdges > 0 do
If SearchEdge(Vertex, NumberEdge) then
begin
Sta.Push(Vertex);
DeleteEdge(NumberEdge);
end
else
If Sta.Pop(Vertex)
then Sta1.Push(Vertex)
else exit;
While Sta1.Pop(Vertex) do Sta.Push(Vertex);
Euler := true;
end;

const

Root = 4;

MS1 : array[1..6,1..6] of integer=
((1,0,1,0,0,1),
(0,1,0,0,0,0),
(0,0,1,0,0,0),
(0,1,0,1,0,1),
(0,0,0,1,1,0),
(1,0,0,0,1,0));



var i, j, k, t : integer;
sta1 : Stack;

BEGIN

with Gra do {Вот здесь рисую граф ДО преобразования}
begin
Init(6, 6);
k := 1;
for i := 1 to 6 do
for j := 1 to 5 do
for t := j + 1 to 6 do
begin
if (MS1[j,i] = 1) and (MS1[t,i] = 1)
then
begin
Edges[i].From := j;
Edges[i].Into := t;
Used[j] := true;
Used[t] := true;
Inc(k);
break;
end;
end;
Print;
end;

{Gra.Init(6, 6); Здесь надо нарисовать граф ПОСЛЕ построения ЭЦ}
sta1.Pop(i);
t := 1;
while not sta1.Empty do
begin
sta1.Pop(j);
with Gra do
begin
Edges[t].From := i;
Edges[t].Into := j;
writeln(i, ' ',j);
readln;
Used[i] := true;
Used[j] := true;
end;
i := j;
inc(t);
end;}
write('Euler cycle: '); {Отладочная инфа - простой вывод списка вершин}
Euler(sta1);
sta1.print;
readln;
{Gra.Print;}
END.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 16.05.2024 17:01
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name