VirtualTreeView 4.8.7 released

[MISV]

Can anyone think of a possible workaround for virtual treeview until a fix is available?

I have tried to repond to onscroll by calling repaint and various similar things (invalidate, update etc.) but that does not work ... even if it redraws it does not redraw the content of the columns

[balazsszekely]

@MISV
Can anyone think of a possible workaround for virtual treeview until a fix is available?

Try the following:
  1. Open VirtualTrees.pas
  2. Locate the following function: procedure SetCanvasOrigin(Canvas: TCanvas; X, Y: Integer);
  3. Just above SetCanvasOrigin paste this:
 

Code: [Select]

  {$IFDEF LCLCarbon}
  function SetWindowOrgEx(DC: HDC; NewX, NewY: Integer; OldPoint: PPoint): Boolean;
  begin
    Result := Boolean(SetViewPortOrgEx(DC, -NewX, -NewY, LPPoint(OldPoint)));
  end;
  {$ENDIF}

  //procedure SetCanvasOrigin(Canvas: TCanvas; X, Y: Integer);
  //...
 

[MISV]

"SetCanvasOrigin" is not available in:
https://svn.code.sf.net/p/lazarus-ccr/svn/components/virtualtreeview-new/branches/4.8/VirtualTrees.pas

However, I can see it in:
https://svn.code.sf.net/p/lazarus-ccr/svn/components/virtualtreeview-new/trunk/
?

From inspecting the source the latter contains the call you are taking about, but no usage of e.g. LCLCarbon meaning I suspect it is a copy of the Delphi compatible virtual trees?

[LuizAmérico]

I don't have mac, but AFAIK, Window Origin is ignored at all in Carbon

[balazsszekely]

@MISV, @LuizAmérico
Yes, instead of the branch I used the trunk, but it's irrelevant in this particular case.  According to the bug report(http://bugs.freepascal.org/view.php?id=28689)
 "SetWindowOrgEx" is not working  under OSX, so I was trying to replace with "SetViewPortOrgEx". Unfortunately both end up calling procedure "TCarbonDeviceContext.UpdateContextOfs" from carboncanvas.pp which fails. I need more time to find out the reason.

[LuizAmérico]

Look at TGtk2WidgetSet.StretchCopyArea method specifically what is done at:

Code: [Select]

if SrcDevContext.HasTransf then
  begin
    // TK: later with shear and rotation error here?
    SrcDevContext.TransfPoint(XSrc, YSrc);
    SrcDevContext.TransfExtent(SrcWidth, SrcHeight);
  end;
  SrcDCOrigin := SrcDevContext.Offset;
  Inc(XSrc, SrcDCOrigin.X);
  Inc(YSrc, SrcDCOrigin.Y);

  if DstDevContext.HasTransf then
  begin
    // TK: later with shear and rotation error here?
    DstDevContext.TransfPoint(X, Y);
    DstDevContext.TransfExtent(Width, Height);
  end;
  DstDCOrigin := DstDevContext.Offset;
  Inc(X, DstDCOrigin.X);
  Inc(Y, DstDCOrigin.Y);

Try to replicate at

Code: [Select]

TCarbonDeviceContext.StretchDraw

[MISV]

Am I correct in that this bug/issue has to be fixed at deeper levels in carbon? (If so, should I crosss posrt this to Carbon group?) If there is anything I should try modifying in virtual treeview source and test it, let me know. I can make the changes and take a screenshot on OSX / Lazarus 1.4.2

[LuizAmérico]

Should be modified in carbon widgetset

[MISV]

I have made a post in Carbon group then since this is really a discussion for Carbon:

http://forum.lazarus.freepascal.org/index.php/board,27.0.html

[MISV]

I will try see if I can investigate Carbon changes, but don't yet fully understand how Lazarus organizes its libraries. How would I easiest go around changing in a widget?

Should I simply make the code changes and then remove the relevant earlier compiled files in appropriate /lib directories and recompile an app? Would this be sufficient in testing a solution?

[LuizAmérico]

Look at TGtk2WidgetSet.StretchCopyArea in gtk2widgetset.inc file for the manipulations (the changes that are done in XSrc and YSrc) that are done inside it through a call to SrcDevContext.TransfPoint

Try to replicate the behavior of TCarbonDeviceContext.StretchDraw in CarbonCanvas file.

[MISV]

