diff --git a/delphi/KPANSI.PAS b/delphi/KPANSI.PAS index 42fbd0b..13bebe9 100644 --- a/delphi/KPANSI.PAS +++ b/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 - 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;