Прозрачность PNG в проектах Lazarus ...

[Andreich]

Собствено говоря часть вопроса уже озвучена в названии темы,.. возможно ли такое впринципе. Есть лишь одна небольшая поправка: нужно чтобы была возможность полупрозрачности и сглаживания, т.к. в противном случае PGN не имеет никаких приимуществ по сравнению с тем же BMP.

P.S. Буду признателен за любую информацию.

[Andreich]

Неужели ни у кого нет идей?... Путь это даже будет даже не PNG, а что-то другое, главное чтобы со сглаживанием!

[Павел Ишенин]

А что собственно не работает у вас? Вы пробовали? У меня замечательно работает прозрачность PNG

[Andreich]

Если имеется в виду прозрачность Transparent, то с этим проблем нет. Имеется в виду немного другое: например я нарисовал в Gimp картинку (обыкновенная линия, проведенная под некоторым углом отличным от 90 градусов) затем сохранил изображение с прозрачным фоном и пытаюсь поместить эту картинку на форму... она помещается, но вот сглаженные края линии (то как она выглядела в Gimp) изчезают, становятся ребристыми. Возможно я не совсем корректно выразился, когда сказал "сглаживание", более уместным было бы "антиалиасинг", но я не знаю насколько этот термин рименим к статическому PNG изображению.

[Logo]

Если имеется в виду прозрачность Transparent, то с этим проблем нет. Имеется в виду немного другое: например я нарисовал в Gimp картинку (обыкновенная линия, проведенная под некоторым углом отличным от 90 градусов) затем сохранил изображение с прозрачным фоном и пытаюсь поместить эту картинку на форму... она помещается, но вот сглаженные края линии (то как она выглядела в Gimp) изчезают, становятся ребристыми. Возможно я не совсем корректно выразился, когда сказал "сглаживание", более уместным было бы "антиалиасинг", но я не знаю насколько этот термин рименим к статическому PNG изображению.

Это только с GTK - GTK2 такая проблема, - не работает альфа канал, который отвечает за полупрозрачность и все из этого вытекающее. Сказали, что в релизе 0.9.28 можно не ждать, будет в следующем. В QT работает.
У одного из посетителей этого форума есть реализация этой проблемы, но ему лень сделать патч, говорит, что много переписать придется.

[Andreich]

Это только с GTK - GTK2 такая проблема, - не работает альфа канал, который отвечает за полупрозрачность и все из этого вытекающее. Сказали, что в релизе 0.9.28 можно не ждать, будет в следующем. В QT работает.

А что нужно, чтобы пересобрать Lazarus под Qt?
make в каталоге .../lcl/interfaces/qt выполнил, а вот из IDE он пересобираться не хочет,.. ругается на -lqt4intf (not found).

[Attid]

Andreich
а поискать ?

[Павел Ишенин]

В gtk2 альфа канал работает пока только в TBitBtn и TListView.

[carrots]

Вот столкнулся с этой проблемой, пришлось переписать процедуру прорисовки растровых изображений.

Замените в rasterimage.inc процедуру Draw на

Код: Выделить всё

procedure TRasterImage.Draw(DestCanvas: TCanvas; const DestRect: TRect);
var
  UseMaskHandle: HBitmap;
  SrcDC: hDC;
  DestDC: hDC;
  DstBmp:TBitmap;
  RShift, GShift, BShift, AShift, DstRShift, DstGShift, DstBShift:Integer;
  RWidth, RHeight:integer;
  ix, iy, iyStartByte, dstiyStartByte:integer;
  srcdata, dstdata: PByteArray;
  tmpdc:HDC;
  bmp, old: HBitmap;
  msk: HBitmap;
  FinishX:Integer;
  FinishY:Integer;
  DP, SP:integer;
  SrcPR, DstPR:byte;
  SrcWidthPR,SrcHeightPR:single;
