Changeset 212

Timestamp:

May 9, 2020, 9:35:25 PM (4 years ago)

Author:

chronos

Message:

• Fixed: Better High DPI scaling on highdpi branch.

Location:

branches/highdpi

Files:

• LocalPlayer/Help.pas (modified) (1 diff)
• LocalPlayer/IsoEngine.pas (modified) (6 diffs)
• LocalPlayer/Term.pas (modified) (3 diffs)
• Packages/CevoComponents/DrawDlg.pas (modified) (1 diff)
• Packages/DpiControls/UDpiControls.pas (modified) (21 diffs)
• Start.pas (modified) (1 diff)

branches/highdpi/LocalPlayer/Help.pas

@@ -445 +445 @@
   x, y, dx, dy, xSrc, ySrc, sum, xx: integer;
   Heaven: array [0..nHeaven] of integer;
-  PaintPtr, CoalPtr: TPixelPointer;
+  PaintPtr: TPixelPointer;
+  CoalPtr: TPixelPointer;
   ImpPtr: array [-1..1] of TPixelPointer;
 begin

branches/highdpi/LocalPlayer/IsoEngine.pas

@@ -34 +34 @@
     function IsShoreTile(Loc: integer): boolean;
     procedure MakeDark(Line: PPixelPointer; Length: Integer);
-    procedure ShadeOutside(x0, y0, x1, y1, xm, ym: integer);
+    procedure ShadeOutside(x0, y0, Width, Height, xm, ym: integer);
   protected
     FOutput: TDpiBitmap;
@@ -1015 +1015 @@
             1 + 8 * (xxt * 2 + 1), 1 + yyt + 16 * (yyt * 3 + 1));
           Borders.BeginUpdate;
-          for dy := 0 to yyt * 2 - 1 do
-          begin
-            PixelPtr := PixelPointer(Borders, 0, p1 * (yyt * 2) + dy);
-            for dx := 0 to xxt * 2 - 1 do begin
+          PixelPtr := PixelPointer(Borders, ScaleToVcl(0), ScaleToVcl(p1 * (yyt * 2)));
+          for dy := 0 to ScaleToVcl(yyt * 2) - 1 do begin
+            for dx := 0 to ScaleToVcl(xxt * 2) - 1 do begin
               if PixelPtr.Pixel^.B = 99 then begin
                 PixelPtr.Pixel^.B := Tribe[p1].Color shr 16 and $FF;
@@ -1026 +1025 @@
               PixelPtr.NextPixel;
             end;
+            PixelPtr.NextLine;
           end;
           Borders.EndUpdate;
@@ -1330 +1330 @@
 end;
 
-procedure TIsoMap.ShadeOutside(x0, y0, x1, y1, xm, ym: integer);
+procedure TIsoMap.ShadeOutside(x0, y0, Width, Height, xm, ym: integer);
 const
   rShade = 3.75;
@@ -1339 +1339 @@
 begin
   FOutput.BeginUpdate;
-  for y := y0 to y1 - 1 do begin
-    Line := PixelPointer(FOutput, 0, y);
-    y_n := (y - ym) / yyt;
-    if abs(y_n) < rShade then begin
+  Line := PixelPointer(FOutput, ScaleToVcl(x0), ScaleToVcl(y0));
+  for y := 0 to ScaleToVcl(Height) - 1 do begin
+    y_n := (ScaleFromVcl(y) + y0 - ym) / yyt;
+    if Abs(y_n) < rShade then begin
       // Darken left and right parts of elipsis
-      w_n := sqrt(sqr(rShade) - sqr(y_n));
-      wBright := trunc(w_n * xxt + 0.5);
-      Line.SetX(x0);
-      MakeDark(@Line, xm - x0 - wBright);
-      Line.SetX(xm + wBright);
-      MakeDark(@Line, x1 - xm - wBright);
+      w_n := Sqrt(Sqr(rShade) - Sqr(y_n));
+      wBright := Trunc(w_n * xxt + 0.5);
+      Line.SetX(0);
+      MakeDark(@Line, ScaleToVcl(xm - wBright));
+      Line.SetX(ScaleToVcl(xm + wBright));
+      MakeDark(@Line, ScaleToVcl(Width - xm - wBright));
     end else begin
       // Darken entire line
-      Line.SetX(x0);
-      MakeDark(@Line, x1 - x0);
+      Line.SetX(0);
+      MakeDark(@Line, ScaleToVcl(Width));
     end;
+    Line.NextLine;
   end;
   FOutput.EndUpdate;
