AI_Slop/WinComm
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
WinComm/delphi/KPANSI.PAS
Scott Duensing 8e3bad86e3 Bypass 255-byte string limit and batch plain text runs in parser 
Add ReadInputBuf to TKPComm for direct PChar reads up to 2048 bytes,
eliminating short string allocation and 8x fewer ReadComm API calls.
Add ParseDataBuf to TKPAnsi with run batching: scans ahead for printable
text runs, computes colors once per run, fills cells in tight loop
without per-character state/wrap checks.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-02 17:15:35 -06:00

2504 lines
65 KiB
ObjectPascal
Raw Blame History

unit KPAnsi;
{ KPAnsi - ANSI BBS terminal emulation component for Delphi 1.0. }
{ }
{ TKPAnsi is a TCustomControl descendant providing a visual ANSI terminal }
{ display with scrollback buffer, cursor blinking, and ANSI music support. }
{ Renders incoming data using standard ANSI/VT100 escape sequences for }
{ cursor positioning, color attributes, and screen manipulation. }
{ }
{ Rendering uses a font atlas with a nibble lookup table and inline ASM }
{ to expand glyph bitmaps directly into a reusable 8bpp DIB pixel buffer. }
{ Constant mini-frame values are hoisted outside the column loop to reduce }
{ per-cell overhead. Smart blink tracking dirties only cursor and blink }
{ rows instead of the entire screen, eliminating wasteful full repaints. }
{ }
{ Installs to the "KP" palette tab alongside TKPComm. }
interface
uses
SysUtils, Classes, WinTypes, WinProcs, Messages, Graphics, Controls, Forms;
type
TKeyDataEvent = procedure(Sender: TObject; const Data: string) of object;
TParseState = (psNormal, psEscape, psCSI, psCSIQuestion, psMusic);
TTermCell = record
Ch: Char;
FG: Byte; { palette index 0-15 }
BG: Byte; { palette index 0-15 }
Bold: Boolean;
Blink: Boolean;
end;
PTermLine = ^TTermLineRec;
TTermLineRec = record
Cells: array[0..255] of TTermCell;
end;
TDibInfo = record
bmiHeader: TBitmapInfoHeader;
bmiColors: array[0..15] of TRGBQuad;
end;
TKPAnsi = class(TCustomControl)
private
{ Terminal buffer state }
FScreen: TList; { Active screen lines (FRows PTermLine ptrs) }
FScrollback: TList; { Scrollback history (up to FScrollbackSize) }
{ Cursor position (0-based row/col within the active screen) }
FCursorRow: Integer; { Current row (0 = top) }
FCursorCol: Integer; { Current column (0 = left) }
FSaveCurRow: Integer; { Saved row for SCP/RCP (ESC[s / ESC[u) }
FSaveCurCol: Integer; { Saved column for SCP/RCP }
{ Current text attributes (set by SGR escape sequences) }
FAttrFG: Integer; { Foreground color index 0-7 }
FAttrBG: Integer; { Background color index 0-7 }
FAttrBold: Boolean; { Bold: maps FG to bright (index + 8) }
FAttrBlink: Boolean; { Blink: cell toggles visibility on timer }
FAttrReverse: Boolean; { Reverse video: swap FG/BG at render time }
{ ANSI escape sequence parser state }
FParseState: TParseState; { Current parser state machine position }
FParamBuf: array[0..31] of Char; { CSI parameter digits/semicolons }
FParamLen: Integer; { Current length of FParamBuf }
FMusicStr: string; { Accumulated ANSI music string (ESC[M..^N) }
{ Font metrics (measured from OEM charset paint font) }
FCellWidth: Integer; { Character cell width in pixels (typically 8) }
FCellHeight: Integer; { Character cell height in pixels (typ 12-16) }
{ Blink state }
FBlinkOn: Boolean; { Cursor blink phase: True=visible }
FLastBlinkTick: Longint; { GetTickCount value at last blink toggle }
{ Scrollback view }
FScrollPos: Integer; { Lines scrolled back (0=live, >0=viewing history) }
FPendingScrolls: Integer; { Scroll-up count pending for ScrollDC coalescing }
{ Terminal modes }
FWrapMode: Boolean; { Auto-wrap at right margin (DEC ?7h/l) }
{ Terminal dimensions }
FCols: Integer; { Number of columns (default 80) }
FRows: Integer; { Number of rows (default 25) }
FScrollbackSize: Integer; { Max scrollback lines to retain (default 500) }
{ Cursor visibility (DEC ?25h/l) }
FCursorVisible: Boolean; { True if cursor is shown }
FLastCursorRow: Integer; { Previous cursor row for ghost cleanup }
{ Events }
FOnKeyData: TKeyDataEvent; { Keyboard data callback (keys -> serial) }
{ Paint font }
FPaintFont: HFont; { GDI font handle for OEM_CHARSET rendering }
FStockFont: Boolean; { True if FPaintFont is a stock object (no delete) }
{ Dirty tracking: per-row flags for incremental rendering }
FDirtyRow: array[0..255] of Boolean; { True = row needs re-render }
FAllDirty: Boolean; { True = all rows need re-render }
FScrollbarDirty: Boolean; { True = scrollbar range/position needs update }
FTextBlinkOn: Boolean; { Text blink phase: True=visible, False=hidden }
{ Font atlas: glyph bitmaps + nibble lookup table (GlobalAlloc) }
FGlyphBufH: THandle; { GlobalAlloc handle for glyph block (8256 bytes) }
FGlyphBuf: Pointer; { Far ptr: offset 0..63 = nibble table, 64+ = glyphs }
{ Row pixel buffer: reusable 8bpp DIB for one terminal row }
FRowBufH: THandle; { GlobalAlloc handle for pixel buffer }
FRowBuf: Pointer; { Far ptr to pixel data (cols*cellW*cellH bytes) }
FDibInfo: TDibInfo; { BITMAPINFO with 16-color ANSI palette }
FRowBufSize: Integer; { Pixel buffer size in bytes }
{ Nibble table color cache: avoids rebuild when colors unchanged }
FNibbleFG: Byte; { FG index currently in nibble table (255=invalid) }
FNibbleBG: Byte; { BG index currently in nibble table (255=invalid) }
procedure AllocLine(Line: PTermLine);
procedure BuildAtlas;
procedure ClearLine(Line: PTermLine);
procedure CMFontChanged(var Msg: TMessage); message cm_FontChanged;
procedure CreatePaintFont;
procedure CreateRowBuffers;
procedure DeleteChars(N: Integer);
procedure DeleteLines(N: Integer);
procedure DestroyRowBuffers;
procedure DirtyAll;
procedure DirtyBlinkRows;
procedure DirtyRow(Row: Integer);
procedure DoScrollDown;
procedure DoScrollUp;
procedure EraseDisplay(Mode: Integer);
procedure EraseLine(Mode: Integer);
procedure ExecuteCSI(FinalCh: Char);
procedure ExecuteMusic;
procedure FreeLineList(List: TList);
function GetCursorCol: Integer;
function GetCursorRow: Integer;
procedure InitDibInfo;
procedure InsertChars(N: Integer);
procedure InsertLines(N: Integer);
procedure ParseData(const S: string);
procedure ParseDataBuf(Buf: PChar; Len: Integer);
procedure ParseSGR;
procedure ProcessChar(Ch: Char);
procedure RecalcCellSize;
procedure RenderRow(Row: Integer);
procedure ResizeScreen;
procedure SetCols(Value: Integer);
procedure SetCursorVisible(Value: Boolean);
procedure SetRows(Value: Integer);
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 WMVScroll(var Msg: TWMScroll); message wm_VScroll;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Clear;
procedure Reset;
procedure FlipToScreen;
procedure TickBlink;
procedure Write(const S: string);
procedure WriteDeferred(const S: string);
procedure WriteDeferredBuf(Buf: PChar; Len: Integer);
property CursorCol: Integer read GetCursorCol;
property CursorRow: Integer read GetCursorRow;
published
property Cols: Integer read FCols write SetCols default 80;
property Rows: Integer read FRows write SetRows default 25;
property ScrollbackSize: Integer read FScrollbackSize
write SetScrollbackSize default 500;
property CursorVisible: Boolean read FCursorVisible
write SetCursorVisible default True;
property Font;
property Color default clBlack;
property OnKeyData: TKeyDataEvent read FOnKeyData write FOnKeyData;
property TabStop default True;
end;
procedure Register;
implementation
const
AnsiColors: array[0..15] of TColor = (
$00000000, { 0 Black }
$00000080, { 1 Red (low) -- BGR order }
$00008000, { 2 Green }
$00008080, { 3 Yellow/Brown }
$00800000, { 4 Blue }
$00800080, { 5 Magenta }
$00808000, { 6 Cyan }
$00C0C0C0, { 7 White (low) }
$00808080, { 8 Dark Gray }
$000000FF, { 9 Red (bright) }
$0000FF00, { 10 Green (bright) }
$0000FFFF, { 11 Yellow (bright) }
$00FF0000, { 12 Blue (bright) }
$00FF00FF, { 13 Magenta (bright) }
$00FFFF00, { 14 Cyan (bright) }
$00FFFFFF { 15 White (bright) }
);
{ Blink toggle interval in milliseconds (cursor + text blink). }
BlinkMs = 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 = (
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 parameters from char buffer }
{ Zero-allocation: parses integers directly without Copy or StrToIntDef. }
{ ----------------------------------------------------------------------- }
procedure ParseParamBuf(Buf: PChar; Len: Integer;
var Params: array of Integer; var Count: Integer);
var
I: Integer;
Value: Integer;
InNum: Boolean;
begin
Count := 0;
Value := 0;
InNum := False;
for I := 0 to Len - 1 do
begin
if Buf[I] = ';' then
begin
if Count <= High(Params) then
begin
if InNum then
Params[Count] := Value
else
Params[Count] := 0;
Inc(Count);
end;
Value := 0;
InNum := False;
end
else if (Buf[I] >= '0') and (Buf[I] <= '9') then
begin
Value := Value * 10 + (Ord(Buf[I]) - Ord('0'));
InNum := True;
end;
end;
{ Last value after final semicolon (or entire buffer if no semicolons) }
if Count <= High(Params) then
begin
if InNum then
Params[Count] := Value
else
Params[Count] := 0;
Inc(Count);
end;
end;
{ ----------------------------------------------------------------------- }
{ TKPAnsi }
{ ----------------------------------------------------------------------- }
procedure TKPAnsi.AllocLine(Line: PTermLine);
var
I: Integer;
begin
for I := 0 to FCols - 1 do
begin
Line^.Cells[I].Ch := ' ';
Line^.Cells[I].FG := 7;
Line^.Cells[I].BG := 0;
Line^.Cells[I].Bold := False;
Line^.Cells[I].Blink := False;
end;
end;
procedure TKPAnsi.BuildAtlas;
{ Render all 256 CP437 characters into a monochrome bitmap, then extract }
{ per-glyph pixel masks into the glyph block at offset 64. Each glyph }
{ byte is an 8-bit mask: MSB = leftmost pixel, 1 = FG, 0 = BG. The }
{ nibble lookup table at offset 0..63 is built at render time. 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;
GlyphPtr: PPixelBuf;
Stride: Longint;
BmpSize: Longint;
Ch: Char;
begin
{ Free old glyph block }
if FGlyphBufH <> 0 then
begin
GlobalUnlock(FGlyphBufH);
GlobalFree(FGlyphBufH);
FGlyphBufH := 0;
FGlyphBuf := nil;
end;
if FPaintFont = 0 then
Exit;
if (FCellWidth < 1) or (FCellHeight < 1) or (FCellHeight > 32) then
Exit;
{ Allocate glyph block: 64 bytes nibble table + 256*32 glyph data }
FGlyphBufH := GlobalAlloc(GMEM_FIXED or GMEM_ZEROINIT, 8256);
if FGlyphBufH = 0 then
Exit;
FGlyphBuf := GlobalLock(FGlyphBufH);
if FGlyphBuf = nil then
begin
GlobalFree(FGlyphBufH);
FGlyphBufH := 0;
Exit;
end;
GlyphPtr := PPixelBuf(FGlyphBuf);
{ 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 into glyph block at offset 64. }
{ 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
GlyphPtr^[64 + I * 32 + 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;
Line: PTermLine;
begin
{ Move current screen lines to scrollback }
for I := 0 to FScreen.Count - 1 do
begin
FScrollback.Add(FScreen[I]);
end;
FScreen.Clear;
TrimScrollback;
{ Allocate fresh screen lines }
for I := 0 to FRows - 1 do
begin
GetMem(Line, SizeOf(TTermLineRec));
AllocLine(Line);
FScreen.Add(Line);
end;
FCursorRow := 0;
FCursorCol := 0;
FScrollPos := 0;
UpdateScrollbar;
FAllDirty := True;
Invalidate;
end;
procedure TKPAnsi.ClearLine(Line: PTermLine);
var
I: Integer;
begin
for I := 0 to FCols - 1 do
begin
Line^.Cells[I].Ch := ' ';
Line^.Cells[I].FG := 7;
Line^.Cells[I].BG := 0;
Line^.Cells[I].Bold := False;
Line^.Cells[I].Blink := False;
end;
end;
procedure TKPAnsi.CMFontChanged(var Msg: TMessage);
begin
inherited;
RecalcCellSize;
end;
constructor TKPAnsi.Create(AOwner: TComponent);
var
I: Integer;
Line: PTermLine;
begin
inherited Create(AOwner);
Width := 640;
Height := 400;
Color := clBlack;
TabStop := True;
FCols := 80;
FRows := 25;
FScrollbackSize := 500;
FCursorVisible := True;
FScreen := TList.Create;
FScrollback := TList.Create;
FCursorRow := 0;
FCursorCol := 0;
FLastCursorRow := 0;
FSaveCurRow := 0;
FSaveCurCol := 0;
FAttrFG := 7;
FAttrBG := 0;
FAttrBold := False;
FAttrBlink := False;
FAttrReverse := False;
FParseState := psNormal;
FParamLen := 0;
FMusicStr := '';
FCellWidth := 8;
FCellHeight := 16;
FBlinkOn := True;
FLastBlinkTick := GetTickCount;
FScrollPos := 0;
FPendingScrolls := 0;
FWrapMode := True;
FPaintFont := 0;
FStockFont := False;
FAllDirty := True;
FScrollbarDirty := False;
FTextBlinkOn := True;
FRowBufSize := 0;
FGlyphBufH := 0;
FGlyphBuf := nil;
FRowBufH := 0;
FRowBuf := nil;
FNibbleFG := 255;
FNibbleBG := 255;
{ Set a monospace font -- OEM charset selected in CreatePaintFont }
Font.Name := 'Terminal';
Font.Size := 9;
Font.Pitch := fpFixed;
{ Allocate initial screen lines }
for I := 0 to FRows - 1 do
begin
GetMem(Line, SizeOf(TTermLineRec));
AllocLine(Line);
FScreen.Add(Line);
end;
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. Raster }
{ precision prevents the font mapper from substituting a TrueType font }
{ that might remap character codes through Unicode tables. }
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
FPaintFont := NewFont
else
DeleteObject(NewFont);
end;
if FPaintFont = 0 then
begin
FPaintFont := GetStockObject(OEM_FIXED_FONT);
FStockFont := True;
end;
end;
procedure TKPAnsi.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or ws_VScroll;
{ 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.CreateRowBuffers;
begin
{ Free old row buffer (glyph block is managed by BuildAtlas) }
if FRowBufH <> 0 then
begin
GlobalUnlock(FRowBufH);
GlobalFree(FRowBufH);
FRowBufH := 0;
FRowBuf := nil;
end;
FRowBufSize := FCols * FCellWidth * FCellHeight;
if FRowBufSize < 1 then
Exit;
{ Single reusable buffer for one terminal row }
FRowBufH := GlobalAlloc(GMEM_FIXED or GMEM_ZEROINIT, FRowBufSize);
if FRowBufH <> 0 then
FRowBuf := GlobalLock(FRowBufH)
else
FRowBuf := nil;
end;
procedure TKPAnsi.DeleteChars(N: Integer);
var
Line: PTermLine;
I: Integer;
begin
if N < 1 then
N := 1;
Line := FScreen[FCursorRow];
for I := FCursorCol to FCols - 1 - N do
Line^.Cells[I] := Line^.Cells[I + N];
for I := FCols - N to FCols - 1 do
begin
if I >= 0 then
begin
Line^.Cells[I].Ch := ' ';
Line^.Cells[I].FG := 7;
Line^.Cells[I].BG := 0;
Line^.Cells[I].Bold := False;
Line^.Cells[I].Blink := False;
end;
end;
FDirtyRow[FCursorRow] := True;
end;
procedure TKPAnsi.DeleteLines(N: Integer);
var
I: Integer;
J: Integer;
Line: PTermLine;
begin
if N < 1 then
N := 1;
for I := 1 to N do
begin
if FCursorRow < FScreen.Count then
begin
Line := FScreen[FCursorRow];
FreeMem(Line, SizeOf(TTermLineRec));
FScreen.Delete(FCursorRow);
GetMem(Line, SizeOf(TTermLineRec));
AllocLine(Line);
FScreen.Add(Line);
end;
end;
for J := FCursorRow to FRows - 1 do
FDirtyRow[J] := True;
end;
destructor TKPAnsi.Destroy;
begin
DestroyRowBuffers;
if (FPaintFont <> 0) and not FStockFont then
begin
DeleteObject(FPaintFont);
FPaintFont := 0;
end;
FreeLineList(FScreen);
FScreen.Free;
FreeLineList(FScrollback);
FScrollback.Free;
inherited Destroy;
end;
procedure TKPAnsi.DestroyRowBuffers;
begin
if FRowBufH <> 0 then
begin
GlobalUnlock(FRowBufH);
GlobalFree(FRowBufH);
FRowBufH := 0;
FRowBuf := nil;
end;
if FGlyphBufH <> 0 then
begin
GlobalUnlock(FGlyphBufH);
GlobalFree(FGlyphBufH);
FGlyphBufH := 0;
FGlyphBuf := nil;
end;
end;
procedure TKPAnsi.DirtyAll;
begin
FAllDirty := True;
end;
procedure TKPAnsi.DirtyBlinkRows;
{ Targeted dirty marking for blink toggle. Instead of DirtyAll (which }
{ forces a full 25-row re-render and 25 SetDIBitsToDevice calls), only }
{ dirty the cursor row (cursor blink) and rows containing blink cells }
{ (text blink). Typical BBS content has 0-3 blink rows, so this reduces }
{ blink overhead from ~63ms to ~3ms on a 486. }
var
I: Integer;
J: Integer;
Line: PTermLine;
begin
{ In scrollback view, FlipToScreen sets FAllDirty anyway }
if FAllDirty or (FScrollPos <> 0) then
Exit;
{ Dirty cursor row for cursor blink }
if FCursorVisible and (FCursorRow >= 0) and (FCursorRow < FRows) then
FDirtyRow[FCursorRow] := True;
{ Dirty rows containing blink cells for text blink }
for I := 0 to FRows - 1 do
begin
if not FDirtyRow[I] and (I < FScreen.Count) then
begin
Line := FScreen[I];
for J := 0 to FCols - 1 do
begin
if Line^.Cells[J].Blink then
begin
FDirtyRow[I] := True;
Break;
end;
end;
end;
end;
end;
procedure TKPAnsi.DirtyRow(Row: Integer);
begin
if (Row >= 0) and (Row <= 255) then
FDirtyRow[Row] := True;
end;
procedure TKPAnsi.DoScrollDown;
var
Line: PTermLine;
begin
if FScreen.Count < FRows then
Exit;
{ Remove bottom line }
Line := FScreen[FScreen.Count - 1];
FreeMem(Line, SizeOf(TTermLineRec));
FScreen.Delete(FScreen.Count - 1);
{ Insert blank line at top }
GetMem(Line, SizeOf(TTermLineRec));
AllocLine(Line);
FScreen.Insert(0, Line);
{ Scroll down is rare; just repaint everything }
FAllDirty := True;
end;
procedure TKPAnsi.DoScrollUp;
var
Line: PTermLine;
begin
if FScreen.Count < FRows then
Exit;
{ Move top line to scrollback }
Line := FScreen[0];
FScrollback.Add(Line);
FScreen.Delete(0);
{ TrimScrollback deferred to ParseData for batching }
{ Add blank line at bottom }
GetMem(Line, SizeOf(TTermLineRec));
AllocLine(Line);
FScreen.Add(Line);
FScrollbarDirty := True;
{ Track pending scrolls for coalesced ScrollDC in FlipToScreen. }
{ Multiple scrolls during one ParseData call collapse into a single }
{ ScrollDC call, then only the newly exposed bottom rows are rendered.}
Inc(FPendingScrolls);
end;
procedure TKPAnsi.EraseDisplay(Mode: Integer);
var
I: Integer;
J: Integer;
Line: PTermLine;
begin
case Mode of
0: { Erase below: current position to end of screen }
begin
{ Erase rest of current line }
Line := FScreen[FCursorRow];
for J := FCursorCol to FCols - 1 do
begin
Line^.Cells[J].Ch := ' ';
Line^.Cells[J].FG := 7;
Line^.Cells[J].BG := 0;
Line^.Cells[J].Bold := False;
Line^.Cells[J].Blink := False;
end;
{ Erase all lines below }
for I := FCursorRow + 1 to FScreen.Count - 1 do
begin
ClearLine(FScreen[I]);
end;
end;
1: { Erase above: start of screen to current position }
begin
{ Erase all lines above }
for I := 0 to FCursorRow - 1 do
begin
ClearLine(FScreen[I]);
end;
{ Erase current line up to and including cursor }
Line := FScreen[FCursorRow];
for J := 0 to FCursorCol do
begin
Line^.Cells[J].Ch := ' ';
Line^.Cells[J].FG := 7;
Line^.Cells[J].BG := 0;
Line^.Cells[J].Bold := False;
Line^.Cells[J].Blink := False;
end;
end;
2: { Erase all: move screen to scrollback, allocate fresh }
begin
for I := 0 to FScreen.Count - 1 do
begin
FScrollback.Add(FScreen[I]);
end;
FScreen.Clear;
TrimScrollback;
for I := 0 to FRows - 1 do
begin
GetMem(Line, SizeOf(TTermLineRec));
AllocLine(Line);
FScreen.Add(Line);
end;
UpdateScrollbar;
end;
end;
{ Mark affected rows dirty for deferred batch rendering }
case Mode of
0:
for I := FCursorRow to FRows - 1 do
FDirtyRow[I] := True;
1:
for I := 0 to FCursorRow do
FDirtyRow[I] := True;
2:
FAllDirty := True;
end;
end;
procedure TKPAnsi.EraseLine(Mode: Integer);
var
J: Integer;
Line: PTermLine;
begin
Line := FScreen[FCursorRow];
case Mode of
0: { Erase from cursor to end of line }
begin
for J := FCursorCol to FCols - 1 do
begin
Line^.Cells[J].Ch := ' ';
Line^.Cells[J].FG := 7;
Line^.Cells[J].BG := 0;
Line^.Cells[J].Bold := False;
Line^.Cells[J].Blink := False;
end;
end;
1: { Erase from start of line to cursor }
begin
for J := 0 to FCursorCol do
begin
Line^.Cells[J].Ch := ' ';
Line^.Cells[J].FG := 7;
Line^.Cells[J].BG := 0;
Line^.Cells[J].Bold := False;
Line^.Cells[J].Blink := False;
end;
end;
2: { Erase entire line }
ClearLine(Line);
end;
FDirtyRow[FCursorRow] := True;
end;
procedure TKPAnsi.ExecuteCSI(FinalCh: Char);
var
Params: array[0..15] of Integer;
Count: Integer;
P1: Integer;
P2: Integer;
begin
ParseParamBuf(@FParamBuf[0], FParamLen, Params, Count);
if Count > 0 then
P1 := Params[0]
else
P1 := 0;
if Count > 1 then
P2 := Params[1]
else
P2 := 0;
case FinalCh of
'A': { CUU - Cursor Up }
begin
if P1 < 1 then
P1 := 1;
FCursorRow := FCursorRow - P1;
if FCursorRow < 0 then
FCursorRow := 0;
end;
'B': { CUD - Cursor Down }
begin
if P1 < 1 then
P1 := 1;
FCursorRow := FCursorRow + P1;
if FCursorRow >= FRows then
FCursorRow := FRows - 1;
end;
'C': { CUF - Cursor Forward }
begin
if P1 < 1 then
P1 := 1;
FCursorCol := FCursorCol + P1;
if FCursorCol >= FCols then
FCursorCol := FCols - 1;
end;
'D': { CUB - Cursor Back }
begin
if P1 < 1 then
P1 := 1;
FCursorCol := FCursorCol - P1;
if FCursorCol < 0 then
FCursorCol := 0;
end;
'H', 'f': { CUP/HVP - Cursor Position (1-based params) }
begin
if P1 < 1 then
P1 := 1;
if P2 < 1 then
P2 := 1;
FCursorRow := P1 - 1;
FCursorCol := P2 - 1;
if FCursorRow >= FRows then
FCursorRow := FRows - 1;
if FCursorCol >= FCols then
FCursorCol := FCols - 1;
end;
'J': { ED - Erase Display }
begin
EraseDisplay(P1);
end;
'K': { EL - Erase Line }
begin
EraseLine(P1);
end;
'L': { IL - Insert Lines }
begin
InsertLines(P1);
end;
'M': { DL - Delete Lines }
begin
DeleteLines(P1);
end;
'P': { DCH - Delete Characters }
begin
DeleteChars(P1);
end;
'S': { SU - Scroll Up }
begin
if P1 < 1 then
P1 := 1;
while P1 > 0 do
begin
DoScrollUp;
Dec(P1);
end;
end;
'T': { SD - Scroll Down }
begin
if P1 < 1 then
P1 := 1;
while P1 > 0 do
begin
DoScrollDown;
Dec(P1);
end;
end;
'@': { ICH - Insert Characters }
begin
InsertChars(P1);
end;
'm': { SGR - Set Graphic Rendition }
begin
ParseSGR;
end;
's': { SCP - Save Cursor Position }
begin
FSaveCurRow := FCursorRow;
FSaveCurCol := FCursorCol;
end;
'c': { DA - Device Attributes }
begin
{ Respond as VT100 with no options }
if Assigned(FOnKeyData) then
FOnKeyData(Self, #27'[?1;0c');
end;
'n': { DSR - Device Status Report }
begin
if P1 = 5 then
begin
{ Terminal status: report OK }
if Assigned(FOnKeyData) then
FOnKeyData(Self, #27'[0n');
end
else if P1 = 6 then
begin
{ Cursor Position Report: respond with ESC[row;colR (1-based) }
if Assigned(FOnKeyData) then
FOnKeyData(Self, #27'[' + IntToStr(FCursorRow + 1) + ';' +
IntToStr(FCursorCol + 1) + 'R');
end;
end;
'u': { RCP - Restore Cursor Position }
begin
FCursorRow := FSaveCurRow;
FCursorCol := FSaveCurCol;
if FCursorRow >= FRows then
FCursorRow := FRows - 1;
if FCursorCol >= FCols then
FCursorCol := FCols - 1;
end;
end;
end;
procedure TKPAnsi.ExecuteMusic;
var
Tempo: Integer;
DefLen: Integer;
Octave: Integer;
I: Integer;
Ch: Char;
NoteIdx: Integer;
Duration: Integer;
Dotted: Boolean;
NoteDurMs: Integer;
Freq: Integer;
OctMul: Integer;
J: Integer;
NumStr: string;
begin
if Length(FMusicStr) = 0 then
Exit;
Tempo := 120;
DefLen := 4;
Octave := 4;
{ Open sound device }
OpenSound;
I := 1;
while I <= Length(FMusicStr) do
begin
Ch := UpCase(FMusicStr[I]);
Inc(I);
case Ch of
'T': { Tempo }
begin
NumStr := '';
while (I <= Length(FMusicStr)) and
(FMusicStr[I] >= '0') and (FMusicStr[I] <= '9') do
begin
NumStr := NumStr + FMusicStr[I];
Inc(I);
end;
if Length(NumStr) > 0 then
Tempo := StrToIntDef(NumStr, 120);
if Tempo < 32 then
Tempo := 32;
if Tempo > 255 then
Tempo := 255;
end;
'L': { Default length }
begin
NumStr := '';
while (I <= Length(FMusicStr)) and
(FMusicStr[I] >= '0') and (FMusicStr[I] <= '9') do
begin
NumStr := NumStr + FMusicStr[I];
Inc(I);
end;
if Length(NumStr) > 0 then
DefLen := StrToIntDef(NumStr, 4);
if DefLen < 1 then
DefLen := 1;
end;
'O': { Octave }
begin
NumStr := '';
while (I <= Length(FMusicStr)) and
(FMusicStr[I] >= '0') and (FMusicStr[I] <= '9') do
begin
NumStr := NumStr + FMusicStr[I];
Inc(I);
end;
if Length(NumStr) > 0 then
Octave := StrToIntDef(NumStr, 4);
if Octave < 0 then
Octave := 0;
if Octave > 7 then
Octave := 7;
end;
'>': { Octave up }
begin
if Octave < 7 then
Inc(Octave);
end;
'<': { Octave down }
begin
if Octave > 0 then
Dec(Octave);
end;
'A'..'G': { Note }
begin
{ Map note letter to semitone index: C=0 D=2 E=4 F=5 G=7 A=9 B=11 }
case Ch of
'C': NoteIdx := 0;
'D': NoteIdx := 2;
'E': NoteIdx := 4;
'F': NoteIdx := 5;
'G': NoteIdx := 7;
'A': NoteIdx := 9;
'B': NoteIdx := 11;
else NoteIdx := 0;
end;
{ Check for sharp/flat }
if I <= Length(FMusicStr) then
begin
if (FMusicStr[I] = '#') or (FMusicStr[I] = '+') then
begin
Inc(NoteIdx);
if NoteIdx > 11 then
NoteIdx := 11;
Inc(I);
end
else if FMusicStr[I] = '-' then
begin
Dec(NoteIdx);
if NoteIdx < 0 then
NoteIdx := 0;
Inc(I);
end;
end;
{ Parse optional duration }
Duration := 0;
NumStr := '';
while (I <= Length(FMusicStr)) and
(FMusicStr[I] >= '0') and (FMusicStr[I] <= '9') do
begin
NumStr := NumStr + FMusicStr[I];
Inc(I);
end;
if Length(NumStr) > 0 then
Duration := StrToIntDef(NumStr, 0);
if Duration < 1 then
Duration := DefLen;
{ Check for dot }
Dotted := False;
if (I <= Length(FMusicStr)) and (FMusicStr[I] = '.') then
begin
Dotted := True;
Inc(I);
end;
{ Calculate duration in ms: whole note = 4 beats, beat = 60000/tempo ms }
NoteDurMs := (4 * 60000) div (Tempo * Duration);
if Dotted then
NoteDurMs := (NoteDurMs * 3) div 2;
{ Calculate frequency }
Freq := BaseNoteFreq[NoteIdx];
OctMul := 1;
for J := 1 to Octave do
begin
OctMul := OctMul * 2;
end;
Freq := (Freq * OctMul) div 16; { BaseNoteFreq is at octave 4 }
{ Queue the note }
SetVoiceAccent(1, Tempo, 128, 0, 0);
SetVoiceNote(1, Freq, Duration, 0);
end;
'P': { Pause/Rest }
begin
Duration := 0;
NumStr := '';
while (I <= Length(FMusicStr)) and
(FMusicStr[I] >= '0') and (FMusicStr[I] <= '9') do
begin
NumStr := NumStr + FMusicStr[I];
Inc(I);
end;
if Length(NumStr) > 0 then
Duration := StrToIntDef(NumStr, 0);
if Duration < 1 then
Duration := DefLen;
{ Dotted rest }
if (I <= Length(FMusicStr)) and (FMusicStr[I] = '.') then
Inc(I);
SetVoiceNote(1, 0, Duration, 0);
end;
end;
end;
StartSound;
CloseSound;
end;
procedure TKPAnsi.FlipToScreen;
{ Render dirty rows into the shared 8bpp DIB buffer, blasting each to the }
{ screen via SetDIBitsToDevice immediately after rendering. One GDI call }
{ per dirty row, zero for the pixel expansion itself. Coalesced ScrollDC }
{ shifts on-screen pixels to match FScreen after scrolling, reducing the }
{ per-scroll GDI cost from 25 rows to just the newly exposed rows. }
var
DC: HDC;
Row: Integer;
GhostRow: Integer;
HasDirty: Boolean;
ScrollR: TRect;
ClipR: TRect;
UpdateR: TRect;
begin
if not HandleAllocated then
Exit;
if FRowBuf = nil then
RecalcCellSize;
if FRowBuf = nil then
Exit;
{ Scrollback view: force full redraw (line mapping changes) }
if FScrollPos <> 0 then
begin
FAllDirty := True;
FPendingScrolls := 0;
end;
{ Deferred scrollbar update (batched from DoScrollUp) }
if FScrollbarDirty then
begin
UpdateScrollbar;
FScrollbarDirty := False;
end;
{ Coalesced ScrollDC: shift on-screen pixels to match FScreen after }
{ one or more DoScrollUp calls, then only render the newly exposed rows. }
if (FPendingScrolls > 0) and not FAllDirty then
begin
if FPendingScrolls < FRows then
begin
ScrollR.Left := 0;
ScrollR.Top := 0;
ScrollR.Right := FCols * FCellWidth;
ScrollR.Bottom := FRows * FCellHeight;
ClipR := ScrollR;
DC := GetDC(Handle);
ScrollDC(DC, 0, -(FPendingScrolls * FCellHeight),
ScrollR, ClipR, 0, @UpdateR);
ReleaseDC(Handle, DC);
{ Dirty the newly exposed bottom rows }
for Row := FRows - FPendingScrolls to FRows - 1 do
begin
if Row >= 0 then
FDirtyRow[Row] := True;
end;
{ Dirty row that now shows cursor ghost from pre-scroll pixels }
GhostRow := FCursorRow - FPendingScrolls;
if (GhostRow >= 0) and (GhostRow < FRows) then
FDirtyRow[GhostRow] := True;
{ Sync FLastCursorRow since pixel positions shifted }
FLastCursorRow := FCursorRow;
end
else
FAllDirty := True;
FPendingScrolls := 0;
end;
{ Dirty old cursor row to erase ghost when cursor moved between rows }
if FCursorRow <> FLastCursorRow then
begin
if (FLastCursorRow >= 0) and (FLastCursorRow <= 255) then
FDirtyRow[FLastCursorRow] := True;
if (FCursorRow >= 0) and (FCursorRow <= 255) then
FDirtyRow[FCursorRow] := True;
FLastCursorRow := FCursorRow;
end;
{ Early exit: skip GetDC/ReleaseDC when nothing needs rendering }
if not FAllDirty then
begin
HasDirty := False;
for Row := 0 to FRows - 1 do
begin
if FDirtyRow[Row] then
begin
HasDirty := True;
Break;
end;
end;
if not HasDirty then
Exit;
end;
{ Interleaved render + blast: single buffer is reused per row }
DC := GetDC(Handle);
for Row := 0 to FRows - 1 do
begin
if FAllDirty or FDirtyRow[Row] then
begin
RenderRow(Row);
SetDIBitsToDevice(DC,
0, Row * FCellHeight,
FCols * FCellWidth, FCellHeight,
0, 0,
0, FCellHeight,
FRowBuf,
PBitmapInfo(@FDibInfo)^,
0); { DIB_RGB_COLORS }
FDirtyRow[Row] := False;
end;
end;
FAllDirty := False;
ReleaseDC(Handle, DC);
end;
procedure TKPAnsi.FreeLineList(List: TList);
var
I: Integer;
begin
for I := 0 to List.Count - 1 do
begin
FreeMem(PTermLine(List[I]), SizeOf(TTermLineRec));
end;
List.Clear;
end;
function TKPAnsi.GetCursorCol: Integer;
begin
Result := FCursorCol;
end;
function TKPAnsi.GetCursorRow: Integer;
begin
Result := FCursorRow;
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;
I: Integer;
begin
if N < 1 then
N := 1;
Line := FScreen[FCursorRow];
for I := FCols - 1 downto FCursorCol + N do
Line^.Cells[I] := Line^.Cells[I - N];
for I := FCursorCol to FCursorCol + N - 1 do
begin
if I < FCols then
begin
Line^.Cells[I].Ch := ' ';
Line^.Cells[I].FG := 7;
Line^.Cells[I].BG := 0;
Line^.Cells[I].Bold := False;
Line^.Cells[I].Blink := False;
end;
end;
FDirtyRow[FCursorRow] := True;
end;
procedure TKPAnsi.InsertLines(N: Integer);
var
I: Integer;
J: Integer;
Line: PTermLine;
begin
if N < 1 then
N := 1;
for I := 1 to N do
begin
if FScreen.Count > 0 then
begin
Line := FScreen[FScreen.Count - 1];
FreeMem(Line, SizeOf(TTermLineRec));
FScreen.Delete(FScreen.Count - 1);
end;
GetMem(Line, SizeOf(TTermLineRec));
AllocLine(Line);
FScreen.Insert(FCursorRow, Line);
end;
for J := FCursorRow to FRows - 1 do
FDirtyRow[J] := True;
end;
procedure TKPAnsi.KeyDown(var Key: Word; Shift: TShiftState);
var
S: string;
begin
S := '';
case Key of
vk_Up:
S := #27'[A';
vk_Down:
S := #27'[B';
vk_Right:
S := #27'[C';
vk_Left:
S := #27'[D';
vk_Home:
S := #27'[H';
vk_End:
S := #27'[K';
vk_Prior: { Page Up }
S := #27'[V';
vk_Next: { Page Down }
S := #27'[U';
vk_Insert:
S := #27'[@';
vk_Delete:
S := #27#127;
vk_F1:
S := #27'OP';
vk_F2:
S := #27'OQ';
vk_F3:
S := #27'OR';
vk_F4:
S := #27'OS';
vk_F5:
S := #27'Ot';
vk_F6:
S := #27'Ou';
vk_F7:
S := #27'Ov';
vk_F8:
S := #27'Ow';
vk_F9:
S := #27'Ox';
vk_F10:
S := #27'Oy';
end;
if (Length(S) > 0) and Assigned(FOnKeyData) then
begin
FOnKeyData(Self, S);
Key := 0;
end;
inherited KeyDown(Key, Shift);
end;
procedure TKPAnsi.KeyPress(var Key: Char);
var
S: string;
begin
if Key = #13 then
S := #13
else if Key >= ' ' then
S := Key
else if Key = #8 then
S := #8
else if Key = #9 then
S := #9
else if Key = #27 then
S := #27
else
S := '';
if (Length(S) > 0) and Assigned(FOnKeyData) then
begin
FOnKeyData(Self, S);
end;
inherited KeyPress(Key);
end;
procedure TKPAnsi.Paint;
var
Row: Integer;
begin
if FRowBuf = nil then
RecalcCellSize;
if FRowBuf = nil then
Exit;
{ Full repaint: render each row into the shared buffer and blast it }
FAllDirty := True;
for Row := 0 to FRows - 1 do
begin
RenderRow(Row);
SetDIBitsToDevice(Canvas.Handle,
0, Row * FCellHeight,
FCols * FCellWidth, FCellHeight,
0, 0,
0, FCellHeight,
FRowBuf,
PBitmapInfo(@FDibInfo)^,
0); { DIB_RGB_COLORS }
FDirtyRow[Row] := False;
end;
FAllDirty := False;
end;
procedure TKPAnsi.ParseData(const S: string);
{ String wrapper -- delegates to ParseDataBuf for actual processing. }
begin
if Length(S) > 0 then
ParseDataBuf(@S[1], Length(S));
end;
procedure TKPAnsi.ParseDataBuf(Buf: PChar; Len: Integer);
{ Process incoming data from a PChar buffer (no string allocation needed). }
{ Fast path batches runs of printable characters: colors are computed once }
{ per run, and cells are filled in a tight loop without per-character state }
{ checks. Run length is bounded by end of input, end of current row, or }
{ next non-printable character -- whichever comes first. }
{ }
{ Does NOT call FlipToScreen -- the caller handles rendering. }
var
I: Integer;
Line: PTermLine;
FGIdx: Byte;
BGIdx: Byte;
RunEnd: Integer;
Remaining: Integer;
begin
Line := nil;
I := 0;
while I < Len do
begin
{ Fast path: printable character in normal state }
if (FParseState = psNormal) and (Buf[I] >= ' ') then
begin
{ Handle wrap at right margin }
if FCursorCol >= FCols then
begin
if FWrapMode then
begin
FCursorCol := 0;
Inc(FCursorRow);
if FCursorRow >= FRows then
begin
FCursorRow := FRows - 1;
DoScrollUp;
end;
Line := nil;
end
else
FCursorCol := FCols - 1;
end;
if Line = nil then
Line := FScreen[FCursorRow];
{ Compute colors once for the entire run }
if FAttrBold then
FGIdx := FAttrFG + 8
else
FGIdx := FAttrFG;
BGIdx := FAttrBG;
{ Find run end: stop at control char, end of input, or end of row }
Remaining := FCols - FCursorCol;
RunEnd := I;
while (RunEnd < Len) and (Buf[RunEnd] >= ' ') and
(RunEnd - I < Remaining) do
Inc(RunEnd);
{ Fill cells in tight loop -- no per-character state/wrap checks }
if FAttrReverse then
begin
while I < RunEnd do
begin
Line^.Cells[FCursorCol].Ch := Buf[I];
Line^.Cells[FCursorCol].FG := BGIdx;
Line^.Cells[FCursorCol].BG := FGIdx;
Line^.Cells[FCursorCol].Bold := FAttrBold;
Line^.Cells[FCursorCol].Blink := FAttrBlink;
Inc(FCursorCol);
Inc(I);
end;
end
else
begin
while I < RunEnd do
begin
Line^.Cells[FCursorCol].Ch := Buf[I];
Line^.Cells[FCursorCol].FG := FGIdx;
Line^.Cells[FCursorCol].BG := BGIdx;
Line^.Cells[FCursorCol].Bold := FAttrBold;
Line^.Cells[FCursorCol].Blink := FAttrBlink;
Inc(FCursorCol);
Inc(I);
end;
end;
FDirtyRow[FCursorRow] := True;
end
else
begin
{ Slow path: control chars, escape sequences }
Line := nil;
ProcessChar(Buf[I]);
Inc(I);
end;
end;
{ Deferred scrollback trim -- batched from DoScrollUp }
TrimScrollback;
{ Snap to bottom on new data }
if FScrollPos <> 0 then
begin
FScrollPos := 0;
FScrollbarDirty := True;
FAllDirty := True;
end;
end;
procedure TKPAnsi.ParseSGR;
var
Params: array[0..15] of Integer;
Count: Integer;
I: Integer;
Code: Integer;
begin
ParseParamBuf(@FParamBuf[0], FParamLen, Params, Count);
{ SGR with no parameters means reset }
if Count = 0 then
begin
FAttrFG := 7;
FAttrBG := 0;
FAttrBold := False;
FAttrBlink := False;
FAttrReverse := False;
Exit;
end;
for I := 0 to Count - 1 do
begin
Code := Params[I];
case Code of
0: { Reset }
begin
FAttrFG := 7;
FAttrBG := 0;
FAttrBold := False;
FAttrBlink := False;
FAttrReverse := False;
end;
1: { Bold }
FAttrBold := True;
5: { Blink }
FAttrBlink := True;
7: { Reverse }
FAttrReverse := True;
22: { Normal intensity (cancel bold) }
FAttrBold := False;
25: { Blink off }
FAttrBlink := False;
27: { Reverse off }
FAttrReverse := False;
30..37: { Foreground color }
FAttrFG := Code - 30;
40..47: { Background color }
FAttrBG := Code - 40;
end;
end;
end;
procedure TKPAnsi.ProcessChar(Ch: Char);
var
FGIdx: Integer;
BGIdx: Integer;
TabCol: Integer;
Line: PTermLine;
begin
case FParseState of
psNormal:
begin
case Ch of
#27: { ESC }
FParseState := psEscape;
#13: { CR }
FCursorCol := 0;
#10: { LF }
begin
Inc(FCursorRow);
if FCursorRow >= FRows then
begin
FCursorRow := FRows - 1;
DoScrollUp;
end;
end;
#8: { BS }
begin
if FCursorCol > 0 then
Dec(FCursorCol);
end;
#9: { TAB }
begin
TabCol := ((FCursorCol div 8) + 1) * 8;
if TabCol >= FCols then
TabCol := FCols - 1;
FCursorCol := TabCol;
end;
#5: { ENQ - Answerback }
begin
if Assigned(FOnKeyData) then
FOnKeyData(Self, #27'[?1;0c');
end;
#7: { BEL }
MessageBeep(0);
else
begin
{ Printable character }
if (FCursorCol >= FCols) then
begin
if FWrapMode then
begin
FCursorCol := 0;
Inc(FCursorRow);
if FCursorRow >= FRows then
begin
FCursorRow := FRows - 1;
DoScrollUp;
end;
end
else
begin
FCursorCol := FCols - 1;
end;
end;
{ Calculate effective colors. Bold maps FG to bright }
{ (index + 8). Blink is stored as a cell attribute }
{ and rendered in RenderRow -- NOT mapped to bright BG, }
{ so colored backgrounds (SGR 40-47) display correctly. }
if FAttrBold then
FGIdx := FAttrFG + 8
else
FGIdx := FAttrFG;
BGIdx := FAttrBG;
Line := FScreen[FCursorRow];
if FAttrReverse then
begin
Line^.Cells[FCursorCol].FG := BGIdx;
Line^.Cells[FCursorCol].BG := FGIdx;
end
else
begin
Line^.Cells[FCursorCol].FG := FGIdx;
Line^.Cells[FCursorCol].BG := BGIdx;
end;
Line^.Cells[FCursorCol].Ch := Ch;
Line^.Cells[FCursorCol].Bold := FAttrBold;
Line^.Cells[FCursorCol].Blink := FAttrBlink;
{ Mark row dirty for deferred batch rendering }
FDirtyRow[FCursorRow] := True;
Inc(FCursorCol);
end;
end;
end;
psEscape:
begin
case Ch of
'[':
begin
FParamLen := 0;
FParseState := psCSI;
end;
else
begin
{ Unrecognized escape sequence, return to normal }
FParseState := psNormal;
end;
end;
end;
psCSI:
begin
case Ch of
'0'..'9', ';':
begin
if FParamLen < 32 then
begin
FParamBuf[FParamLen] := Ch;
Inc(FParamLen);
end;
end;
'?':
begin
FParseState := psCSIQuestion;
end;
'M':
begin
{ Check if this is ANSI music: ESC[M starts music mode }
if FParamLen = 0 then
begin
FMusicStr := '';
FParseState := psMusic;
end
else
begin
{ DL - Delete Lines with params }
ExecuteCSI('M');
FParseState := psNormal;
end;
end;
else
begin
{ Final byte: execute the command }
ExecuteCSI(Ch);
FParseState := psNormal;
end;
end;
end;
psCSIQuestion:
begin
case Ch of
'0'..'9', ';':
begin
if FParamLen < 32 then
begin
FParamBuf[FParamLen] := Ch;
Inc(FParamLen);
end;
end;
'h': { Set Mode }
begin
if (FParamLen = 1) and (FParamBuf[0] = '7') then
FWrapMode := True
else if (FParamLen = 2) and (FParamBuf[0] = '2') and (FParamBuf[1] = '5') then
FCursorVisible := True;
FParseState := psNormal;
end;
'l': { Reset Mode }
begin
if (FParamLen = 1) and (FParamBuf[0] = '7') then
FWrapMode := False
else if (FParamLen = 2) and (FParamBuf[0] = '2') and (FParamBuf[1] = '5') then
FCursorVisible := False;
FParseState := psNormal;
end;
else
begin
{ Unrecognized DEC private mode, return to normal }
FParseState := psNormal;
end;
end;
end;
psMusic:
begin
if Ch = #14 then { Ctrl-N terminates music }
begin
ExecuteMusic;
FParseState := psNormal;
end
else
begin
FMusicStr := FMusicStr + Ch;
end;
end;
end;
end;
procedure TKPAnsi.RecalcCellSize;
var
DC: HDC;
Extent: Longint;
begin
if not HandleAllocated then
Exit;
{ Recreate the OEM charset paint font from current Font properties }
CreatePaintFont;
{ Measure character cell size }
DC := GetDC(Handle);
try
SelectObject(DC, FPaintFont);
Extent := GetTextExtent(DC, 'W', 1);
FCellWidth := LoWord(Extent);
FCellHeight := HiWord(Extent);
finally
ReleaseDC(Handle, DC);
end;
if FCellWidth < 1 then
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;
{ Build font atlas, initialize DIB palette, allocate row buffers }
BuildAtlas;
InitDibInfo;
CreateRowBuffers;
FAllDirty := True;
Invalidate;
end;
procedure TKPAnsi.RenderRow(Row: Integer);
{ Core atlas renderer with nibble lookup table and inline ASM. For each }
{ cell in the row, the Pascal outer loop resolves colors and rebuilds the }
{ 16-entry nibble table on color change. The inline ASM inner loop }
{ expands one glyph (all scanlines) by splitting each glyph byte into }
{ high and low nibbles, looking up 4 pre-resolved pixels per nibble, and }
{ writing them as word stores. Zero branching in the inner loop. }
{ }
{ Register allocation in ASM block: }
{ DS = glyph block segment (table at 0..63, glyph data at 64+) }
{ SI = glyph data offset (increments through scanlines) }
{ ES = pixel buffer segment }
{ DI = pixel buffer offset (decrements by Stride for bottom-up DIB) }
{ BX = table index (BH=0, BL = nibble * 4) }
{ CX = scanline counter }
{ AX/DX = temporaries }
{ }
{ Critical: Delphi 1.0 may allocate local variables to SI/DI as register }
{ variables. The ASM block clobbers SI/DI for its own purposes, so ALL }
{ local variable values are pushed to an explicit mini-frame (via PUSH) }
{ BEFORE any register clobber, then accessed via BP-relative offsets. }
{ BP-relative addressing defaults to SS segment, safe after DS change. }
var
Line: PTermLine;
Col: Integer;
FGIdx: Byte;
BGIdx: Byte;
CharCode: Integer;
SbkCount: Integer;
VisRow: Integer;
TabPtr: PPixelBuf;
I: Integer;
Ofs: Integer;
GlyphSeg: Word;
PixSeg: Word;
GlyphOfs: Word;
PixOfs: Word;
Stride: Word;
CellH: Word;
begin
if FRowBuf = nil then
Exit;
if FGlyphBuf = nil then
Exit;
Stride := Word(FCols) * Word(FCellWidth);
CellH := FCellHeight;
{ Extract segments from far pointers -- pure Pascal, no register clobber }
GlyphSeg := Seg(PPixelBuf(FGlyphBuf)^);
PixSeg := Seg(PPixelBuf(FRowBuf)^);
{ 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(PPixelBuf(FRowBuf)^, FRowBufSize, 0);
Exit;
end;
{ Force nibble table rebuild on first cell }
FNibbleFG := 255;
FNibbleBG := 255;
{ Push constant mini-frame values ONCE before the column loop. }
{ These 4 values (Stride, CellH, PixSeg, GlyphSeg) don't change }
{ across cells. Only per-cell values (GlyphOfs, PixOfs) are pushed }
{ inside the loop. This saves 320 push instructions per row (4 pushes }
{ x 80 cells). SP is 8 bytes below Delphi's expectation until the }
{ matching ADD SP,8 at the end, but local variable access uses BP, }
{ not SP, so this is safe. }
asm
push Stride
push CellH
push PixSeg
push GlyphSeg
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);
{ Rebuild nibble table on color change: 16 entries x 4 bytes }
if (FGIdx <> FNibbleFG) or (BGIdx <> FNibbleBG) then
begin
TabPtr := PPixelBuf(FGlyphBuf);
for I := 0 to 15 do
begin
Ofs := I * 4;
if (I and 8) <> 0 then TabPtr^[Ofs] := FGIdx
else TabPtr^[Ofs] := BGIdx;
if (I and 4) <> 0 then TabPtr^[Ofs + 1] := FGIdx
else TabPtr^[Ofs + 1] := BGIdx;
if (I and 2) <> 0 then TabPtr^[Ofs + 2] := FGIdx
else TabPtr^[Ofs + 2] := BGIdx;
if (I and 1) <> 0 then TabPtr^[Ofs + 3] := FGIdx
else TabPtr^[Ofs + 3] := BGIdx;
end;
FNibbleFG := FGIdx;
FNibbleBG := BGIdx;
end;
{ Compute offsets -- all 16-bit, no Longint }
GlyphOfs := 64 + Word(CharCode) shl 5;
PixOfs := Word(CellH - 1) * Stride + Word(Col) * 8;
asm
{ Push only per-cell values. Constants already on stack above. }
push PixOfs
push GlyphOfs
push bp
mov bp, sp
{ Mini-frame layout (same offsets as before): }
{ [bp] = saved original BP }
{ [bp+2] = GlyphOfs (pushed this cell) }
{ [bp+4] = PixOfs (pushed this cell) }
{ [bp+6] = GlyphSeg (pushed once before loop) }
{ [bp+8] = PixSeg (pushed once before loop) }
{ [bp+10] = CellH (pushed once before loop) }
{ [bp+12] = Stride (pushed once before loop) }
push ds
push bx
push si
push di
mov si, [bp+2]
mov es, [bp+8]
mov di, [bp+4]
mov cx, [bp+10]
xor bh, bh
mov ds, [bp+6]
@rowloop:
mov al, [si] { load glyph byte from DS:SI }
inc si
mov ah, al { save copy }
{ High nibble -> 4 pixels }
and al, $F0
shr al, 1
shr al, 1 { AL = high_nibble * 4 }
mov bl, al
mov dx, [bx] { 2 table bytes (DS:BX, table at offset 0) }
mov es:[di], dx
mov dx, [bx+2] { 2 more table bytes }
mov es:[di+2], dx
{ Low nibble -> 4 pixels }
mov al, ah
and al, $0F
shl al, 1
shl al, 1 { AL = low_nibble * 4 }
mov bl, al
mov dx, [bx]
mov es:[di+4], dx
mov dx, [bx+2]
mov es:[di+6], dx
sub di, [bp+12] { Stride via SS:[BP+12] -- safe after DS change }
dec cx
jnz @rowloop
pop di
pop si
pop bx
pop ds
pop bp
add sp, 4 { remove per-cell GlyphOfs + PixOfs only }
end;
end;
{ Cursor overlay: if cursor is on this row and visible, re-render the }
{ cursor cell with swapped FG/BG using the same ASM inner loop. }
{ Constants are still on the stack from above -- reused here. }
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);
{ Rebuild nibble table for cursor colors }
TabPtr := PPixelBuf(FGlyphBuf);
for I := 0 to 15 do
begin
Ofs := I * 4;
if (I and 8) <> 0 then TabPtr^[Ofs] := FGIdx
else TabPtr^[Ofs] := BGIdx;
if (I and 4) <> 0 then TabPtr^[Ofs + 1] := FGIdx
else TabPtr^[Ofs + 1] := BGIdx;
if (I and 2) <> 0 then TabPtr^[Ofs + 2] := FGIdx
else TabPtr^[Ofs + 2] := BGIdx;
if (I and 1) <> 0 then TabPtr^[Ofs + 3] := FGIdx
else TabPtr^[Ofs + 3] := BGIdx;
end;
FNibbleFG := FGIdx;
FNibbleBG := BGIdx;
GlyphOfs := 64 + Word(CharCode) shl 5;
PixOfs := Word(CellH - 1) * Stride + Word(FCursorCol) * 8;
asm
push PixOfs
push GlyphOfs
push bp
mov bp, sp
push ds
push bx
push si
push di
mov si, [bp+2]
mov es, [bp+8]
mov di, [bp+4]
mov cx, [bp+10]
xor bh, bh
mov ds, [bp+6]
@curloop:
mov al, [si]
inc si
mov ah, al
and al, $F0
shr al, 1
shr al, 1
mov bl, al
mov dx, [bx]
mov es:[di], dx
mov dx, [bx+2]
mov es:[di+2], dx
mov al, ah
and al, $0F
shl al, 1
shl al, 1
mov bl, al
mov dx, [bx]
mov es:[di+4], dx
mov dx, [bx+2]
mov es:[di+6], dx
sub di, [bp+12]
dec cx
jnz @curloop
pop di
pop si
pop bx
pop ds
pop bp
add sp, 4
end;
end;
{ Remove constant mini-frame words pushed before the column loop }
asm
add sp, 8
end;
end;
procedure TKPAnsi.Reset;
begin
FAttrFG := 7;
FAttrBG := 0;
FAttrBold := False;
FAttrBlink := False;
FAttrReverse := False;
FParseState := psNormal;
FParamLen := 0;
FMusicStr := '';
FWrapMode := True;
FSaveCurRow := 0;
FSaveCurCol := 0;
Clear;
end;
procedure TKPAnsi.ResizeScreen;
var
I: Integer;
Line: PTermLine;
begin
{ Free existing screen lines }
FreeLineList(FScreen);
{ Allocate new screen lines }
for I := 0 to FRows - 1 do
begin
GetMem(Line, SizeOf(TTermLineRec));
AllocLine(Line);
FScreen.Add(Line);
end;
FCursorRow := 0;
FCursorCol := 0;
FScrollPos := 0;
UpdateScrollbar;
RecalcCellSize;
end;
procedure TKPAnsi.SetCols(Value: Integer);
begin
if Value < 1 then
Value := 1;
if Value > 256 then
Value := 256;
if Value <> FCols then
begin
FCols := Value;
ResizeScreen;
end;
end;
procedure TKPAnsi.SetCursorVisible(Value: Boolean);
begin
if Value <> FCursorVisible then
begin
FCursorVisible := Value;
FDirtyRow[FCursorRow] := True;
FlipToScreen;
end;
end;
procedure TKPAnsi.SetRows(Value: Integer);
begin
if Value < 1 then
Value := 1;
if Value > 255 then
Value := 255;
if Value <> FRows then
begin
FRows := Value;
ResizeScreen;
end;
end;
procedure TKPAnsi.SetScrollbackSize(Value: Integer);
begin
if Value < 0 then
Value := 0;
FScrollbackSize := Value;
TrimScrollback;
end;
procedure TKPAnsi.TrimScrollback;
{ Batch-optimized: free excess items, shift remainder down in one pass, }
{ then shrink from the end. O(n) total vs O(k*n) for k front-deletions. }
var
Excess: Integer;
I: Integer;
Line: PTermLine;
begin
Excess := FScrollback.Count - FScrollbackSize;
if Excess <= 0 then
Exit;
{ Free the oldest lines }
for I := 0 to Excess - 1 do
begin
Line := FScrollback[I];
FreeMem(Line, SizeOf(TTermLineRec));
end;
{ Shift remaining items down in one pass }
for I := 0 to FScrollback.Count - Excess - 1 do
FScrollback[I] := FScrollback[I + Excess];
{ Remove excess slots from the end (O(1) per deletion) }
for I := 1 to Excess do
FScrollback.Delete(FScrollback.Count - 1);
end;
procedure TKPAnsi.UpdateScrollbar;
var
SbkCount: Integer;
begin
if not HandleAllocated then
Exit;
SbkCount := FScrollback.Count;
if SbkCount > 0 then
begin
SetScrollRange(Handle, sb_Vert, 0, SbkCount, False);
SetScrollPos(Handle, sb_Vert, SbkCount - FScrollPos, True);
end
else
begin
SetScrollRange(Handle, sb_Vert, 0, 0, False);
SetScrollPos(Handle, sb_Vert, 0, True);
end;
end;
procedure TKPAnsi.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
begin
{ Suppress background erase -- SetDIBitsToDevice covers everything }
Msg.Result := 1;
end;
procedure TKPAnsi.WMGetDlgCode(var Msg: TMessage);
begin
Msg.Result := dlgc_WantArrows or dlgc_WantTab or dlgc_WantChars;
end;
procedure TKPAnsi.TickBlink;
var
Now: Longint;
begin
Now := GetTickCount;
if Now - FLastBlinkTick >= BlinkMs then
begin
FLastBlinkTick := Now;
FBlinkOn := not FBlinkOn;
FTextBlinkOn := not FTextBlinkOn;
DirtyBlinkRows;
end;
end;
procedure TKPAnsi.WMVScroll(var Msg: TWMScroll);
var
SbkCount: Integer;
NewPos: Integer;
begin
SbkCount := FScrollback.Count;
if SbkCount = 0 then
Exit;
NewPos := FScrollPos;
case Msg.ScrollCode of
sb_LineUp:
Inc(NewPos);
sb_LineDown:
Dec(NewPos);
sb_PageUp:
Inc(NewPos, FRows);
sb_PageDown:
Dec(NewPos, FRows);
sb_ThumbPosition, sb_ThumbTrack:
NewPos := SbkCount - Msg.Pos;
sb_Top:
NewPos := SbkCount;
sb_Bottom:
NewPos := 0;
end;
if NewPos < 0 then
NewPos := 0;
if NewPos > SbkCount then
NewPos := SbkCount;
if NewPos <> FScrollPos then
begin
FScrollPos := NewPos;
SetScrollPos(Handle, sb_Vert, SbkCount - FScrollPos, True);
FlipToScreen;
end;
end;
procedure TKPAnsi.Write(const S: string);
begin
if Length(S) > 0 then
begin
ParseData(S);
FlipToScreen;
end;
end;
procedure TKPAnsi.WriteDeferred(const S: string);
begin
if Length(S) > 0 then
ParseData(S);
end;
procedure TKPAnsi.WriteDeferredBuf(Buf: PChar; Len: Integer);
begin
if Len > 0 then
ParseDataBuf(Buf, Len);
end;
{ ----------------------------------------------------------------------- }
{ Component registration }
{ ----------------------------------------------------------------------- }
procedure Register;
begin
RegisterComponents('KP', [TKPAnsi]);
end;
end.
Reference in a new issue View git blame Copy permalink