ew8bak/ewsdr
1
0
Fork 0
mirror of https://git.vladimir.cc/vladimir/ewsdr.git synced 2026-08-25 20:37:33 +00:00
Code Issues Packages Projects Releases Wiki Activity

fix(macos): S-метр, линейка и зумбар больше не мылятся на Retina

Browse Source 
Cocoa рисует канву в физических пикселях, TBitmap всегда 1x, поэтому кадр,
собранный в offscreen-битмап логического размера, растягивался вдвое.

PlatformUtils.GetScreenScale возвращает 2 на Retina и 1 на остальных
платформах. Масштаб — обычная переменная, а не условная компиляция: на
Windows/Linux умножение на 1 даёт прежние числа, а на канву кадр кладётся
через Draw, как и раньше (StretchDraw только при масштабе > 1).

В SMeterView, RulerView и PanZoomBar битмап растёт в S раз, пиксельные
константы, размеры шрифтов и толщина пера умножаются на S. Перо важно
отдельно: иначе на Retina все риски стали бы вдвое тоньше.

RulerView кэширует битмап, поэтому смена масштаба сбрасывает кэш.
PanZoomBar.ThumbGeom получил параметр AScale: отрисовка зовёт его с
физической шириной, хит-тест мыши — с логической, код мыши не менялся.

Objective-C изолирован в MacScale.pas: {$MODESWITCH OBJECTIVEC1} несовместим
с {$MODE Delphi}, а DWARF-3 (-gw3, Debug-режим lazbuild) роняет FPC 3.2.4 с
internal error 200609171 на любых Objective-C типах — отсюда {$DEBUGINFO OFF}.

