Fix OEM font rendering and terminal responsiveness in TKPAnsi
Replace TBitmap back buffer with raw GDI memory DC to prevent Delphi's TCanvas from overriding the OEM_CHARSET font selection. Add OUT_RASTER_PRECIS to CreateFontIndirect to ensure Windows maps to a true CP437 raster font instead of a TrueType substitution. Optimize paint loop with fixed char array instead of string concatenation. Restore Update call in ParseData so WM_PAINT is not starved by WM_COMMNOTIFY. Add text blink support via timer-driven FG/BG toggling and store blink as cell attribute instead of mapping to bright background. Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
This commit is contained in:
parent
a3c52e0817
commit
be566a5767
1 changed files with 226 additions and 44 deletions
|
|
@ -59,11 +59,23 @@ type
|
|||
FScrollbackSize: Integer;
|
||||
FCursorVisible: Boolean;
|
||||
FOnKeyData: TKeyDataEvent;
|
||||
FPaintFont: HFont;
|
||||
FStockFont: Boolean;
|
||||
FMemDC: HDC;
|
||||
FMemBmp: HBitmap;
|
||||
FMemOldBmp: HBitmap;
|
||||
FBufW: Integer;
|
||||
FBufH: Integer;
|
||||
FTextBlinkOn: Boolean;
|
||||
FBlinkCount: Integer;
|
||||
procedure AllocLine(Line: PTermLine);
|
||||
procedure ClearLine(Line: PTermLine);
|
||||
procedure CMFontChanged(var Msg: TMessage); message cm_FontChanged;
|
||||
procedure CreateBackBuffer;
|
||||
procedure CreatePaintFont;
|
||||
procedure DeleteChars(N: Integer);
|
||||
procedure DeleteLines(N: Integer);
|
||||
procedure DestroyBackBuffer;
|
||||
procedure DoScrollDown;
|
||||
procedure DoScrollUp;
|
||||
procedure EraseDisplay(Mode: Integer);
|
||||
|
|
@ -86,6 +98,7 @@ type
|
|||
procedure SetScrollbackSize(Value: Integer);
|
||||
procedure TrimScrollback;
|
||||
procedure UpdateScrollbar;
|
||||
procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message wm_EraseBkgnd;
|
||||
procedure WMGetDlgCode(var Msg: TMessage); message wm_GetDlgCode;
|
||||
procedure WMTimer(var Msg: TWMTimer); message wm_Timer;
|
||||
procedure WMVScroll(var Msg: TWMScroll); message wm_VScroll;
|
||||
|
|
@ -141,6 +154,9 @@ const
|
|||
|
||||
CursorBlinkMs = 500;
|
||||
|
||||
{ OUT_RASTER_PRECIS may not be defined in Delphi 1.0 WinTypes }
|
||||
OutRasterPrecis = 6;
|
||||
|
||||
{ ANSI music note frequencies (octave 0, multiply by 2^octave) }
|
||||
{ C, C#, D, D#, E, F, F#, G, G#, A, A#, B }
|
||||
BaseNoteFreq: array[0..11] of Word = (
|
||||
|
|
@ -297,8 +313,17 @@ begin
|
|||
FTimerActive := False;
|
||||
FScrollPos := 0;
|
||||
FWrapMode := True;
|
||||
FPaintFont := 0;
|
||||
FStockFont := False;
|
||||
FMemDC := 0;
|
||||
FMemBmp := 0;
|
||||
FMemOldBmp := 0;
|
||||
FBufW := 0;
|
||||
FBufH := 0;
|
||||
FTextBlinkOn := True;
|
||||
FBlinkCount := 0;
|
||||
|
||||
{ Set a monospace font }
|
||||
{ Set a monospace font -- OEM charset selected in CreatePaintFont }
|
||||
Font.Name := 'Terminal';
|
||||
Font.Size := 9;
|
||||
Font.Pitch := fpFixed;
|
||||
|
|
@ -313,6 +338,80 @@ begin
|
|||
end;
|
||||
|
||||
|
||||
procedure TKPAnsi.CreateBackBuffer;
|
||||
var
|
||||
ScreenDC: HDC;
|
||||
begin
|
||||
DestroyBackBuffer;
|
||||
FBufW := FCols * FCellWidth;
|
||||
FBufH := FRows * FCellHeight;
|
||||
if (FBufW < 1) or (FBufH < 1) then
|
||||
Exit;
|
||||
|
||||
{ Create a memory DC with compatible bitmap for double buffering. }
|
||||
{ We manage this DC directly with GDI calls -- no TCanvas/TBitmap }
|
||||
{ involvement -- so our OEM_CHARSET font stays selected and }
|
||||
{ cannot be overridden by VCL font realization. }
|
||||
ScreenDC := GetDC(0);
|
||||
FMemDC := CreateCompatibleDC(ScreenDC);
|
||||
FMemBmp := CreateCompatibleBitmap(ScreenDC, FBufW, FBufH);
|
||||
ReleaseDC(0, ScreenDC);
|
||||
FMemOldBmp := SelectObject(FMemDC, FMemBmp);
|
||||
if FPaintFont <> 0 then
|
||||
SelectObject(FMemDC, FPaintFont);
|
||||
SetBkMode(FMemDC, OPAQUE);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKPAnsi.CreatePaintFont;
|
||||
var
|
||||
LF: TLogFont;
|
||||
ActualLF: TLogFont;
|
||||
NewFont: HFont;
|
||||
begin
|
||||
{ Free previous font (stock fonts must not be deleted) }
|
||||
if (FPaintFont <> 0) and not FStockFont then
|
||||
DeleteObject(FPaintFont);
|
||||
FPaintFont := 0;
|
||||
FStockFont := False;
|
||||
|
||||
{ Build LOGFONT requesting OEM_CHARSET with raster precision for CP437 }
|
||||
{ box-drawing, block elements, and other BBS ANSI art glyphs. }
|
||||
FillChar(LF, SizeOf(LF), 0);
|
||||
LF.lfHeight := Font.Height;
|
||||
LF.lfPitchAndFamily := FIXED_PITCH or FF_MODERN;
|
||||
LF.lfCharSet := OEM_CHARSET;
|
||||
LF.lfOutPrecision := OutRasterPrecis;
|
||||
if fsBold in Font.Style then
|
||||
LF.lfWeight := FW_BOLD
|
||||
else
|
||||
LF.lfWeight := FW_NORMAL;
|
||||
StrPCopy(LF.lfFaceName, Font.Name);
|
||||
|
||||
NewFont := CreateFontIndirect(LF);
|
||||
if NewFont <> 0 then
|
||||
begin
|
||||
{ Verify Windows actually gave us an OEM charset font }
|
||||
GetObject(NewFont, SizeOf(ActualLF), @ActualLF);
|
||||
if ActualLF.lfCharSet = OEM_CHARSET then
|
||||
begin
|
||||
FPaintFont := NewFont;
|
||||
if FMemDC <> 0 then
|
||||
SelectObject(FMemDC, FPaintFont);
|
||||
Exit;
|
||||
end;
|
||||
{ Windows substituted a non-OEM font; discard it }
|
||||
DeleteObject(NewFont);
|
||||
end;
|
||||
|
||||
{ Fall back to the stock OEM fixed font -- guaranteed CP437 }
|
||||
FPaintFont := GetStockObject(OEM_FIXED_FONT);
|
||||
FStockFont := True;
|
||||
if FMemDC <> 0 then
|
||||
SelectObject(FMemDC, FPaintFont);
|
||||
end;
|
||||
|
||||
|
||||
procedure TKPAnsi.CreateParams(var Params: TCreateParams);
|
||||
begin
|
||||
inherited CreateParams(Params);
|
||||
|
|
@ -371,6 +470,20 @@ begin
|
|||
end;
|
||||
|
||||
|
||||
procedure TKPAnsi.DestroyBackBuffer;
|
||||
begin
|
||||
if FMemDC <> 0 then
|
||||
begin
|
||||
SelectObject(FMemDC, FMemOldBmp);
|
||||
DeleteObject(FMemBmp);
|
||||
DeleteDC(FMemDC);
|
||||
FMemDC := 0;
|
||||
FMemBmp := 0;
|
||||
FMemOldBmp := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
destructor TKPAnsi.Destroy;
|
||||
begin
|
||||
if FTimerActive then
|
||||
|
|
@ -378,6 +491,12 @@ begin
|
|||
KillTimer(Handle, 1);
|
||||
FTimerActive := False;
|
||||
end;
|
||||
DestroyBackBuffer;
|
||||
if (FPaintFont <> 0) and not FStockFont then
|
||||
begin
|
||||
DeleteObject(FPaintFont);
|
||||
FPaintFont := 0;
|
||||
end;
|
||||
FreeLineList(FScreen);
|
||||
FScreen.Free;
|
||||
FreeLineList(FScrollback);
|
||||
|
|
@ -1021,14 +1140,32 @@ var
|
|||
Y: Integer;
|
||||
Line: PTermLine;
|
||||
StartCol: Integer;
|
||||
BatchStr: string;
|
||||
BatchBuf: array[0..255] of Char;
|
||||
BatchLen: Integer;
|
||||
BatchFG: TColor;
|
||||
BatchBG: TColor;
|
||||
CellFG: TColor;
|
||||
VisRow: Integer;
|
||||
SbkOffset: Integer;
|
||||
SbkCount: Integer;
|
||||
R: TRect;
|
||||
HBr: HBrush;
|
||||
begin
|
||||
Canvas.Font := Font;
|
||||
{ Ensure back buffer exists (created by RecalcCellSize) }
|
||||
if FMemDC = 0 then
|
||||
RecalcCellSize;
|
||||
if FMemDC = 0 then
|
||||
Exit;
|
||||
|
||||
{ Pre-fill entire back buffer with black so no white pixels can }
|
||||
{ leak through gaps between rows or at the edges. }
|
||||
R.Left := 0;
|
||||
R.Top := 0;
|
||||
R.Right := FBufW;
|
||||
R.Bottom := FBufH;
|
||||
HBr := CreateSolidBrush(ColorToRGB(AnsiColors[0]));
|
||||
FillRect(FMemDC, R, HBr);
|
||||
DeleteObject(HBr);
|
||||
|
||||
SbkCount := FScrollback.Count;
|
||||
|
||||
|
|
@ -1057,44 +1194,46 @@ begin
|
|||
end;
|
||||
|
||||
if Line = nil then
|
||||
begin
|
||||
{ Blank row }
|
||||
Canvas.Brush.Color := AnsiColors[0];
|
||||
Canvas.FillRect(Rect(0, Y, FCols * FCellWidth, Y + FCellHeight));
|
||||
Continue;
|
||||
end;
|
||||
|
||||
{ Batch consecutive cells with same attributes for performance }
|
||||
{ Batch consecutive cells with same effective colors into a single }
|
||||
{ TextOut call for performance. Uses a fixed char array instead }
|
||||
{ of string concatenation to avoid heap allocation per cell. }
|
||||
{ When text blink is in the off phase, blinking cells render with }
|
||||
{ FG = BG so the text becomes invisible. }
|
||||
Col := 0;
|
||||
while Col < FCols do
|
||||
begin
|
||||
StartCol := Col;
|
||||
BatchFG := Line^.Cells[Col].FG;
|
||||
BatchBG := Line^.Cells[Col].BG;
|
||||
if Line^.Cells[Col].Bold and (BatchFG = Line^.Cells[Col].FG) then
|
||||
begin
|
||||
{ Bold maps low color to bright: if FG is in 0..7, use 8..15 }
|
||||
end;
|
||||
if Line^.Cells[Col].Blink then
|
||||
begin
|
||||
{ Blink renders as bright background }
|
||||
end;
|
||||
BatchStr := Line^.Cells[Col].Ch;
|
||||
if Line^.Cells[Col].Blink and not FTextBlinkOn then
|
||||
BatchFG := BatchBG
|
||||
else
|
||||
BatchFG := Line^.Cells[Col].FG;
|
||||
BatchBuf[0] := Line^.Cells[Col].Ch;
|
||||
BatchLen := 1;
|
||||
Inc(Col);
|
||||
|
||||
{ Extend batch while attributes match }
|
||||
while (Col < FCols) and
|
||||
(Line^.Cells[Col].FG = BatchFG) and
|
||||
(Line^.Cells[Col].BG = BatchBG) do
|
||||
{ Extend batch while effective colors match }
|
||||
while Col < FCols do
|
||||
begin
|
||||
BatchStr := BatchStr + Line^.Cells[Col].Ch;
|
||||
if Line^.Cells[Col].BG <> BatchBG then
|
||||
Break;
|
||||
if Line^.Cells[Col].Blink and not FTextBlinkOn then
|
||||
CellFG := BatchBG
|
||||
else
|
||||
CellFG := Line^.Cells[Col].FG;
|
||||
if CellFG <> BatchFG then
|
||||
Break;
|
||||
BatchBuf[BatchLen] := Line^.Cells[Col].Ch;
|
||||
Inc(BatchLen);
|
||||
Inc(Col);
|
||||
end;
|
||||
|
||||
X := StartCol * FCellWidth;
|
||||
Canvas.Font.Color := BatchFG;
|
||||
Canvas.Brush.Color := BatchBG;
|
||||
Canvas.TextOut(X, Y, BatchStr);
|
||||
SetTextColor(FMemDC, ColorToRGB(BatchFG));
|
||||
SetBkColor(FMemDC, ColorToRGB(BatchBG));
|
||||
WinProcs.TextOut(FMemDC, X, Y, @BatchBuf[0], BatchLen);
|
||||
end;
|
||||
|
||||
{ Draw cursor if on this row and visible }
|
||||
|
|
@ -1103,11 +1242,16 @@ begin
|
|||
begin
|
||||
X := FCursorCol * FCellWidth;
|
||||
{ Invert the cursor cell }
|
||||
Canvas.Brush.Color := Line^.Cells[FCursorCol].FG;
|
||||
Canvas.Font.Color := Line^.Cells[FCursorCol].BG;
|
||||
Canvas.TextOut(X, Y, Line^.Cells[FCursorCol].Ch);
|
||||
SetTextColor(FMemDC, ColorToRGB(Line^.Cells[FCursorCol].BG));
|
||||
SetBkColor(FMemDC, ColorToRGB(Line^.Cells[FCursorCol].FG));
|
||||
WinProcs.TextOut(FMemDC, X, Y,
|
||||
@Line^.Cells[FCursorCol].Ch, 1);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ Blit the completed frame to screen in one operation }
|
||||
BitBlt(Canvas.Handle, 0, 0, FBufW, FBufH,
|
||||
FMemDC, 0, 0, SRCCOPY);
|
||||
end;
|
||||
|
||||
|
||||
|
|
@ -1130,7 +1274,13 @@ begin
|
|||
{ Reset cursor blink to visible on new data }
|
||||
FBlinkOn := True;
|
||||
|
||||
{ Invalidate + Update forces an immediate synchronous repaint. }
|
||||
{ Without Update, WM_PAINT is low-priority and gets starved by }
|
||||
{ incoming WM_COMMNOTIFY messages, causing visible input lag. }
|
||||
{ The paint loop uses a fixed char array (no heap allocs) and our }
|
||||
{ own GDI memory DC, so repainting is fast enough for this. }
|
||||
Invalidate;
|
||||
Update;
|
||||
end;
|
||||
|
||||
|
||||
|
|
@ -1251,15 +1401,15 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
{ Calculate effective colors }
|
||||
{ Calculate effective colors. Bold maps FG to bright }
|
||||
{ (index + 8). Blink is stored as a cell attribute }
|
||||
{ and rendered in Paint -- NOT mapped to bright BG, so }
|
||||
{ colored backgrounds (SGR 40-47) display correctly. }
|
||||
if FAttrBold then
|
||||
FGIdx := FAttrFG + 8
|
||||
else
|
||||
FGIdx := FAttrFG;
|
||||
if FAttrBlink then
|
||||
BGIdx := FAttrBG + 8
|
||||
else
|
||||
BGIdx := FAttrBG;
|
||||
BGIdx := FAttrBG;
|
||||
|
||||
Line := FScreen[FCursorRow];
|
||||
if FAttrReverse then
|
||||
|
|
@ -1379,18 +1529,30 @@ end;
|
|||
|
||||
procedure TKPAnsi.RecalcCellSize;
|
||||
var
|
||||
TM: TTextMetric;
|
||||
DC: HDC;
|
||||
DC: HDC;
|
||||
OldFont: HFont;
|
||||
Extent: Longint;
|
||||
begin
|
||||
if not HandleAllocated then
|
||||
Exit;
|
||||
|
||||
{ Destroy back buffer first so the old font is not selected in any }
|
||||
{ DC when CreatePaintFont deletes it. }
|
||||
DestroyBackBuffer;
|
||||
|
||||
{ Recreate the OEM charset paint font from current Font properties }
|
||||
CreatePaintFont;
|
||||
|
||||
{ Measure actual rendered character size with GetTextExtent. }
|
||||
{ TEXTMETRIC fields can disagree with actual rendering for OEM }
|
||||
{ raster fonts; GetTextExtent returns the real pixel dimensions. }
|
||||
DC := GetDC(Handle);
|
||||
try
|
||||
Canvas.Font := Font;
|
||||
SelectObject(DC, Font.Handle);
|
||||
GetTextMetrics(DC, TM);
|
||||
FCellWidth := TM.tmAveCharWidth;
|
||||
FCellHeight := TM.tmHeight;
|
||||
OldFont := SelectObject(DC, FPaintFont);
|
||||
Extent := GetTextExtent(DC, 'W', 1);
|
||||
SelectObject(DC, OldFont);
|
||||
FCellWidth := LoWord(Extent);
|
||||
FCellHeight := HiWord(Extent);
|
||||
finally
|
||||
ReleaseDC(Handle, DC);
|
||||
end;
|
||||
|
|
@ -1403,6 +1565,9 @@ begin
|
|||
Width := FCols * FCellWidth + GetSystemMetrics(sm_CxVScroll);
|
||||
Height := FRows * FCellHeight;
|
||||
|
||||
{ (Re)create the GDI back buffer at the new size }
|
||||
CreateBackBuffer;
|
||||
|
||||
{ Start cursor blink timer }
|
||||
if not FTimerActive then
|
||||
begin
|
||||
|
|
@ -1535,6 +1700,13 @@ begin
|
|||
end;
|
||||
|
||||
|
||||
procedure TKPAnsi.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
|
||||
begin
|
||||
{ Suppress background erase -- double-buffered Paint covers everything }
|
||||
Msg.Result := 1;
|
||||
end;
|
||||
|
||||
|
||||
procedure TKPAnsi.WMGetDlgCode(var Msg: TMessage);
|
||||
begin
|
||||
Msg.Result := dlgc_WantArrows or dlgc_WantTab or dlgc_WantChars;
|
||||
|
|
@ -1544,8 +1716,18 @@ end;
|
|||
procedure TKPAnsi.WMTimer(var Msg: TWMTimer);
|
||||
begin
|
||||
FBlinkOn := not FBlinkOn;
|
||||
if FCursorVisible then
|
||||
Invalidate;
|
||||
|
||||
{ Text blink runs at half the cursor rate (every other tick) so }
|
||||
{ blinking text toggles roughly once per second. }
|
||||
Inc(FBlinkCount);
|
||||
if FBlinkCount >= 2 then
|
||||
begin
|
||||
FBlinkCount := 0;
|
||||
FTextBlinkOn := not FTextBlinkOn;
|
||||
end;
|
||||
|
||||
{ Always repaint: cursor blink and text blink both need it }
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue