Exercício 1
program ex1; // 33 linhas
uses crt;
var a, b : real;
oper : string[1];
valido : boolean;
begin
writeln('CALCULADORA SIMPLES');
write('Valor 1: ');
readln(a);
repeat
write('Operador (+, -, /, *): ');
readln(oper);
until (oper='+') or (oper='-') or (oper='/') or (oper='*');
repeat
write('Valor 2: ');
readln(b);
if (oper='/') and (b=0) then begin
valido := false;
writeln('ERRO! Divisao por zero!');
end else valido := true;
until valido;
write('Resultado: ');
if (oper='+') then writeln(a+b:0:10)
else begin
if (oper='-') then writeln(a-b:0:10)
else begin
if (oper='*') then writeln(a*b:0:10)
else writeln(a/b:0:10);
end;
end;
write('Prima ENTER para fechar...');
readln;
end.
Exercício 2
program ex2; // 18 linhas
uses crt;
var i, alunos, avaliacao, positivas : integer;
begin
writeln('CONTADOR DE AVALIACOES POSITIVAS');
write('Numero de alunos? ');
readln(alunos);
for i:=1 to alunos do begin
repeat
write('Nota do aluno ',i,': ');
readln(avaliacao);
until ((avaliacao>=0) and (avaliacao<=20));
if (avaliacao>=10) then positivas := positivas + 1;
end;
writeln;
writeln('Existem ',positivas,' positivas (',(positivas/alunos)*100:0:1,'%)');
readln;
end.
Exercício 3
program ex3; // 19 linhas
uses crt;
var numero, maior : real;
n, i : integer;
begin
repeat
write('Quantos numeros vai introduzir? (5-50) ');
readln(n);
until (n>=5) and (n<=50);
maior := 0;
for i:=1 to n do begin
write(i,'o numero: ');
readln(numero);
if (numero > maior) then maior := numero;
end;
writeln;
writeln('O maior numero foi: ',maior:0:10);
readln;
end.
Exercício 4
program ex4; // 24 linhas
uses crt;
var s : string;
i, j : integer;
begin
writeln('Este programa tira os espacos a mais de uma STRING');
writeln;
write('Escreva uma STRING: ');
readln(s);
j := 0;
for i:=1 to length(s) do
begin
j := j+1;
if (s[i] = ' ') then begin
s[j] := ' ';
while (s[i] = ' ') do
i := i+1;
j := j+1
end;
s[j] := s[i];
end;
writeln('Nova STRING: ',s);
readln;
end.
Exercício 5
program ex5; // 24 linhas
uses crt;
var numero : real;
function factorial(n : integer) : integer;
var i, temp : integer;
begin
if (n=0) or (n=1) then factorial := 1
else begin
temp := n;
for i:=n-1 downto 1 do begin
temp := temp * i;
end;
factorial := temp;
end;
end;
begin
repeat
write('Numero para calcular factorial: ');
readln(numero);
until (numero = ROUND(numero)) and (numero>=0);
writeln;
writeln('Factorial de ',ROUND(numero),': ',factorial(ROUND(numero)));
readln;
end.
Exercício 6
program ex6; // 46 linhas
uses crt;
var a, b : real;
oper : string[1];
begin
REPEAT
textcolor(15);
writeln('CALCULADORA SIMPLES');
write('Valor 1: ');
readln(a);
write('Operador (+, -, *, /): ');
readln(oper);
if (oper='/') then begin
repeat
write('Valor 2: ');
readln(b);
if (b=0) then begin
textcolor(12);
writeln('ERRO! Divisao por zero!');
textcolor(15);
end;
until (b<>0);
end else begin
write('Valor 2: ');
readln(b);
end;
writeln;
write('RESULTADO da operacao: ');
textcolor(14);
if (oper='+') then write(a+b:0:10)
else begin
if (oper='-') then write(a-b:0:10)
else begin
if (oper='*') then write(a*b:0:10)
else write(a/b:0:10);
end;
end;
textcolor(15);
writeln('1 > Repetir operacao');
writeln('0 > Sair');
repeat
readln(oper);
until (oper='1') or (oper='0');
if (oper='1') then writeln;
UNTIL (oper='0');
end.
Exercício 7
program ex7; // 17 linhas
uses crt;
var i, j : integer;
begin
for i:=1 to 20 do begin
for j:=1 to 45 do begin
case j of
1..15 : textbackground(1);
16..30 : textbackground(7);
31..45 : textbackground(4);
end;
write(' ');
end;
writeln;
end;
readln;
end.
Exercício 8
program ex8; // 60 linhas
uses crt;
var aluno : array[1..30] of record // RECORD referido no exercício
nome : string[60];
matematica : real;
portugues : real;
end;
media : record // RECORD facultativo: depende do método de cada programador
matematica : real;
portugues : real;
end;
quantos, i : integer;
begin
writeln('ESTATISTICA DA TURMA');
writeln;
repeat
write('Quantos alunos sao? (1-30) ');
readln(quantos);
until (quantos>=1) and (quantos<=30);
writeln;
for i:=1 to quantos do begin
writeln('ALUNO ',i);
with aluno[i] do begin
write('Nome: ');
readln(nome);
repeat
write('Media a Matematica: ');
readln(matematica);
until (matematica>=0) and (matematica <=20);
repeat
write('Media a Portugues: ');
readln(portugues);
until (portugues>=0) and (portugues<=20);
end;
writeln;
end;
for i:=1 to quantos do begin
media.matematica += aluno[i].matematica;
media.portugues += aluno[i].portugues;
end;
with media do begin
matematica := matematica / quantos;
portugues := portugues / quantos;
end;
writeln;
writeln('TURMA');
writeln('Media a Portugues: ',media.portugues:0:2);
writeln('Media a Matematica: ',media.matematica:0:2);
writeln;
writeln('ALUNOS APTOS A COMPARECER AO EXAME NACIONAL DE MATEMATICA:');
for i:=1 to quantos do begin
if (aluno[i].matematica>=9.5) then writeln(' ',aluno[i].nome);
end;
writeln;
writeln('ALUNOS APTOS A COMPARECER AO EXAME NACIONAL DE PORTUGUES:');
for i:=1 to quantos do begin
if (aluno[i].portugues>=9.5) then writeln(' ',aluno[i].nome);
end;
readln;
end.
Exercício 9
program ex9; // 48 linhas
uses crt;
var operacao : record
a : real;
b : real;
oper : char;
end;
opcao : char;
begin
REPEAT
textbackground(7);
textcolor(16);
clrscr;
writeln('CALCULADORA');
with operacao do begin
write(' Valor 1: ');
readln(a);
write(' Operacao (+, -, *, /): ');
repeat
oper := readkey;
until (char(oper)='+') or (char(oper)='-') or (char(oper)='*') or (char(oper)='/');
if (oper='/') then begin
repeat
write(' Valor 2: ');
readln(b);
until (b<>0);
end else begin
write(' Valor 2: ');
readln(b);
end;
write('Resultado: ');
if (char(oper)='+') then write(a+b:0:10)
else begin
if (char(oper)='-') then write(a-b:0:10)
else begin
if (char(oper)='*') then write(a*b:0:10)
else write(a/b:0:10);
end;
end;
end;
writeln;
writeln('1 > Repetir operacao');
writeln('0 > Sair');
repeat
opcao := readkey;
until (char(opcao)='1') or (char(opcao)='0');
UNTIL (char(opcao)='0');
end.
Exercício 10
program ex10; // 58 linhas
(* Há muitas mais propostas possíveis, inclusive mais interactivas.
O objectivo deste é tão-somente exemplificar a utilização dos métodos.*)
uses crt;
var s, sp : string[80];
a : string[80];
p, l : byte;
opc : char;
begin
write('A primeira frase nunca se altera. So pode trabalhar com esta!');
write('Escreva uma frase: ');
readln(s);
repeat
writeln;
writeln('1 - Procurar');
writeln('2 - Apagar');
writeln('3 - Inserir');
writeln('0 - Sair');
repeat
opc := readkey;
writeln;
if not (opc = '0') then begin
writeln('FRASE: ');
writeln(s); writeln;
end;
case opc of
'1' : begin
write('Procurar: ');
readln(sp);
p := Pos(sp, s);
if not (p = 0) then writeln('Primeira ocorrencia na posicao ', p)
else writeln('Nao existe na frase');
end;
'2' : begin
write('Posicao onde comecar a apagar: ');
readln(p);
write('Quantas letras apagar: ');
readln(l);
a := s;
Delete(a, p, l);
writeln('Frase final: ', a);
end;
'3' : begin
write('Posicao onde comecar a inserir: ');
readln(p);
write('Expressao a inserir: ');
readln(sp);
a := s;
Insert(sp, s, p);
writeln('Frase final: ', a);
end;
end;
until (opc in ['0'..'3']);
write('Deseja repetir? (S/N) ');
repeat
opc := readkey;
until (UpCase(opc) in ['S', 'N']);
writeln; writeln;
until (UpCase(opc) = 'N');
end.
Exercício 11
program ex11; // 20 linhas
uses crt;
var face : array[1..6] of integer;
i : integer;
begin
randomize;
for i:=1 to 1000000 do
inc(face[random(6)+1]);
for i:=1 to 6 do writeln('Face ',i,': ',face[i]);
readln;
end.
Exercício 12
program ex12; // 35 linhas
type TLetra = record
Qual : char;
Vezes : word;
end;
const vogais : set of char = ['A', 'E', 'I', 'O', 'U'];
consoantes : set of char = ['A'..'Z'] - ['A', 'E', 'I', 'O', 'U'];
var Linha : string[80];
Letras : array [1..26] of TLetra;
i : integer;
procedure IniciarLetras(var L : array of TLetra);
var j : integer;
begin
for j:=1 to 26 do begin
L[j].Qual := char(j+64);
L[j].Vezes := 0;
end;
end;
begin
write('Introduza linha de texto: ');
readln(Linha);
IniciarLetras(Letras);
for i:=1 to length(Linha) do
inc(Letras[ord(UpCase(Linha[i]))-63].Vezes);
writeln('VOGAIS:');
for i:=1 to 26 do
if (Letras[i].Qual in vogais) and (Letras[i].Vezes > 0) then
writeln(Letras[i].Qual,' = ',Letras[i].Vezes);
writeln('CONSOANTES:');
for i:=1 to 26 do
if (Letras[i].Qual in consoantes) and (Letras[i].Vezes > 0) then
writeln(Letras[i].Qual,' = ',Letras[i].Vezes);
readln; // pausa
end.
Exercício 13
{$MODE DELPHI}
program ex13; // 27 linhas
uses windows, sysutils, strutils;
var Num : integer;
Rom : string;
Mensagem : pchar;
begin
try
writeln('INTEIRO --> ROMANO');
write('Numero? ');
readln(Num);
writeln('Romano = ', IntToRoman(Num));
writeln;
writeln('ROMANO --> INTEIRO');
write('Romano? ');
readln(Rom);
Rom := UpCase(Rom);
writeln('Numero = ', RomanToInt(Rom));
except
ON ex:exception do begin
Mensagem := @ex.message[1];
MessageBox(0, Mensagem, 'Ocorreu um erro', 0 + MB_ICONHAND);
end;
end;
readln; // pausa
end.
Desafio 1
program des1; // 21 linhas
uses crt;
var texto : string;
procedure ler(var s : string);
begin
readln(s);
end;
procedure escrever(s : string);
var i : integer;
begin
for i:=length(s) downto 1 do write(s[i]);
end;
begin
write('Escreva linha de texto: ');
ler(texto);
writeln;
write('Texto por ordem inversa: ');
escrever(texto);
writeln;
readln;
end.
Desafio 2
program des2; // 23 linhas
uses crt;
var i, j : integer;
key : char;
begin
writeln('Cores disponiveis: ');
writeln;
for i:=1 to 8 do write(i,' ');
writeln;
for i:=1 to 16 do begin
for j:=1 to 8 do begin
textcolor(i);
textbackground(j);
if (i>=1) and (i<=9) then write('0');
write(i,' TESTE ');
end;
writeln;
end;
textbackground(8);
textcolor(7);
writeln;
readln;
end.
Desafio 3
program des3; // 16 linhas
uses crt;
var i, j : integer;
begin
writeln('Tabela ASCII do presente computador:');
writeln;
for i:=32 to 255-9 do begin
write(i,' ',char(i),' ',i+1,' ',char(i+1),' ',i+2,' ',char(i+2));
write(' ',i+3,' ',char(i+3),' ',i+4,' ',char(i+4));
write(' ',i+5,' ',char(i+5),' ',i+6,' ',char(i+6));
write(' ',i+7,' ',char(i+7),' ',i+8,' ',char(i+8));
writeln(' ',i+9,' ',char(i+9));
i := i+9;
end;
readln;
end.
Desafio 4
program des4; // 19 linhas
uses crt;
function BolToBin(v : boolean) : integer;
begin
case v of
true : BolToBin := 1;
false : BolToBin := 0;
end;
end;
function BinToBol(v : integer) : boolean;
begin
case v of
1 : BinToBol := true;
0 : BinToBol := false;
end;
end;
begin
// programa
end.
Desafio 5
Desafio 6
program des6;
uses crt;
var numero : integer;
function multiplo(mult, num : integer) : boolean;
begin
if (mult mod num = 0) then multiplo := true
else multiplo := false;
end;
procedure mostrar_primos(n : integer);
var lista : set of byte;
primos : set of byte;
i : integer;
j : integer;
l : integer;
begin
lista := [2..n];
primos := [];
i:=2;
while ([i] <= lista) do begin
primos += [i];
for j:=i to n do begin
if multiplo(j,i) then lista -= [j];
end;
l:=2;
while (not ([l] <= lista)) and (l<=n) do l += 1;
i := l; // Assim que determinado, é atribuído a I, que é primo.
end;
write('PRIMOS: ');
for i:=2 to n do begin
if ([i] <= primos) then write(i,', ');
end;
end;
begin
repeat
write('Calcular numeros primos ate: '); readln(numero);
until (numero in [2..maxint]);
writeln;
mostrar_primos(numero);
writeln;
write('ENTER para sair...'); readln;
end.