@@ -1576 +1577 @@
     xm := x + (dx + 1) * xxt;
     ym := y + (dy + 1) * yyt + yyt;
-    ShadeOutside(FLeft, FTop, FRight, FBottom, xm, ym);
+    ShadeOutside(FLeft, FTop, FRight - FLeft, FBottom - FTop, xm, ym);
     CityGrid(xm, ym, CityAllowClick);
     for dy := -2 to ny + 1 do

branches/highdpi/LocalPlayer/Term.pas

@@ -532 +532 @@
   SmallScreen, GameOK, MapValid, skipped, idle: boolean;
 
-  SaveOption: array [0 .. nSaveOption - 1] of integer;
-  MiniColors: array [0 .. 11, 0 .. 1] of TColor;
+  SaveOption: array [0..nSaveOption - 1] of integer;
+  MiniColors: array [0..fTerrain, 0..1] of TColor;
   MainMap: TIsoMap;
   CurrentMoveInfo: record AfterMovePaintRadius, AfterAttackExpeller: integer;
@@ -4077 +4077 @@
   MiniPixel := PixelPointer(Mini);
   PrevMiniPixel := PixelPointer(Mini);
-  for y := 0 to G.ly - 1 do
-  begin
-    for x := 0 to G.lx - 1 do
-      if MyMap[x + G.lx * y] and fTerrain <> fUNKNOWN then
-      begin
-        Loc := x + G.lx * y;
+  for y := 0 to ScaleToVcl(G.ly) - 1 do
+  begin
+    for x := 0 to ScaleToVcl(G.lx) - 1 do
+      if MyMap[ScaleFromVcl(x) + G.lx * ScaleFromVcl(y)] and fTerrain <> fUNKNOWN then
+      begin
+        Loc := ScaleFromVcl(x) + G.lx * ScaleFromVcl(y);
         for i := 0 to 1 do
         begin
-          xm := ((x - xwMini) * 2 + i + y and 1 - hw + G.lx * 5) mod (G.lx * 2);
+          xm := ((x - ScaleToVcl(xwMini)) * 2 + i + y and 1 - ScaleToVcl(hw) +
+            ScaleToVcl(G.lx) * 5) mod (ScaleToVcl(G.lx) * 2);
           MiniPixel.SetXY(xm, y);
           cm := MiniColors[MyMap[Loc] and fTerrain, i];
@@ -5079 +5080 @@
         dx := 0;
         dy := 0;
-        if Mouse.CursorPos.y < DpiScreen.height - PanelHeight then
-          if Mouse.CursorPos.x = 0 then
+        if DpiMouse.CursorPos.y < DpiScreen.height - PanelHeight then
+          if DpiMouse.CursorPos.x = 0 then
             dx := -speed // scroll left
-          else if Mouse.CursorPos.x = DpiScreen.width - 1 then
+          else if DpiMouse.CursorPos.x = DpiScreen.width - 1 then
             dx := speed; // scroll right
-        if Mouse.CursorPos.y = 0 then
+        if DpiMouse.CursorPos.y = 0 then
           dy := -speed // scroll up
-        else if (Mouse.CursorPos.y = DpiScreen.height - 1) and
-          (Mouse.CursorPos.x >= TerrainBtn.Left + TerrainBtn.width) and
-          (Mouse.CursorPos.x < xRightPanel + 10 - 8) then
+        else if (DpiMouse.CursorPos.y = DpiScreen.height - 1) and
+          (DpiMouse.CursorPos.x >= TerrainBtn.Left + TerrainBtn.width) and
+          (DpiMouse.CursorPos.x < xRightPanel + 10 - 8) then
           dy := speed; // scroll down
         if (dx <> 0) or (dy <> 0) then

branches/highdpi/Packages/CevoComponents/DrawDlg.pas

@@ -128 +128 @@
   {$IFDEF LINUX}
   // HitTest is not supported under Linux GTK2 so use form inside move mechanizm
-  NewFormPos := ScreenToClient(Mouse.CursorPos);
+  NewFormPos := ScreenToClient(DpiMouse.CursorPos);
   if (NewFormPos.X >= 0) and (NewFormPos.X < Width) and
     (NewFormPos.Y >= 0) and (NewFormPos.Y < Height) then begin
     MoveMousePos := ClientToScreen(Point(X, Y));
     MoveFormPos := Point(Left, Top);
