Недавно натолкнулся на интересную процедурку:

Код

procedure SmoothResize(Width, Height : integer; S,D : TBitmap); type   TRGBArray = array[Word] of TRGBTriple;   pRGBArray = ^TRGBArray; var   x, y: Integer;   xP, yP: Integer;   xP2, yP2: Integer;   SrcLine1, SrcLine2: pRGBArray;   t3: Integer;   z, z2, iz2: Integer;   DstLine: pRGBArray;   DstGap: Integer;   w1, w2, w3, w4: Integer;   Terminating : Boolean; begin   S.PixelFormat := pf24Bit;   D.PixelFormat := pf24Bit;   if Width*Height=0 then   begin    D.Assign(S);    exit;   end;   D.Width:=Width;   D.Height:=Height;   Terminating:=false;   if (S.Width = D.Width) and (S.Height = D.Height) then     D.Assign(S)   else   begin     DstLine := D.ScanLine[0];     DstGap  := Integer(D.ScanLine[1]) - Integer(DstLine);     xP2 := MulDiv(pred(S.Width), $10000, D.Width);     yP2 := MulDiv(pred(S.Height), $10000, D.Height);     yP  := 0;     for y := 0 to pred(D.Height) do     begin       xP := 0;       SrcLine1 := S.ScanLine[yP shr 16];       if (yP shr 16 < pred(S.Height)) then         SrcLine2 := S.ScanLine[succ(yP shr 16)]       else         SrcLine2 := S.ScanLine[yP shr 16];       z2  := succ(yP and $FFFF);       iz2 := succ((not yp) and $FFFF);       for x := 0 to pred(D.Width) do       begin         t3 := xP shr 16;         z  := xP and $FFFF;         w2 := MulDiv(z, iz2, $10000);         w1 := iz2 - w2;         w4 := MulDiv(z, z2, $10000);         w3 := z2 - w4;         DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 +           SrcLine1[t3 + 1].rgbtRed * w2 + SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr 16;         DstLine[x].rgbtGreen := (SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 +           SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr 16;         DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 +           SrcLine1[t3 + 1].rgbtBlue * w2 +SrcLine2[t3].rgbtBlue * w3 +  SrcLine2[t3 + 1].rgbtBlue * w4) shr 16;         Inc(xP, xP2);       end; {for}       Inc(yP, yP2);       DstLine := pRGBArray(Integer(DstLine) + DstGap);     end; {for}   end; {if} end; {SmoothResize}

Всё бы хорошо, но есть два НО:
1) Как это работает и на чём основан алгоритм? я ничего не понимаю толком...
2) Алгоритм "съедает" самые нижние и самые правые пиксели в изображении... Как это исправить? Всё упираетсмя для меня в п.1
Помогите, кто может!

Отличная процедура! Работает вроде быстро, вот только при уменьшении действительно съедает некоторые пикселы, да и уменьшает не очень качественно. Зато увеличивает хорошо.

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

s-mike: а можешь запостить "алгоритмы более качественного уменьшения"? Сама процедурка уменьшает очень качественно при коэффициенте уменьшения 1-2 (НЕ БОЛЕЕ).
И всё же любой алгоритм можно изменить чтобы он не съедал пиксели... Ещё варианты будут?

Цитата(Illusion @ 18.5.2005, 01:15)

а можешь запостить "алгоритмы более качественного уменьшения"?

Я ее включил в поставку Image Controls, модуль ImgCtrlUtils.pas, процедура MakeThumbNail.

Вот она, в общем:

Код