begin
  if (Width=0) or (Height=0)
  then Exit;

  BitmapHandleNeeded;
  if not BitmapHandleAllocated then Exit;

  if Masked then
    UseMaskHandle:=MaskHandle
  else
    UseMaskHandle:=0;

  DestCanvas.Changing;
  DestDC := DestCanvas.GetUpdatedHandle([csHandleValid]);


  if ((WidgetSet.LCLPlatform = lpGtk) or (WidgetSet.LCLPlatform = lpGtk2)) and
    (PixelFormat = pf32bit) and (RawImage.Description.BitsPerPixel = 32) and
     (RawImage.Description.Format = ricfRGBA)  then
  begin

     RWidth:= DestRect.Right-DestRect.Left;
     RHeight:= DestRect.Bottom-DestRect.Top;

     DstBmp := TBitmap.Create;
     DstBmp.PixelFormat:=pf32bit;
     DstBmp.SetSize(RWidth,RHeight);
     DstBmp.Canvas.CopyRect(rect(0,0,DstBmp.Width,DstBmp.Height),DestCanvas,DestRect);
     try
      srcdata:=PByteArray(RawImage.Data);
      dstdata:=PByteArray(DstBmp.RawImage.Data);

      RShift:=RawImage.Description.RedShift div 8;
      GShift:=RawImage.Description.GreenShift div 8;
      BShift:=RawImage.Description.BlueShift div 8;
      AShift:=RawImage.Description.AlphaShift div 8;

      DstRShift:=DstBmp.RawImage.Description.RedShift div 8;
      DstGShift:=DstBmp.RawImage.Description.GreenShift div 8;
      DstBShift:=DstBmp.RawImage.Description.BlueShift div 8;

      FinishY:=min(rHeight,DstBmp.RawImage.Description.Height);
      FinishX:=min(rWidth,DstBmp.RawImage.Description.Width);
      if (Height = rHeight)and(Width = rWidth) then
      begin
        for iy := 0 to FinishY-1 do
        begin
          iyStartByte := iy*RawImage.Description.Width;
          dstiyStartByte := iy*dstBmp.RawImage.Description.Width;
          for ix := 0 to FinishX-1 do
          begin
            DP :=((ix+dstiyStartByte)*4);
            SP :=((ix+iyStartByte)*4);
            SrcPR:=srcdata^[SP+AShift];
            DstPR:=255-SrcPR;
            dstdata^[DP+DstRShift]:=((srcdata^[SP+RShift]*SrcPR)+(dstdata^[DP+DstRShift]*DstPR)) div 255;
            dstdata^[DP+DstGShift]:=((srcdata^[SP+GShift]*SrcPR)+(dstdata^[DP+DstGShift]*DstPR)) div 255;
            dstdata^[DP+DstBShift]:=((srcdata^[SP+BShift]*SrcPR)+(dstdata^[DP+DstBShift]*DstPR)) div 255;
          end;
        end;
      end else
      begin
        SrcWidthPR:=Width/RWidth;
        SrcHeightPR:=Height/RHeight;
        for iy := 0 to FinishY-1 do
        begin
          iyStartByte := trunc(iy*SrcHeightPR)*RawImage.Description.Width;
          dstiyStartByte := iy*dstBmp.RawImage.Description.Width;
          for ix := 0 to FinishX-1 do
          begin
            DP :=((ix+dstiyStartByte)*4);
            SP :=((trunc(ix*SrcWidthPR)+iyStartByte)*4);
            SrcPR:=srcdata^[SP+AShift];
            DstPR:=255-SrcPR;
            dstdata^[DP+RShift]:=((srcdata^[SP+RShift]*SrcPR)+(dstdata^[DP+RShift]*DstPR))div 255;
            dstdata^[DP+GShift]:=((srcdata^[SP+GShift]*SrcPR)+(dstdata^[DP+GShift]*DstPR))div 255;
            dstdata^[DP+BShift]:=((srcdata^[SP+BShift]*SrcPR)+(dstdata^[DP+BShift]*DstPR))div 255;
          end;
        end;
      end;

      WidgetSet.RawImage_CreateBitmaps(dstBmp.RawImage, bmp, msk, false);
      tmpDC := CreateCompatibleDC(DestDC);
      old := SelectObject(tmpDC, bmp);

      StretchMaskBlt(DestDC, DestRect.Left, DestRect.Top, DstBmp.RawImage.Description.Width, DstBmp.RawImage.Description.Height, TmpDC,  0, 0, DstBmp.RawImage.Description.Width, DstBmp.RawImage.Description.Height,
      0, 0,0,DestCanvas.CopyMode);


    finally
      DeleteObject(SelectObject(tmpDC, old));
      DeleteObject(msk);
      DeleteDC(tmpDC);
      DstBmp.Free;
    end;

  end else
  begin
    SrcDC := Canvas.GetUpdatedHandle([csHandleValid]);
    StretchMaskBlt(DestDC,
            DestRect.Left,DestRect.Top,
            DestRect.Right-DestRect.Left,DestRect.Bottom-DestRect.Top,
            SrcDC,0,0,Width,Height, UseMaskHandle,0,0,DestCanvas.CopyMode);
  end;

  DestCanvas.Changed;
end;



и перекопилируйте lazarus.

Тестировал только под Linux, GTK 2, но по идее с остальными системами тоже должно работать.

[Andreich]

Тестировал только под Linux, GTK 2, но по идее с остальными системами тоже должно работать.

После выполнения предложенной последовательности произошло примерно следующее...
(Ubuntu 9.04, Lazarus 0.9.26.3 + Gtk2)

[carrots]

Попробуй этот

Код: Выделить всё

procedure TRasterImage.Draw(DestCanvas: TCanvas; const DestRect: TRect);
var
  UseMaskHandle: HBitmap;
  SrcDC: hDC;
  DestDC: hDC;
  RWidth, RHeight:Integer;
  DstMap: TLazIntfImage;
  DstBmp:TBitmap;
  SrcBmp:TBitmap;
  ix, iy, SrcPos, DstPos:integer;
  srcdata, dstdata, outdata: PByteArray;
  srccolors, dstcolors: PIntegerArray;
  tmpDC: HDC;
  bmp, old: HBitmap;
  msk: HBitmap;
  SrcPR, DstPR:single;
  RShift, GShift, BShift, AShift, DstRShift, DstGShift, DstBShift:Integer;
