Download binary for Dos or binary for Linux
program {PASCAL} CODER; { v. 0.01}
{ Under GNU License }
{ JOAO PAULO SCHWARZ SCHULER }
{ http://www.schulers.com }
{ Turbo Pascal Source }
{ Free Pascal Source for DOS }
{ Free Pascal Source for Linux }
uses crt,Umem,reser,Uvite,
strings
{$ifndef linux}
,dos
{$else}
,linux
{$endif}
;
{ Joao Paulo Schwarz Schuler N:1482/93-2 }
type LINHA = word;
COLUNA = word;
const MAXNUMLIN=12000; { Numero maximo de linhas }
Const clNormal =LightGray; { Normal Text Color }
clString =LightGreen; { String Color }
clCom =LightBlue; { Comment Color }
clReserved =White; { Reserved word Color }
clNumber =LightRed; { Number Color }
clDelim =Yellow; { Delimiter Color }
type TTextEd = object
TJAN :linha; { Tamanho da janela em linhas }
PLVIS :linha; { Primeira linha visivel }
PCVIS :coluna; { Primeira coluna visivel }
ULTLIN :linha; { Ultima linha do texto }
PCURSORX:coluna; { Posicao do cursor X }
PCURSORY:linha; { Posicao do cursor Y }
EDLIN :linha; { Linha que esta sendo editada }
EDCOL :coluna; { Coluna em edicao }
RCAR :char; { Ultimo caracter lido }
CRCAR :byte; { Codigo do caracter lido }
SAI :boolean; { Sai do programa quando SAI }
{ for verdadeira }
PAR :string; { Parametro de entrada no DOS }
NOMEARQ :string;
TX :array [1..MAXNUMLIN] of PChar;
Modif :boolean; { Modificado ? }
procedure INIVAR;
procedure DESALOCAVAR;
procedure LOCATE(X:coluna;Y:linha);
procedure APRJAN;
procedure DISPLIN(L:linha);
procedure POSCURSOR;
procedure INC_EDLIN;
procedure DEC_EDLIN;
procedure INC_EDCOL;
procedure DEC_EDCOL;
procedure POEMCAR(C:char);
procedure DELETACAR;
procedure BAKSPACE;
procedure F1Key;
procedure DELETALIN(NLIN:linha);
procedure INSERELIN(NLIN:linha);
procedure SAVE(NOME:string);
procedure LOAD(NOME:string);
procedure LEARQ;
procedure GRAVAARQ;
procedure EXECUTATECLA;
procedure LETECLA;
procedure COD00;
function E_TEX(C:char):boolean;
end; { of TTextEd DECLARATION }
type COR = record
FRE:byte;
FUN:byte;
end;
var CORGL:COR; { Variavel global que contem a cor atual }
type
PTELA = record { Posicao na TELA }
X:coluna;
Y:linha;
end;
MJAN = string[7]; { Moldura da JANela }
TIPOJAN = record
MOLD:MJAN; { MOLDura }
COR:COR; { COR }
end;
OCOR = object { Objeto de COR }
C:COR;
procedure SCOR; { Salva a cor atual }
procedure RCOR; { Restaura cor antiga }
end;
OPOS = object { Objeto de POSicao }
P:PTELA;
procedure SPOS; { Salva a posicao atual }
procedure RPOS; { Restaura a posicao antiga }
end;
OCP = object { Objeto de Cor e Posicao }
C:OCOR;
P:OPOS;
procedure SCP;
procedure RCP;
end;
function IsAlpha(C:char):boolean;
{devolve true se eh caracter}
begin
IsAlpha:=( (C>='A') and (C<='Z') ) or ( (C>='a') and (C<='z') ) ;
end;
function IsDigit(C:char):boolean;
{devolve true se eh digito}
begin
IsDigit:=( (C>='0') and (C<='9') );
end;
function IsDelim(C:char):boolean;
{devolve true se eh Delimitador}
begin
IsDelim:=(pos(C,'~!@# $%^&*()-+=|\}{][":'';?><./,`')<>0); {_}
end;
procedure SELCOR(FRE,FUN:byte);
begin
textcolor(FRE);
textbackground(FUN);
CORGL.FRE:=FRE;
CORGL.FUN:=FUN;
end;
function MENOR(X,Y:coluna):coluna;
begin
if X<Y
then MENOR:=X
else MENOR:=Y;
end;
procedure TTextEd.INIVAR;
var L:longint;
begin
Modif:=false;
for L:=1 to MAXNUMLIN
do TX[L]:=nil;
SAI:=false;
PAR:=paramstr(1);
TJAN:=GetMaxRow-2;
PLVIS:=1;
PCVIS:=1;
EDLIN:=1;
EDCOL:=1;
{StrSet(TX[1],'');}
PCURSORX:=1;
PCURSORY:=1;
ULTLIN:=1;
end;
procedure TTextEd.DESALOCAVAR;
var L:linha;
begin
for L:=1 to ULTLIN
do StrDispose(TX[L]);
end;
procedure TTextEd.LOCATE(X:coluna;Y:linha);
begin
gotoxy(X,Y);
if WHEREX<>X then write(chr(7),X);
if WHEREY<>Y then write(chr(7),Y);
end;
procedure TTextEd.APRJAN;
var L:linha; { Numero da linha na janela }
begin
for L:=0 to TJAN do
begin
if L+PLVIS<=ULTLIN then
begin
DispLin(L+PLVIS);
end
else
write(' ':78);
end;
gotoxy(6,TJAN+2);
write(EDCOL:2,':',EDLIN:5,' F1-File ',NomeArq);
end;
procedure WriteColored(S:string;First,Len:word); {inside of displin}
{ Len : Length of line to be displayed }
{ First character to be displayed }
var Com,BStr:boolean;
{Comentario}
var P:word;
C:char;
SS:string; {Showed string}
SL:word; {Showed string length}
Cont:boolean;
Palavra:String;
OLDP:word;
begin
Com:=false;
Bstr:=false;
TextColor(LightGray);
SS:=copy(S,First,Len);
SL:=Length(SS);
Cont:=true;
if SL>0 then
begin
P:=1;
while P<=SL do
begin
C:=SS[P];
Cont:=true;
if Cont and (C=chr(39))
then begin
BStr:=Not(BStr);
if Bstr
then begin
TextColor(clString);
Write(C);
Inc(P);
while (SS[P]<>chr(39)) and (P<=SL) do
begin
write(SS[P]);
inc(P)
end;
if (P<=SL)
then write(SS[P]);
bstr:=not(SS[P]=chr(39));
TextColor(clNormal);
Cont:=false;
Com:=true;
end
else begin
Write(C);
TextColor(clNormal);
end;
Cont:=false;
end;
if Cont and Bstr
then begin
Write(C);
Cont:=false;
end;
if Cont and (C='{')
then begin
TextColor(clCom);
while (SS[P]<>'}') and (P<=SL) do
begin
write(SS[P]);
inc(P)
end;
if P<=SL
then write(SS[P]);
TextColor(clNormal);
Cont:=false;
Com:=true;
end;
if Cont and IsDelim(C)
then begin
TextColor(clDelim);
Write(C);
TextColor(clNormal);
Cont:=false;
end;
if Cont and IsDigit(C) and
((P=1) or (IsDelim(SS[pred(P)])))
then begin
TextColor(clNumber);
while (IsDigit(SS[P])) or (SS[P]='.') and (P<=SL) do
begin
write(SS[P]);
inc(P);
end;
dec(P);
textcolor(clNormal);
Cont:=false;
end; { of internal if }
if Cont and IsAlpha(C) and
((P=1) or (IsDelim(SS[pred(P)])))
then begin
OLDP:=P;
Palavra:='';
while not(IsDelim(SS[P])) and (P<=SL) do
begin
Palavra:=Palavra+SS[P];
inc(P);
end;
dec(P);
if IsReserved(Palavra)
then begin
TextColor(clReserved);
Write(Palavra);
TextColor(clNormal);
end
else Write(Palavra);
Cont:=false;
end; { of medium if }
if Cont
then write(C);
inc(P);
end; { of for }
end; { of if }
writeln(' ':78-SL);
end;
procedure TTextEd.DISPLIN(L:linha);
var CURRTX:string; { Linha a ser mostrada no video }
TCURRTX:word; { Tamanho da linha a ser mostrada no video }
begin
LOCATE(1,SUCC(L-PLVIS));
WriteColored(MyStrPas(TX[L]),PCVIS,78);
end;
procedure TTextEd.POSCURSOR;
begin
locate(succ(EDCOL-PCVIS),succ(EDLIN-PLVIS));
end;
procedure TTextEd.INC_EDCOL;
begin
if EDCOL<succ(StrLen(TX[EDLIN])) then
begin
inc(EDCOL);
if EDCOL-PCVIS>78 then
begin
inc(PCVIS);
APRJAN;
end
end;
end;
procedure TTextEd.DEC_EDCOL;
begin
if EDCOL>1 then
begin
dec(EDCOL);
if EDCOL<PCVIS then
begin
dec(PCVIS);
APRJAN;
end;
end;
end;
procedure TTextEd.INC_EDLIN;
begin
if EDLIN<ULTLIN then
begin
inc(EDLIN);
if EDLIN-PLVIS>TJAN then
inc(PLVIS);
APRJAN;
if EDCOL>StrLen(TX[EDLIN]) then
EDCOL:=succ(StrLen(TX[EDLIN]));
if EDCOL-PCVIS>78 then
PCVIS:=EDCOL;
end;
end;
procedure TTextEd.DEC_EDLIN;
begin
if EDLIN>1 then
begin
dec(EDLIN);
if EDLIN<PLVIS then
PLVIS:=EDLIN;
APRJAN;
if EDCOL>StrLen(TX[EDLIN]) then
EDCOL:=succ(StrLen(TX[EDLIN]));
if EDCOL-PCVIS>78 then
PCVIS:=EDCOL;
end;
end;
procedure TTextEd.POEMCAR(C:char);
var AUX:string;
begin
Modif:=true;
AUX:=MyStrPas(TX[EDLIN]);
insert(C,AUX,EDCOL);
StrSet(TX[EDLIN],AUX);
DISPLIN(EDLIN);
INC_EDCOL;
end;
procedure TTextEd.DELETACAR;
var AUX:string;
begin
Modif:=true;
if (EDCOL>Length(MyStrPas(TX[EDLIN]))) and (EDLIN<ULTLIN)
then begin
StrSet(TX[EDLIN],MyStrPas(TX[EDLIN])+MyStrPas(TX[succ(EDLIN)]));
if succ(EDLIN)=ULTLIN
then begin
DeletaLin(succ(EDLIN));
Inc(EDLIN);
end
else DeletaLin(succ(EDLIN));
AprJan;
end
else begin
AUX:=MyStrPas(TX[EDLIN]);
delete(AUX,EDCOL,1);
StrSet(TX[EDLIN],AUX);
DISPLIN(EDLIN);
write(' ');
end;
end; { of procedure }
procedure TTextEd.BAKSPACE;
var OL:word; {old len}
begin
Modif:=true;
if EDCOL>1
then begin
DEC_EDCOL;
DELETACAR;
end
else begin
if EDLIN>1
then begin
OL:=StrLen(TX[pred(EDLIN)]);
StrSet(TX[pred(EDLIN)],
MyStrPas(TX[pred(EDLIN)])+
MyStrPas(TX[EDLIN]));
if EDLIN<>ULTLIN
then begin
DeletaLin(EDLIN);
Dec_EDLIN
end
else DeletaLin(EDLIN);
while EDCOL<=OL
do INC_EDCOL;
end;
end
end;
function TTextEd.E_TEX(C:CHAR):boolean;
begin
E_TEX:=( ( (C>='A') and (C<='Z') ) or ( (C>='a') and (C<='z') ) or
( (C>='0') and (C<='9') ) or
(pos(C,'~!@# $%^&*()-_+=|\}{][":'';?><./,`')<>0) );
end; { of E_TEX }
procedure TTextEd.DELETALIN(NLIN:linha);
var L:linha;
begin
Modif:=true;
dec(ULTLIN);
if TX[NLIN]<>nil
then StrDispose(TX[NLIN]);
if NLIN<ULTLIN then
begin
for L:=NLIN to ULTLIN
do TX[L]:=TX[succ(L)]
end
else
begin
DEC_EDLIN;
end;
end;
procedure TTextEd.INSERELIN(NLIN:linha);
var L:linha;
begin
if NLIN<=ULTLIN then
for L:=ULTLIN downto NLIN do TX[succ(L)]:=TX[L];
inc(ULTLIN);
TX[NLIN]:=nil;
end;
procedure TTextEd.LOAD(NOME:string);
var L:linha;
ARQ:Text;
AUX:string;
begin
L:=0;
Modif:=false;
{NOME:='popo';}
assign(ARQ,NOME);
reset(ARQ);
while not(eof(ARQ)) do
begin
inc(L);
readln(ARQ,AUX);
StrSet(TX[L],AUX);
end;
close(ARQ);
ULTLIN:=L;
APRJAN;
end;
procedure TTextEd.SAVE(NOME:string);
var L:linha;
ARQ:Text;
begin
L:=0;
Modif:=true;
assign(ARQ,NOME);
rewrite(ARQ);
for L:=1 to ULTLIN do writeln(ARQ,TX[L]);
close(ARQ);
end;
procedure TTextEd.LEARQ;
var LCHO:TLChoice;
LP:Lista_Pointer;
WC:TWind;
Choiced:word;
begin
if Modif and Confirma('Save Changes ?',1)
then Save(NomeArq);
WC.Init(5,5,25,20,2,white,blue,blue,white);
LP.INIT;
MakeDirList(LP);
LCHO.INIT(WC,LP);
Choiced:=LCHO.RUN(1);
if LCHO.GetCs<>Esc then
begin
NomeArq:=MyStrPas(LP.Get(Choiced));
DESALOCAVAR;
INIVAR;
LOAD(NOMEARQ);
end;
DisposeListPChar(LP);
LP.Done;
WC.Done;
SetLargestWindow;
TextBackGround(Black);
clrscr;
APRJAN;
end;
procedure TTextEd.F1Key;
var P:TPrompt;
W,WC:TWind;
Choiced:byte;
begin
W.Init(3,3,12,9,1,white,blue,blue,white);
P.init(white,blue,blue,white);
P.prompt(1,1,'New ');
P.prompt(1,2,'Load ');
P.prompt(1,3,'Save ');
P.prompt(1,4,'Save As');
P.prompt(1,5,'Exit ');
W.Normal;
Choiced:=P.run(3);
case Choiced of
1: begin
if Modif and Confirma('Save Changes ?',1)
then Save(NomeArq);
DesalocaVar;
IniVar;
NomeArq:='NoName';
Modif:=false;
end;
2: LEARQ;
3: SAVE(NOMEARQ);
4: GRAVAARQ;
5: Sai:=true;
end; { of case }
SetLargestWindow;
TextBackGround(Black);
APRJAN;
W.Done;
P.Done;
end;
procedure TTextEd.GRAVAARQ;
var W:TWind;
R:TSRead;
begin
W.Init(3,TJAN-3,60,TJAN-1,1,white,blue,blue,white);
W.devout('File Name:');
R.init(W.PX,W.PY,blue,white,28,'');
R.run;
W.Done;
if R.GetCs=Normal then
begin
NomeArq:=R.EDLIN;
SAVE(NomeArq);
Look(NomeArq+' saved.');
end;
SetLargestWindow;
TextBackGround(Black);
APRJAN;
end;
procedure TTextEd.COD00;
var COD:byte;
begin
RCAR:=readkey;
COD:=ord(RCAR);
case COD of
DELETE_KEY: DELETACAR;
LEFT_KEY : DEC_EDCOL;
RIGHT_KEY : INC_EDCOL;
UP_KEY : DEC_EDLIN;
DOWN_KEY : INC_EDLIN;
F1_KEY : F1KEY;
PGUP_KEY :begin
if EDLIN>TJAN then
begin
EDLIN:=EDLIN-TJAN;
PLVIS:=EDLIN;
EDCOL:=1;
PCVIS:=1;
APRJAN;
end;
end;
PGDN_KEY :begin
if EDLIN+TJAN<ULTLIN then
begin
EDLIN:=EDLIN+TJAN;
PLVIS:=EDLIN;
EDCOL:=1;
PCVIS:=1;
APRJAN;
end;
end;
ALTS_KEY :GRAVAARQ;
HOME_KEY :begin
EDCOL:=1;
PCVIS:=1;
APRJAN;
end;
END_KEY :begin
EDCOL:=succ(Length(MyStrPAS(TX[EDLIN])));
if EDCOL<78
then PCVIS:=1
else PCVIS:=(EDCOL-75);
APRJAN;
end;
end; { of case }
end; { of COD00 }
procedure TTextEd.LETECLA;
begin
gotoxy(6,TJAN+2);
write(EDCOL:4);
POSCURSOR;
RCAR:=readkey;
CRCAR:=ord(RCAR);
end;
function NextChar(S:string;I:word):integer;
var L,P:word; {L:len; Position; search from I}
found:boolean;
begin
L:=Length(S);
found:=false;
if L>I then
begin
P:=I;
found:=false;
while (P<=L) and not(found) do
begin
if S[P]<>' '
then found:=true;
inc(P);
end;
end;
if found
then NextChar:=P-1
else NextChar:=-1;
end;
function MakeSpaces(W:word):string;
var R:string;
C:word;
begin
R:='';
for C:=1 to W
do R:=R+' ';
MakeSpaces:=R;
end;
procedure TTextEd.EXECUTATECLA;
procedure OnEnter;
var AUX,LEVA:string;
IDENT:integer;
begin
AUX:=MyStrPas(TX[EDLIN]);
IDENT:=NextChar(AUX,1);
if EDCOL<=Length(AUX)
then begin
LEVA:=Copy(AUX,EDCOL,Length(AUX)-EDCOL+1);
delete(AUX,EDCOL,Length(AUX)-EDCOL+1);
StrSet(TX[EDLIN],AUX);
end
else LEVA:='';
inc(EDLIN);
if EDLIN+PLVIS>TJAN
then inc(PLVIS);
INSERELIN(EDLIN);
if IDENT>0
then begin
StrSet(TX[EDLIN],MakeSpaces(IDENT-1)+LEVA);
EDCOL:=IDENT;
PCVIS:=IFW(EDCOL<78,1,IDENT);
end
else begin
EDCOL:=1;
PCVIS:=1;
end;
APRJAN;
end;
begin
if CRCAR=0 then
begin
COD00;
end
else
begin
if E_TEX(RCAR) then
begin
POEMCAR(RCAR);
end
else
case CRCAR of
BAKSPACE_KEY:BAKSPACE;
ENTER_KEY :OnEnter;
ESC_KEY :begin
SAI:=true;
end;
CTRLY_KEY :begin
DELETALIN(EDLIN);
APRJAN;
EDCOL:=1;
PCVIS:=1;
end;
CTRLS_KEY :SAVE(NOMEARQ);
CTRLL_KEY :LEARQ;
end; { of CASE }
end;
end; { OF TTextEd.EXECUTATECLA }
procedure OCOR.SCOR;
begin
C:=CORGL;
end;
procedure OCOR.RCOR;
begin
CORGL:=C;
textcolor(CORGL.FRE);
textbackground(CORGL.FUN);
end;
procedure OPOS.SPOS;
begin
P.X:=whereX;
P.Y:=whereY;
end;
procedure OPOS.RPOS;
begin
gotoxy(P.X,P.Y);
end;
procedure OCP.SCP;
begin
C.SCOR;
P.SPOS;
end;
procedure OCP.RCP;
begin
C.RCOR;
P.RPOS;
end;
var T:TTextEd;
OrigMode: Integer; { original video mode }
begin { of main program }
{$IFnDEF LINUX}
OrigMode := LastMode;
VITextMode(C80 + Font8x8);
{$ENDIF}
TextBackGround(black);
clrscr;
T.INIVAR;
if paramcount>0 then
begin
T.NOMEARQ:=T.PAR;
T.LOAD(T.NOMEARQ);
end
else
T.NOMEARQ:='NoName';
while not(T.SAI) do
begin
T.LETECLA;
T.EXECUTATECLA;
if T.SAI and T.Modif
then begin
if Confirma('Save Changes ?',1)
then T.Save(T.NomeArq);
end;
end;
T.DESALOCAVAR;
{$IFnDEF LINUX}
VITextMode(OrigMode);
{$ENDIF}
clrscr;
end.