VPF::SmoothResize (увеличение) - Форум программистов

14SatanA88

Дата 24.1.2012, 11:41 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 393
Регистрация: 13.5.2010

Репутация: 2
Всего: 5

Доброго времени суток, уважаемые программеры.

Использую процедуру SmoothResize.
Уменьшение изображения проходит отлично, а вот при попытке увеличить вываливается с ошибкой "scan line index out of range"

Код


const
  PixelCountMax = 32768;

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

***

procedure SmoothResize(Width, Height : integer; S, D : TBitmap);
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}

Не могу разобраться, в чем дело. Прошу Вашей помощи.

Illusion Dolphin

Дата 24.1.2012, 21:28 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 1198
Регистрация: 3.5.2003

Репутация: 36
Всего: 63

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

Код


type
  TRGB = record
    B, G, R : Byte;
  end;

  ARGB = array [0..32677] of TRGB;
  PARGB = ^ARGB;
  PRGB = ^TRGB;
  PARGBArray = array of PARGB;

  TRGB32 = record
    B, G, R, L : byte;
  end;

  ARGB32 = array [0..32677] of TRGB32;
  PARGB32 = ^ARGB32;
  PRGB32 = ^TRGB32;
  PARGB32Array = array of PARGB32;

Код



procedure Interpolate(X, Y, Width, Height: Integer; Rect: TRect; S, D: TBitmap);
var
  Z1, Z2: single;
  K: Single;
  I, J, SW: Integer;
  Dw, Dh, Xo, Yo: Integer;
  Y1r: Extended;
  XS, XD: array of PARGB;
  XS32, XD32: array of PARGB32;
  Dx, Dy, Dxjx1r: Extended;
  XAW : array of Integer;
  XAWD : array of Extended;
begin
  if not ((S.PixelFormat = pf32bit) and (D.PixelFormat = pf32bit)) then
  begin
    S.PixelFormat := pf24bit;
    D.PixelFormat := pf24bit;
  end;
  D.SetSize(Math.Max(D.Width, X + Width), Math.Max(D.Height, Y + Height));
  SW := S.Width;
  DW := Math.Min(D.Width - X, X + Width);
  DH := Math.Min(D.Height - y, Y + Height);
  DX := Width / (Rect.Right - Rect.Left - 1);
  DY := Height / (Rect.Bottom - Rect.Top - 1);
  if (Dx < 1) and (Dy < 1) then
    Exit;

  if (S.PixelFormat = pf24Bit) then
  begin
    SetLength(Xs, S.Height);
    for I := 0 to S.Height - 1 do
      XS[I] := S.Scanline[I];
    SetLength(Xd, D.Height);
    for I := 0 to D.Height - 1 do
      XD[I] := D.Scanline[I];
  end else
  begin
    SetLength(XS32, S.Height);
    for I := 0 to S.Height - 1 do
      XS32[I] := S.Scanline[I];
    SetLength(XD32, D.Height);
    for I := 0 to D.Height - 1 do
      XD32[I] := D.Scanline[I];
  end;

  SetLength(XAW, Width + 1);
  SetLength(XAWD, Width + 1);
  for I := 0 to Width do
  begin
    XAW[I] := Trunc(I / Dx);
    XAWD[I] := I / Dx - XAW[I];
  end;

  if (S.PixelFormat = pf24Bit) then
  begin
    for I := 0 to Min(Round((Rect.Bottom - Rect.Top - 1) * DY) - 1, DH - 1) do
    begin
      Yo := Trunc(I / Dy) + Rect.Top;
      Y1r := Trunc(I / Dy) * Dy;
      if Yo > S.Height then
        Break;
      if I + Y < 0 then
        Continue;

      for J := 0 to Min(Round((Rect.Right - Rect.Left - 1) * DX) - 1, DW - 1) do
      begin
        Xo := XAW[J] + Rect.Left;
        if Xo > SW then
          Continue;
        if J + X < 0 then
          Continue;

        Dxjx1r := XAWD[J];

        Z1 := (Xs[Yo, Xo + 1].R - Xs[Yo, Xo].R) * Dxjx1r + Xs[Yo, Xo].R;
        Z2 := (Xs[Yo + 1, Xo + 1].R - Xs[Yo + 1, Xo].R) * Dxjx1r + Xs[Yo + 1, Xo].R;
        k := (z2 - Z1) / Dy;
        Xd[I + Y, J + X].R := Round(I * K + Z1 - Y1r * K);

        Z1 := (Xs[Yo, Xo + 1].G - Xs[Yo, Xo].G)* Dxjx1r + Xs[Yo, Xo].G;
        Z2 := (Xs[Yo + 1, Xo + 1].G - Xs[Yo + 1, Xo].G) * Dxjx1r + Xs[Yo + 1, Xo].G;
        K := (Z2 - Z1) / Dy;
        Xd[I + Y, J + X].G := Round(I * K + Z1 - Y1r * K);

        Z1 := (Xs[Yo, Xo + 1].B - Xs[Yo, Xo].B) * Dxjx1r + Xs[Yo, Xo].B;
        Z2 := (Xs[Yo + 1, Xo + 1].B - Xs[Yo + 1, Xo].B)  * Dxjx1r + Xs[Yo + 1, Xo].B;
        K := (Z2 - Z1) / Dy;
        Xd[I + Y, J + X].B := Round(I * K + Z1 - Y1r * K);
      end;
    end;
  end else
  begin
    for I := 0 to Min(Round((Rect.Bottom - Rect.Top - 1) * DY) - 1, DH - 1) do
    begin
      Yo := Trunc(I / Dy) + Rect.Top;
      Y1r := Trunc(I / Dy) * Dy;
      if Yo > S.Height then
        Break;
      if I + Y < 0 then
        Continue;

      for J := 0 to Min(Round((Rect.Right - Rect.Left - 1) * DX) - 1, DW - 1) do
      begin
        Xo := XAW[J] + Rect.Left;
        if Xo > SW then
          Continue;
        if J + X < 0 then
          Continue;

        Dxjx1r := XAWD[J];

        Z1 := (XS32[Yo, Xo + 1].R - XS32[Yo, Xo].R) * Dxjx1r + XS32[Yo, Xo].R;
        Z2 := (XS32[Yo + 1, Xo + 1].R - XS32[Yo + 1, Xo].R) * Dxjx1r + XS32[Yo + 1, Xo].R;
        k := (z2 - Z1) / Dy;
        XD32[I + Y, J + X].R := Round(I * K + Z1 - Y1r * K);

        Z1 := (XS32[Yo, Xo + 1].G - XS32[Yo, Xo].G)* Dxjx1r + XS32[Yo, Xo].G;
        Z2 := (XS32[Yo + 1, Xo + 1].G - XS32[Yo + 1, Xo].G) * Dxjx1r + XS32[Yo + 1, Xo].G;
        K := (Z2 - Z1) / Dy;
        XD32[I + Y, J + X].G := Round(I * K + Z1 - Y1r * K);

        Z1 := (XS32[Yo, Xo + 1].B - XS32[Yo, Xo].B) * Dxjx1r + XS32[Yo, Xo].B;
        Z2 := (XS32[Yo + 1, Xo + 1].B - XS32[Yo + 1, Xo].B)  * Dxjx1r + XS32[Yo + 1, Xo].B;
        K := (Z2 - Z1) / Dy;
        XD32[I + Y, J + X].B := Round(I * K + Z1 - Y1r * K);

        Z1 := (XS32[Yo, Xo + 1].L - XS32[Yo, Xo].L) * Dxjx1r + XS32[Yo, Xo].L;
        Z2 := (XS32[Yo + 1, Xo + 1].L - XS32[Yo + 1, Xo].L)  * Dxjx1r + XS32[Yo + 1, Xo].L;
        K := (Z2 - Z1) / Dy;
        XD32[I + Y, J + X].L := Round(I * K + Z1 - Y1r * K);
      end;
    end;
  end;