begin
  if (Width=0) or (Height=0)
  then Exit;

  if PixelFormat = pf32bit then
  begin
    RWidth:=DestRect.Right-DestRect.Left;
    RHeight:=DestRect.Bottom-DestRect.Top;

    SrcBmp := tbitmap(self);
    if (SrcBmp.Width <> RWidth) or (SrcBmp.Height <> RHeight) then
    begin
      SrcBmp := TBitmap.Create;
      SrcBmp.PixelFormat:=pf32bit;
      SrcBmp.RawImage.Description.AlphaShift:=RawImage.Description.AlphaShift;
      SrcBmp.RawImage.Description.RedShift:=RawImage.Description.RedShift;
      SrcBmp.RawImage.Description.GreenShift:=RawImage.Description.GreenShift;
      SrcBmp.RawImage.Description.BlueShift:=RawImage.Description.BlueShift;
      SrcBmp.SetSize(RWidth,RHeight);
      SrcBmp.Canvas.FillRect(0,0,1,1);
      srccolors:=PIntegerArray(RawImage.Data);
      dstcolors:=PIntegerArray(SrcBmp.RawImage.Data);
      for ix := 0 to SrcBmp.Width-1 do
        for iy := 0 to SrcBmp.Height-1 do
          dstcolors^[ix+(iy*SrcBmp.Width)] := srccolors^[((ix*Width)div SrcBmp.Width)+(((iy*Height)div SrcBmp.Height)*Width)];
    end;

    DstBmp := TBitmap.Create;
    DstBmp.PixelFormat:=pf24bit;
    DstBmp.TransparentMode:=tmFixed;
    DstBmp.Transparent:=false;
    DstBmp.Masked:=false;
    DstBmp.SetSize(SrcBmp.Width,SrcBmp.Height);
    DstBmp.Canvas.CopyRect(rect(0,0,DstBmp.Width,DstBmp.Height),DestCanvas,DestRect);
    DstMap := DstBmp.CreateIntfImage;
    try


    srcdata:=PByteArray(SrcBmp.RawImage.Data);
    dstdata:=PByteArray(DstBmp.RawImage.Data);
    outdata:=DstMap.GetDataLineStart(0);
    RShift:=RawImage.Description.RedShift div 8;
    GShift:=RawImage.Description.GreenShift div 8;
    BShift:=RawImage.Description.BlueShift div 8;
    AShift:=RawImage.Description.AlphaShift div 8;

    DstRShift:=DstBmp.RawImage.Description.RedShift div 8;
    DstGShift:=DstBmp.RawImage.Description.GreenShift div 8;
    DstBShift:=DstBmp.RawImage.Description.BlueShift div 8;
    for ix := 0 to (SrcBmp.Width*SrcBmp.Height)-1 do
    begin
      SrcPR:=(srcdata^[(ix*4)+AShift])/256;
      DstPR:=1-SrcPR;
      outdata^[(ix*4)+DstRShift]:=trunc((srcdata^[(ix*4)+RShift]*SrcPR)+(dstdata^[(ix*4)+DstRShift]*DstPR));
      outdata^[(ix*4)+DstGShift]:=trunc((srcdata^[(ix*4)+GShift]*SrcPR)+(dstdata^[(ix*4)+DstGShift]*DstPR));
      outdata^[(ix*4)+DstBShift]:=trunc((srcdata^[(ix*4)+BShift]*SrcPR)+(dstdata^[(ix*4)+DstBShift]*DstPR));
    end;

    DstMap.CreateBitmaps(bmp, msk, false);
    tmpDC := CreateCompatibleDC(DestCanvas.Handle);
    old := SelectObject(tmpDC, bmp);

//    DestCanvas.Changing;

//    BitBlt(DestCanvas.Handle, DestRect.Left, DestRect.Top, DestRect.Right, DestRect.Bottom, tmpDC, 0, 0, SRCCOPY);

//    DestCanvas.Changed;

    DestCanvas.Changing;

      DestDC := DestCanvas.GetUpdatedHandle([csHandleValid]);


      StretchMaskBlt(DestDC,
              DestRect.Left,DestRect.Top,
              DstMap.Width,DstMap.Height,
              tmpDC,0,0,DstMap.Width,DstMap.Height, 0,0,0,DestCanvas.CopyMode);

    DestCanvas.Changed;


    finally
      DeleteObject(SelectObject(tmpDC, old));
      DeleteObject(msk);
      DeleteDC(tmpDC);
      DstMap.Free;
      DstBmp.Free;
      if SrcBmp <> self then SrcBmp.free;
    end;
  end else
  begin

    BitmapHandleNeeded;
    if not BitmapHandleAllocated then Exit;

    if Masked then
      UseMaskHandle:=MaskHandle
    else
      UseMaskHandle:=0;

    SrcDC := Canvas.GetUpdatedHandle([csHandleValid]);
    DestCanvas.Changing;

      DestDC := DestCanvas.GetUpdatedHandle([csHandleValid]);


      StretchMaskBlt(DestDC,
              DestRect.Left,DestRect.Top,
              DestRect.Right-DestRect.Left,DestRect.Bottom-DestRect.Top,
              SrcDC,0,0,Width,Height, UseMaskHandle,0,0,DestCanvas.CopyMode);

    DestCanvas.Changed;

  end;
end;         

Здесь используется предыдущий вариант переноса битов и еще несколько поправок, но по моему лучше первый вариант.
Еще причина может быть в старом lazarus-е, у меня v0.9.27, fpc 2.3.1

[Logo]

Оооо......
Теперь моё приложение приняло человеческий вид

Lazarus 0.9.27 SVN, OS Mandriva.
Все работает на ура и весьма быстро.

carrots, еще компонент анимации, плизззззз....

Добавлено спустя 29 минут 32 секунды:
Под QT со "спецэффектами"

Нужно делать условную компиляцию

[carrots]

Нужно делать условную компиляцию

Этот файл не реагирует на ключ {$IFDEF LCLGTK2}


2Andreich пробовал под suse, mandriva, debian, под gnome и KDE, везде работает, так что причина наверное в старом lazarus и FPC

[Logo]

