Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Паскаль, Turbo Pascal, PascalABC.NET
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 21.04.2018, 21:16   #1
ИнокентийПетрович
 
Регистрация: 21.04.2018
Сообщений: 4
По умолчанию Найти ошибку в работе с вершинами

При работе с вершинами пути вышел ресурсию. На основе используется алгоритм Дейстры. Иду по алгоритму Дейстры, для нахождения сначала общего пути, для разбора определённых вершин.
Ошибка в процедуре Find
program Pousk;
var
O,M:integer;
MatrixKart:array[1..10,1..10] of integer;
lol:integer;
procedure OpenKart;
var
f:text;
i,j:integer;
begin
assign(f,'karta.txt');
reset(f);
read(f,O);
read(f,M);
for i:=1 to O do
begin
for j:=1 to M do
begin
read(f,MatrixKart[i,j]);
write(MatrixKart[i,j]:4);
end;
writeln;
end;
close(f);
end;
procedure MatrixPute;//Карта пути
var
O,M:integer;
i,j:integer;
Matrix:array [1..10,1..10] of integer;
f: text;
n: byte;
begin
write('Введите количество офисов - ');
readln(O);
write('Введите количество магазинов - ');
readln(M);
for i:=1 to O do
begin
for j:=1 to M do
begin
write('Введите растояние от Офиса ',i,' до Магазина ',j,': ');
readln(Matrix[i,j]);
end;
end;
writeln('Готовый массив - карта');
for i:=1 to O do
begin
for j:=1 to M do
begin
write(Matrix[i,j]);
end;
writeln;
end;

//Запись массива в файл
assign (f, 'karta.txt');
rewrite (f);
write(f,O:4);
write(f,M:4);
writeln(f,'');
for i := 1 to O do begin
for j :=1 to M do begin
n := Matrix[i,j];
write (f, n:4)
end;
writeln (f)
end;
close (f);
OpenKart;
end;


procedure Find(number:integer);
var
i,j,temp,minindex, min:integer;
d,v:array[1..100] of integer;
// Восстановление пути
ver:array[1..100] of integer; // массив посещенных вершин
endd,k,l,weight:integer;
begin
//Инициализация вершин и расстояний
endd := O; // индекс конечной вершины = 5 - 1
ver[1] := endd + 1; // начальный элемент - конечная вершина
k := 1; // индекс предыдущей вершины
weight := d[endd]; // вес конечной вершины
for i:= 1 to O do
begin
d[i] := 10000;
v[i] := 1;
end;
d[1] := 0;
// Шаг алгоритма
repeat
begin
minindex := 10000;
min := 10000;
for i:= 1 to O do
begin
// Если вершину ещё не обошли и вес меньше min
if ((v[i] = 1)> (d[i]<min)) then
begin
// Переприсваиваем значения
min := d[i];
minindex := i;
end;
end;
// Добавляем найденный минимальный вес
// к текущему весу вершины
// и сравниваем с текущим минимальным весом вершины
if (minindex <> 10000) then
begin
for i:= 1 to O do
begin
if (MatrixKart[minindex][i] > 0) then
begin
temp := min + MatrixKart[minindex][i];
if (temp < d[i]) then
begin
d[i] := temp;
end;
end;
end;
v[minindex] := 0;
end;
end;
until (minindex < 10000);
while (endd > 0) do// пока не дошли до начальной вершины
begin
for i:=1 to O do// просматриваем все вершины
if (MatrixKart[endd][i] <> 0) then // если связь есть
begin
temp := weight - MatrixKart[endd][i]; // определяем вес пути из предыдущей вершины
if (temp = d[i]) then// если вес совпал с рассчитанным
begin // значит из этой вершины и был переход
weight := temp; // сохраняем новый вес
endd := i; // сохраняем предыдущую вершину
ver[k] := i + 1; // и записываем ее в массив
k:=k+1;
end;
end;
end;
// Вывод пути (начальная вершина оказалась в конце массива из k элементов)
writeln('Вывод кратчайшего пути');
for i:=k-1 downto 0 do
writeln(ver[i]:4);
end;

procedure Choose(O:integer;M:integer);
var
number,i:integer;
begin
writeln('Количество офисов: ',O);
writeln('Количество магазинов: ',M);
write('Введите офис из которого выезжаете: ');
readln(number);
Find(number);
end;

begin
write('Создать(1) или открыть карту(2)');
readln(lol);
if (lol=1) then MatrixPute
else OpenKart;
Choose(O,M);
end.
ИнокентийПетрович вне форума Ответить с цитированием
Старый 22.04.2018, 03:20   #2
min@y™
Цифровой кот
Старожил
 
Аватар для min@y™
 
Регистрация: 29.08.2014
Сообщений: 7,656
По умолчанию

Расскажу я вам, дружочки, как выращивать грибочки: нужно в поле утром рано сдвинуть два куска урана...
min@y™ вне форума Ответить с цитированием
Старый 22.04.2018, 10:56   #3
ИнокентийПетрович
 
Регистрация: 21.04.2018
Сообщений: 4
По умолчанию

Пожалуйста
ИнокентийПетрович вне форума Ответить с цитированием
Старый 22.04.2018, 10:59   #4
evg_m
Старожил
 
Регистрация: 20.04.2008
Сообщений: 5,515
По умолчанию

