AI_Slop/WinComm
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
WinComm/delphi/KPANSI.PAS
Scott Duensing ec0ec8f074 Replace event-driven WM_COMMNOTIFY architecture with polling main loop 
The ISR still fills the ring buffer (mandatory for 115200 baud), but the
app now polls ReadComm directly via a PeekMessage loop instead of waiting
for WM_COMMNOTIFY.  Blink uses GetTickCount instead of WM_TIMER.  This
eliminates all Windows message overhead from the data path while keeping
the message loop alive for keyboard, paint, and scrollbar.

Removed from KPCOMM.PAS: NotifyWndProc, hidden notification window,
RegisterClass/CreateWindow, EnableCommNotification, SetCommEventMask,
DoCommEvent, Process*Notify methods, OnComm/CommEvent/RThreshold/
SThreshold properties, modem shadow state (CTS/DSR/CD).

Removed from KPANSI.PAS: WM_TIMER handler, SetTimer/KillTimer, replaced
with public TickBlink method using GetTickCount at 500ms intervals.

Removed from drv/isr.c: checkNotify function and its call from
isrDispatch.  Removed from drv/commdrv.c: pfnPostMessage, all
rxNotifySent/txNotifySent edge-trigger bookkeeping, gutted
enableNotification to a no-op API-compat stub.  Removed from
drv/commdrv.h: rxNotifySent/txNotifySent fields (shifts struct layout),
PostMessageProcT typedef, pfnPostMessage extern.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-01 19:01:40 -06:00

2383 lines
61 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 }
FParamStr: string; { Accumulated CSI parameter digits/semicolons }
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) }
{ 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 FlipToScreen;
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 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 TickBlink;
procedure Write(const S: string);
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 parameter string into integer array }
{ ----------------------------------------------------------------------- }
procedure ParseParams(const S: string; var Params: array of Integer;
var Count: Integer);
var
I: Integer;
Start: Integer;
Token: string;
begin
Count := 0;
if Length(S) = 0 then
Exit;
Start := 1;
for I := 1 to Length(S) do
begin
if S[I] = ';' then
begin
if Count <= High(Params) then
begin
Token := Copy(S, Start, I - Start);
if Length(Token) > 0 then
Params[Count] := StrToIntDef(Token, 0)
else
Params[Count] := 0;
Inc(Count);
end;
Start := I + 1;
end;
end;
{ Last token after final semicolon (or entire string if no semicolons) }
if Count <= High(Params) then
begin
Token := Copy(S, Start, Length(S) - Start + 1);
if Length(Token) > 0 then
Params[Count] := StrToIntDef(Token, 0)
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;
FParamStr := '';
FMusicStr := '';
FCellWidth := 8;
FCellHeight := 16;
FBlinkOn := True;
FLastBlinkTick := GetTickCount;
FScrollPos := 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;
{ Without ScrollDC, all rows must be re-rendered after a scroll }
{ because the on-screen pixels haven't moved to match FScreen. }
FAllDirty := True;
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
ParseParams(FParamStr, 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. }
var
DC: HDC;
Row: Integer;
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
FAllDirty := True;
{ Deferred scrollbar update (batched from DoScrollUp) }
if FScrollbarDirty then
begin
UpdateScrollbar;
FScrollbarDirty := False;
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;
{ 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);
{ Process incoming data with an inlined fast path for printable characters. }
{ ~80% of BBS data is printable text in normal state. Inlining avoids the }
{ per-character method call to ProcessChar, and caching the Line pointer }
{ eliminates repeated TList lookups for consecutive chars on the same row. }
{ }
{ Does NOT call FlipToScreen -- the caller (Write) calls FlipToScreen }
{ after ParseData returns, ensuring immediate rendering. }
var
I: Integer;
Ch: Char;
Line: PTermLine;
FGIdx: Byte;
BGIdx: Byte;
begin
Line := nil;
for I := 1 to Length(S) do
begin
Ch := S[I];
{ Fast path: printable character in normal state }
if (FParseState = psNormal) and (Ch >= ' ') then
begin
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];
if FAttrBold then
FGIdx := FAttrFG + 8
else
FGIdx := FAttrFG;
BGIdx := FAttrBG;
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;
FDirtyRow[FCursorRow] := True;
Inc(FCursorCol);
end
else
begin
{ Slow path: control chars, escape sequences }
Line := nil;
ProcessChar(Ch);
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;
{ Reset cursor blink to visible on new data }
FBlinkOn := True;
end;
procedure TKPAnsi.ParseSGR;
var
Params: array[0..15] of Integer;
Count: Integer;
I: Integer;
Code: Integer;
begin
ParseParams(FParamStr, 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
FParamStr := '';
FParseState := psCSI;
end;
else
begin
{ Unrecognized escape sequence, return to normal }
FParseState := psNormal;
end;
end;
end;
psCSI:
begin
case Ch of
'0'..'9', ';':
begin
FParamStr := FParamStr + Ch;
end;
'?':
begin
FParseState := psCSIQuestion;
end;
'M':
begin
{ Check if this is ANSI music: ESC[M starts music mode }
if Length(FParamStr) = 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', ';':
FParamStr := FParamStr + Ch;
'h': { Set Mode }
begin
if FParamStr = '7' then
FWrapMode := True
else if FParamStr = '25' then
FCursorVisible := True;
FParseState := psNormal;
end;
'l': { Reset Mode }
begin
if FParamStr = '7' then
FWrapMode := False
else if FParamStr = '25' 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;
FParamStr := '';
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;
FlipToScreen;
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;
{ ----------------------------------------------------------------------- }
{ Component registration }
{ ----------------------------------------------------------------------- }
procedure Register;
begin
RegisterComponents('KP', [TKPAnsi]);
end;
end.
Reference in a new issue View git blame Copy permalink