Замер после правки: 37.5% CPU против 38% базовых, отрисовка этих трёх
элементов ниже уровня шума в профиле.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
ew8bak
2026-07-09 19:09:53 +03:00
co-authored by Claude Opus 4.8
parent 406f32b52c
commit fd8769898a
5 changed files with 232 additions and 112 deletions
Download Patch File Download Diff File Expand all files Collapse all files
PanZoomBar.pas
+49 -28
View File
@@ -26,7 +26,7 @@ interface
uses
Classes, SysUtils, Graphics, ExtCtrls, Controls, Math,
LCLIntf, LCLType, IntfGraphics, fpImage, AppTheme;
LCLIntf, LCLType, IntfGraphics, fpImage, AppTheme, PlatformUtils;
type
TPanZoomEvent = procedure(AZoom, APan: Double) of object;
@@ -47,9 +47,14 @@ type
FDragLo: Double; // зафиксированный левый край окна (для edge-зума), доля
FDragHi: Double; // зафиксированный правый край окна, доля
FOnZoomPan: TPanZoomEvent;
// Масштаб канвы: 2 на Retina, 1 на Windows/Linux. Только для отрисовки —
// мышь работает в логических координатах паинтбокса.
FScale: Integer;
function VisFraction: Double; // доля span, видимая при текущем зуме
function ThumbGeom(W: Integer; out L, Wd: Integer): Boolean; // px-геометрия окна
// AScale: 1 для хит-теста (логические px), FScale для отрисовки (физические).
function ThumbGeom(W: Integer; out L, Wd: Integer;
AScale: Integer = 1): Boolean;
procedure CurWindow(out Lo, Hi: Double); // доли краёв окна
procedure EmitWindow(NewLo, NewHi: Double); // окно → zoom/pan + callback
function EdgePx(Wd: Integer): Integer;
@@ -109,6 +114,7 @@ begin
FCenterFreq := 0.0;
FSpanHz := 192000.0;
FDragMode := dmNone;
FScale := 1;
end;
destructor TPanZoomBar.Destroy;
@@ -162,13 +168,14 @@ begin
Result := Max(3, Min(8, Wd div 3));
end;
function TPanZoomBar.ThumbGeom(W: Integer; out L, Wd: Integer): Boolean;
function TPanZoomBar.ThumbGeom(W: Integer; out L, Wd: Integer;
AScale: Integer = 1): Boolean;
var Lo, Hi: Double;
begin
Result := W > 0;
if not Result then begin L := 0; Wd := 0; Exit; end;
CurWindow(Lo, Hi);
Wd := Max(MIN_THUMB_PX, Round((Hi - Lo) * W));
Wd := Max(MIN_THUMB_PX * AScale, Round((Hi - Lo) * W));
if Wd > W then Wd := W;
L := Round(Lo * W);
if L < 0 then L := 0;
@@ -199,7 +206,9 @@ var
i, X, TickMaj, TickMin, LabelY, NDiv, LabelEvery, TW: Integer;
FreqStart, FreqHz, PixPerDiv: Double;
Lbl: string;
Sc: Integer; // масштаб канвы, см. FScale
begin
Sc := FScale;
C := FBmp.Canvas;
C.Brush.Style := bsSolid;
C.Brush.Color := FTheme.SliderBG;
@@ -207,11 +216,12 @@ begin
C.Font.Name := 'Courier New';
C.Font.Style := [];
C.Font.Height := -Max(7, Round(H * 0.40));
C.Font.Height := -Max(7 * Sc, Round(H * 0.40));
C.Brush.Style := bsClear;
C.Pen.Width := Sc;
TickMaj := Max(3, Round(H * 0.28));
TickMin := Max(2, Round(H * 0.16));
TickMaj := Max(3 * Sc, Round(H * 0.28));
TickMin := Max(2 * Sc, Round(H * 0.16));
LabelY := TickMaj + ((H - TickMaj) - C.TextHeight('0')) div 2;
if LabelY < TickMaj then LabelY := TickMaj;
@@ -219,14 +229,14 @@ begin
if FSpanHz <= 0 then Exit;
FreqStart := FCenterFreq - FSpanHz / 2;
PixPerDiv := W / NDiv;
if PixPerDiv >= (C.TextWidth('000.000') + 8) then LabelEvery := 1
else if PixPerDiv * 2 >= (C.TextWidth('000.000') + 8) then LabelEvery := 2
if PixPerDiv >= (C.TextWidth('000.000') + 8 * Sc) then LabelEvery := 1
else if PixPerDiv * 2 >= (C.TextWidth('000.000') + 8 * Sc) then LabelEvery := 2
else LabelEvery := 4;
for i := 0 to NDiv do
begin
X := Round(i * PixPerDiv);
if X >= W then X := W - 1;
if X >= W then X := W - Sc;
C.Pen.Color := FTheme.RulerBorder;
if (i mod LabelEvery) = 0 then
begin
@@ -254,8 +264,10 @@ var
tR, tG, tB, bgR, bgG, bgB, nR, nG, nB: Integer;
A, RowT, Gloss: Double;
Active: Boolean;
Sc: Integer; // масштаб канвы, см. FScale
begin
if (Wd <= 0) or (W <= 0) or (H <= 2) then Exit;
Sc := FScale;
if (Wd <= 0) or (W <= 0) or (H <= 2 * Sc) then Exit;
Active := FDragMode <> dmNone;
if Active then
begin
@@ -270,8 +282,8 @@ begin
tB := GetBValue(ColorToRGB(FTheme.SliderThumbNorm));
end;
top := 1;
bot := H - 2;
top := Sc;
bot := H - 2 * Sc;
Intf := FBmp.CreateIntfImage;
try
for y := top to bot do
@@ -299,47 +311,56 @@ begin
// Объёмная фаска + маркеры краёв (две вертикальные риски — «ручки» ресайза).
with FBmp.Canvas do
begin
Pen.Width := 1; Brush.Style := bsClear;
Pen.Width := Sc; Brush.Style := bsClear;
Pen.Color := FTheme.SliderThumbBdr;
Rectangle(L, top, L + Wd, bot + 1);
Rectangle(L, top, L + Wd, bot + Sc);
Pen.Color := RGBToColor(EnsureRange(tR + 70, 0, 255),
EnsureRange(tG + 70, 0, 255),
EnsureRange(tB + 70, 0, 255));
MoveTo(L + 1, top + 1); LineTo(L + Wd - 1, top + 1);
MoveTo(L + 1, top + 1); LineTo(L + 1, bot);
MoveTo(L + Sc, top + Sc); LineTo(L + Wd - Sc, top + Sc);
MoveTo(L + Sc, top + Sc); LineTo(L + Sc, bot);
Pen.Color := RGBToColor(EnsureRange(tR - 60, 0, 255),
EnsureRange(tG - 60, 0, 255),
EnsureRange(tB - 60, 0, 255));
MoveTo(L + 1, bot); LineTo(L + Wd - 1, bot);
MoveTo(L + Wd - 1, top + 1); LineTo(L + Wd - 1, bot + 1);
MoveTo(L + Sc, bot); LineTo(L + Wd - Sc, bot);
MoveTo(L + Wd - Sc, top + Sc); LineTo(L + Wd - Sc, bot + Sc);
// «ручки» захвата по краям (видны, когда окно достаточно широкое)
if Wd >= 3 * MIN_THUMB_PX then
if Wd >= 3 * MIN_THUMB_PX * Sc then
begin
Pen.Color := FTheme.SliderThumbBdr;
MoveTo(L + 3, top + 2); LineTo(L + 3, bot - 1);
MoveTo(L + Wd - 4, top + 2); LineTo(L + Wd - 4, bot - 1);
MoveTo(L + 3 * Sc, top + 2 * Sc); LineTo(L + 3 * Sc, bot - Sc);
MoveTo(L + Wd - 4 * Sc, top + 2 * Sc); LineTo(L + Wd - 4 * Sc, bot - Sc);
end;
Brush.Style := bsSolid;
end;
end;
procedure TPanZoomBar.Paint(Sender: TObject);
var W, H, L, Wd: Integer;
var W, H, BmpW, BmpH, L, Wd: Integer;
begin
if FPb = nil then Exit;
W := FPb.Width; H := FPb.Height;
if (W <= 0) or (H <= 0) then Exit;
if (FBmp.Width <> W) or (FBmp.Height <> H) then FBmp.SetSize(W, H);
DrawRulerInto(W, H);
if ThumbGeom(W, L, Wd) then BlendThumb(L, Wd, W, H);
// Битмап в физических пикселях канвы, иначе Cocoa растянет его и замылит.
FScale := GetScreenScale;
BmpW := W * FScale; BmpH := H * FScale;
if (FBmp.Width <> BmpW) or (FBmp.Height <> BmpH) then FBmp.SetSize(BmpW, BmpH);
DrawRulerInto(BmpW, BmpH);
// Геометрия бегунка — в физических px; хит-тест в мыши зовёт ThumbGeom без масштаба.
if ThumbGeom(BmpW, L, Wd, FScale) then BlendThumb(L, Wd, BmpW, BmpH);
FBmp.Canvas.Brush.Style := bsClear;
FBmp.Canvas.Pen.Width := FScale;
FBmp.Canvas.Pen.Color := FTheme.RulerBorder;
FBmp.Canvas.Rectangle(0, 0, W, H);
FBmp.Canvas.Rectangle(0, 0, BmpW, BmpH);
FBmp.Canvas.Brush.Style := bsSolid;
FPb.Canvas.Draw(0, 0, FBmp);
if FScale = 1 then
FPb.Canvas.Draw(0, 0, FBmp)
else
FPb.Canvas.StretchDraw(Rect(0, 0, W, H), FBmp);
end;
procedure TPanZoomBar.HandleMouseDown(Button: TMouseButton; X, Y: Integer);