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>

delphi/KPANSI.PAS

@@ -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
+      if Line^.Cells[Col].Blink and not FTextBlinkOn then
-      begin
+        BatchFG := BatchBG
-        { Bold maps low color to bright: if FG is in 0..7, use 8..15 }
+      else
-      end;
+        BatchFG := Line^.Cells[Col].FG;
-      if Line^.Cells[Col].Blink then
+      BatchBuf[0] := Line^.Cells[Col].Ch;
-      begin
+      BatchLen    := 1;
-        { Blink renders as bright background }
-      end;
-      BatchStr := Line^.Cells[Col].Ch;
       Inc(Col);
 
-      { Extend batch while attributes match }
+      { Extend batch while effective colors match }
-      while (Col < FCols) and
+      while Col < FCols do
-            (Line^.Cells[Col].FG = BatchFG) and
-            (Line^.Cells[Col].BG = BatchBG) 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;
+      SetTextColor(FMemDC, ColorToRGB(BatchFG));
-      Canvas.Brush.Color := BatchBG;
+      SetBkColor(FMemDC, ColorToRGB(BatchBG));
-      Canvas.TextOut(X, Y, BatchStr);
+      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;
+      SetTextColor(FMemDC, ColorToRGB(Line^.Cells[FCursorCol].BG));
-      Canvas.Font.Color  := Line^.Cells[FCursorCol].BG;
+      SetBkColor(FMemDC, ColorToRGB(Line^.Cells[FCursorCol].FG));
-      Canvas.TextOut(X, Y, Line^.Cells[FCursorCol].Ch);
+      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;
-                BGIdx := FAttrBG + 8
-              else
-                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;
+    OldFont := SelectObject(DC, FPaintFont);
-    SelectObject(DC, Font.Handle);
+    Extent  := GetTextExtent(DC, 'W', 1);
-    GetTextMetrics(DC, TM);
+    SelectObject(DC, OldFont);
-    FCellWidth  := TM.tmAveCharWidth;
+    FCellWidth  := LoWord(Extent);
-    FCellHeight := TM.tmHeight;
+    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;