Ir ao conteúdo
  • Cadastre-se

[Pascal] Projeto UNIT de utilidades.


Simon Viegas

Posts recomendados

  • Membro VIP

Olá,

Hoje não estou muito bom com as palavras, mas vou resumir mais ou menos a proposta.

Criar uma (ou mais) UNIT(s) que contenham alguns procedimentos notáveis.

Basicamente a ideia é coletar e agrupar idéias, em units, para facilitar o "reuso"...

Em fim, vamos para prática:

Comecei a desenvolver algumas coisas..

Unit CRT_FCH

UNIT CRT_FCH; {versão 0.001}

INTERFACE {tudo que é visto pelas "estruturas" que o carregar!!!}

{ *** CONSTANTES UNIVERSAIS ***}
CONST
ENTER = #13;
BACKSPACE = #08;
ESC = #27;

{ *** Sobre a UNIT ***}
procedure About;
{ *** Ajuda sobre essa Unit ***}
procedure HELP_CRT_FCH;
{ *** Da um pause no programa *** }
procedure Pause;
{ *** Formata o texto e a tela do Pascal *** }
procedure Formatar(corTexto, corFundo:byte);
{ *** ler um password *** }
function ReadPWD(tamanho:byte):string;
{ *** ler um password (e desce uma linha) *** }
function ReadPWDln(tamanho:byte):string;


{ *** EM DESENVOLVIMENTO *** }

(*
.
.
.
{ *** Imprime o texto centralizado *** }
procedure WriteCet(x,y:byte; msn:string);
{ *** Imprime o texto colorido *** }
procedure WritePic(corT, corF:byte; msn:string);
.
.
.
*)



IMPLEMENTATION {tudo que é visto EXCLUSIVAMENTE pela propria unit (e as
implementacoes das units declaradas na interface}
uses
CRT;

{ *** Sobre a UNIT ***}
procedure About;
begin
WriteLn;
WriteLn(' Unit obtida no FCH - Forum do Clube do Hardware');
WriteLn;
WriteLn(' Name : CRT_FCH ');
WriteLn(' Author : Simon Viegas, XXXXXX, XXXXX ');
WriteLn(' Description: Unit com algumas funcionalidades ');
WriteLn(' Date : 09/08/09 14:46 ');
WriteLn(' Copyright : Forum Clube do Hardware ');
WriteLn;
WriteLn(' EXECUTE O COMANDO HELP_CRT_FCH para abrir o Help da Unit');
WriteLn;
end;

{ *** Ajuda sobre essa Unit ***}
procedure HELP_CRT_FCH;
begin
WriteLn('{ *** Sobre a UNIT ***}');
WriteLn('procedure About;');
WriteLn('{ *** Ajuda sobre essa Unit ***}');
WriteLn('procedure HELP_CRT_FCH;');
WriteLn('{ *** Da um pause no programa *** }');
WriteLn('procedure Pause;');
WriteLn('{ *** Formata o texto e a tela do Pascal *** }');
WriteLn('procedure Formatar(corTexto, corFundo:byte);');
WriteLn('{ *** ler um password *** }');
WriteLn('function ReadPWD(tamanho:byte):string;');
WriteLn('{ *** ler um password (e desce uma linha) *** }');
WriteLn('function ReadPWDln(tamanho:byte):string;');
pause;
end;

{ *** Da um pause no prgrama *** }
procedure pause;
begin
WriteLn;
TextAttr:=TextAttr+Blink;
Write('Precione qualquer tecla para continuar');
TextAttr:=TextAttr-Blink;
ReadKey;
end;

{ *** Formata o texto e a tela do Pacal *** }
procedure formatar(corTexto, corFundo:byte);
begin
TextColor(corTexto);
TextBackGround(corFundo);
end;

{ *** ler um password *** }
function readPWD(tamanho:byte):string;
type
T_Senha = Array [1..255] of Char;
var
caractere :char; {caractere lido pelo usuario}
cont :byte; {contador de teclas já lidas}
senha_tmp :string;
v_senha :T_Senha; {a senha em si}
i :byte; {usado no for}
begin
cont:= 0; {zera o contador de caracteres já usados (é necessário)}
Repeat
caractere:=readkey; {ler a tecla digitada}
case UpCase(caractere) of {UpCase retorna o caractere em maiusculo}
{caso seja um alfanumérico}
'A' .. 'Z',
'0' .. '9' : begin
if cont<tamanho then
begin
inc(cont); {o mesmo que cont:= cont + 1;}
v_senha[cont]:= caractere; {armazena o caracteres}
write('*'); {imprime um "*" (ocultando a senha)}
end;
end;
{caso queira apagar uma linha}
BACKSPACE : begin
if cont>=1 then
begin
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
write(' '); {"apaga" um caractere}
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
dec(cont); {atualiza o contador} {dec(x) = x:=x-1;}
end;
end;
end;{fim case}
Until(caractere = ENTER){ or (cont > max)};
{retorna a senha via function}
senha_tmp:='';
For i:= 1 to cont do
senha_tmp:=senha_tmp+v_senha[i];
readPWD:=senha_tmp;
end;

{ *** ler um password (e desce uma linha) *** }
function ReadPWDln(tamanho:byte):string;
begin
ReadPWDln:=ReadPWD(tamanho);
WriteLn;
end;

begin
ClrScr; {limpa a tela}
Formatar(White,Black); {formata a tela}
About; {exibe o "sobre" da unit}
Pause; {da uma pause}
ClrScr; {limpa a tela (logo após o programa que carregar essa UNIT será 'iniciado'}
end.

Aqui um programa para testar o "PassWord"

PROGRAM testeUnitPassword;
(*
Name : Teste de Login
Author : Simon Viegas, XXXXXX, XXXXX
Description: Programa que testa a unit
Date : 09/08/09 14:46
Copyright : Forum Clube do Hardware
*)

USES
CRT, {biblioteca com comandos extas}
CRT_FCH;

CONST
TamanhoSenha = 8;
{ *** Tela de Login ***}
procedure telaLogin(x,y:byte);
var
x1, {coordenada X}
y1 : byte; {coordenada Y}
usuario : String; {login do usuario}
senha : String; {senha do usuario}

begin
GotoXY(x,y);
Write(' ********* LOGIN DO USUÁRIO ********* ');
GotoXY(x,y+3);
Write(' LOGIN : ');
x1:=WhereX; y1:=WhereY; {copia a posicao para onde vai o LOGIN}
GotoXY(x,y+4);
Write(' SENHA (max ',TamanhoSenha:3,') : ');
GotoXY(x1,y1);
ReadLn(usuario);
GotoXY(x1,y1+1);
senha:=ReadPWDln(TamanhoSenha); {unit CRT_FCR (Forum Clube do Hardware}
Writeln;
Writeln('Senha digitada ',senha);
end;

CONST
{posição onda vai ficar a tela de login}
x=10; {coordenada X}
y=5; {coordenada Y}


BEGIN
{preparando o layout}
Formatar(Yellow,Black); {unit CRT_FCH}
ClrScr;

WriteLn;
WriteLn;
{imprimindo a tela e lendo dados}
telaLogin(x,y);
ReadKey;
END.

Em fim, o que vocês acham da ideia....

Obs.: Os código que enviei foram só como base, tudo pode ser modificado/melhorado...

Fico no aguardo de sugestões.

Abraços

Link para o comentário
Compartilhar em outros sites

Em 14/08/2009 às 14:11, Simon Viegas disse:

 

Spoiler

Olá,

Hoje não estou muito bom com as palavras, mas vou resumir mais ou menos a proposta.

Basicamente a ideia é coletar e agrupar idéias, em units, para facilitar o "reuso"...

Em fim, vamos para prática:

Comecei a desenvolver algumas coisas..

Unit CRT_FCH



INTERFACE {tudo que é visto pelas "estruturas" que o carregar!!!}

{ *** CONSTANTES UNIVERSAIS ***}
CONST
ENTER = #13;
BACKSPACE = #08;
ESC = #27;

{ *** Sobre a UNIT ***}
procedure About;
{ *** Ajuda sobre essa Unit ***}
procedure HELP_CRT_FCH;
{ *** Da um pause no programa *** }
procedure Pause;
{ *** Formata o texto e a tela do Pascal *** }
procedure Formatar(corTexto, corFundo:byte);
{ *** ler um password *** }
function ReadPWD(tamanho:byte):string;
{ *** ler um password (e desce uma linha) *** }
function ReadPWDln(tamanho:byte):string;


{ *** EM DESENVOLVIMENTO *** }

(*
.
.
.
{ *** Imprime o texto centralizado *** }
procedure WriteCet(x,y:byte; msn:string);
{ *** Imprime o texto colorido *** }
procedure WritePic(corT, corF:byte; msn:string);
.
.
.
*)



IMPLEMENTATION {tudo que é visto EXCLUSIVAMENTE pela propria unit (e as
implementacoes das units declaradas na interface}
uses
CRT;

{ *** Sobre a UNIT ***}
procedure About;
begin
WriteLn;
WriteLn(' Unit obtida no FCH - Forum do Clube do Hardware');
WriteLn;
WriteLn(' Name : CRT_FCH ');
WriteLn(' Author : Simon Viegas, XXXXXX, XXXXX ');
WriteLn(' Description: Unit com algumas funcionalidades ');
WriteLn(' Date : 09/08/09 14:46 ');
WriteLn(' Copyright : Forum Clube do Hardware ');
WriteLn;
WriteLn(' EXECUTE O COMANDO HELP_CRT_FCH para abrir o Help da Unit');
WriteLn;
end;

{ *** Ajuda sobre essa Unit ***}
procedure HELP_CRT_FCH;
begin
WriteLn('{ *** Sobre a UNIT ***}');
WriteLn('procedure About;');
WriteLn('{ *** Ajuda sobre essa Unit ***}');
WriteLn('procedure HELP_CRT_FCH;');
WriteLn('{ *** Da um pause no programa *** }');
WriteLn('procedure Pause;');
WriteLn('{ *** Formata o texto e a tela do Pascal *** }');
WriteLn('procedure Formatar(corTexto, corFundo:byte);');
WriteLn('{ *** ler um password *** }');
WriteLn('function ReadPWD(tamanho:byte):string;');
WriteLn('{ *** ler um password (e desce uma linha) *** }');
WriteLn('function ReadPWDln(tamanho:byte):string;');
pause;
end;

{ *** Da um pause no prgrama *** }
procedure pause;
begin
WriteLn;
TextAttr:=TextAttr+Blink;
Write('Precione qualquer tecla para continuar');
TextAttr:=TextAttr-Blink;
ReadKey;
end;

{ *** Formata o texto e a tela do Pacal *** }
procedure formatar(corTexto, corFundo:byte);
begin
TextColor(corTexto);
TextBackGround(corFundo);
end;

{ *** ler um password *** }
function readPWD(tamanho:byte):string;
type
T_Senha = Array [1..255] of Char;
var
caractere :char; {caractere lido pelo usuario}
cont :byte; {contador de teclas já lidas}
senha_tmp :string;
v_senha :T_Senha; {a senha em si}
i :byte; {usado no for}
begin
cont:= 0; {zera o contador de caracteres já usados (é necessário)}
Repeat
caractere:=readkey; {ler a tecla digitada}
case UpCase(caractere) of {UpCase retorna o caractere em maiusculo}
{caso seja um alfanumérico}
'A' .. 'Z',
'0' .. '9' : begin
if cont<tamanho then
begin
inc(cont); {o mesmo que cont:= cont + 1;}
v_senha[cont]:= caractere; {armazena o caracteres}
write('*'); {imprime um "*" (ocultando a senha)}
end;
end;
{caso queira apagar uma linha}
BACKSPACE : begin
if cont>=1 then
begin
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
write(' '); {"apaga" um caractere}
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
dec(cont); {atualiza o contador} {dec(x) = x:=x-1;}
end;
end;
end;{fim case}
Until(caractere = ENTER){ or (cont > max)};
{retorna a senha via function}
senha_tmp:='';
For i:= 1 to cont do
senha_tmp:=senha_tmp+v_senha;
readPWD:=senha_tmp;
end;

{ *** ler um password (e desce uma linha) *** }
function ReadPWDln(tamanho:byte):string;
begin
ReadPWDln:=ReadPWD(tamanho);
WriteLn;
end;

begin
ClrScr; {limpa a tela}
Formatar(White,Black); {formata a tela}
About; {exibe o "sobre" da unit}
Pause; {da uma pause}
ClrScr; {limpa a tela (logo após o programa que carregar essa UNIT será 'iniciado'}
end.


UNIT CRT_FCH; {versão 0.001}

Aqui um programa para testar o "PassWord"


(*
Name : Teste de Login
Author : Simon Viegas, XXXXXX, XXXXX
Description: Programa que testa a unit
Date : 09/08/09 14:46
Copyright : Forum Clube do Hardware
*)

USES
CRT, {biblioteca com comandos extas}
CRT_FCH;

CONST
TamanhoSenha = 8;
{ *** Tela de Login ***}
procedure telaLogin(x,y:byte);
var
x1, {coordenada X}
y1 : byte; {coordenada Y}
usuario : String; {login do usuario}
senha : String; {senha do usuario}

begin
GotoXY(x,y);
Write(' ********* LOGIN DO USUÁRIO ********* ');
GotoXY(x,y+3);
Write(' LOGIN : ');
x1:=WhereX; y1:=WhereY; {copia a posicao para onde vai o LOGIN}
GotoXY(x,y+4);
Write(' SENHA (max ',TamanhoSenha:3,') : ');
GotoXY(x1,y1);
ReadLn(usuario);
GotoXY(x1,y1+1);
senha:=ReadPWDln(TamanhoSenha); {unit CRT_FCR (Forum Clube do Hardware}
Writeln;
Writeln('Senha digitada ',senha);
end;

CONST
{posição onda vai ficar a tela de login}
x=10; {coordenada X}
y=5; {coordenada Y}


BEGIN
{preparando o layout}
Formatar(Yellow,Black); {unit CRT_FCH}
ClrScr;

WriteLn;
WriteLn;
{imprimindo a tela e lendo dados}
telaLogin(x,y);
ReadKey;
END.


PROGRAM testeUnitPassword;

Em fim, o que vocês acham da ideia....

Obs.: Os código que enviei foram só como base, tudo pode ser modificado/melhorado...

Fico no aguardo de sugestões.

Abraços

 


{ *** Da um pause no prgrama *** }
procedure pause;
  begin
  WriteLn;
  TextAttr:=TextAttr+Blink;
  Write('Precione qualquer tecla para continuar');
  TextAttr:=TextAttr-Blink;
  ReadKey;
  end;

 

 

Olá!

Legal essa Unit...

:confused:

TextAttr:=TextAttr+Blink;

O que significa?

TextAttr é uma variável?

Obs.: Tenho que descobrir como fazer funcionar Units no Dev-Pascal!!!:lol:

Link para o comentário
Compartilhar em outros sites

  • Membro VIP
Olá!

Legal essa Unit...

:confused:

TextAttr:=TextAttr+Blink;

O que significa?

TextAttr é uma variável?

Obs.: Tenho que descobrir como fazer funcionar Units no Dev-Pascal!!!:lol:

Olá,

Isso, é uma variável que armazena "os atributos do texto". É como se fosse uma combinação do valor do TextColor + TextBackGround (cor do texto e cor do fundo respectivamente).

Essa lógica

TextAttr:=TextAttr+Blink;

eu tinha acabado de inventar... não sei se vai funcionar muito bem em "todas as configurações de cores"...

Mas é mais ou menos isso:

TextAttr:=TextAttr+Blink;

Atritubos atuais = Atributos atuais + fazer piscar

Idealizei mais ou menos isso. Fiz os testes e funcionou (pelo menos no dia, rs).

Segundo o Help do Turbo Pascal 7.1:

(em inglês)

   TextAttr (variable)     (Crt unit)
▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀
Stores currently selected text attributes

The text attributes are normally set through calls to TextColor and
TextBackground.

However, you can also set them by directly storing a value in TextAttr.

Link para o comentário
Compartilhar em outros sites

  • Membro VIP

Adicionei mais alguns comandos...

Esse abaixo foi comentado recetemente aqui no Fórum... é bem legal.

Uma alternativa para o Delay()

{da um delay no pascal em milissegundos}
procedure aguardar(t:real);
function timer:real;
var
hour,
minute,
second,
sec100 :word;
begin
gettime(hour,minute,second,sec100);
{//acho que dá para otimizar essa fórmula abaixo!!!}
timer:=(hour*3600.0+minute*60.0+second)*100.0+1.0*sec100;
end;

var
t1 :real;
begin
t1:=timer;
repeat until timer>t1+(100*t)/1000;
end;

Vide este tópico...

Caso queira limpar uma linha específica.

procedure limparErro(x, y: byte);  {Apagar linha de erro}
begin
gotoXY(x,y); clreol;
gotoXY(x,y);
end;

Neste caso, vai limpar o trecho e vai reposicionar no início de onde foi apagado.

Eu acho que tenho ums comandos legais aqui em casa, mas não estou encontrando...

A medida que for encontrando vou inserindo na Unit..

e aí galera, mas uma sugestão?

Link para o comentário
Compartilhar em outros sites

Em 26/08/2009 às 18:02, Simon Viegas disse:

 

Spoiler
Adicionei mais alguns comandos...

Esse abaixo foi comentado recetemente aqui no Fórum... é bem legal.

Uma alternativa para o Delay()


procedure aguardar(t:real);
function timer:real;
var
hour,
minute,
second,
sec100 :word;
begin
gettime(hour,minute,second,sec100);
{//acho que dá para otimizar essa fórmula abaixo!!!}
timer:=(hour*3600.0+minute*60.0+second)*100.0+1.0*sec100;
end;

var
t1 :real;
begin
t1:=timer;
repeat until timer>t1+(100*t)/1000;
end;


{da um delay no pascal em milissegundos}

Vide este tópico...

Caso queira limpar uma linha específica.


begin
gotoXY(x,y); clreol;
gotoXY(x,y);
end;


procedure limparErro(x, y: byte);  {Apagar linha de erro}

Neste caso, vai limpar o trecho e vai reposicionar no início de onde foi apagado.

Eu acho que tenho ums comandos legais aqui em casa, mas não estou encontrando...

A medida que for encontrando vou inserindo na Unit..

e aí galera, mas uma sugestão?

 

 

Em 26/08/2009 às 18:02, Simon Viegas disse:

 

Spoiler


{da um delay no pascal em milissegundos}
procedure aguardar(t:real);
  function timer:real;
    var
      hour,
      minute,
      second,
      sec100 :word;
    begin
    gettime(hour,minute,second,sec100);
    {//acho que dá para otimizar essa fórmula abaixo!!!}
    timer:=(hour*3600.0+minute*60.0+second)*100.0+1.0*sec100;
    end;

  var
    t1 :real;
  begin
  t1:=timer;
  repeat until timer>t1+(100*t)/1000;
  end;

 

 

Bem,

quanto à linha:

repeat until timer>t1+(100*t)/1000;

Poderíamos escrever:

repeat until timer>t1+t/10;

Uma outra opção seria fazer

timer:=(hour*3600.0+minute*60.0+second)*1000.0+10.0*sec100;

//transformar em milissegundos em vez de centésimos de segundos... :D

Dessa forma, o laço ficaria:

repeat until timer>t1+t;

 

No Código:

{da um delay no pascal em milissegundos}
procedure aguardar(t:real);
  function timer:real;
    var
      hour,
      minute,
      second,
      sec100 :word;
    begin
    gettime(hour,minute,second,sec100);
    //Converte a hora capturada em milissegundos}
    timer:=(hour*3600.0+minute*60.0+second)*1000.0+10.0*sec100;
    end;

  var
    t1 :real;
  begin
  t1:=timer;
  repeat until timer>t1+t;
  end;

 

 

Link para o comentário
Compartilhar em outros sites

Olá, pessoal!

Tem mais uma função legal, a que calcula a potência de um número para expoentes inteiros:


function Potencia(base: real; expoente: integer): double;
function Modulo(x: integer): Integer;
Begin
Modulo:= x;
if(x<0) then
Modulo:= -Modulo;
End;

Var
i: integer;
Begin
Potencia:= 1;
if(expoente<>0) then Begin
for i:= 1 to Modulo(expoente) do
Potencia:= Potencia *base;
if(expoente<0) then
Potencia:= 1/Potencia;
End;
End;

T+

:)

Link para o comentário
Compartilhar em outros sites

  • 5 meses depois...
  • Membro VIP

Saiu mais uma versão quentinha... tem poucas mudanças, mas já é um avanço.. ^_^

Versão 0.002

Adicionado:

{ *** imprimi texto de modo centralizado ***}

procedure WritCet (texto:string);

{ *** Da um delay no pascal em milissegundos}

procedure Aguardar(t:real);

{ *** Limpa uma linha especifica ***}

procedure LimparLinha(x, y: byte);

{*** Calcula potencia de um numero para expoentes inteiros ***}

function Potencia(base: real; expoente: integer): double;

Dúvidas / Elogios / Críticas / Sugetões é só postar!!!

UNIT CRT_FCH

{$N+} {habilita calculos com double}
UNIT CRT_FCH; {versão 0.002}

INTERFACE {tudo que é visto pelas "estruturas" que o carregar!!!}

{ *** CONSTANTES UNIVERSAIS ***}
CONST
ENTER = #13;
BACKSPACE = #08;
ESC = #27;

{ *** Sobre a UNIT ***}
procedure About;
{ *** Ajuda sobre essa Unit ***}
procedure HELP_CRT_FCH;
{ *** Da um pause no programa *** }
procedure Pause;
{ *** Formata o texto e a tela do Pascal *** }
procedure Formatar(corTexto, corFundo:byte);
{ *** ler um password *** }
function ReadPWD(tamanho:byte):string;
{ *** ler um password (e desce uma linha) *** }
function ReadPWDln(tamanho:byte):string;


[COLOR="Red"]{versao 002}


{ *** imprimi texto de modo centralizado ***}
procedure WritCet (texto:string);
{ *** Da um delay no pascal em milissegundos}
procedure Aguardar(t:real);
{ *** Limpa uma linha especifica ***}
procedure LimparLinha(x, y: byte);
{*** Calcula potencia de um numero para expoentes inteiros ***}
function Potencia(base: real; expoente: integer): double;[/COLOR]


IMPLEMENTATION {tudo que é visto EXCLUSIVAMENTE pela propria unit (e as
implementacoes das units declaradas na interface}
uses
CRT, {carrega comando como ReadKey, TextColor, TextBackGround, ClrScr}
DOS ; {carrega comando como GetTime, GetDate, DateTime}

{ *** Sobre a UNIT ***}
procedure About;
begin
WriteLn;
WriteLn(' Unit obtida no FCH - Forum do Clube do Hardware');
WriteLn;
WriteLn(' Name : CRT_FCH ');
WriteLn(' Author : Simon Viegas, gu_ludo, XXXXX ');
WriteLn(' Description: Unit com algumas funcionalidades ');
WriteLn(' Date : 09/08/09 14:46 ');
WriteLn(' Copyright : Forum Clube do Hardware ');
WriteLn;
WriteLn(' EXECUTE O COMANDO HELP_CRT_FCH para abrir o Help da Unit');
WriteLn;
end;

{ *** Ajuda sobre essa Unit ***}
procedure HELP_CRT_FCH;
begin
WriteLn('{versao001}');
WriteLn('{ *** Sobre a UNIT ***}');
WriteLn('procedure About;');
WriteLn('{ *** Ajuda sobre essa Unit ***}');
WriteLn('procedure HELP_CRT_FCH;');
WriteLn('{ *** Da um pause no programa *** }');
WriteLn('procedure Pause;');
WriteLn('{ *** Formata o texto e a tela do Pascal *** }');
WriteLn('procedure Formatar(corTexto, corFundo:byte);');
WriteLn('{ *** ler um password *** }');
WriteLn('function ReadPWD(tamanho:byte):string;');
WriteLn('{ *** ler um password (e desce uma linha) *** }');
WriteLn('function ReadPWDln(tamanho:byte):string;');
[COLOR="Red"] WriteLn('{versao 002}');
WriteLn('{ *** imprimi texto de modo centralizado ***}');
WriteLn('procedure WritCet (texto:string);');
WriteLn('{ *** Da um delay no pascal em milissegundos}');
WriteLn('procedure Aguardar(t:real);');
WriteLn('{ *** Limpa uma linha especifica ***}');
WriteLn('procedure LimparLinha(x, y: byte);');
WriteLn('{*** Calcula potencia de um numero para expoentes inteiros ***}');
WriteLn('function Potencia(base: real; expoente: integer): double;');[/COLOR]
pause;
end;

{ *** Da um pause no prgrama *** }
procedure pause;
begin
WriteLn;
TextAttr:=TextAttr+Blink;
Write('Precione qualquer tecla para continuar');
TextAttr:=TextAttr-Blink;
ReadKey;
end;

{ *** Formata o texto e a tela do Pacal *** }
procedure formatar(corTexto, corFundo:byte);
begin
TextColor(corTexto);
TextBackGround(corFundo);
end;

{ *** ler um password *** }
function readPWD(tamanho:byte):string;
type
T_Senha = Array [1..255] of Char;
var
caractere :char; {caractere lido pelo usuario}
cont :byte; {contador de teclas já lidas}
senha_tmp :string;
v_senha :T_Senha; {a senha em si}
i :byte; {usado no for}
begin
cont:= 0; {zera o contador de caracteres já usados (é necessário)}
Repeat
caractere:=readkey; {ler a tecla digitada}
case UpCase(caractere) of {UpCase retorna o caractere em maiusculo}
{caso seja um alfanumérico}
'A' .. 'Z',
'0' .. '9' : begin
if cont<tamanho then
begin
inc(cont); {o mesmo que cont:= cont + 1;}
v_senha[cont]:= caractere; {armazena o caracteres}
write('*'); {imprime um "*" (ocultando a senha)}
end;
end;
{caso queira apagar uma linha}
BACKSPACE : begin
if cont>=1 then
begin
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
write(' '); {"apaga" um caractere}
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
dec(cont); {atualiza o contador} {dec(x) = x:=x-1;}
end;
end;
end;{fim case}
Until(caractere = ENTER){ or (cont > max)};
{retorna a senha via function}
senha_tmp:='';
For i:= 1 to cont do
senha_tmp:=senha_tmp+v_senha[i];
readPWD:=senha_tmp;
end;

{ *** ler um password (e desce uma linha) *** }
function ReadPWDln(tamanho:byte):string;
begin
ReadPWDln:=ReadPWD(tamanho);
WriteLn;
end;

[COLOR="Red"]{versao 002}
{ *** imprimi texto de modo centralizado ***}
procedure WritCet (texto:string);
begin
gotoXY(40-(length(texto) div 2), whereY); {centraliza}
writeln(texto);
end;

{da um delay no pascal em milissegundos}
procedure Aguardar(t:real);
function timer:real;
var
hour,
minute,
second,
sec100 :word;
begin
gettime(hour,minute,second,sec100);
{//Converte a hora capturada em milissegundos}
timer:=(hour*3600.0+minute*60.0+second)*1000.0+10.0*sec100;
end;

var
t1 :real;
begin
t1:=timer;
repeat until timer>t1+t;
end;

{ *** Limpa uma linha especifica ***}
procedure LimparLinha(x, y: byte);
begin
GotoXY(x,y); clreol;
GotoXY(x,y);
end;

{*** Calcula potencia de um numero para expoentes inteiros ***}
function Potencia(base: real; expoente: integer): double;
var
i :word;
tmp_Potencia :double;
begin
tmp_Potencia:= 1; {valor inicial e serve tambem caso expoente seja 0}
if (expoente<>0) then
begin
{calcula a potencia con a base em 'valor absoluto'}
for i:=1 to Abs(expoente) do
tmp_Potencia := tmp_Potencia*base;
{se o expoente for positivo}
if (expoente>0) then
Potencia:=tmp_Potencia
{se o expoente for negaivo}
else
Potencia:=1/tmp_Potencia;
end;
end;[/COLOR]


begin
ClrScr; {limpa a tela}
Formatar(White,Black); {formata a tela}
About; {exibe o "sobre" da unit}
Pause; {da uma pause}
ClrScr; {limpa a tela (logo após o programa que carregar essa UNIT será 'iniciado'}
end.

Abraços

Link para o comentário
Compartilhar em outros sites

  • 2 semanas depois...
  • Membro VIP

Adicionamos mais alguns recursos...

1) Posto o ClrScr depois do Formatar na "Begin/End" da unit;

2) Removido o "pause" do HELP_CRT_FCH;

3) Adicionado as constantes das principais teclas do teclado;

4) Adicionado os comandos:

procedure WritePic (texto: string; cor: byte);

{ *** Imprime texto colorido - nao desce a linha *** }

procedure WritelnPic (texto: string; cor: byte);

{ *** Imprime texto colorido - desce a linha *** }

procedure WriteXY(x,y:byte; texto:String);

{imprime texto em determinada posicao e retorna o cursor na posicao original}

4) Adicionado as variaveis

XOld,YOld :byte; {coodenadas do curso atual}

textAttrOld :word; {atributos de texto atual}

CÓDIGO Versão 0.010

{$N+} {habilita calculos com double}
UNIT CRT_FCH; {versão 0.010}

INTERFACE {tudo que é visto pelas "estruturas" que o carregar!!!}

{ *** CONSTANTES UNIVERSAIS ***}
[COLOR="Red"]const {Codigo ASCII de Teclas}
F1=#59; F2=#60; F3=#61; F4=#62; F5=#63; F6=#64;
F7=#65; F8=#66; F9=#67; F10=#68; F11=#69; F12=#70;
ENTER=#13; ESC=#27; BACKSPACE=#8; TABE =#9; ESPACO=' ';
SetaCima=#72; SetaBaixo=#80; SeteEsqueda=#75; SetaDireita=#77;[/COLOR]

procedure About;
{ *** Sobre a UNIT ***}

procedure HELP_CRT_FCH;
{ *** Ajuda sobre essa Unit ***}

procedure Pause;
{ *** Da um pause no programa *** }

procedure Formatar(corTexto, corFundo:byte);
{ *** Formata o texto e a tela do Pascal *** }

function ReadPWD(tamanho:byte):string;
{ *** ler um password *** }

function ReadPWDln(tamanho:byte):string;
{ *** ler um password (e desce uma linha) *** }

procedure Aguardar(t:real);
{ *** Da um delay no pascal em milissegundos}

procedure LimparLinha(x, y: byte);
{ *** Limpa uma linha especifica ***}

function Potencia(base: real; expoente: integer): double;
{ *** Calcula potencia de um numero para expoentes inteiros ***}


[COLOR="Red"]{
****************************************************************************
ROTINAS PARA IMPRESSAO DE CARACTERS
****************************************************************************
}

(* BASICOS *)

procedure WriteCet(texto:String);
{ *** Imprimi texto de modo centralizado *** }

procedure WritePic(cor:byte; texto:String);
{imprime texto colorido - nao desce a linha}

procedure WriteLNPic(cor:byte; texto:String);
{ *** Imprime texto colorido - desce a linha *** }

procedure WriteXY(x,y:byte; texto: string);
{imprime texto em determinada posicao e retorna o cursor na posicao original}[/COLOR]



IMPLEMENTATION {tudo que é visto EXCLUSIVAMENTE pela propria unit (e as
implementacoes das units declaradas na interface}
uses
CRT, {carrega comando como ReadKey, TextColor, TextBackGround, ClrScr}
DOS ; {carrega comando como GetTime, GetDate, DateTime}

var
XOld,YOld :byte; {coodenadas do curso atual}
textAttrOld :word; {atributos de texto atual}


{ *** Sobre a UNIT ***}
procedure About;
begin
WriteCet(' Unit obtida no FCH - Forum do Clube do Hardware');
WriteLn;
WriteLn(' Name : CRT_FCH ');
WriteLn(' Author : Simon Viegas, gu_ludo, XXXXX ');
WriteLn(' Description: Unit com algumas funcionalidades ');
WriteLn(' Date : 09/08/09 14:46 ');
WriteLn(' Copyright : Forum Clube do Hardware ');
WriteLn;
WriteCet(' EXECUTE O COMANDO HELP_CRT_FCH para abrir o Help da Unit');
end;

{ *** Ajuda sobre essa Unit ***}
procedure HELP_CRT_FCH;
begin
WriteLn('{versao001}');
WriteLn('{ *** Sobre a UNIT ***}');
WriteLn('procedure About;');
WriteLn('{ *** Ajuda sobre essa Unit ***}');
WriteLn('procedure HELP_CRT_FCH;');
WriteLn('{ *** Da um pause no programa *** }');
WriteLn('procedure Pause;');
WriteLn('{ *** Formata o texto e a tela do Pascal *** }');
WriteLn('procedure Formatar(corTexto, corFundo:byte);');
WriteLn('{ *** ler um password *** }');
WriteLn('function ReadPWD(tamanho:byte):string;');
WriteLn('{ *** ler um password (e desce uma linha) *** }');
WriteLn('function ReadPWDln(tamanho:byte):string;');
WriteLn('{versao 002}');
WriteLn('{ *** Da um delay no pascal em milissegundos}');
WriteLn('procedure Aguardar(t:real);');
WriteLn('{ *** Limpa uma linha especifica ***}');
WriteLn('procedure LimparLinha(x, y: byte);');
WriteLn('{*** Calcula potencia de um numero para expoentes inteiros ***}');
WriteLn('function Potencia(base: real; expoente: integer): double;');
end;

{ *** Da um pause no prgrama *** }
procedure pause;
begin
WriteLn;
TextAttr:=TextAttr+Blink;
Write('Precione qualquer tecla para continuar');
TextAttr:=TextAttr-Blink;
ReadKey;
end;

{ *** Formata o texto e a tela do Pacal *** }
procedure formatar(corTexto, corFundo:byte);
begin
TextColor(corTexto);
TextBackGround(corFundo);
end;

{ *** ler um password *** }
function readPWD(tamanho:byte):string;
type
T_Senha = Array [1..255] of Char;
var
caractere :char; {caractere lido pelo usuario}
cont :byte; {contador de teclas já lidas}
senha_tmp :string;
v_senha :T_Senha; {a senha em si}
i :byte; {usado no for}
begin
cont:= 0; {zera o contador de caracteres já usados (é necessário)}
Repeat
caractere:=readkey; {ler a tecla digitada}
case UpCase(caractere) of {UpCase retorna o caractere em maiusculo}
{caso seja um alfanumérico}
'A' .. 'Z',
'0' .. '9' : begin
if cont<tamanho then
begin
inc(cont); {o mesmo que cont:= cont + 1;}
v_senha[cont]:= caractere; {armazena o caracteres}
write('*'); {imprime um "*" (ocultando a senha)}
end;
end;
{caso queira apagar uma linha}
BACKSPACE : begin
if cont>=1 then
begin
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
write(' '); {"apaga" um caractere}
gotoxy(WhereX -1, WhereY); {posiciona uma coluna atrás}
dec(cont); {atualiza o contador} {dec(x) = x:=x-1;}
end;
end;
end;{fim case}
Until(caractere = ENTER){ or (cont > max)};
{retorna a senha via function}
senha_tmp:='';
For i:= 1 to cont do
senha_tmp:=senha_tmp+v_senha[i];
readPWD:=senha_tmp;
end;

{ *** ler um password (e desce uma linha) *** }
function ReadPWDln(tamanho:byte):string;
begin
ReadPWDln:=ReadPWD(tamanho);
WriteLn;
end;

{da um delay no pascal em milissegundos}
procedure Aguardar(t:real);
function timer:real;
var
hour,
minute,
second,
sec100 :word;
begin
gettime(hour,minute,second,sec100);
{//Converte a hora capturada em milissegundos}
timer:=(hour*3600.0+minute*60.0+second)*1000.0+10.0*sec100;
end;

var
t1 :real;
begin
t1:=timer;
repeat until timer>t1+t;
end;

{ *** Limpa uma linha especifica ***}
procedure LimparLinha(x, y: byte);
begin
GotoXY(x,y); clreol;
GotoXY(x,y);
end;

{*** Calcula potencia de um numero para expoentes inteiros ***}
function Potencia(base: real; expoente: integer): double;
var
i :word;
tmp_Potencia :double;
begin
tmp_Potencia:= 1; {valor inicial e serve tambem caso expoente seja 0}
if (expoente<>0) then
begin
{calcula a potencia con a base em 'valor absoluto'}
for i:=1 to Abs(expoente) do
tmp_Potencia := tmp_Potencia*base;
{se o expoente for positivo}
if (expoente>0) then
Potencia:=tmp_Potencia
{se o expoente for negaivo}
else
Potencia:=1/tmp_Potencia;
end;
end;



[COLOR="Red"]{
****************************************************************************
ROTINAS PARA IMPRESSAO DE CARACTERS
****************************************************************************
}

procedure WriteCet (texto:string);
{ *** imprimi texto de modo centralizado ***}
begin
gotoXY(40-(length(texto) div 2), whereY); {centraliza}
writeln(texto);
end;

procedure WritePic (cor:byte; texto:String);
{imprime texto colorido - nao desce a linha}
begin
textAttrOld:=textAttr; {copia dos atributos de texto atual}
textColor(cor);
write(texto);
textAttr:=textAttrOld; {reconfigura os atributos de texto}
end;

procedure WriteLNPic (cor:byte; texto:String);
{imprime texto colorido - desce a linha}
begin
writePic(cor,texto);
writeln;
end;

procedure WriteXY(x,y:byte; texto:String);
{imprime texto em determinada posicao e retorna o cursor na posicao original}
begin
XOld:=whereX; YOld:=whereY; {copia as coodenadas do curso atual}
gotoXY(x,y);
write(texto);
gotoXY(XOld,YOld); {retorna as coodenadas do curso}
end;[/COLOR]

begin
Formatar(White,Black); {formata a tela}
ClrScr; {limpa a tela}
About; {exibe o "sobre" da unit}
Pause; {da uma pause}
ClrScr; {limpa a tela (logo após o programa que carregar essa UNIT será 'iniciado'}
end.

Abraços

Link para o comentário
Compartilhar em outros sites

  • 2 meses depois...

Algumas ideias:

 
uses
crt;
var
x,y,resultado:real;
p,q:integer;

// funcao modulo |x|
function Modulo (k:real):real;
begin
if k<0 then
Modulo:=-1*k
else
Modulo:=k;
end;

// funcao calcular o maximo divisor comum
function MDC (a,b:integer):integer;
var r:integer;
begin
r := a mod b;
while (r<>0) do
begin
a := b;
b := r;
r := a mod b;
end;
MDC:=trunc(modulo(B)); //trunc inutil mas essencial
end;

// funcao calcular o minimo multiplo comum
function MMC (x1,x2:integer):integer;
begin
MMC:=x1 * x2 div MDC(x1,x2);
end;

// funcao contar casas decimais
function CasasDecimais(z1:real):integer;
const
precisao=15;
var
EmString:string;
passo:shortint;
begin
str(z1:1:precisao,EmString); //converte para string com 'precisao' (20) casas decimais
delete(EmString,1,Pos('.',EmString)); //apaga tudo ate o ponto
passo:=precisao;
while EmString[passo]='0' do //apaga os zeros do final
begin
delete(EmString,passo,1);
passo:=passo-1;
end;
CasasDecimais:=length(EmString); //conta as casas
end;

// converter decimal em fracao
procedure DecimalEmFracao (z1:real; var p,q:integer);
var p2:integer;
begin
p:=trunc(z1*exp(ln(10)*CasasDecimais(z1)));
q:=trunc(exp(ln(10)*CasasDecimais(z1)));
// o trunc nao vai mudar nada, apenas mudar para tipo integer
// tem-se: z1 = p/q
// simplificar
p2:=p; //guardar o valor de p em p2
p:=p div MDC(p,q); //simplificar o numerador
q:=q div MDC(p2,q); //simplificar o denominador
{ writeln(z1,' = ',p,' / ',q); }
// z1 = p / q
// simplificado
end;

// calcular a potencia
function Potencia(base,expoente:real):real;
const
indefinido=0;
begin
if base>0 then //base positiva
Potencia:=exp(ln(base)*expoente) // Potencia = base ^ expoente
else //base negativa ou nula
if base=0 then //base nula
if expoente>0 then //base nula e expoente positivo
Potencia:=0
else //base nula e expoente negativo ou nulo
Potencia:=indefinido
else //base negativa
begin
DecimalEmFracao(expoente,p,q); // tem-se expoente=p/q
if q mod 2 = 0 then // indice da raiz par
Potencia:=indefinido
else // indice da raiz impar
if p mod 2 = 1 then // novo expoente par
Potencia:=-exp(ln(modulo(base))*expoente) // Potencia=-(|base|) ^ (expoente)
else
Potencia:=exp(ln(modulo(base))*expoente); // Potencia= (|base|) ^ (expoente)
end;

// calcular raiz
(*
function Raiz (indice,radicando:real) :real;
{var...;}
begin
Raiz:=Potencia(radicando,1/indice);
end;
*)
end;

Begin

(*
// testar modulo
while true do
begin
readln(x);
writeln(modulo(x):0:4);
writeln;
end;
*)

(*
// testar potencia
while true do
begin
readln(x,y);
resultado:=Potencia(x,y);
gotoxy(1,wherey+3);
if x>= 0 then write(x:0:2) else write('(',x:0:2,')');
gotoxy(wherex,wherey-1);
write(y:0:2);
gotoxy(wherex+1,wherey+1);
write('= ',resultado:0:8);
writeln;
gotoxy(1,wherey+4);
end;
*)

(*
//testar mdc
while true do begin
readln(x,y);
writeln(MDC(trunc(x),trunc(y)));
end;
*)

(*
//testar mmc
while true do begin
readln(x,y);
writeln(MMC(trunc(x),trunc(y)));
end;
*)

(*
// testar decimal em fracao
while true do begin
readln(x);
DecimalEmFracao(x,p,q);
writeln('x = ',p,' / ',q);
end;
*)

(*
// testar numero de casas
while true do begin
readln(x);
writeln(CasasDecimais(x));
end;
*)

End.

 

program teste_unit;

Fiz como um programa que testa cada utilidade.

Para testar, basta retirar os "(*" e "*)" do trecho de teste desejado.

O que faz:

  • calcula o módulo de um número real;
  • calcula o mínimo múltiplo comum entre dois números inteiros;
  • calcula o máximo divisor comum entre dois números inteiros;
  • conta o número de casas decimais de um número real (necessária para os próximos);
  • converte um número real numa fração de numerador e denominador inteiros e primos entre si;
  • calcula potências e raízes de dois números REAIS;

Obrigado pela atenção.

Link para o comentário
Compartilhar em outros sites

  • 2 semanas depois...

Se ainda estiver fazendo, aqui vai um procedure para ler um número real sem erros:

program LER_NUMEROS;
uses
crt;

var
x:real;

procedure LerReal (var numeroreal:real);
const
menos=['-'];
algarismos=['0'..'9'];
ponto=['.',','];
backspace=[chr(8)];
enter=[chr(13)];
var
tecla:char;
caracter: array[1..255] of char;
numerostr:string;
contador,i1:byte;
erroconv:integer;
aceitar:set of chr(0)..chr(255);
begin
contador:=1;
aceitar:=['-','0'..'9','.',',',chr(13),chr(8)];
repeat
repeat
tecla:=readkey
until (tecla in aceitar) and ((contador=1) or (tecla<>'-')) and ((contador<>1) or (not (tecla in enter))); //aceitar apenas numeros, negativo, ponto, virgula, backspace e enter
if tecla in algarismos+menos then //numero
begin
caracter[contador]:=tecla;
write(tecla);
if tecla in menos then
aceitar:=aceitar-['-']; // nao aceitar o menos outra vez
end
else
if tecla in ponto then //ponto ou virgula
begin
caracter[contador]:='.';
write('.');
aceitar:=aceitar-['.',',']; // nao aceitar mais o ponto
end
else
if tecla in backspace then //backspace
begin
if contador>1 then
begin
if contador =2 then
aceitar:=aceitar+['-'];
if caracter[contador-1] in ponto then
aceitar:=aceitar+['.'];
caracter[contador-1]:='0';
gotoxy(wherex-1,wherey);
clreol;
contador:=contador-2;
end;
end;
contador:=contador+1;
until (tecla in enter) or (contador=255); //enter
numerostr:='';
for i1:=1 to contador-2 do
numerostr:=concat(numerostr,caracter[i1]); //unir caracteres
val(numerostr,numeroreal,erroconv);
writeln;
end;

begin {programa}
textbackground(9);
clrscr;
textcolor(yellow);
while true do
begin
writeln('Digite o numero:');
LerReal(x);
writeln('voce digitou o numero ',x:0:10,' .');
readkey;
clrscr;
end;
end.

Link para o comentário
Compartilhar em outros sites

  • mês depois...

Arquivado

Este tópico foi arquivado e está fechado para novas respostas.

Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×
×
  • Criar novo...