procedure MakeThumbNail(const Src, Dest: TBitmap); type   PRGB24 = ^TRGB24;   TRGB24 = packed record     B: Byte;     G: Byte;     R: Byte;   end; var   x, y, ix, iy: integer;   x1, x2, x3: integer;   xscale, yscale: single;   iRed, iGrn, iBlu, iRatio: Longword;   p, c1, c2, c3, c4, c5: tRGB24;   pt, pt1: pRGB24;   iSrc, iDst, s1: integer;   i, j, r, g, b, tmpY: integer;   RowDest, RowSource, RowSourceStart: integer;   w, h: integer;   dxmin, dymin: integer;   ny1, ny2, ny3: integer;   dx, dy: integer;   lutX, lutY: array of integer; begin   if src.PixelFormat <> pf24bit then src.PixelFormat := pf24bit;   if dest.PixelFormat <> pf24bit then dest.PixelFormat := pf24bit;   w := Dest.Width;   h := Dest.Height;   if (src.Width <= dest.Width) and (src.Height <= dest.Height) then   begin     dest.Assign(src);     exit;   end;   iDst := (w * 24 + 31) and not 31;   iDst := iDst div 8; //BytesPerScanline   iSrc := (Src.Width * 24 + 31) and not 31;   iSrc := iSrc div 8;   xscale := 1 / (w / src.Width);   yscale := 1 / (h / src.Height);   // X lookup table   SetLength(lutX, w);   x1 := 0;   x2 := trunc(xscale);   for x := 0 to w - 1 do   begin     lutX[x] := x2 - x1;     x1 := x2;     x2 := trunc((x + 2) * xscale);   end;   // Y lookup table   SetLength(lutY, h);   x1 := 0;   x2 := trunc(yscale);   for x := 0 to h - 1 do   begin     lutY[x] := x2 - x1;     x1 := x2;     x2 := trunc((x + 2) * yscale);   end;   dec(w);   dec(h);   RowDest := integer(Dest.Scanline[0]);   RowSourceStart := integer(Src.Scanline[0]);   RowSource := RowSourceStart;   for y := 0 to h do   begin     dy := lutY[y];     x1 := 0;     x3 := 0;     for x := 0 to w do     begin       dx:= lutX[x];       iRed:= 0;       iGrn:= 0;       iBlu:= 0;       RowSource := RowSourceStart;       for iy := 1 to dy do       begin         pt := PRGB24(RowSource + x1);         for ix := 1 to dx do         begin           iRed := iRed + pt.R;           iGrn := iGrn + pt.G;           iBlu := iBlu + pt.B;           inc(pt);         end;         RowSource := RowSource - iSrc;       end;       iRatio := 65535 div (dx * dy);       pt1 := PRGB24(RowDest + x3);       pt1.R := (iRed * iRatio) shr 16;       pt1.G := (iGrn * iRatio) shr 16;       pt1.B := (iBlu * iRatio) shr 16;       x1 := x1 + 3 * dx;       inc(x3,3);     end;     RowDest := RowDest - iDst;     RowSourceStart := RowSource;   end;   if dest.Height < 3 then exit;   // Sharpening...   s1 := integer(dest.ScanLine[0]);   iDst := integer(dest.ScanLine[1]) - s1;   ny1 := Integer(s1);   ny2 := ny1 + iDst;   ny3 := ny2 + iDst;   for y := 1 to dest.Height - 2 do   begin     for x := 0 to dest.Width - 3 do     begin       x1 := x * 3;       x2 := x1 + 3;       x3 := x1 + 6;       c1 := pRGB24(ny1 + x1)^;       c2 := pRGB24(ny1 + x3)^;       c3 := pRGB24(ny2 + x2)^;       c4 := pRGB24(ny3 + x1)^;       c5 := pRGB24(ny3 + x3)^;       r := (c1.R + c2.R + (c3.R * -12) + c4.R + c5.R) div -8;       g := (c1.G + c2.G + (c3.G * -12) + c4.G + c5.G) div -8;       b := (c1.B + c2.B + (c3.B * -12) + c4.B + c5.B) div -8;       if r < 0 then r := 0 else if r > 255 then r := 255;       if g < 0 then g := 0 else if g > 255 then g := 255;       if b < 0 then b := 0 else if b > 255 then b := 255;       pt1 := pRGB24(ny2 + x2);       pt1.R := r;       pt1.G := g;       pt1.B := b;     end;     inc(ny1, iDst);     inc(ny2, iDst);     inc(ny3, iDst);   end; end;

s-mike, ты невнимательно тестировал эту процедуру! Я прикрепил изображение с, так сказать, "драйв-тестом". Имелась изображение размером 1024x768, уменьшалось с помощью нескольких алгоритмов до 800х600, там даны 4 изображения на сравление:
1) Хочется сказать, что это оригинал по виду, но это как раз SmoothResize, который нужно подправить
2) Nearest, без коментариев ;)
3) Мой алгоритм, основал на "усреднении" значений, хорош (явно как и твой) при большом коэффициенте уменьшения
4) Твой алгоритм.

Не нужно быть больши профессионалом чтобы сказать что SmoothResize обошёл всех на порядок . Давайте теперь доведём до ума этот алгоритм, т.к. он может понадобится потом ещё людям, а подобный алгоритм ищёт многие

P.S. Только хотел сказать что у тебя изображение получается как бы после шарпен-маск, и только увидел комментарий "// Sharpening..." ))))))

Присоединённый файл ( Кол-во скачиваний: 47 )
 pic.jpg

Illusion Dolphin, как по мне, так для оценки качества лучше использовать картинки с текстом, сразу заметно, какие пиксели съедаются.

s-mike:
а как по мне, то лучше использовать именно то, на что в конечном счёте расчитан алгоритм ;). И только из-за того, что я использовал изображжение, я заметил Sharpen эффект в твоём алгоритме.
По теме:
В интернете нашёл ещё несколько реализаций моего алгоритма, у всех тот же недостаток.
Помогите понять вот (в коде коментарии будут):

Код

procedure XXX2Resize(Width, Height : integer; S,D : TBitmap; CallBack : TBaseEffectCallBackProc = nil); var h,w,x,y,xP,yP,xpnew, yP2,xP2:     Integer; yp2e,xp2e : extended; Read,Read2:  PByteArray; t,z,z2,iz2:  Integer; pc:PBytearray; w1,w2,w3,w4: Integer; src,Dst : Tbitmap; Col1r,col1g,col1b,Col2r,col2g,col2b:   byte; begin  w:=Width;  h:=Height;    pointer(src):=pointer(s);    pointer(Dst):=pointer(d);   Dst.Width:=w;   Dst.Height:=h;   if src.PixelFormat <> pf24bit then src.PixelFormat := pf24bit;   if Dst.PixelFormat <> pf24bit then Dst.PixelFormat := pf24bit;   xP2:=((src.Width-1)shl 15)div (Dst.Width{-1}); // если добавить -1, то изображение получается на метсе, НО корябится цвет!!!   xp2e:=src.Width/Dst.Width;   yp2e:=src.Height/Dst.Height;   yP2:=((src.Height-1)shl 15)div (Dst.Height{-1}); // то же самое   yP:=0;   for y:=0 to Dst.Height-1 do   begin      xP:=0;     Read:=src.ScanLine[yP shr 15];  // т.е. пробовал заменять целые вещественными 0 было предположение что это может быть из-за неточности округления. В результате полностью исчер эффект сглаживания :( //    Read:=src.ScanLine[Round(y*yp2e)];     if yP shr 16<src.Height-1 then  //почему 16? почему не 15?       Read2:=src.ScanLine [yP shr 15+1]     else       Read2:=src.ScanLine [yP shr 15];  // не могу понять это - строчканикогда не вызывается  {   yp:=Round(y*yp2e);    if yP<src.Height-1 then       Read2:=src.ScanLine [yp+1]     else       Read2:=src.ScanLine [yp];   }     pc:=Dst.scanline[y];     z2:=yP and $7FFF;  //а это что за зверь?     iz2:=$8000-z2;  //что за числа странные $7FFF и $8000 и откуда они берутся?     for x:=0 to Dst.Width-1 do     begin //      t:=Round(xp2e*x);       t:=xp shr 15;       Col1r:=Read[t*3];         Col1g:=Read[t*3+1];         Col1b:=Read[t*3+2];       Col2r:=Read2[t*3];         Col2g:=Read2[t*3+1];         Col2b:=Read2[t*3+2];       z:=xP and $7FFF;         w2:=(z*iz2)shr 15;         w1:=iz2-w2;       w4:=(z*z2)shr 15;         w3:=z2-w4;         pc[x*3+2]:=         (Col1b*w1+Read[(t+1)*3+2]*w2+            Col2b*w3+Read2[(t+1)*3+2]*w4)shr 15;         pc[x*3+1]:=         (Col1g*w1+Read[(t+1)*3+1]*w2+            Col2g*w3+Read2[(t+1)*3+1]*w4)shr 15;         pc[x*3]:=         (Col1r*w1+Read2[(t+1)*3]*w2+            Col2r*w3+Read2[(t+1)*3]*w4)shr 15;         Inc(xP,xP2);     end;     Inc(yP,yP2);   end; end;

Кто-нибудь, ответьте на вопросы в коде.

Цитата(Illusion @ 19.5.2005, 09:26)

Кто-нибудь, ответьте на вопросы в коде.

Нихотим...

Код

procedure SmoothResize(Width, Height : integer; S,D : TBitmap); type   TRGBArray = array[Word] of TRGBTriple;   pRGBArray = ^TRGBArray; var   x, y: Integer;   xP, yP: Integer;   Mx, My: Integer;   SrcLine1, SrcLine2: pRGBArray;   t3: Integer;   z, z2, iz2: Integer;   DstLine: pRGBArray;   DstGap: Integer;   w1, w2, w3, w4: Integer; begin   S.PixelFormat := pf24Bit;   D.PixelFormat := pf24Bit;   if Width*Height=0 then   begin    D.Assign(S);    exit;   end;   D.Width:=Width;   D.Height:=Height;   if (S.Width = D.Width) and (S.Height = D.Height) then     D.Assign(S)   else   begin     DstLine := D.ScanLine[0];     DstGap  := Integer(D.ScanLine[1]) - Integer(DstLine);     Mx := MulDiv(pred(S.Width), $10000, D.Width);     My := MulDiv(pred(S.Height), $10000, D.Height);     yP  := My;     for y := 0 to pred(D.Height) do     begin       xP := Mx;       t3:=yP shr 16;       if (t3 < pred(S.Height)) then        begin         dec(t3);         if t3<0 then inc(t3);         SrcLine1 := S.ScanLine[t3];         SrcLine2 := S.ScanLine[succ(t3)];        end else        begin         SrcLine1 := S.ScanLine[S.Height-2];         SrcLine2 := S.ScanLine[S.Height-1];        end;       z2  := succ(yP and $FFFF);       iz2 := succ((not yp) and $FFFF);       for x := 0 to pred(D.Width) do       begin         t3 := xP shr 16;         z  := xP and $FFFF;         w2 := MulDiv(z, iz2, $10000);         w1 := iz2 - w2;         w4 := MulDiv(z, z2, $10000);         w3 := z2 - w4;         dec(t3);         if t3<0 then inc(t3);         if t3>=S.Width-1 then t3:=S.Width-2;         DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 +           SrcLine1[t3 + 1].rgbtRed * w2 + SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr 16;         DstLine[x].rgbtGreen := (SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 +           SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr 16;         DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 +           SrcLine1[t3 + 1].rgbtBlue * w2 +SrcLine2[t3].rgbtBlue * w3 +  SrcLine2[t3 + 1].rgbtBlue * w4) shr 16;         Inc(xP, Mx);       end; {for}       Inc(yP, My);       DstLine := pRGBArray(Integer(DstLine) + DstGap);     end; {for}   end; {if} end; {SmoothResize}

Это сообщение отредактировал(а) Girder - 22.5.2005, 12:53

Girder: я-то думал, раз ты пришёл, то всё вопросы сняты
НО:
Функция страдает теми же болезнями, что и её оригинал, разве что в разных формах.
Пример прикрепил к посту, там 3 изображения:
-на первом и тестирую алгоритм (и не только на нём, он на этом изображении пока всегда виден деффект, изображение имеет маааааленькую рамочку белого цвета шириной 1 пиксель)
-на втором видны деффекты оригинального алгоритма, рамочки нет справа и снизу
-на третьем - увы и ах, но модифицированный алгоритм "съел" белую линию вдоль изображения аж в 3х стороных (сверху, снихзу, и слева, хотя справа всё ОК).
Girder, ещё варианты будут? Если бы я понял вопросы из кода, то сам бы подправил, но я не понимаю алгоритма немного (z2 и iz2).

Присоединённый файл ( Кол-во скачиваний: 17 )
 images.zip

Цитата(Illusion @ 22.5.2005, 13:00)

Girder: я-то думал, раз ты пришёл, то всё вопросы сняты

Ты же говорил:

Цитата

2) Алгоритм "съедает" самые нижние и самые правые пиксели в изображении... Как это исправить?

PS: Я немножко подправил код(см. выше... что бы нулевую строку и столбец не срезал).

Ты лудше подцепи(или пришли мне) тестовую оригенальную картинку в BMP(качество... jpg - не очень).

PS2: Алгоритм основан... на банальном смешивание 4х4(чуть-чуть отличается от банального) и требовать от него не возможного...

Это сообщение отредактировал(а) Girder - 22.5.2005, 13:05

Цитата

Алгоритм основан... на банальном смешивание 4х4

