Паскаль. Величина пятен

[hon]

Есть файл. Пример файла:

PHP код:

5 5
1 0 1 0 0
0 0 1 1 0
1 0 0 0 0
1 0 0 0 1
1 0 1 0 1 


Первая строка — величина матрицы. (Первая цифра<3, вторая>101.)
Дальше через пробел идет информация о пятне в море. Если пятно есть, то 1, если нет, 0.

Записать в другой файл:
1-я строчка: количество пятен
2-я строчка и дальше: площадь пятна и количество пятен такой площади. Оссортировать строчки 2 и более в порядке возрастания.
Пример:

PHP код:

5
1 2
2 1
3 2 


Вот накинул код, как генерировать данные размером 5х5, и как считать пятна. А как посчитать площадь пятен одинакового размере и из кол-во не знаю.

[hon]

32 просмотра и не одного ответа?

[phomm]

Никогда не ориентируйся на просмотры - это наивно.
Лучше молись, чтобы задача просто кого-то заинтересовала или была в смежной области интересов ))

Меня заинтересовала задача, вот решение. Перевести в паскаль можно, думаю, но я точно не буду это делать.

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

Лицензия. автор - я. делаем что-то с кодом, правило хорошего тона - упомянуть меня, постить куда-то желательно моей ссылкой http://phomm.narod.ru/programs/field.zip , в остальном фривар.

[vvmcpp]

"А как посчитать площадь пятен одинакового размере и из кол-во не знаю."

PHP не знаю но логика такая:
Начнем с количества пятен. Сколько единиц, столько и пятен.
Считаем единицы.
Если пятна одинакового размера, то наверное достаточно будет посчитать размер одного пятна.
"площадь пятна и количество пятен такой площади" - не совсем понятно условие.
Как обозначается площадь в этой матрице? Тоже единицами? .. Но если площадь пятна 0 то его как бы и нет. А там все равно 1.

[Аватар]

Заинтересовали пятна Код phomm посмотрел, даже разбираться не стал. У меня попроще на массивах и тоже delphi

procedure TForm1.Button1Click(Sender: TObject);
var n,m,i,j,c,v,k: Integer;
    a: array of array of TPoint;
    b: array of Integer;
    Changed: Boolean;
procedure SetCount(pi,pj,si,sj: Integer);
begin
  if a[pi,pj].Y=0 then begin a[pi,pj].Y:=a[si,sj].Y; Inc(b[a[si,sj].Y-1]); end
  else if a[pi,pj].Y>a[si,sj].Y then begin a[pi,pj].Y:=a[si,sj].Y; Inc(b[a[si,sj].Y-1]); Dec(b[a[pi,pj].Y-1]); end
  else if a[pi,pj].Y<a[si,sj].Y then begin a[si,sj].Y:=a[pi,pj].Y; Inc(b[a[pi,pj].Y-1]); Dec(b[a[si,sj].Y-1]); end
  else Exit;
  Changed:=True;
end;
begin
  {заполнил массив, с файла вводи сам и единицы сам считай}
  Randomize;
  n:=10+Random(11); //от 10 до 20
  m:=10+Random(11); //от 10 до 20
  SetLength(a,n,m);
  for i:=0 to n-1 do
    for j:=0 to m-1 do begin
      a[i,j].X:=Random(10);
      if a[i,j].X<7 then a[i,j].X:=0 else a[i,j].X:=1; //для 70% нули, остальные 1
      a[i,j].Y:=0;
    end;
  {Собственно анализ пятен}
  c:=0;
  repeat
    Changed:=False;
    for i:=0 to n-1 do
      for j:=0 to m-1 do
        if a[i,j].X=1 then begin
          if (j>0) and (a[i,j-1].Y>0) then SetCount(i,j,i,j-1);
          if (i>0) and (a[i-1,j].Y>0) then SetCount(i,j,i-1,j);
          if (j<m-1) and (a[i,j+1].Y>0) then SetCount(i,j,i,j+1);
          if (i<n-1) and (a[i+1,j].Y>0) then SetCount(i,j,i+1,j);
          if a[i,j].Y=0 then begin
            Inc(c);
            SetLength(b,c);
            a[i,j].Y:=c;
            b[c-1]:=1;
            Changed:=True;
          end;
        end;
  until not Changed;
  {Сортировка}
  for i:=0 to c-2 do
    for j:=i+1 to c-1 do
      if b[j]<b[i] then begin
        v:=b[i];
        b[i]:=b[j];
        b[j]:=v;
      end;
  {Результат в Memo}
  v:=0;
  for i:=0 to c-1 do
    if b[i]>0 then begin
      if b[i]<>v then begin
        if v>0 then Memo1.Lines.Add(Format('по %d пятен %d',[v,k]));
        v:=b[i];
        k:=0;
      end;
      Inc(k);
    end;
  if v>0 then Memo1.Lines.Add(Format('по %d пятен %d',[v,k]));