-    MousePosNew := Mouse.CursorPos;
+    MousePosNew := DpiMouse.CursorPos;
     // Activate move only if mouse position was not changed during inherited call
     if (MousePosNew.X = MoveMousePos.X) and (MousePosNew.Y = MoveMousePos.Y) then begin

branches/highdpi/Packages/DpiControls/UDpiControls.pas

@@ -38 +38 @@
     property OnMouseUp;
     property OnMouseMove;
+    property OnMouseWheel;
+    property OnMouseLeave;
+    property OnMouseEnter;
   end;
 
@@ -122 +125 @@
     FLeft: Integer;
     FOnChangeBounds: TNotifyEvent;
+    FOnMouseUp: TMouseEvent;
     FOnMouseDown: TMouseEvent;
     FOnMouseMove: TMouseMoveEvent;
-    FOnMouseUp: TMouseEvent;
+    FOnMouseEnter: TNotifyEvent;
+    FOnMouseLeave: TNotifyEvent;
     FOnMouseWheel: TMouseWheelEvent;
     FOnResize: TNotifyEvent;
@@ -161 +166 @@
     procedure DoFormResize;
     procedure DoChangeBounds;
+    procedure MouseDownHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
+      X, Y: Integer); virtual;
+    procedure MouseUpHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
+      X, Y: Integer); virtual;
+    procedure MouseMoveHandler(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual;
+    procedure MouseWheelHandler(Sender: TObject; Shift: TShiftState;
+         WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); virtual;
+    procedure MouseLeaveHandler(Sender: TObject); virtual;
+    procedure MouseEnterHandler(Sender: TObject); virtual;
   protected
     procedure UpdateBounds; virtual;
@@ -174 +188 @@
     function GetVclControl: TControl; virtual;
     procedure UpdateVclControl; virtual;
-    procedure MouseDownHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
-      X, Y: Integer); virtual;
-    procedure MouseUpHandler(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
-      X, Y: Integer); virtual;
-    procedure MouseMoveHandler(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual;
-    procedure MouseWheelHandler(Sender: TObject; Shift: TShiftState;
-         WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); virtual;
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
       X, Y: Integer); virtual;
@@ -187 +194 @@
     procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual;
     procedure MouseLeave; virtual;
+    procedure MouseEnter; virtual;
   public
     function ScreenToClient(const APoint: TPoint): TPoint; virtual;
@@ -333 +341 @@
     function GetVclGraphicControl: TGraphicControl; virtual;
     procedure UpdateVclControl; override;
-    procedure UpdateVclControlPrivate; virtual;
     property OnPaint: TNotifyEvent read GetOnPaint write SetOnPaint;
   public
@@ -668 +675 @@
 
   TDpiPaintBox = class(TDpiGraphicControl)
-  private
-    procedure UpdateVclControlPrivate; override;
   public
     VclPaintBox: TPaintBox;
@@ -689 +694 @@
     FForms: TDpiForms;
     procedure AddForm(AForm: TDpiForm);
+    procedure RemoveForm(AForm: TDpiForm);
     function GetActiveForm: TDpiForm;
     function GetCursor: TCursor;
@@ -767 +773 @@
   end;
 
+  { TDpiMouse }
+
+  // TMouse
+  TDpiMouse = class
+  private
+    function GetCursorPos: TPoint;
+    procedure SetCursorPos(AValue: TPoint);
+  public
+    property CursorPos: TPoint read GetCursorPos write SetCursorPos;
+  end;
+
 var
   DpiFormFileDesc: TDpiFormFileDesc;
   DpiScreen: TDpiScreen;
   DpiApplication: TDpiApplication;
+  DpiMouse: TDpiMouse;
 
 procedure Register;
@@ -869 +887 @@
 end;
 
+{ TDpiMouse }
+
+function TDpiMouse.GetCursorPos: TPoint;
+begin
+  Result := ScalePointFromVcl(Mouse.CursorPos);
+end;
+
+procedure TDpiMouse.SetCursorPos(AValue: TPoint);
+begin
+  Mouse.CursorPos := ScalePointToVcl(AValue);
+end;
+
 { TDpiSizeConstraints }
 
@@ -1549 +1579 @@
 { TDpiPaintBox }
 
-procedure TDpiPaintBox.UpdateVclControlPrivate;
-begin
-  VclPaintBox.OnPaint := @PaintHandler;
-  VclPaintBox.OnMouseDown := @MouseDownHandler;
-  VclPaintBox.OnMouseUp := @MouseUpHandler;
-  VclPaintBox.OnMouseMove := @MouseMoveHandler;
-end;
-
 function TDpiPaintBox.GetVclGraphicControl: TGraphicControl;
 begin
