Добавил:
Опубликованный материал нарушает ваши авторские права? Сообщите нам.
Вуз: Предмет: Файл:
Скачиваний:
44
Добавлен:
02.05.2014
Размер:
21.35 Кб
Скачать
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, Buttons, XPMan, ComCtrls, ToolWin, Menus,
ImgList,Shellapi,Inifiles, Spin, ActnMan, ActnCtrls, ActnMenus,
CustomizeDlg, ActnColorMaps, XPStyleActnCtrls, ActnList;

type
TForm1 = class(TForm)
XPManifest1: TXPManifest;
StatusBar1: TStatusBar;
MainMenu1: TMainMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
N7: TMenuItem;
N8: TMenuItem;
N9: TMenuItem;
N10: TMenuItem;
ImageList1: TImageList;
N6: TMenuItem;
N11: TMenuItem;
SaveDialog1: TSaveDialog;
OpenDialog1: TOpenDialog;
N12: TMenuItem;
N13: TMenuItem;
N14: TMenuItem;
N15: TMenuItem;
N16: TMenuItem;
N17: TMenuItem;
N18: TMenuItem;
N19: TMenuItem;
PopupMenu1: TPopupMenu;
N20: TMenuItem;
N21: TMenuItem;
N22: TMenuItem;
N23: TMenuItem;
N24: TMenuItem;
N25: TMenuItem;
N26: TMenuItem;
ToolBar1: TToolBar;
BitBtn9: TBitBtn;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
BitBtn3: TBitBtn;
BitBtn4: TBitBtn;
BitBtn5: TBitBtn;
BitBtn6: TBitBtn;
Image1: TImage;
N27: TMenuItem;
N28: TMenuItem;
Memo1: TMemo;
Button1: TButton;
N29: TMenuItem;
N30: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn4Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure BitBtn6Click(Sender: TObject);
procedure SaveDialog1CanClose(Sender: TObject; var CanClose: Boolean);
procedure OpenDialog1CanClose(Sender: TObject; var CanClose: Boolean);
procedure N13Click(Sender: TObject);
procedure N14Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure N15Click(Sender: TObject);
procedure Image1Click(Sender: TObject);
procedure N17Click(Sender: TObject);
procedure N10Click(Sender: TObject);
procedure N26Click(Sender: TObject);
procedure BitBtn9Click(Sender: TObject);
procedure BitBtn3Click(Sender: TObject);
procedure FormShortCut(var Msg: TWMKey; var Handled: Boolean);
procedure N16Click(Sender: TObject);
procedure N28Click(Sender: TObject);
procedure N29Click(Sender: TObject);
procedure N30Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
protected
{ Protected declarations }
procedure WMDropFiles (var Msg: TMessage); message wm_DropFiles;
public
{ Public declarations }
end;
type
graf = record
x:integer;
y:integer;
end;
massiv = array[1..50,1..50] of integer;
const maxves = 1000;
var
Form1: TForm1;
flag:byte;{флаг операции}
Mx,My,n,i,j,v,vn,Rcount,countV:integer;
a:array[1..50] of graf;{массив с координатами вершин}
mv:array[1..50] of integer;
s,r:massiv;{матрица связанности}
F:file of integer;
MF:array[0..10] of string;//массив сообщений
FileName: array[0..256] of char;
Ini: Tinifile;
mPress:boolean;
{цвет}
fon_color, rebro_color, verhina_color, activ_color,text_color:integer;
mVes: boolean;
ves: integer;
mOrient: boolean;
t: tobject;
Vrazriv: integer;
Most: string;

implementation

uses Unit2, Unit3, Unit4, Unit5, Unit6, Unit7;



{$R *.dfm}
{--}



{--}
Function Mince(PathToMince: String; InSpace: Integer): String;
Var
sl: TStringList;
sHelp, sFile: String;
iPos: Integer;

