diff --git a/delphi/KPANSI.PAS b/delphi/KPANSI.PAS new file mode 100644 index 0000000..d6eae58 --- /dev/null +++ b/delphi/KPANSI.PAS @@ -0,0 +1,1582 @@ +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. } +{ } +{ 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: TColor; + BG: TColor; + Bold: Boolean; + Blink: Boolean; + end; + + PTermLine = ^TTermLineRec; + TTermLineRec = record + Cells: array[0..255] of TTermCell; + end; + + TKPAnsi = class(TCustomControl) + private + FScreen: TList; + FScrollback: TList; + FCursorRow: Integer; + FCursorCol: Integer; + FSaveCurRow: Integer; + FSaveCurCol: Integer; + FAttrFG: Integer; + FAttrBG: Integer; + FAttrBold: Boolean; + FAttrBlink: Boolean; + FAttrReverse: Boolean; + FParseState: TParseState; + FParamStr: string; + FMusicStr: string; + FCellWidth: Integer; + FCellHeight: Integer; + FBlinkOn: Boolean; + FTimerActive: Boolean; + FScrollPos: Integer; + FWrapMode: Boolean; + FCols: Integer; + FRows: Integer; + FScrollbackSize: Integer; + FCursorVisible: Boolean; + FOnKeyData: TKeyDataEvent; + procedure AllocLine(Line: PTermLine); + procedure ClearLine(Line: PTermLine); + procedure CMFontChanged(var Msg: TMessage); message cm_FontChanged; + procedure DeleteChars(N: Integer); + procedure DeleteLines(N: 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 InsertChars(N: Integer); + procedure InsertLines(N: Integer); + procedure ParseData(const S: string); + procedure ParseSGR; + procedure ProcessChar(Ch: Char); + procedure RecalcCellSize; + procedure ResizeScreen; + procedure SetCols(Value: Integer); + procedure SetCursorVisible(Value: Boolean); + procedure SetRows(Value: Integer); + procedure SetScrollbackSize(Value: Integer); + procedure TrimScrollback; + procedure UpdateScrollbar; + procedure WMGetDlgCode(var Msg: TMessage); message wm_GetDlgCode; + procedure WMTimer(var Msg: TWMTimer); message wm_Timer; + 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 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) } + ); + + CursorBlinkMs = 500; + + { 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 + ); + + +{ ----------------------------------------------------------------------- } +{ 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 := AnsiColors[7]; + Line^.Cells[I].BG := AnsiColors[0]; + Line^.Cells[I].Bold := False; + Line^.Cells[I].Blink := False; + end; +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; + 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 := AnsiColors[7]; + Line^.Cells[I].BG := AnsiColors[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; + FSaveCurRow := 0; + FSaveCurCol := 0; + FAttrFG := 7; + FAttrBG := 0; + FAttrBold := False; + FAttrBlink := False; + FAttrReverse := False; + FParseState := psNormal; + FParamStr := ''; + FMusicStr := ''; + FCellWidth := 8; + FCellHeight := 16; + FBlinkOn := True; + FTimerActive := False; + FScrollPos := 0; + FWrapMode := True; + + { Set a monospace font } + 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.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + Params.Style := Params.Style or ws_VScroll; +end; + + +procedure TKPAnsi.DeleteChars(N: Integer); +var + Line: PTermLine; + I: Integer; +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 + begin + Line^.Cells[I].Ch := ' '; + Line^.Cells[I].FG := AnsiColors[7]; + Line^.Cells[I].BG := AnsiColors[0]; + Line^.Cells[I].Bold := False; + Line^.Cells[I].Blink := False; + end; + end; +end; + + +procedure TKPAnsi.DeleteLines(N: Integer); +var + I: 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); + { Add a blank line at the bottom } + GetMem(Line, SizeOf(TTermLineRec)); + AllocLine(Line); + FScreen.Add(Line); + end; + end; +end; + + +destructor TKPAnsi.Destroy; +begin + if FTimerActive then + begin + KillTimer(Handle, 1); + FTimerActive := False; + end; + FreeLineList(FScreen); + FScreen.Free; + FreeLineList(FScrollback); + FScrollback.Free; + inherited Destroy; +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); +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; + { Add blank line at bottom } + GetMem(Line, SizeOf(TTermLineRec)); + AllocLine(Line); + FScreen.Add(Line); + UpdateScrollbar; +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 := AnsiColors[7]; + Line^.Cells[J].BG := AnsiColors[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 := AnsiColors[7]; + Line^.Cells[J].BG := AnsiColors[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; +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 := AnsiColors[7]; + Line^.Cells[J].BG := AnsiColors[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 := AnsiColors[7]; + Line^.Cells[J].BG := AnsiColors[0]; + Line^.Cells[J].Bold := False; + Line^.Cells[J].Blink := False; + end; + end; + 2: { Erase entire line } + begin + ClearLine(Line); + end; + end; +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; + '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.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.InsertChars(N: Integer); +var + Line: PTermLine; + I: Integer; +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 + begin + Line^.Cells[I].Ch := ' '; + Line^.Cells[I].FG := AnsiColors[7]; + Line^.Cells[I].BG := AnsiColors[0]; + Line^.Cells[I].Bold := False; + Line^.Cells[I].Blink := False; + end; + end; +end; + + +procedure TKPAnsi.InsertLines(N: Integer); +var + I: 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; +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; + Col: Integer; + X: Integer; + Y: Integer; + Line: PTermLine; + StartCol: Integer; + BatchStr: string; + BatchFG: TColor; + BatchBG: TColor; + VisRow: Integer; + SbkOffset: Integer; + SbkCount: Integer; +begin + Canvas.Font := Font; + + SbkCount := FScrollback.Count; + + 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 + begin + { Blank row } + Canvas.Brush.Color := AnsiColors[0]; + Canvas.FillRect(Rect(0, Y, FCols * FCellWidth, Y + FCellHeight)); + Continue; + end; + + { Batch consecutive cells with same attributes for performance } + Col := 0; + while Col < FCols do + begin + StartCol := Col; + BatchFG := Line^.Cells[Col].FG; + BatchBG := Line^.Cells[Col].BG; + if Line^.Cells[Col].Bold and (BatchFG = Line^.Cells[Col].FG) then + begin + { Bold maps low color to bright: if FG is in 0..7, use 8..15 } + end; + if Line^.Cells[Col].Blink then + begin + { Blink renders as bright background } + end; + BatchStr := Line^.Cells[Col].Ch; + Inc(Col); + + { Extend batch while attributes match } + while (Col < FCols) and + (Line^.Cells[Col].FG = BatchFG) and + (Line^.Cells[Col].BG = BatchBG) do + begin + BatchStr := BatchStr + Line^.Cells[Col].Ch; + Inc(Col); + end; + + X := StartCol * FCellWidth; + Canvas.Font.Color := BatchFG; + Canvas.Brush.Color := BatchBG; + Canvas.TextOut(X, Y, BatchStr); + 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 } + Canvas.Brush.Color := Line^.Cells[FCursorCol].FG; + Canvas.Font.Color := Line^.Cells[FCursorCol].BG; + Canvas.TextOut(X, Y, Line^.Cells[FCursorCol].Ch); + end; + end; +end; + + +procedure TKPAnsi.ParseData(const S: string); +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; + end; + + { Reset cursor blink to visible on new data } + FBlinkOn := True; + + Invalidate; +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; + #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 } + if FAttrBold then + FGIdx := FAttrFG + 8 + else + FGIdx := FAttrFG; + if FAttrBlink then + BGIdx := FAttrBG + 8 + else + BGIdx := FAttrBG; + + Line := FScreen[FCursorRow]; + if FAttrReverse then + begin + Line^.Cells[FCursorCol].FG := AnsiColors[BGIdx]; + Line^.Cells[FCursorCol].BG := AnsiColors[FGIdx]; + end + else + begin + Line^.Cells[FCursorCol].FG := AnsiColors[FGIdx]; + Line^.Cells[FCursorCol].BG := AnsiColors[BGIdx]; + end; + Line^.Cells[FCursorCol].Ch := Ch; + Line^.Cells[FCursorCol].Bold := FAttrBold; + Line^.Cells[FCursorCol].Blink := FAttrBlink; + + 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 + TM: TTextMetric; + DC: HDC; +begin + if not HandleAllocated then + Exit; + DC := GetDC(Handle); + try + Canvas.Font := Font; + SelectObject(DC, Font.Handle); + GetTextMetrics(DC, TM); + FCellWidth := TM.tmAveCharWidth; + FCellHeight := TM.tmHeight; + finally + ReleaseDC(Handle, DC); + end; + if FCellWidth < 1 then + FCellWidth := 8; + if FCellHeight < 1 then + FCellHeight := 16; + + { Resize control to fit terminal dimensions } + Width := FCols * FCellWidth + GetSystemMetrics(sm_CxVScroll); + Height := FRows * FCellHeight; + + { Start cursor blink timer } + if not FTimerActive then + begin + SetTimer(Handle, 1, CursorBlinkMs, nil); + FTimerActive := True; + end; + + Invalidate; +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; + Invalidate; + 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; +var + Line: PTermLine; +begin + while FScrollback.Count > FScrollbackSize do + begin + Line := FScrollback[0]; + FreeMem(Line, SizeOf(TTermLineRec)); + FScrollback.Delete(0); + end; +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.WMGetDlgCode(var Msg: TMessage); +begin + Msg.Result := dlgc_WantArrows or dlgc_WantTab or dlgc_WantChars; +end; + + +procedure TKPAnsi.WMTimer(var Msg: TWMTimer); +begin + FBlinkOn := not FBlinkOn; + if FCursorVisible then + Invalidate; +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); + Invalidate; + end; +end; + + +procedure TKPAnsi.Write(const S: string); +begin + if Length(S) > 0 then + ParseData(S); +end; + + +{ ----------------------------------------------------------------------- } +{ Component registration } +{ ----------------------------------------------------------------------- } + +procedure Register; +begin + RegisterComponents('KP', [TKPAnsi]); +end; + +end. diff --git a/delphi/KPTEST.DPR b/delphi/KPTEST.DPR index 6b7823a..f51c4f1 100644 --- a/delphi/KPTEST.DPR +++ b/delphi/KPTEST.DPR @@ -3,7 +3,8 @@ program KPTest; uses Forms, TestMain in 'TESTMAIN.PAS', - KPComm in 'KPCOMM.PAS'; + KPComm in 'KPCOMM.PAS', + KPAnsi in 'KPANSI.PAS'; begin Application.CreateForm(TMainForm, MainForm); diff --git a/delphi/README.md b/delphi/README.md new file mode 100644 index 0000000..70f58d2 --- /dev/null +++ b/delphi/README.md @@ -0,0 +1,210 @@ +# KP Serial Components for Delphi 1.0 + +Native Delphi 1.0 components for serial communications and ANSI BBS terminal +emulation under Windows 3.1. Both components install to the **KP** component +palette tab. + +## Components + +### TKPComm — Serial Communications (`KPCOMM.PAS`) + +Non-visual `TComponent` descendant providing RS-232 serial I/O via the +Windows 3.1 comm API (`OpenComm`, `BuildCommDCB`, `SetCommState`, +`EnableCommNotification`, etc.). + +**Published properties:** + +| Property | Type | Default | Description | +|---|---|---|---| +| CommPort | Integer | 1 | COM port number (1–16) | +| Settings | string | `9600,N,8,1` | Baud, parity, data bits, stop bits | +| PortOpen | Boolean | False | Open/close the port | +| InBufferSize | Integer | 4096 | Receive buffer size (bytes) | +| OutBufferSize | Integer | 4096 | Transmit buffer size (bytes) | +| RThreshold | Integer | 0 | Receive notification threshold (0 = disabled) | +| SThreshold | Integer | 0 | Send notification threshold (0 = disabled) | +| Handshaking | THandshaking | hsNone | Flow control (hsNone, hsXonXoff, hsRtsCts, hsBoth) | +| InputLen | Integer | 0 | Max bytes per Input read (0 = all available) | +| InputMode | TInputMode | imText | imText or imBinary | +| DTREnable | Boolean | True | Assert DTR on open | +| RTSEnable | Boolean | True | Assert RTS on open | +| NullDiscard | Boolean | False | Discard received null bytes | +| EOFEnable | Boolean | False | Treat Ctrl-Z as EOF | +| ParityReplace | string | `?` | Replacement char for parity errors | +| OnComm | TNotifyEvent | nil | Fired on comm events (receive, send, modem line changes, errors) | + +**Public runtime properties:** + +| Property | Type | Description | +|---|---|---| +| Input | string | Read received data from the buffer | +| Output | string | Write data to the transmit buffer | +| InBufferCount | Integer | Bytes waiting in receive buffer | +| OutBufferCount | Integer | Bytes waiting in transmit buffer | +| CTSHolding | Boolean | CTS line state (shadow, toggled on transitions) | +| DSRHolding | Boolean | DSR line state | +| CDHolding | Boolean | CD/RLSD line state | +| Break | Boolean | Set/clear break condition | +| CommEvent | Integer | Last event code (comEvReceive, comEvCTS, comEvtBreak, etc.) | + +**Usage:** + +```pascal +Comm := TKPComm.Create(Self); +Comm.CommPort := 1; +Comm.Settings := '9600,N,8,1'; +Comm.RThreshold := 1; +Comm.OnComm := CommEvent; +Comm.PortOpen := True; + +{ Send data } +Comm.Output := 'ATZ' + #13; + +{ In OnComm handler } +if Comm.CommEvent = comEvReceive then + Data := Comm.Input; +``` + +### TKPAnsi — ANSI BBS Terminal Emulator (`KPANSI.PAS`) + +Visual `TCustomControl` descendant providing a full ANSI terminal display with +scrollback, blinking cursor, 16-color palette, and ANSI music. + +**Published properties:** + +| Property | Type | Default | Description | +|---|---|---|---| +| Cols | Integer | 80 | Terminal width in columns (1–256) | +| Rows | Integer | 25 | Terminal height in rows (1–255) | +| ScrollbackSize | Integer | 500 | Maximum scrollback lines | +| CursorVisible | Boolean | True | Show/hide blinking block cursor | +| Font | TFont | Terminal 9pt | Monospace font for rendering | +| Color | TColor | clBlack | Default background color | +| TabStop | Boolean | True | Accept keyboard focus | +| OnKeyData | TKeyDataEvent | nil | Fired when user presses a key | + +**Public methods and properties:** + +| Member | Kind | Description | +|---|---|---| +| Write(const S: string) | method | Feed data to the terminal for parsing and display | +| Clear | method | Move screen to scrollback, blank the display, home cursor | +| Reset | method | Reset all attributes, clear screen, home cursor | +| CursorRow | Integer | Current cursor row (0-based, read-only) | +| CursorCol | Integer | Current cursor column (0-based, read-only) | + +**Supported ANSI escape sequences:** + +CSI (ESC\[) sequences: + +| Sequence | Name | Action | +|---|---|---| +| ESC\[*n*A | CUU | Cursor up *n* rows | +| ESC\[*n*B | CUD | Cursor down *n* rows | +| ESC\[*n*C | CUF | Cursor forward *n* columns | +| ESC\[*n*D | CUB | Cursor back *n* columns | +| ESC\[*r*;*c*H | CUP | Cursor position (1-based row;col) | +| ESC\[*r*;*c*f | HVP | Same as CUP | +| ESC\[*n*J | ED | Erase display (0=below, 1=above, 2=all) | +| ESC\[*n*K | EL | Erase line (0=right, 1=left, 2=all) | +| ESC\[*n*S | SU | Scroll up *n* lines | +| ESC\[*n*T | SD | Scroll down *n* lines | +| ESC\[*n*L | IL | Insert *n* blank lines at cursor | +| ESC\[*n*M | DL | Delete *n* lines at cursor | +| ESC\[*n*@ | ICH | Insert *n* blank characters at cursor | +| ESC\[*n*P | DCH | Delete *n* characters at cursor | +| ESC\[*params*m | SGR | Set graphic rendition (see below) | +| ESC\[s | SCP | Save cursor position | +| ESC\[u | RCP | Restore cursor position | + +SGR codes: + +| Code | Effect | +|---|---| +| 0 | Reset all attributes | +| 1 | Bold (bright foreground) | +| 5 | Blink (rendered as bright background) | +| 7 | Reverse video | +| 22 | Cancel bold | +| 25 | Cancel blink | +| 27 | Cancel reverse | +| 30–37 | Foreground color (ANSI 0–7) | +| 40–47 | Background color (ANSI 0–7) | + +DEC private modes: + +| Sequence | Effect | +|---|---| +| ESC\[?7h | Enable line wrap (default) | +| ESC\[?7l | Disable line wrap | +| ESC\[?25h | Show cursor | +| ESC\[?25l | Hide cursor | + +Control characters: + +| Char | Effect | +|---|---| +| CR (#13) | Carriage return | +| LF (#10) | Line feed (scrolls at bottom) | +| BS (#8) | Backspace (no erase) | +| TAB (#9) | Tab to next 8-column stop | +| BEL (#7) | System beep | + +**ANSI Music:** + +Detected by `ESC[M` followed by a music string terminated by Ctrl-N (#14). +Syntax: `T L O ` where notes are A–G with +optional sharp (`#`/`+`) or flat (`-`), duration (1/2/4/8/16), and dot (`.`) +for dotted notes. `P` inserts a rest. `>` and `<` shift octave. Played +asynchronously via the Windows 3.1 Sound API. + +**Keyboard mapping (via OnKeyData):** + +| Key | Output | +|---|---| +| Printable chars | The character itself | +| Enter | CR (#13) | +| Backspace | BS (#8) | +| Tab | TAB (#9) | +| Escape | ESC (#27) | +| Arrow Up/Down/Right/Left | ESC\[A / ESC\[B / ESC\[C / ESC\[D | +| Home / End | ESC\[H / ESC\[K | +| Page Up / Page Down | ESC\[V / ESC\[U | +| Insert / Delete | ESC\[@ / ESC DEL | +| F1–F4 | ESC OP / OQ / OR / OS | +| F5–F10 | ESC Ot / Ou / Ov / Ow / Ox / Oy | + +## Test Application + +`KPTEST.DPR` / `TESTMAIN.PAS` — a minimal terminal application that wires the +two components together. The form is created entirely in code (no DFM). + +**Layout:** A toolbar row at the top with port number, settings, Open/Close +buttons, and a status label. The TKPAnsi terminal fills the rest of the form. + +**Wiring:** + +- `TKPComm.OnComm` handler reads `Input` and passes it to `TKPAnsi.Write` +- `TKPAnsi.OnKeyData` handler sends keystrokes to `TKPComm.Output` + +## Building + +Requires Delphi 1.0. + +1. Open `KPTEST.DPR` in the Delphi IDE +2. Compile and run (F9) + +To install the components for design-time use: + +1. Component > Install Component +2. Add `KPCOMM.PAS` and `KPANSI.PAS` +3. Both appear on the **KP** palette tab + +## Files + +| File | Description | +|---|---| +| `KPCOMM.PAS` | TKPComm serial communications component | +| `KPANSI.PAS` | TKPAnsi ANSI terminal emulator component | +| `KPTEST.DPR` | Test application project file | +| `TESTMAIN.PAS` | Test application main form unit | diff --git a/delphi/TESTMAIN.PAS b/delphi/TESTMAIN.PAS index 018976f..0f60091 100644 --- a/delphi/TESTMAIN.PAS +++ b/delphi/TESTMAIN.PAS @@ -1,18 +1,24 @@ unit TestMain; -{ Test application for the TKPComm serial communications component. } -{ Form and all controls are created in code (no DFM required). } +{ Test application for TKPComm and TKPAnsi components. } +{ Form and all controls are created in code (no DFM required). } +{ } +{ Layout: toolbar row at top (port, settings, open/close, status), } +{ TKPAnsi terminal filling the rest of the form. Received serial data } +{ is fed to the terminal via TKPAnsi.Write; keystrokes from the terminal } +{ are sent out via TKPComm.Output. } interface uses SysUtils, Classes, WinTypes, WinProcs, Messages, - Forms, Controls, StdCtrls, KPComm; + Forms, Controls, StdCtrls, KPComm, KPAnsi; type TMainForm = class(TForm) private FComm: TKPComm; + FAnsi: TKPAnsi; FLabelPort: TLabel; FEditPort: TEdit; FLabelSettings: TLabel; @@ -20,14 +26,9 @@ type FBtnOpen: TButton; FBtnClose: TButton; FLabelStatus: TLabel; - FLabelRecv: TLabel; - FMemoRecv: TMemo; - FEditSend: TEdit; - FBtnSend: TButton; - FLabelInfo: TLabel; + procedure AnsiKeyData(Sender: TObject; const Data: string); procedure BtnCloseClick(Sender: TObject); procedure BtnOpenClick(Sender: TObject); - procedure BtnSendClick(Sender: TObject); procedure CommEvent(Sender: TObject); procedure UpdateStatus; public @@ -40,10 +41,23 @@ var implementation +procedure TMainForm.AnsiKeyData(Sender: TObject; const Data: string); +begin + if FComm.PortOpen and (Length(Data) > 0) then + begin + try + FComm.Output := Data; + except + on E: Exception do + { Ignore send errors from keyboard input } + end; + end; +end; + + procedure TMainForm.BtnCloseClick(Sender: TObject); begin FComm.PortOpen := False; - FMemoRecv.Lines.Add('--- Port closed ---'); UpdateStatus; end; @@ -55,29 +69,12 @@ begin FComm.Settings := FEditSettings.Text; FComm.RThreshold := 1; FComm.PortOpen := True; - FMemoRecv.Lines.Add('--- Port opened on COM' + - FEditPort.Text + ' at ' + FEditSettings.Text + ' ---'); except on E: Exception do - FMemoRecv.Lines.Add('Open failed: ' + E.Message); - end; - UpdateStatus; -end; - - -procedure TMainForm.BtnSendClick(Sender: TObject); -begin - if Length(FEditSend.Text) = 0 then - Exit; - try - FComm.Output := FEditSend.Text + #13; - FMemoRecv.Lines.Add('TX: ' + FEditSend.Text); - FEditSend.Text := ''; - except - on E: Exception do - FMemoRecv.Lines.Add('Send failed: ' + E.Message); + FAnsi.Write('Open failed: ' + E.Message + #13#10); end; UpdateStatus; + FAnsi.SetFocus; end; @@ -90,32 +87,9 @@ begin begin S := FComm.Input; if Length(S) > 0 then - FMemoRecv.Lines.Add('RX: ' + S); + FAnsi.Write(S); end; - comEvCTS: - FMemoRecv.Lines.Add('CTS changed'); - comEvDSR: - FMemoRecv.Lines.Add('DSR changed'); - comEvCD: - FMemoRecv.Lines.Add('CD changed'); - comEvRing: - FMemoRecv.Lines.Add('Ring'); - comEvEOF: - FMemoRecv.Lines.Add('EOF received'); - comEvtBreak: - FMemoRecv.Lines.Add('Break received'); - comEvtFrame: - FMemoRecv.Lines.Add('Framing error'); - comEvtOverrun: - FMemoRecv.Lines.Add('Overrun error'); - comEvtRxOver: - FMemoRecv.Lines.Add('RX buffer overflow'); - comEvtParity: - FMemoRecv.Lines.Add('Parity error'); - comEvtTxFull: - FMemoRecv.Lines.Add('TX buffer full'); end; - UpdateStatus; end; @@ -123,9 +97,9 @@ constructor TMainForm.Create(AOwner: TComponent); begin inherited CreateNew(AOwner); - Caption := 'KPComm Test'; - Width := 500; - Height := 380; + Caption := 'KPComm ANSI Terminal'; + Width := 660; + Height := 460; BorderStyle := bsSingle; { Serial component } @@ -159,11 +133,10 @@ begin FEditSettings.Width := 140; FEditSettings.Text := '9600,N,8,1'; - { Row 2: Open/Close buttons and status } FBtnOpen := TButton.Create(Self); FBtnOpen.Parent := Self; - FBtnOpen.Left := 8; - FBtnOpen.Top := 38; + FBtnOpen.Left := 300; + FBtnOpen.Top := 8; FBtnOpen.Width := 65; FBtnOpen.Height := 25; FBtnOpen.Caption := 'Open'; @@ -171,8 +144,8 @@ begin FBtnClose := TButton.Create(Self); FBtnClose.Parent := Self; - FBtnClose.Left := 80; - FBtnClose.Top := 38; + FBtnClose.Left := 372; + FBtnClose.Top := 8; FBtnClose.Width := 65; FBtnClose.Height := 25; FBtnClose.Caption := 'Close'; @@ -181,56 +154,20 @@ begin FLabelStatus := TLabel.Create(Self); FLabelStatus.Parent := Self; - FLabelStatus.Left := 160; - FLabelStatus.Top := 44; + FLabelStatus.Left := 450; + FLabelStatus.Top := 12; FLabelStatus.Caption := 'Closed'; - { Receive area } - FLabelRecv := TLabel.Create(Self); - FLabelRecv.Parent := Self; - FLabelRecv.Left := 8; - FLabelRecv.Top := 70; - FLabelRecv.Caption := 'Received:'; - - FMemoRecv := TMemo.Create(Self); - FMemoRecv.Parent := Self; - FMemoRecv.Left := 8; - FMemoRecv.Top := 86; - FMemoRecv.Width := 476; - FMemoRecv.Height := 186; - FMemoRecv.ScrollBars := ssVertical; - FMemoRecv.ReadOnly := True; - - { Send row } - FEditSend := TEdit.Create(Self); - FEditSend.Parent := Self; - FEditSend.Left := 8; - FEditSend.Top := 280; - FEditSend.Width := 400; - - FBtnSend := TButton.Create(Self); - FBtnSend.Parent := Self; - FBtnSend.Left := 416; - FBtnSend.Top := 280; - FBtnSend.Width := 65; - FBtnSend.Height := 25; - FBtnSend.Caption := 'Send'; - FBtnSend.Enabled := False; - FBtnSend.OnClick := BtnSendClick; - - { Status info line } - FLabelInfo := TLabel.Create(Self); - FLabelInfo.Parent := Self; - FLabelInfo.Left := 8; - FLabelInfo.Top := 316; - FLabelInfo.Width := 476; - FLabelInfo.Caption := 'RX: 0 TX: 0 Event: 0'; + { ANSI terminal } + FAnsi := TKPAnsi.Create(Self); + FAnsi.Parent := Self; + FAnsi.Left := 0; + FAnsi.Top := 38; + FAnsi.OnKeyData := AnsiKeyData; end; procedure TMainForm.UpdateStatus; -var - S: string; begin if FComm.PortOpen then FLabelStatus.Caption := 'Open' @@ -239,28 +176,6 @@ begin FBtnOpen.Enabled := not FComm.PortOpen; FBtnClose.Enabled := FComm.PortOpen; - FBtnSend.Enabled := FComm.PortOpen; - FEditSend.Enabled := FComm.PortOpen; - - S := 'RX: ' + IntToStr(FComm.InBufferCount) + - ' TX: ' + IntToStr(FComm.OutBufferCount); - if FComm.PortOpen then - begin - if FComm.CTSHolding then - S := S + ' CTS: On' - else - S := S + ' CTS: Off'; - if FComm.DSRHolding then - S := S + ' DSR: On' - else - S := S + ' DSR: Off'; - if FComm.CDHolding then - S := S + ' CD: On' - else - S := S + ' CD: Off'; - end; - S := S + ' Event: ' + IntToStr(FComm.CommEvent); - FLabelInfo.Caption := S; end;