Форум программистов [Powered by Invision Power Board]

Код

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.