Home

{                UNIDADE de VIDEO e TECLADO v. 0.01 }
{                VIDEO AND KEYBOARD UNIT    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 }

                            unit UVITE;

                            INTERFACE
uses crt,UMEM;

const TIPOS : array [1..4] of string[6] =
              ('攷碩蝶','瓢伴雄','娶埔由','峽喀頂') ; { TIPOS DE MOLDURAS }

      BAKSPACE_KEY =   8;
      LEFT_KEY     =  75;
      RIGHT_KEY    =  77;
      DELETE_KEY   =  83;
      ENTER_KEY    =  13;
      UP_KEY       =  72;    { CODIGO DAS TECLAS }
      DOWN_KEY     =  80;    { KEY CODES         }
      CTRLY_KEY    =  25;
      CTRLS_KEY    =  19;
      CTRLL_KEY    =  12;
      PGUP_KEY     =  73;
      PGDN_KEY     =  81;
      ESC_KEY      =  27;
      ALTS_KEY     =  31;
      INSERT_KEY   =  82;
      F1_KEY       =  59;
      F2_KEY       =  60;
      F10_KEY      =  68;
      HOME_KEY     =  71;
      END_KEY      =  79;



type CodigoSaida = (None,Normal,Esc,Up,Down);

type TCOR = record
             L,F:byte;                { Letra e Fundo }
            end;


{ Dark Colors :              }
{(Foreground & Background)   }
{ 様様様様様様様様様様様様   }
{ Black         0            }
{ Blue          1            }
{ Green         2            }
{ Cyan          3            }
{ Red           4            }
{ Magenta       5            }
{ Brown         6            }
{ LightGray     7            }
{                            }
{ Light Colors:              }
{(Foreground)                }
{ 様様様様様様様様          }
{ DarkGray       8           }
{ LightBlue      9           }
{ LightGreen    10           }
{ LightCyan     11           }
{ LightRed      12           }
{ LightMagenta  13           }
{ Yellow        14           }
{ White         15           }

{For flashing (blinking) text foreground, Blink = 128.    }


type TTEXTVIDEO = array [0..4095] of byte ;

type STR80 = string[80];

type PSTR80 = ^STR80;



procedure PrintCar(X,Y:byte;C:char);
{ imprime caracter na posicao X,Y }

function E_TEX(C:CHAR):boolean;
{ devolve TRUE se for caracter de texto }

procedure Waitkey;
{ espera tecla }

procedure LOOK(TX:str80);
{ Exibe mensagem TX de advertencia }

function CONFIRMA(TX:str80;DEFAULT:byte):boolean;
{ Exibe mensagem TX de confirmacao }


{ --------------   OBJETO DE TECLADO -------------------------------  }
{ O objeto de teclado tem o objetivo de gerir a varredura do teclado  }
{ e desviar o processamento para tratamento da tecla correspondente.  }
{ A calsse TTeclado foi construida para ser herdada por outras classes}
type TTeclado = object {(TProcesso)}
                  RCAR:char;
                  CRCAR:byte;

                  procedure P_BAKSPACE_KEY;      virtual; { procedimentos }
                  procedure P_LEFT_KEY;          virtual; { de teclas     }
                  procedure P_RIGHT_KEY;         virtual; { dependem de   }
                  procedure P_DELETE_KEY;        virtual; { seu respectivo}
                  procedure P_ENTER_KEY;         virtual; { pressionamento}
                  procedure P_UP_KEY;            virtual; { para sua      }
                  procedure P_DOWN_KEY;          virtual; { execucao      }
                  procedure P_CTRLY_KEY;         virtual;
                  procedure P_CTRLS_KEY;         virtual;
                  procedure P_CTRLL_KEY;         virtual;
                  procedure P_PGUP_KEY;          virtual;
                  procedure P_PGDN_KEY;          virtual;
                  procedure P_ESC_KEY;           virtual;
                  procedure P_ALTS_KEY;          virtual;
                  procedure P_INSERT_KEY;        virtual;
                  procedure P_F1_KEY;            virtual;
                  procedure P_F2_KEY;            virtual;
                  procedure P_F10_KEY;           virtual;
                  procedure P_TEXTO(C:char);     virtual;
   { procedimento chamado quando caracter digitado for validado por E_TEX }
                  procedure P_LETECLA;           virtual;
                  { espera e identifica tecla pressionada }

                  procedure P_EXECUTATECLA;      virtual;
                  { desvio para o procedimento de tecla correspondente }

                  procedure P_COD00;             virtual;
                  { trata teclas com codigo de varredura 00 }
end;

{ --------------   OBJETO DE PROMPT -------------------------------- }
{ objeto desenvolvido para permitir o uso de menus                   }

type PROMPTITEM= record
                   TX:PChar;       { Texto apresentado de cada item }
                   X,Y:byte;       { posicao de cada item }
                 end;