ГмЪ... а в чём отличие? я там выше постил результаты тестирования алгоритмов и знаешь, он отличается в очень хорошую сторону при зуме в 50-100%.
тестирую вот на этих двух картинках, пока их хватает . Одна - просто битмапка, где по краю есть линия шириной в 1 пиксель, вторая - то же самое по сути, но другого размера и разма другого цвета+изображение цветное и по буквам можно судить о качестве сглаживания, картинка изначально в jpeg, но теперь я запостил оригинал. Я для начала всегда уменьшаю до 75% jpeg картинку и на чёрном фоне смотрю, осталась ли что от рамки на фотке .
P.S. Пожалуйста, помого, т.к. тут явно никто другой не моможет

Присоединённый файл ( Кол-во скачиваний: 7 )
 2images.zip

Ну не знаю... тестовые картинки... вроде нормально смотряться... вот с такой правкой:

Код

procedure SmoothResize(Width, Height : integer; S,D : TBitmap); type   TRGBArray = array[Word] of TRGBTriple;   pRGBArray = ^TRGBArray; var   x, y: Integer;   xP, yP: Integer;   Mx, My: Integer;   SrcLine1, SrcLine2: pRGBArray;   t3: Integer;   z, z2, iz2: Integer;   DstLine: pRGBArray;   DstGap: Integer;   w1, w2, w3, w4: Integer; begin   S.PixelFormat := pf24Bit;   D.PixelFormat := pf24Bit;   if Width*Height=0 then   begin    D.Assign(S);    exit;   end;   D.Width:=Width;   D.Height:=Height;   if (S.Width = D.Width) and (S.Height = D.Height) then     D.Assign(S)   else   begin     DstLine := D.ScanLine[0];     DstGap  := Integer(D.ScanLine[1]) - Integer(DstLine);     Mx := MulDiv(S.Width+1, $10000, D.Width);     My := MulDiv(S.Height+1, $10000, D.Height);     yP  := 0;     for y := 0 to pred(D.Height) do     begin       xP := 0;       SrcLine1 := S.ScanLine[yP shr 16];       if (yP shr 16 < pred(S.Height))and(Y<>D.Height-1) then         SrcLine2 := S.ScanLine[succ(yP shr 16)]       else       begin         SrcLine1 := S.ScanLine[S.Height-2];         SrcLine2 := S.ScanLine[S.Height-1];       end;       z2  := succ(yP and $FFFF);       iz2 := succ((not yp) and $FFFF);       for x := 0 to pred(D.Width) do       begin         t3 := xP shr 16;         z  := xP and $FFFF;         w2 := MulDiv(z, iz2, $10000);         w1 := iz2 - w2;         w4 := MulDiv(z, z2, $10000);         w3 := z2 - w4;         if (t3>=S.Width-1)or(x=D.Width-1) then          t3:=S.Width-2;         DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 +           SrcLine1[t3 + 1].rgbtRed * w2 + SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr 16;         DstLine[x].rgbtGreen := (SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 +           SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr 16;         DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 +           SrcLine1[t3 + 1].rgbtBlue * w2 +SrcLine2[t3].rgbtBlue * w3 +  SrcLine2[t3 + 1].rgbtBlue * w4) shr 16;         Inc(xP, Mx);       end; {for}       Inc(yP, My);       DstLine := pRGBArray(Integer(DstLine) + DstGap);     end; {for}   end; {if} end; {SmoothResize}

Это сообщение отредактировал(а) Girder - 22.5.2005, 21:13

Girder: большой респект тебе ! Это то. что нужно, теперь всё ОК.

хм...
Объясните ньюбу как этим пользоваться?

Так пройдёт?

Код

... var  image_1, image_2 : TBitmap; begin image_1.Create;  image_1.LoadFromFile('v:\incomming\P9080219.JPG'); image_2.Create; SmoothResize(800,600,image_1,image_2); Image1.Picture.Bitmap := image_1; end;

Код

uses ... jpeg; procedure TForm1.Button1Click(Sender: TObject); var jpg:TJpegImage;     bm:TBitmap; begin  jpg:=TJpegImage.Create;  bm:=TBitmap.Create;  jpg.LoadFromFile('e:\8\xxx.jpg');  jpg.DIBNeeded;  bm.Assign(jpg);  SmoothResize(100,100,bm,Image1.Picture.Bitmap);  jpg.Free;  bm.Free; end;

Это сообщение отредактировал(а) Girder - 10.10.2005, 16:18