end;

И в конце облом - теме два года Зато интересно

[phomm]

Да, давно писал программку, было время, ещё был щедрый ))
Я блин старался, а от ТС даже полслова не было, хотя товарищ не однодневный.

Суть алгоритма основана на очереди с рекурсивным заполнением. Двойным циклом идём по массиву, встречаем клетку с пятном, создаём на неё очередь, и запускаем рекурсию с этой клетки, рекурсия обходит все прилегающие клетки (в алгоритме предусмотрена переключалка - учитывать ли клетки соприкасающиеся только сторонами или ещё и углами), и они помечаются ссылкой на очередь, которой они принадлежат. На каждой встреченной клетке рекурсия "пушится" и работает с этой клетки, если у клетки больше некуда ступить (все прилегающие клетки уже помечены какой-то очередью), рекурсия "попается". В конце работы размер очереди и будет показывать площадь пятна. Чтобы посчитать колво пятен одинаковой площади, просто бежим и смотрим где у нас головы очередей (их стартовые клетки) и берём из их свойства размер.
Программа дополнительно снабжена генератором с задаваемыми размерами карты и степенью дисперсности вода-земля.

Аватар, Ваш код тоже непрост, да и я не считаю свой код сложным ))
В Вашем коде меня особенно напряг сетленс в четверном вложенном цикле (у меня, конечно, он тоже по сути есть , в TList.Grow , но не в таком количестве - он по сути за логарифм работает, у Вас за степень).
Мой код конечно на классах, что сложнее, т.к. требовательнее к знаниям, но имхо декомпозиция даёт ощутимую часть понятливости.

Уважаемый vvmcpp, Вы малость были введены в заблуждение, ТС требовался код на паскале, а не пхп.

[Poma][a]

Первая строка — величина матрицы. (Первая цифра<3, вторая>101.)

А кто-нибудь может объяснить про что тут речь? Какая первая цифра? Может число? Тогда что за не соответствие примеру ТС?
Мой вариант..

uses Math;
const
        SIZE = 100;
var
        mtx : array [0..SIZE, 0..SIZE] of Integer;
function Value(x, y : Integer) : Integer;
var
	cnt : Integer;

begin
	cnt := 0;

	if mtx[x-1, y] = 1 then begin
		mtx[x-1, y] := 0;
		Inc(cnt, Value(x-1, y)+1)
	end;

	if mtx[x+1, y] = 1 then begin
		mtx[x+1, y] := 0;
		Inc(cnt, Value(x+1, y)+1)
	end;

	if mtx[x, y-1] = 1 then begin
		mtx[x, y-1] := 0;
		Inc(cnt, Value(x, y-1)+1)
	end;

	if mtx[x, y+1] = 1 then begin
		mtx[x, y+1] := 0;
		Inc(cnt, Value(x, y+1)+1)
	end;

	Value := cnt
end;

var
	a : array [0..SIZE] of Integer;
	n, m, i, j : Integer;

begin
        ReadLn(n, m);


        for i := 1 to SIZE do
		a[i] := 0;

	for i := 1 to n do
		for j := 1 to m do
			Read(mtx[i,j]);

	for i := 0 to n+1 do begin
		mtx[i, 0] := -1; mtx[0, i] := -1;
		mtx[i, n+1] := -1; mtx[n+1, i] := -1
	end;

	for i := 1 to n do
		for j := 1 to m do
			if mtx[i, j] = 1 then begin
                                mtx[i, j] := 0;
				Inc(a[Value(i, j)+1]);
                        end;

	for i := 1 to Max(n, m) do
		if a[i] <> 0 then
			WriteLn(i, ' ', a[i])