type PROMPTITEMPTR=^PROMPTITEM;

type TPrompt = object      { objeto de prompt parecido com o do CLIPPER }
                 LISTAPROMPT:LISTA_POINTER;
                 { LISTAPROMPT contera os os itens e posicoes do menu   }

                 NUM:word;                            { numero de opcoes }
                 ATUAL:byte;                          { opcao iluminada  }
                 LN,FN,LR,FR:byte; { CORES:Letra Normal,   }
                                   {       Fundo Normal,   }
                                   {       Letra Realcada, }
                                   {       Fundo Realcado  }

                 RCAR:char;              { caracter recebido           }
                 CRCAR:byte;             { codigo do caracter recebido }
                 SAI:boolean;            { verdadeiro quando SAI       }
                 CS:byte;                { Codigo de saida             }

                 procedure  Init(LNP,FNP,LRP,FRP:byte);
                 { define cores e inicia lista de itens}

                 procedure Prompt(XP,YP:byte;PC:PChar);
                 { acrescenta opcao }

                 procedure Disp;
                 { mostra opcoes    }

                 procedure Letecla;
                 { espera tecla ser digitada }

                 procedure ExecutaTecla;

                 function Run(FIRST:byte):byte;
                 { executa com inicio em FIRST }

                 procedure Done;

               end;

{ ----------------  OBJETO DE LEITURA DO TECLADO: TSRead ---------------- }
{ This Class is used to read a line from the keyboard                     }
type TSRead = object(TTeclado)

                { TTeclado e ancestral de TSRead }

                EDLIN:string;           { String em edicao            }
                EDCOL:byte;             { coluna da edicao            }
                TAM:byte;               { tamanho maximo da string    }
                X,Y:byte;               { posicao da edicao           }
                L,F:byte;               { cor da string editada       }
                SAI:boolean;            { verdadeiro quando SAI       }
                OLDSTR:string;
                CS:CodigoSaida;         { Codigo de saida       }

                constructor Init(XP,YP,LP,FP,TAMANHO:byte;STARTUP:str80);
                   { Define XP,YP: coordenadas da edicao                  }
                   { LP,FP: cor da letra e fundo espectivamente           }
                   { TAMANHO:Numero de caracteres permitidos para edicao  }
                   { STARTUP:Contem string inicial para edicao            }
                procedure PoemCar(C:char);  { Insere caracter             }
                procedure DeletaCar;        { deleta caracter             }
                procedure Run;              { executa                     }
                procedure LETECLA;          { le tecla                    }
                procedure EXECUTATECLA;     { executa tecla               }
                procedure DispLin;          { reapresenta linha de edicao }
                procedure INC_EDCOL;        { incrementa coluna de edicao }
                procedure DEC_EDCOL;        { decrementa coluna de edicao }
                function GETCS:CodigoSaida; { devolve codigo de saida     }
                function GETSTRING:string;  { devolve string editada      }

                procedure P_BAKSPACE_KEY;     virtual;
                procedure P_ENTER_KEY;        virtual;
                procedure P_ESC_KEY;          virtual;
                procedure P_DELETE_KEY;       virtual;
                procedure P_LEFT_KEY;         virtual;
                procedure P_RIGHT_KEY;        virtual;
                procedure P_UP_KEY;           virtual;
                procedure P_DOWN_KEY;         virtual;
                procedure P_TEXTO(C:char);    virtual;
              end;

{ ------------- ALTERACAO DO TAMANHO DE UMA JANELA ----------------- }

type TSizeWind = object (TTeclado)
                  X1,Y1,X2,Y2:byte; { coordenadas da janela atual }
                  OX1,OY1,OX2,OY2:byte; {coordenadas da janela antiga }
                  NLIN,NCOL:byte;
                  CS:CodigoSaida;

                  constructor SetPos(PX1,PY1,PX2,PY2,MINCOL,MINLIN:byte);
                  { define posicao da janela atual,
                    numero minimo de linhas,
                    numero minimo de colunas }

                  procedure P_LEFT_KEY;         virtual;
                  procedure P_RIGHT_KEY;        virtual;
                  procedure P_UP_KEY;           virtual;
                  procedure P_DOWN_KEY;         virtual;
                  procedure P_ENTER_KEY;        virtual;
                  procedure P_ESC_KEY;          virtual;

                  destructor Done;

                end;

{ ------------- ALTERACAO DA POSICAO DE UMA JANELA ----------------- }

