Skip to content

Instantly share code, notes, and snippets.

@pakLebah

pakLebah/ansiCRT.pas

Last active October 2, 2024 13:15
Show Gist options
  • Save pakLebah/c5e2bbd0b93c863b2122660111db68d1 to your computer and use it in GitHub Desktop.
Save pakLebah/c5e2bbd0b93c863b2122660111db68d1 to your computer and use it in GitHub Desktop.
Download ZIP
ANSI code unit and demo program using Free Pascal.
Raw
ansiCRT.pas
unit ansiCRT;
(******************************************************************************
This unit is emulating classic Pascal's CRT unit text color management and
cursor movement using ANSI Escape Code sequence. Keyboard input handling &
screen windowing is not possible. For keyboard input, better use the FPC's
Keyboard unit.
ANSI Escape Code list taken from:
https://en.wikipedia.org/wiki/ANSI_escape_code
Inspired by an article at:
http://www.lihaoyi.com/post/BuildyourownCommandLinewithANSIescapecodes.html
Some more info from:
- https://docs.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences
- https://misc.flogisoft.com/bash/tip_colors_and_formatting
Todo list:
• Non-blocking standard i/o reading to obtain return value of esc commands,
so the WhereXY and ScreenSize procedures would work correctly.
• Cursor styling and coloring (most consoles today ignores them though).
(c) v.0.2 by Mr Bee aka @pak_lebah – 2 December 2018
******************************************************************************)
{$MODE OBJFPC}{$H+}{$J-}
interface
const
// text styles
tsResetAll = 0;
tsBold = 1; // bright
tsDim = 2;
tsItalic = 3;
tsUnderline = 4;
tsBlink = 5;
tsOverline = 6;
tsInvert = 7;
tsHidden = 8;
tsStrike = 9;
tsDefault = 20;
tsNoBold = 21;
tsNoDim = 22;
tsNoItalic = 0; // 23; not working?
tsNoUnderline = 24;
tsNoBlink = 25;
tsNoOverline = 26;
tsNoInvert = 27;
tsNoHidden = 28;
tsNoStrike = 29;
// foreground colors
fcBlack = 30;
fcRed = 31;
fcGreen = 32;
fcBrown = 33;
fcBlue = 34;
fcMagenta = 35;
fcCyan = 36;
fcLightGray = 37;
fcRichColors = 38; // requires additional parameter(s)
fcDefault = 39;
fcDarkGray = 90;
fcLightRed = 91;
fcLightGreen = 92;
fcYellow = 93;
fcLightBlue = 94;
fcLightMagenta = 95;
fcLightCyan = 96;
fcWhite = 97;
// background colors
bcBlack = 40;
bcRed = 41;
bcGreen = 42;
bcBrown = 43;
bcBlue = 44;
bcMagenta = 45;
bcCyan = 46;
bcLightGray = 47;
bcRichColors = 48; // requires additional parameter(s)
bcDefault = 49;
bcDarkGray = 100;
bcLightRed = 101;
bcLightGreen = 102;
bcYellow = 103;
bcLightBlue = 104;
bcLightMagenta = 105;
bcLightCyan = 106;
bcWhite = 107;
// CRT unit's colors
Black = 30; // 0;
Blue = 34; // 1;
Green = 32; // 2;
Cyan = 36; // 3;
Red = 31; // 4;
Magenta = 35; // 5;
Brown = 33; // 6;
LightGray = 37; // 7;
DarkGray = 90; // 8;
LightBlue = 94; // 9;
LightGreen = 92; // 10;
LightCyan = 96; // 11;
LightRed = 91; // 12;
LightMagenta = 95; // 13;
Yellow = 93; // 14;
White = 97; // 15;
// ANSI table drawing chars
tdTopLeft = #27'(0l'#27'(B'; // ┌
tdTopCenter = #27'(0w'#27'(B'; // ┬
tdTopRight = #27'(0k'#27'(B'; // ┐
tdMidLeft = #27'(0t'#27'(B'; // ├
tdMidCenter = #27'(0n'#27'(B'; // ┼
tdMidRight = #27'(0u'#27'(B'; // ┤
tdBottomLeft = #27'(0m'#27'(B'; // └
tdBottomCenter = #27'(0v'#27'(B'; // ┴
tdBottomRight = #27'(0j'#27'(B'; // ┘
tdHorzLine = #27'(0q'#27'(B'; // ─
tdVertLine = #27'(0x'#27'(B'; // │
{$IFDEF WINDOWS}
function EnableANSIMode: boolean;
{$ENDIF}
// CRT's screen clearance
procedure ClrScr;
procedure ClrEol;
procedure ClrLine;
// CRT's cursor mode and positioning
procedure CursorOn;
procedure CursorOff;
procedure BlinkOn;
procedure BlinkOff;
procedure GotoXY(const X, Y: integer);
// function WhereX: integer;
// function WhereY: integer;
// function ScreenWidth: integer;
// function ScreenHeight: integer;
// ANSI's cursor positioning
procedure MoveUp(const Lines: word = 1);
procedure MoveDown(const Lines: word = 1);
procedure MoveRight(const Cols: word = 1);
procedure MoveLeft(const Cols: word = 1);
procedure MoveLineUp(const Lines: word = 1);
procedure MoveLineDown(const Lines: word = 1);
procedure GotoLine(const Line: word = 1);
procedure GotoColumn(const Col: word = 1);
// procedure WhereXY(var X,Y: integer);
// procedure ScreenSize(var X,Y: integer);
procedure StoreCursorPosition(const useAlt: boolean = {$IFDEF DARWIN}true{$ELSE}false{$ENDIF});
procedure RestoreCursorPosition(const useAlt: boolean = {$IFDEF DARWIN}true{$ELSE}false{$ENDIF});
// ANSI's text styling and coloring
procedure SetAttribute(const Attr: word; const Text: string = '');
procedure SetColor(const Color: word; const Text: string = '');
procedure SetStyle(const Style: word; const Text: string = '');
procedure SetColors(const ForeColor, BackColor: word; const Text: string = '');
procedure SetAttributes(const Attrs: array of word; const Text: string = '');
procedure Reset(const ColorOnly: boolean = false);
// ANSI's rich coloring (not all console support rich colors)
procedure SetForeColor256(const Color: word; const Text: string = '');
procedure SetBackColor256(const Color: word; const Text: string = '');
procedure SetForeColorRGB(const R,G,B: word; const Text: string = '');
procedure SetBackColorRGB(const R,G,B: word; const Text: string = '');
// CRT's text styling and coloring
procedure TextMode(const Style: word; const Text: string = '');
procedure TextColor(const Color: word; const Text: string = '');
procedure TextBackground(const Color: word; const Text: string = '');
function ansiText(const Text: string; const Color: word): string;
// helper functions
function int2Str(const int: integer): string;
function str2Int(const txt: string): integer;
implementation
{$IFDEF WINDOWS}
uses
Windows;
function EnableANSIMode: boolean;
begin
result := false;
// To Windows programmers, please complete this function... :)
// 1. handle := GetStdHandle(STD_OUTPUT_HANDLE);
// 2. GetConsoleMode(handle, mode);
// 3. mode := mode or ENABLE_VIRTUAL_TERMINAL_PROCESSING;
// 4. result := SetConsoleMode(handle, mode);
end;
{$ENDIF}
function int2Str(const int: integer): string;
begin
Str(int, result);
end;
function str2Int(const txt: string): integer;
var
i,c: integer;
begin
Val(txt,i,c);
if c <> 0 then result := -0 else result := i;
end;
function readStdIn(var txt: string): boolean;
begin
result := false;
// this should be replaced by non-blocking i/o reading
read(txt);
end;
procedure ClrScr;
begin
write(#27'[2J'#27'[H');
end;
procedure ClrEol;
begin
write(#27'[0K');
end;
procedure ClrLine;
begin
write(#27'[2K');
end;
procedure CursorOn;
begin
write(#27'[?25h');
end;
procedure CursorOff;
begin
write(#27'[?25l');
end;
procedure BlinkOn;
begin
write(#27'[?12h');
end;
procedure BlinkOff;
begin
write(#27'[?12l');
end;
procedure MoveUp(const Lines: word = 1);
begin
write(#27'[',lines,'A');
end;
procedure MoveDown(const Lines: word = 1);
begin
write(#27'[',lines,'B');
end;
procedure MoveRight(const Cols: word = 1);
begin
write(#27'[',cols,'C');
end;
procedure MoveLeft(const Cols: word = 1);
begin
write(#27'[',cols,'D');
end;
procedure MoveLineDown(const Lines: word = 1);
begin
write(#27'[',lines,'E');
end;
procedure MoveLineUp(const Lines: word = 1);
begin
write(#27'[',lines,'F');
end;
procedure GotoColumn(const Col: word = 1);
begin
write(#27'[',col,'G');
end;
procedure GotoXY(const X, Y: integer);
begin
write(#27'[',y,';',x,'H');
end;
procedure GotoLine(const Line: word = 1);
begin
write(#27'[',line,'d');
end;
procedure WhereXY(var X,Y: integer);
var
s: string = '';
p,l: integer;
begin
x := -1; y := -1; // –1 means 'unknown'
write(#27'[6n'); // returns: \e[line;columnR (note the last 'R')
readStdIn(s);
if s = '' then exit;
l := Length(s);
p := Pos(';',s);
if p <> 0 then
begin
y := str2Int(Copy(s,3,p-3));
x := str2Int(Copy(s,p+1,l-p-1));
end;
end;
procedure ScreenSize(var X,Y: integer);
var
s: string = '';
p,l: integer;
begin
x := -1; y := -1; // –1 means 'unknown'
write(#27'[18t'); // returns: \e[8;line;columnt (note the last 't')
readStdIn(s);
if s = '' then exit;
Delete(s,3,2); // remove the '8;' value prefix
l := Length(s);
p := Pos(';',s);
if p <> 0 then
begin
y := str2Int(Copy(s,3,p-3));
x := str2Int(Copy(s,p+1,l-p-1));
end;
end;
procedure StoreCursorPosition(const useAlt: boolean = {$IFDEF DARWIN}true{$ELSE}false{$ENDIF});
begin
if useAlt then write(#27'7')
else write(#27'[s');
end;
procedure RestoreCursorPosition(const useAlt: boolean = {$IFDEF DARWIN}true{$ELSE}false{$ENDIF});
begin
if useAlt then write(#27'8')
else write(#27'[u');
end;
procedure SetAttribute(const Attr: word; const Text: string = '');
begin
write(#27'[',attr,'m');
if text <> '' then
// undo the attribute after the text
case attr of
tsBold : write(text,#27'[',tsNoBold ,'m');
tsDim : write(text,#27'[',tsNoDim ,'m');
tsItalic : write(text,#27'[',tsNoItalic ,'m');
tsUnderline : write(text,#27'[',tsNoUnderline,'m');
tsBlink : write(text,#27'[',tsNoBlink ,'m');
tsOverline : write(text,#27'[',tsNoOverline ,'m');
tsInvert : write(text,#27'[',tsNoInvert ,'m');
tsHidden : write(text,#27'[',tsNoHidden ,'m');
tsStrike : write(text,#27'[',tsNoStrike ,'m');
30..37, 90.. 97: write(text,#27'[',fcDefault ,'m');
40..47,100..107: write(text,#27'[',bcDefault ,'m');
else write(text,#27'[',tsDefault ,'m');
end;
end;
procedure SetColor(const Color: word; const Text: string = '');
begin
SetAttribute(Color, Text);
end;
procedure SetStyle(const Style: word; const Text: string = '');
begin
SetAttribute(Style, Text);
end;
procedure SetColors(const ForeColor, BackColor: word; const Text: string = '');
begin
write(#27'[',foreColor,';',backColor,'m');
if text <> '' then write(text,#27'[',fcDefault,';',bcDefault,'m');
end;
procedure SetAttributes(const Attrs: array of word; const Text: string = '');
var
i,j: integer;
s: string;
begin
s := #27'[';
j := High(attrs);
for i := 0 to j-1 do s += int2Str(attrs[i])+';';
write(s,attrs[j],'m');
if text <> '' then write(text,#27'[',tsResetAll,'m');
end;
procedure Reset(const ColorOnly: boolean = false);
begin
if ColorOnly then
write(#27'[',fcDefault,';',bcDefault,'m')
else
write(#27'[0m');
end;
// ANSI's rich coloring
procedure SetForeColor256(const Color: word; const Text: string = '');
begin
write(#27'[',fcRichColors,';5;',color,'m');
if text <> '' then write(text,#27'[',fcDefault,'m');
end;
procedure SetBackColor256(const Color: word; const Text: string = '');
begin
write(#27'[',bcRichColors,';5;',color,'m');
if text <> '' then write(text,#27'[',bcDefault,'m');
end;
procedure SetForeColorRGB(const R,G,B: word; const Text: string = '');
begin
write(#27'[',fcRichColors,';2;',r,';',g,';',b,'m');
if text <> '' then write(text,#27'[',fcDefault,'m');
end;
procedure SetBackColorRGB(const R,G,B: word; const Text: string = '');
begin
write(#27'[',bcRichColors,';2;',r,';',g,';',b,'m');
if text <> '' then write(text,#27'[',bcDefault,'m');
end;
procedure TextMode(const Style: word; const Text: string = '');
begin
if style in [0..29] then SetAttribute(style, text);
end;
procedure TextColor(const Color: word; const Text: string = '');
begin
if color in [40..47, 100..107] then // bc to fc
SetAttribute(color-10, text)
else
SetAttribute(color, text);
end;
procedure TextBackground(const Color: word; const Text: string = '');
begin
if color in [30..37, 90..97] then // fc to bc
SetAttribute(color+10, text)
else
SetAttribute(color, text);
end;
function ansiText(const Text: string; const Color: word): string;
begin
result := #27'['+int2Str(Color)+'m';
case Color of
tsBold : result += text+#27'['+int2str(tsNoBold) +'m';
tsDim : result += text+#27'['+int2str(tsNoDim) +'m';
tsItalic : result += text+#27'['+int2str(tsNoItalic) +'m';
tsUnderline : result += text+#27'['+int2str(tsNoUnderline)+'m';
tsBlink : result += text+#27'['+int2str(tsNoBlink) +'m';
tsOverline : result += text+#27'['+int2str(tsNoOverline) +'m';
tsInvert : result += text+#27'['+int2str(tsNoInvert) +'m';
tsHidden : result += text+#27'['+int2str(tsNoHidden) +'m';
tsStrike : result += text+#27'['+int2str(tsNoStrike) +'m';
30..37, 90.. 97: result += text+#27'['+int2str(fcDefault) +'m';
40..47,100..107: result += text+#27'['+int2str(bcDefault) +'m';
else result += text+#27'['+int2str(tsDefault) +'m';
end;
end;
initialization
{$WARNING This unit would only work on console that supports ANSI code.}
end.
Raw
ansidemo.lpr
program ansiDemo;
uses
ansiCRT;
var
i: integer = 0;
s: string = '';
begin
ClrScr;
Randomize;
// combined attributes
SetAttributes([fcYellow, bcBlue]);
writeln(tdMidLeft,' ANSI CRT Demo ',tdMidRight);
writeln;
// foreground colors
SetAttributes([tsNoUnderline, fcDefault, bcDefault]);
TextColor(fcLightGray, 'Text colors: ');
for i in [fcBlack..fcLightGray] do TextColor(i,' '+int2Str(i)+' ');
for i in [fcDarkGray..fcWhite] do TextColor(i,' '+int2Str(i-60)+' ');
writeln;
// background colors
SetAttributes([fcDefault, bcDefault]);
TextColor(fcLightGray, 'Back colors: ');
for i in [bcBlack..bcLightGray] do TextBackground(i,' '+int2Str(i)+' ');
for i in [bcDarkGray..bcWhite] do TextBackground(i,' '+int2Str(i-60)+' ');
writeln;
// rich colors (256)
SetAttributes([fcDefault, bcDefault]);
TextColor(fcLightGray, ' 256 colors: ');
for i in [80..87] do SetForeColor256(i,' '+int2Str(i)+' ');
SetAttributes([fcDefault, bcDefault]);
for i in [90..97] do SetBackColor256(i,' '+int2Str(i)+' ');
writeln;
// rich colors (rgb) - works on vscode but doesn't work on terminal
SetAttributes([fcDefault, bcDefault]);
TextColor(fcLightGray, ' RGB colors: ');
for i in [0..7] do SetForeColorRGB(random(255-16-i)+16+i,
random(255-16-i)+16+i,
random(255-16-i)+16+i,
' '+int2Str(i+10)+' ');
SetAttributes([fcDefault, bcDefault]);
for i in [0..7] do SetBackColorRGB(random(255-16-i)+16+i,
random(255-16-i)+16+i,
random(255-16-i)+16+i,
' '+int2Str(i+10)+' ');
writeln;
// text styles
SetAttributes([fcDefault, bcDefault]);
TextColor(fcLightGray, 'Text styles: ');
for i in [tsBold..tsStrike] do TextMode(i,' '+int2Str(i)+' ');
writeln(LineEnding);
{ cursor positioning }
// A. without saving cursor position
// writeln('Type: ');
// B. with saving cursor position
write('Type: ');
StoreCursorPosition;
repeat
// A. without saving cursor position
// MoveLineUp;
// GotoColumn(7);
// ClrEol;
// TextColor(White);
// readln(s);
// GotoColumn(7);
// ClrEol;
// TextColor(Yellow);
// write(Length(s),' chars (type `q` to quit).');
// B. with saving cursor position
RestoreCursorPosition;
reset(true);
ClrEol;
readln(s);
GotoColumn(7);
ClrEol;
TextColor(Yellow);
write(Length(s),' chars (type `q` to quit).');
until s = 'q';
writeln;
Reset;
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment