Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
665 lines (615 sloc) 12.8 KB
{CRIPTO VERSAO 1.1}
USES CRT,DOS,jogos;
TYPE
CONJ= RECORD
C: CHAR;
F,K: BOOLEAN;
END;
CONJ2= RECORD
N1,N2: INTEGER;
END;
NOME= STRING[20];
REG= RECORD
BM,BS,BP: INTEGER;
RT,RP: NOME;
END;
RECORDES= ARRAY [1..3] OF REG;
CODIGO= ARRAY [0..9] OF CONJ;
TABELA= ARRAY [1..10] OF CONJ2;
OPCOES = ARRAY [1..15] OF STRING[80];
TIPOS= (OPSOMA,OPSUB,OPMUL);
CONST
UP=#72;
DOWN=#80;
LEFT=#75;
RIGHT=#77;
CR=#13;
ESC=#27;
ESPACO=#32;
MENU1: OPCOES= ('SOMA','SUBTRACAO','MULTIPLICACAO',
'','','','','','','','','','','','');
M1=3;
MENU2: OPCOES= ('SIM','NAO','','','','','','','','','','','','','');
M2=2;
INT=$1C;
VAR
ER,PONT,LS,MIN,SEG,TAM,US,N1,N2: INTEGER;
C: CODIGO;
TAB: TABELA;
VENCEU,GAMEOVER: BOOLEAN;
ANTIGO: POINTER;
REC: RECORDES;
ATUAL: TIPOS;
PROCEDURE WRITEXY (X,Y: INTEGER; S: STRING);
BEGIN
GOTOXY (X,Y);
WRITE (S);
END;
PROCEDURE SETNORMAL;
BEGIN
TEXTCOLOR (LIGHTGRAY);
TEXTBACKGROUND (BLACK);
END;
PROCEDURE SETINVERSE;
BEGIN
TEXTCOLOR (BLACK);
TEXTBACKGROUND (LIGHTGRAY);
END;
PROCEDURE TIMER; INTERRUPT;
VAR
SAVX,SAVY,SAVC: INTEGER;
T: STRING[3];
H,M,S,D: WORD;
BEGIN
GETTIME (H,M,S,D);
IF S<>LS THEN BEGIN
SAVX:=WHEREX;
SAVY:=WHEREY;
SAVC:=TEXTATTR;
LS:=S;
INC (SEG);
IF SEG=60 THEN BEGIN
SEG:=0;
INC (MIN);
END;
SETINVERSE;
STR (MIN:2,T);
WRITEXY (47,22,T);
STR (SEG:2,T);
WRITE (':',T);
TEXTATTR:=SAVC;
GOTOXY (SAVX,SAVY);
END;
END;
PROCEDURE LIGAINT;
BEGIN
SETINTVEC ($1C,ADDR (TIMER));
END;
PROCEDURE DESLINT;
BEGIN
SETINTVEC ($1C,ANTIGO);
END;
PROCEDURE WAITFORKEY;
VAR
T: CHAR;
BEGIN
T:=READKEY;
IF T=#0 THEN T:=READKEY;
END;
PROCEDURE INITCODIGO;
VAR
N: INTEGER;
FUNCTION SORTEIO: CHAR;
VAR
X: INTEGER;
T: CHAR;
B: BOOLEAN;
BEGIN
X:=RANDOM (26);
T:=CHR (X+65);
B:=FALSE;
IF N>0 THEN BEGIN
FOR X:=0 TO N DO
IF C[X].C=T THEN B:=TRUE;
IF B THEN SORTEIO:=SORTEIO
ELSE SORTEIO:=T;
END ELSE SORTEIO:=T;
END;
BEGIN
RANDOMIZE;
FOR N:=0 TO 9 DO BEGIN
C[N].C:=SORTEIO;
C[N].F:=FALSE;
C[N].K:=FALSE;
END;
END;
FUNCTION S (C: CHAR;N: BYTE): STRING;
VAR
CT: BYTE;
T: STRING;
BEGIN
T:='';
IF N>0 THEN FOR CT:=1 TO N DO T:=T+C;
S:=T;
END;
PROCEDURE JANELA (X1,Y1,X2,Y2,BACK,FRONT: BYTE);
VAR CONTADOR: BYTE;
TEMP: STRING;
BEGIN
TEXTCOLOR (FRONT);
TEXTBACKGROUND (BACK);
FOR CONTADOR:=Y1 TO Y2 DO BEGIN
GOTOXY (X1,CONTADOR);
WRITE (S (ESPACO,X2-X1));
END;
IF (X2-X1-1)>40 THEN
TEMP:=S (#196,X2-X1-31)+S (#196,30)
ELSE
TEMP:=S (#196,X2-X1-1);
GOTOXY (X1,Y1);
WRITE (#218,TEMP,#191);
FOR CONTADOR:=Y1+1 TO Y2-1 DO BEGIN
GOTOXY (X1,CONTADOR);
WRITE (#179);
GOTOXY (X2,CONTADOR);
WRITE (#179);
END;
GOTOXY (X1,Y2);
WRITE (#192,TEMP,#217);
END;
FUNCTION CENTRALIZA (TEXTO: STRING): INTEGER;
BEGIN
CENTRALIZA:=TRUNC (40-LENGTH (TEXTO)/2);
END;
FUNCTION MENU (ITENS: OPCOES; Y,TOT: INTEGER): INTEGER;
VAR TEMP,MAXX,CONT: INTEGER;
TECLA: CHAR;
BEGIN
MAXX:=0;
FOR CONT:=1 TO 10 DO
IF LENGTH (ITENS[CONT])>MAXX THEN MAXX:=LENGTH (ITENS[CONT]);
JANELA (TRUNC (40-MAXX/2)-3,Y,TRUNC (40+MAXX/2)+2,Y+1+TOT,BLACK,LIGHTGRAY);
TEXTCOLOR (LIGHTGRAY);
FOR CONT:=1 TO TOT DO BEGIN
GOTOXY (CENTRALIZA (ITENS[CONT]),Y+CONT);
WRITE (ITENS[CONT]);
END;
CONT:=1;
TEMP:=1;
REPEAT
TEXTBACKGROUND (LIGHTGRAY);
TEXTCOLOR (BLACK);
GOTOXY (TRUNC (40-MAXX/2)-1,Y+CONT);
WRITE (S (ESPACO,MAXX+2));
GOTOXY (CENTRALIZA (ITENS[CONT]),Y+CONT);
WRITE (ITENS[CONT]);
TECLA:=READKEY;
IF TECLA=ESC THEN BEGIN
MENU:=0;
EXIT;
END;
IF TECLA=#0 THEN CASE READKEY OF
UP: IF CONT>1 THEN TEMP:=CONT-1;
DOWN: IF CONT<TOT THEN TEMP:=CONT+1;
END;
IF TEMP<>CONT THEN BEGIN
TEXTBACKGROUND (BLACK);
TEXTCOLOR (LIGHTGRAY);
GOTOXY (TRUNC (40-MAXX/2)-1,Y+CONT);
WRITE (S (ESPACO,MAXX+2));
GOTOXY (CENTRALIZA (ITENS[CONT]),Y+CONT);
WRITE (ITENS[CONT]);
CONT:=TEMP;
END;
UNTIL TECLA=CR;
MENU:=CONT;
END;
PROCEDURE RECEBE (TAM,X,Y: INTEGER; VAR STX: NOME);
VAR
TC: CHAR;
COUNT: BYTE;
BEGIN
SETINVERSE;
GOTOXY (X,Y);
WRITE (S (#32,TAM));
CURSOR (TRUE);
STX:='';
COUNT:=0;
GOTOXY (X,Y);
REPEAT
TC:=READKEY;
WHILE (TC=#0) DO BEGIN
TC:=READKEY;
TC:=READKEY;
END;
IF (ORD(TC)>31) AND (ORD(TC)<127) AND (LENGTH(STX)<TAM) THEN BEGIN
INC (COUNT);
STX:=STX+UPCASE(TC);
WRITE (UPCASE(TC));
END;
IF (TC=#8) AND (LENGTH(STX)>0) THEN BEGIN
STX:=COPY (STX,1,LENGTH(STX)-1);
GOTOXY (X,Y);
WRITE (S (#32,TAM));
GOTOXY (X,Y);
WRITE (STX);
END;
IF TC=#27 THEN BEGIN
STX:='ANONIMO';
CURSOR (FALSE);
EXIT;
END;
UNTIL TC=#13;
CURSOR (FALSE);
END;
PROCEDURE IMPSTATUS (SS: STRING; Y: BYTE);
BEGIN
GOTOXY (1,Y);
SETINVERSE;
WRITE (S (ESPACO,80));
GOTOXY (40-LENGTH (SS) DIV 2,Y);
WRITE (SS);
END;
PROCEDURE CLEARSTATUS (Y: BYTE; B: BOOLEAN);
BEGIN
GOTOXY (1,Y);
IF B THEN SETINVERSE ELSE SETNORMAL;
WRITE (S (ESPACO,80));
END;
PROCEDURE INITNUMEROS;
VAR
S,N: INTEGER;
BEGIN
RANDOMIZE;
FOR N:=1 TO 10 DO BEGIN
TAB[N].N1:=RANDOM (10000);
IF ATUAL=OPMUL THEN TAB[N].N2:=RANDOM (99)+1
ELSE TAB[N].N2:=RANDOM (10000);
IF (ATUAL=OPSUB) AND (TAB[N].N2>TAB[N].N1) THEN BEGIN
S:=TAB[N].N1;
TAB[N].N1:=TAB[N].N2;
TAB[N].N2:=S;
END;
END;
END;
PROCEDURE WNUMERO (X,Y,NUM: LONGINT; B: BOOLEAN);
VAR
S: STRING;
L,N,T,CODE: INTEGER;
BEGIN
STR (NUM,S);
L:=LENGTH (S);
FOR N:=1 TO L DO BEGIN
SETNORMAL;
GOTOXY (X+6-N,Y);
VAL (COPY (S,L-N+1,1),T,CODE);
IF NOT(B) THEN IF NOT (C[T].F) THEN WRITE (C[T].C) ELSE BEGIN
TEXTCOLOR (WHITE);
WRITE (T);
END;
IF B AND NOT(C[T].F) THEN C[T].K:=TRUE;
END;
SETNORMAL;
END;
PROCEDURE SOMA (X,Y,N1,N2: INTEGER; B: BOOLEAN);
BEGIN
SETNORMAL;
WNUMERO (X,Y,N1,B);
WNUMERO (X,Y+1,N2,B);
WNUMERO (X,Y+3,N1+N2,B);
IF NOT(B) THEN BEGIN
WRITEXY (X,Y+1,'+');
WRITEXY (X,Y+2,S (#196,6));
END;
END;
PROCEDURE SUB (X,Y,N1,N2: INTEGER; B: BOOLEAN);
BEGIN
SETNORMAL;
WNUMERO (X,Y,N1,B);
WNUMERO (X,Y+1,N2,B);
WNUMERO (X,Y+3,N1-N2,B);
IF NOT (B) THEN BEGIN
WRITEXY (X,Y+1,'-');
WRITEXY (X,Y+2,S (#196,6));
END;
END;
PROCEDURE MUL (X,Y,N1,N2: INTEGER; B: BOOLEAN);
BEGIN
SETNORMAL;
WNUMERO (X,Y,N1,B);
WNUMERO (X,Y+1,N2,B);
WNUMERO (X,Y+3,LONGINT(N1)*(N2 MOD 10),B);
WNUMERO (X-1,Y+4,LONGINT(N1)*(N2 DIV 10),B);
WNUMERO (X,Y+6,LONGINT(N1)*N2,B);
IF NOT (B) THEN BEGIN
WRITEXY (X,Y+1,'x');
WRITEXY (X,Y+2,S (#196,6));
WRITEXY (X,Y+5,S (#196,6));
END;
END;
PROCEDURE IMPSOLUCAO;
VAR
N: INTEGER;
BEGIN
FOR N:=0 TO 9 DO BEGIN
GOTOXY (40,N+10);
WRITE (C[N].C,'-',N);
END;
END;
PROCEDURE INITVIDEO;
BEGIN
CURSOR (FALSE);
SETNORMAL;
CLRSCR;
IMPSTATUS ('CRIPTOARITMETICA - BY RICARDO BITTENCOURT',1);
CLEARSTATUS (24,TRUE);
END;
PROCEDURE TESTE;
VAR
N: INTEGER;
BEGIN
FOR N:=0 TO 9 DO C[N].F:=TRUE;
GOTOXY (10,20);
WRITE (N1,'-',N2,'-');
END;
PROCEDURE FILA (B: BOOLEAN);
VAR
N: INTEGER;
BEGIN
FOR N:=1 TO US DO CASE ATUAL OF
OPSOMA: SOMA ((80-TAM) DIV 2+(N-1)*7,10,TAB[N].N1,TAB[N].N2,B);
OPSUB: SUB ((80-TAM) DIV 2+(N-1)*7,10,TAB[N].N1,TAB[N].N2,B);
OPMUL: MUL ((80-TAM) DIV 2+(N-1)*7,10,TAB[N].N1,TAB[N].N2,B);
END;
END;
FUNCTION READCHAR: CHAR;
VAR
T: CHAR;
BEGIN
CURSOR (TRUE);
REPEAT
T:=UPCASE(READKEY);
WHILE T=#0 DO BEGIN
T:=READKEY;
T:=READKEY;
END;
UNTIL T IN ['A'..'Z',ESC,CR];
CURSOR (FALSE);
IF T IN ['A'..'Z'] THEN WRITE (T);
READCHAR:=T;
END;
FUNCTION READNUMBER: INTEGER;
VAR
T: CHAR;
A,CODE: INTEGER;
BEGIN
CURSOR (TRUE);
REPEAT
T:=READKEY;
WHILE T=#0 DO BEGIN
T:=READKEY;
T:=READKEY;
END;
UNTIL T IN ['0'..'9'];
VAL (T,A,CODE);
CURSOR (FALSE);
READNUMBER:=A;
WRITE (T);
END;
PROCEDURE MENSAGEM (S: STRING; Y: INTEGER);
BEGIN
IMPSTATUS (S,Y);
WAITFORKEY;
CLEARSTATUS (Y,FALSE);
END;
PROCEDURE LISTA;
VAR
N: INTEGER;
BEGIN
FOR N:=0 TO 9 DO BEGIN
GOTOXY (50,10+N);
WRITE (N,'-',C[N].C,'-',C[N].F,'-',C[N].K);
END;
END;
FUNCTION PEGATUAL: INTEGER;
BEGIN
CASE ATUAL OF
OPSOMA: PEGATUAL:=1;
OPSUB: PEGATUAL:=2;
OPMUL: PEGATUAL:=3;
END;
END;
PROCEDURE IMPRECORDES;
VAR
N: INTEGER;
BEGIN
CLEARSTATUS (23,TRUE);
CLEARSTATUS (24,TRUE);
N:=PEGATUAL;
WITH REC[N] DO BEGIN
WRITEXY (1,23,'MELHOR TEMPO: ');
WRITE (BM:2,':',BS:2,' <- ',RT);
WRITEXY (1,24,'MELHOR PONTUACAO: ');
WRITE (BP:2,' <- ',RP);
END;
END;
PROCEDURE ATUALIZA;
VAR
T: STRING[3];
BEGIN
SETINVERSE;
CLEARSTATUS (22,TRUE);
GOTOXY (60,22);
WRITE ('PONTOS: ',PONT);
GOTOXY (40,22);
WRITE ('TEMPO: ');
STR (MIN:2,T);
WRITE (T);
STR (SEG:2,T);
WRITE (':',T);
GOTOXY (1,22);
END;
PROCEDURE JOGA;
VAR
T: CHAR;
N,A: INTEGER;
PROCEDURE CHECA;
VAR
B: BOOLEAN;
N: INTEGER;
BEGIN
C[A].F:=TRUE;
C[A].K:=FALSE;
B:=FALSE;
INC (PONT,100);
FOR N:=0 TO 9 DO IF C[N].K THEN B:=TRUE;
IF NOT (B) THEN BEGIN
GAMEOVER:=TRUE;
VENCEU:=TRUE;
END;
END;
PROCEDURE PROCESSA;
BEGIN
CASE T OF
ESC: GAMEOVER:=TRUE;
CR: IF US<10 THEN BEGIN
INC (TAM,7);
INC (US);
FILA (TRUE);
JANELA (1,2,80,21,BLACK,BLACK);
IMPRECORDES;
DEC (PONT,100);
END;
END;
END;
BEGIN
FILA (TRUE);
IMPRECORDES;
REPEAT
DESLINT;
FILA (FALSE);
LIGAINT;
ATUALIZA;
WRITE ('LETRA: ');
T:=READCHAR;
IF T IN [ESC,CR] THEN PROCESSA ELSE BEGIN
A:=10;
FOR N:=0 TO 9 DO IF T=C[N].C THEN A:=N;
IF A=10 THEN MENSAGEM ('ESTA LETRA NAO PODE SER SUBSTITUIDA',2) ELSE
IF NOT(C[A].K) THEN MENSAGEM ('ESTA LETRA NAO PODE SER SUBSTITUIDA',2)
ELSE BEGIN
WRITE (' <- NUMERO: ');
A:=READNUMBER;
IF C[A].C=T THEN CHECA ELSE BEGIN
MENSAGEM ('SUBSTITUICAO ERRADA',2);
DEC (PONT,50);
INC (ER);
IF ER>2 THEN GAMEOVER:=TRUE;
END;
END;
END;
UNTIL GAMEOVER;
IF US=1 THEN INC (PONT,100);
DESLINT;
END;
PROCEDURE INITVARS;
BEGIN
GAMEOVER:=FALSE;
VENCEU:=FALSE;
TAM:=6;
US:=1;
MIN:=0;
SEG:=0;
LS:=-1;
PONT:=0;
ER:=0;
END;
PROCEDURE FINAL;
VAR
F: FILE OF RECORDES;
BEGIN
CURSOR (TRUE);
ASSIGN (F,'CRIPTO.HIG');
REWRITE (F);
WRITE (F,REC);
CLOSE (F);
DESLINT;
SETNORMAL;
CLRSCR;
WRITELN ('CRIPTOARITMETICA - Versao 1.1');
WRITELN ('Autor: Ricardo Bittencourt Vidigal Leitao');
WRITELN ('Data: 20/07/94');
END;
PROCEDURE ACABOU;
VAR
N: INTEGER;
BEGIN
FILA (FALSE);
ATUALIZA;
IF VENCEU THEN BEGIN
IMPSTATUS ('VOCE VENCEU',2);
N:=PEGATUAL;
IF ((SEG<REC[N].BS) AND (MIN=REC[N].BM)) OR (MIN<REC[N].BM) THEN BEGIN
REC[N].BM:=MIN;
REC[N].BS:=SEG;
IMPSTATUS ('E CONSEGUIU BATER O RECORDE',3);
WRITEXY (1,23,'MELHOR TEMPO: ');
WRITE (REC[N].BM:2,':',REC[N].BS:2,' <- ');
RECEBE (20,WHEREX,23,REC[N].RT);
END;
IF PONT>REC[N].BP THEN BEGIN
REC[N].BP:=PONT;
IMPSTATUS ('E CONSEGUIU BATER O RECORDE',3);
WRITEXY (1,24,'MELHOR PONTUACAO: ');
WRITE (REC[N].BP:2,' <- ');
RECEBE (20,WHEREX,24,REC[N].RP);
END;
END ELSE IMPSTATUS ('GAME OVER',2);
END;
PROCEDURE ESCOLHA;
VAR
M: INTEGER;
BEGIN
REPEAT
M:=MENU (MENU1,10,M1);
ATUAL:=TIPOS (M-1);
UNTIL M<>0;
INITVIDEO;
END;
PROCEDURE LIMPA (VAR R: REG);
BEGIN
R.BM:=99;
R.BS:=0;
R.BP:=0;
R.RT:='ANONIMO';
R.RP:=R.RT;
END;
PROCEDURE REALINIT;
VAR
SR: SEARCHREC;
N: INTEGER;
F: FILE OF RECORDES;
BEGIN
GETINTVEC ($1C,ANTIGO);
FINDFIRST ('CRIPTO.HIG',0,SR);
IF DOSERROR<>18 THEN BEGIN
ASSIGN (F,'CRIPTO.HIG');
RESET (F);
READ (F,REC);
CLOSE (F);
END ELSE FOR N:=1 TO 3 DO LIMPA (REC[N]);
END;
BEGIN
REALINIT;
REPEAT
INITVIDEO;
INITCODIGO;
ESCOLHA;
INITNUMEROS;
INITVARS;
JOGA;
ACABOU;
IMPSTATUS ('JOGAR DE NOVO',21);
UNTIL MENU (MENU2,17,M2)<>1;
FINAL;
END.