Модераторы: Poseidon, Snowy, bems, MetalFan
  

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> Работа с массивом. Поиск сгустков единичек 
:(
    Опции темы
Jovi
Дата 22.12.2006, 20:51 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 10
Регистрация: 20.11.2006

Репутация: нет
Всего: нет
Есть такая задачка.

Есть массив 1000 на 1000 из единичек и ноликов.
В нем нужно найти все "сгустки" единичек в количестве до 50 штук и заменить их на нолики.

Под сгустком единичек понимаеются непосредственно прилегающие друг к другу единички вне зависимости от того, с какой стороны они прилегают.

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

Господа, что посоветуете?
Заранее Вам благодарен.
PM MAIL   Вверх
S.A.G.
  Дата 23.12.2006, 00:36 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


не эксперт
***


Профиль
Группа: Завсегдатай
Сообщений: 1339
Регистрация: 20.7.2006
Где: in ad equate

Репутация: нет
Всего: 19
Допустим массив называеться Mas и начинаеться с нуля. Тогда адресация элементов будет в пределах от 0 до 999.

Код

i:= 0; //адресует массив
repeat
  if Mas[i] = 1 then
    begin 
      for k:= i + 1 to 999 do
        if Mas[k] = 0 then
          break;      
      if (k - i < 50) and (Mas[k] = 0) then //последним условием страхуемся от случая когда k = 999
        for j:= i to k - 1 do
          Mas[j]:= 0;
      i:= k + 1
    end;
until i > 999


Ааа блин втыкнул.. это для одномерного массива решение задачи. Надеюсь наведет на какую-то мысль.. Задача должна быть стопудофф решаемая.. просто нужно увеличить размерность а мыслить также.

P.S. Можешь подождать пока кто-нибудь додумаеться или у меня снова появиться желание заглянуть в эту тему. smile

Это сообщение отредактировал(а) main - 23.12.2006, 00:49


--------------------
Вот она задачка: спасти себя от себя самого © Cube
Sometimes good people do evil things © A Simple Plan
PM   Вверх
MetalFan
Дата 23.12.2006, 19:29 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Аццкий Сотона
****


Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128
накидал ради развития алгоритм для замены всех "скоплений" единиц колвом > 1 на нули.
можешь модифицировать для замены с подсчетом)
надо?


--------------------
There are always someone smarter than you...
PM MAIL   Вверх
MetalFan
Дата 25.12.2006, 09:49 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Аццкий Сотона
****


Профиль
Группа: Комодератор
Сообщений: 3815
Регистрация: 2.10.2006
Где: Moscow

Репутация: 62
Всего: 128
вот небольшой примерчик)
"убивает" все скопления единичек кол-вом > 1
Код

unit Unit1;

interface
  uses SysUtils, windows;

const
  C_ArrHigh = 10; //размерность массива C_ArrHigh * C_ArrHigh


type
  TSourceArray = array [1..C_ArrHigh, 1..C_ArrHigh] of byte; //integer

//заменяет все скопления единиц в массиве кол-вом > 1, возвращает кол-во замененных единиц.
function FindReplaceTrueBundle( var Arr: TSourceArray ): Integer;

procedure SaveArrToFile( const AFileName: string; Arr: TSourceArray );

implementation


function FindReplaceNeighbours( var Arr: TSourceArray; AI, AJ, APrevI, APrevJ: Integer ): Integer;
var
  lCount: Integer;
  lNextI, lNextJ: Integer;
  lFirst: Boolean;
