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.