Цитата:
Код:
//Инициализация вершин и расстояний
  endd := O; // индекс конечной вершины = 5 - 1
  ver[1] := endd + 1; // начальный элемент - конечная вершина
  k := 1; // индекс предыдущей вершины
  weight := d[endd]; // вес конечной вершины
А ЧЕМ у нас заполнен массив d? и чему станет равно weight ?
Цитата:
Код:
 for i:= 1 to O do
begin
d[i] := 10000;
v[i] := 1;
end;
сначала используем, ПОТОМ заполняем?!
программа — запись алгоритма на языке понятном транслятору
evg_m на форуме Ответить с цитированием
Старый 23.04.2018, 23:52   #5
ИнокентийПетрович
 
Регистрация: 21.04.2018
Сообщений: 4
По умолчанию Вот собственно исправил, только кратчайший путь ищет не правильно, помогите пожалуйста исправить

Код:
program Pousk;
const N=6;
type IntSet=set of 2..N;
var
a,amin:array[1..N+1] of integer;
Lmin,i:integer;
OM:integer;
MatrixKart:array[1..N,1..N] of integer;
lol:integer;

procedure OpenKart;
var
f:text;
i,j:integer;
begin
assign(f,'karta.txt');
reset(f);
read(f,OM);
for i:=1 to OM do
 begin
 for j:=1 to OM do
  begin
    read(f,MatrixKart[i,j]);
    write(MatrixKart[i,j]:4);
  end;
  writeln;
 end;
close(f);
end;

procedure MatrixPute;//Карта пути
var
OM:integer;
i,j:integer;
Matrix:array [1..10,1..10] of integer;
f: text;
n: byte;
begin
  write('Введите количество офисов - и магазинов');
  readln(OM);
  for i:=1 to OM do
    begin
      for j:=1 to OM do
        begin
          write('Введите растояние от Офиса ',i,' до Магазина ',j,': ');
          readln(Matrix[i,j]);
        end;
    end;
    //Запись массива в файл
    assign (f, 'karta.txt');
    rewrite (f);
    write(f,OM:4);
    writeln(f,'');
    for i := 1 to OM do begin
        for j :=1 to OM do begin
            n := Matrix[i,j];
            write (f, n:4)
        end;
        writeln (f)
    end;
    close (f);
    OpenKart;
end;

 procedure Find(S:IntSet;number:integer);
    var
      L,i:integer;
      aa:real;
        begin
        if S=[i] then
          begin
            L:=0;
            for i:=1 to N do
              L:=L+MatrixKart[a[i],a[i+1]];
                if (L<Lmin) then
                  begin
                    Lmin:=L;
                    Amin:=a;
                  end;
          end
          else
            for i:=2 to N do
              if i in S then
                begin
                  A[1]:=1;
                  A[number]:=1;
                  A[N+1]:=1;
                  Find(S-[i],number+1)
                end;

        end;

procedure Choose(OM:integer);
var
number,i:integer;
begin
  writeln('Количество офисов и магазинов:  ',OM);
  write('Введите офис из которого выезжаете: ');
  readln(number);
  Find([2..OM],number);
end;

begin
Lmin:=MaxInt;
write('Создать(1) или открыть карту(2)');
readln(lol);
if (lol=1) then MatrixPute
else OpenKart;
Choose(OM);

 writeln('Оптимальный маршрут: ');
    for i:=1 to N+1 do
      begin
        write(Amin[i],'-->')
      end;
     writeln;
     writeln('Длинна маршрута - ',Lmin);
end.


________
Код нужно оформлять по правилам:
тегом [CODE]..[/СODE]
(это кнопочка на панели форматирования с решёточкой #)
Не забывайте об этом!

Модератор.

Последний раз редактировалось Serge_Bliznykov; 24.04.2018 в 00:05.
ИнокентийПетрович вне форума Ответить с цитированием
Старый 24.04.2018, 09:54   #6
evg_m
Старожил
 
Регистрация: 20.04.2008
Сообщений: 5,515
По умолчанию

Цитата:
Код:
    var
      L,i:integer;
      aa:real;
        begin
        if S=[i] then
ЧЕМУ здесь(в последней приведенной строке) равно i ?
читайте Warning(и старайтесь исправить). там все это есть(сказано).
программа — запись алгоритма на языке понятном транслятору

Последний раз редактировалось evg_m; 24.04.2018 в 09:59.
evg_m на форуме Ответить с цитированием
Старый 24.04.2018, 10:53   #7
ИнокентийПетрович
 
Регистрация: 21.04.2018
Сообщений: 4
По умолчанию Помогите исправить

На что заменить то ? Помогите исправить чтобы работало. Голова уже не варит
ИнокентийПетрович вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Даны координаты трёх точек, являющихся вершинами некоторого параллелограмма. Найти координаты четвертой вершины. yamato_pm Паскаль, Turbo Pascal, PascalABC.NET 1 18.12.2013 19:42
Помогите найти ошибку - StrToFloat выдаёт ошибку EConvertError для ячеек StringGrid (Delphi) Artsiom Помощь студентам 10 18.12.2013 14:10
Найти треугольник с наибольшей площадью с вершинами в точках заданных координатами (подправить код) C++ GrShOot Помощь студентам 0 28.05.2013 01:47
Дано 3 точки своими координатами х,у. Будет ли они вершинами треугольника. Если да - найти периметр и площадь треугольника Arhi555 Паскаль, Turbo Pascal, PascalABC.NET 2 11.09.2012 17:46