_ _ _ ____ _ _
/ \ _ __ ___ | |_| |__ ___ _ __ | _ \ _ __ ___ (_) __| |
/ _ \ | '_ \ / _ \| __| '_ \ / _ \ '__| | | | | '__/ _ \| |/ _\` |
/ ___ \| | | | (_) | |_| | | | __/ | | |_| | | | (_) | | (_| |
/_/ \_\_| |_|\___/ \__|_| |_|\___|_| |____/|_| \___/|_|\__,_|
bbs
XQTRs lair...
Home //
Blog //
NULL emag. //
Files //
Docs //
Tutors //
GitHub repo
__ _ __ _ _ __
______\ \_\\_______________________\///__________________________//_/ /______
\___\ /___/
| .__ __ |
| | ___ __________/ |________ |
| \ \/ / ____/\ __\_ __ \ |
; > < <_| | | | | | \/ ;
: /__/\_ \__ | |__| |__| :
. \/ |__| .
. .
: H/Q Another Droid BBS - andr01d.zapto.org:9999 :
; ;
+ --- -- - . - --- --- --- - . - -- --- +
: :
| FreePascal ANSI Viewer |
: :
` --- -- - . - --- --- --- - . - -- --- '
One of the "musts" back then, was for a program to display ansi files,
graphics. From then, many of us have forgotten how to do so and
others, because they use external tools, they think its easy. So lets
take a dive into programming and check the logic/algorithm on how to
manipulate ansi files.
ANSI codes start with an ESCape char (d27) and end with a letter. So
in our code we have to check if we found an Escape char and read until
we find a valid ansi code letter/code. You can find many ansi codes in
this link: https://conemu.github.io/en/AnsiEscapeCodes.html
We will use this document to "translate" ansi codes.
So we begin by opening the file and reading it byte to byte. If we
encounter an escape char then we fill a string buffer, until we reach
a valid ansi code. If we don't find an escape, then we just display
the character.
while (not eof(f)) and (done=false) do begin
blockread(f,b,1); // read file one byte at a time
case b of
#27: doesc; // found ESC? process code
#13: delay(d); // Found end of line? add some delay to make the
// ansi more easy to view
else
write(b); // plain char? then show it on screen
lastch:=b; // save the last char we display (for ansi code)
end;
end;
All the work is done in the DOESC procedure. In here we will process
any ansi code and accordingly will show a character, move the cursor
etc. So lets see how this works.
procedure doesc;
var
buf:string[255];
j:byte;
begin
buf:='';
blockread(f,b,1); // read the file and fill our
while length(buf)<255 do begin // buffer until we reach a
blockread(f,b,1); // valid ansi code
buf:=buf+b;
if b in
// All these are valid ansi codes
['m','J','H','f','A','B','C','D','u','s','K','@','F','E','G','X','b','d']
then break;
end;
if length(buf)<1 then exit;
cnt:=strwordcount(buf,';'); // Some ANSI codes have parameters
c:=buf[length(buf)]; // We count how many we have,
delete(buf,length(buf),1); // store the code in C and clean
case c of // the buffer from any code.
'd': gotoline(buf);
'b': repeatlastchar(buf); // Read the link above to see what
'X': erasechars(buf); // commands do. The most important
'm': ansicoloring(buf); // is "m" which alters the colors
'K': clearline(buf);
'A': cursorup(buf);
'B': cursordown(buf);
'C': cursorright(buf);
'D': cursorleft(buf);
'E': linesdown(buf);
'F': linesup(buf);
'G': gotocol(buf);
'f','H': cursormove(buf);
's': begin
savex:=wherex;
savey:=wherey;
end;
'u' : gotoxy(savex,savey);
'@' : insertspaces(buf);
'J' : begin
if str2int(strwordget(1,buf,';')) = 2 then ClrScr;
End;
end;
end;
We use a CASE statement to check what command we have to parse and
execute its code. The parameters for some codes are in a format like:
1;30;44. To get each parameter i use the StrWordGet command which is
not the perfect way to do, but its more easy to understand. This
command will give as string between the semicolon ; that we ask for.
For example if we give strwordget(2,buffer,';') it will give us the
string 30, from the example above, which is a color code. This way we
have an easy way to get the parameters.
From now on, its just "translating" what the ANSI command does, into
code. If for example we encounter a command that moves the cursor x
lines below, we parse this code and move the cursor with the GOTOXY
command.
The most "bizarre" command is "m" which changes the color to be
displayed and has many parameters and features. I am not going to
explain it here, cause it needs a whole article by its self.
Grab the program below, compile it with FreePascal and you have an
easy ANSI viewer for your system. Don't forget to change the terminal
encoding to CP437 or a similar... it will not show correct in UTF8
terminals... which is also a subject for another article... enjoy!
+ --- -- - . - --- --- --- - . - -- --- '
COMPLETE PROGRAM - COPY/PASTE and COMPILE with FREEPASCAL
+ --- -- - . - --- --- --- - . - -- --- '
program dispansi;
{$mode objfpc}{$H-}
uses crt,dos;
Function Str2Int (Str: String): LongInt;
Var
N : LongInt;
T : LongInt;
Begin
Val(Str, T, N);
Str2Int := T;
End;
Function Int2Str (N: LongInt): String;
Var
T : String;
Begin
Str(N, T);
Int2Str := T;
End;
Function strWordCount (Str: String; Ch: Char) : Byte;
Var
Start : Byte;
Res : Byte;
Begin
Res := 0;
If Ch = ' ' Then
While Str[1] = Ch Do
Delete (Str, 1, 1);
If Str = '' Then Exit;
Res := 1;
While Pos(Ch, Str) > 0 Do Begin
Inc (Res);
Start := Pos(Ch, Str);
If Ch = ' ' Then Begin
While Str[Start] = Ch Do
Delete (Str, Start, 1);
End Else
Delete (Str, Start, 1);
End;
strWordCount := Res;
End;
Function strWordGet (Num: Byte; Str: String; Ch: Char) : String;
Var
Count : Byte;
Temp : String;
Start : Byte;
Begin
strWordGet := '';
Count := 1;
Temp := Str;
If Pos(Ch,Str)<=0 Then Begin
strWordGet:=str;
Exit;
End;
If Ch = ' ' Then
While Temp[1] = Ch Do
Delete (Temp, 1, 1);
While Count < Num Do Begin
Start := Pos(Ch, Temp);
If Start = 0 Then Exit;
If Ch = ' ' Then Begin
While Temp[Start] = Ch Do
Inc (Start);
Dec(Start);
End;
Delete (Temp, 1, Start);
Inc (Count);
End;
If Pos(Ch, Temp) > 0 Then
strWordGet := Copy(Temp, 1, Pos(Ch, Temp) - 1)
Else
strWordGet := Temp;
End;
procedure dansi(fn:string;d:integer);
const
AnsiColors: Array[0..7] of Integer = (0, 4, 2, 6, 1, 5, 3, 7);
var
done:boolean;
key:char;
f:file;
b:char;
c:char;
cnt:byte;
savex:byte;
savey:byte;
lastch:char;
procedure ansicoloring(s:string);
var
i:byte;
cl:byte;
w:byte;
Colour:byte;
begin
for i:= 1 to cnt do begin
w:=str2int(strwordget(i,s,';'));
case w of
0: TextAttr:=7;
1: begin
cl:=textattr mod 16;
if cl < 8 then cl:=cl+8;
textcolor(cl);
end;
7: TextAttr:= ((TextAttr and $70) shr 4) + ((TextAttr and $07)
shl 4);
8: TextAttr:= 0; { Video Off }
30..37: Begin
Colour := AnsiColors[w - 30];
if (TextAttr mod 16 > 7) then
Inc(Colour, 8);
TextColor(Colour);
End;
40..47: TextBackground(AnsiColors[w - 40]);
End;
end;
end;
procedure linesdown(s:string);
var
y:byte;
begin
try
y:=str2int(s);
except
y:=1;
end;
gotoxy(1,wherey+y);
end;
procedure linesup(s:string);
var
y:byte;
begin
try
y:=str2int(s);
except
y:=1;
end;
gotoxy(1,wherey-y);
end;
procedure cursorup(s:string);
var
y:byte;
begin
try
y:=str2int(s);
except
y:=1;
end;
gotoxy(wherex,wherey-y);
end;
procedure cursordown(s:string);
var
y:byte;
begin
try
y:=str2int(s);
except
y:=1;
end;
gotoxy(wherex,wherey+y);
end;
procedure cursorleft(s:string);
var
x:byte;
begin
try
x:=str2int(s);
except
x:=1;
end;
gotoxy(wherex-x,wherey);
end;
procedure cursorright(s:string);
var
x:byte;
begin
try
x:=str2int(s);
except
x:=1;
end;
gotoxy(wherex+x,wherey);
end;
procedure gotocol(s:string);
var
x:byte;
begin
try
x:=str2int(s);
except
x:=wherex;
end;
gotoxy(x,wherey);
end;
procedure cursormove(s:string);
Begin
gotoxy(str2int(strwordget(2,s,';')),str2int(strwordget(1,s,';')));
End;
procedure insertspaces(s:string);
var
j,a:byte;
begin
try
a:=str2int(strwordget(1,s,';'));
except
a:=1;
end;
for j:=1 to a do write(' ');
end;
procedure clearline(s:string);
var j,a:byte;
begin
try
a:=str2int(strwordget(1,s,';'));
except
a:=0;
end;
case a of
0: for j:=wherex to 80 do write(' ');
1: for j:=1 to wherex do write(' ');
2: begin ClrEOL;Gotoxy(1,wherey);End;
end;
end;
procedure erasechars(s:string);
var
j,a:byte;
begin
try
a:=str2int(strwordget(1,s,';'));
except
a:=1;
end;
for j:=1 to a do write(' ');
end;
procedure repeatlastchar(s:string);
var
j,a:byte;
begin
try
a:=str2int(strwordget(1,s,';'));
except
a:=1;
end;
for j:=1 to a do write(lastch);
end;
procedure gotoline(s:string);
var
j,a:byte;
begin
try
a:=str2int(strwordget(1,s,';'));
except
a:=1;
end;
gotoxy(wherex,a);
end;
procedure doesc;
var
buf:string[255];
j:byte;
begin
buf:='';
blockread(f,b,1);
while length(buf)<255 do begin
blockread(f,b,1);
buf:=buf+b;
if b in
['m','J','H','f','A','B','C','D','u','s','K','@','F','E','G','X','b','d']
then break;
end;
if length(buf)<1 then exit;
cnt:=strwordcount(buf,';');
c:=buf[length(buf)];
//writeln('C:> '+buf +'C: '+c);
delete(buf,length(buf),1);
//writeln(buf+'=='+int2str(cnt));
case c of
'd': gotoline(buf);
'b': repeatlastchar(buf);
'X': erasechars(buf);
'm': ansicoloring(buf);
'K': clearline(buf);
'A': cursorup(buf);
'B': cursordown(buf);
'C': cursorright(buf);
'D': cursorleft(buf);
'E': linesdown(buf);
'F': linesup(buf);
'G': gotocol(buf);
'f','H': cursormove(buf);
's': begin
savex:=wherex;
savey:=wherey;
end;
'u' : gotoxy(savex,savey);
'@' : insertspaces(buf);
'J' : begin
if str2int(strwordget(1,buf,';')) = 2 then ClrScr;
End;
end;
end;
begin
savex:=1;
savey:=1;
assign(f,fn);
reset(f,1);
while (not eof(f)) and (done=false) do begin
blockread(f,b,1);
if keypressed then begin
key:=readkey;
Case key of
'+' : d := d + 3;
'-' : begin
d := d - 3;
if d<0 then d:=0;
end;
'*' : d := 20;
'/' : d := 5;
#27 : Done:=true;
End;
end;
case b of
#27: doesc;
#13: delay(d);
else
write(b);
lastch:=b;
end;
end;
close(f);
end;
begin
dansi(paramstr(1),10);
end.
+ --- -- - . - --- --- --- - . - -- --- '
_____ _ _ ____ _ _
| _ |___ ___| |_| |_ ___ ___ | \ ___ ___|_|_| | 8888
| | | . | _| | -_| _| | | | _| . | | . | 8 888888 8
|__|__|_|_|___|_| |_|_|___|_| |____/|_| |___|_|___| 8888888888
8888888888
DoNt Be aNoTHeR DrOiD fOR tHe SySteM 88 8888 88
8888888888
/: HaM RaDiO /: ANSi ARt! /: MySTiC MoDS /: DooRS '88||||88'
/: NeWS /: WeATheR /: FiLEs /: SPooKNet ''8888"'
/: GaMeS /: TeXtFiLeS /: PrEPardNeSS /: FsxNet 88
/: TuTors /: bOOkS/PdFs /: SuRVaViLiSM /: ArakNet 8 8 88888888888
888 8888][][][888
TeLNeT : andr01d.zapto.org:9999 [UTC 11:00 - 20:00] 8 888888##88888
SySoP : xqtr eMAiL: xqtr@gmx.com 8 8888.####.888
DoNaTe : https://paypal.me/xqtr 8 8888##88##888