begin

  Result := 0;
  if Arr[AI, AJ] = 0 then Exit; //если ноль - то и не смотрим ничего
  lFirst := (APrevI = -1) and (APrevJ = -1); //первая единица, найденная перебором

  //сразу сбрасываем текущий элемент, чтобы не попасть в бесконечную рекурсию в случае
  //  1 1
  //  1 1 b т.п.
  Arr[AI, AJ] := 0;

  if not lFirst  then  //если не первая, значит считаем, что нашли одну единиц
    Result := 1;
  //далее проверяем соседние элементы...
  lNextI := pred( AI );
  lNextJ := AJ;
  if (AI > 1) and (( APrevI <> lNextI) or (APrevJ <> lNextJ)) then
  begin
    lCount := FindReplaceNeighbours( Arr, lNextI, lNextJ, AI, AJ );
    Inc( Result, lCount);
  end;

  lNextI := AI;
  lNextJ := pred( AJ );
  if (AJ > 1) and (( APrevI <> lNextI) or (APrevJ <> lNextJ)) then
  begin
    lCount := FindReplaceNeighbours( Arr, lNextI, lNextJ, AI, AJ );
    Inc( Result, lCount);
  end;

  lNextI := succ(AI);
  lNextJ := AJ;

  if (AI < C_ArrHigh) and (( APrevI <> lNextI) or (APrevJ <> lNextJ)) then
  begin
    lCount := FindReplaceNeighbours( Arr, lNextI, lNextJ, AI, AJ );
    Inc( Result, lCount);
  end;

  lNextI := AI;
  lNextJ := succ( AJ );
  if (AJ < C_ArrHigh)and (( APrevI <> lNextI) or (APrevJ <> lNextJ)) then
  begin
    lCount := FindReplaceNeighbours( Arr, lNextI, lNextJ, AI, AJ );
    Inc( Result, lCount);
  end;
  //

  if lFirst then
    if (Result > 0) then // если первый элемент и найдены соседние - то увеличиваем счетчик
      Inc( Result )
    else
      Arr[AI, AJ] := 1; //иначе восстанавливаем отдельно стоящую единицу
end;

function FindReplaceTrueBundle( var Arr: TSourceArray ): Integer;
  var
    i, j: integer;
    lCount: Integer;
  begin
    Result := 0;
    for i := 1 to C_ArrHigh do
      for j := 1 to C_ArrHigh do
      begin
        lCount := FindReplaceNeighbours( Arr, i, j, -1, -1 );
        Inc( Result, lCount );
      end;
  end;

procedure SaveArrToFile( const AFileName: string; Arr: TSourceArray );
var
  i, j: Integer;
  lTextFile: Text;
  lChr: Char;
begin
  Assign( lTextFile, AFileName );
  try
    Rewrite( lTextFile );
    for i := 1 to C_ArrHigh do
    begin
      for j := 1 to C_ArrHigh do
      begin
        lChr := '0';
        if Arr[ i, j] = 1 then
          lChr := '1';
        Write( ltextfile, lChr, ' ');
      end;
      Writeln( ltextfile );
    end;

  finally
    CloseFile( lTextFile );
  end;
end;

end.



--------------------
There are always someone smarter than you...
PM MAIL   Вверх
Jovi
Дата 26.12.2006, 21:10 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 10
Регистрация: 20.11.2006

Репутация: нет
Всего: нет
Попробую и обязательно напишу ответ.
Я его попробую переделать, чтоб решал мою задачу - увивал все скопления от 1 до 20, скажем, а большие оставлял. Тое сть если представить это в виде картинки - убивал все точки и помехи, а оставлял большие линии и рисунки.
PM MAIL   Вверх
Демо
Дата 27.12.2006, 12:02 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Завсегдатай
Сообщений: 1278
Регистрация: 3.11.2005

Репутация: 30
Всего: 50
Jovi, 

Соседние точки, лежащие рядом по диагонали, учитывать?


--------------------
    
PM MAIL ICQ Skype   Вверх
  
 Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Общие вопросы"
SnowyMetalFan
bemsPoseidon
Rrader

Запрещается!

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делиться вскрытыми компонентами

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи

Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, MetalFan, bems, Poseidon, Rrader.
 
1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Общие вопросы | Следующая тема »

Подписаться на тему | Подписка на этот форум | Скачать/Распечатать тему


 




[ Время генерации скрипта: 0.1102 ]   [ Использовано запросов: 21 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
 По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.