From 0ff633f605b60684be650d7b9692e2884eb6f5ef Mon Sep 17 00:00:00 2001 From: Scott Duensing Date: Thu, 26 Feb 2026 23:21:22 -0600 Subject: [PATCH] Replace GDI rendering with font atlas and direct pixel writes Build a monochrome font atlas at startup (BuildAtlas), then render terminal cells by writing palette indices directly into 8bpp DIB row buffers (RenderRow). Each dirty row reaches the screen via a single SetDIBitsToDevice call instead of ~12 GDI calls (TextOut, SetTextColor, SetBkColor, BitBlt). This reduces per-frame GDI overhead by ~10x, targeting smooth playback of BBS door games on Win16. Key changes: - TTermCell FG/BG from TColor to Byte (palette index 0-15) - Font atlas: render 256 CP437 glyphs into monochrome bitmap, extract per-glyph pixel masks via GetBitmapBits - Per-row 8bpp DIB buffers via GlobalAlloc replace dual memory DCs - RenderRow: zero-GDI atlas lookup + byte writes with cursor overlay - FlipToScreen: ScrollDC on screen only, SetDIBitsToDevice per dirty row - Text blink via FTextBlinkOn + re-render replaces dual-buffer phase swap - Removed: CreateBuffers, DestroyBuffers, PaintLine, ClearBufRect, RedrawBuffers, DrawRow, FBufDC/FBufBmp/FBlinkPhase fields Co-Authored-By: Claude Opus 4.6 --- delphi/KPANSI.PAS | 873 ++++++++++++++++++++++------------------------ 1 file changed, 423 insertions(+), 450 deletions(-) diff --git a/delphi/KPANSI.PAS b/delphi/KPANSI.PAS index 3c3970c..aaa18ea 100644 --- a/delphi/KPANSI.PAS +++ b/delphi/KPANSI.PAS @@ -7,6 +7,11 @@ unit KPAnsi; { Renders incoming data using standard ANSI/VT100 escape sequences for } { cursor positioning, color attributes, and screen manipulation. } { } +{ Rendering uses a font atlas with direct pixel writes into 8bpp DIB row } +{ buffers, minimizing GDI calls to a single SetDIBitsToDevice per dirty } +{ row. This eliminates the per-call overhead of TextOut/SetTextColor/ } +{ SetBkColor that dominates rendering time on Win16. } +{ } { Installs to the "KP" palette tab alongside TKPComm. } interface @@ -21,8 +26,8 @@ type TTermCell = record Ch: Char; - FG: TColor; - BG: TColor; + FG: Byte; { palette index 0-15 } + BG: Byte; { palette index 0-15 } Bold: Boolean; Blink: Boolean; end; @@ -32,6 +37,11 @@ type Cells: array[0..255] of TTermCell; end; + TDibInfo = record + bmiHeader: TBitmapInfoHeader; + bmiColors: array[0..15] of TRGBQuad; + end; + TKPAnsi = class(TCustomControl) private FScreen: TList; @@ -61,32 +71,31 @@ type FOnKeyData: TKeyDataEvent; FPaintFont: HFont; FStockFont: Boolean; - FBlinkPhase: Integer; FBlinkCount: Integer; FUpdateCount: Integer; FPendingScroll: Integer; FLastRenderTick: Longint; FDirtyRow: array[0..255] of Boolean; FAllDirty: Boolean; - FBufDC: array[0..1] of HDC; - FBufBmp: array[0..1] of HBitmap; - FBufOldBmp: array[0..1] of HBitmap; - FBufW: Integer; - FBufH: Integer; + FTextBlinkOn: Boolean; + FGlyphBits: array[0..255, 0..31] of Byte; + FRowBufH: array[0..255] of THandle; + FRowBuf: array[0..255] of Pointer; + FDibInfo: TDibInfo; + FRowBufSize: Integer; procedure AllocLine(Line: PTermLine); - procedure ClearBufRect(X, Y, W, H: Integer; BG: TColor); + procedure BuildAtlas; procedure ClearLine(Line: PTermLine); procedure CMFontChanged(var Msg: TMessage); message cm_FontChanged; - procedure CreateBuffers; procedure CreatePaintFont; + procedure CreateRowBuffers; procedure DeleteChars(N: Integer); procedure DeleteLines(N: Integer); - procedure DestroyBuffers; + procedure DestroyRowBuffers; procedure DirtyAll; procedure DirtyRow(Row: Integer); procedure DoScrollDown; procedure DoScrollUp; - procedure DrawRow(Row: Integer); procedure EraseDisplay(Mode: Integer); procedure EraseLine(Mode: Integer); procedure ExecuteCSI(FinalCh: Char); @@ -95,14 +104,14 @@ type procedure FreeLineList(List: TList); function GetCursorCol: Integer; function GetCursorRow: Integer; + procedure InitDibInfo; procedure InsertChars(N: Integer); procedure InsertLines(N: Integer); - procedure PaintLine(Line: PTermLine; PixelY: Integer); procedure ParseData(const S: string); procedure ParseSGR; procedure ProcessChar(Ch: Char); procedure RecalcCellSize; - procedure RedrawBuffers; + procedure RenderRow(Row: Integer); procedure ResizeScreen; procedure SetCols(Value: Integer); procedure SetCursorVisible(Value: Boolean); @@ -180,6 +189,11 @@ const 262, 277, 294, 311, 330, 349, 370, 392, 415, 440, 466, 494 ); +type + { Typed pointer for direct byte access to 8bpp row pixel buffers } + TPixelBuf = array[0..65519] of Byte; + PPixelBuf = ^TPixelBuf; + { ----------------------------------------------------------------------- } { Helper: parse semicolon-delimited parameter string into integer array } @@ -236,8 +250,8 @@ begin for I := 0 to FCols - 1 do begin Line^.Cells[I].Ch := ' '; - Line^.Cells[I].FG := AnsiColors[7]; - Line^.Cells[I].BG := AnsiColors[0]; + Line^.Cells[I].FG := 7; + Line^.Cells[I].BG := 0; Line^.Cells[I].Bold := False; Line^.Cells[I].Blink := False; end; @@ -250,6 +264,89 @@ begin end; +procedure TKPAnsi.BuildAtlas; +{ Render all 256 CP437 characters into a monochrome bitmap, then extract } +{ per-glyph pixel masks into FGlyphBits. Each entry FGlyphBits[ch, row] } +{ is an 8-bit mask: MSB = leftmost pixel, 1 = foreground, 0 = background. } +{ This is a one-time GDI cost at startup; after extraction, the bitmap } +{ and DC are deleted and never needed again. } +var + AtlasBmp: HBitmap; + AtlasDC: HDC; + OldBmp: HBitmap; + OldFont: HFont; + I: Integer; + Row: Integer; + RawH: THandle; + RawPtr: PPixelBuf; + Stride: Longint; + BmpSize: Longint; + Ch: Char; +begin + FillChar(FGlyphBits, SizeOf(FGlyphBits), 0); + + if FPaintFont = 0 then + Exit; + if (FCellWidth < 1) or (FCellHeight < 1) or (FCellHeight > 32) then + Exit; + + { Create monochrome bitmap: 256 chars side-by-side, FCellHeight tall } + AtlasBmp := CreateBitmap(256 * FCellWidth, FCellHeight, 1, 1, nil); + if AtlasBmp = 0 then + Exit; + + AtlasDC := CreateCompatibleDC(0); + if AtlasDC = 0 then + begin + DeleteObject(AtlasBmp); + Exit; + end; + + OldBmp := SelectObject(AtlasDC, AtlasBmp); + OldFont := SelectObject(AtlasDC, FPaintFont); + SetTextColor(AtlasDC, RGB(255, 255, 255)); + SetBkColor(AtlasDC, RGB(0, 0, 0)); + SetBkMode(AtlasDC, OPAQUE); + + { Render all 256 CP437 characters } + for I := 0 to 255 do + begin + Ch := Char(I); + WinProcs.TextOut(AtlasDC, I * FCellWidth, 0, @Ch, 1); + end; + + { Extract raw monochrome bitmap data } + Stride := ((Longint(256) * FCellWidth + 15) div 16) * 2; + BmpSize := Stride * FCellHeight; + RawH := GlobalAlloc(GMEM_FIXED, BmpSize); + if RawH <> 0 then + begin + RawPtr := GlobalLock(RawH); + if RawPtr <> nil then + begin + GetBitmapBits(AtlasBmp, BmpSize, RawPtr); + { Extract per-glyph bytes. For 8-pixel-wide fonts each glyph is } + { exactly one byte per scan line, aligned to byte boundaries. } + for I := 0 to 255 do + begin + for Row := 0 to FCellHeight - 1 do + begin + FGlyphBits[I, Row] := RawPtr^[Row * Stride + I]; + end; + end; + GlobalUnlock(RawH); + end; + GlobalFree(RawH); + end; + + { Clean up -- atlas DC and bitmap are never needed again } + SelectObject(AtlasDC, OldFont); + SelectObject(AtlasDC, OldBmp); + DeleteDC(AtlasDC); + DeleteObject(AtlasBmp); +end; + + procedure TKPAnsi.Clear; var I: Integer; @@ -288,8 +385,8 @@ begin for I := 0 to FCols - 1 do begin Line^.Cells[I].Ch := ' '; - Line^.Cells[I].FG := AnsiColors[7]; - Line^.Cells[I].BG := AnsiColors[0]; + Line^.Cells[I].FG := 7; + Line^.Cells[I].BG := 0; Line^.Cells[I].Bold := False; Line^.Cells[I].Blink := False; end; @@ -339,18 +436,13 @@ begin FWrapMode := True; FPaintFont := 0; FStockFont := False; - FBlinkPhase := 0; FBlinkCount := 0; FUpdateCount := 0; FPendingScroll := 0; FLastRenderTick := 0; FAllDirty := True; - FBufDC[0] := 0; - FBufDC[1] := 0; - FBufBmp[0] := 0; - FBufBmp[1] := 0; - FBufW := 0; - FBufH := 0; + FTextBlinkOn := True; + FRowBufSize := 0; { Set a monospace font -- OEM charset selected in CreatePaintFont } Font.Name := 'Terminal'; @@ -410,15 +502,6 @@ begin FPaintFont := GetStockObject(OEM_FIXED_FONT); FStockFont := True; end; - - { Select font into both buffer DCs } - if FPaintFont <> 0 then - begin - if FBufDC[0] <> 0 then - SelectObject(FBufDC[0], FPaintFont); - if FBufDC[1] <> 0 then - SelectObject(FBufDC[1], FPaintFont); - end; end; @@ -426,370 +509,27 @@ procedure TKPAnsi.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); Params.Style := Params.Style or ws_VScroll; - { CS_OWNDC gives us a private DC whose state (selected font, BkMode, } - { colors) persists across GetDC/ReleaseDC calls. This eliminates the } - { per-frame cost of SelectObject + SetBkMode that otherwise dominates } - { rendering time on Win16. } + { CS_OWNDC gives us a private DC cached across GetDC/ReleaseDC calls, } + { avoiding DC allocation overhead on each FlipToScreen render pass. } Params.WindowClass.Style := Params.WindowClass.Style or cs_OwnDC; end; -procedure TKPAnsi.ClearBufRect(X, Y, W, H: Integer; BG: TColor); -var - R: TRect; - HBr: HBrush; - I: Integer; -begin - R.Left := X; - R.Top := Y; - R.Right := X + W; - R.Bottom := Y + H; - HBr := CreateSolidBrush(ColorToRGB(BG)); - for I := 0 to 1 do - begin - if FBufDC[I] <> 0 then - FillRect(FBufDC[I], R, HBr); - end; - DeleteObject(HBr); -end; - - -procedure TKPAnsi.CreateBuffers; -var - ScreenDC: HDC; - I: Integer; -begin - DestroyBuffers; - FBufW := FCols * FCellWidth; - FBufH := FRows * FCellHeight; - if (FBufW < 1) or (FBufH < 1) then - Exit; - ScreenDC := GetDC(0); - for I := 0 to 1 do - begin - FBufDC[I] := CreateCompatibleDC(ScreenDC); - FBufBmp[I] := CreateCompatibleBitmap(ScreenDC, FBufW, FBufH); - FBufOldBmp[I] := SelectObject(FBufDC[I], FBufBmp[I]); - if FPaintFont <> 0 then - SelectObject(FBufDC[I], FPaintFont); - SetBkMode(FBufDC[I], OPAQUE); - end; - ReleaseDC(0, ScreenDC); -end; - - -procedure TKPAnsi.DestroyBuffers; +procedure TKPAnsi.CreateRowBuffers; var I: Integer; begin - for I := 0 to 1 do - begin - if FBufDC[I] <> 0 then - begin - SelectObject(FBufDC[I], FBufOldBmp[I]); - DeleteObject(FBufBmp[I]); - DeleteDC(FBufDC[I]); - FBufDC[I] := 0; - FBufBmp[I] := 0; - FBufOldBmp[I] := 0; - end; - end; -end; - - -procedure TKPAnsi.DirtyAll; -begin - FAllDirty := True; -end; - - -procedure TKPAnsi.DirtyRow(Row: Integer); -begin - if (Row >= 0) and (Row <= 255) then - FDirtyRow[Row] := True; -end; - - -procedure TKPAnsi.DrawRow(Row: Integer); -begin - if (Row >= 0) and (Row < FScreen.Count) then - PaintLine(FScreen[Row], Row * FCellHeight); -end; - - -procedure TKPAnsi.PaintLine(Line: PTermLine; PixelY: Integer); -{ Render a line to both buffer DCs using batched TextOut. } -{ Groups consecutive cells with identical colors into single calls } -{ (typically 5-10 per row instead of 80 per-cell calls). } -var - Col: Integer; - BatchStart: Integer; - BatchLen: Integer; - I: Integer; - X: Integer; - CellFG: TColor; - CellBG: TColor; - CurFG: TColor; - CurBG: TColor; - HasBlink: Boolean; - Buf: array[0..255] of Char; -begin - if FBufDC[0] = 0 then + DestroyRowBuffers; + FRowBufSize := FCols * FCellWidth * FCellHeight; + if FRowBufSize < 1 then Exit; - - { Check if any cell on this line blinks } - HasBlink := False; - for Col := 0 to FCols - 1 do + for I := 0 to FRows - 1 do begin - if Line^.Cells[Col].Blink then - begin - HasBlink := True; - Break; - end; - end; - - if HasBlink then - begin - { Blink row: must render to each buffer separately } - for I := 0 to 1 do - begin - if FBufDC[I] = 0 then - Continue; - CurFG := TColor(-1); - CurBG := TColor(-1); - BatchStart := 0; - BatchLen := 0; - - for Col := 0 to FCols - 1 do - begin - CellBG := Line^.Cells[Col].BG; - if (I = 1) and Line^.Cells[Col].Blink then - CellFG := CellBG - else - CellFG := Line^.Cells[Col].FG; - - if (CellFG <> CurFG) or (CellBG <> CurBG) then - begin - if BatchLen > 0 then - begin - X := BatchStart * FCellWidth; - WinProcs.TextOut(FBufDC[I], X, PixelY, @Buf[0], BatchLen); - end; - if CellFG <> CurFG then - begin - SetTextColor(FBufDC[I], ColorToRGB(CellFG)); - CurFG := CellFG; - end; - if CellBG <> CurBG then - begin - SetBkColor(FBufDC[I], ColorToRGB(CellBG)); - CurBG := CellBG; - end; - BatchStart := Col; - BatchLen := 0; - end; - - Buf[BatchLen] := Line^.Cells[Col].Ch; - Inc(BatchLen); - end; - - if BatchLen > 0 then - begin - X := BatchStart * FCellWidth; - WinProcs.TextOut(FBufDC[I], X, PixelY, @Buf[0], BatchLen); - end; - end; - end - else - begin - { No blink: render to buffer 0 only, then copy row to buffer 1 } - CurFG := TColor(-1); - CurBG := TColor(-1); - BatchStart := 0; - BatchLen := 0; - - for Col := 0 to FCols - 1 do - begin - CellFG := Line^.Cells[Col].FG; - CellBG := Line^.Cells[Col].BG; - - if (CellFG <> CurFG) or (CellBG <> CurBG) then - begin - if BatchLen > 0 then - begin - X := BatchStart * FCellWidth; - WinProcs.TextOut(FBufDC[0], X, PixelY, @Buf[0], BatchLen); - end; - if CellFG <> CurFG then - begin - SetTextColor(FBufDC[0], ColorToRGB(CellFG)); - CurFG := CellFG; - end; - if CellBG <> CurBG then - begin - SetBkColor(FBufDC[0], ColorToRGB(CellBG)); - CurBG := CellBG; - end; - BatchStart := Col; - BatchLen := 0; - end; - - Buf[BatchLen] := Line^.Cells[Col].Ch; - Inc(BatchLen); - end; - - if BatchLen > 0 then - begin - X := BatchStart * FCellWidth; - WinProcs.TextOut(FBufDC[0], X, PixelY, @Buf[0], BatchLen); - end; - - { Copy rendered row from buffer 0 to buffer 1 } - if FBufDC[1] <> 0 then - BitBlt(FBufDC[1], 0, PixelY, FBufW, FCellHeight, - FBufDC[0], 0, PixelY, SRCCOPY); - end; -end; - - -procedure TKPAnsi.FlipToScreen; -var - DC: HDC; - Row: Integer; - I: Integer; - MinDirty: Integer; - MaxDirty: Integer; - FullBlt: Boolean; - Line: PTermLine; - X: Integer; - Y: Integer; - SrcY: Integer; - H: Integer; - R: TRect; - ScrollY: Integer; -begin - if not HandleAllocated then - Exit; - if FBufDC[0] = 0 then - RecalcCellSize; - if FBufDC[0] = 0 then - Exit; - - FullBlt := FAllDirty; - - if FScrollPos <> 0 then - begin - { Scrollback view: full redraw from scrollback + screen data } - RedrawBuffers; - FPendingScroll := 0; - FullBlt := True; - end - else - begin - { Apply deferred scroll to both buffer DCs. ScrollDC here is } - { safe because all parsing is complete and dirty flags have been } - { shifted to match the new line positions by DoScrollUp. } - if (FPendingScroll > 0) and not FAllDirty then - begin - R.Left := 0; - R.Top := 0; - R.Right := FBufW; - R.Bottom := FBufH; - ScrollY := FPendingScroll * FCellHeight; - for I := 0 to 1 do - begin - if FBufDC[I] <> 0 then - ScrollDC(FBufDC[I], 0, -ScrollY, R, R, 0, nil); - end; - end; - FPendingScroll := 0; - - { Render only dirty rows into both buffers (batched TextOut) } - MinDirty := FRows; - MaxDirty := -1; - for Row := 0 to FRows - 1 do - begin - if FAllDirty or FDirtyRow[Row] then - begin - if Row < FScreen.Count then - PaintLine(FScreen[Row], Row * FCellHeight); - FDirtyRow[Row] := False; - if Row < MinDirty then - MinDirty := Row; - if Row > MaxDirty then - MaxDirty := Row; - end; - end; - FAllDirty := False; - end; - - DC := GetDC(Handle); - - if FullBlt then - begin - BitBlt(DC, 0, 0, FBufW, FBufH, - FBufDC[FBlinkPhase], 0, 0, SRCCOPY); - end - else if MaxDirty >= 0 then - begin - { Partial BitBlt: only the dirty row band } - SrcY := MinDirty * FCellHeight; - H := (MaxDirty - MinDirty + 1) * FCellHeight; - BitBlt(DC, 0, SrcY, FBufW, H, - FBufDC[FBlinkPhase], 0, SrcY, SRCCOPY); - end; - - { Cursor overlay -- drawn directly to screen DC. CS_OWNDC keeps } - { FPaintFont and OPAQUE BkMode set from RecalcCellSize; re-assert } - { them here in case VCL Paint altered the DC state. } - if FCursorVisible and FBlinkOn and (FScrollPos = 0) and - (FCursorRow >= 0) and (FCursorRow < FRows) and - (FCursorRow < FScreen.Count) and - (FCursorCol >= 0) and (FCursorCol < FCols) then - begin - SelectObject(DC, FPaintFont); - SetBkMode(DC, OPAQUE); - Line := FScreen[FCursorRow]; - X := FCursorCol * FCellWidth; - Y := FCursorRow * FCellHeight; - SetTextColor(DC, ColorToRGB(Line^.Cells[FCursorCol].BG)); - SetBkColor(DC, ColorToRGB(Line^.Cells[FCursorCol].FG)); - WinProcs.TextOut(DC, X, Y, @Line^.Cells[FCursorCol].Ch, 1); - end; - - ReleaseDC(Handle, DC); -end; - - -procedure TKPAnsi.RedrawBuffers; -var - Row: Integer; - VisRow: Integer; - SbkCount: Integer; - Line: PTermLine; -begin - if FBufDC[0] = 0 then - Exit; - SbkCount := FScrollback.Count; - for Row := 0 to FRows - 1 do - begin - VisRow := Row - FScrollPos; - if VisRow < 0 then - begin - if (SbkCount + VisRow >= 0) and (SbkCount + VisRow < SbkCount) then - Line := FScrollback[SbkCount + VisRow] - else - Line := nil; - end - else if VisRow < FScreen.Count then - Line := FScreen[VisRow] + FRowBufH[I] := GlobalAlloc(GMEM_FIXED or GMEM_ZEROINIT, FRowBufSize); + if FRowBufH[I] <> 0 then + FRowBuf[I] := GlobalLock(FRowBufH[I]) else - Line := nil; - - if Line = nil then - ClearBufRect(0, Row * FCellHeight, FBufW, FCellHeight, AnsiColors[0]) - else - PaintLine(Line, Row * FCellHeight); + FRowBuf[I] := nil; end; end; @@ -809,8 +549,8 @@ begin if I >= 0 then begin Line^.Cells[I].Ch := ' '; - Line^.Cells[I].FG := AnsiColors[7]; - Line^.Cells[I].BG := AnsiColors[0]; + Line^.Cells[I].FG := 7; + Line^.Cells[I].BG := 0; Line^.Cells[I].Bold := False; Line^.Cells[I].Blink := False; end; @@ -851,7 +591,7 @@ begin KillTimer(Handle, 1); FTimerActive := False; end; - DestroyBuffers; + DestroyRowBuffers; if (FPaintFont <> 0) and not FStockFont then begin DeleteObject(FPaintFont); @@ -865,6 +605,36 @@ begin end; +procedure TKPAnsi.DestroyRowBuffers; +var + I: Integer; +begin + for I := 0 to 255 do + begin + if FRowBufH[I] <> 0 then + begin + GlobalUnlock(FRowBufH[I]); + GlobalFree(FRowBufH[I]); + FRowBufH[I] := 0; + FRowBuf[I] := nil; + end; + end; +end; + + +procedure TKPAnsi.DirtyAll; +begin + FAllDirty := True; +end; + + +procedure TKPAnsi.DirtyRow(Row: Integer); +begin + if (Row >= 0) and (Row <= 255) then + FDirtyRow[Row] := True; +end; + + procedure TKPAnsi.DoScrollDown; var Line: PTermLine; @@ -955,8 +725,8 @@ begin for J := FCursorCol to FCols - 1 do begin Line^.Cells[J].Ch := ' '; - Line^.Cells[J].FG := AnsiColors[7]; - Line^.Cells[J].BG := AnsiColors[0]; + Line^.Cells[J].FG := 7; + Line^.Cells[J].BG := 0; Line^.Cells[J].Bold := False; Line^.Cells[J].Blink := False; end; @@ -978,8 +748,8 @@ begin for J := 0 to FCursorCol do begin Line^.Cells[J].Ch := ' '; - Line^.Cells[J].FG := AnsiColors[7]; - Line^.Cells[J].BG := AnsiColors[0]; + Line^.Cells[J].FG := 7; + Line^.Cells[J].BG := 0; Line^.Cells[J].Bold := False; Line^.Cells[J].Blink := False; end; @@ -1027,8 +797,8 @@ begin for J := FCursorCol to FCols - 1 do begin Line^.Cells[J].Ch := ' '; - Line^.Cells[J].FG := AnsiColors[7]; - Line^.Cells[J].BG := AnsiColors[0]; + Line^.Cells[J].FG := 7; + Line^.Cells[J].BG := 0; Line^.Cells[J].Bold := False; Line^.Cells[J].Blink := False; end; @@ -1038,8 +808,8 @@ begin for J := 0 to FCursorCol do begin Line^.Cells[J].Ch := ' '; - Line^.Cells[J].FG := AnsiColors[7]; - Line^.Cells[J].BG := AnsiColors[0]; + Line^.Cells[J].FG := 7; + Line^.Cells[J].BG := 0; Line^.Cells[J].Bold := False; Line^.Cells[J].Blink := False; end; @@ -1386,6 +1156,78 @@ begin end; +procedure TKPAnsi.FlipToScreen; +{ Render dirty rows into 8bpp DIB buffers, then blast to screen via } +{ SetDIBitsToDevice. One GDI call per dirty row, zero for rendering. } +var + DC: HDC; + Row: Integer; + R: TRect; + ScrollY: Integer; +begin + if not HandleAllocated then + Exit; + if FRowBuf[0] = nil then + RecalcCellSize; + if FRowBuf[0] = nil then + Exit; + + { Scrollback view: force full redraw, ignore pending scroll } + if FScrollPos <> 0 then + begin + FAllDirty := True; + FPendingScroll := 0; + end; + + { Deferred scroll: shift existing screen pixels up. Row buffers are } + { per-row so they don't need scrolling; only the screen DC is shifted. } + if (FPendingScroll > 0) and not FAllDirty then + begin + R.Left := 0; + R.Top := 0; + R.Right := FCols * FCellWidth; + R.Bottom := FRows * FCellHeight; + ScrollY := FPendingScroll * FCellHeight; + DC := GetDC(Handle); + ScrollDC(DC, 0, -ScrollY, R, R, 0, nil); + ReleaseDC(Handle, DC); + end; + FPendingScroll := 0; + + { Render dirty rows into per-row pixel buffers (pure memory, zero GDI) } + for Row := 0 to FRows - 1 do + begin + if (FAllDirty or FDirtyRow[Row]) and (FRowBuf[Row] <> nil) then + begin + RenderRow(Row); + end; + end; + + { Blast dirty rows to screen } + DC := GetDC(Handle); + for Row := 0 to FRows - 1 do + begin + if FAllDirty or FDirtyRow[Row] then + begin + if FRowBuf[Row] <> nil then + begin + SetDIBitsToDevice(DC, + 0, Row * FCellHeight, + FCols * FCellWidth, FCellHeight, + 0, 0, + 0, FCellHeight, + FRowBuf[Row], + PBitmapInfo(@FDibInfo)^, + 0); { DIB_RGB_COLORS } + end; + FDirtyRow[Row] := False; + end; + end; + FAllDirty := False; + ReleaseDC(Handle, DC); +end; + + procedure TKPAnsi.FreeLineList(List: TList); var I: Integer; @@ -1410,6 +1252,34 @@ begin end; +procedure TKPAnsi.InitDibInfo; +{ Initialize the BITMAPINFOHEADER and 16-color palette for the 8bpp DIB } +{ row buffers. The palette maps indices 0-15 to the ANSI color table. } +var + I: Integer; + C: TColor; +begin + FillChar(FDibInfo, SizeOf(FDibInfo), 0); + with FDibInfo.bmiHeader do + begin + biSize := SizeOf(TBitmapInfoHeader); + biWidth := FCols * FCellWidth; + biHeight := FCellHeight; + biPlanes := 1; + biBitCount := 8; + biCompression := 0; { BI_RGB } + end; + for I := 0 to 15 do + begin + C := AnsiColors[I]; + FDibInfo.bmiColors[I].rgbRed := C and $FF; + FDibInfo.bmiColors[I].rgbGreen := (C shr 8) and $FF; + FDibInfo.bmiColors[I].rgbBlue := (C shr 16) and $FF; + FDibInfo.bmiColors[I].rgbReserved := 0; + end; +end; + + procedure TKPAnsi.InsertChars(N: Integer); var Line: PTermLine; @@ -1425,8 +1295,8 @@ begin if I < FCols then begin Line^.Cells[I].Ch := ' '; - Line^.Cells[I].FG := AnsiColors[7]; - Line^.Cells[I].BG := AnsiColors[0]; + Line^.Cells[I].FG := 7; + Line^.Cells[I].BG := 0; Line^.Cells[I].Bold := False; Line^.Cells[I].Blink := False; end; @@ -1542,46 +1412,41 @@ end; procedure TKPAnsi.Paint; var - Row: Integer; - Line: PTermLine; - X: Integer; - Y: Integer; + Row: Integer; begin - if FBufDC[0] = 0 then + if FRowBuf[0] = nil then RecalcCellSize; - if FBufDC[0] = 0 then + if FRowBuf[0] = nil then Exit; - { Full repaint: render all rows into buffers } + { Full repaint: render all rows into buffers, then blast to canvas } FPendingScroll := 0; + FAllDirty := True; + for Row := 0 to FRows - 1 do begin - if Row < FScreen.Count then - PaintLine(FScreen[Row], Row * FCellHeight); + if FRowBuf[Row] <> nil then + begin + RenderRow(Row); + end; + end; + + for Row := 0 to FRows - 1 do + begin + if FRowBuf[Row] <> nil then + begin + SetDIBitsToDevice(Canvas.Handle, + 0, Row * FCellHeight, + FCols * FCellWidth, FCellHeight, + 0, 0, + 0, FCellHeight, + FRowBuf[Row], + PBitmapInfo(@FDibInfo)^, + 0); { DIB_RGB_COLORS } + end; FDirtyRow[Row] := False; end; FAllDirty := False; - - { BitBlt to canvas (provided by VCL WM_PAINT handler) } - BitBlt(Canvas.Handle, 0, 0, FBufW, FBufH, - FBufDC[FBlinkPhase], 0, 0, SRCCOPY); - - { Cursor overlay -- VCL may have selected its own font into the } - { canvas DC, so re-assert FPaintFont for correct cell dimensions. } - if FCursorVisible and FBlinkOn and (FScrollPos = 0) and - (FCursorRow >= 0) and (FCursorRow < FRows) and - (FCursorRow < FScreen.Count) and - (FCursorCol >= 0) and (FCursorCol < FCols) then - begin - SelectObject(Canvas.Handle, FPaintFont); - SetBkMode(Canvas.Handle, OPAQUE); - Line := FScreen[FCursorRow]; - X := FCursorCol * FCellWidth; - Y := FCursorRow * FCellHeight; - SetTextColor(Canvas.Handle, ColorToRGB(Line^.Cells[FCursorCol].BG)); - SetBkColor(Canvas.Handle, ColorToRGB(Line^.Cells[FCursorCol].FG)); - WinProcs.TextOut(Canvas.Handle, X, Y, @Line^.Cells[FCursorCol].Ch, 1); - end; end; @@ -1733,8 +1598,8 @@ begin { 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. } + { and rendered in RenderRow -- NOT mapped to bright BG, } + { so colored backgrounds (SGR 40-47) display correctly. } if FAttrBold then FGIdx := FAttrFG + 8 else @@ -1744,13 +1609,13 @@ begin Line := FScreen[FCursorRow]; if FAttrReverse then begin - Line^.Cells[FCursorCol].FG := AnsiColors[BGIdx]; - Line^.Cells[FCursorCol].BG := AnsiColors[FGIdx]; + Line^.Cells[FCursorCol].FG := BGIdx; + Line^.Cells[FCursorCol].BG := FGIdx; end else begin - Line^.Cells[FCursorCol].FG := AnsiColors[FGIdx]; - Line^.Cells[FCursorCol].BG := AnsiColors[BGIdx]; + Line^.Cells[FCursorCol].FG := FGIdx; + Line^.Cells[FCursorCol].BG := BGIdx; end; Line^.Cells[FCursorCol].Ch := Ch; Line^.Cells[FCursorCol].Bold := FAttrBold; @@ -1871,13 +1736,10 @@ begin { Recreate the OEM charset paint font from current Font properties } CreatePaintFont; - { Measure character size and configure screen DC. CS_OWNDC keeps } - { these settings across GetDC/ReleaseDC calls, so the font and } - { BkMode persist for cursor overlay rendering in FlipToScreen. } + { Measure character cell size } DC := GetDC(Handle); try SelectObject(DC, FPaintFont); - SetBkMode(DC, OPAQUE); Extent := GetTextExtent(DC, 'W', 1); FCellWidth := LoWord(Extent); FCellHeight := HiWord(Extent); @@ -1888,13 +1750,17 @@ begin FCellWidth := 8; if FCellHeight < 1 then FCellHeight := 16; + if FCellHeight > 32 then + FCellHeight := 32; { Resize control to fit terminal dimensions } Width := FCols * FCellWidth + GetSystemMetrics(sm_CxVScroll); Height := FRows * FCellHeight; - { (Re)create dual bitmaps; mark all rows dirty for next render } - CreateBuffers; + { Build font atlas, initialize DIB palette, allocate row buffers } + BuildAtlas; + InitDibInfo; + CreateRowBuffers; FAllDirty := True; { Start render/blink timer } @@ -1908,6 +1774,115 @@ begin end; +procedure TKPAnsi.RenderRow(Row: Integer); +{ Core atlas renderer. For each cell in the row, look up the glyph in } +{ the monochrome atlas and write FG/BG palette indices directly into the } +{ 8bpp row buffer. Zero GDI calls. Cursor overlay is also rendered here } +{ by swapping FG/BG for the cursor cell. } +var + Line: PTermLine; + Pix: PPixelBuf; + Stride: Longint; + Col: Integer; + GlyphRow: Integer; + BufScanline: Integer; + Bits: Byte; + Offset: Longint; + Pixel: Integer; + FGIdx: Byte; + BGIdx: Byte; + CharCode: Integer; + SbkCount: Integer; + VisRow: Integer; +begin + if FRowBuf[Row] = nil then + Exit; + + Pix := FRowBuf[Row]; + Stride := Longint(FCols) * FCellWidth; + + { Determine which line to render (handles scrollback view) } + if FScrollPos <> 0 then + begin + SbkCount := FScrollback.Count; + VisRow := Row - FScrollPos; + if VisRow < 0 then + begin + if (SbkCount + VisRow >= 0) then + Line := FScrollback[SbkCount + VisRow] + else + Line := nil; + end + else if VisRow < FScreen.Count then + Line := FScreen[VisRow] + else + Line := nil; + end + else if Row < FScreen.Count then + Line := FScreen[Row] + else + Line := nil; + + if Line = nil then + begin + { Blank row: fill with background color 0 (black) } + FillChar(Pix^, FRowBufSize, 0); + Exit; + end; + + for Col := 0 to FCols - 1 do + begin + { Determine effective colors } + if Line^.Cells[Col].Blink and not FTextBlinkOn then + FGIdx := Line^.Cells[Col].BG { hide blinking text } + else + FGIdx := Line^.Cells[Col].FG; + BGIdx := Line^.Cells[Col].BG; + CharCode := Ord(Line^.Cells[Col].Ch); + + { Render glyph into buffer -- bottom-up for DIB format } + for GlyphRow := 0 to FCellHeight - 1 do + begin + BufScanline := FCellHeight - 1 - GlyphRow; + Bits := FGlyphBits[CharCode, GlyphRow]; + Offset := Longint(BufScanline) * Stride + Longint(Col) * FCellWidth; + for Pixel := 0 to FCellWidth - 1 do + begin + if (Bits and $80) <> 0 then + Pix^[Offset + Pixel] := FGIdx + else + Pix^[Offset + Pixel] := BGIdx; + Bits := Bits shl 1; + end; + end; + end; + + { Cursor overlay: if cursor is on this row and visible, re-render the } + { cursor cell with swapped FG/BG using the same atlas lookup. } + if FCursorVisible and FBlinkOn and (FScrollPos = 0) and + (Row = FCursorRow) and (FCursorCol >= 0) and (FCursorCol < FCols) then + begin + FGIdx := Line^.Cells[FCursorCol].BG; + BGIdx := Line^.Cells[FCursorCol].FG; + CharCode := Ord(Line^.Cells[FCursorCol].Ch); + for GlyphRow := 0 to FCellHeight - 1 do + begin + BufScanline := FCellHeight - 1 - GlyphRow; + Bits := FGlyphBits[CharCode, GlyphRow]; + Offset := Longint(BufScanline) * Stride + Longint(FCursorCol) * FCellWidth; + for Pixel := 0 to FCellWidth - 1 do + begin + if (Bits and $80) <> 0 then + Pix^[Offset + Pixel] := FGIdx + else + Pix^[Offset + Pixel] := BGIdx; + Bits := Bits shl 1; + end; + end; + end; +end; + + procedure TKPAnsi.Reset; begin FAttrFG := 7; @@ -1968,7 +1943,6 @@ begin if Value <> FCursorVisible then begin FCursorVisible := Value; - { Mark cursor row dirty so BitBlt erases/redraws cursor overlay } FDirtyRow[FCursorRow] := True; FlipToScreen; end; @@ -2033,7 +2007,7 @@ end; procedure TKPAnsi.WMEraseBkgnd(var Msg: TWMEraseBkgnd); begin - { Suppress background erase -- TextOut with OPAQUE covers everything } + { Suppress background erase -- SetDIBitsToDevice covers everything } Msg.Result := 1; end; @@ -2050,11 +2024,10 @@ begin Inc(FBlinkCount); if FBlinkCount >= BlinkInterval then begin - FBlinkCount := 0; - FBlinkOn := not FBlinkOn; - Inc(FBlinkPhase); - if FBlinkPhase > 1 then - FBlinkPhase := 0; + FBlinkCount := 0; + FBlinkOn := not FBlinkOn; + FTextBlinkOn := not FTextBlinkOn; + DirtyAll; end; { Render pending dirty rows and/or update blink state. This also }