Download binary for Dos or binary for Linux
Home

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.