Новичок
Профиль
Группа: Участник
Сообщений: 1
Регистрация: 28.4.2013
Репутация: нет
Всего: нет
|
| Код |
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Grids, ComCtrls, Menus, ExtCtrls;
type
TForm1 = class(TForm)
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
SG1: TStringGrid;
Edit1: TEdit;
Label1: TLabel;
Button2: TButton;
Button3: TButton;
Button1: TButton;
mmo1: TMemo;
Button4: TButton;
SaveDialog1: TSaveDialog;
Button5: TButton;
MainMenu1: TMainMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
Button6: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure SG1KeyPress(Sender: TObject; var Key: Char);
procedure Edit1KeyPress(Sender: TObject; var Key: Char);
procedure Button5Click(Sender: TObject);
procedure N3Click(Sender: TObject);
procedure N7Click(Sender: TObject);
procedure Button6Click(Sender: TObject);
private
function perenos (const a : tstringgrid; i,j : integer): integer;
function test (a : tstringgrid):integer;
function zapolnen(a: array of boolean) : integer;
{ Private declarations }
public
kolvo : integer;
labg : array[1..10] of TLabel;
labv : array[1..12] of TLabel;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Unit2, Unit3;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
close;
end;
procedure TForm1.Button2Click(Sender: TObject);
var i:integer;
begin
if (edit1.text<>'')and(StrToInt(Edit1.Text)<16) then
begin
sg1.Visible:=true;
Button3.Visible:=True;
kolvo:=strtoint(edit1.Text);
sg1.ColCount:=kolvo+1;
sg1.RowCount:=kolvo+1;
for i:=1 to kolvo do
sg1.Cells[0,i]:='x'+ inttostr(i);
for i:=1 to kolvo do
sg1.Cells[i,0]:='x'+ inttostr(i);
sg1.Height:=sg1.defaultRowHeight*(kolvo)+50;
sg1.Width:=sg1.defaultColWidth*(kolvo)+50;
button3.Visible:=true;
end
else
Edit1.text:=InputBox('Algoritm Deykstri','Введите воличество вершин, не более 15!!!','6');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
button3.WordWrap:=true;
Button3.Visible:=False;
end;
procedure TForm1.Button3Click(Sender: TObject);
const m=15;
const max=999999;
var i,j,min_d,min_v,n,put,nach : integer;
str,str_can : string;
duga : array [1..m,1..m] of integer;//матрица смежности
duga_v : array [1..m] of integer; //матрица дуг н-ной вершины
ver : array [1..m] of integer;//кротчайшие расстояния
bul : array [1..m] of boolean;//список просмотренных вершин
begin
min_v:=0;
if (test(sg1)<>1) then
begin
fillchar(ver,sizeof(ver), max);
fillchar(bul,sizeof(bul),0);
for i:=1 to sg1.colcount-1 do
for j:=1 to sg1.colcount-1 do
duga[i,j]:=perenos(sg1,i,j);
//first start
n:=strtoint(inputbox('Дейкстра','Введите начальную вершину','1'));
while((n>kolvo)or(n<0)) do
begin
showmessage('Вершина не входит в граф!');
n:=strtoint(inputbox('Дейкстра','Введите начальную вершину','1'));
end;
min_d:=max;
for i:=1 to sg1.colcount-1 do
begin
if (duga[i,n]>0) and (not(bul[i])) then
begin
duga_v[i]:=duga[i,n];
if (duga_v[i]<min_d) and (duga_v[i]>0) then
begin
min_v:=i;
min_d:=duga_v[i];
end;
end;
end;
mmo1.Lines.Add('В кратчайший путь от вершины X '+inttostr(n)+' ко всем вершинам входят дуги : ');
mmo1.Lines.Add('- к вершине X'+inttostr(min_v)+' :('+inttostr(n)+';'+inttostr(min_v)+ ') длина пути : '+ inttostr(min_d));
str:=('('+inttostr(n)+';'+inttostr(min_v)+')');
nach:=n;
put:=min_d;
bul[n]:=true;
n:=min_v;
min_d:= max;
//first end;
while(zapolnen(bul)<>kolvo-1) do
begin
//all start
for i:=1 to sg1.colcount-1 do
begin
if (duga[i,n]>0) and (not(bul[i])) then
begin
duga_v[i]:=duga[i,n];
if (duga_v[i]<min_d) and (duga_v[i]>0) then
begin
min_v:=i;
min_d:=duga_v[i];
end;
end;
end;
//all end;
put:=put+min_d;
mmo1.Lines.Add('- к вершине X'+inttostr(min_v)+': '+str +'('+inttostr(n)+';'+inttostr(min_v)+'). Длина пути :'+ inttostr(put));
str:=str+'('+inttostr(n)+';'+inttostr(min_v)+')';
str_can:='dm'+inttostr(n)+inttostr(min_v);
bul[n]:=true;
n:=min_v;
min_d:= max;
end;
end;
pagecontrol1.ActivePageIndex:=1;
end;
procedure TForm1.SG1KeyPress(Sender: TObject; var Key: Char);
begin
if key=chr(13) then
if sg1.Col < sg1.ColCount-1 then
sg1.Col:=sg1.Col+1
else
if sg1.Row < sg1.RowCount-1 then
begin
sg1.Row:=sg1.Row+1;
sg1.Col:=1;
end;
if key=chr(8) then
key:=chr(8)
else
if not (key in ['0'..'9']) then
key:=#0;
end;
function TForm1.perenos(const a: tstringgrid; i,j : integer): integer;
begin
if i=j then
perenos:=0;
perenos:=strtoint(a.cells[i,j]);
end;
function TForm1.test(a: tstringgrid): integer;
var i,j,er :integer;
begin
test:=0;
for i:=1 to a.rowcount-1 do
for j:=1 to a.colcount-1 do
begin
if (i=j) then
a.cells[i,j]:=inttostr(0)
else
if (a.Cells[i,j]='') then
begin
a.cells[i,j]:='0';
test:=0;
end
else
if (StrToInt(a.cells[i,j])<0) or (StrToInt(a.cells[i,j])>1000) then
begin
showmessage('Ошибка! Вершина расположенная в '+inttostr(i)+'-ом столбце и в '+inttostr(j)+'-ой строке содержит неверное значение');
test:=1;
end;
end;
j:=0;
for i:=0 to a.RowCount-1 do
begin
er:=0;
if ((a.Cells[j,i]=inttostr(0)) or (a.Cells[j,i]=inttostr(00)) or (a.Cells[j,i]=inttostr(000))) then
er:=er+1;
if er = a.RowCount-1 then
begin
test:=1;
showmessage('Вершина X'+inttostr(i)+', не соединена ни с одной вершиной. Проверьте данные');
end;
if i=a.rowcount-1 then
j:=j+1;
end;
end;
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if key=chr(8) then
key:=chr(8)
else
if not (key in ['0'..'9']) then
key:=#0;
end;
function TForm1.zapolnen(a: array of boolean): integer;
var
i, Count: Integer;
begin
Count:=0;
for i:=Low(a) to High(a) do
if a[i]<>false then
Inc(Count);
zapolnen:=count;
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
if savedialog1.Execute=true then
mmo1.Lines.SaveToFile(savedialog1.filename);
end;
procedure TForm1.N3Click(Sender: TObject);
begin
form2.showmodal;
end;
procedure TForm1.N7Click(Sender: TObject);
begin
form3.showmodal;
end;
procedure TForm1.Button6Click(Sender: TObject);
var i, j: Integer;
begin
with SG1 do
for i:=1 to RowCount-1 do //Заголовки строк не трогаем
for j:=1 to ColCount-1 do //Заголовки столбцов не трогаем
Cells[j, i]:='';
end;
end.
|
Ой , админы) извините ! не прочел правила. Переместите тему ?? ))) Это сообщение отредактировал(а) Volna - 28.4.2013, 14:14
Присоединённый файл ( Кол-во скачиваний: 13 )
курсовая.rar 344,50 Kb |
[Алгоритм] Алгоритм ДЕйкстры с ошибками, делфи реализация 
Загрузка ...
