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

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

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

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

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

Ответ
 
Опции темы Поиск в этой теме
Старый 19.03.2019, 20:22   #1
Daniia
Новичок
Джуниор
 
Регистрация: 19.03.2019
Сообщений: 3
По умолчанию Pascal ABC.NET какое минимальное количество водостоков нужно построить, чтобы после дождя вся вода утекала в водостоки

Карту местности условно разбили на квадраты, и посчитали среднюю высоту над уровнем моря для каждого квадрата.

Когда идет дождь, вода равномерно выпадает на все квадраты. Если один из четырех соседних с данным квадратом квадратов имеет меньшую высоту над уровнем моря, то вода с текущего квадрата стекает туда (и, если есть возможность, то дальше), если же все соседние квадраты имеют большую высоту, то вода скапливается в этом квадрате.

Разрешается в некоторых квадратах построить водостоки. Когда на каком-то квадрате строят водосток, то вся вода, которая раньше скапливалась в этом квадрате, будет утекать в водосток.

Если есть группа квадратов, имеющих одинаковую высоту и образующих связную область, то если хотя бы рядом с одним из этих квадратов есть квадрат, имеющий меньшую высоту, то вся вода утекает туда, если же такого квадрата нет, то вода стоит во всех этих квадратах. При этом достаточно построить водосток в любом из этих квадратов, и вся вода с них будет утекать в этот водосток.

Требуется определить, какое минимальное количество водостоков нужно построить, чтобы после дождя вся вода утекала в водостоки.

Входные данные
Во входном файле INPUT.TXT записаны сначала числа N и M, задающие размеры карты — натуральные числа, не превышающие 100. Далее, идет N строк, по M чисел в каждой, задающих высоту квадратов карты над уровнем моря. Высота задается натуральным числом, не превышающим 10000. Считается, что квадраты, расположенные за пределами карты, имеют высоту 10001 (то есть вода никогда не утекает за пределы карты).

Выходные данные
В выходной файл OUTPUT.TXT выведите минимальное количество водостоков, которое необходимо построить.

Например, вход:
4 5
1 2 3 1 10
1 4 3 10 10
1 5 5 5 5
6 6 6 6 6

выход: 2

Для Pascal ABC.NET
СПАСИБО!