Look at TGtk2WidgetSet.StretchCopyArea method specifically what is done at:

Code: Pascal  [Select][+][-]

1. if SrcDevContext.HasTransf then
2.   begin
3.     // TK: later with shear and rotation error here?
4.     SrcDevContext.TransfPoint(XSrc, YSrc);
5.     SrcDevContext.TransfExtent(SrcWidth, SrcHeight);
6.   end;
7.   SrcDCOrigin := SrcDevContext.Offset;
8.   Inc(XSrc, SrcDCOrigin.X);
9.   Inc(YSrc, SrcDCOrigin.Y);
10.  
11.   if DstDevContext.HasTransf then
12.   begin
13.     // TK: later with shear and rotation error here?
14.     DstDevContext.TransfPoint(X, Y);
15.     DstDevContext.TransfExtent(Width, Height);
16.   end;
17.   DstDCOrigin := DstDevContext.Offset;
18.   Inc(X, DstDCOrigin.X);
19.   Inc(Y, DstDCOrigin.Y);
20.  

Look at TGtk2WidgetSet.StretchCopyArea in gtk2widgetset.inc file for the manipulations (the changes that are done in XSrc and YSrc) that are done inside it through a call to SrcDevContext.TransfPoint

Try to replicate the behavior of TCarbonDeviceContext.StretchDraw in CarbonCanvas file.

Thanks!

To solve this issue I will first try locate all the relevant code sections and include them here.

If anyone has specific code changes they want me to test - let me know.


/Developer/lazarus/lcl/intefaces/gtk2/gtk2widgetset.inc

Code: [Select]

{------------------------------------------------------------------------------
  Function: TGtk2WidgetSet.StretchCopyArea
  Params:  DestDC:                The destination devicecontext
           X, Y:                  The left/top corner of the destination rectangle
           Width, Height:         The size of the destination rectangle
           SrcDC:                 The source devicecontext
           XSrc, YSrc:            The left/top corner of the source rectangle
           SrcWidth, SrcHeight:   The size of the source rectangle
           Mask:                  An optional mask
           XMask, YMask:          Only used if Mask<>nil
           Rop:                   The raster operation to be performed
  Returns: True if succesful

  The StretchBlt function copies a bitmap from a source rectangle into a
  destination rectangle using the specified raster operation. If needed, it
  resizes the bitmap to fit the dimensions of the destination rectangle.
  Sizing is done according to the stretching mode currently set in the
  destination device context.
  If SrcDC contains a mask the pixmap will be copied with this transparency.

  ToDo:
    Mirroring
    Extended NonDrawable support (Image, Bitmap, etc)
    Scale mask
 ------------------------------------------------------------------------------}
function TGtk2WidgetSet.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;

//--
// NOTE: lots of sub functions removed here
//--

var
  NewSrcWidth: Integer;
  NewSrcHeight: Integer;
  NewWidth: Integer;
  NewHeight: Integer;
  SrcDCOrigin: TPoint;
  DstDCOrigin: TPoint;
  SrcWholeWidth, SrcWholeHeight: integer;
  DstWholeWidth, DstWholeHeight: integer;
begin
  Result := IsValidDC(DestDC) and IsValidDC(SrcDC);
  {$IFDEF VerboseStretchCopyArea}
  DebugLn('StretchCopyArea Start '+dbgs(Result));
  {$ENDIF}
  if not Result then Exit;

  if SrcDevContext.HasTransf then
  begin
    // TK: later with shear and rotation error here?
    SrcDevContext.TransfPoint(XSrc, YSrc);
    SrcDevContext.TransfExtent(SrcWidth, SrcHeight);
  end;
  SrcDCOrigin := SrcDevContext.Offset;
  Inc(XSrc, SrcDCOrigin.X);
  Inc(YSrc, SrcDCOrigin.Y);

  if DstDevContext.HasTransf then
  begin
    // TK: later with shear and rotation error here?
    DstDevContext.TransfPoint(X, Y);
    DstDevContext.TransfExtent(Width, Height);
  end;
  DstDCOrigin := DstDevContext.Offset;
  Inc(X, DstDCOrigin.X);
  Inc(Y, DstDCOrigin.Y);

  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);

  if SrcDevContext.Drawable = nil then RaiseSrcDrawableNil;
  gdk_window_get_size(PGdkWindow(SrcDevContext.Drawable), @SrcWholeWidth, @SrcWholeHeight);


  if DstDevContext.Drawable = nil then RaiseDestDrawableNil;
  gdk_window_get_size(PGdkWindow(DstDevContext.Drawable), @DstWholeWidth, @DstWholeHeight);

  {$IFDEF VerboseStretchCopyArea}
  DebugLn('TGtk2WidgetSet.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(DstDCOrigin),
    ' Mask='+DbgS(Mask)+' XMask='+dbgs(XMask)+' YMask='+dbgs(YMask),
    ' SizeChange='+dbgs(SizeChange)+' ROpIsSpecial='+dbgs(ROpIsSpecial),
    ' DestWhole='+dbgs(DstWholeWidth)+','+dbgs(DstWholeHeight),
    ' 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('TGtk2WidgetSet.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;


/Developer/lazarus/lcl/intefaces/gtk2/gtk2devicecontext.inc

Code: [Select]

procedure TGtkDeviceContext.TransfPoint(var X1, Y1: Integer);
begin
  // to do: put affine transformation here (for all Transf.. methods)
  X1 := MulDiv(X1, FViewPortExt.x, FWindowExt.x) + FViewPortOrg.x - FWindowOrg.x;
  Y1 := MulDiv(Y1, FViewPortExt.y, FWindowExt.y) + FViewPortOrg.y - FWindowOrg.y;
end;


/Developer/lazarus/lcl/intefaces/carbon/CarbonCanvas.pp

Code: [Select]

{------------------------------------------------------------------------------
  Method:  StretchMaskBlt
  Params:  X, Y                  - Left/top corner of the destination rectangle
           Width, Height         - Size of the destination rectangle
           SrcDC                 - Carbon device context
           XSrc, YSrc            - Left/top corner of the source rectangle
           SrcWidth, SrcHeight   - Size of the source rectangle
           Mask                  - mask bitmap
           XMask, YMask          - Left/top corner of the mask rectangle
           Rop                   - Raster operation to be performed (TODO)
  Returns: If the function succeeds

  Copies a bitmap from a source rectangle into a destination rectangle using
  the specified raster operations. If needed it resizes the bitmap to
  fit the dimensions of the destination rectangle. Sizing is done according to
  the stretching mode currently set in the destination device context.
  TODO: copy from any canvas
        ROP
        stretch mode (should be set by winapi call in DC (MWE))
 ------------------------------------------------------------------------------}
function TCarbonDeviceContext.StretchDraw(X, Y, Width, Height: Integer;
  SrcDC: TCarbonBitmapContext; XSrc, YSrc, SrcWidth, SrcHeight: Integer;
  Msk: TCarbonBitmap; XMsk, YMsk: Integer; Rop: DWORD): Boolean;
var
  Image, MskImage: CGImageRef;
  SubImage, SubMask: Boolean;
  Bitmap: TCarbonBitmap;
  LayRect, DstRect: CGRect;
  ImgRect: CGRect;
  LayerContext: CGContextRef;
  Layer: CGLayerRef;
  UseLayer: Boolean;
begin
  Result := False;
 
  Image := nil;
  Bitmap := SrcDC.GetBitmap;
  if Bitmap <> nil then Image := Bitmap.CGImage;

  if Image = nil then Exit;

  DstRect := CGRectMake(X, Y, Abs(Width), Abs(Height));

  SubMask := (Msk <> nil)
         and (Msk.CGImage <> nil)
         and (  (XMsk <> 0)
             or (YMsk <> 0)
             or (Msk.Width <> SrcWidth)
             or (Msk.Height <> SrcHeight));

  SubImage := ((Msk <> nil) and (Msk.CGImage <> nil))
           or (XSrc <> 0)
           or (YSrc <> 0)
           or (SrcWidth <> Bitmap.Width)
           or (SrcHeight <> Bitmap.Height);


  if SubMask then
    MskImage := Msk.CreateSubImage(Bounds(XMsk, YMsk, SrcWidth, SrcHeight))
  else
    if Msk <> nil then MskImage := Msk.CGImage
    else MskImage := nil;

  if SubImage then
    Image := Bitmap.CreateSubImage(Bounds(XSrc, YSrc, SrcWidth, SrcHeight));


  UseLayer:=Assigned(MskImage)
            or (CGImageGetWidth(Image){%H-}<>SrcWidth)
            or (CGImageGetHeight(Image){%H-}<>SrcHeight);

  try
    if not UseLayer then
    begin
      // Normal drawing
      Result := DrawCGImage(X, Y, Width, Height, Image);
    end
    else
    begin
      // use temp layer to mask source image
      // todo find a way to mask "hard" when stretching, now some soft remains are visible
      LayRect := CGRectMake(0, 0, SrcWidth, SrcHeight);
      Layer := CGLayerCreateWithContext(SrcDC.CGContext, LayRect.size, nil);

      // the sub-image is out of edges
      if (CGImageGetWidth(Image){%H-}<>SrcWidth) or (CGImageGetHeight(Image){%H-}<>SrcHeight) then
      begin
        with ImgRect do
          if XSrc<0 then origin.x:=SrcWidth-CGImageGetWidth(Image) else origin.x:=0;
        with ImgRect do
          if YSrc<0 then origin.y:=0 else origin.y:=SrcHeight-CGImageGetHeight(Image);

        ImgRect.size.width:=CGImageGetWidth(Image);
        ImgRect.size.height:=CGImageGetHeight(Image);
      end
      else
        ImgRect:=LayRect;

      try
        LayerContext := CGLayerGetContext(Layer);
        CGContextScaleCTM(LayerContext, 1, -1);
        CGContextTranslateCTM(LayerContext, 0, -SrcHeight);

        SetCGFillping(LayerContext, Width, Height);
        if Assigned(MskImage) then CGContextClipToMask(LayerContext, ImgRect, MskImage);
        CGContextDrawImage(LayerContext, ImgRect, Image);

        CGContextDrawLayerInRect(CGContext, DstRect, Layer);
       
        Result := True;
      finally
        CGLayerRelease(Layer);
      end;
    end;

  finally
    if SubImage then CGImageRelease(Image);
    if SubMask then CGImageRelease(MskImage);
  end;
 
  //DebugLn('StretchMaskBlt succeeds: ', Format('Dest %d Src %d X %d Y %d',
  //  [Integer(CGContext),
  //  Integer(Image),
  //  X, Y]));
end;


/Developer/lazarus/lcl/intefaces/carbon/CarbonCanvas.pp

Code: [Select]

procedure TCarbonDeviceContext.SetWindowOfs(const AWindowOfs: TPoint);
begin
  UpdateContextOfs(AWindowOfs, ViewPortOfs);
end;


/Developer/lazarus/lcl/intefaces/carbon/CarbonCanvas.pp

Code: [Select]

procedure TCarbonDeviceContext.UpdateContextOfs(const AWindowOfs, AViewOfs: TPoint);
var
  dx, dy: Integer;
begin
  if isSamePoint(AWindowOfs, fWindowOfs) and isSamePoint(AViewOfs, fViewPortOfs) then Exit;
  GetWindowViewTranslate(FWindowOfs, FViewPortOfs, dx{%H-}, dy{%H-});
  CGContextTranslateCTM(CGContext, -dx, -dy);

  FWindowOfs := AWindowOfs;
  FViewPortOfs := AViewOfs;
  GetWindowViewTranslate(FWindowOfs, FViewPortOfs, dx, dy);
  CGContextTranslateCTM(CGContext, dx, dy);
end;


For reference, here is the bug report by Luiz:
http://bugs.freepascal.org/view.php?id=28689

[freeman35]

JAM software share Virtual-TreeView in github
https://github.com/Virtual-TreeView/Virtual-TreeView

I copied from there:

Feature Requests
We currently focus on reducing the number of reported bugs and getting Virtual Treeview stable. Feature Requests will most likely not processed at the moment. We are only going to process enhancement requests if the new feature is of general interest and a source code patch based on the latest SVN revision is attached to the report. Please mark feature requests with the flag "Enhancement".

Is that mean(underlined) can we use this codes under lazarus ?

[JuhaManninen]

Is that mean(underlined) can we use this codes under lazarus ?

No, there is no mention about Lazarus.

I did not know about Virtual Treeview moving to JAM Software maintenance. LuizAmérico, how realistic would it be to maintain a Lazarus fork as a branch of this GitHub repo? Finally JAM Software could be persuaded to merge the codebases.

[LuizAmérico]

I already have done the preparation to fork from the official GitHub repository (in fact i was already merging code from Google Code but manually).

Don't hold your breath for the newest features. After version 6, VTV removed old delphi compatible adding code that does not compile with fpc.