Форум: "Начинающим";
Текущий архив: 2009.08.30;
Скачать: [xml.tar.bz2];

Вниз

Сброс размера динамического массива   Найти похожие ветки 

← →
Художник   (2009-07-03 16:41) [0]

Доброе время суток. Пытаюсь реаллизовать заливку замкнутой области. Но возникла проблема. По непонятной мне причине происходит сброс размера массива. Возможно чегото не учел. Помогите разобраться плз. Привожу всю процедуру. Проблемная строчка, на данный момент, выделена жирным.

procedure SetFill(ZpX, ZpY: integer; Cnv: TCanvas; Col, Bord: TColor; FillRect: TRect);

   function Check(CHKx, CHKy: integer): boolean;
   begin
     if (CHKX > FillRect.Left) and (CHKX < FillRect.Right)
       and (CHKY > FillRect.Top) and (CHKY < FillRect.Bottom) and
       (Cnv.Pixels[CHKX, CHKY] <> Col) and (Cnv.Pixels[CHKX, CHKY] <> Bord)
       then result := true else result := false;
    end;

 var
   arr1: array of TPoint;
   arr2: array of TPoint;
   x, CountArr1, CountArr2: integer;
 begin
   if Check(ZpX, ZpY) then
   begin
   //  setlength(arr2, (FillRect.Right - FillRect.Left) * (FillRect.Bottom - FillRect.Top) * 5);

     setlength(arr1, 2000);
     setlength(arr2, 2000);

     CountArr1 := 0;
     CountArr2 := 0;
     Cnv.Pixels[ZpX, ZpY] := Col;

     if Check(ZpX + 1, ZpY) then
     begin
       inc(CountArr1);

       arr1[CountArr1 - 1].X := ZpX + 1;
       arr1[CountArr1 - 1].Y := ZpY;
     end;

     if Check(ZpX, ZpY + 1) then
     begin
       inc(CountArr1);

       arr1[CountArr1 - 1].X := ZpX; ;
       arr1[CountArr1 - 1].Y := ZpY + 1;
     end;

     if Check(ZpX - 1, ZpY) then
     begin

       inc(CountArr1);
       arr1[CountArr1 - 1].X := ZpX - 1;
       arr1[CountArr1 - 1].Y := ZpY;
     end;

     if Check(ZpX, ZpY - 1) then
     begin
       inc(CountArr1);
       arr1[CountArr1 - 1].X := ZpX; ;
       arr1[CountArr1 - 1].Y := ZpY - 1;
     end;

     while not ((CountArr1 = 0) and (CountArr2 = 0)) do
     begin

       for x := 0 to CountArr1 - 1 do
       begin
         Cnv.Pixels[arr1[x].X, arr1[x].Y] := Col;
         if Check(arr1[x].X + 1, arr1[x].Y) then
         begin
           inc(CountArr2);
           arr2[CountArr2 - 1].X := arr1[x].X + 1;
           arr2[CountArr2 - 1].Y := arr1[x].Y;
         end;

         if Check(arr1[x].X, arr1[x].Y + 1) then
         begin
           inc(CountArr2);
           arr2[CountArr2 - 1].X := arr1[x].X; ;
           arr2[CountArr2 - 1].Y := arr1[x].Y + 1;
         end;

         if Check(arr1[x].X - 1, arr1[x].Y) then
         begin
           inc(CountArr2);
           arr2[CountArr2 - 1].X := arr1[x].X - 1;
           arr2[CountArr2 - 1].Y := arr1[x].Y;
         end;

         if Check(arr1[x].X, arr1[x].Y - 1) then
         begin
           inc(CountArr2);
           arr2[CountArr2 - 1].X := arr1[x].X;
           arr2[CountArr2 - 1].Y := arr1[x].Y - 1;
         end;

       end;
       CountArr1 := 0;

       for x := 0 to CountArr2 - 1 do
       begin

         Cnv.Pixels[arr2[x].X, arr2[x].Y] := Col;

         if Check(arr2[x].X + 1, arr2[x].Y) then
         begin

           inc(CountArr1);
           if length(arr2) < 2000 then showmessage("1-oops");

           arr1[CountArr1 - 1].X := arr2[x].X + 1;

           if length(arr2) < 2000 then
           begin
             showmessage("2-oops");
             Showmessage(inttostr(length(arr2)));
             Showmessage(inttostr(x));
           end;
           arr1[CountArr1 - 1].Y := arr2[x].Y;

         end;

         if Check(arr2[x].X, arr2[x].Y + 1) then
         begin
           inc(CountArr1);
           arr1[CountArr1 - 1].X := arr2[x].X;
           arr1[CountArr1 - 1].Y := arr2[x].Y + 1;
         end;

         if length(arr2) < 2000 then showmessage("3-oops");

         {
         if Check(arr2[x].X - 1, arr2[x].Y) then
         begin
           inc(CountArr1);
           t.X := arr2[x].X - 1;
           t.Y := arr2[x].Y;
           arr1[CountArr1 - 1] := t;
         end;

        if Check(arr2[x].X, arr2[x].Y - 1) then
         begin
           inc(CountArr1);
           t.X := arr2[x].X;
           t.Y := arr2[x].Y - 1;
           arr1[CountArr1 - 1] := t;
         end;    }
       end;
       CountArr2 := 0;
     end;
   end;
 end;


....

bitmap.Width := 20;
 bitmap.Height := 20;
 SetFill(10, 10, bitmap.Canvas, Clred, ClBlack, bitmap.Canvas.ClipRect);
...


---

← →
Sapersky   (2009-07-03 16:58) [1]

if length(arr2) < 2000 then showmessage("1-oops");

Не вижу, где в процедуре меняется размер массива кроме setlength(arr2, 2000); Т.е. непонятно, с чего бы длина уменьшилась. Вероятно, просто точек оказывается больше 2000 (включи Range Check).
И кстати, обычно такие вещи делаются рекурсией.
И через Pixels будет медленно, лучше тогда стандартный FloodFill.

---

← →
Художник   (2009-07-03 17:08) [2]

> Не вижу, где в процедуре меняется размер массива кроме setlength(arr2,
>  2000);


Вот и я не вижу.


> И кстати, обычно такие вещи делаются рекурсией.

До ближайшего переполнения буфера. С очередью надежнее я думаю.


> И через Pixels будет медленно.

Это на момент разработки. Затем будет через ScanLine


> лучше тогда стандартный FloodFill


нее мне это не подходит.


> Вероятно, просто точек оказывается больше 2000 (включи Range
> Check).


А это точно. Функция  Check не проверяет ячейку массива на "занятость". Отсюда и раздуваются Count"ы

благодарю, теперь вроде понятно.

---

← →
Художник   (2009-07-03 17:25) [3]

> Функция  Check не проверяет ячейку массива на "занятость".
>  Отсюда и раздуваются Count"ы


А ее и не нужно проверять.
Просто на момент занесения координат пикселя закрашиваем последний.

Усе пашет.

---

← →
Художник   (2009-07-03 18:50) [4]

Ну вот собсно конечный результат. Может можно еще как оптимизировать?
На Canvas.Pixels внимание не обращать, как и собсно на TCanvas. Это легко меняется на ScanLine.

type
 TPointWord = packed record
   X, Y: Word;
 end;
 procedure SetFill(ZpX, ZpY: integer; Cnv: TCanvas; Col, Bord: TColor; FillRect: TRect);

   procedure PaintPixels(X, Y: integer);
   begin
     Cnv.Pixels[X, Y] := Col;
   end;

   function Check(CHKx, CHKy: integer): boolean;
   begin
     if (CHKX > FillRect.Left) and (CHKX < FillRect.Right)
       and (CHKY > FillRect.Top) and (CHKY < FillRect.Bottom) and
       (Cnv.Pixels[CHKX, CHKY] <> Col) and (Cnv.Pixels[CHKX, CHKY] <> Bord)
       then result := true else result := false;

   end;

 var
   arr1: array of TPointWord;
   arr2: array of TPointWord;
   x, CountArr1, CountArr2: integer;
 begin

   if Check(ZpX, ZpY) then
   begin
     setlength(arr1, 4);
     setlength(arr2, 0);

     CountArr1 := 0;
     CountArr2 := 0;
     PaintPixels(ZpX, ZpY);

     if Check(ZpX + 1, ZpY) then
     begin
       inc(CountArr1);

       arr1[CountArr1 - 1].X := ZpX + 1;
       arr1[CountArr1 - 1].Y := ZpY;
       PaintPixels(arr1[CountArr1 - 1].X, arr1[CountArr1 - 1].Y);
     end;

     if Check(ZpX, ZpY + 1) then
     begin
       inc(CountArr1);

       arr1[CountArr1 - 1].X := ZpX; ;
       arr1[CountArr1 - 1].Y := ZpY + 1;
       PaintPixels(arr1[CountArr1 - 1].X, arr1[CountArr1 - 1].Y);

     end;

     if Check(ZpX - 1, ZpY) then
     begin

       inc(CountArr1);
       arr1[CountArr1 - 1].X := ZpX - 1;
       arr1[CountArr1 - 1].Y := ZpY;
       PaintPixels(arr1[CountArr1 - 1].X, arr1[CountArr1 - 1].Y);

     end;

     if Check(ZpX, ZpY - 1) then
     begin
       inc(CountArr1);
       arr1[CountArr1 - 1].X := ZpX; ;
       arr1[CountArr1 - 1].Y := ZpY - 1;
       PaintPixels(arr1[CountArr1 - 1].X, arr1[CountArr1 - 1].Y);

     end;

     while not ((CountArr1 = 0) and (CountArr2 = 0)) do
     begin
       setlength(arr2, CountArr1 * 4);
       for x := 0 to CountArr1 - 1 do
       begin

         if Check(arr1[x].X + 1, arr1[x].Y) then
         begin
           inc(CountArr2);
           arr2[CountArr2 - 1].X := arr1[x].X + 1;
           arr2[CountArr2 - 1].Y := arr1[x].Y;
           PaintPixels(arr2[CountArr2 - 1].X, arr2[CountArr2 - 1].Y);
         end;

         if Check(arr1[x].X, arr1[x].Y + 1) then
         begin
           inc(CountArr2);
           arr2[CountArr2 - 1].X := arr1[x].X; ;
           arr2[CountArr2 - 1].Y := arr1[x].Y + 1;
           PaintPixels(arr2[CountArr2 - 1].X, arr2[CountArr2 - 1].Y);
         end;

         if Check(arr1[x].X - 1, arr1[x].Y) then
         begin
           inc(CountArr2);
           arr2[CountArr2 - 1].X := arr1[x].X - 1;
           arr2[CountArr2 - 1].Y := arr1[x].Y;
           PaintPixels(arr2[CountArr2 - 1].X, arr2[CountArr2 - 1].Y);
         end;

         if Check(arr1[x].X, arr1[x].Y - 1) then
         begin
           inc(CountArr2);
           arr2[CountArr2 - 1].X := arr1[x].X;
           arr2[CountArr2 - 1].Y := arr1[x].Y - 1;
           PaintPixels(arr2[CountArr2 - 1].X, arr2[CountArr2 - 1].Y);
         end;
       end;

       CountArr1 := 0;
       setlength(arr1, CountArr2 * 4);
       for x := 0 to CountArr2 - 1 do
       begin
         if Check(arr2[x].X + 1, arr2[x].Y) then
         begin
           inc(CountArr1);
           arr1[CountArr1 - 1].X := arr2[x].X + 1;
           arr1[CountArr1 - 1].Y := arr2[x].Y;
           PaintPixels(arr1[CountArr1 - 1].X, arr1[CountArr1 - 1].Y);
         end;

         if Check(arr2[x].X, arr2[x].Y + 1) then
         begin
           inc(CountArr1);
           arr1[CountArr1 - 1].X := arr2[x].X;
           arr1[CountArr1 - 1].Y := arr2[x].Y + 1;
           PaintPixels(arr1[CountArr1 - 1].X, arr1[CountArr1 - 1].Y);
         end;

         if Check(arr2[x].X - 1, arr2[x].Y) then
         begin
           inc(CountArr1);
           arr1[CountArr1 - 1].X := arr2[x].X - 1;
           arr1[CountArr1 - 1].Y := arr2[x].Y;
           PaintPixels(arr1[CountArr1 - 1].X, arr1[CountArr1 - 1].Y);
         end;

         if Check(arr2[x].X, arr2[x].Y - 1) then
         begin
           inc(CountArr1);
           arr1[CountArr1 - 1].X := arr2[x].X;
           arr1[CountArr1 - 1].Y := arr2[x].Y - 1;
           PaintPixels(arr1[CountArr1 - 1].X, arr1[CountArr1 - 1].Y);
         end;
       end;
       CountArr2 := 0;
     end;
     setlength(arr2, 0);
     setlength(arr1, 0);
   end;
 end;

---

← →
Sapersky   (2009-07-03 20:31) [5]

Сугубо эстетическая претензия - очень громоздко, много копипаста. Заполнение из массива с занесением в другой можно выделить в процедуру, собственно, и первичное заполнение можно делать этой же процедурой, если занести начальную точку в один из массивов.
Проверку соседних пикселей можно делать так:


Const
 Offsets : array [0..3] of TPoint =
   ((x: -1; y: 0), (x: 0; y: -1), (x: 1; y: 0), (x: 0; y: 1));

For n:=0 to 3 do begin
 px := x + Offsets[n].x; py := y + Offsets[n].y;
 If Check(px, py) ...
end;


Гораздо компактнее, хотя и не оптимальнее, всё-таки лишний цикл.

setlength с нулём в начале и конце не нужно, оно само делается.

---

← →
Художник   (2009-07-04 10:55) [6]

> занести начальную точку в один из массивов.

...

> Const  Offsets : array [0..3] of TPoint =    ((x: -1; y:
>  0), (x: 0; y: -1), (x: 1; y: 0), (x: 0; y: 1));For n:=0
> to 3 do begin  px := x + Offsets[n].x; py := y + Offsets[n].
> y;  If Check(px, py) ...end;


Во гораздо лучше! Спасибо.


>  хотя и не оптимальнее, всё-таки лишний цикл.


Не думаю, что это критично

---

Страницы: 1 вся ветка

Форум: "Начинающим";
Текущий архив: 2009.08.30;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.49 MB
Время: 0.008 c