нашла пример на турбо паскаль, но для меня это сложно( может быть как-то можно переделать? или по-другому решить

Код:
{$I+,Q+,R+,S+}
 
Const
 Nmax=101;
 InpFile='c.in';
 OutFile='c.out';
 
Type
 Int=longint;
 
var
 pole,paint: array[0..Nmax,0..Nmax] of int;
 s: array[1..Nmax*Nmax] of int;
 n,m: int;
 answer,num: int;
 
procedure InpData;
 var
  i,j: int;
begin
 fillchar(pole,sizeof(pole),63);
 assign(input,InpFile);
 reset(input);
   readln(n,m);
   for i:=1 to n do
     for j:=1 to m do
       read(pole[i,j]);
 close(input);
end;
 
procedure go(x,y: int);
begin
  if paint[x,y]<>0 then exit;
  paint[x,y]:=num;
 
  if ((x-1) in [1..N]) and (y in [1..M]) then begin
    if pole[x-1,y]=pole[x,y] then go(x-1,y);
    if pole[x-1,y]<pole[x,y] then s[num]:=1;
  end;
 
  if ((x+1) in [1..N]) and (y in [1..M]) then begin
    if pole[x+1,y]=pole[x,y] then go(x+1,y);
    if pole[x+1,y]<pole[x,y] then s[num]:=1;
  end;
 
  if (x in [1..N]) and ((y-1) in [1..M]) then begin
    if pole[x,y-1]=pole[x,y] then go(x,y-1);
    if pole[x,y-1]<pole[x,y] then s[num]:=1;
  end;
 
  if (x in [1..N]) and ((y+1) in [1..M]) then begin
    if pole[x,y+1]=pole[x,y] then go(x,y+1);
    if pole[x,y+1]<pole[x,y] then s[num]:=1;
  end;
 
end;
 
procedure Solve;
 var
  i,j: int;
begin
  fillchar(paint,sizeof(paint),0);
  fillchar(s,sizeof(s),0);
  answer:=0;
  num:=0;
 
  for i:=1 to n do
    for j:=1 to m do
      if paint[i,j]=0 then begin
        inc(num);
        go(i,j);
      end;
 
  for i:=1 to Num do
    if s[i]=0 then inc(answer);
end;
 
procedure OutData;
begin
  assign(output,OutFile);
  rewrite(output);
    writeln(answer);
  close(output);
end;
 
begin
 InpData;
 Solve;
 OutData;
end.
Daniia вне форума Ответить с цитированием
Старый 20.03.2019, 10:22   #2
evg_m
Старожил
 
Регистрация: 20.04.2008
Сообщений: 5,515
По умолчанию

Код:
program Project1;

const
  maxM =100;
  superH =1001;

type
  mmmm = array[1..maxM, 1..maxM] of integer;

const
  InpFile='c.in';
  OutFile='c.out';

procedure InpData(pole: mmmm);
 var
  i,j: integer;
  n, m: integer;
begin
 assign(input,InpFile);
 reset(input);
   readln(n,m);
   for i:=1 to maxM do
     for j:=1 to maxM do
       if (i<=n) and (j<=m) then //это точка карты
         read(pole[i,j]) // читаем и записываем
       else
         pole[i,j]:=superH; // ставим супервысоту
 close(input);
end;

procedure OutData(pole: mmmm);
var
  answer: integer;
  i, j: integer;
begin
  answer:=0;
  for i:=1 to maxM do
    for j:=1 to maxM do
      if pole[i,j]=-2 then Inc(answer); //считаем поставленные водостоки

  assign(output,OutFile);
  rewrite(output);
    writeln(answer);
  close(output);
end;

function ScanMin(pole: mmmm; out minX, minY: integer): boolean;
var
  s: integer;
  j, i: integer;
begin
  s:=superH; // заведомо больший

  for j:=1 to maxM do
    for i:=1 to maxM do
    begin
      if pole[i,j]=superH then continue; //это граница вне карты
      if pole[i,j]<0 then continue; //точка УЖЕ "оборудована водостоком"
      if pole[i,j]>s then continue; // точка выше ранее найденого минимума

      // похоже мы наши
      s:=pole[i,j];    //запомним это
      minx:=i; miny:=j; // и где это
    end;

   result:=(s<>999); // нашли иль нет(=999)
end;

procedure SetTruba(pole: mmmm; x, y: integer; tp: integer);
var
  r: byte;
begin
  if pole[x,y]<0 then Exit; //все сток уже есть
  r:=pole[x, y]; //
  pole[x, y]:=tp; // ставим признак (труба -2 / естественный сток -1 )
  // и проверяем БЛИЖАЙШИЕ квадраты
  if (x>0)    and (pole[x-1,y]>=r) then // и если она стекает
     SetTruba(pole,x-1,y, -1); // повторим отметки для новых точек
  if (x<maxM) and (pole[x+1,y]>=r) then SetTruba(pole,x+1,y, -1);
  if (y>0)    and (pole[x,y-1]>=r) then SetTruba(pole,x,y-1, -1);
  if (y<maxM) and (pole[x,y+1]>=r) then SetTruba(pole,x,y+1, -1);
end;

procedure Full(pole: mmmm);
var
  minX, minY: integer;
  r: boolean;
begin
  r:=ScanMin(pole, minx, miny); // ищем самую низкую точку (любую из нескольких таких)
  while r do begin
   SetTruba(pole, minx, miny, -2); // ставим там водосток и отмечаем все что туда будет стекать
   r:=ScanMin(pole, minx, miny); // ищем самую низкую точку ИЗ оставшихся
  end;
end;


var
  pole: mmmm;
begin
  InpData(pole);
  Full(pole);
  OutData(pole);
end.
проверено на синтаксис(в Lazarus), но не тестировано.
программа — запись алгоритма на языке понятном транслятору
evg_m вне форума Ответить с цитированием
Старый 20.03.2019, 18:28   #3
Daniia
Новичок
Джуниор
 
Регистрация: 19.03.2019
Сообщений: 3
По умолчанию

спасибо! почему-то после первого begin на строчке
assign(input,InpFile); выдает ошибку "параметр цикла for должен описываться в заголовке цикла"
Daniia вне форума Ответить с цитированием
Старый 20.03.2019, 21:38   #4
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

у меня ругалось на строчку
Цитата:
Сообщение от evg_m Посмотреть сообщение
Код:
function ScanMin(pole: mmmm; out minX, minY: integer): boolean;
изменил на
Код:
function ScanMin(pole: mmmm; out minX, minY: integer): boolean;
вроде откомпилировалось:
pabc_.png


ДОБАВЛЕНО
попытался запустить.

во-первых, размерность с ошибкой.
должна быть:
Код:
type
  mmmm = array[0..maxM, 0..maxM] of integer;
а во-вторых, вывалилось по ошибке переполнения программного стека

Последний раз редактировалось Serge_Bliznykov; 20.03.2019 в 21:42.
Serge_Bliznykov вне форума Ответить с цитированием
Старый 21.03.2019, 13:40   #5
evg_m
Старожил
 
Регистрация: 20.04.2008
Сообщений: 5,515
По умолчанию

Цитата:
во-первых, размерность с ошибкой.
должна быть:
это требование ABC? или SetTruba вываливалась?
X>1, Y>1 надо при 1..maxM

Цитата:
по ошибке переполнения программного стека
Код:
   if pole[x,y]=superH then Exit; // это нам ни к чему
исправленный вариант
на "универсальный" 'вариант массива minM..MaxM

Код:
const
  minM =1; // или 0;
  maxM =100;
  superH =1001;

type
  mmmm = array[minM..maxM, minM..maxM] of integer;
и опять нетестированный
Код:
procedure SetTruba(pole: mmmm; x, y: integer; tp: integer);
var
  r: byte;
begin
  if pole[x,y]<0 then Exit; //все сток уже есть
  if pole[x,y]=superH then Exit; // это нам ни к чему, граница однако
  r:=pole[x, y]; //
  pole[x, y]:=tp; // ставим признак (труба -2 / естественный сток -1 )
  // и проверяем БЛИЖАЙШИЕ квадраты
  if (x>minM)    and (pole[x-1,y]>=r) then // и если она стекает
     SetTruba(pole,x-1,y, -1); // повторим отметки для новых точек
  if (x<maxM) and (pole[x+1,y]>=r) then SetTruba(pole,x+1,y, -1);
  if (y>minM)    and (pole[x,y-1]>=r) then SetTruba(pole,x,y-1, -1);
  if (y<maxM) and (pole[x,y+1]>=r) then SetTruba(pole,x,y+1, -1);
end;
ну и циклы в таком разе
for j:=minM to maxM do
а может и не надо циклы менять ?
программа — запись алгоритма на языке понятном транслятору

Последний раз редактировалось evg_m; 21.03.2019 в 13:44.
evg_m вне форума Ответить с цитированием
Старый 21.03.2019, 14:13   #6
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

Цитата:
Сообщение от evg_m Посмотреть сообщение
и опять нетестированный
тоже самое - вываливается по переполнению стека.

я не разбирал алгоритм.
Но, смотрите, поле у Вас 100x100 и Вы его в стеке целиком передаёте.
процедура рекурсивная, всего несколько вызовов и всё - стек кончился.
А зачем Вы вообще поле в стек засунули? Ведь в исходном примере такого не было!


в общем, на примере из пост #1
корректно работает такая программа:
Код:
program Project1;

const
  minM =0; // или 0;
  maxM =100;
  superH =1001;

type
  mmmm = array[minM..maxM, minM..maxM] of integer;

var
  pole: mmmm;
  n,m : integer;
  
const
  InpFile='c.in';
  OutFile='c.out';

procedure InpData;
begin
 assign(input,InpFile);
 reset(input);
   readln(n,m);
   for var i:=0 to maxM do
     for var j:=0 to maxM do
       if (i>0) and (j>0) and (i<=n) and (j<=m) then //это точка карты
         read(pole[i,j]) // читаем и записываем
       else
         pole[i,j]:=superH; // ставим супервысоту
 close(input);
end;

procedure OutData;
var
  answer: integer;
begin
  answer:=0;
  for var i:=1 to n do
    for var j:=1 to m do
      if pole[i,j]=-2 then Inc(answer); //считаем поставленные водостоки

  assign(output,OutFile);
  rewrite(output);
    writeln(answer);
  close(output);
end;

function ScanMin(var minX, minY: integer): boolean;
var
  s: integer;
begin
  s:=superH; // заведомо больший

  for var j:=1 to m do
    for var i:=1 to n do
    begin
      if pole[i,j]=superH then continue; //это граница вне карты
      if pole[i,j]<0 then continue; //точка УЖЕ "оборудована водостоком"
      if pole[i,j]>s then continue; // точка выше ранее найденого минимума

      // похоже мы нашли
      s:=pole[i,j];    //запомним это
      minx:=i; miny:=j; // и где это
    end;

   result:=(s<superH); // нашли иль нет(=999)
end;

procedure SetTruba(x, y: integer; tp: integer);
var
  r: byte;
begin
  if pole[x,y]<0 then Exit; //все сток уже есть
  if pole[x,y]=superH then Exit; // это нам ни к чему
  r:=pole[x, y]; //
  pole[x, y]:=tp; // ставим признак (труба -2 / естественный сток -1 )
  // и проверяем БЛИЖАЙШИЕ квадраты
  if (x>minM)    and (pole[x-1,y]>=r) then // и если она стекает
     SetTruba(x-1,y, -1); // повторим отметки для новых точек
  if (x<n) and (pole[x+1,y]>=r) then SetTruba(x+1,y, -1);
  if (y>minM)    and (pole[x,y-1]>=r) then SetTruba(x,y-1, -1);
  if (y<m) and (pole[x,y+1]>=r) then SetTruba(x,y+1, -1);
end;

procedure Full();
var
  minX, minY: integer;
  r: boolean;
begin
  r:=ScanMin( minx, miny); // ищем самую низкую точку (любую из нескольких таких)
  while r do begin
   SetTruba( minx, miny, -2); // ставим там водосток и отмечаем все что туда будет стекать
   r:=ScanMin( minx, miny); // ищем самую низкую точку ИЗ оставшихся
  end;
end;


begin
  InpData;
  Full;
  OutData;
end.

НО! ДЛЯ ДРУГИХ ВАРИАНТОВ НЕ ТЕСТИРОВАЛ!
Serge_Bliznykov вне форума Ответить с цитированием
Старый 21.03.2019, 14:33   #7
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

ВДОГОНКУ.

для коллекции.
исходный код из пост #1 после лёгкой корректировки тоже работает в PascalABC.NET
Код:
Const
 Nmax=101;
 InpFile='c.in';
 OutFile='c.out';
 
Type
 Int=longint;
 
var
 pole,paint: array[0..Nmax,0..Nmax] of int;
 s: array[1..Nmax*Nmax] of int;
 n,m: int;
 answer,num: int;
 
procedure InpData;
begin
 for var i:=0 to Nmax do
   for var j:=0 to Nmax do pole[i,j] := 63;
 assign(input,InpFile);
 reset(input);
   readln(n,m);
   for var i:=1 to n do
     for var j:=1 to m do
       read(pole[i,j]);
 close(input);
end;
 
procedure go(x,y: int);
begin
  if paint[x,y]<>0 then exit;
  paint[x,y]:=num;
 
  if ((x-1) in [1..N]) and (y in [1..M]) then begin
    if pole[x-1,y]=pole[x,y] then go(x-1,y);
    if pole[x-1,y]<pole[x,y] then s[num]:=1;
  end;
 
  if ((x+1) in [1..N]) and (y in [1..M]) then begin
    if pole[x+1,y]=pole[x,y] then go(x+1,y);
    if pole[x+1,y]<pole[x,y] then s[num]:=1;
  end;
 
  if (x in [1..N]) and ((y-1) in [1..M]) then begin
    if pole[x,y-1]=pole[x,y] then go(x,y-1);
    if pole[x,y-1]<pole[x,y] then s[num]:=1;
  end;
 
  if (x in [1..N]) and ((y+1) in [1..M]) then begin
    if pole[x,y+1]=pole[x,y] then go(x,y+1);
    if pole[x,y+1]<pole[x,y] then s[num]:=1;
  end;
 
end;
 
procedure Solve;
begin
  for var i:=0 to Nmax do
    for var j:=0 to Nmax do paint[i,j] := 0;
  for var i:=1 to Nmax*Nmax do s[i] := 0;
  answer:=0;
  num:=0;
 
  for var i:=1 to n do
    for var j:=1 to m do
      if paint[i,j]=0 then begin
        inc(num);
        go(i,j);
      end;
 
  for var i:=1 to Num do
    if s[i]=0 then inc(answer);
end;
 
procedure OutData;
begin
  assign(output,OutFile);
  rewrite(output);
  writeln(answer);
  close(output);
end;
 
begin
 InpData;
 Solve;
 OutData;
end.
на мой взгляд вариант от evg_m короче и понятней.
Только его нужно погонять на тестах.
Serge_Bliznykov вне форума Ответить с цитированием
Старый 21.03.2019, 14:46   #8
evg_m
Старожил
 
Регистрация: 20.04.2008
Сообщений: 5,515
По умолчанию

Цитата:
ну и циклы в таком разе
for j:=minM to maxM do
а может и не надо циклы менять ?
видимо все таки надо хотя бы в начальном заполнении.
мусора в поле быть не должно.
Код:
procedure InpData(pole: mmmm);
 var
  i,j: integer;
  n, m: integer;
begin
 assign(input,InpFile);
 reset(input);
   readln(n,m);
   for i:=minM to maxM do
     for j:=minM to maxM do
       if (i<1) or (j<1) then // мы не планируем "пользоваться" 0 координатой 
          pole[i,j]:=superH // на всякий случай ставим там границу
       else if (i>n) or (j>m) then // и с другой стороны тоже
         pole[i,j]:=superH; // ставим супервысоту
       else //это точка карты
         read(pole[i,j]); // читаем и записываем
 close(input);
end;
тоже что и у вас.
Цитата:
Но, смотрите, поле у Вас 100x100 и Вы его в стеке целиком передаёте.
процедура рекурсивная, всего несколько вызовов и всё - стек кончился.
а что массив передается в стеке , не как ссылка? (я не знаю, не задумывался об этом).
в случае копирования массива в стек, да согласен целиком и полностью.
а так там всего 100х100 =10 000 вызовов в самом неблагоприятном случае.(полная карта и совершенно плоский рельеф).
программа — запись алгоритма на языке понятном транслятору
evg_m вне форума Ответить с цитированием
Старый 21.03.2019, 15:13   #9
Аватар
Старожил
 
Аватар для Аватар
 
Регистрация: 17.11.2010
Сообщений: 19,042
По умолчанию

const или var для параметра и в стеке будет только ссылка на массив, а не сам целиком
Если бы архитекторы строили здания так, как программисты пишут программы, то первый залетевший дятел разрушил бы цивилизацию
Аватар вне форума Ответить с цитированием
Ответ


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

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Упростить решение Pascal: После каждого ингридента написано его количество, которое нужно добавлять в определенный момент времени, время для каждой части приготовления nobody_nohead Помощь студентам 7 14.12.2016 09:23
Составьте процедуру обнуляющую минимальное количество элементов так, чтобы сумма элементов столбца не превышала заданную KorsD Паскаль, Turbo Pascal, PascalABC.NET 3 16.01.2015 10:03
Матрица минимальное количество сдвигов pascal referent Помощь студентам 1 23.12.2012 01:03
Определить, какое количество цифр числа надо исправить, чтобы исправленное совпадало с обращенным к заданному числу M Krusad Паскаль, Turbo Pascal, PascalABC.NET 2 08.10.2012 12:54
Pascal, графика, нужно построить блок-схему студент АГНИ Паскаль, Turbo Pascal, PascalABC.NET 2 26.05.2012 10:57