Image shrink by pixel averaging

[peterbone]

Hi

I need a procedure that will shrink a bitmap using pixel averaging for best quality. I have written one myself (below) but I'm sure it can be speeded up and also it doesn't take into account sub-pixels. Can anyone point me to some code? Thanks

procedure Shrink(ARatio : Real ; ABitmap : TBitmap ; var ABitmapOut : TBitmap);
Var
  Lx, Ly : integer;
  LyBox, LxBox : integer;
  TR, TG, TB : integer;
  avR, avG, avB : integer;
  LRowIn, LRowOut : pRGBTripleArray;
  LBoxCount : integer;
  LScanLineBytes : integer;
begin
  LRowOut := ABitmapOut.ScanLine[0];
  LScanLineBytes := Integer(ABitmapOut.Scanline[1]) - Integer(LRowOut);
  for Ly := 0 to ABitmapOut.Height-1 do begin
    for Lx := 0 to ABitmapOut.Width-1 do begin

      TR := 0; TG := 0; TB := 0;
      LBoxCount := 0;
      for LyBox := trunc(Ly*ARatio) to trunc((Ly+1)*ARatio) - 1 do begin
        LRowIn := ABitmap.ScanLine[LyBox];
        for LxBox := trunc(Lx*ARatio) to trunc((Lx+1)*ARatio) - 1 do begin
          TR := TR + LRowIn[LxBox].rgbtRed;
          TG := TG + LRowIn[LxBox].rgbtGreen;
          TB := TB + LRowIn[LxBox].rgbtBlue;
          Inc(LBoxCount);
        end;
      end;
      
      avR := TR div LBoxCount;
      avG := TG div LBoxCount;
      avB := TB div LBoxCount;
      LRowOut[Lx].rgbtBlue  := avB;
      LRowOut[Lx].rgbtGreen := avG;
      LRowOut[Lx].rgbtRed   := avR;
    end;
    Inc(Integer(LRowOut), LScanLineBytes);
  end;
end;

Peter

[Traveler]

I wanted to try your code but recieved an error on pRGBTripleArray.
Does it require D7? I've tried it using D5.

[peterbone]

Sorry, I forgot to put those types in

[pascal]TRGBTripleArray = array[0..100000] of TRGBTriple;
PRGBTripleArray = ^TRGBTripleArray;[/pascal]

I've now made the algorithm much faster by holding the lines for each box in an array which cuts down the number of scanline calls a lot

[pascal]procedure Shrink(ARatio : Real ; ABitmap, ABitmapOut : TBitmap);
Var
Lx, Ly : integer;
LyBox, LxBox, LyBox1, LyBox2, LxBox1, LxBox2 : integer;
TR, TG, TB : integer;
avR, avG, avB : integer;
LRowIn, LRowOut : pRGBTripleArray;
LBoxCount : integer;
LRowBytes : integer;
LBoxRows : array of pRGBTripleArray;
begin
SetLength(LBoxRows, trunc(ARatio)+1);

LRowOut := ABitmapOut.ScanLine[0];
LRowBytes := Integer(ABitmapOut.Scanline[1]) - Integer(LRowOut);
for Ly := 0 to ABitmapOut.Height-1 do begin

LyBox1 := trunc(Ly*ARatio);
LyBox2 := trunc((Ly+1)*ARatio) - 1;

for LyBox := LyBox1 to LyBox2 do
LBoxRows[LyBox-LyBox1] := ABitmap.ScanLine[LyBox];

for Lx := 0 to ABitmapOut.Width-1 do begin

LxBox1 := trunc(Lx*ARatio);
LxBox2 := trunc((Lx+1)*ARatio) - 1;

TR := 0; TG := 0; TB := 0;
LBoxCount := 0;
for LyBox := LyBox1 to LyBox2 do begin
LRowIn := LBoxRows[LyBox-LyBox1];
for LxBox := LxBox1 to LxBox2 do begin
TR := TR + LRowIn[LxBox].rgbtRed;
TG := TG + LRowIn[LxBox].rgbtGreen;
TB := TB + LRowIn[LxBox].rgbtBlue;
Inc(LBoxCount);
end;
end;

avR := TR div LBoxCount;
avG := TG div LBoxCount;
avB := TB div LBoxCount;
LRowOut[Lx].rgbtBlue := avB;
LRowOut[Lx].rgbtGreen := avG;
LRowOut[Lx].rgbtRed := avR;

end;
Inc(Integer(LRowOut), LRowBytes);
end;
end;[/pascal]

I'm amazed at how much this has speeded it up. It's now about 50 times faster! So it looks like I've solved my problem but this thread wasn't a complete waste because you can now use my code.

Peter

[Harry Hunt]

[pascal]
const
MaxPixelCount = 65536;

type
TRGBArray = array[0..MaxPixelCount - 1] of TRGBTriple;
pRGBArray = ^TRGBArray;