Begin
sHelp := PathToMince;
iPos := Pos('\', sHelp);
If iPos = 0 Then
Begin
Result := PathToMince;
End
Else
Begin
sl := TStringList.Create;
While iPos <> 0 Do
Begin
sl.Add(Copy(sHelp, 1, (iPos - 1)));
sHelp := Copy(sHelp, (iPos + 1), Length(sHelp));
iPos := Pos('\', sHelp);
End;
If sHelp <> '' Then
Begin
sl.Add(sHelp);
End;
sFile := sl[sl.Count - 1];
sl.Delete(sl.Count - 1);
Result := '';
While (Length(Result + sFile) < InSpace) And (sl.Count <> 0) Do
Begin
Result := Result + sl[0] + '\';
sl.Delete(0);
End;
If sl.Count = 0 Then
Begin
Result := Result + sFile;
End
Else
Begin
Result := Result + '..\' + sFile;
End;
sl.Free;
End;
End;
{----------------------------------------------------}
{----------------------------------------------------}
{----------------------------------------------------}
{-------}
function svayz(mas:massiv;ver:integer):boolean;//проверка связанности
var mn,k,i,j:integer;
mv:array [1..50] of integer;

function proverka(vg:integer):boolean;//подфункция проверки вхождения в массив вершин
var i:integer;
begin
proverka:=false;
for i:=1 to mn do
if vg=mv[i] then
begin
proverka:=true;
break;
end;
end;

begin
if ver>1 then
begin
mn:=1;
k:=1;
mv[mn]:=1;
repeat
for j:=1 to ver do
if (mas[mv[k],j]<>maxves) and (proverka(j)=false) then
begin
mn:=mn+1;
mv[mn]:=j;
end;
k:=k+1;
until k>mn;
if mn<>ver then svayz:=false
else svayz:=true;
end
else svayz:=false;
end;

procedure delete( var mas:massiv; var ver:integer; v:integer ); //удаление вершины из массива
var i:integer;
begin
mas[v,ver]:=maxves;
for i:=1 to ver do
begin
mas[i,v]:=mas[i,ver];
mas[i,ver]:=maxves;
mas[v,i]:=mas[ver,i];
mas[ver,i]:=maxves;
end;
mas[v,v]:=maxves;
ver:=ver-1;
end;

function stepen(mas:massiv; ver,v:integer):integer;//считаем степень вершины
var count,i:integer;
begin
count:=0;
if (v<=ver) and (v>0) then
for i:=1 to ver do
if mas[v,i]<>maxves then count:=count+1;
stepen:=count;
end;

function maxstepen(mas:massiv;ver:integer):integer; //номер вершины с макс степенью
var max,i:integer;
begin
if (ver>1) and (stepen(mas,ver,1)>0) then
begin
max:=1;
for i:=2 to ver do
if stepen(mas,ver,max)<stepen(mas,ver,i) then
max:=i;
maxstepen:=max;
end
else maxstepen:=0;
end;

{-------}
function graf_sv(mas:massiv;ver:integer):integer;//вершинная связанность
var countS,i,j,max,verbuf:integer;
masbuf:massiv;
step:array[1..50] of integer;
begin
countS:=0;
if ver>1 then
begin
while (svayz(mas,ver)=true) do
begin
inc(countS);
masbuf:=mas;
verbuf:=ver;

for i:=1 to ver do
step[i]:=stepen(mas,ver,i);

for j:=1 to ver do
begin

max:=1;
for i:=1 to ver do
if step[i]>step[max] then max:=i;

delete(mas,ver,max);
if svayz(mas,ver)=false then break
else
begin
step[max]:=0;
mas:=masbuf;
ver:=verbuf;
end;
end;
if step[max]=0 then delete(mas,ver,maxstepen(mas,ver));
end;
end;
if countS=1 then Vrazriv:=max;
graf_sv:=countS;
end;


function graf_sr(mas:massiv; ver:integer):integer;
var countS,max,i,j,verbuf:integer;
masbuf:massiv;
begin
counts:=0;
if (ver>1) and (svayz(mas,ver)=true) then
begin
masbuf:=mas;
verbuf:=ver;
i:=1;
j:=1;
{----В поисках Моста-------}
while ((svayz(mas,ver) = true))and(i<=ver) do
begin
j:=1;
while ((svayz(mas,ver) = true))and(j<=ver) do
begin
mas:=masbuf;
ver:=verbuf;
mas[i,j]:=maxves;
mas[j,i]:=maxves;
inc(j);
end;
inc(i);
end;
{-----}
if svayz(mas,ver) = true then {если нет то ишем минимальную степень}
begin
max:=1;
for i:=1 to verbuf do
if stepen(masbuf,verbuf,i)<stepen(masbuf,verbuf,max) then
max:=i;
countS:=stepen(masbuf,verbuf,max);
Most:='Нет';
end
else
begin
countS:=1;
Most:='{'+inttostr(i-1)+','+inttostr(j-1)+'}';
end;
end
else Most:='Нет';
graf_sr:=countS; //the End =) uRA!!
end;

{----------------------------------------------------}
{----------------------------------------------------}
{----------------------------------------------------}

procedure save_File(namefile:string);
begin
assignfile(f,namefile);
rewrite(f);
write(f,n);
write(f,Rcount);
if mVes = true then i:=1
else i:=0;
write(f,i);
if mOrient = true then i:=1
else i:=0;
write(f,i);
for I:=1 to n do
begin
write(f,a[i].x);
write(f,a[i].y);
end;
for I:=1 to n do
for j:=1 to n do
write(f,s[i,j]);
closefile(f);
Form1.Caption:='миниРедактор графов V1.3: '+mince(namefile,50);
end;


procedure greate_graf; //прорисовка графа на Canvas
begin
Rcount:=0;
with form1 do
begin
{-Передача цветов и очистка Canvas-}
Image1.Canvas.Font.Color:=text_color;
image1.Canvas.Brush.Color := fon_color;
Image1.Canvas.Pen.Color:= rebro_color;
image1.Canvas.FillRect(form1.image1.Canvas.ClipRect);
{---------------------------}

{--передача данных Form3----}
if n>0 then
begin
form3.StringGrid1.ColCount:=n+1;
form3.StringGrid1.RowCount:=n+1;
Form3.StatusBar1.Panels.Items[0].Text:='Cвязность вершинная\рёберная: '+inttostr(graf_sv(s,n))+'\'+inttostr(graf_sr(s,n));
if graf_sv(s,n)=1 then
Form3.StatusBar1.Panels.Items[2].Text:='Точка сочленения: '+inttostr(Vrazriv)
else
Form3.StatusBar1.Panels.Items[2].Text:='Точка сочленения: Нет';
Form3.StatusBar1.Panels.Items[1].Text:='Мост: '+Most;
for i:=1 to n do
begin
Form3.StringGrid1.Cells[0,i]:=inttostr(i);
Form3.StringGrid1.Cells[i,0]:=inttostr(i);
end;

{---------------------------}
{-Считаем кол-во рёбер-}
r:=s;
i:=n;
Rcount:=0;
repeat
Rcount:=Rcount+stepen(r,i,1);
delete(r,i,1);
until i<=1;
{---------------------------}

for I:=1 to n do //прорисовка рёбер
for j:=1 to n do
begin
if s[i,j]<>maxves then
begin
Image1.Canvas.MoveTo(a[i].x+10,a[i].y+10);
Image1.Canvas.LineTo(a[j].x+10,a[j].y+10);

if mves = true then
Image1.Canvas.TextOut(round((abs(a[j].x+a[i].x))/2),round((abs(a[j].y+a[i].y))/2),inttostr(s[i,j]));
end;

{-Заполняем StringGrid в форме Form3-}
if s[i,j]=maxves then Form3.StringGrid1.Cells[j,i]:='-'
else Form3.StringGrid1.Cells[j,i]:=inttostr(s[i,j]);
end;
{---------------------------}

for i:=1 to n do //проприсовка вершин
begin
image1.Canvas.Brush.Color := verhina_color;
if i=vn then
image1.Canvas.Brush.Color := activ_color;
Image1.Canvas.Rectangle(a[i].x,a[i].y,a[i].x+20,a[i].y+20);
Image1.Canvas.TextOut(a[i].x+5,a[i].y+5,inttostr(i));
end;
end;
StatusBar1.Panels.Items[0].Text:='Кол-во вершин\ребер: '+inttostr(n)+'\'+inttostr(Rcount);//сабж
end;

end;

procedure open_file(namefile:string);
begin
Flag:=0;
assignfile(f,namefile);
reset(f);
read(f,n);//вершин
read(f,Rcount); //ребер
read(f,i); //учитывать вес
if i=1 then mves:=true else mves:=false;
read(f,i); //ориентированный
if i=1 then mOrient:=true else mOrient:=false;
for I:=1 to n do
begin
read(f,a[i].x);
read(f,a[i].y);
end;
for I:=1 to n do
for j:=1 to n do
read(f,s[i,j]);
closefile(f);
Form1.Caption:='миниРедактор графов V1.3: '+mince(namefile,50);
vn:=1;
greate_graf; //прорисовка графа
end;

procedure clear_graf; //чистим Canvas и обнуляем граф
begin
for i:=1 to n do
for j:=1 to n do
s[i,j]:=maxves;
greate_graf;
Form3.StringGrid1.RowCount:=1;
Form3.StringGrid1.colCount:=1;
n:=0;
vn:=0;
Rcount:=0;
with form1 do
begin
image1.Canvas.Brush.Color :=fon_color;
image1.Canvas.FillRect(form1.image1.Canvas.ClipRect);
StatusBar1.Panels.Items[0].Text:='Кол-во вершин\ребер: '+inttostr(n)+'\'+inttostr(Rcount);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var l:DWORD;
begin
{-----сохраняем данные в Options.ini------}
Ini:=TiniFile.Create(extractfilepath(paramstr(0))+'Options.ini');
fon_color:=ini.ReadInteger('Color','fon',10);
rebro_color:=ini.ReadInteger('Color','rebro',10);
verhina_color:=ini.ReadInteger('Color','Verhina',10);
text_color:=ini.ReadInteger('Color','Text',10);
activ_color:=ini.ReadInteger('Color','Activ',10);
DragAcceptFiles(Handle, true);
{-----------------------------------------}
{-------прячем Мин и Макс-----------------
l := GetWindowLong(Self.Handle, GWL_STYLE);
l := l and not (WS_MAXIMIZEBOX);
l := SetWindowLong(Self.Handle, GWL_STYLE, l);
{-----------------------------------------}
{заполняем массив имен режимов}
mf[0]:='миниРедактор графов V1.3';
mf[1]:='Добавление вершин';
mf[2]:='Добавление ребер';
// mf[3]:='Перестановка вершин';
mf[4]:='Удаление рёбер';
greate_graf;//перерисовываем граф

end;

procedure TForm1.WMDropFiles(var Msg: TMessage);
begin
{-организовываем DragAndDrop-}
DragQueryFile(THandle(Msg.WParam), 0, FileName, SizeOf(Filename));
if pos('.graf',filename)<>0 then
open_file(filename)
else
MessageDlg('Данный файл не может быть открыт текущим приложением ',mtWarning,[mbcancel],0);
DragFinish(THandle(Msg.WParam));
{-----------------------------}
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
MX:=x;
My:=y;
if (mpress=true) then //перемещение вершин
begin
if (mx+20>=Image1.Width) then mx:=Image1.Width-20;
if (mx<=0) then mx:=1;
if (my+20>=Image1.Height) then my:=Image1.Height-20;
if (my<=0) then my:=1;
a[v].x:=mx;
a[v].y:=my;
greate_graf;
end ;
if n>0 then
for i:=1 to n do //проверка наличия вершины подкурсором
if (a[i].x<=mx) and (a[i].y<=my) and (a[i].x+20>=mx) and (a[i].y+20>=my) then
begin
v:=i;
break;
end
else v:=0
else v:=0;
StatusBar1.Panels.Items[1].Text:='Вершина под курсором: '+inttostr(v);
StatusBar1.Panels.Items[2].Text:='Активная вершина: '+inttostr(vn)+'('+inttostr(stepen(s,n,vn))+')';
StatusBar1.Panels.Items[3].Text:=mf[flag];
end;


procedure TForm1.BitBtn1Click(Sender: TObject);
begin
if Flag=1 then flag:=0 else flag:=1;
end;

procedure TForm1.BitBtn4Click(Sender: TObject);
begin
if n=0 then MessageDlg('Нет графа для обработки',mtWarning,[mbcancel],0)
else
begin
form3.show;
end;
end;

procedure TForm1.BitBtn2Click(Sender: TObject);
begin
if n<=1 then MessageDlg('Нет вершин для растановки рёбер ',mtWarning,[mbcancel],0)
else Flag:=2;

end;

procedure TForm1.BitBtn6Click(Sender: TObject);
begin
SaveDialog1.Filter:='*.graf|*.graf';
SaveDialog1.Execute;
end;

procedure TForm1.SaveDialog1CanClose(Sender: TObject;
var CanClose: Boolean);
begin
if SaveDialog1.Filter='*.graf|*.graf' then
begin
if pos('.graf',SaveDialog1.FileName)=0 then
save_file(SaveDialog1.FileName+'.graf')
else
save_file(SaveDialog1.FileName)
end;

if SaveDialog1.Filter='*.bmp|*.bmp' then
begin
if pos('.bmp',SaveDialog1.FileName)=0 then
Image1.Picture.SaveToFile(SaveDialog1.FileName+'.bmp')
else
Image1.Picture.SaveToFile(SaveDialog1.FileName);
end;
end;

procedure TForm1.OpenDialog1CanClose(Sender: TObject;
var CanClose: Boolean);
begin

Open_file(OpenDialog1.FileName);

end;

procedure TForm1.N13Click(Sender: TObject);
begin
MessageDlg('Данный пункт меню еще не доработан. Буим стараться =)',mtWarning,[mbCancel],0)
end;

procedure TForm1.N14Click(Sender: TObject);
begin
SaveDialog1.Filter:='*.bmp|*.bmp';
SaveDialog1.Execute;
end;


procedure TForm1.FormDestroy(Sender: TObject);
begin
{сохранение палитры в *.ini файл}
Ini:=TiniFile.Create(extractfilepath(paramstr(0))+'Options.ini');
Ini.Writeinteger('Color','Fon',fon_color);
Ini.Writeinteger('Color','Verhina',verhina_color);
Ini.Writeinteger('color','Rebro',rebro_color);
Ini.Writeinteger('color','Activ',activ_color);
Ini.Writeinteger('color','Text',text_color);
end;


procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if v<>0 then
begin
mpress:=true;
end;
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
mpress:=false;
end;

procedure TForm1.N15Click(Sender: TObject);
begin
if flag=4 then flag:=0 else flag:=4;
end;


procedure TForm1.Image1Click(Sender: TObject);
begin
if (n>=50) and (flag = 1) then MessageDlg('Максимальное кол-во вершин', mtWarning,[mbOK],0)
else
begin
if (flag=1) and (v=0) then //добавление вершины
begin
n:=n+1;
vn:=n;
for i:=1 to n do
begin
s[i,n]:=maxves;
s[n,i]:=maxves;
end;
a[n].x:=mx;
a[n].y:=my;
end;
end ;


if (flag=4) and (v<>0) and (vn<>v) then //удаляем ребро
begin
s[v,vn]:=maxves;
s[vn,v]:=maxves;
flag:=0;
end;
if v=0 then vn:=0; //обнуляем активную вершину еси кликнем в пустоте
if (vn>0) and (v<>vn) and (flag=2)then //создаем связь м\у вершинами
begin
if (mves=true) and (s[vn,v]=maxves) and (s[v,vn]=maxves) then
begin
form4.showmodal;
Form4.Caption:='Ввод веса ребра';
end;
if (mOrient = false) then
begin
s[vn,v]:=ves;
s[v,vn]:=ves;
end
else s[vn,v]:=ves;
if (mves=true) and (s[v,vn]<>maxves)then s[vn,v]:=s[v,vn];
flag:=0;
end;
if v<>0 then vn:=v; //установка активной вершины
greate_graf//перерисовываем граф наф

end;

procedure TForm1.N17Click(Sender: TObject);
begin
form2.ShowModal;
end;

procedure TForm1.N10Click(Sender: TObject);
begin
if MessageDlg('Завершить работу? ',mtConfirmation,[mbYes, mbNo],0 ) = mrYes then close;
end;

procedure TForm1.N26Click(Sender: TObject);
begin
greate_graf;
end;

procedure TForm1.BitBtn9Click(Sender: TObject);
begin
clear_graf;
end;

procedure TForm1.BitBtn3Click(Sender: TObject);
begin
opendialog1.Execute;
end;

procedure TForm1.FormShortCut(var Msg: TWMKey; var Handled: Boolean);
begin
StatusBar1.Panels.Items[3].Text:=mf[flag];
end;

procedure TForm1.N16Click(Sender: TObject);
begin
if (vn<>0) then //удаление вершины
begin
a[vn]:=a[n];
delete(s,n,vn);//удаление вершины из массива S
vn:=0;
end;
greate_graf;
end;

procedure TForm1.N28Click(Sender: TObject);
begin
Form5.showmodal;
end;

procedure TForm1.N29Click(Sender: TObject);
begin
form6.show;
end;

procedure TForm1.N30Click(Sender: TObject);
var mas:massiv;
i,j,c,ver,countV:integer;
mv:array[1..50] of integer;
begin
mas:=s;
ver:=n;
i:=0;
countV:=0;
c:=0;
form7.memo1.clear;
while (c<n) do
begin
inc(c);
if stepen(mas,ver,c)=1 then
begin
for i:=1 to ver do
if (mas[i,c] <> maxves) then
begin
inc(countV);
mv[countV]:=i;
form7.memo1.Text:=Form7.Memo1.Text+' + '+inttostr(mv[countV]);
mas[c,i]:=maxves;
mas[i,c]:=maxves;
break;
end;
c:=0;
end;
end;

form7.show;

end;

procedure TForm1.Button1Click(Sender: TObject);
var mas:massiv;
i,j,c,ver:integer;
begin
form7.show;
mas:=s;
ver:=n;
i:=0;
countV:=0;
c:=0;
form7.memo1.clear;
while (c<n) do
begin
inc(c);
if stepen(mas,ver,c)=1 then
begin
for i:=1 to ver do
if (mas[i,c] <> maxves) then
begin
inc(countV);
mv[countV]:=i;
form7.memo1.Text:=memo1.Text+' + '+inttostr(mv[countV]);
mas[c,i]:=maxves;
mas[i,c]:=maxves;
break;
end;
c:=0;
end;
end;



end;
end.{-> HAppY END <-}
Соседние файлы в папке Мини-редактор графов