Добавил:
Tushkan
Опубликованный материал нарушает ваши авторские права? Сообщите нам.
Вуз:
Предмет:
Файл:Программа для построения и анализа графов / UGraph
.pasunit UGraph;
interface
uses utype, classes,dialogs, graphics;
{$M+}
procedure ProcessMessages; //Супер процедура от зависания
type TArrV = array of TV;
type TarrE = array of TR;
type TBoolMatrix = array of array of 0..1;
type TGraph = class
public
{Описанные в этой секции элементы доступны всем.}
V: Tarrv; // Массив вершин
E: TarrE; // Массив ребер
//MatrixSm: TMatrix; // Матриц смежности и инциденции
//Matrixinc: TMatrix;//Вычисляется процедурой CreateMatrix(...)
Orgraph: boolean; // true - орграф. Иначе - не орграф
Vzves: boolean; // тру - взвешенный
service: integer; //сюда пишем каждый себе что нужно
comment: string; // Комментарий к графу
Web: boolean; //Является ли сетью?
col: Tarrcol;
minOstov: TGraph ; //Минимальные остовы - по одному в каждой компоненте связности
constructor Create; overload;
constructor Create(num: integer); overload;
constructor Create(filename: string); overload;
constructor Invert(G: tgraph);
function klika: boolean; //Тру если клика (Вычисляется процедурой Kilka(g));
function Odnorod: boolean; //Тру если однородный (Вычисляется процедурой Kilka(g));
//Удаление ребра - G - Граф, E - Указатель на ребро
function delete(Reb: TR): boolean; overload;
//Удаление вершины - G - Граф, V - Указатель на вершину
function delete(Ver: TV): boolean; overload;
//Создание ребра - G - Граф, p1, p2 - Указатели на вершины - концы ребра.
//Возвращается созданное ребро.
function Create(p1, p2: TV): TR; overload;
//Создание вершины - G - Граф, x,y - координаты вершины. Возвращается вершина.
function Create( x, y: integer): TV; overload;
//Есть ли ребро в графе?
function GetE(p1, p2: TV):tr;
//Вернуть вершину по координатам и радиусу
function GetVChoord(x, y: integer): TV;
function GetEChoord(x, y: integer): TR;
//Процедура проерки и исправления ошибок в графе
procedure CheckGraph;
//Отрисовка графа на канве
procedure Draw(Canv: tcanvas; small: boolean = false);
//Процедура копирования графа g
constructor assign(g: tgraph);
//Сохранить граф в файл
procedure SaveTofile(filename: string);
//Есть ли вершина в графе?
function ExistV(ver: TV): boolean;
//Есть ли ребро в графе?
function ExistE(reb: TR): boolean;
//возвращает указатель на матицу смежности
procedure GetMatrixSm(var PmatrixSm:tmatrix);
//возвращает указатель на матицу инциденций
procedure GetMatrixInc(var PmatrixInc:tmatrix);
//procedure createMatrix;
//процедурa возвращает массив инцидентных ребер
//Если флаг 1, то ищутся только дуги, исх из ver
//Если -1, то то ищутся только дуги, вх из ver
//Если другой, то все.
//Выводятся с индекса 0.
function GetIncE(ver:tv; flag: integer = 0): tstrings;
//процедурa возвращает массив смежных вершин
//Если флаг 1, то ищутся только вершины, смежные по исходящей дуге
//Если -1, то то ищутся только вершины, смежные по входящей дуге
//Если другой, то все.
//Выводятся с индекса 0.
function GetIncV(ver:tv; flag: integer = 0): tstrings;
procedure delete; overload;
//процедурa возвращает степень вершины
//Если флаг 1, то считаются только исходящие дуги
//Если -1, - только входящие дуги
//Если другой, то все.
function DegV(ver: TV; flag: integer=0): integer;
//процедурa возвращает номер вершины в графе если 0 то нет
function Num(ver: TV): integer; overLoad;
//процедурa возвращает номер ребра в графе если 0 то нет
function Num(reb: TR): integer; OverLoad;
//Добавить к графу ребро
function Add(reb: TR): boolean; overload;
//Добавить к графу вершину
function Add(ver: TV):boolean; overload;
function Svyaz:boolean;//Тру если связан
//Поиск смежных вершин с возвратом их в массиве
//Если флаг 1, то ищутся только вершины, смежные по исходящей дуге
//Если -1, то то ищутся только вершины, смежные по входящей дуге
//Если другой, то все.
//Выводятся с индекса 1.
function GetIncV2(ver:tv; flag: integer = 0): Tarrv;
//процедурa возвращает массив инцидентных ребер
//Если флаг 1, то ищутся только дуги, исх из ver
//Если -1, то то ищутся только дуги, вх из ver
//Если другой, то все.
//Выводятся с индекса 0.
function GetIncE2(ver:tv; flag: integer = 0): Tarre;
//Поиск матрицы достижимости (i-ая строка - достижимые вершины для i-ой вершины)
//Поиск матрицы достижимости (i-ая строка - достижимые вершины для i-ой вершины)
function SearchReachMatrix:tboolmatrix;
//True- Существует путь из S в F (для произв графа)
function IsPath(S,F:TV):boolean;
//rocedure FindConComponents(g:tgraph; lb:tstrings);
//procedure FindStronglyConComponents(g:tgraph; lb:tstrings);
//Поиск кротчайщего пути и его длины по алгоритму Дейкстры
//S-начало пути,F-конец
//Возвращает 1 в случае успеха, -1 - граф не взвешен или не ориент, или не связан
//-2 - не существует пути
function SearchMinPath(var G:tgraph;S,F:tv;var LengthMinPath:integer):shortint;
//Поиск максимального потока (заносится в поля ребер) и минимального разреза (заносятся
//Razr - ребра мин разреза
//s,t - источник и сток
//MaxStream - величина макс потока
//Возвращает 1 в случае успеха
//-1 если граф не является сетью
//-2 если нет пути из s в t
function SearchMaxStreamAndRazrez(var Razr:tgraph;s,t:tv;var MaxStream:integer):shortint;
//Раскраскра графа эвристическим алгоритмом (не всегда является оптимальной)
//ChromaticNumber - хроматическое число
//Возвращает 1 в случае успеха
//-1 - если граф ориентированный
function Coloring(var ChromaticNumber:integer):shortint;
//Сохранить граф в файл. Filename - имя файла. G - подграф
procedure SaveImage(filename: string; g: tgraph = nil);
//Создать из текстового файла с матрицей инциденции
constructor CreatewithInc(filename: string);
//Создать из текстового файла с матрицей смежности
constructor CreatewithSm(filename: string);
private
{Описанные в этой секции элементы не доступны извне (за пределами класса, но доступны в пределах модуля).}
{Здесь обычно находятся поля класса.}
protected
{Описанные в этой секции элементы доступны только классу и всем его потомкам.}
published
{Описанные в этой секции элементы доступны всем и отображаются в Object Inspector'e.}
end;
procedure drawstr(Canv: tcanvas; xt1, yt1, xt2, yt2: real; tru: boolean; rad: integer);
{function unscalex(x: real; arrcol: colorarray): integer;
function scalex(x: real; arrcol: colorarray): integer;
function unscaley(y: real; arrcol: colorarray): integer;
function scaley(y: real; arrcol: colorarray): integer;
}
type TArrG = array of ^TGraph;
var g: TGraph;
implementation
uses windows, math, IniFiles, sysutils, ufund, uostov, jpeg;
procedure ProcessMessages; //ПРоцедура от зависания. Вставлять в большие циклы и рекурсии
var
Msg: TMsg;
begin
while true do
begin
if not PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then Break;
if Msg.Message <> 18 then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
end;
constructor TGraph.Create;
begin
if self <> nil then begin
delete;
col:=G_arrcol;
setlength(v,1);
setlength(e, 1);
new(E[0]);
E[0]^:=TRC.Create;
e[0].p1:=nil;
new(v[0]);
v[0]^:=TVc.Create;
service:=0;
end else
self:=Tgraph.Create;
end;
function TGraph.delete(Ver: TV): boolean;
var
i: integer;
ts: tstrings;
begin
result:=false;
if Existv(ver) then begin
ts:=GetIncE(ver);
for i := 0 to ts.Count-1 do
delete(tR(ts.Objects[i]));
ts.Free;
for i := Num(ver)+1 to high(V) do
V[i - 1]:=V[i];
setlength(v, length(v) - 1);
//creatematrix;
result:=true;
end;
end;
function TGraph.delete(Reb: TR): boolean;
var
i: integer;
begin
result:=false;
if ExistE(reb) then begin
for i := num(reb) + 1 to high(e) do
e[i - 1]:=e[i];
setlength(e, length(e) - 1);
result:=true;
//creatematrix;
end;
end;
function TGraph.Create(x, y: integer): TV;
begin
setlength(v, length(v) + 1);
new(v[high(v)]);//:=tv.Create;
v[high(v)]^:=tvC.Create;
v[high(v)].x := x;
v[high(v)].y := y;
v[high(v)].move:=false;
v[high(v)].status := col^.colorV;
v[high(v)].color:=clWhite;
result := v[high(v)];
//creatematrix;
end;
function TGraph.Create(p1, p2: TV): TR;
begin
result:=nil;
if (p1<>p2) and (GetE(p1, p2) = nil) then begin
setlength(E, length(E) + 1);
new(E[high(E)]);
E[high(E)]^:=TRc.Create;
E[high(E)].p1:=p1;
E[high(E)].p2:=p2;
E[high(E)].ves:=0;
E[high(e)].status:=col^.colore;
result := E[high(E)];
//creatematrix;
end;
end;
function TGraph.GetE(p1, p2: TV):tr;
var i: integer;
begin
Result:=nil;
if Orgraph then begin
for i := 1 to High(e) do
if (e[i].p1 = p1) and (e[i].p2 = p2) then begin
result:=e[i];
break;
end
end else begin
for i := 1 to High(e) do
if ((e[i].p1 = p1) and (e[i].p2 = p2)) or ((e[i].p1 = p2) and (e[i].p2 = p1))then begin
result:=e[i];
break;
end;
end
end;
function TGraph.GetVChoord(x, y: integer): TV;
var i: integer;
begin
result:=nil;
for i := 1 to High(V) do
if sqr(v[i].x - x) +sqr(v[i].y - Y)< sqr(col.rad) then begin
result:=v[i];
break;
end
end;
function TGraph.GetEChoord(x, y: integer): TR;
var i: integer;
q:real;
RE: tr;
begin
result:=nil;
for i := 1 to High(e) do begin
if E[i].p1.x <> E[i].p2.x then begin
re:=GetE(e[i].p2, e[i].p1) ;
if re = nil then begin
q := (E[i].p2.y - E[i].p1.y) /(E[i].p2.x - E[i].p1.x) * (x - E[i].p1.x)+ E[i].p1.y;
if ((x >= min(E[i].p1.x, E[i].p2.x) - col^.delta) and
(x <= max(E[i].p1.x, E[i].p2.x) + col^.delta) and
(y >= q - col^.delta) and
(y <= q+ col^.delta)) then begin
result:= e[i];
break;
end;
end else begin
if ((x >= min(E[i].p1.x, E[i].p2.x) - col^.delta) and (x <= (max(E[i].p1.x, E[i].p2.x)+ min(E[i].p1.x, E[i].p2.x))/2 + col^.delta)) then begin
q := (E[i].p2.y - E[i].p1.y) /(E[i].p2.x - E[i].p1.x) * (x - E[i].p1.x)+ E[i].p1.y;
if ((y >= q - col^.delta) and(y <= q+ col^.delta)) then begin
result:= re;
break;
end;
end else if ((x <= mAx(E[i].p1.x, E[i].p2.x) + col^.delta) and (x >= (max(E[i].p1.x, E[i].p2.x)+ min(E[i].p1.x, E[i].p2.x))/2 + col^.delta)) then begin
q := (E[i].p2.y - E[i].p1.y) /(E[i].p2.x - E[i].p1.x) * (x - E[i].p1.x)+ E[i].p1.y;
if ((y >= q - col^.delta) and(y <= q+ col^.delta)) then begin
result:= e[i];
break;
end;
end;
end;
end else begin
re:=GetE(e[i].p2, e[i].p1) ;
if re = nil then begin
if ((x >= E[i].p1.x - col^.delta) and
(x <= E[i].p1.x+col^.delta) and
(y >= min(E[i].p1.y, E[i].p2.y) - col^.delta) and
(y <= max(E[i].p1.y, E[i].p2.Y)+ col^.delta)) then begin
result := e[i];
break;
end;
end else begin
if ((x >= E[i].p1.x - col^.delta) and (x <= E[i].p1.x+col^.delta)) then
if((y >= (min(E[i].p1.y, E[i].p2.y)+max(E[i].p1.y, E[i].p2.Y))/2 - col^.delta) and
(y <= max(E[i].p1.y, E[i].p2.Y)+ col^.delta)) then begin
result :=re;
break;
end else if((y <= (min(E[i].p1.y, E[i].p2.y)+max(E[i].p1.y, E[i].p2.Y))/2 - col^.delta) and
(y >= min(E[i].p1.y, E[i].p2.Y)+ col^.delta)) then begin
result := e[i];
break;
end;
end;
end;
end;
end;
function TGraph.Odnorod: boolean;
var i: integer;
begin
result:=true;
if Orgraph then begin
if high(V) > 1 then begin
for i := 2 to high(V) do
if DegV(V[i], 1) <> degv(V[1], 1) then begin
result:=false;
break;
end;
end;
end else begin
if high(V) > 1 then begin
for i := 2 to high(V) do
if DegV(V[i]) <> degv(V[1]) then begin
result:=false;
break;
end;
end;
end;
end;
function TGraph.klika: boolean;
begin
if Orgraph then begin
if odnorod then begin
if high(v)>1 then
if DegV(v[1], 1) = high(v)-1 then
result:=true
else
result:=false
else
result:=true;
end else
result:=false;
end else begin
if odnorod then begin
if high(v)>1 then
if DegV(v[1]) = high(v)-1 then
result:=true
else
result:=false
else
result:=true;
end else
result:=false;
end;
end;
constructor TGraph.Create(num: integer);
var i, j: integer;
begin
create;
try
for i := 1 to num do begin
Create(round(cos(2*PI*i/num)*100+150), round(sin(2*PI*i/num)*100+150));
for j := 1 to i-1 do
create(V[i], V[j]);
end;
except
end;
comment:='Клика '+ inttostr(num);
end;
constructor TGraph.Create(filename: string);
var graphfile: TIniFile;
hgv, hge, i: integer;
ves: integer;
ver: tv;
tv: tr;
begin
Create;
try
graphfile:=tinifile.Create(FileName);
hgv:= graphfile.readInteger('graph', 'Vount', -1);
hge:= graphfile.ReadInteger('graph', 'Eount', -1);
Orgraph:=graphfile.readbool('graph', 'Orgraph', false);
vzves:=graphfile.readbool('graph', 'Vzves', false);
web:=graphfile.readbool('graph', 'Web', false);
comment:=graphfile.readString('graph', 'Comment', '');
for i := 1 to hgv do begin
Create(graphfile.readinteger('V'+inttostr(i), 'X', 0), graphfile.readInteger('V'+inttostr(i), 'y', 0)).color:=clwhite;
end;
for i := 1 to hge do begin
tv:= create(V[graphfile.readInteger('E'+inttostr(i), 'P1', -1)],V[graphfile.readInteger('E'+inttostr(i), 'P2', -1)]);
ves:=graphfile.readInteger('E'+inttostr(i), 'Ves', 0);
E[i].potok:= graphfile.readInteger('E'+inttostr(i), 'Potok', 0);
tv^.ves:=ves;
end;
graphfile.Free;
except
end;
end;
procedure TGraph.CheckGraph;
var i, j: integer;
begin
if not Orgraph then begin
i:=1;
while i <= high(e) do
if (e[i].p1 = nil) or (e[i].p2 = nil) then
delete(e[i])
else begin
j:=1;
while j < i do
if ((e[j].p1 = E[i].p1) and (e[j].p2 = E[i].p2)) or ((e[j].p1 = E[i].p2) and (e[j].p2 = E[i].p1)) then begin
delete(E[i]);
break;
end else
j:=j+1;
if j = i then
inc(i);
end
end else
//createMatrix;
end;
procedure TGraph.GetMatrixSm(var PmatrixSm:tmatrix);
var i, j, k: integer;
//MatrixSm: TMatrixC;
begin
//MatrixSm.Free;
new(PmatrixSm);
pmatrixsm^:=TMatrixC.create(high(V), high(V));
for i := 1 to high(v) do
for j := 1 to high(V) do
pmatrixsm.Matrix[i, j]:=0;
if Orgraph then
for i := 1 to high(E) do begin
j:=1;
k:=1;
while j<=high(V) do
if V[j] = E[i].p1 then break
else j:=j+1;
while k<=high(V) do
if V[k] = E[i].p2 then break
else k:=k+1;
pmatrixsm.Matrix[j, k]:=1;
end
else
for i := 1 to high(E) do begin
j:=1;
k:=1;
while j<=high(V) do
if V[j] = E[i].p1 then break
else j:=j+1;
while k<=high(V) do
if V[k] = E[i].p2 then break
else k:=k+1;
if (j <= high(v))and (K <= high(v)) then begin
pmatrixsm.Matrix[j, k]:=1;
pmatrixsm.Matrix[k, j]:=1;
end;
end;
//n:=high(v);
// m:=high(v);
//PmatrixSm:=addr(pmatrixsm);
end;
procedure TGraph.GetMatrixInc(var PmatrixInc:tmatrix);
var i, j, k: integer;
//MatrixInc: TMatrixC;
begin
//pMatrixinc.Fre
new(PmatrixInc);
pMatrixinc^:=TMatrixC.create(length(V),length(e));
for i := 1 to high(v) do
for j := 1 to high(e) do
pMatrixinc.Matrix[i, j]:=0;
if Orgraph then
for i := 1 to high(E) do begin
j:=1;
k:=1;
while j<=high(V) do
if V[j] = E[i].p1 then break
else j:=j+1;
while k<=high(V) do
if V[k] = E[i].p2 then break
else k:=k+1;
pMatrixinc.Matrix[j,i]:=1;
pMatrixinc.Matrix[k,i]:=-1;
end
else
for i := 1 to high(E) do begin
j:=1;
k:=1;
while j<=high(V) do
if V[j] = E[i].p1 then break
else j:=j+1;
while k<=high(V) do
if V[k] = E[i].p2 then break
else k:=k+1;
pMatrixinc.Matrix[k,i]:=1;
pMatrixinc.Matrix[j,i]:=1;
end;
{ n:=high(v);
m:=high(e);
PmatrixInc:=addr(MatrixInc); }
end;
procedure TGraph.Draw(Canv: tcanvas; small: boolean = false);
var
i: integer;
num:string;
numi: integer;
begin
//Canv.Lock;
if not small then begin
canv.Pen.Width:=1;
Canv.Refresh;
Canv.Pen.Color := col^.Rect;
Canv.Rectangle(0, 0, col^.he, col^.wi);
end;
{ -------Отрисовка вершин ------- }
if col^.ShowNameV then
for i := 1 to high(V) do begin
if small then begin
canv.Pen.Color:=col^.selV;
canv.Pen.Width:=2;
end else begin
Canv.Pen.Color := V[i].status;
canv.Pen.Width:=1;
end;
if V[i].status= col^.movev then V[i].status:= (col^.colorV);
numi:=g.Num(v[i]);
if numi <> 0 then
Canv.brush.Color := g.V[numi].color
else begin
Canv.brush.Color := v[i].color;
numi:=i;
end;
num:=inttostr(numi);
Canv.Ellipse(V[i].x - col^.rad, V[i].y - col^.rad,
V[i].x + col^.rad,V[i].y + col^.rad);
Canv.Brush.color := clwhite;
Canv.font.Color := clblack;
canv.Font.Height:=col^.sizefont;
Canv.Brush.Style := bsClear;
Canv.TextOut(V[i].x - round(Canv.TextWidth(num)/2), V[i].y -round(canv.TextHeight(num)/2), num);
Canv.Brush.Style := bsSolid;
end
else
for i := 1 to high(V) do
begin
if small then begin
canv.Pen.Color:=col^.selV;
canv.Pen.Width:=2;
end else begin
Canv.Pen.Color := V[i].status;
canv.Pen.Width:=1;
end;
Canv.brush.Color := g.V[g.Num(V[i])].color;
Canv.Ellipse(V[i].x - col^.rad, V[i].y - col^.rad,V[i].x + col^.rad,V[i].y + col^.rad);
Canv.Brush.color := clwhite;
end;
{ ------------Отрисовка ребер--------- }
for i := 1 to high(e) do
begin
if small then begin
canv.Pen.Color:=col^.sele;
canv.Pen.Width:=2;
end else begin
Canv.Pen.Color := e[i].status;
canv.Pen.Width:=1;
end;
if E[i].status= col^.mEvee then E[i].status:= col^.colorE;
drawstr(Canv, e[i].p1.x,e[i].p1.y,e[i].p2.x,e[i].p2.y, Orgraph or Web,
round(col^.rad*col^.scale/100)
);
end;
if web then
for i := 1 to high(e) do begin
if e[i].potok > 0 then
canv.textout(round((E[I].p1.x+E[i].p2.x)/2),round((E[I].p1.y+E[i].p2.y)/2), inttostr(e[i].potok)+' ['+inttostr(E[i].ves)+']')
else
canv.textout(round((E[I].p1.x+E[i].p2.x)/2),round((E[I].p1.y+E[i].p2.y)/2),'['+inttostr(E[i].ves)+']')
end
else
if col^.ShownameE then begin
if col^.ShowVes and Vzves then
for i := 1 to high(e) do begin
numi:=g.Num(e[i]);
if numi = 0 then
numi:=i;
num:=inttostr(numi);
canv.textout(round((E[I].p1.x+E[i].p2.x)/2),round((E[I].p1.y+E[i].p2.y)/2), 'e'+num+' ('+inttostr(E[i].ves)+')')
end
else
for i := 1 to high(e) do begin
numi:=g.Num(e[i]);
if numi = 0 then
numi:=i;
num:=inttostr(numi);
canv.textout(round((E[I].p1.x+E[i].p2.x)/2), round((E[I].p1.y+E[i].p2.y)/2), 'e'+num)
end
end else
if col^.ShowVes and Vzves then
for i := 1 to high(e) do
canv.textout(Round((E[I].p1.x+E[i].p2.x)/2), Round( (E[I].p1.y+E[i].p2.y)/2), '('+inttostr(E[i].ves)+')');
{------------Отрисовка ребер--------- }
// Canv.unLock;
end;
procedure drawstr(Canv: tcanvas; xt1, yt1, xt2, yt2: real; tru: boolean;
rad: integer);
var
X1, x2, y1, y2: real;
x3, x4, y3, y4: real;
x5, y5, ox, oy: real;
begin
if not((xt1=xt2) and (yt1 = yt2)) then begin
X1 := rad * (xt2 - xt1) / sqrt(sqr(xt1 - xt2) + sqr(yt1 - yt2)) + xt1;
y1 := rad * (yt2 - yt1) / sqrt(sqr(xt1 - xt2) + sqr(yt1 - yt2)) + yt1;
x2 := rad * (xt1 - xt2) / sqrt(sqr(xt1 - xt2) + sqr(yt1 - yt2)) + xt2;
y2 := rad * (yt1 - yt2) / sqrt(sqr(xt1 - xt2) + sqr(yt1 - yt2)) + yt2;
if (X1 <> x2) or (y1 <> y2) then
begin
x5 := abs(((x2 - X1) * rad / sqrt(sqr(x2 - X1) + sqr(y2 - y1))) - x2);
y5 := abs(((y2 - y1) * rad / sqrt(sqr(x2 - X1) + sqr(y2 - y1))) - y2);
ox := (x2 - (x2 - x5));
oy := (y2 - (y2 - y5));
x3 := (ox - (y2 - y5) / 5);
y3 := (oy + (x2 - x5) / 5);
x4 := (ox + (y2 - y5) / 5);
y4 := (oy - (x2 - x5) / 5);
// Canv.Pen.Width := 1;
// canv.Pen.Style:=psSolid;
with Canv do
begin
moveto(round(X1), round(y1));
LineTo(round(x2), round(y2));
if tru then
begin
Canv.Pen.Width:=Canv.Pen.Width+1;
LineTo(round(x3), round(y3));
moveto(round(x2), round(y2));
LineTo(round(x4), round(y4));
Canv.Pen.Width:=Canv.Pen.Width-1;
end;
end;
end;
end;
end;
constructor TGraph.assign(g: tgraph);
var i: integer;
begin
create;
setlength(v, length(g.V));
for i := 0 to high(g.V) do begin
v[i]:=g.V[i];
end;
setlength(E, length(g.e));
for i := 0 to high(g.E) do begin
E[i]:=g.E[i];
end;
Orgraph:=g.Orgraph;
Vzves:=g.Vzves;
comment:=g.comment;
service:=g.service;
//createMatrix;
end;
procedure TGraph.SaveTofile(filename: string);
var graphfile: Tinifile;
i: integer;
begin
graphfile:=tinifile.Create(FileName);
graphfile.WriteInteger('graph', 'Vount', high(V));
graphfile.WriteInteger('graph', 'Eount', high(E));
graphfile.writebool('graph', 'Orgraph', Orgraph);
graphfile.writebool('graph', 'Vzves', vzves);
graphfile.writebool('graph', 'Web', Web);
graphfile.WriteString('graph', 'Comment', comment);
for i := 1 to high(V) do begin
graphfile.WriteInteger('V'+inttostr(i), 'X', V[i].x);
graphfile.WriteInteger('V'+inttostr(i), 'y', V[i].Y);
// graphfile.WriteString('V'+inttostr(i), 'Comment', V[i]^.comment);
end;
for i := 1 to high(e) do begin
graphfile.WriteInteger('E'+inttostr(i), 'P1', Num(e[i].p1));
graphfile.WriteInteger('E'+inttostr(i), 'P2', num(e[i].p2));
graphfile.WriteInteger('E'+inttostr(i), 'Ves', E[i].ves);
graphfile.WriteInteger('E'+inttostr(i), 'Potok', E[i].potok);
end;
graphfile.Free;
end;
function TGraph.ExistV(ver: TV): boolean;
var i: integer;
begin
result:=false;
for i := 1 to high(v) do
if v[i] = ver then begin
result:=true;
break;
end;
end;
function TGraph.ExistE(reb: Tr): boolean;
var i: integer;
begin
result:=false;
for i := 1 to high(e) do
if e[i] = reb then begin
result:=true;
break;
end;
end;
procedure TGraph.Delete;
var i: integer;
begin
try
for i := 1 to high(v) do
v[i]^.Free;
for i := 1 to high(e) do
E[i]^.Free;
setlength(v, 1);
setlength(e, 1);
except
end;
end;
function TGraph.GetIncE(ver:tv; flag: integer = 0): tstrings;
var i: integer;
TS: tstrings;
begin
ts:=TStringList.Create;
ts.Clear;
case flag of
1:for i := 1 to high(e) do
if e[i].p1 = ver then
ts.addobject('', tobject(e[i]));
-1:for i := 1 to high(e) do
if e[i].p2 = ver then
ts.addobject('', tobject(e[i]));
else
for i := 1 to high(e) do
if (e[i].p1 = ver) or (e[i].p2 = ver) then
ts.addobject('', tobject(e[i]));
end;
result:=ts;
end;
function TGraph.GetIncV(ver:tv; flag: integer = 0): tstrings;
var i: integer;
TS: tstrings;
begin
ts:=TStringList.Create;
ts.Clear;
case flag of
1:for i := 1 to high(e) do
if e[i].p1 = ver then
ts.addobject('', tobject(e[i].p2));
-1:for i := 1 to high(e) do
if e[i].p2 = ver then
ts.addobject('', tobject(e[i].p1));
else
for i := 1 to high(e) do
if (e[i].p1 = ver) then
ts.addobject('', tobject(e[i].p2))
else if (e[i].p2 = ver) then
ts.addobject('', tobject(e[i].p1))
end;
result:=ts;
end;
function TGraph.DegV(ver: TV; flag: integer=0): integer;
var i: integer;
begin
result:=0;
case flag of
1: for i := 1 to high(e) do
if e[i].p1 = ver then
inc(result);
-1: for i := 1 to high(e) do
if (e[i].p2=ver) then
inc(result);
else
for i := 1 to high(e) do
if (e[i].p1=ver) or ( e[i].p2=ver) then
inc(result);
end;
end;
function TGraph.Num(reb: TR): integer;
var i: integer;
begin
result:=0;
for i := 1 to high(e) do
if reb = e[i] then begin
result:=i;
break;
end;
end;
function TGraph.Num(ver: TV): integer;
var i: integer;
begin
result:=0;
for i := 1 to high(V) do
if ver = V[i] then begin
result:=i;
break;
end;
end;
function TGraph.Add(reb: TR): boolean;
begin
result:=false;
if (reb <> nil ) and not ExistE(reb) then begin
setlength(e, length(e)+1);
e[high(e)]:=reb;
result:=true;
end;
end;
function TGraph.Add(ver: TV): boolean;
begin
result:=false;
if not ExistV(ver) then begin
result:=true;
setlength(v, length(v)+1);
v[high(v)]:=ver;
end;
end;
function TGraph.Svyaz:boolean;
begin
//if length(TSsvyaz)=1 then
result:=true
//else
//result:=false;
end;
function TGraph.GetIncV2(ver:tv; flag: integer = 0): Tarrv;
var i: integer;
adj:Tarrv;
begin
SetLength(adj,1);
case flag of
1:for i := 1 to high(e) do
if e[i].p1 = ver then
begin
SetLength(adj,length(adj)+1);
adj[high(adj)]:=e[i].p2;
end;
-1:for i := 1 to high(e) do
if e[i].p2 = ver then
begin
SetLength(adj,length(adj)+1);
adj[high(adj)]:=e[i].p1;
end;
else
for i := 1 to high(e) do
if (e[i].p1 = ver) then
begin
SetLength(adj,length(adj)+1);
adj[high(adj)]:=e[i].p2;
end
else if (e[i].p2 = ver) then
begin
SetLength(adj,length(adj)+1);
adj[high(adj)]:=e[i].p1;
end;
end;
result:=adj;
//SetLength(adj,0);
//adj:=nil;
end;
function TGraph.GetIncE2(ver:tv; flag: integer = 0): Tarre;
var i: integer;
Adj:tarre;
begin
SetLength(adj,1);
//ts:=TStringList.Create;
//ts.Clear;
case flag of
1:for i := 1 to high(e) do
if e[i].p1 = ver then
begin
SetLength(adj,length(adj)+1);
adj[high(adj)]:=e[i];
end;
//ts.addobject('', tobject(e[i]));
-1:for i := 1 to high(e) do
if e[i].p2 = ver then
begin
SetLength(adj,length(adj)+1);
adj[high(adj)]:=e[i];
end;
else
for i := 1 to high(e) do
if (e[i].p1 = ver) or (e[i].p2 = ver) then
begin
SetLength(adj,length(adj)+1);
adj[high(adj)]:=e[i];
end;
end;
result:=adj;
end;
function TGraph.SearchMinPath(var G:tgraph;S,F:tv;var LengthMinPath:integer):shortint;
const contin = 100000;//этим значением инициализируются метки Labels (типа бескон-ть), изменить, если будут отрицат веса
type TLabels = record
L: integer;
ConstL: boolean; //true -если метка постоянная(L-точное значение длины мин пути из S в V)
//false- L -временных метка для вершины(верхняя оценка длины мин пути из S в V)
end;
var
Labels:array of tlabels;
i,j:integer;
ver:tv;//текущая вершина
minl:integer;//значение мин labels
Indmin:integer;//номер вершины,c labels=minl
begin
if not (Vzves and Orgraph and Svyaz) then
begin
result:=-1;
exit;
end;
if IsPath(s,f)=false then
begin
result:=-2;
exit;
end;
//поиск меток и длины пути
SetLength(Labels,Length(v));
for i := 1 to high(V) do
begin
Labels[i].l:=contin;
Labels[i].ConstL:=false;
end;
Labels[Num(s)].l:=0;
Labels[Num(s)].ConstL:=true;
ver:=s;
//с исполь GetIncV
{repeat
Indmin:=1;
minl:=Labels[num(tv(GetIncV(ver,1).objects[1]))];
for j := 1 to DegV(ver) do
begin
tempLabels[num(tv(GetIncV(ver,1).objects[j]))] := min(tempLabels[num(tv(GetIncV(ver,1).objects[j]))],templabels[num(ver)]+GetE(ver,tv(GetIncV(ver,1).objects[j])).ves);
if tempLabels[num(tv(GetIncV(ver,1).objects[j]))]<minl then
begin
Indmin:=j;
minl:=tempLabels[num(tv(GetIncV(ver,1).objects[j]))];
end;
end;
ver:=tv(GetIncV(ver,1).objects[indmin]);
Labels[num(ver)]:=TempLabels[num(ver)];
until Labels[Num(f)]<>0; }
repeat
for j := 1 to DegV(ver,1) do
begin
//ShowMessage(inttostr(tempLabels[num(GetIncV2(ver,1)[j])]));
//ShowMessage(inttostr(templabels[num(ver)]{+GetE(ver,GetIncV2(ver,1)[j]).ves}));
if labels[num(GetIncV2(ver,1)[j])].ConstL=false then
Labels[num(GetIncV2(ver,1)[j])].l := min(Labels[num(GetIncV2(ver,1)[j])].l,labels[num(ver)].l+GetE(ver,GetIncV2(ver,1)[j]).ves);
end;
Indmin:=1;
minl:=contin;
for j := 1 to high(labels) do
if (Labels[j].l<minl) and (Labels[j].ConstL=false) then
begin
Indmin:=j;
minl:=Labels[j].l;
end;
ver:=v[indmin];
Labels[num(ver)].ConstL:=true;
until Labels[Num(f)].ConstL;
LengthMinPath := Labels[Num(f)].L;
//поиск маршрута
ver:=f;
g:=tgraph.create;
SetLength(g.V,2);
SetLength(g.E,1);
g.V[1]:=f;
repeat
i:=1;
repeat
//for i := 1 to degv(ver,-1) do
if Labels[num(ver)].L=labels[num(GetIncV2(ver,-1)[i])].L+gete(GetIncV2(ver,-1)[i],ver).ves then
begin
SetLength(g.V,length(g.V)+1);
g.V[high(g.V)]:=GetIncV2(ver,-1)[i];
SetLength(g.e,length(g.e)+1);
g.e[high(g.e)]:=gete(GetIncV2(ver,-1)[i],ver);
ver:=GetIncV2(ver,-1)[i];
break;
end;
//ShowMessage(inttostr(degv(ver,-1)));
inc(i);
until i=DegV(ver,-1)+1;
until ver=s;
SetLength(Labels,0);
Labels:=nil;
result:=1;
end;
function Tgraph.SearchReachMatrix:tboolmatrix;
var R:TBoolMatrix;
i,j:integer;
MatrixSm:tmatrix;
//m,n:integer;//размеры м-цы смежности
//процедура добавления вершин в R,достижимых из данной
//x-номер текущей вершины,count-номер строки в R
Procedure Component( x,count :Integer);
var
i :Integer;
begin
R[count][x]:= 1;
for i:=1 to high(V) do
//если вершина смежна с текущей и это не петля
if (MatrixSm.Matrix[x,i] = 1) and (x<>i) then
begin
//если ее не обходили
if R[count,i] = 0 then
Component(i,count);
end;
end;
begin
//new(matrixsm);
GetMatrixSm(MatrixSm);
//new(matrixsm);
//MatrixSm.create(m,n);
//showmessage(inttostr(MatrixSm.Matrix[0,0]));
SetLength(R,high(V)+1,high(V)+1);
//showmessage(inttostr(MatrixSm.Matrix[0,0]));
for i := 1 to high(V) do
for j := 1 to high(V) do
R[i,j]:=0;
for i := 1 to high(V) do
Component(i,i);
result:=r;
setlength(MatrixSm.Matrix,0,0);
matrixsm:=nil;
SetLength(R,0,0);
R:=nil;
end;
function Tgraph.IsPath(S,F:TV):boolean;
begin
if SearchReachMatrix[num(s),num(f)]=1 then
result:=true
else
result:=false;
end;
constructor TGraph.Invert(G: tgraph);
var i, j: integer;
begin
create;
Orgraph:=false;
setlength(v, length(g.v));
for i := 1 to high(g.V) do begin
v[i]:=g.V[i];
for j := 1 to i-1 do
if (g.GetE(g.V[i], g.V[j]) = nil) then
Create(g.V[j], g.V[i]);
end;
end;
function Tgraph.SearchMaxStreamAndRazrez(var Razr:tgraph;s,t:tv;var MaxStream:integer):shortint;
type TP = record
ist:integer; //вершнина из которой идет поток
stream:integer;//поток, к-ый можно передать по этой дуге (из ist в текущ)
end;
var LG:boolean;
p:array of TP;//массив меток
i,j:integer;
c:array of array of integer;//матрица пропускных способностей
F:array of array of integer;//матрица потоков
//расстановка меток
procedure Mark;
var M: array of boolean; //непросмотренные вершины
L,i:integer;
begin
SetLength(m,length(g.V));
for i := 1 to high(m) do
m[i]:=true;
p[num(s)].ist:=num(s);
p[num(s)].stream:=MaxInt;
L:=num(s);
while (p[num(t)].ist=0) and lg do
begin
for i := 1 to high(g.V) do //поиск непомеченной вершины
if (p[i].ist=0) and ((c[L,i]<>0) or (c[i,l]<>0)) then
if f[L,i]<c[L,i] then //если дуга прямая
begin
p[i].ist:=L;
if p[L].stream<c[L,i]-F[l,i] then
p[i].stream:=p[L].stream
else
p[i].stream:=c[L,i]-F[L,i];
end
else //если дуга обратная
if f[i,L]>0 then
begin
p[i].ist:=-L;
if p[l].stream<F[i,L] then
p[i].stream:=p[L].stream
else
p[i].stream:=F[i,L];
end;
m[L] := false; //вершина L просмотрена
L := 1;
//ищем помеченную и непросмотренную вершину
repeat
inc(L);
until (L>high(G.V)) or ((p[L].ist<>0) and (m[L] = true));
if L>high(g.V) then
lg := false;
end;
end;
//изменение потока по дугам найденной цепочки
Procedure Stream(q:integer);
begin
//определяем прямая ли дуга (-номер вершины - обратная)
if p[q].ist>0 then
F[p[q].ist,q]:=f[p[q].ist,q]+p[num(t)].stream
else
F[q,abs(p[q].ist)]:=F[q,abs(p[q].ist)]-p[num(t)].stream;
if abs(p[q].ist)<>num(s) then //если не источник то идем к предыд вершине цепочки
begin
q := abs(p[q].ist);
stream(q);
end;
end;
begin
//исключения
if not web then
begin
result:=-1;
exit;
end;
if IsPath(s,t)=false then
begin
result:=-2;
exit;
end;
setlength(p,length(g.V));
SetLength(c,length(g.V),length(g.V));
SetLength(f,length(g.V),length(g.V));
for i := 1 to high(g.V) do
for j := 1 to high(g.V) do
if gete(g.V[i],g.V[j])<>nil then
c[i,j]:=gete(g.V[i],g.V[j]).ves
else
c[i,j]:=0;
{for i := 1 to high(g.E) do
g.E[i].potok:=0; }
lg:=true;
while lg do
begin
for i := 1 to high(p) do
begin
p[i].ist:=0;
p[i].stream:=0;
end;
mark;
if lg then
stream(num(t));
end;
for i := 1 to high(g.v) do
for j := 1 to high(g.V) do
if GetE(g.V[i],g.V[j]) <> nil then
GetE(g.V[i],g.V[j]).potok:=f[i,j];
MaxStream:=0;
for i := 1 to high(GetIncE2(t,-1)) do
MaxStream:=MaxStream+GetIncE2(t,-1)[i].potok;
//поиск разрезов
razr:=tgraph.Create;
for i := 1 to high(g.e) do
if ((p[num(g.E[i].p1)].ist<>0) and (p[num(g.E[i].p2)].ist=0)) or ((p[num(g.E[i].p2)].ist<>0) and (p[num(g.E[i].p1)].ist=0)) then
razr.Add(g.E[i]);
SetLength(f,0,0);
SetLength(c,0,0);
SetLength(p,0);
f:=nil;
c:=nil;
p:=nil;
result:=1;
end;
function TGraph.Coloring(var ChromaticNumber: integer): shortint;
var MaxNezav:TArrG;
M: TBoolMatrix;//матрица максимально независимых множеств (столбец - макс незав мн-во, строка вершина)
NotCover : array of boolean;//массив непокрытых строк м-цы M (непокрашенных вершин)
CountNotCover:integer;//число непокрашенных вершин
i,j:integer;
NMax,max:integer;//номер незав мно-ва, покрывающего наиб число непокрашенных вершин и само это число
temp:integer;//сколько непокрытых вершин покрывает текущее незав мн-во
color:tcolor;
arrcolors: array of tcolor;
begin
if Orgraph then
begin
result := -1;
exit;
end;
randomize;
MaxNezav:=Nezav(g);
SetLength(m,length(g.V),length(MaxNezav));
SetLength(NotCover,length(g.V));
CountNotCover:=high(g.V);
Nmax:=1;
SetLength(arrcolors,1);
ChromaticNumber:=0;
for i := 1 to high(NotCover) do
NotCover[i]:=true;
for i := 1 to high(g.V) do
for j := 1 to high(MaxNezav) do
if MaxNezav[j].ExistV(g.V[i]) then
m[i,j]:=1;
while CountNotCover>0 do
begin
//поиск Max
max:=0;
for i := 1 to high(maxnezav) do
begin
temp:=0;
for j := 1 to high(NotCover) do
if (m[j,i] = 1) and (NotCover[j] = true) then
inc(temp);
if temp>max then
begin
max:=temp;
nmax:=i;
end;
end;
color:=rgb(random(256),random(256),random(256));
i:=1;
while i<=high(arrcolors) do
begin
if (abs(GetRValue(arrcolors[i]-color))<255/high(g.V)) or (abs(GetBValue(arrcolors[i]-color))<255/high(g.V)) or (abs(GetGValue(arrcolors[i]-color))<255/high(g.V)) then
begin
color:=rgb(random(256),random(256),random(256));
i:=0;
end;
inc(i);
end;
SetLength(arrcolors,length(arrcolors)+1);
arrcolors[high(arrcolors)]:=color;
//color:=rgb(random(round(255/high(g.V)))-ChromaticNumber*round(255/high(g.V)),255-random(round(255/high(g.V)))-ChromaticNumber*round(255/high(g.V)),255-random(round(255/high(g.V)))-ChromaticNumber*round(255/high(g.V)));
//showmessage(inttostr(255-random(round(255/high(g.V)))-ChromaticNumber*round(255/high(g.V))));
//color:=rgb(255-random(round(255/high(g.V)))+ChromaticNumber*10,255-random(round(255/high(g.V)))+ChromaticNumber*10,255-random(round(255/high(g.V)))+ChromaticNumber*10);
for i := 1 to high(g.V) do
if (MaxNezav[nmax].ExistV(g.V[i])) and (notcover[i]) then
begin
g.V[i].color:=color; //nmax;//??
NotCover[i] := false;
dec(CountNotCover);
end;
inc(ChromaticNumber);
end;
setlength(arrcolors,0);
arrcolors:=nil;
SetLength(NotCover,0);
NotCover:=nil;
SetLength(m,0,0);
m:=nil;
result:=1;
end;
//function TGraph.Coloring(var ChromaticNumber: integer): shortint;
//var MaxNezav:TArrG;
// M: TBoolMatrix;//матрица максимально независимых множеств (столбец - макс незав мн-во, строка вершина)
// NotCover : array of boolean;//массив непокрытых строк м-цы M (непокрашенных вершин)
// CountNotCover:integer;//число непокрашенных вершин
// i,j:integer;
// NMax,max:integer;//номер незав мно-ва, покрывающего наиб число непокрашенных вершин и само это число
// temp:integer;//сколько непокрытых вершин покрывает текущее незав мн-во
// color:tcolor;
// // flag:boolean; //покрасили ли на этом шаге вершину
//begin
//
//if Orgraph then
//begin
// result := -1;
// exit;
//end;
//randomize;
//MaxNezav:=Nezav(g);
//SetLength(m,length(g.V),length(MaxNezav));
//SetLength(NotCover,length(g.V));
//CountNotCover:=high(g.V);
//Nmax:=1;
////max:=0;
//ChromaticNumber:=0;
//for i := 1 to high(NotCover) do
// NotCover[i]:=true;
//
//for i := 1 to high(g.V) do
// for j := 1 to high(MaxNezav) do
// if MaxNezav[j].ExistV(g.V[i]) then
// m[i,j]:=1;
//
//
//while CountNotCover>0 do
//begin
// //поиск Max
// max:=0;
// for i := 1 to high(maxnezav) do
// begin
// temp:=0;
// for j := 1 to high(NotCover) do
// if (m[j,i] = 1) and (NotCover[j] = true) then
// inc(temp);
// if temp>max then
// begin
// max:=temp;
// nmax:=i;
// end;
// end;
// //flag:=false;
// color:=rgb(random(256),random(256),random(256));
// for i := 1 to high(g.V) do
// if (MaxNezav[nmax].ExistV(g.V[i])) and (notcover[i]) then
// begin
// //flag:=true;
// g.V[i].color:=color; //nmax;//??
// NotCover[i] := false;
// dec(CountNotCover);
// end;
// //if max>0 then
// inc(ChromaticNumber);
//
//
//end;
//
//SetLength(NotCover,0);
//NotCover:=nil;
//SetLength(m,0,0);
//m:=nil;
//result:=1;
//end;
procedure Tgraph.SaveImage(filename: string; g: tgraph = nil);
var canv:TPicture;
jpeg: TJPEGImage;
begin
jpeg:=TJPEGImage.Create;
canv:=TPicture.Create;
try
canv.Bitmap.Width:= col.wi;
canv.bitmap.Height:=col.he;
draw(canv.Bitmap.Canvas);
if g<> nil then g.draw(canv.Bitmap.Canvas, true);
jpeg.Assign(canv.Graphic);
jpeg.savetofile(FileName);
finally
canv.free;
jpeg.Free;
end;
end;
constructor TGraph.CreatewithInc(filename: string);
var graphfile: Text;
x, y,i, j, ves: integer;
arr: array of array of integer;
ver: TV;
begin
try
AssignFile(graphfile,filename);
reset(graphfile);
Read(graphfile, x, y);
setlength(arr, x+1, y+1);
for j := 1 to y do
for i := 1 to x do
Read(graphfile, arr[i][j]);
create;
for i := 1 to y do begin
Create(round(cos(2*PI*i/x)*100+150), round(sin(2*PI*i/x)*100+150));
end;
for i := 1 to x do begin
ves:=0;
for j := 1 to y do
if (arr[i][j]<> 0) then
if ves = 0 then
ves:=j
else begin
if (arr[i][ves] > 0) then
create(v[ves], v[j])
else
create(v[j], v[ves]);
break;
end;
end;
except
end;
end;
constructor TGraph.CreatewithSm(filename: string);
var graphfile: Text;
x,i, j, ves: integer;
arr: array of array of integer;
ver: TV;
begin
try
AssignFile(graphfile,filename);
reset(graphfile);
Read(graphfile, x);
setlength(arr, x+1, x+1);
for j := 1 to x do
for i := 1 to x do
Read(graphfile, arr[i][j]);
create;
for i := 1 to x do begin
Create(round(cos(2*PI*i/x)*100+150), round(sin(2*PI*i/x)*100+150));
end;
for i := 1 to x do begin
ves:=0;
for j := 1 to x do
if (i<>j) then
if (arr[i][j] = 1) then
create(v[i], v[j])
else if (arr[i][j] = 1) then
create(v[j], v[i])
end;
except
end;
end;
end.
Соседние файлы в папке Программа для построения и анализа графов