procedure Resample(SourceBitmap, DestBitmap: TBitmap);
var
x,y,xP,yP,
yP2,xP2: Integer;
SourceRow, SourceRow2, DestRow: pRGBArray;
t,z,z2,iz2: Integer;
pc: TRGBTriple;
w1,w2,w3,w4: Integer;
Col1,Col2: TRGBTriple;
begin
if (DestBitmap.Width < 1) or (DestBitmap.Height < 1) then
Exit;
if(DestBitmap.Width = SourceBitmap.Width) and (DestBitmap.Height =
SourceBitmap.Height) then
begin
BitBlt(DestBitmap.Canvas.Handle, 0, 0, DestBitmap.Width, DestBitmap.Height,
SourceBitmap.Canvas.Handle, 0, 0, SRCCOPY);
Exit;
end;
xP2 := ((SourceBitmap.Width - 1) shl 15) div DestBitmap.Width;
yP2 := ((SourceBitmap.Height - 1) shl 15) div DestBitmap.Height;
yP := 0;
for y := 0 to DestBitmap.Height - 1 do
begin
xP := 0;
SourceRow := SourceBitmap.ScanLine[yP shr 15];
if yP shr 16 < SourceBitmap.Height - 1 then
SourceRow2 := SourceBitmap.ScanLine[yP shr 15 + 1]
else
SourceRow2 := SourceBitmap.ScanLine[yP shr 15];
z2 := yP and $7FFF;
iz2 := $8000 - z2;
DestRow := DestBitmap.ScanLine[Y];
for x := 0 to DestBitmap.Width - 1 do
begin
t := xP shr 15;
Col1 := SourceRow[t];
Col2 := SourceRow2[t];
z := xP and $7FFF;
w2 := (z * iz2) shr 15;
w1 := iz2 - w2;
w4 := (z * z2) shr 15;
w3 := z2 - w4;
pc.rgbtBlue:= (Col1.rgbtBlue * w1 + SourceRow[T + 1].rgbtBlue * w2 +
Col2.rgbtBlue * w3 + SourceRow2[T + 1].rgbtBlue * w4) shr 15;
pc.rgbtGreen:= (Col1.rgbtGreen * w1 + SourceRow[T + 1].rgbtGreen * w2 +
Col2.rgbtGreen * w3 + SourceRow2[T + 1].rgbtGreen * w4) shr 15;
pc.rgbtRed:= (Col1.rgbtRed * w1 + SourceRow[T + 1].rgbtRed * w2 +
Col2.rgbtRed * w3 + SourceRow2[T + 1].rgbtRed * w4) shr 15;
DestRow[X] := PC;
Inc(xP, xP2);
end;
Inc(yP, yP2);
end;
end;
[/pascal]

This is a routine for bilinear resample. I didn't write it (That's why it's so poorly formatted :lol, but It's pretty fast and gives you great results.

[peterbone]

I think mine's better than that :roll: . The bilinear method averages a box of 2 by 2 pixels from the source bitmap for each pixel in the destination bitmap - but mine averages the maximum number of pixels. So if you reduce by 5 times, it will average a 5 by 5 box of pixels from the source. Also, mine seems to be a lot more optimized because I've reduced the number of scanline calls a lot.
Thanks though.

Peter

[Harry Hunt]

yeah, you're right. Yours is much more optimized. I've been using this one for quite some time because I was too lazy to write my own but I guess I'll write my own in assembler next time I need one.

[Harry Hunt]

I wrote a small benchmarking program for the two resample routines to see how much faster yours is... You can download it here:
http://public.xcessred.com/resamplespeed.zip (3 KB, Source code only).

Yours gave me a division by zero error. I put in an if-statement to bypass that but that seems to make it not work ( :roll: ). I just copied and pasted your code but either I did something wrong or your code has a bug. Maybe you can look at it and tell me why it's not working

My guess is I misinterpreted the ARatio parameter....

[peterbone]

yes, you got the ratio calculation inverted. I agree that your way round makes more sense but the program needs it that way round or it would just have to invert it itself - so it's quicker that way round. It would probably be a better all purpose procedure if the ratio was calculated in the procedure itself but I'm using it to resize multiple bitmaps by the same ratio so I left it as it is to avoid repetition. So at the moment you have to set the bitmap dimensions for source and destination and make sure the ratio is correct for those dimensions before calling the procedure.

I havn't tried your comparison program yet because you didn't include the form.

I also just changed my procedure slightly because I realized that the ABitmapOut doesn't need to be a var - I edited the code in my post above.

Peter

[Harry Hunt]

Thanks for looking at it!

It works now and I uploaded the ZIP file again, this time with the DFM included (stupid me!)

Check it out. "My" routine is actually faster than yours.

[peterbone]

oh yeah, yours is fast! But remember mine isn't doing the same algorithm. Mine's giving much better quality because it's using as much information from the source bitmap as possible. The speed of mine will decrease compared to yours as the shrink ratio increases - and in your demo the shrink ratio is very large.

Peter