end;

--------------------

В мире всего две бесконечности: вселенная и человеческая глупость... На счёт вселенной я не уверен.
Шифрование и организация фотографий - Photo Database 4.5

14SatanA88

Дата 24.1.2012, 22:34 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 393
Регистрация: 13.5.2010

Репутация: 2
Всего: 5

Illusion Dolphin, спасибо
у меня только один вопрос остался
как в этой процедуре используются аргументы X, Y, Rect ?

можно пример вызова?

Illusion Dolphin

Дата 25.1.2012, 20:31 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 1198
Регистрация: 3.5.2003

Репутация: 36
Всего: 63

X, Y, Width, Height - это конечные параметры отображения, область в D.
Rect - это область источника (S) которая будет увеличиваться. Всё начинается с нуля.
Т,е. простой вызов это:

Код


procedure InterpolateSimple(Width, Height: Integer; S, D : TBitmap);
begin
  Interpolate(0, 0, Width, Height, Rect(0, 0, S.Width - 1, S.Height - 1), S, D);
end;

--------------------

14SatanA88

Дата 26.1.2012, 14:00 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 393
Регистрация: 13.5.2010

Репутация: 2
Всего: 5

Illusion Dolphin, спасибо, требуемый результат достигнут.
было бы прекрасно, если бы вы еще разъяснили мне сам алгоритм масштабирования.

14SatanA88

Дата 26.1.2012, 20:44 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 393
Регистрация: 13.5.2010

Репутация: 2
Всего: 5

и еще такой вопрос: как отсюда полностью выбросить Rect?
я всегда буду увеличивать все изображение целиком, поэтому использовать Rect мне не нужно.
сам я пытался избавиться от него, но кроме Access Violation ничего не получилось пока.

Illusion Dolphin

Дата 26.1.2012, 21:13 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 1198
Регистрация: 3.5.2003

Репутация: 36
Всего: 63

Тут алгоритм вот такой http://delphi4all.narod.ru/alg/iminterp.htm только оптимизирован.
"как отсюда полностью выбросить Rect":
Вместо Rect.Top и Rect.Left ставим нули, а Rect.Right и Rect.Bottom - это ширина и высота исходного изображения. В коде заменяете значения и всё. Подробнее - в гугл по слову "интерполяция".

--------------------

14SatanA88

Дата 26.1.2012, 21:38 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 393
Регистрация: 13.5.2010

Репутация: 2
Всего: 5

Illusion Dolphin, благодарю
тему можно закрывать

1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »