Changeset 538 for trunk/Packages/DpiControls

Timestamp:

Apr 16, 2024, 10:57:39 AM (7 months ago)

Author:

chronos

Message:

• Fixed: Map drawing in case of fractional scaling.

Location:

trunk/Packages/DpiControls

Files:

• Dpi.Common.pas (modified) (4 diffs)
• Dpi.Graphics.pas (modified) (1 diff)
• Dpi.PixelPointer.pas (modified) (2 diffs)
• NativePixelPointer.pas (modified) (3 diffs)

trunk/Packages/DpiControls/Dpi.Common.pas

@@ -11 +11 @@
 
 function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
-    YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
+  YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
 function BitBltCanvas(Dest: TCanvas; X, Y, Width, Height: Integer; Src: TCanvas;
-    XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
+  XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
+function BitBltBitmap(Dest: TBitmap; X, Y, Width, Height: Integer; Src: TBitmap;
+  XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
 function CreateRectRgn(X1, Y1, X2, Y2: Integer): HRGN;
 {$IFDEF WINDOWS}
@@ -39 +41 @@
 resourcestring
   SNotImplemented = 'Not implemented';
+  SUnsupportedPaintOperationType = 'Unsupported paint operation type';
 
 
 implementation
+
+uses
+  NativePixelPointer;
 
 function BitBltCanvas(Dest: TCanvas; X, Y, Width, Height: Integer;
@@ -47 +53 @@
 begin
   Result := BitBlt(Dest.Handle, X, Y, Width, Height, Src.Handle, XSrc, YSrc, Rop);
+end;
+
+function BitBltBitmap(Dest: TBitmap; X, Y, Width, Height: Integer;
+  Src: TBitmap; XSrc, YSrc: Integer; Rop: DWORD): Boolean;
+var
+  SrcPixel: TPixelPointer;
+  DstPixel: TPixelPointer;
+  DstWidth, DstHeight: Integer;
+  SrcWidth, SrcHeight: Integer;
+  XX, YY: Integer;
+  DstPixelX, DstPixelY: Integer;
+  XNative, YNative: Integer;
+  DstPixelWidth, DstPixelHeight: Integer;
+begin
+  if Frac(ScreenInfo.Dpi / 96) = 0 then
+  begin
+    // Use faster non-fractional scaling
+    Result := BitBlt(Dest.Canvas.Handle, X, Y, Width, Height, Src.Canvas.Handle, XSrc, YSrc, Rop);
+    Exit;
+  end;
+
+  if X < 0 then begin
+    Width := Width + X;
+    XSrc := XSrc - X;
+    X := 0;
+  end;
+  if Y < 0 then begin
+    Height := Height + Y;
+    YSrc := YSrc - Y;
+    Y := 0;
+  end;
+  if (X + Width) > Dest.Width then begin
+    Width := Dest.Width - X;
+  end;
+  if (Y + Height) > Dest.Height then begin
+    Height := Dest.Height - Y;
+  end;
+
+  DstWidth := ScaleToNativeDist(X, Width);
+  DstHeight := ScaleToNativeDist(Y, Height);
+  SrcWidth := ScaleToNativeDist(XSrc, Width);
+  SrcHeight := ScaleToNativeDist(YSrc, Height);
+  XNative := ScaleToNative(X);
+  YNative := ScaleToNative(Y);
+
+  Dest.BeginUpdate;
+  SrcPixel := TPixelPointer.Create(Src.NativeBitmap);
+  DstPixel := TPixelPointer.Create(Dest.NativeBitmap);
+  for YY := 0 to Height - 1 do begin
+    DstPixelHeight := ScaleToNative(Y + YY + 1) - ScaleToNative(Y + YY);
+    for DstPixelY := 0 to DstPixelHeight - 1 do begin
+      for XX := 0 to Width - 1 do begin
+        SrcPixel.SetXY(ScaleToNative(XSrc + XX), ScaleToNative(YSrc + YY));
+        DstPixel.SetXY(ScaleToNative(X + XX), ScaleToNative(Y + YY) + DstPixelY);
+        DstPixelWidth := ScaleToNative(X + XX + 1) - ScaleToNative(X + XX);
+        for DstPixelX := 0 to DstPixelWidth - 1 do begin
+{$IFDEF DEBUG}
+          if SrcPixel.PosValid and DstPixel.PosValid then
+{$ENDIF}
+            if Rop = SRCCOPY then begin
+              DstPixel.PixelB := SrcPixel.PixelB;
+              DstPixel.PixelG := SrcPixel.PixelG;
+              DstPixel.PixelR := SrcPixel.PixelR;
+            end else
+            if Rop = SRCPAINT then begin
+              DstPixel.PixelB := SrcPixel.PixelB or DstPixel.PixelB;
+              DstPixel.PixelG := SrcPixel.PixelG or DstPixel.PixelG;
+              DstPixel.PixelR := SrcPixel.PixelR or DstPixel.PixelR;
+            end else
+            if Rop = SRCAND then begin
+              DstPixel.PixelB := SrcPixel.PixelB and DstPixel.PixelB;
+              DstPixel.PixelG := SrcPixel.PixelG and DstPixel.PixelG;
+              DstPixel.PixelR := SrcPixel.PixelR and DstPixel.PixelR;
+            end else
+            if Rop = DSTINVERT then begin
+              DstPixel.PixelB := not DstPixel.PixelB;
+              DstPixel.PixelG := not DstPixel.PixelG;
+              DstPixel.PixelR := not DstPixel.PixelR;
+            end else begin
+              raise Exception.Create(SUnsupportedPaintOperationType);
+            end;
+          DstPixel.NextPixel;
+        end;
+      end;
+      //DstPixel.NextLine;
+    end;
+  end;
+  Dest.EndUpdate;
+  Result := True;
 end;
 
@@ -95 +190 @@
 function ScaleToNative(Value: Integer): Integer;
 begin
-  Result := Round(Value * ScreenInfo.Dpi / 96);
+  Result := Ceil(Value * ScreenInfo.Dpi / 96);
 end;
 

trunk/Packages/DpiControls/Dpi.Graphics.pas

@@ -692 +692 @@
   SrcPtr: TPixelPointer;
   DstPtr: TPixelPointer;
-  xx, yy: Integer;
-  SrcX, SrcY: Integer;
-  DstX, DstY: Integer;
-  DstWidth, DstHeight: Integer;
-begin
-  //Dst.Canvas.StretchDraw(Rect(0, 0, ScaleToNative(Dst.Width), ScaleToNative(Dst.Height)), Src);
-  //Exit;
+  XX, YY: Integer;
+  DstPixelX, DstPixelY: Integer;
+  DstPixelWidth, DstPixelHeight: Integer;
+begin
   Dst.BeginUpdate;
   SrcPtr := TPixelPointer.Create(Src, 0, 0);
   DstPtr := TPixelPointer.Create(Dst, 0, 0);
-  {for yy := 0 to Dst.Height - 1 do begin
-    for xx := 0 to Dst.Width - 1 do begin
-      SrcPtr.SetXY(Min(ScaleFromNative(xx), Src.Width - 1),
-        Min(ScaleFromNative(yy), Src.Height - 1));
-      DstPtr.PixelB := SrcPtr.PixelB;
-      DstPtr.PixelG := SrcPtr.PixelG;
-      DstPtr.PixelR := SrcPtr.PixelR;
-      DstPtr.NextPixel;
-    end;
-    DstPtr.NextLine;
-  end;
-  }
-  for SrcY := 0 to Src.Height - 1 do begin
-    DstHeight := ScaleToNative(SrcY + 1) - ScaleToNative(SrcY);
-    for DstY := 0 to DstHeight - 1 do begin
-      for SrcX := 0 to Src.Width - 1 do begin
-        DstWidth := ScaleToNative(SrcX + 1) - ScaleToNative(SrcX);
-        for DstX := 0 to DstWidth - 1 do begin
+  for YY := 0 to Src.Height - 1 do begin
+    DstPixelHeight := ScaleToNative(YY + 1) - ScaleToNative(YY);
+    for DstPixelY := 0 to DstPixelHeight - 1 do begin
+      for XX := 0 to Src.Width - 1 do begin
+        DstPixelWidth := ScaleToNative(XX + 1) - ScaleToNative(XX);
+        for DstPixelX := 0 to DstPixelWidth - 1 do begin
           DstPtr.PixelB := SrcPtr.PixelB;
           DstPtr.PixelG := SrcPtr.PixelG;

trunk/Packages/DpiControls/Dpi.PixelPointer.pas

@@ -93 +93 @@
 
 resourcestring
-  SOutOfRange = 'Pixel pointer out of range [X: %d. Y: %d]';
+  SOutOfRange = 'Pixel pointer out of range [X: %d, Y: %d, Width: %d, Height: %d]';
   SWrongBitmapSize = 'Wrong bitmap size [width: %d, height: %d]';
 
@@ -160 +160 @@
     X := B - Y * BytesPerLine;
     X := Floor(X / BytesPerPixel);
-    raise Exception.Create(Format(SOutOfRange, [X, Y]));
+    raise Exception.Create(Format(SOutOfRange, [X, Y, Width, Height]));
   end;
   {$ENDIF}

trunk/Packages/DpiControls/NativePixelPointer.pas

@@ -63 +63 @@
     procedure SetX(X: Integer); inline; // Set horizontal pixel position relative to base
     procedure CheckRange; inline; // Check if current pixel position is not out of range
+    function PosValid: Boolean;
     class function Create(Bitmap: TRasterImage; BaseX: Integer = 0; BaseY: Integer = 0): TPixelPointer; static;
     property PixelARGB: TColor32 read GetPixelARGB write SetPixelARGB;
@@ -93 +94 @@
 
 resourcestring
-  SOutOfRange = 'Pixel pointer out of range [X: %d. Y: %d]';
+  SOutOfRange = 'Pixel pointer out of range [X: %d, Y: %d, Width: %d, Height: %d]';
   SWrongBitmapSize = 'Wrong bitmap size [width: %d, height: %d]';
 
@@ -159 +160 @@
     X := X - Y * BytesPerLine;
     X := Floor(X / BytesPerPixel);
-    raise Exception.Create(Format(SOutOfRange, [X, Y]));
+    raise Exception.Create(Format(SOutOfRange, [X, Y, Width, Height]));
   end;
   {$ENDIF}
+end;
+
+function TPixelPointer.PosValid: Boolean;
+begin
+  Result := not ((PByte(Pixel) < PByte(Data)) or
+    (PByte(Pixel) >= PByte(Data) + Height * BytesPerLine));
 end;