end.

[Аватар]

В Вашем коде меня особенно напряг сетленс в четверном вложенном цикле

В третьем. Да, не порядок, лень было статический массив сделать по максимальному кол-ву единиц, код-то на коленке. Собственно тот SetLength и отработает в самом тяжелом случае не более, чем кол-во этих единиц во входной информации в первой итерации repeat. Подозреваю, что мой код проиграет по скорости выполнения. Хотя если все динамические массивы заменить на статические может и нет. Ромаха, свой код на примере 5x5 проверял? На более сложном не пробовал?

[phomm]

Да, извиняюсь , в тройном, сперва глянул код, написал в тройном, потом второй раз проглядел и почему-то показалось что в четверном. Исправляю.
На статику негибко. Если входные данные 1000*1000 и всё забито единичками - пятно будет милионной площади, какой статмассив такое съест (ну как в коде задать в смысле)

Код Ромахи пробовал запустить, поматерился вводя даже те 25 циферок что указаны у тс , по нескольку раз, но так и не добился работы, где-то происходил креш. Переделывать на чтение файла не хочется, но если автор сделает, то погоняю тесты.

Ваш, Аватар, код погонял, не понятно что в исходной картине генерации, посему добавил вывод, ну и плюс чуть увеличил вероятность. Заметка: в мемо установить моноширный шрифт, типа courier new:

for i:=0 to n-1 do
  begin
    for j:=0 to m-1 do begin
      a[i,j].X:=Random(10);
      if a[i,j].X<5 then a[i,j].X:=0 else a[i,j].X:=1; //для 70% нули, остальные 1
      a[i,j].Y:=0;
      Memo1.Text := Memo1.Text + ' ' + Chr(48 + a[i,j].X);
    end;
    Memo1.Text := Memo1.Text + #13#10;
  end;

получил одну такую генерацию:

 0 1 0 1 1 0 0 0 1 1 0 0
 0 0 1 1 1 1 0 1 1 0 0 1
 1 1 1 0 0 1 0 0 0 1 0 0
 1 1 0 1 0 1 1 0 1 0 1 0
 1 1 1 1 0 1 1 1 0 1 0 1
 1 1 1 0 0 1 0 0 1 0 1 0
 1 0 0 0 1 0 1 0 1 0 1 0
 1 0 0 1 1 0 0 1 0 0 0 1
 1 0 0 1 0 0 1 1 0 0 0 0
 1 1 0 0 1 0 1 1 0 1 0 0
 1 1 0 0 1 0 0 1 0 0 1 1
по 1 пятен 12
по 2 пятен 8
по 3 пятен 1
по 4 пятен 1
по 11 пятен 1
по 19 пятен 1

не смог её объяснить, т.к. снизу слева идёт пятно размера больше 19, если считать снизу слева, то 19 как раз в точке x2 y2 будет, и по идее должно идти дальше, но с той точки уже пошло пятно на 11. Также не нашёл пятна на 6 которое внизу посредине.

[Аватар]

Ага, есть такой прокол. Подправил SetCount. Раньше сбрасывал не правильно счетчики

procedure SetCount(pi,pj,si,sj: Integer);
begin
  if a[pi,pj].Y=0 then begin a[pi,pj].Y:=a[si,sj].Y; Inc(b[a[si,sj].Y-1]); end
  else if a[pi,pj].Y>a[si,sj].Y then begin Dec(b[a[pi,pj].Y-1]); a[pi,pj].Y:=a[si,sj].Y; Inc(b[a[si,sj].Y-1]);  end
  else if a[pi,pj].Y<a[si,sj].Y then begin Dec(b[a[si,sj].Y-1]); a[si,sj].Y:=a[pi,pj].Y; Inc(b[a[pi,pj].Y-1]); end
  else Exit;
  Changed:=True;
end;

На статику негибко

Задача то на паскале. И подозреваю, что строчка (Первая цифра<3, вторая>101.) должна говорить об реальных ограничениях на размер массива. Хотя фиг её поймёшь