type TMoveWind = object (TTeclado)
                  X1,Y1,X2,Y2:byte; { coordenadas da janela atual }
                  OX1,OY1,OX2,OY2:byte; {coordenadas da janela antiga }
                  CS:CodigoSaida;

                  constructor SetPos(PX1,PY1,PX2,PY2:byte);
                  { define posicao da janela atual }

                  procedure P_LEFT_KEY;         virtual;
                  procedure P_RIGHT_KEY;        virtual;
                  procedure P_UP_KEY;           virtual;
                  procedure P_DOWN_KEY;         virtual;
                  procedure P_ENTER_KEY;        virtual;
                  procedure P_ESC_KEY;          virtual;

                  destructor Done;

                end;


{ ----------------- OBJETO DE JANELA: TWind ---------------------------- }
{ this class is used to create a window                                  }
type TWind = object

              X1,Y1,X2,Y2:byte;       { COORDENDAS DA JANELA      }
              CN,CR:tcor;             { COR NORMAL E COR REALCADA }
              PX,PY:byte;             { POSICOES X E Y DO CURSOR  }
              NCOL:byte;              { NUMERO DE COLUNAS         }
              NLIN:byte;              { NUMERO DE LINHAS          }
              ITIPO:byte;             { TIPO DA JANELA            }

              constructor JustInit;

              constructor Init(E1,E2,D1,D2,TIPO,LN,FN,LR,FR:byte); {desenha }
                                                  { janela nas coordenadas  }
                                                  { E1,E2,D1, D2  do  tipo  }
                                                  { TIPO com cores:         }
                                                  {       Letra Normal,     }
                                                  {       Fundo Normal,     }
                                                  {       Letra Realcada,   }
                                                  {       Fundo Realcado    }

              procedure RePos(E1,E2,D1,D2:byte);  { RePosiciona janela      }
              procedure ReTam(MINCOL,MINLIN:byte);{ REajusta TAManho        }
              {MINLINL:numero minimo de linhas, }
              {MINCOL: numero minimo de colunas }
              procedure ReLoc;                    { Move a janela           }
              procedure Desenha;                  { Desenha janela          }
              procedure SelCor(LN,FN,LR,FR:byte); { seleciona cores         }
              procedure SelWind;                  { seleciona janela        }
              procedure DevOut(TX:string);        { imprime string          }
              procedure DevOutln(TX:string);      { imprime string e LF     }
              procedure RDevOut(TX:string);       { imprime string realcada }
              procedure RDevOutln(TX:string);     { imprime string realcada }
              procedure Normal;                   { prepara para comando    }
              procedure EndNormal;                { termina bloco de comando}
              procedure CLS;                      { apaga a tela            }
              procedure Locate(X,Y:byte);         { posiciona cursor        }

              function GETLIN:byte;               { devolve numero de linhas}
              function GETCOL:byte;               {devolve numero de colunas}

              destructor Done;                    { recupera tela anterior  }

             end;
{ ------------------OBJETO DE ESCOLHA -------------------------------- }
{ This class is like Clipper's AChoice                                 }
type TLChoice = object(TTeclado)

                 J:TWind;
                 LISTA:LISTA_POINTER;    { lista de opcoes     }
                 MANY:word;               { numero de elementos }
                 FIRSTVISIBLE:word;       { primeiro elemento visivel }
                 INFOCUS:word;            { elemento selecionado      }
                 WantToQuit:boolean;
                 CS:CodigoSaida;

                 constructor INIT(var JANELA:TWind;var OPCOES:LISTA_POINTER);
                 destructor DONE;

                 procedure REAPRESENTA;

                 function RUN(START:word):word;
                 {executa TLChoice}

                 function GETCS:CodigoSaida;
                 { retorna codigo de saida }

                 procedure P_UP_KEY;            virtual;
                 procedure P_DOWN_KEY;          virtual;
                 procedure P_ENTER_KEY;         virtual;
                 procedure P_ESC_KEY;           virtual;

               end;

{----------------------------------------------------------------------}

function CHOICEFILE(var J:TWind):PChar;
{ Menu de escolha de arquivo }

procedure VITextMode(TM:integer);
{ Set TextMode and some variables }

procedure SetLargestWindow;

function GetMaxCol:byte;
{ davolve numero maximo de colunas }

function GetMaxRow:byte;
{ davolve numero maximo de linhas }

                            IMPLEMENTATION

var MaxLin,MaxCol:byte;

function GetMaxCol:byte;
{ davolve numero maximo de colunas }
begin
GetMaxCol:=MaxCol;
end;

function GetMaxRow:byte;
{ davolve numero maximo de linhas }
begin
GetMaxRow:=MaxLin;
end;

procedure VITextMode(TM:integer);
{ Set TextMode and some variables }
begin
TextMode(TM);
MaxLin:=Hi(WindMax)+1;
MaxCol:=Lo(WindMax)+1;
end;

procedure SetLargestWindow;
begin
Window(1,1,MaxCol,MaxLin);
end;

function CHOICEFILE(var J:TWind):PChar;
{ Menu de escolha de arquivo }
var LP:LISTA_POINTER;
    LCHO:TLChoice;
    PC:PCHAR;
    ESCOLHIDO:word;
begin
J.CLS;
PC:=nil;
LP.INIT;
MakeDirList(LP);
LCHO.INIT(J,LP);
ESCOLHIDO:=LCHO.RUN(1);
if LCHO.GETCS = Normal
   then CHOICEFILE:= GetPChar(GetString(LP.GET(ESCOLHIDO)))
   else CHOICEFILE:= PC;
DisposeListPChar(LP);
LP.Done;
end;

procedure PrintCar(X,Y:byte;C:char);
{ imprime caracter na posicao X,Y }
begin
gotoxy(X,Y);
write(C);
end;

function E_TEX(C:CHAR):boolean;
{ devolve TRUE se for caracter de texto }
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 Waitkey;
{ espera tecla }
var C:char;
begin
C:=readkey;
if ord(C)=0 then
   C:=readkey;
end;

procedure LOOK(TX:str80);
{ Exibe mensagem TX de advertencia }
var LI,CI,LF,CF:byte;
    WIN:TWind;       { objeto de janela }
begin
LI:=11;  { Linha Inicial  }
LF:=15;  { Linha Final    }
CI:=25;  { Coluna Inicial }
CF:=45;  { Coluna Final   }
if ord(TX[0])>15 then                { necessita outro tamanho ??? }
   begin
   CI:=40 - (ord(TX[0]) div 2);      { calcula novo tamanho        }
   CF:=40 + (ord(TX[0]) div 2)+4;
   end;
WIN.Init(CI,LI,CF,LF,3,white,red,white,red);
WIN.DevOutLn('  '+TX);
WIN.Locate((CF-CI) div 2,3);
WIN.RDevOut('OK');
WaitKey;
WIN.Done;
end;

function CONFIRMA(TX:str80;DEFAULT:byte):boolean;
{ Exibe mensagem TX de confirmacao }
{ DEFAULT=1 significa DEFAULT = SIM }
var LI,CI,LF,CF:byte;
    WIN:TWind;       { objeto de janela }
    PRO:TPrompt;     { objeto de prompt }
    MEIO:byte;  { meio da janela }
    RESULT:boolean;
begin
if DEFAULT<>1 then DEFAULT:=2;
LI:=11;  { Linha Inicial  }
LF:=15;  { Linha Final    }
CI:=25;  { Coluna Inicial }
CF:=45;  { Coluna Final   }
if ord(TX[0])>15 then                { necessita outro tamanho ??? }
   begin
   CI:=40 - (ord(TX[0]) div 2);      { calcula novo tamanho        }
   CF:=40 + (ord(TX[0]) div 2)+4;
   end;
MEIO:=(CF - CI) div 2;
WIN.Init(CI,LI,CF,LF,3,white,red,white,red);
WIN.DevOutLn('  '+TX);
PRO.Init(LightGray,red,white,red);
PRO.Prompt(MEIO-3,3,'Yes');
PRO.Prompt(MEIO+3,3,'No');
RESULT:= (PRO.Run(DEFAULT)=1) ;
WIN.Done;
CONFIRMA:=RESULT;
end;


{ -------------------- OBJETO DE TECLADO -------------------- }

procedure TTeclado.P_BAKSPACE_KEY;
begin;
end;

procedure TTeclado.P_LEFT_KEY;
begin;
end;


procedure TTeclado.P_RIGHT_KEY;
begin;
end;

procedure TTeclado.P_DELETE_KEY;
begin;
end;

procedure TTeclado.P_ENTER_KEY;
begin;
end;

procedure TTeclado.P_UP_KEY;
begin;
end;

procedure TTeclado.P_DOWN_KEY;
begin;
end;

procedure TTeclado.P_CTRLY_KEY;
begin;
end;

procedure TTeclado.P_CTRLS_KEY;
begin;
end;

procedure TTeclado.P_CTRLL_KEY;
begin;
end;

procedure TTeclado.P_PGUP_KEY;
begin;
end;

procedure TTeclado.P_PGDN_KEY;
begin;
end;

procedure TTeclado.P_ESC_KEY;
begin;
end;

procedure TTeclado.P_ALTS_KEY;
begin;
end;

procedure TTeclado.P_INSERT_KEY;
begin;
end;

procedure TTeclado.P_F1_KEY;
begin;
end;

procedure TTeclado.P_F2_KEY;
begin;
end;

procedure TTeclado.P_F10_KEY;
begin;
end;

procedure TTeclado.P_TEXTO(C:char);
{ procedimento chamado quando caracter digitado for validado por E_TEX }
{ C: caracter considerado de texto de acordo com E_TEX }
begin;
end;

procedure TTeclado.P_LETECLA;
{ espera e identifica tecla pressionada }
begin
RCAR:=readkey;
CRCAR:=ord(RCAR);
end;

procedure TTeclado.P_EXECUTATECLA;
{ desvio para o procedimento de tecla correspondente }
begin;
if CRCAR=0 then
   begin
   P_COD00;
   end
 else
   begin
     if E_TEX(RCAR) then
        begin
        P_TEXTO(RCAR);
        end
      else
        case CRCAR of
          BAKSPACE_KEY: P_BAKSPACE_KEY;
          ENTER_KEY   : P_ENTER_KEY;
          ESC_KEY     : P_ESC_KEY;
          CTRLS_KEY   : P_CTRLS_KEY;
          CTRLY_KEY   : P_CTRLY_KEY;
        end; { of CASE }
      end;

end;

procedure TTeclado.P_COD00;
{ trata teclas com codigo de varredura 00 }
var COD:byte;
begin
RCAR:=readkey;
COD:=ord(RCAR);
case COD of
   DELETE_KEY: P_DELETE_KEY;
   LEFT_KEY  : P_LEFT_KEY;
   RIGHT_KEY : P_RIGHT_KEY;
   UP_KEY    : P_UP_KEY;
   DOWN_KEY  : P_DOWN_KEY;
   PGUP_KEY  : P_PGUP_KEY;
   PGDN_KEY  : P_PGDN_KEY;
   ALTS_KEY  : P_ALTS_KEY;
   INSERT_KEY: P_INSERT_KEY;
   F1_KEY    : P_F1_KEY;
   F2_KEY    : P_F2_KEY;
   F10_KEY   : P_F10_KEY;
end; { of case  }
end; { of COD00 }





{ --------------   OBJETO DE PROMPT -------------------------------- }


procedure TPrompt.PROMPT(XP,YP:byte;PC:PChar);
{ Insere intem na lista de prompt }
var PIPTR:PromptItemPTR;
begin
new(PIPTR);
PIPTR^.X:=XP;
PIPTR^.Y:=YP;
PIPTR^.TX:=PC;
LISTAPROMPT.INSERT(PIPTR);
NUM:=LISTAPROMPT.GETNUM;
end;

procedure TPrompt.Init(LNP,FNP,LRP,FRP:byte);
{ CORES:Letra Normal,   }
{       Fundo Normal,   }
{       Letra Realcada, }
{       Fundo Realcado  }

begin
LN:=LNP;
FN:=FNP;
LR:=LRP;
FR:=FRP;
LISTAPROMPT.INIT;
SAI:=false;
end;

procedure TPrompt.ExecutaTecla;
begin
if (CRCAR=UP_KEY)   or (CRCAR=LEFT_KEY)  then dec(ATUAL);  { levanta       }
if (CRCAR=DOWN_KEY) or (CRCAR=RIGHT_KEY) then inc(ATUAL);  { abaixa        }
if ATUAL=0         then ATUAL:=NUM;                        { vai ao FIM    }
if ATUAL=succ(NUM) then ATUAL:=1;                          { vai ao INICIO }
if CRCAR=13 then      { ENTER ??? }
   begin
   CS:=ATUAL;         { Codigo de Saida = numero do item atual(SELECIONADO)}
   SAI:=true;
   end;

if CRCAR=ESC_KEY then
   begin
   CS:=255;         { 255 = desistencia }
   SAI:=true;
   end;

Disp;
end;



function TPrompt.Run(FIRST:byte):byte;
{ executa o prompt; O item que recebe a cor realcada primeiro e FIRST }
begin
ATUAL:=FIRST;
Disp;
while not(SAI) do
      begin
      Letecla;
      ExecutaTecla;
      end;
Run:=CS;
end;

procedure TPrompt.Done;
begin
ListaPrompt.Done;
end;

procedure TPrompt.Disp;
{ mostra os intes; o item selecionado de indice ATUAL e realcado }
var PIPTR:PromptItemPTR;
var I:integer;
begin
for i:=1 to NUM do
    begin
    PIPTR:=LISTAPROMPT.GET(I);
    gotoxy(PIPTR^.X,PIPTR^.Y);
    if ATUAL=I                         { REALCADO ??? }
       then begin
            textcolor(LR);             { MOSTRA ITEM EM COR REALCADA }
            textbackground(FR);
            write(PIPTR^.TX);
            end
       else begin
            textcolor(LN);             { MOSTRA ITEM EM COR NORMAL   }
            textbackground(FN);
            write(PIPTR^.TX);
            end;
    end;
end;

procedure TPrompt.LETECLA;
{ espera tecla ser digitada }
begin
      RCAR:=readkey;
      CRCAR:=ord(RCAR);
      if CRCAR=0 then LETECLA;         { ELIMINA CODIGO DE VARREDURA 00 }
end;



{ ------------- ALTERACAO DO TAMANHO DE UMA JANELA ----------------- }
constructor TSizeWind.SetPos(PX1,PY1,PX2,PY2,MINCOL,MINLIN:byte);
{ define posicao da janela atual,
  numero minimo de linhas,
  numero minimo de colunas }
begin
X1:=PX1; OX1:=PX1;
Y1:=PY1; OY1:=PY1;
X2:=PX2; OX2:=PX2;
Y2:=PY2; OY2:=PY2;
NLIN:=MINLIN;
NCOL:=MINCOL;
end;


procedure TSizeWind.P_LEFT_KEY;
begin
if succ(X2-x1)>NCOL then
   dec(X2);
end;

procedure TSizeWind.P_RIGHT_KEY;
begin
if X2<80 then
   inc(X2);
end;

procedure TSizeWind.P_UP_KEY;
begin
if Y2-Y1>succ(NLIN) then
   dec(Y2);
end;

procedure TSizeWind.P_DOWN_KEY;
begin
if Y2<24 then
   inc(Y2);
end;

procedure TSizeWind.P_ENTER_KEY;
begin
CS:=Normal;
end;

procedure TSizeWind.P_ESC_KEY;
begin
CS:=Esc;
end;

destructor TSizeWind.Done;
begin
end;

{ ------------- ALTERACAO DA POSICAO DE UMA JANELA ----------------- }
constructor TMoveWind.SetPos(PX1,PY1,PX2,PY2:byte);
{ define posicao da janela atual }
begin
X1:=PX1; OX1:=PX1;
Y1:=PY1; OY1:=PY1;
X2:=PX2; OX2:=PX2;
Y2:=PY2; OY2:=PY2;
end;

procedure TMoveWind.P_LEFT_KEY;
begin
if X1>1 then
   begin
   dec(X1);
   dec(X2);
   end;
end;

procedure TMoveWind.P_RIGHT_KEY;
begin
if X2<80 then
   begin
   inc(X1);
   inc(X2);
   end;
end;

procedure TMoveWind.P_UP_KEY;
begin
if Y1>1 then
   begin
   dec(Y1);
   dec(Y2);
   end;
end;

procedure TMoveWind.P_DOWN_KEY;
begin
if Y2<24 then
   begin
   inc(Y1);
   inc(Y2);
   end;
end;

procedure TMoveWind.P_ENTER_KEY;
begin
CS:=Normal;
end;

procedure TMoveWind.P_ESC_KEY;
begin
CS:=Esc;
end;

destructor TMoveWind.Done;
begin
end;



{ ----------------- OBJETO DE JANELA: TWind ---------------------------- }

constructor TWind.JustInit;
begin
end;

constructor TWind.Init(E1,E2,D1,D2,TIPO,LN,FN,LR,FR:byte);
var I:integer;
begin
X1:=E1;
Y1:=E2;
X2:=D1;
Y2:=D2;
NCOL:=pred(X2-X1);
NLIN:=pred(Y2-Y1);
ITIPO:=TIPO;
SelCor(LN,FN,LR,FR);

window(1,1,MaxCol,MaxLin);
PrintCar(X1,Y1,TIPOS[TIPO,1]);     { desenha pontas }
PrintCar(X2,Y1,TIPOS[TIPO,2]);
PrintCar(X1,Y2,TIPOS[TIPO,3]);
PrintCar(X2,Y2,TIPOS[TIPO,4]);

gotoxy(succ(X1),Y1);
for I:=1 to pred(X2-X1) do         { desenha linha superior }
    write(TIPOS[TIPO,5]);

gotoxy(succ(X1),Y2);               { desenha linha inferior }
for I:=1 to pred(X2-X1) do
    write(TIPOS[TIPO,5]);

for I:=succ(Y1) to pred(Y2) do     { desenha linhas verticais }
    begin
    gotoxy(X1,I);
    write(TIPOS[TIPO,6]);
    write(TIPOS[TIPO,6]:(X2-X1));
    end;

{Selwind;}
PX:=1;
PY:=1;

end;

procedure TWind.RePos(E1,E2,D1,D2:byte);
{ RePosiciona janela      }
var I:integer;
begin
X1:=E1;
Y1:=E2;
X2:=D1;
Y2:=D2;
NCOL:=pred(X2-X1);
NLIN:=pred(Y2-Y1);
Desenha;
end;

procedure TWind.ReTam(MINCOL,MINLIN:byte);
{ REajusta TAManho        }
var SW:TSizeWind;
begin
end;

procedure TWind.ReLoc;
{ Move a janela }
var MW:TMoveWind;
begin
end;


procedure TWind.Desenha;
var I:integer;
begin
textcolor(CN.L);                       { define cor normal     }
textbackground(CN.F);
window(1,1,MaxCol,MaxLin);
PrintCar(X1,Y1,TIPOS[ITIPO,1]);     { desenha pontas }
PrintCar(X2,Y1,TIPOS[ITIPO,2]);
PrintCar(X1,Y2,TIPOS[ITIPO,3]);
PrintCar(X2,Y2,TIPOS[ITIPO,4]);

gotoxy(succ(X1),Y1);
for I:=1 to pred(X2-X1) do         { desenha linha superior }
    write(TIPOS[ITIPO,5]);

gotoxy(succ(X1),Y2);               { desenha linha inferior }
for I:=1 to pred(X2-X1) do
    write(TIPOS[ITIPO,5]);

for I:=succ(Y1) to pred(Y2) do     { desenha linhas verticais }
    begin
    gotoxy(X1,I);
    write(TIPOS[ITIPO,6]);
    write(TIPOS[ITIPO,6]:(X2-X1));
    end;
PX:=1;
PY:=1;
end;

procedure TWind.SelCor(LN,FN,LR,FR:byte);
begin
CN.L:=LN;
CN.F:=FN;
CR.L:=LR;
CR.F:=FR;
textcolor(LN);                           { ativa cores normais }
textbackground(FN);
end;

procedure TWind.SelWind;
begin
window(succ(X1),succ(Y1),pred(X2),pred(Y2));     { ativa janela }
end;

procedure TWind.DevOut(TX:string);
begin
SelWind;
textcolor(CN.L);                       { define cor normal     }
textbackground(CN.F);
gotoxy(PX,PY);
write(TX);                             { imprime em cor normal }
PX:=WhereX;
PY:=WhereY;
end;

procedure TWind.DevOutln(TX:string);
begin
SelWind;
textcolor(CN.L);                       { define cor normal     }
textbackground(CN.F);
gotoxy(PX,PY);
writeln(TX);                           { imprime em cor normal }
                                       { com CR                }
PX:=WhereX;
PY:=WhereY;
end;

procedure TWind.RDevOut(TX:string);
begin
SelWind;
textcolor(CR.L);
textbackground(CR.F);                  { define cor realcada     }
gotoxy(PX,PY);
write(TX);                             { imprime em cor realcada }
PX:=WhereX;
PY:=WhereY;
end;

procedure TWind.RDevOutln(TX:string);
begin
SelWind;
textcolor(CR.L);
textbackground(CR.F);                  { define cor realcado     }
gotoxy(PX,PY);
writeln(TX);                           { imprime em cor realcada }
                                       { com CR                  }
PX:=WhereX;
PY:=WhereY;
end;

procedure TWind.Normal;                { prepara para comando de }
                                       { video externo a unidade }
begin
SelWind;
textcolor(CN.L);
textbackground(CN.F);
gotoxy(PX,PY);
end;

procedure TWind.EndNormal;             { termina bloco de comando}
begin
PX:=WhereX;
PY:=WhereY;
end;

procedure TWind.CLS;                   { apaga o conteudo da janela }
begin
Normal;
clrscr;
end;

procedure TWind.Locate(X,Y:byte);      { posiciona cursor na janela }
begin
PX:=X;
PY:=Y;
end;

function TWind.GETLIN:byte;
{ devolve numero de linhas}
begin
GETLIN:=NLIN;
end;

function TWind.GETCOL:byte;
{devolve numero de colunas}
begin
GETCOL:=NCOL;
end;


destructor TWind.Done;                 { recupera tela }
begin
end;


{ ----------------  OBJETO DE LEITURA DO TECLADO: TSRead ---------------- }

procedure TSRead.POEMCAR(C:char);      { insere caracter }
begin
insert(C,EDLIN,EDCOL);
if length(EDLIN)>TAM
   then EDLIN[0]:=chr(TAM);
DispLin;
INC_EDCOL;
end;

procedure TSRead.DELETACAR;
begin
delete(EDLIN,EDCOL,1);
DispLin;
end;

procedure TSRead.DispLin;              { apresenta linha em edicao }
begin
gotoxy(X,Y);
textcolor(L);
textbackground(F);
write(EDLIN);
if ord(EDLIN[0])<TAM then
   write(' ':(TAM-ord(EDLIN[0])))
end;

procedure TSRead.INC_EDCOL;
begin
if EDCOL<=length(EDLIN) then inc(EDCOL);
SAI:=EDCOL>TAM;
end;

procedure TSRead.DEC_EDCOL;
begin
IF EDCOL>1 then dec(EDCOL);
end;

procedure TSRead.LETECLA;
begin
      Gotoxy(pred(X+EDCOL),Y);
      P_LETECLA;
end;

procedure TSRead.EXECUTATECLA;
begin
P_EXECUTATECLA;
end;

procedure TSRead.P_BAKSPACE_KEY;
begin
DEC_EDCOL;
DELETACAR;
end;

procedure TSRead.P_ENTER_KEY;
begin
SAI:=true;
CS:=Normal;
end;

procedure TSRead.P_ESC_KEY;
begin
SAI:=true;
EDLIN:=OLDSTR;
CS:=Esc;
end;

procedure TSRead.P_DELETE_KEY;
begin
delete(EDLIN,EDCOL,1);
DispLin;
end;

procedure TSRead.P_LEFT_KEY;
begin
DEC_EDCOL;
end;

procedure TSRead.P_RIGHT_KEY;
begin
INC_EDCOL;
end;

procedure TSRead.P_UP_KEY;
begin
SAI:=true;
CS :=Up;
end;

procedure TSRead.P_DOWN_KEY;
begin
SAI:=true;
CS :=Down;
end;

procedure TSRead.RUN;
begin
SAI:=false;
 while not(SAI) do
       begin
       LETECLA;
       EXECUTATECLA;
       end;
end;

procedure TSRead.P_TEXTO(C:char);
begin
POEMCAR(C);
end;

constructor TSRead.Init(XP,YP,LP,FP,TAMANHO:byte;STARTUP:str80);
begin
X:=XP;
Y:=YP;
L:=LP;
F:=FP;
TAM:=TAMANHO;
EDLIN:=STARTUP;
DispLin;
EDCOL:=1; { coluna de edicao e 1 }
CS:=None; { nao tem codigo de saida ainda }
end;

function TSRead.GETCS:CodigoSaida;
{ devolve codigo de saida     }
begin
GETCS:=CS;
end;

function TSRead.GETSTRING:string;
{ devolve string editada      }
begin
GETSTRING:=EDLIN;
end;

{ ------------------OBJETO DE ESCOLHA -------------------------------- }
constructor TLChoice.INIT(var JANELA:TWind;var OPCOES:LISTA_POINTER);
begin
J.JustInit;
J:=JANELA;
LISTA.NUMP:=OPCOES.NUMP;      { LISTA:=OPCOES }
LISTA.BASE:=OPCOES.BASE;
MANY:=LISTA.GETNUM;
INFOCUS:=1;
WantToQuit:=false;
FIRSTVISIBLE:=1;
end;

procedure TLChoice.REAPRESENTA;
var COUNT:word;
begin
J.LOCATE(1,1);
if succ(MANY)=INFOCUS then        { depois ultimo elemento ??? }
   INFOCUS:=1;                    { primeiro elemento }

if INFOCUS=0 then                 { antes primeiro elemento    }
   INFOCUS:=MANY;                 { ultimo elemento            }

if FIRSTVISIBLE<1 then         { primeiro elemento visivel nao pode ser }
   FIRSTVISIBLE:=1;            { menor que 1 }

if FIRSTVISIBLE>MANY then      { primeiro elemento visivel nao pode estar }
   FIRSTVISIBLE:=MANY-pred(J.GETLIN); { alem do ultimo }

if INFOCUS<FIRSTVISIBLE then   { elemento realcado nao pode estar fora  }
   FIRSTVISIBLE:=INFOCUS;      { da janela }

if INFOCUS>FIRSTVISIBLE+pred(J.GETLIN) then
   FIRSTVISIBLE:=INFOCUS-pred(J.GETLIN);


for COUNT:=FIRSTVISIBLE to FIRSTVISIBLE+pred(J.GETLIN) do
    begin
    if COUNT<=MANY then
       begin
       if INFOCUS=COUNT then
          begin
          J.RDevOut(GETSTRING(LISTA.GET(COUNT)));
          ClrEOL;
          end
       else
          begin
          J.DevOut(GETSTRING(LISTA.GET(COUNT)));
          ClrEOL;
          end;
       end;

    if WhereY<>J.GETLIN then
       begin
       writeln;
       J.EndNormal;
       end;

    end;
end;

destructor TLChoice.DONE;
begin
end;

procedure TLChoice.P_UP_KEY;
begin
dec(INFOCUS);
end;

procedure TLChoice.P_DOWN_KEY;
begin
inc(INFOCUS);
end;

function TLChoice.RUN(START:word):word;
var RESULT:word;
begin
INFOCUS:=START;
while not(WantToQuit) do
      begin
      REAPRESENTA;
      P_LeTecla;
      P_ExecutaTecla;
      end;
RUN:=INFOCUS;
end;

procedure TLChoice.P_ENTER_KEY;
begin
WantToQuit:=true;
CS:=Normal;
end;

procedure TLChoice.P_ESC_KEY;
begin
WantToQuit:=true;
CS:=Esc;
end;

function TLChoice.GETCS:CodigoSaida;
{ retorna codigo de saida }
begin
GETCS:=CS;
end;




begin
MaxLin:=Hi(WindMax)+1;
MaxCol:=Lo(WindMax)+1;
end.