@@ -1796 +1818 @@
 begin
   inherited;
-  UpdateVclControlPrivate;
-end;
-
-procedure TDpiGraphicControl.UpdateVclControlPrivate;
-begin
   TGraphicControlEx(GetVclGraphicControl).OnPaint := @PaintHandler;
-  TControlEx(GetVclControl).OnMouseDown := @MouseDownHandler;
-  TControlEx(GetVclControl).OnMouseUp := @MouseUpHandler;
-  TControlEx(GetVclControl).OnMouseMove := @MouseMoveHandler;
-  // Some VCL component event are not accessible on TGraphicControl level.
-  // Delegate this responsibility up
-  {
-  GetVclGraphicControl.OnPaint := @PaintHandler;
-  GetVclControl.OnMouseDown := @MouseDownHandler;
-  GetVclControl.OnMouseUp := @MouseUpHandler;
-  GetVclControl.OnMouseMove := @MouseMoveHandler;
-  }
-//  raise Exception.Create('Missing inicialization of private fields for ' + ClassName);
 end;
 
@@ -2134 +2139 @@
 end;
 
+procedure TDpiScreen.RemoveForm(AForm: TDpiForm);
+begin
+  FForms.Remove(AForm);
+  if AForm = FActiveForm then FActiveForm := nil;
+end;
+
 function TDpiScreen.GetActiveForm: TDpiForm;
 begin
@@ -2161 +2172 @@
   FForms := TDpiForms.Create;
   FForms.FreeObjects := False;
-  Dpi := 150;
+  Dpi := Round(96 * 2); //Screen.PixelsPerInch;
 end;
 
@@ -2214 +2225 @@
   GetVclControl.OnResize := @VclFormResize;
   GetVclControl.OnChangeBounds := @VclChangeBounds;
+  TControlEx(GetVclControl).OnMouseDown := @MouseDownHandler;
+  TControlEx(GetVclControl).OnMouseUp := @MouseUpHandler;
+  TControlEx(GetVclControl).OnMouseMove := @MouseMoveHandler;
+  TControlEx(GetVclControl).OnMouseEnter := @MouseEnterHandler;
+  TControlEx(GetVclControl).OnMouseLeave := @MouseLeaveHandler;
+  TControlEx(GetVclControl).OnMouseWheel := @MouseWheelHandler;
 end;
 
@@ -2244 +2261 @@
 end;
 
+procedure TDpiControl.MouseLeaveHandler(Sender: TObject);
+begin
+  MouseLeave;
+  if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
+end;
+
+procedure TDpiControl.MouseEnterHandler(Sender: TObject);
+begin
+  MouseEnter;
+  if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
+end;
+
 procedure TDpiControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
   Y: Integer);
@@ -2260 +2289 @@
 procedure TDpiControl.MouseLeave;
 begin
-
+end;
+
+procedure TDpiControl.MouseEnter;
+begin
 end;
 
@@ -2817 +2849 @@
 begin
   inherited;
-  GetVclForm.OnMouseDown := @MouseDownHandler;
-  GetVclForm.OnMouseUp := @MouseUpHandler;
-  GetVclForm.OnMouseMove := @MouseMoveHandler;
   GetVclForm.OnActivate := @ActivateHandler;
   GetVclForm.OnDeactivate := @DeactivateHandler;
@@ -2847 +2876 @@
 // Init the component with an IDE resource
 constructor TDpiForm.Create(TheOwner: TComponent);
-var
-  C: TComponent;
 begin
   //inherited;
@@ -2855 +2882 @@
   try
     CreateNew(TheOwner, 1); // this calls BeginFormUpdate, which is ended in AfterConstruction
-    // Self
-    C := FindGlobalComponent('TListDlg');
     if (ClassType <> TDpiForm) and not (csDesigning in ComponentState) then begin
       if not InitResourceComponent(Self, TDataModule) then begin
@@ -2878 +2903 @@
 begin
   FreeAndNil(VclForm);
+  DpiScreen.RemoveForm(Self);
 end;
 

branches/highdpi/Start.pas

@@ -48 +48 @@
     Bitmap: TDpiBitmap; { game world sample preview }
     Size: TPoint;
-    Colors: array [0 .. 11, 0 .. 1] of TColor;
+    Colors: array [0..fTerrain, 0..1] of TColor;
     Mode: TMiniMode;
     procedure LoadFromLogFile(FileName: string; var LastTurn: Integer);