carrots
Перенеси свою реализацию в файл lazarus/lcl/interfaces/gtk/gtkwidgetset.inc футкция
function TGtkWidgetSet.StretchCopyArea(DestDC: HDC; X, Y, Width, Height: Integer;

Из rasterimage.inc

Код: Выделить всё

procedure TRasterImage.Draw(DestCanvas: TCanvas; const DestRect: TRect);
.....
  StretchMaskBlt(DestDC, // Ссылается на function TGtkWidgetSet.StretchMaskBlt( из gtkwinapi.inc, а затем StretchCopyArea(
....


Вызов идет из function TGtkWidgetSet.StretchMaskBlt(
и из function TGtkWidgetSet.StretchBlt(
Учти там параметры.

Короче StretchMaskBlt для каждого виджетсет реализуется своя, а ключи условной компиляции в rasterimage.inc не действуют.

И еще, я не понял зачем заливать один пиксел :

Код: Выделить всё

...
      SrcBmp.SetSize(RWidth,RHeight);
      SrcBmp.Canvas.FillRect(0,0,1,1); // ??????  Может нужно всю площадь канвы очистить, тогда и шума не будет в старой версии Лазаруса?
...


[carrots]

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

function TGtkWidgetSet.StretchCopyArea в gtkwidgetset.inc

Код: Выделить всё

function TGtkWidgetSet.StretchCopyArea(DestDC: HDC; X, Y, Width, Height: Integer;
  SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer;
  Mask: HBITMAP; XMask, YMask: Integer;
  Rop: Cardinal): Boolean;
var
  SrcDevContext: TGtkDeviceContext absolute SrcDC;
  DstDevContext: TGtkDeviceContext absolute DestDC;
  TempPixmap: PGdkPixmap;
  TempMaskBitmap: PGdkBitmap;
  SizeChange, ROpIsSpecial: Boolean;
  FlipHorz, FlipVert: Boolean;

  function ScaleAndROP(DestGC: PGDKGC;
    Src: PGDKDrawable; SrcPixmap: PGdkDrawable; SrcMaskBitmap: PGdkBitmap): Boolean;
  var
    Depth: Integer;
    ScaleMethod: TGdkInterpType;
    ShrinkWidth, ShrinkHeight: Boolean;
    GC: PGDKGC;
  begin
    {$IFDEF VerboseStretchCopyArea}

    DebugLn('ScaleAndROP START DestGC=',DbgS(DestGC),
      ' SrcPixmap=',DbgS(SrcPixmap),
      ' SrcMaskPixmap=',DbgS(SrcMaskPixmap));
    {$ENDIF}
    Result := False;

    if DestGC = nil
    then begin
      DebugLn('WARNING: [TGtkWidgetSet.StretchCopyArea] Uninitialized DestGC');
      exit;
    end;

    // create a temporary graphic context for the scale and raster operations
    // copy the destination GC values into the temporary GC
    GC := gdk_gc_new(DstDevContext.Drawable);
    gdk_gc_copy(GC, DestGC);

    // clear any previous clipping in the temporary GC
    gdk_gc_set_clip_region(GC, nil);
    gdk_gc_set_clip_rectangle(GC, nil);

    if SizeChange
    then begin
      {$IFDEF VerboseStretchCopyArea}
      Depth:=gdk_visual_get_system^.Depth;
      DebugLn('ScaleAndROP Scaling buffer: '+dbgs(Width),' x '+dbgs(Height),' x '+dbgs(Depth));
      {$ENDIF}

      // calculate ScaleMethod
      {$IFDEF VerboseGtkToDos}{$note use SetStretchBltMode(dc, mode) here}{$ENDIF}
      //GDKPixbuf Scaling is not done in the same way as Windows
      //but by rights ScaleMethod should really be chosen based
      //on the destination device's internal flag
      {GDK_INTERP_NEAREST,GDK_INTERP_TILES,
      GDK_INTERP_BILINEAR,GDK_INTERP_HYPER);}

      ShrinkWidth := Width < SrcWidth;
      ShrinkHeight := Height < SrcHeight;
      if ShrinkWidth and ShrinkHeight
      then ScaleMethod := GDK_INTERP_TILES
      else
        if ShrinkWidth or ShrinkHeight
        then ScaleMethod := GDK_INTERP_BILINEAR//GDK_INTERP_HYPER
        else ScaleMethod := GDK_INTERP_BILINEAR;

      // Scale the src part to a temporary pixmap with the size of the
      // destination rectangle

      Result := ScalePixmapAndMask(GC, ScaleMethod,
                            SrcPixmap, XSrc, YSrc, SrcWidth, SrcHeight,
                            nil, SrcMaskBitmap,
                            Width, Height, FlipHorz, FlipVert, TempPixmap, TempMaskBitmap);
      if not Result
      then DebugLn('WARNING: ScaleAndROP ScalePixmap for pixmap failed');
    end
    else begin
      if ROpIsSpecial
      then begin
        // no scaling, but special ROp

        Depth:=gdk_visual_get_system^.Depth;
        {$IFDEF VerboseStretchCopyArea}
        DebugLn('ScaleAndROP Creating rop buffer: '+dbgs(Width),' x '+dbgs(Height),' x '+dbgs(Depth));
        {$ENDIF}
        TempPixmap := gdk_pixmap_new(nil,SrcWidth,SrcHeight,Depth);
        gdk_window_copy_area(TempPixmap, GC, 0, 0,
           Src, XSrc, YSrc, SrcWidth, SrcHeight);
      end;
      Result := True;
    end;

    // set raster operation in the destination GC
    if Result
    then SetGCRasterOperation(DestGC, ROP);

    gdk_gc_unref(GC);
  end;

  procedure ROPFillBuffer(DC : hDC);
  var
    OldCurrentBrush: PGdiObject;
    Brush : hBrush;
  begin
    if TempPixmap = nil then exit;

    if not ((ROp=WHITENESS) or (ROp=BLACKNESS) or (ROp=DSTINVERT)) then Exit;

    {$IFDEF VerboseStretchCopyArea}
    DebugLn('ROPFillBuffer ROp='+dbgs(ROp));
    {$ENDIF}
    with TGtkDeviceContext(DC) do
    begin
      // Temporarily hold the old brush to
      // replace it with the given brush
      OldCurrentBrush := CurrentBrush;
      if ROP = WHITENESS
      then
        Brush := GetStockObject(WHITE_BRUSH)
      else
        Brush := GetStockObject(BLACK_BRUSH);
      CurrentBrush := PGdiObject(Brush);
      SelectedColors := dcscBrush;

      if not IsNullBrush
      then begin
        gdk_draw_rectangle(TempPixmap, GC, 1, 0, 0, Width, Height);
      end;
      // Restore current brush
      CurrentBrush := OldCurrentBrush;
    end;
  end;

  function SrcDevBitmapToDrawable: Boolean;
  var
    SrcDrawable: PGdkDrawable;
    MskBitmap: PGdkBitmap;
    ClipMask: PGdkBitmap;
    SrcGDIBitmap: PGdiObject;
  begin
    Result:=true;
    {$IFDEF VerboseStretchCopyArea}
    DebugLn('SrcDevBitmapToDrawable Start');
    {$ENDIF}

    SrcGDIBitmap := SrcDevContext.CurrentBitmap;
    if SrcGDIBitmap = nil
    then begin
      SrcDrawable := SrcDevContext.Drawable;
      MskBitmap := nil;
      if SrcDrawable = nil then
      begin
        DebugLn('SrcDevBitmapToDrawable NOTE: SrcDevContext.CurrentBitmap=nil, SrcDevContext.Drawable = nil');
        exit;
      end;
    end
    else begin
      SrcDrawable := SrcGDIBitmap^.GDIPixmapObject.Image;
      MskBitmap := CreateGdkMaskBitmap(HBITMAP(PtrUInt(SrcGDIBitmap)), Mask);
    end;

    {$IFDEF VerboseStretchCopyArea}
    DebugLn('SrcDevBitmapToDrawable SrcPixmap=[',GetWindowDebugReport(SrcPixmap),']',
      ' MaskPixmap=[',GetWindowDebugReport(MaskPixmap),']');
    {$ENDIF}

    if (MskBitmap = nil) and (not SizeChange) and (ROP=SRCCOPY)
    then begin
      // simply copy the area
      {$IFDEF VerboseStretchCopyArea}
      DebugLn('SrcDevBitmapToDrawable Simple copy');
      {$ENDIF}
      gdk_gc_set_function(DstDevContext.GC, GDK_COPY);
      gdk_window_copy_area(DstDevContext.Drawable, DstDevContext.GC, X, Y,
        SrcDrawable, XSrc, YSrc, Width, Height);
      gdk_gc_set_function(DstDevContext.GC, DstDevContext.GetFunction);
      Exit;
    end;


    // perform raster operation and scaling into Scale and fGC
    DstDevContext.SelectedColors := dcscCustom;
    if not ScaleAndROP(DstDevContext.GC, SrcDevContext.Drawable, SrcDrawable, MskBitmap)
    then begin
      DebugLn('WARNING: SrcDevBitmapToDrawable: ScaleAndROP failed');
      Exit;
    end;

    {$IFDEF VerboseStretchCopyArea}
    DebugLn('SrcDevBitmapToDrawable TempPixmap=',DbgS(TempPixmap),' TempMaskPixmap=',DbgS(TempMaskBitmap));
    {$ENDIF}
    if TempPixmap <> nil
    then begin
      SrcDrawable := TempPixmap;
      XSrc := 0;
      YSrc := 0;
      SrcWidth := Width;
      SrcHeight := Height;
    end;
    if TempMaskBitmap <> nil
    then begin
      MskBitmap := TempMaskBitmap;
      XMask := 0;
      YMask := 0;
    end;

    case ROP of
      WHITENESS, BLACKNESS :
        ROPFillBuffer(DestDC);
    end;

    {$IFDEF VerboseStretchCopyArea}
    DebugLn('SrcDevBitmapToDrawable ',
      ' SrcPixmap=',DbgS(SrcPixmap),
      ' XSrc='+dbgs(XSrc),' YSrc='+dbgs(YSrc),' SrcWidth='+dbgs(SrcWidth),' SrcHeight='+dbgs(SrcHeight),
      ' MaskPixmap=',DbgS(MaskPixmap),
      ' XMask='+dbgs(XMask),' YMask='+dbgs(YMask),
      '');
    {$ENDIF}

    // set clipping mask for transparency
    MergeClipping(DstDevContext, DstDevContext.GC, X, Y, Width, Height,
                  MskBitmap, XMask, YMask, ClipMask);

    // draw image
    {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
    gdk_window_copy_area(DstDevContext.Drawable, DstDevContext.GC, X, Y,
      SrcDrawable, XSrc, YSrc, SrcWidth, SrcHeight);
    {$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF}

    // unset clipping mask for transparency
    DstDevContext.ResetGCClipping;
    if ClipMask <> nil
    then gdk_bitmap_unref(ClipMask);

    // restore raster operation to SRCCOPY
    gdk_gc_set_function(DstDevContext.GC, GDK_Copy);

    Result:=True;
  end;

  function DrawableToDrawable: Boolean;
  begin
    {$IFDEF VerboseStretchCopyArea}
    DebugLn('DrawableToDrawable Start');
    {$ENDIF}
    Result:=SrcDevBitmapToDrawable;
  end;

  function PixmapToDrawable: Boolean;
  begin
    {$IFDEF VerboseStretchCopyArea}
    DebugLn('PixmapToDrawable Start');
    {$ENDIF}
    Result:=SrcDevBitmapToDrawable;
  end;

  function PixmapToBitmap: Boolean;
  begin
    DebugLn('WARNING: [TGtkWidgetSet.StretchCopyArea] PixmapToBitmap unimplemented!');
    Result:=false;
  end;

  function BitmapToPixmap: Boolean;
  begin
    DebugLn('WARNING: [TGtkWidgetSet.StretchCopyArea] BitmapToPixmap unimplemented!');
    Result:=false;
  end;

  function Unsupported: Boolean;
  begin
    DebugLn('WARNING: [TGtkWidgetSet.StretchCopyArea] Destination and/or Source unsupported!!');
    Result:=false;
  end;

  //----------
  function NoDrawableToNoDrawable: Boolean;
  begin
    Result := Unsupported;
    if SrcDevContext.CurrentBitmap = nil then Exit;
    if DstDevContext.CurrentBitmap = nil then Exit;

    case SrcDevContext.CurrentBitmap^.GDIBitmapType of
      gbBitmap:
        case DstDevContext.CurrentBitmap^.GDIBitmapType of
          gbBitmap: Result:=DrawableToDrawable;
          gbPixmap: Result:=BitmapToPixmap;
        end;
      gbPixmap:
        case DstDevContext.CurrentBitmap^.GDIBitmapType of
          gbBitmap: Result:=PixmapToBitmap;
          gbPixmap: Result:=DrawableToDrawable;
        end;
    end;
  end;

  function NoDrawableToDrawable: Boolean;
  begin
    Result := Unsupported;
    if SrcDevContext.CurrentBitmap = nil then Exit;

    case SrcDevContext.CurrentBitmap^.GDIBitmapType of
      gbBitmap: Result:=PixmapToDrawable;
      gbPixmap: Result:=PixmapToDrawable;
    end;
  end;

  function DrawableToNoDrawable: Boolean;
  begin
    Result := Unsupported;
    if DstDevContext.CurrentBitmap = nil then Exit;

    case DstDevContext.CurrentBitmap^.GDIBitmapType of
      gbBitmap: Result:=Unsupported;
      gbPixmap: Result:=Unsupported;
    end;
  end;

  procedure RaiseSrcDrawableNil;
  begin
    DebugLn(['RaiseSrcDrawableNil ',GetWidgetDebugReport(SrcDevContext.Widget)]);
    RaiseGDBException(Format('TGtkWidgetSet.StretchCopyArea SrcDC=%p Drawable=nil', [Pointer(SrcDevContext)]));
  end;

  procedure RaiseDestDrawableNil;
  begin
    RaiseGDBException(Format('TGtkWidgetSet.StretchCopyArea DestDC=%p Drawable=nil', [Pointer(DstDevContext)]));
  end;

var
  NewSrcWidth: Integer;
  NewSrcHeight: Integer;
  NewWidth: Integer;
  NewHeight: Integer;
  SrcDCOrigin: TPoint;
  DstDCOrigin: TPoint;
  SrcWholeWidth, SrcWholeHeight: integer;
  DstWholeWidth, DstWholeHeight: integer;

  ix, iy, SrcPos, DstPos, iyStartByte, dstiyStartByte:integer;
  srcdata, dstdata, maskdata: PByteArray;
  srccolors, dstcolors: PIntegerArray;
  DstBmp:TRawImage;
  SrcBmp:TRawImage;
  MaskBmp:TRawImage;
  ResBMPData: array of integer;
  tmpdc:HDC;
  bmp, old: HBitmap;
  msk: HBitmap;
  StartX, FinishX:Integer;
  StartY, FinishY:Integer;
  DP, SP:integer;
  SrcWidthPR,SrcHeightPR:single;
  SrcPR, DstPR:byte;
  RShift, GShift, BShift, AShift, DstRShift, DstGShift, DstBShift:Integer;
begin
  if (Width=0) or (Height=0)
  then Exit;
  if Mask <> 0 then
  begin
   WidgetSet.RawImage_FromDevice(SrcBmp,SrcDC,rect(0,0,SrcWidth,SrcHeight));
   if (SrcBmp.Description.Format = ricfRGBA) and (SrcBmp.Description.BitsPerPixel = 32) then
   begin
     WidgetSet.RawImage_FromDevice(DstBmp,DestDC,rect(x,y,x+Width,y+height));
     WidgetSet.RawImage_FromBitmap(MaskBmp,Mask,0);
     try
      srcdata:=PByteArray(SrcBmp.Data);
      dstdata:=PByteArray(DstBmp.Data);
      maskdata:=PByteArray(MaskBmp.Data);

      RShift:=SrcBmp.Description.RedShift div 8;
      GShift:=SrcBmp.Description.GreenShift div 8;
      BShift:=SrcBmp.Description.BlueShift div 8;
      AShift:=SrcBmp.Description.AlphaShift div 8;

      DstRShift:=DstBmp.Description.RedShift div 8;
      DstGShift:=DstBmp.Description.GreenShift div 8;
      DstBShift:=DstBmp.Description.BlueShift div 8;

      StartY:=max(0,height-DstBmp.Description.Height);
      StartX:=max(0,width-DstBmp.Description.width);
      FinishY:=min(Height,DstBmp.Description.Height);
      FinishX:=min(Width,DstBmp.Description.Width);
      if (SrcHeight = Height)and(SrcWidth = Width) then
      begin
        for iy := 0 to FinishY-1 do
        begin
          iyStartByte := (iy+starty)*srcBmp.Description.Width;
          dstiyStartByte := iy*dstBmp.Description.Width;
          for ix := 0 to FinishX-1 do
          begin
            DP :=((ix+dstiyStartByte)*4);
            SP :=(((ix+StartX)+iyStartByte)*4);
            SrcPR:=maskdata^[SP];
            DstPR:=255-SrcPR;
            dstdata^[DP+RShift]:=((srcdata^[SP+RShift]*SrcPR)+(dstdata^[DP+RShift]*DstPR)) div 255;
            dstdata^[DP+GShift]:=((srcdata^[SP+GShift]*SrcPR)+(dstdata^[DP+GShift]*DstPR)) div 255;
            dstdata^[DP+BShift]:=((srcdata^[SP+BShift]*SrcPR)+(dstdata^[DP+BShift]*DstPR)) div 255;
          end;
        end;
      end else
      begin
        SrcWidthPR:=SrcWidth/Width;
        SrcHeightPR:=SrcHeight/Height;
        for iy := 0 to FinishY-1 do
        begin
          iyStartByte := trunc((iy+starty)*SrcHeightPR)*srcBmp.Description.Width;
          dstiyStartByte := iy*dstBmp.Description.Width;
          for ix := 0 to FinishX-1 do
          begin
            DP :=((ix+dstiyStartByte)*4);
            SP :=((trunc((ix+StartX)*SrcWidthPR)+iyStartByte)*4);
            SrcPR:=maskdata^[SP];
            DstPR:=255-SrcPR;
            dstdata^[DP+RShift]:=((srcdata^[SP+RShift]*SrcPR)+(dstdata^[DP+RShift]*DstPR))div 255;
            dstdata^[DP+GShift]:=((srcdata^[SP+GShift]*SrcPR)+(dstdata^[DP+GShift]*DstPR))div 255;
            dstdata^[DP+BShift]:=((srcdata^[SP+BShift]*SrcPR)+(dstdata^[DP+BShift]*DstPR))div 255;
          end;
        end;
      end;
    WidgetSet.RawImage_CreateBitmaps(dstBmp, bmp, msk, false);
    tmpDC := CreateCompatibleDC(DestDC);
    old := SelectObject(tmpDC, bmp);

    StretchMaskBlt(DestDC, x+StartX, y+StartY, DstBmp.Description.Width, DstBmp.Description.Height, TmpDC, 0, 0, DstBmp.Description.Width, DstBmp.Description.Height,
    0, XMask, YMask, Rop);


      finally
        DeleteObject(SelectObject(tmpDC, old));
        DeleteObject(msk);
        DeleteDC(tmpDC);
        DstBmp.FreeData;
        SrcBmp.FreeData;
        MaskBmp.FreeData;
     end;


   end;
  end else
  begin





  Result := IsValidDC(DestDC) and IsValidDC(SrcDC);
  {$IFDEF VerboseStretchCopyArea}
  DebugLn('StretchCopyArea Start '+dbgs(Result));
  {$ENDIF}
  if not Result then Exit;

  FlipHorz := Width < 0;
  if FlipHorz then
  begin
    Width := -Width;
    X := X - Width;
  end;

  FlipVert := Height < 0;
  if FlipVert then
  begin
    Height := -Height;
    Y := Y - Height;
  end;

  if (Width = 0) or (Height = 0) then exit;
  if (SrcWidth = 0) or (SrcHeight = 0) then exit;

  SizeChange := (Width <> SrcWidth) or (Height <> SrcHeight) or FlipVert or FlipHorz;
  ROpIsSpecial := (Rop <> SRCCOPY);

  SrcDCOrigin := SrcDevContext.Offset;
  Inc(XSrc, SrcDCOrigin.X);
  Inc(YSrc, SrcDCOrigin.Y);
  if SrcDevContext.Drawable = nil then RaiseSrcDrawableNil;
  gdk_window_get_size(PGdkWindow(SrcDevContext.Drawable), @SrcWholeWidth, @SrcWholeHeight);


  DstDCOrigin := DstDevContext.Offset;
  Inc(X, DstDCOrigin.X);
  Inc(Y, DstDCOrigin.Y);
  if DstDevContext.Drawable = nil then RaiseDestDrawableNil;
  gdk_window_get_size(PGdkWindow(DstDevContext.Drawable), @DstWholeWidth, @DstWholeHeight);

  {$IFDEF VerboseStretchCopyArea}
  DebugLn('TGtkWidgetSet.StretchCopyArea BEFORE CLIPPING X='+dbgs(X),' Y='+dbgs(Y),' Width='+dbgs(Width),' Height='+dbgs(Height),
    ' XSrc='+dbgs(XSrc)+' YSrc='+dbgs(YSrc)+' SrcWidth='+dbgs(SrcWidth)+' SrcHeight='+dbgs(SrcHeight),
    ' SrcDrawable=',DbgS(TGtkDeviceContext(SrcDC).Drawable),
    ' SrcOrigin='+dbgs(SrcDCOrigin),
    ' DestDrawable='+DbgS(TGtkDeviceContext(DestDC).Drawable),
    ' DestOrigin='+dbgs(DestDCOrigin),
    ' Mask='+DbgS(Mask)+' XMask='+dbgs(XMask)+' YMask='+dbgs(YMask),
    ' SizeChange='+dbgs(SizeChange)+' ROpIsSpecial='+dbgs(ROpIsSpecial),
    ' DestWhole='+dbgs(DestWholeWidth)+','+dbgs(DestWholeHeight),
    ' SrcWhole='+dbgs(SrcWholeWidth)+','+dbgs(SrcWholeHeight),
    '');
  {$ENDIF}
  {$IFDEF VerboseGtkToDos}{$note use intersectrect here}{$ENDIF}
  if X >= DstWholeWidth then Exit;
  if Y >= DstWholeHeight then exit;
  if X + Width <= 0 then exit;
  if Y + Height <=0 then exit;
  if XSrc >= SrcWholeWidth then Exit;
  if YSrc >= SrcWholeHeight then exit;
  if XSrc + SrcWidth <= 0 then exit;
  if YSrc + SrcHeight <=0 then exit;

  // gdk does not allow copying areas, party laying out of bounds
  // -> clip

  // clip src to the left
  if (XSrc<0) then begin
    NewSrcWidth:=SrcWidth+XSrc;
    NewWidth:=((Width*NewSrcWidth) div SrcWidth);
    {$IFDEF VerboseStretchCopyArea}
    DebugLn('StretchCopyArea Cliping Src to left NewSrcWidth='+dbgs(NewSrcWidth),' NewWidth='+dbgs(NewWidth));
    {$ENDIF}
    if NewWidth = 0 then exit;
    inc(X, Width-NewWidth);
    if X >= DstWholeWidth then exit;
    XSrc:=0;
    SrcWidth := NewSrcWidth;
  end;

  // clip src to the top
  if (YSrc<0) then begin
    NewSrcHeight:=SrcHeight+YSrc;
    NewHeight:=((Height*NewSrcHeight) div SrcHeight);
    {$IFDEF VerboseStretchCopyArea}
    DebugLn('StretchCopyArea Cliping Src to top NewSrcHeight='+dbgs(NewSrcHeight),' NewHeight='+dbgs(NewHeight));
    {$ENDIF}
    if NewHeight = 0 then exit;
    inc(Y, Height - NewHeight);
    if Y >= DstWholeHeight then exit;
    YSrc:=0;
    SrcHeight := NewSrcHeight;
  end;

  // clip src to the right
  if (XSrc+SrcWidth>SrcWholeWidth) then begin
    NewSrcWidth:=SrcWholeWidth-XSrc;
    Width:=((Width*NewSrcWidth) div SrcWidth);
    {$IFDEF VerboseStretchCopyArea}
    DebugLn('StretchCopyArea Cliping Src to right NewSrcWidth='+dbgs(NewSrcWidth),' NewWidth='+dbgs(Width));
    {$ENDIF}
    if (Width=0) then exit;
    if (X+Width<=0) then exit;
    SrcWidth:=NewSrcWidth;
  end;

  // clip src to the bottom
  if (YSrc+SrcHeight>SrcWholeHeight) then begin
    NewSrcHeight:=SrcWholeHeight-YSrc;
    Height:=((Height*NewSrcHeight) div SrcHeight);
    {$IFDEF VerboseStretchCopyArea}
    DebugLn('StretchCopyArea Cliping Src to bottom NewSrcHeight='+dbgs(NewSrcHeight),' NewHeight='+dbgs(Height));
    {$ENDIF}
    if (Height=0) then exit;
    if (Y+Height<=0) then exit;
    SrcHeight:=NewSrcHeight;
  end;

  if Mask = 0
  then begin
    XMask := XSrc;
    YMask := YSrc;
  end;

  // mark temporary scaling/rop buffers as uninitialized
  TempPixmap := nil;
  TempMaskBitmap := nil;

  {$IFDEF VerboseStretchCopyArea}
  write('TGtkWidgetSet.StretchCopyArea AFTER CLIPPING X='+dbgs(X)+' Y='+dbgs(Y)+' Width='+dbgs(Width)+' Height='+dbgs(Height),
    ' XSrc='+dbgs(XSrc),' YSrc='+dbgs(YSrc)+' SrcWidth='+dbgs(SrcWidth)+' SrcHeight='+dbgs(SrcHeight),
    ' SrcDrawable='+DbgS(SrcDevContext.Drawable),
    ' DestDrawable='+DbgS(DstDevContext.Drawable),
    ' Mask='+DbgS(Mask)+' XMask='+dbgs(XMask)+' YMask='+dbgs(YMask),
    ' SizeChange='+dbgs(SizeChange)+' ROpIsSpecial='+dbgs(ROpIsSpecial));
  write(' ROp=');
  case ROp of
    SRCCOPY     : DebugLn('SRCCOPY');
    SRCPAINT    : DebugLn('SRCPAINT');
    SRCAND      : DebugLn('SRCAND');
    SRCINVERT   : DebugLn('SRCINVERT');
    SRCERASE    : DebugLn('SRCERASE');
    NOTSRCCOPY  : DebugLn('NOTSRCCOPY');
    NOTSRCERASE : DebugLn('NOTSRCERASE');
    MERGECOPY   : DebugLn('MERGECOPY');
    MERGEPAINT  : DebugLn('MERGEPAINT');
    PATCOPY     : DebugLn('PATCOPY');
    PATPAINT    : DebugLn('PATPAINT');
    PATINVERT   : DebugLn('PATINVERT');
    DSTINVERT   : DebugLn('DSTINVERT');
    BLACKNESS   : DebugLn('BLACKNESS');
    WHITENESS   : DebugLn('WHITENESS');
  else
    DebugLn('???');
  end;
  {$ENDIF}

  {$IFDEF VerboseGtkToDos}{$note tode remove, earlier checks require drawable <> nil}{$ENDIF}
  if SrcDevContext.Drawable = nil
  then begin
    if DstDevContext.Drawable = nil
    then
      Result := NoDrawableToNoDrawable
    else
      Result := NoDrawableToDrawable;
  end
  else begin
    if DstDevContext.Drawable = nil
    then
      Result := DrawableToNoDrawable
    else
      Result := DrawableToDrawable;
  end;

  if TempPixmap <> nil
  then gdk_pixmap_unref(TempPixmap);
  if TempMaskBitmap <> nil
  then gdk_pixmap_unref(TempMaskBitmap);



  end;


end;


procedure TRasterImage.Draw в rasterimage.inc

Код: Выделить всё

procedure TRasterImage.Draw(DestCanvas: TCanvas; const DestRect: TRect);
var
  UseMaskHandle, Maskbuf: HBitmap;
  MaskBMP: TRawImage;
  BuferedMask: boolean;
  SrcData, MaskData: PByteArray;
  i, AShift: integer;
  SrcDC: hDC;
  DestDC: hDC;
begin
  if (Width=0) or (Height=0)
  then Exit;

  BitmapHandleNeeded;
  if not BitmapHandleAllocated then Exit;

  BuferedMask := false;
  if Masked then
    UseMaskHandle:=MaskHandle
  else
  if (PixelFormat = pf32bit)and(RawImage.Description.BitsPerPixel = 32) then
  begin
    WidgetSet.RawImage_FromBitmap(MaskBMP,BitmapHandle,MaskHandle);
    SrcData:=PByteArray(RawImage.Data);
    MaskData:=PByteArray(MaskBMP.Data);
    AShift:=RawImage.Description.AlphaShift div 8;

    for i := 0 to (Width*Height)-1 do
      MaskData^[i*4] := SrcData^[(i*4)+AShift];

    WidgetSet.RawImage_CreateBitmaps(MaskBMP,UseMaskHandle,Maskbuf);
    MaskBMP.FreeData;
    DeleteObject(Maskbuf);
    BuferedMask := true;
  end else UseMaskHandle:=0;

  SrcDC := Canvas.GetUpdatedHandle([csHandleValid]);
  DestCanvas.Changing;
  DestDC := DestCanvas.GetUpdatedHandle([csHandleValid]);
  StretchMaskBlt(DestDC,
          DestRect.Left,DestRect.Top,
          DestRect.Right-DestRect.Left,DestRect.Bottom-DestRect.Top,
          SrcDC,0,0,Width,Height, UseMaskHandle,0,0,DestCanvas.CopyMode);
  DestCanvas.Changed;

  if BuferedMask then DeleteObject(UseMaskHandle);
end;             

Делалоcь на последнем lazarus и fpc с svn