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

Вниз

Алгоритм пикселизации.   Найти похожие ветки 

← →
Штотоносец   (2005-03-21 13:21) [0]

Это опять я =) с вопросрм по эффектам. Теперь меня заинтересовал алгоритм пикселизации. Кто-нибудь сможет мне помочь?

---

← →
man1   (2005-03-21 13:23) [1]

есть компонент OrImage, там расшарте много есть

---

← →
Штотоносец   (2005-03-21 13:27) [2]

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

---

← →
man1   (2005-03-21 13:56) [3]

не для меня это сложно

---

← →
Fenik   (2005-03-21 20:03) [4]

> Штотоносец  (21.03.05 13:27) [2]
> Типа, берем смежные пиксели, вычисляем средний цвет... и т.д. > Только более подробно.

А куда подробней? :))
Разбиваем растр на одинаковые прямоугольники (или квадраты - собственно частный случай прямоугольника), берем каждый, вычисляем среднеарифметический цвет по всем его пикселям и закрашиваем текущий прямоугольник найденным для него цветом.

procedure Pixelate(Bitmap: TBitmap; W, H: Word);
var I, J, X, Y: Integer;
   Red, Green, Blue, hX, hY, hW, hH, Count: Cardinal;
   Pixel: pRGBTriple;
begin
 if ((W = 1) and (H = 1)) or (W = 0) or (H = 0)
   or (Bitmap.Width <= 1) or (Bitmap.Height <= 1) then Exit;
 for I := 0 to Pred(Bitmap.Width) div W do
   for J := 0 to Pred(Bitmap.Height) div H do begin
     Count := 0;
     Red := 0;
     Green := 0;
     Blue := 0;
     hX := Min(W * Succ(I), Pred(Bitmap.Width));
     hY := Min(H * Succ(J), Pred(Bitmap.Height));
     hW := I * W;
     hH := J * H;
     for Y := hH to hY do begin
       Pixel := Bitmap.ScanLine[Y];
       Inc(Pixel, hW);
       for X := hW to hX do begin
         with Pixel^ do begin
           Inc(Blue,  rgbtBlue);
           Inc(Green, rgbtGreen);
           Inc(Red,   rgbtRed);
         end;
         Inc(Count);
         Inc(Pixel);
       end;
     end;
     with Bitmap.Canvas do begin
       Brush.Color := RGB(Red div Count, Green div Count, Blue div Count);
       FillRect(Rect(hW, hH, Succ(hX), Succ(hY)));
     end;
   end;
end;

Данная процедура - это решение "в лоб". Можно еще оптимизировать.

---

← →
Fenik ©   (2005-03-21 23:11) [5]

Вот так лучше выглядит:

procedure Pixelate(Bitmap: TBitmap; W, H: Word);
var I, J, X, Y: Integer;
    Width, Height, Left, Top, Right, Bottom: Integer;
    Red, Green, Blue, Count: Cardinal;
    Pixel: pRGBTriple;
begin
  Width := Bitmap.Width - 1;
  Height := Bitmap.Height - 1;
  if ((W = 1) and (H = 1)) or (W = 0) or (H = 0)
    or (Width < 1) or (Height < 1) then Exit;
  Left := 0;
  Right := W;
  for I := 0 to (Width div W) do begin
    Top := 0;
    Bottom := H;
    for J := 0 to (Height div H) do begin
      Count := 0;
      Red := 0;
      Green := 0;
      Blue := 0;
      if Right > Width then Right := Width;
      if Bottom > Height then Bottom := Height;
      for Y := Top to Bottom do begin
        Pixel := Bitmap.ScanLine[Y];
        Inc(Pixel, Left);
        for X := Left to Right do begin
          with Pixel^ do begin
            Inc(Blue,  rgbtBlue);
            Inc(Green, rgbtGreen);
            Inc(Red,   rgbtRed);
          end;
          Inc(Count);
          Inc(Pixel);
        end;
      end;
      with Bitmap.Canvas do begin
        Brush.Color := RGB(Red div Count, Green div Count, Blue div Count);
        FillRect(Rect(Left, Top, Right + 1, Bottom + 1));
      end;
      Inc(Top, H);
      Inc(Bottom, H);
    end;
    Inc(Left, W);
    Inc(Right, W);
  end;
end;

---

← →
Штотоносец   (2005-03-22 13:33) [6]

Почему-то он у меня не работает =(
Возвращает черный экран с цветными вертикальными полосами слева.
Вызов: Pixelate(TempBMP, 2, 2);

---

← →
Штотоносец   (2005-03-22 15:06) [7]

Все, решил задачу так:

procedure PixelsEffect(Bitmap: TBitmap; Hor, Ver: Word);
 function Min(A, B: Integer): Integer;
   begin
     if A<B then Result := A
       else Result := B;
   end;

type
 TRGB=record
   B,G,R: Byte;
 end;
 pRGB=^TRGB;
var
 i,j,x,y,xd,yd,rr,gg,bb,h,hx,hy:Integer;
 Dest:pRGB;
begin
 Bitmap.PixelFormat:=pf24Bit;
 if (Hor=1) and (Ver=1) then Exit;
 xd:=(Bitmap.Width-1) div Hor;
 yd:=(Bitmap.Height-1) div Ver;
 for i:=0 to xd do
   for j:=0 to yd do begin
     h:= 0;
     rr:=0;
     gg:=0;
     bb:=0;
     hx:=Min(Hor*(i + 1),Bitmap.Width-1);
     hy:=Min(Ver*(j + 1),Bitmap.Height-1);
     for y:=j*Ver to hy do begin
       Dest:=Bitmap.ScanLine[y];
       Inc(Dest,i*Hor);
       for x:=i*Hor to hx do begin
         Inc(rr,Dest^.R);
         Inc(gg,Dest^.G);
         Inc(bb,Dest^.B);
         Inc(h);
         Inc(Dest);
       end;
     end;
     Bitmap.Canvas.Brush.Color:=RGB(rr div h, gg div h, bb div h);
     Bitmap.Canvas.FillRect(Rect(i*Hor, j*Ver, hx+1, hy+1));
   end;
end;


---

← →
Анонимщик1   (2005-03-22 15:50) [8]

Решальщик, блин

---

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

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

Наверх

Память: 0.47 MB
Время: 0.041 c