diff --git a/delphi/KPANSI.PAS b/delphi/KPANSI.PAS index 13bebe9..903974e 100644 --- a/delphi/KPANSI.PAS +++ b/delphi/KPANSI.PAS @@ -61,37 +61,47 @@ type FOnKeyData: TKeyDataEvent; FPaintFont: HFont; FStockFont: Boolean; - FMemDC: HDC; - FMemBmp: HBitmap; - FMemOldBmp: HBitmap; + FBlinkPhase: Integer; + FUpdateCount: Integer; + FDirtyRow: array[0..255] of Boolean; + FAllDirty: Boolean; + FBufDC: array[0..1] of HDC; + FBufBmp: array[0..1] of HBitmap; + FBufOldBmp: array[0..1] of HBitmap; FBufW: Integer; FBufH: Integer; - FTextBlinkOn: Boolean; - FBlinkCount: Integer; procedure AllocLine(Line: PTermLine); + procedure ClearBufRect(X, Y, W, H: Integer; BG: TColor); procedure ClearLine(Line: PTermLine); procedure CMFontChanged(var Msg: TMessage); message cm_FontChanged; - procedure CreateBackBuffer; + procedure CreateBuffers; procedure CreatePaintFont; procedure DeleteChars(N: Integer); procedure DeleteLines(N: Integer); - procedure DestroyBackBuffer; + procedure DestroyBuffers; + procedure DirtyAll; + procedure DirtyRow(Row: Integer); procedure DoScrollDown; procedure DoScrollUp; + procedure DrawRow(Row: Integer); procedure EraseDisplay(Mode: Integer); procedure EraseLine(Mode: Integer); procedure ExecuteCSI(FinalCh: Char); procedure ExecuteMusic; + procedure FlipToScreen; procedure FreeLineList(List: TList); function GetCursorCol: Integer; function GetCursorRow: Integer; procedure InsertChars(N: Integer); procedure InsertLines(N: Integer); + procedure PaintLine(Line: PTermLine; PixelY: Integer); procedure ParseData(const S: string); procedure ParseSGR; procedure ProcessChar(Ch: Char); procedure RecalcCellSize; + procedure RedrawBuffers; procedure ResizeScreen; + procedure ScrollBufs(N: Integer); procedure SetCols(Value: Integer); procedure SetCursorVisible(Value: Boolean); procedure SetRows(Value: Integer); @@ -110,7 +120,9 @@ type public constructor Create(AOwner: TComponent); override; destructor Destroy; override; + procedure BeginUpdate; procedure Clear; + procedure EndUpdate; procedure Reset; procedure Write(const S: string); property CursorCol: Integer read GetCursorCol; @@ -227,6 +239,12 @@ begin end; +procedure TKPAnsi.BeginUpdate; +begin + Inc(FUpdateCount); +end; + + procedure TKPAnsi.Clear; var I: Integer; @@ -253,6 +271,7 @@ begin FCursorCol := 0; FScrollPos := 0; UpdateScrollbar; + FAllDirty := True; Invalidate; end; @@ -315,13 +334,15 @@ begin FWrapMode := True; FPaintFont := 0; FStockFont := False; - FMemDC := 0; - FMemBmp := 0; - FMemOldBmp := 0; + FBlinkPhase := 0; + FUpdateCount := 0; + FAllDirty := True; + FBufDC[0] := 0; + FBufDC[1] := 0; + FBufBmp[0] := 0; + FBufBmp[1] := 0; FBufW := 0; FBufH := 0; - FTextBlinkOn := True; - FBlinkCount := 0; { Set a monospace font -- OEM charset selected in CreatePaintFont } Font.Name := 'Terminal'; @@ -338,31 +359,6 @@ begin end; -procedure TKPAnsi.CreateBackBuffer; -var - ScreenDC: HDC; -begin - DestroyBackBuffer; - FBufW := FCols * FCellWidth; - FBufH := FRows * FCellHeight; - if (FBufW < 1) or (FBufH < 1) then - Exit; - - { Create a memory DC with compatible bitmap for double buffering. } - { We manage this DC directly with GDI calls -- no TCanvas/TBitmap } - { involvement -- so our OEM_CHARSET font stays selected and } - { cannot be overridden by VCL font realization. } - ScreenDC := GetDC(0); - FMemDC := CreateCompatibleDC(ScreenDC); - FMemBmp := CreateCompatibleBitmap(ScreenDC, FBufW, FBufH); - ReleaseDC(0, ScreenDC); - FMemOldBmp := SelectObject(FMemDC, FMemBmp); - if FPaintFont <> 0 then - SelectObject(FMemDC, FPaintFont); - SetBkMode(FMemDC, OPAQUE); -end; - - procedure TKPAnsi.CreatePaintFont; var LF: TLogFont; @@ -376,7 +372,9 @@ begin FStockFont := False; { Build LOGFONT requesting OEM_CHARSET with raster precision for CP437 } - { box-drawing, block elements, and other BBS ANSI art glyphs. } + { 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; @@ -394,21 +392,25 @@ begin { Verify Windows actually gave us an OEM charset font } GetObject(NewFont, SizeOf(ActualLF), @ActualLF); if ActualLF.lfCharSet = OEM_CHARSET then - begin - FPaintFont := NewFont; - if FMemDC <> 0 then - SelectObject(FMemDC, FPaintFont); - Exit; - end; - { Windows substituted a non-OEM font; discard it } - DeleteObject(NewFont); + FPaintFont := NewFont + else + DeleteObject(NewFont); end; - { Fall back to the stock OEM fixed font -- guaranteed CP437 } - FPaintFont := GetStockObject(OEM_FIXED_FONT); - FStockFont := True; - if FMemDC <> 0 then - SelectObject(FMemDC, FPaintFont); + if FPaintFont = 0 then + begin + FPaintFont := GetStockObject(OEM_FIXED_FONT); + FStockFont := True; + end; + + { Select font into both buffer DCs } + if FPaintFont <> 0 then + begin + if FBufDC[0] <> 0 then + SelectObject(FBufDC[0], FPaintFont); + if FBufDC[1] <> 0 then + SelectObject(FBufDC[1], FPaintFont); + end; end; @@ -416,6 +418,364 @@ procedure TKPAnsi.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); Params.Style := Params.Style or ws_VScroll; + { CS_OWNDC gives us a private DC whose state (selected font, BkMode, } + { colors) persists across GetDC/ReleaseDC calls. This eliminates the } + { per-frame cost of SelectObject + SetBkMode that otherwise dominates } + { rendering time on Win16. } + Params.WindowClass.Style := Params.WindowClass.Style or cs_OwnDC; +end; + + +procedure TKPAnsi.ClearBufRect(X, Y, W, H: Integer; BG: TColor); +var + R: TRect; + HBr: HBrush; + I: Integer; +begin + R.Left := X; + R.Top := Y; + R.Right := X + W; + R.Bottom := Y + H; + HBr := CreateSolidBrush(ColorToRGB(BG)); + for I := 0 to 1 do + begin + if FBufDC[I] <> 0 then + FillRect(FBufDC[I], R, HBr); + end; + DeleteObject(HBr); +end; + + +procedure TKPAnsi.CreateBuffers; +var + ScreenDC: HDC; + I: Integer; +begin + DestroyBuffers; + FBufW := FCols * FCellWidth; + FBufH := FRows * FCellHeight; + if (FBufW < 1) or (FBufH < 1) then + Exit; + ScreenDC := GetDC(0); + for I := 0 to 1 do + begin + FBufDC[I] := CreateCompatibleDC(ScreenDC); + FBufBmp[I] := CreateCompatibleBitmap(ScreenDC, FBufW, FBufH); + FBufOldBmp[I] := SelectObject(FBufDC[I], FBufBmp[I]); + if FPaintFont <> 0 then + SelectObject(FBufDC[I], FPaintFont); + SetBkMode(FBufDC[I], OPAQUE); + end; + ReleaseDC(0, ScreenDC); +end; + + +procedure TKPAnsi.DestroyBuffers; +var + I: Integer; +begin + for I := 0 to 1 do + begin + if FBufDC[I] <> 0 then + begin + SelectObject(FBufDC[I], FBufOldBmp[I]); + DeleteObject(FBufBmp[I]); + DeleteDC(FBufDC[I]); + FBufDC[I] := 0; + FBufBmp[I] := 0; + FBufOldBmp[I] := 0; + end; + end; +end; + + +procedure TKPAnsi.DirtyAll; +begin + FAllDirty := True; +end; + + +procedure TKPAnsi.DirtyRow(Row: Integer); +begin + if (Row >= 0) and (Row <= 255) then + FDirtyRow[Row] := True; +end; + + +procedure TKPAnsi.DrawRow(Row: Integer); +begin + if (Row >= 0) and (Row < FScreen.Count) then + PaintLine(FScreen[Row], Row * FCellHeight); +end; + + +procedure TKPAnsi.PaintLine(Line: PTermLine; PixelY: Integer); +{ Render a line to both buffer DCs using batched TextOut. } +{ Groups consecutive cells with identical colors into single calls } +{ (typically 5-10 per row instead of 80 per-cell calls). } +var + Col: Integer; + BatchStart: Integer; + BatchLen: Integer; + I: Integer; + X: Integer; + CellFG: TColor; + CellBG: TColor; + CurFG: TColor; + CurBG: TColor; + HasBlink: Boolean; + Buf: array[0..255] of Char; +begin + if FBufDC[0] = 0 then + Exit; + + { Check if any cell on this line blinks } + HasBlink := False; + for Col := 0 to FCols - 1 do + begin + if Line^.Cells[Col].Blink then + begin + HasBlink := True; + Break; + end; + end; + + if HasBlink then + begin + { Blink row: must render to each buffer separately } + for I := 0 to 1 do + begin + if FBufDC[I] = 0 then + Continue; + CurFG := TColor(-1); + CurBG := TColor(-1); + BatchStart := 0; + BatchLen := 0; + + for Col := 0 to FCols - 1 do + begin + CellBG := Line^.Cells[Col].BG; + if (I = 1) and Line^.Cells[Col].Blink then + CellFG := CellBG + else + CellFG := Line^.Cells[Col].FG; + + if (CellFG <> CurFG) or (CellBG <> CurBG) then + begin + if BatchLen > 0 then + begin + X := BatchStart * FCellWidth; + WinProcs.TextOut(FBufDC[I], X, PixelY, @Buf[0], BatchLen); + end; + if CellFG <> CurFG then + begin + SetTextColor(FBufDC[I], ColorToRGB(CellFG)); + CurFG := CellFG; + end; + if CellBG <> CurBG then + begin + SetBkColor(FBufDC[I], ColorToRGB(CellBG)); + CurBG := CellBG; + end; + BatchStart := Col; + BatchLen := 0; + end; + + Buf[BatchLen] := Line^.Cells[Col].Ch; + Inc(BatchLen); + end; + + if BatchLen > 0 then + begin + X := BatchStart * FCellWidth; + WinProcs.TextOut(FBufDC[I], X, PixelY, @Buf[0], BatchLen); + end; + end; + end + else + begin + { No blink: render to buffer 0 only, then copy row to buffer 1 } + CurFG := TColor(-1); + CurBG := TColor(-1); + BatchStart := 0; + BatchLen := 0; + + for Col := 0 to FCols - 1 do + begin + CellFG := Line^.Cells[Col].FG; + CellBG := Line^.Cells[Col].BG; + + if (CellFG <> CurFG) or (CellBG <> CurBG) then + begin + if BatchLen > 0 then + begin + X := BatchStart * FCellWidth; + WinProcs.TextOut(FBufDC[0], X, PixelY, @Buf[0], BatchLen); + end; + if CellFG <> CurFG then + begin + SetTextColor(FBufDC[0], ColorToRGB(CellFG)); + CurFG := CellFG; + end; + if CellBG <> CurBG then + begin + SetBkColor(FBufDC[0], ColorToRGB(CellBG)); + CurBG := CellBG; + end; + BatchStart := Col; + BatchLen := 0; + end; + + Buf[BatchLen] := Line^.Cells[Col].Ch; + Inc(BatchLen); + end; + + if BatchLen > 0 then + begin + X := BatchStart * FCellWidth; + WinProcs.TextOut(FBufDC[0], X, PixelY, @Buf[0], BatchLen); + end; + + { Copy rendered row from buffer 0 to buffer 1 } + if FBufDC[1] <> 0 then + BitBlt(FBufDC[1], 0, PixelY, FBufW, FCellHeight, + FBufDC[0], 0, PixelY, SRCCOPY); + end; +end; + + +procedure TKPAnsi.FlipToScreen; +var + DC: HDC; + Row: Integer; + MinDirty: Integer; + MaxDirty: Integer; + FullBlt: Boolean; + Line: PTermLine; + X: Integer; + Y: Integer; + SrcY: Integer; + H: Integer; +begin + if not HandleAllocated then + Exit; + if FBufDC[0] = 0 then + RecalcCellSize; + if FBufDC[0] = 0 then + Exit; + + FullBlt := FAllDirty; + + if FScrollPos <> 0 then + begin + { Scrollback view: full redraw from scrollback + screen data } + RedrawBuffers; + FullBlt := True; + end + else + begin + { Render only dirty rows into both buffers (batched TextOut) } + MinDirty := FRows; + MaxDirty := -1; + for Row := 0 to FRows - 1 do + begin + if FAllDirty or FDirtyRow[Row] then + begin + if Row < FScreen.Count then + PaintLine(FScreen[Row], Row * FCellHeight); + FDirtyRow[Row] := False; + if Row < MinDirty then + MinDirty := Row; + if Row > MaxDirty then + MaxDirty := Row; + end; + end; + FAllDirty := False; + end; + + DC := GetDC(Handle); + + if FullBlt then + begin + { Full screen BitBlt (scrollback, resize, blink all-dirty) } + BitBlt(DC, 0, 0, FBufW, FBufH, + FBufDC[FBlinkPhase], 0, 0, SRCCOPY); + end + else if MaxDirty >= 0 then + begin + { Partial BitBlt: only the dirty row band } + SrcY := MinDirty * FCellHeight; + H := (MaxDirty - MinDirty + 1) * FCellHeight; + BitBlt(DC, 0, SrcY, FBufW, H, + FBufDC[FBlinkPhase], 0, SrcY, SRCCOPY); + end; + + { Cursor overlay -- drawn directly to screen, not in buffers } + if FCursorVisible and FBlinkOn and (FScrollPos = 0) and + (FCursorRow >= 0) and (FCursorRow < FRows) and + (FCursorRow < FScreen.Count) and + (FCursorCol >= 0) and (FCursorCol < FCols) then + begin + Line := FScreen[FCursorRow]; + X := FCursorCol * FCellWidth; + Y := FCursorRow * FCellHeight; + SetTextColor(DC, ColorToRGB(Line^.Cells[FCursorCol].BG)); + SetBkColor(DC, ColorToRGB(Line^.Cells[FCursorCol].FG)); + WinProcs.TextOut(DC, X, Y, @Line^.Cells[FCursorCol].Ch, 1); + end; + + ReleaseDC(Handle, DC); +end; + + +procedure TKPAnsi.RedrawBuffers; +var + Row: Integer; + VisRow: Integer; + SbkCount: Integer; + Line: PTermLine; +begin + if FBufDC[0] = 0 then + Exit; + SbkCount := FScrollback.Count; + for Row := 0 to FRows - 1 do + begin + VisRow := Row - FScrollPos; + if VisRow < 0 then + begin + if (SbkCount + VisRow >= 0) and (SbkCount + VisRow < SbkCount) then + Line := FScrollback[SbkCount + VisRow] + else + Line := nil; + end + else if VisRow < FScreen.Count then + Line := FScreen[VisRow] + else + Line := nil; + + if Line = nil then + ClearBufRect(0, Row * FCellHeight, FBufW, FCellHeight, AnsiColors[0]) + else + PaintLine(Line, Row * FCellHeight); + end; +end; + + +procedure TKPAnsi.ScrollBufs(N: Integer); +var + R: TRect; + I: Integer; + ScrollY: Integer; +begin + if FBufDC[0] = 0 then + Exit; + ScrollY := N * FCellHeight; + R.Left := 0; + R.Top := 0; + R.Right := FBufW; + R.Bottom := FBufH; + for I := 0 to 1 do + ScrollDC(FBufDC[I], 0, -ScrollY, R, R, 0, nil); end; @@ -427,12 +787,8 @@ begin if N < 1 then N := 1; Line := FScreen[FCursorRow]; - { Shift cells left } for I := FCursorCol to FCols - 1 - N do - begin Line^.Cells[I] := Line^.Cells[I + N]; - end; - { Clear vacated cells at end } for I := FCols - N to FCols - 1 do begin if I >= 0 then @@ -444,12 +800,14 @@ begin 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 @@ -461,37 +819,24 @@ begin Line := FScreen[FCursorRow]; FreeMem(Line, SizeOf(TTermLineRec)); FScreen.Delete(FCursorRow); - { Add a blank line at the bottom } GetMem(Line, SizeOf(TTermLineRec)); AllocLine(Line); FScreen.Add(Line); end; end; -end; - - -procedure TKPAnsi.DestroyBackBuffer; -begin - if FMemDC <> 0 then - begin - SelectObject(FMemDC, FMemOldBmp); - DeleteObject(FMemBmp); - DeleteDC(FMemDC); - FMemDC := 0; - FMemBmp := 0; - FMemOldBmp := 0; - end; + for J := FCursorRow to FRows - 1 do + FDirtyRow[J] := True; end; destructor TKPAnsi.Destroy; begin - if FTimerActive then + if FTimerActive and HandleAllocated then begin KillTimer(Handle, 1); FTimerActive := False; end; - DestroyBackBuffer; + DestroyBuffers; if (FPaintFont <> 0) and not FStockFont then begin DeleteObject(FPaintFont); @@ -519,6 +864,8 @@ begin GetMem(Line, SizeOf(TTermLineRec)); AllocLine(Line); FScreen.Insert(0, Line); + ScrollBufs(-1); + FDirtyRow[0] := True; end; @@ -538,6 +885,19 @@ begin AllocLine(Line); FScreen.Add(Line); UpdateScrollbar; + ScrollBufs(1); + FDirtyRow[FRows - 1] := True; +end; + + +procedure TKPAnsi.EndUpdate; +begin + Dec(FUpdateCount); + if FUpdateCount <= 0 then + begin + FUpdateCount := 0; + FlipToScreen; + end; end; @@ -601,6 +961,17 @@ begin 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; @@ -634,10 +1005,9 @@ begin end; end; 2: { Erase entire line } - begin - ClearLine(Line); - end; + ClearLine(Line); end; + FDirtyRow[FCursorRow] := True; end; @@ -1008,12 +1378,8 @@ begin if N < 1 then N := 1; Line := FScreen[FCursorRow]; - { Shift cells right } for I := FCols - 1 downto FCursorCol + N do - begin Line^.Cells[I] := Line^.Cells[I - N]; - end; - { Clear inserted cells } for I := FCursorCol to FCursorCol + N - 1 do begin if I < FCols then @@ -1025,30 +1391,32 @@ begin 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 - { Remove bottom line } if FScreen.Count > 0 then begin Line := FScreen[FScreen.Count - 1]; FreeMem(Line, SizeOf(TTermLineRec)); FScreen.Delete(FScreen.Count - 1); end; - { Insert blank line at cursor row } GetMem(Line, SizeOf(TTermLineRec)); AllocLine(Line); FScreen.Insert(FCursorRow, Line); end; + for J := FCursorRow to FRows - 1 do + FDirtyRow[J] := True; end; @@ -1134,124 +1502,42 @@ end; procedure TKPAnsi.Paint; var - Row: Integer; - Col: Integer; - X: Integer; - Y: Integer; - Line: PTermLine; - StartCol: Integer; - BatchBuf: array[0..255] of Char; - BatchLen: Integer; - BatchFG: TColor; - BatchBG: TColor; - CellFG: TColor; - VisRow: Integer; - SbkOffset: Integer; - SbkCount: Integer; - R: TRect; - HBr: HBrush; + Row: Integer; + Line: PTermLine; + X: Integer; + Y: Integer; begin - { Ensure back buffer exists (created by RecalcCellSize) } - if FMemDC = 0 then + if FBufDC[0] = 0 then RecalcCellSize; - if FMemDC = 0 then + if FBufDC[0] = 0 then Exit; - { Pre-fill entire back buffer with black so no white pixels can } - { leak through gaps between rows or at the edges. } - R.Left := 0; - R.Top := 0; - R.Right := FBufW; - R.Bottom := FBufH; - HBr := CreateSolidBrush(ColorToRGB(AnsiColors[0])); - FillRect(FMemDC, R, HBr); - DeleteObject(HBr); - - SbkCount := FScrollback.Count; - + { Ensure all rows are rendered into buffers } for Row := 0 to FRows - 1 do begin - Y := Row * FCellHeight; - - { Determine which line to display based on scroll position } - VisRow := Row - FScrollPos; - if VisRow < 0 then - begin - { Drawing from scrollback } - SbkOffset := SbkCount + VisRow; - if (SbkOffset >= 0) and (SbkOffset < SbkCount) then - Line := FScrollback[SbkOffset] - else - Line := nil; - end - else - begin - { Drawing from active screen } - if VisRow < FScreen.Count then - Line := FScreen[VisRow] - else - Line := nil; - end; - - if Line = nil then - Continue; - - { Batch consecutive cells with same effective colors into a single } - { TextOut call for performance. Uses a fixed char array instead } - { of string concatenation to avoid heap allocation per cell. } - { When text blink is in the off phase, blinking cells render with } - { FG = BG so the text becomes invisible. } - Col := 0; - while Col < FCols do - begin - StartCol := Col; - BatchBG := Line^.Cells[Col].BG; - if Line^.Cells[Col].Blink and not FTextBlinkOn then - BatchFG := BatchBG - else - BatchFG := Line^.Cells[Col].FG; - BatchBuf[0] := Line^.Cells[Col].Ch; - BatchLen := 1; - Inc(Col); - - { Extend batch while effective colors match } - while Col < FCols do - begin - if Line^.Cells[Col].BG <> BatchBG then - Break; - if Line^.Cells[Col].Blink and not FTextBlinkOn then - CellFG := BatchBG - else - CellFG := Line^.Cells[Col].FG; - if CellFG <> BatchFG then - Break; - BatchBuf[BatchLen] := Line^.Cells[Col].Ch; - Inc(BatchLen); - Inc(Col); - end; - - X := StartCol * FCellWidth; - SetTextColor(FMemDC, ColorToRGB(BatchFG)); - SetBkColor(FMemDC, ColorToRGB(BatchBG)); - WinProcs.TextOut(FMemDC, X, Y, @BatchBuf[0], BatchLen); - end; - - { Draw cursor if on this row and visible } - if FCursorVisible and FBlinkOn and (FScrollPos = 0) and - (Row = FCursorRow) and (FCursorCol < FCols) then - begin - X := FCursorCol * FCellWidth; - { Invert the cursor cell } - SetTextColor(FMemDC, ColorToRGB(Line^.Cells[FCursorCol].BG)); - SetBkColor(FMemDC, ColorToRGB(Line^.Cells[FCursorCol].FG)); - WinProcs.TextOut(FMemDC, X, Y, - @Line^.Cells[FCursorCol].Ch, 1); - end; + if Row < FScreen.Count then + PaintLine(FScreen[Row], Row * FCellHeight); + FDirtyRow[Row] := False; end; + FAllDirty := False; - { Blit the completed frame to screen in one operation } + { BitBlt to canvas (provided by VCL WM_PAINT handler) } BitBlt(Canvas.Handle, 0, 0, FBufW, FBufH, - FMemDC, 0, 0, SRCCOPY); + FBufDC[FBlinkPhase], 0, 0, SRCCOPY); + + { Cursor overlay } + if FCursorVisible and FBlinkOn and (FScrollPos = 0) and + (FCursorRow >= 0) and (FCursorRow < FRows) and + (FCursorRow < FScreen.Count) and + (FCursorCol >= 0) and (FCursorCol < FCols) then + begin + Line := FScreen[FCursorRow]; + X := FCursorCol * FCellWidth; + Y := FCursorRow * FCellHeight; + SetTextColor(Canvas.Handle, ColorToRGB(Line^.Cells[FCursorCol].BG)); + SetBkColor(Canvas.Handle, ColorToRGB(Line^.Cells[FCursorCol].FG)); + WinProcs.TextOut(Canvas.Handle, X, Y, @Line^.Cells[FCursorCol].Ch, 1); + end; end; @@ -1260,27 +1546,21 @@ var I: Integer; begin for I := 1 to Length(S) do - begin ProcessChar(S[I]); - end; { Snap to bottom on new data } if FScrollPos <> 0 then begin FScrollPos := 0; UpdateScrollbar; + FAllDirty := True; end; { Reset cursor blink to visible on new data } FBlinkOn := True; - { Invalidate + Update forces an immediate synchronous repaint. } - { Without Update, WM_PAINT is low-priority and gets starved by } - { incoming WM_COMMNOTIFY messages, causing visible input lag. } - { The paint loop uses a fixed char array (no heap allocs) and our } - { own GDI memory DC, so repainting is fast enough for this. } - Invalidate; - Update; + if FUpdateCount = 0 then + FlipToScreen; end; @@ -1426,6 +1706,9 @@ begin Line^.Cells[FCursorCol].Bold := FAttrBold; Line^.Cells[FCursorCol].Blink := FAttrBlink; + { Mark row dirty for deferred batch rendering } + FDirtyRow[FCursorRow] := True; + Inc(FCursorCol); end; end; @@ -1536,10 +1819,6 @@ begin if not HandleAllocated then Exit; - { Destroy back buffer first so the old font is not selected in any } - { DC when CreatePaintFont deletes it. } - DestroyBackBuffer; - { Recreate the OEM charset paint font from current Font properties } CreatePaintFont; @@ -1565,8 +1844,9 @@ begin Width := FCols * FCellWidth + GetSystemMetrics(sm_CxVScroll); Height := FRows * FCellHeight; - { (Re)create the GDI back buffer at the new size } - CreateBackBuffer; + { (Re)create dual bitmaps; mark all rows dirty for next render } + CreateBuffers; + FAllDirty := True; { Start cursor blink timer } if not FTimerActive then @@ -1639,7 +1919,9 @@ begin if Value <> FCursorVisible then begin FCursorVisible := Value; - Invalidate; + { Mark cursor row dirty so BitBlt erases/redraws cursor overlay } + FDirtyRow[FCursorRow] := True; + FlipToScreen; end; end; @@ -1702,7 +1984,7 @@ end; procedure TKPAnsi.WMEraseBkgnd(var Msg: TWMEraseBkgnd); begin - { Suppress background erase -- double-buffered Paint covers everything } + { Suppress background erase -- TextOut with OPAQUE covers everything } Msg.Result := 1; end; @@ -1714,20 +1996,44 @@ end; procedure TKPAnsi.WMTimer(var Msg: TWMTimer); +var + DC: HDC; + Line: PTermLine; + X: Integer; + Y: Integer; begin FBlinkOn := not FBlinkOn; - { Text blink runs at half the cursor rate (every other tick) so } - { blinking text toggles roughly once per second. } - Inc(FBlinkCount); - if FBlinkCount >= 2 then + { Toggle text blink phase by swapping which buffer is displayed. } + { Buffers are already up-to-date; just BitBlt the other one. } + Inc(FBlinkPhase); + if FBlinkPhase > 1 then + FBlinkPhase := 0; + + if not HandleAllocated then + Exit; + if FBufDC[0] = 0 then + Exit; + + DC := GetDC(Handle); + BitBlt(DC, 0, 0, FBufW, FBufH, + FBufDC[FBlinkPhase], 0, 0, SRCCOPY); + + { Cursor overlay } + if FCursorVisible and FBlinkOn and (FScrollPos = 0) and + (FCursorRow >= 0) and (FCursorRow < FRows) and + (FCursorRow < FScreen.Count) and + (FCursorCol >= 0) and (FCursorCol < FCols) then begin - FBlinkCount := 0; - FTextBlinkOn := not FTextBlinkOn; + Line := FScreen[FCursorRow]; + X := FCursorCol * FCellWidth; + Y := FCursorRow * FCellHeight; + SetTextColor(DC, ColorToRGB(Line^.Cells[FCursorCol].BG)); + SetBkColor(DC, ColorToRGB(Line^.Cells[FCursorCol].FG)); + WinProcs.TextOut(DC, X, Y, @Line^.Cells[FCursorCol].Ch, 1); end; - { Always repaint: cursor blink and text blink both need it } - Invalidate; + ReleaseDC(Handle, DC); end; @@ -1767,7 +2073,7 @@ begin begin FScrollPos := NewPos; SetScrollPos(Handle, sb_Vert, SbkCount - FScrollPos, True); - Invalidate; + FlipToScreen; end; end; diff --git a/delphi/KPCOMM.PAS b/delphi/KPCOMM.PAS index 1d1b081..61c74de 100644 --- a/delphi/KPCOMM.PAS +++ b/delphi/KPCOMM.PAS @@ -351,7 +351,6 @@ end; function TKPComm.GetInput: string; var - Stat: TComStat; BytesToRead: Integer; BytesRead: Integer; Buf: array[0..255] of Char; @@ -360,15 +359,12 @@ begin if not FPortOpen or (FCommId < 0) then Exit; - GetCommError(FCommId, Stat); - BytesToRead := Stat.cbInQue; - + { Read directly without querying GetCommError first. ReadComm } + { returns the number of bytes actually available (up to BytesToRead) } + { so the extra GetCommError round-trip is unnecessary overhead. } + BytesToRead := 255; if (FInputLen > 0) and (BytesToRead > FInputLen) then BytesToRead := FInputLen; - if BytesToRead > 255 then - BytesToRead := 255; - if BytesToRead <= 0 then - Exit; BytesRead := ReadComm(FCommId, @Buf, BytesToRead); if BytesRead <= 0 then @@ -558,14 +554,12 @@ end; procedure TKPComm.ProcessReceiveNotify; -var - Stat: TComStat; begin if FRThreshold <= 0 then Exit; - GetCommError(FCommId, Stat); - if Integer(Stat.cbInQue) >= FRThreshold then - DoCommEvent(comEvReceive); + { WM_COMMNOTIFY with CN_RECEIVE means data is available -- the driver } + { already checked the threshold. No need to call GetCommError here. } + DoCommEvent(comEvReceive); end; diff --git a/delphi/TESTMAIN.PAS b/delphi/TESTMAIN.PAS index 0f60091..c28f335 100644 --- a/delphi/TESTMAIN.PAS +++ b/delphi/TESTMAIN.PAS @@ -85,9 +85,19 @@ begin case FComm.CommEvent of comEvReceive: begin - S := FComm.Input; - if Length(S) > 0 then - FAnsi.Write(S); + { Drain all available data in a single update batch. This } + { suppresses per-Write rendering so we get one paint at the } + { end instead of one per 255-byte chunk. } + FAnsi.BeginUpdate; + try + repeat + S := FComm.Input; + if Length(S) > 0 then + FAnsi.Write(S); + until Length(S) = 0; + finally + FAnsi.EndUpdate; + end; end; end; end; @@ -131,7 +141,7 @@ begin FEditSettings.Left := 148; FEditSettings.Top := 8; FEditSettings.Width := 140; - FEditSettings.Text := '9600,N,8,1'; + FEditSettings.Text := '115200,N,8,1'; FBtnOpen := TButton.Create(Self); FBtnOpen.Parent := Self; @@ -164,6 +174,15 @@ begin FAnsi.Left := 0; FAnsi.Top := 38; FAnsi.OnKeyData := AnsiKeyData; + + { Font diagnostic: write known CP437 box-drawing characters. } + { If the OEM font is working, you should see: } + { Line 1: single-line box top ┌───┐ } + { Line 2: shade + full block ░▒▓█ } + { Line 3: single-line box bottom └───┘ } + { If you see accented letters (Ú Ä ¿ ° ± ² Û À Ù), the font is } + { ANSI_CHARSET instead of OEM_CHARSET. } + FAnsi.Write(#$DA#$C4#$C4#$C4#$BF' '#$B0#$B1#$B2#$DB' '#$C0#$C4#$C4#$C4#$D9#13#10); end; diff --git a/drv/commdrv.c b/drv/commdrv.c index 29c156e..0608407 100644 --- a/drv/commdrv.c +++ b/drv/commdrv.c @@ -259,6 +259,13 @@ void applyBaudRate(PortStateT *port, uint16_t baud) base = port->baseAddr; divisor = (uint16_t)(BAUD_DIVISOR_BASE / actualBaud); + // Guard: divisor 0 means the UART treats it as 65536, giving ~1.76 baud. + // This can happen when BuildCommDCB stores a raw truncated value for + // 115200 (e.g. 0xE101 = 57601) and a future rate exceeds 115200. + if (divisor == 0) { + divisor = 1; + } + // Set DLAB to access divisor latch lcr = (uint8_t)_inp(base + UART_LCR); _outp(base + UART_LCR, lcr | LCR_DLAB); @@ -315,6 +322,11 @@ void applyLineParams(PortStateT *port, uint8_t byteSize, uint8_t parity, uint8_t break; } + dbgHex16("KPCOMM: applyLine byteSize", (uint16_t)byteSize); + dbgHex16("KPCOMM: applyLine parity", (uint16_t)parity); + dbgHex16("KPCOMM: applyLine stopBits", (uint16_t)stopBits); + dbgHex16("KPCOMM: applyLine LCR", (uint16_t)lcr); + _outp(base + UART_LCR, lcr); port->byteSize = byteSize; @@ -948,10 +960,12 @@ int16_t FAR PASCAL _export inicom(DCB FAR *dcb) _inp(port->baseAddr + UART_RBR); // Populate ComDEB for third-party compatibility - port->comDeb.port = port->baseAddr; + port->comDeb.port = port->baseAddr; port->comDeb.baudRate = port->baudRate; port->comDeb.qInSize = port->rxSize; port->comDeb.qOutSize = port->txSize; + port->comDeb.lcrShadow = (uint8_t)_inp(port->baseAddr + UART_LCR); + port->comDeb.mcrShadow = (uint8_t)_inp(port->baseAddr + UART_MCR); // Enable receive and line status interrupts _outp(port->baseAddr + UART_IER, IER_RDA | IER_LSI | IER_MSI); @@ -1101,7 +1115,9 @@ void primeTx(PortStateT *port) // reactivateOpenCommPorts - Reactivate all ports after task switch (ordinal 18) // // Called by Windows when switching back to this VM. -// Re-enables interrupts and restores MCR state. +// Restores full UART state: baud rate, line params (LCR), MCR, FIFOs, +// and re-enables interrupts. A DOS fullscreen app or VM switch may +// have reprogrammed the UART, so we must restore everything. // ----------------------------------------------------------------------- void FAR PASCAL _export reactivateOpenCommPorts(void) { @@ -1117,6 +1133,12 @@ void FAR PASCAL _export reactivateOpenCommPorts(void) continue; } + // Restore baud rate (sets DLAB, writes divisor, clears DLAB) + applyBaudRate(port, port->baudRate); + + // Restore line parameters (word length, parity, stop bits) + applyLineParams(port, port->byteSize, port->parity, port->stopBits); + // Restore MCR (DTR, RTS, OUT2) mcr = MCR_OUT2; if (port->dtrState) {