Respostas Exercícios Pascal

Esta é uma pré-visualização de arquivo. Entre para ver o arquivo original

Programando 
com Pascal
Respostas dos 
Exercícios Propostos
Jaime Evaristo
Instituto de Computação
Universidade Federal de Alagoas
Capítulo 1
1. Naturalmente, na primeira travessia, um índio levaria um branco até a outra margem e voltaria sozinho. A questão é a segunda: não 
poderia atravessar um índio e um branco, pois, ao chegar na outra margem, haveria dois brancos e um índio; não poderiam atravessar 
dois índio, pois o terceiro ficaria com dois brancos. A solução é atravessar dois brancos e um deles retornar. A terceira travessia só 
pode ser feita por dois índios, pois já existem dois brancos na outra margem. A questão é o retorno. A única possibilidade é retornar 
um índio e um branco! Temos então o seguinte algoritmo:
1. Atravessem um índio e um branco.
2. Retorne o índio.
3. Atravessem dois brancos.
4. Retorne um branco.
5. Atravessem dois índios.
6. Retornem um índio e um branco.
7. Atravessem dois índios.
8. Retorne um branco.
9. Atravessem dois brancos.
10. Retorne um branco.
11. Atravessem dois brancos. 
2. Indicando por 1, 2, 3, 4, ... os discos na ordem crescente dos seus diâmetros, temos para o caso n = 2: 
1. Disco 1 da origem para auxiliar.
2. Disco 2 da origem para o destino.
3. Disco 1 da auxiliar para o destino.
Para o caso n = 3, basta observar que é necessário apenas transportar os dois discos 1 e 2 da origem para auxiliar (que é o caso 
anterior), transportar o disco 3 da origem para o destino e os discos 1 e 2 da torre auxiliar para o destino (que é, novamente, o caso 
anterior).
1. Disco 1 da origem para destino.
2. Disco 2 da origem para auxiliar.
3. Disco 1 do destino para auxiliar.
4. Disco 3 da origem para destino.
5. Disco 1 da auxiliar para origem.
6. Disco 2 da auxiliar para o destino.
7. Disco 1 da origem para o destino.
3. Para facilitar a linguagem, indiquemos por P(m, n) = 0 se as esferas m e n têm o mesmo peso e por P(m, n) > 0 se a esfera m pesa 
mais que a esfera n. Temos então a seguinte solução: 
1. Pese as esferas 1 e 2.
2. Se P(1, 2) = 0, pese as esferas 1 e 3.
2.1 Se P(1, 3) > 0 então forneça como resposta: a esfera 3 tem peso menor que as esferas 1 e 2.
2.2 Se P(3, 1) > 0 então forneça como resposta: a esfera 3 tem peso maior que as esferas 1 e 2.
3. Se P(1, 2) > 0, pese as esferas 1 e 3.
3.1 Se P(1, 3) = 0 então forneça como resposta: a esfera 2 tem peso menor que as esferas 1 e 3.
3.2 Se P(1, 3) > 0 então forneça como resposta: a esfera 1 tem peso maior que as esferas 2 e 3.
3.3 Se P(3, 1) > 0 então forneça como resposta: a esfera 1 tem peso menor que as esferas 2 e 3.
4. Se P(2, 1) > 0, pese as esferas 2 e 3.
4.1 Se P(2, 3) = 0 então forneça como resposta: a esfera 1 tem peso menor que as esferas 2 e 3.
4.2 Se P(2, 3) > 0 então forneça como resposta: a esfera 2 tem peso maior que as esferas 1 e 3.
4.3 Se P(3, 2) > 0 então forneça como resposta: a esfera 2 tem peso menor que as esferas 1 e 3.
4. Para calcular o produto, utilizamos uma variável P que assume inicialmente o primeiro valor da relação e, para cada novo 
elemento, vai tendo o seu valor substituído pelo produto do seu valor atual pelo novo elemento.
1. Chame de A o primeiro número dado.
2. Chame de N o número de elementos da relação
3. Faça P = A.
4. Repita N - 1 vezes as instruções 4.1 e 4.2.
4.1. Chame de A o próximo número dado.
4.2. Substitua o valor de P por P x A.
5. Calcule M = Raiz(P, N)
6. Forneça M para o valor da média.
5. Basta observar que os dias da semana, sendo em número de 7, repetem-se em ciclos de 7 dias. Assim, se 01/01/1900 foi uma 
segunda-feira, o foram também os dias 08/01/1900, 15/01/1900, 22/01/1900, 29/01/1900, 05/02/1900 e assim sucessivamente. Basta 
então determinar o número de dias decorridos entre a data dada e o dia 01/01/1900 e calcular o resto da divisão por 7.
1. Determine o número n de dias entre a data dada e 01/01/1900.
2. Calcule o resto r da divisão de n por 7
3. Se r = 1 forneça como resposta segunda-feira.
4. Se r = 2 forneça como resposta terça-feira.
5. Se r = 3 forneça como resposta quarta-feira.
6. Se r = 4 forneça como resposta quinta-feira.
7. Se r = 5 forneça como resposta sexta-feira.
8. Se r = 6 forneça como resposta sábado.
9. Se r = 0 forneça como resposta domingo.
6. Indicando por A(x, y) a travessia dos integrantes x e y e por V(x) a volta do integrante x, teríamos:
1. A(baterista, baixista).
2. V(baterista).
3. A(guitarrista, vocal).
4. V(baixista)
5. A(baixista, baterista)
Capítulo 2
1a. 2
1b. true
2a. {Programa que converte uma temperatura em graus Farenheit para graus Celsius}
program ConversaoTemperatura;
var Celsius, Farenheit : real;
begin
writeln('Digite a temperatura em graus Farenheit');
readln(Farenheit);
Celsius := 5*(Farenheit - 32)/9;
writeln(Farenheit:0:2, ' graus Farenheit correspondem a ', Celsius:0:2, ' graus Celsius');
end.
2b. {Programa para gerar o invertido de um inteiro dado}
program InverteInteiro;
var Num, Invertido, Unidade, Dezena, Centena : integer;
begin
writeln('Digite o inteiro (com tres algarismos)');
readln(Num);
Unidade := Num mod 10;
Dezena := (Num mod 100) div 10;
Centena := Num div 100;
Invertido := Unidade * 100 + Dezena * 10 + Centena;
writeln('O invertido de ', Num, ' eh ', Invertido);
end.
2c. {Programa para somar duas fracoes ordinarias}
program SomaFracoes;
var Num1, Den1, Num2, Den2, Num, Den: integer;
begin
writeln('Digite as fracoes');
readln(Num1, Den1, Num2, Den2);
Num := Num1 * Den2 + Num2 * Den1;
Den := Den1 * Den2;
writeln('(', Num1, '/', Den1, ') + (', Num2, '/', Den2,') = (', Num, '/', Den, ')');
end.
2d. {Programa que determina o menor multiplo de um inteiro maior que um outro inteiro}
program MenorMultiplo;
var n, k, MenorMult : integer;
begin
writeln('Digite dois inteiros ');
readln(n, k);
MenorMult := n - n mod k + k;
writeln('O menor multiplo de ', k, ' maior que', n, ' ‚ ', MenorMult);
end.
2e. {Programa que determina o perimetro de um poligono regular inscrito numa circunferencia}
program PerimetroPoligonoInscrito;
var NumLados : integer;
Raio, Perimetro: real;
begin
writeln('Digite o numero de lados do poligono');
readln(NumLados);
writeln('Digite o raio da circunferencia');
readln(Raio);
Perimetro := 2 * NumLados * Raio * Sin(Pi/NumLados);
write('O perimetro do poligono de ', NumLados, ' lados inscrito ');
writeln('numa circunferencia de raio ', Raio:0:2, ' eh igual a ', Perimetro:0:2);
end.
3. {Programa que permuta o conteudo de duas variaveis sem utilizar variavel auxiliar}
program PernutaVariaveis;
var x, y : real;
begin
writeln('Digite dois valores'); 
readln(x, y);
writeln('Conteudos antes da permuta: x = ', x:0:2, ' e y = ', y:0:2);
x := x + y; 
y := x - y; 
x := x - y;
writeln('Conteudo apos a permuta x = ', x:0:2, ' e y = ', y:0:2);
end.
4. {Programa que determina a entrada e as duas prestacoes de uma compra a prazo}
program CalculoPrestacoes;
var Compra, Entrada : real;
Prestacao : integer;
begin
writeln('Digite o valor da compra');
readln(Compra);
Prestacao := Trunc(Compra/3);
Entrada := Compra - 2 * Prestacao;
writeln('Valor da compra: ', Compra:0:2);
writeln('Valor da entrada: ', Entrada:0:2);
writeln('Valor das prestacoes: ', Prestacao, '.00');
end.
5. {Programa para fornecer um intervalo de tempo dado em segundos em horas minutos e segundos}
program IntervaloTempo;
var Intervalo, Resto, Horas, Minutos, Segundos : integer;
begin
writeln('Digite o intervalo de tempo');
readln(Intervalo);
Horas := Intervalo div 3600;
Resto := Intervalo mod 3600;
Minutos := Resto div 60;
Segundos := Resto mod 60;
writeln('O intervalo de tempo ', Intervalo, ' s equivale a ');
writeln(Horas, ' h ', Minutos, ' min ', Segundos,' s');
end.
6. {Programa para fornecer um intervalo de tempo dado em minutos em horas minutos e segundos}
program IntervaloTempo;
var Horas, Minutos : integer;
Intervalo, Segundos, Resto : real;
begin
writeln('Digite o intervalo de tempo');
readln(Intervalo);
Horas := Trunc(Intervalo) div 60;
Resto := Intervalo - Horas * 60;
Minutos := Trunc(Resto);
Segundos := Frac(Resto) * 60;
write('O intervalo de tempo ', Intervalo:0:2, ' s equivale a ');
writeln(Horas, ' h ', Minutos, ' min ', Segundos:0:1,' s');
end.
7. {Programa para discriminar as notas de saque em um caixa eletronico, observando, por pertinente, que o programa escrito com os 
conhecimentos do capitulo 4 fica bem mais simples}
program CaixaEletronico;
var Saque, x, Notas100, Notas50, Notas10, Notas5, Notas1: integer;
begin
writeln('Digite o valor do saque');
readln(Saque);
Notas100 := Saque div 100;
x := Saque mod 100;
Notas50 := x div 50;
x := x mod 50;
Notas10 := x div 10;
x := x mod 10;
Notas5 := x div 5;
Notas1 := x mod 5;
writeln('O saque solicitado no valor de ', Saque, ' deve ser pago com:');
writeln(Notas100, ' notas de 100 reais');
writeln(Notas50, ' notas de 50 reais');
writeln(Notas10, ' notas de 10 reais');
writeln(Notas5, ' notas de 5 reais');
writeln(Notas1, ' notas de 1 real');
end.
8. {Programa para implementar calculo de potencias em Pascal}
program ImplementaPotencia;
var Base, Expoente, Potencia : real;
begin
writeln('Digite a base (positiva) e o expoente');
readln(Base, Expoente);
Potencia := Exp(Expoente * Ln(Base));
writeln(Base:0:2,'^',Expoente:0:2, ' = ', Potencia:0:6);
end.
9. {Programa para determinar o valor das prestacoes de um financiamento}
program CalculoPrestacoesFinanciamento;
var Valor, Fator, ValPrest, Taxa: real;
NumPrest : integer;
begin
write('Valor do financiamento: ');
readln(Valor);
write('Numero de prestacoes: ');
readln(NumPrest);
write('Taxa de juros: ');
readln(Taxa);
Taxa := Taxa/100;
Fator := Exp(NumPrest * Ln(1 + Taxa));
ValPrest := (Valor * Taxa * Fator)/(Fator - 1);
writeln('Financiamento: ', Valor:0:2);
writeln('Numero de prestacoes: ', NumPrest);
writeln('Taxa de juros: ', 100 * Taxa:0:2);
writeln('Valor das prestacoes: ', ValPrest:0:2);
end.
Capítulo 3
1. {programa que implementa a funcao round}
program Arredondamentos;
var x : real;
Arredonda : integer;
begin
writeln('Digite o numero a arredondar');
readln(x);
if Frac(x) < 0.5
then
Arredonda := Trunc(x)
else
Arredonda := Trunc(x) + 1;
writeln('O valor de ', x:0:6, ' arredondado e igual ', Arredonda);
end.
2. {programa que verifica se um inteiro dado eh quadrado perfeito}
program QuadPerfeito;
var x : integer;
Raiz : real;
begin
writeln('Digite o numero');
readln(x);
Raiz := SqrT(x);
if Frac(Raiz) = 0
then
writeln(x, ' eh quadrado perfeito de raiz quadrada igual a ', Raiz:0:0)
else
writeln(x, ' nao eh quadrado perfeito');
end.
3. {programa que determina o maior de tres numeros dados}
program MaiorDe3;
var x, y, z, Maior : real;
begin
writeln('Digite s tres numeros');
readln(x, y , z);
Maior := x;
if (y > Maior) or (z > Maior)
then
if y > z
then
Maior := y
else
Maior := z;
writeln('O maior dos numeros ', x:0:2, ', ', y:0:2, ' e ',z:0:2 , ' eh igual a ', Maior:0:2);
end.
4. {programa que classifica um triangulo de lados dados}
program ClassificaTriangulo;
var x, y, z : real;
begin
writeln('Digite os comprimentos dos lados do triangulo');
readln(x, y , z);
if (x < y + z) and (y < z + x) and (z < x + y)
then
if (x = y) and (y = z)
then
writeln('O triangulo de lados ', x, ', ', y, ' eh ', z, 'e equilatero')
else
if (x = y) or (x = z) or (y = z)
then
writeln('O triangulo de lados ', x, ', ', y, ' eh ', z, ' e isosceles')
else
writeln('O triangulo de lados ', x, ', ', y, ' eh ', z, ' e escaleno')
else
writeln('Os valores dados nao sao comprimentos dos lados de um triangulo');
end.
5. {programa que verifica se um triangulo de lados dados eh retangulo}
program ClassificaTriangulo;
var x, y, z, Hip, Cat1, Cat2 : real;
begin
writeln('Digite os comprimentos dos lados do triangulo');
readln(x, y , z);
if (x < y + z) and (y < z + x) and (z < x + y)
then
begin
Hip := x;
Cat1 := y;
Cat2 := z;
if (y > Hip) or (z > Hip)
then
if (y > z)
then
begin
Hip := y;
Cat1 := x;
end
else
begin
Hip := z;
Cat2 := x;
end;
if Sqr(Hip) = Sqr(Cat1) + Sqr(Cat2)
then
write('O triangulo de lados ', x, ', ', y, ' e ', z, ' eh retangulo de hipotenusa ', Hip, ' e catetos ', Cat1, ' e 
', Cat2);
else
writeln('O triangulo de lados ', x, ', ', y, ' e ', z, ' nao e retangulo');
end
else
writeln('Os valores dados nao sao comprimentos dos lados de um triangulo');
end.
6. {Programa que determina as raizes de uma equacao do segundo grau}
program EquacaoGrau2;
var a, b, c, x1, x2, ParteReal, ParteImag, Delta : real;
begin
writeln('Digite os coeficientes');
readln(a, b, c);
if a <> 0
then
begin
Delta := Sqr(b) - 4*a*c;
ParteReal := -b/(2*a);
ParteImag := SqrT(abs(Delta))/(2*a);
if Delta >= 0
then
begin
x1 := ParteReal + ParteImag;
x2 := ParteReal - ParteImag;
writeln('As raizes da equacao dada sao ', x1, ' e ', x2);
end
else
write('As raizes da equacao dada sao complexas: ', ParteReal:0:2,' + ', ParteImag:0:2,'i e ', 
ParteReal:0:2, ' - ', ParteImag:0:2,'i');
end
else
writeln('A equacao nao e do segundo grau');
end.
7. {Programa que determina a idade de uma pessoa em anos, meses e dias }
program IdadeEmAnosMesesDias;
var DiaNasc, MesNasc, AnoNasc, d, DiaAt, MesAt, AnoAt, Anos, Dias, Meses: integer;
begin
writeln('Digite a data de nascimento');
readln(DiaNasc, MesNasc, AnoNasc);
writeln('Digite a data atual');
readln(DiaAt, MesAt, AnoAt);
Anos := AnoAt - AnoNasc;
Meses := MesAt - Mesnasc;
Dias := DiaAt - DiaNasc;
if (Anos < 0) or ((Anos = 0) and (Meses < 0)) or ((Anos = 0) and (Meses = 0) and (Dias < 0))
then
writeln('Data de nascimento invalida')
else
begin
if Meses < 0
then
begin
Anos := Anos + 1;
Meses := Meses + 12;
end;
if Dias < 0
then
begin
if Meses > 0
then
Meses := Meses – 1
else
begin
Anos := Anos - 1;
Meses := 11;
end;
case MesNasc of
2 : if AnoAt mod 4 = 0
then
Dias := Dias + 29
else
Dias := Dias + 28;
4, 6, 9, 11 : Dias := Dias + 30;
else
Dias := Dias + 31;
end;
end;
write('Uma pessoa que nasceu em ', DiaNasc,'/', Mesnasc,'/', AnoNasc, ' tem na data de ', DiaAt,'/', MesAt,'/', 
AnoAt,' ', Anos, ' anos ', Meses, ' meses ', Dias, ' dias');
end;
end.
8. {Programa que determina a nota mínima de aprovacao}
program NotaMinima;
var Av1, Av2, Av3, Av4, MedBimestral, NotaMin : real;
begin
writeln('Digite as notas das avaliacoes bimestrais');
readln(Av1, Av2, Av3, Av4);
MedBimestral := (Av1 + Av2 + Av3 + Av4)/4;
if (MedBimestral < 7) and (MedBimestral >= 5)
then
begin
NotaMin := (55 - 6 * MedBimestral)/4;
writeln('Um aluno que notas ', Av1:0:2, ', ', Av2:0:2, ', ', Av3:0:2, ' e ', Av4:0:2, ' necessita na prova final de 
uma nota igual a ', NotaMin:0:2);
end
else
writeln('Um aluno que notas ', Av1:0:2, ', ', Av2:0:2, ', ', Av3:0:2, ' e ', Av4:0:2, ' nao faz prova final');
end.
Capítulo 4
1. A configuração da tela após a execução deste programa será
1) 5 15 45
2) 4 12 36
3) 3 9 27
4) 2 6 18
5) 1 3 9
2. {programa que determina a soma dos quadrados dos n primeiros numeros naturais}
program SomaQuadrados;
var n, Soma, i : integer;
begin
writeln('Digite o valor de n');
readln(n);
Soma := 1;
for i := 2 to n do
Soma := Soma + i*i;
writeln('A soma dos quadrados dos ', n, ' primeiros numeros naturais eh ', Soma);
end.
3a. {Programa que calcula a soma dos n primeiros termos da sequencia (1/2, 3/5, 5/8, ...} 
program SomaSerie;
var n, Numerador, Denominador, i : integer;
 Soma : real;
begin
write('Digite o numero de termos a serem somados: ');
readln(n);
Soma := 1/2;
Numerador := 1;
Denominador := 2;
for i := 2 to n do
begin
Numerador
:= Numerador + 2;
 Denominador := Denominador + 3;
 Soma := Soma + Numerador/Denominador;
end;
write('A soma dos ', n,' primeiros termos da sequencia (1/2, 3/5, 5/8, ...) eh igual a ', Soma);
end.
3b. {programa que calcula a soma dos n primeiros termos da sequencia (1, -1/2, 1/3, -1/4, ...} 
program SomaSerie;
var n, i : integer;
 Soma : real;
begin
write('Digite o numero de termos a serem somados: ');
readln(n);
Soma := 1;
for i := 2 to n do
begin
if i mod 2 = 0
then
Soma := Soma - 1/i
else
Soma := Soma + 1/i;
end;
write('A soma dos ', n,' primeiros termos da sequencia (1, -1/2, 1/3, -1/8,...) eh igual a ', Soma);
end.
4. {Programa para determinar o minimo multiplo comum de dois numeros positivo}
program MinMultComum;
var a, b, x, y, Mmc : integer;
begin
writeln('Digite os dois numeros ');
readln( x, y);
a := x;
b := y;
if x < y
then
 begin
a := y;
b := x;
 end;
Mmc := a;
while Mmc mod b <> 0 do
Mmc := Mmc + a;
writeln('mmc(', x,', ', y,') = ', Mmc);
end.
5. {Programa que determina os numeros perfeitos menores que um inteiro dado}
program NumerosPerfeitos;
var Soma, Divisor, n, i, j : integer;
begin
write('Digite o valor de n: ');
readln(n);
writeln('Os numeros perfeitos menores que ', n, ' sao: ');
for i := 2 to n do
begin
Soma := 0;
for j := 1 to i div 2 do
if i mod j = 0
then
Soma := Soma + j;
if Soma = i
then
write(i,' ');
end;
end.
6. {Programa que determina numeros com quatro algarismos com uma propriedade especial}
program PropriedadeEspecial;
var Dezena, Unidade, i : integer;
begin
writeln('Numeros da forma ABCD tais que (AB + BC)*(AB + BC) = ABCD :');
for i := 1000 to 9999 do
begin
Dezena := i div 100;
Unidade := i mod 100;
if Sqr(Dezena + Unidade) = i
then
write(i, ' ');
end;
end.
7. {Programa que determina pares de numeros da forma AB e XY tais que AB*XY = BA*YX}
program PropriedadeEspecial;
var i, j, Invi, Invj : integer;
begin
writeln('Pares de numeros da forma AB e XY tais que AB*XY = BA*YX');
for i := 10 to 99 do
begin
Invi := (i mod 10)*10 + i div 10;
for j := 10 to 99 do
begin
Invj := (j mod 10)* 10 + j div 10;
if i * j = Invi * Invj
then
writeln(i, ' ',j);
end;
end;
end.
8. {Programa que determina o numero de algarismos de um numero}
program NumeroAlgarismos;
var Num, x, NumAlgarismos, i : integer;
begin
writeln('Digite um inteiro'); readln(Num);
x := Num; NumAlgarismos := 1;
while x >= 10 do
begin
 NumAlgarismos := NumAlgarismos + 1;
x := x div 10;
end;
writeln(Num, ' possui ', NumAlgarismos, ' algarismos');
end.
9. {Programa que verifica se um inteiro eh produto de dois primos}
program ProdutoDePrimos;
var Num, Fator1, Fator2, i : integer;
 Raiz : real;
begin
writeln('Digite um inteiro');
readln(Num);
Raiz := SqrT(Num);
Fator1 := 2;
while (Num mod Fator1 <> 0) and (Fator1 <= Raiz) do
Fator1 := Fator1 + 1;
if Fator1 <= Raiz
then
begin
Fator2 := Num div Fator1;
Raiz := SqrT(Fator2);
i := 2;
while (Fator2 mod i <> 0) and (i <= Raiz) do
i := i + 1;
if i <= Raiz
then
writeln(Num, ' nao eh produto de dois primos')
else
writeln(Num, ' eh o produto dos primos ', Fator1, ' e ', Fator2);
end
else
writeln(Num, ' eh primo');
end.
10.{Programa que determina a decomposicao em fatores primos de um inteiro }
program DecomposicaoEmFatoresPrimos;
var Num, x, Fator, Mult : integer;
begin
writeln('Digite um inteiro');
readln(Num);
x := Num;
writeln('Decomposicao em fatores de ', Num,':');
Fator := 2;
while x > 1 do
begin
Mult := 0;
while x mod Fator = 0 do
begin
Mult := Mult + 1;
x := x div Fator;
end;
if Mult > 0
then
writeln('Fator: ', Fator, ' Multiplicidade: ', Mult);
Fator := Fator + 1;
end;
end.
11. {Programa que transforma o computador numa urna eletronica}
program UrnaEletronica;
var Voto, Alibaba, Alcapone, Brancos, Nulos : integer;
 Cont, Conf : char;
 Corrige : boolean;
begin
Cont := 'S';
Alibaba := 0; Alcapone := 0; Brancos := 0; Nulos := 0;
while UpCase(Cont) = 'S' do
begin
repeat
Corrige := false;
writeln('Digite seu voto');
readln(Voto);
case Voto of
83 : begin
writeln('Voce votou em Alibaba. Confirma seu voto (S/N)?');
readln(Conf);
if UpCase(Conf) = 'S'
then
begin
Alibaba := Alibaba + 1;
writeln('Voto confirmado! Obrigado!');
end
else
Corrige := true;
end;
93 : begin
writeln('Voce votou em Alcapone. Confirma seu voto (S/N)?');
readln(Conf);
if UpCase(Conf) = 'S'
then
begin
Alcapone := Alcapone + 1;
writeln('Voto confirmado! Obrigado!');
end
else
Corrige := true;
end;
00 : begin
writeln('Voce votou em branco. Confirma seu voto (S/N)?');
readln(Conf);
if UpCase(Conf) = 'S'
then
begin
Brancos := Brancos + 1;
writeln('Voto confirmado! Obrigado!');
end
else
Corrige := true;
end;
else
begin
writeln('Voce anulou seu votou. Confirma seu voto (S/N)?');
readln(Conf);
if UpCase(Conf) = 'S'
then
begin
Nulos := Nulos + 1;
writeln('Voto confirmado! Obrigado!');
end
else
Corrige := true;
end;
end;
until Corrige = false;
writeln('Novo eleitor (S/N)?');
readln(Cont);
end;
writeln('Resultado da eleicao');
writeln(' Alibaba: ', Alibaba);
writeln(' Alcapone: ', Alcapone);
writeln(' Brancos: ', Brancos);
writeln(' Nulos: ', Nulos);
writeln;
writeln;
write('Candidato eleito: ');
if Alibaba > Alcapone
then
writeln('Alibaba')
else
if Alibaba < Alcapone
then
writeln('Alcapone')
else
writeln('Eleicao empatada');
end.
12. {Programa que determina o n-esimo termo da sequencia de Fibbonaci (1, 1, 2, 3, 5, 8, ...)}
program Fibbonaci;
var n, Anterior1, Anterior2, Termo, i: integer;
begin
writeln('Digite o valor de n');
readln(n);
Anterior1 := 1; Anterior2 := 1; Termo := 1;
for i := 3 to n do
begin
Termo := Anterior1 + Anterior2;
Anterior1 := Anterior2;
Anterior2 := Termo;
end;
writeln('O termo de ordem ', n,' da sequencia de Fibbonaci eh ', Termo);
end.
13. {Programa que determina o troco otimo de uma compra}
program TrocoOtimo;
var Pagamento, x, Compra, Troco: real;
i, Reais, Nota, NumNotas, Centavos, Moeda, NumMoedas: integer;
begin
writeln('Digite o valor da compra');
readln(Compra);
writeln('Digite o valor do pagamento');
readln(Pagamento);
Troco := Pagamento - Compra;
if Troco > 0
then
begin
writeln('Troco de R$ ', Troco:0:2, ' assim distribuido: ');
{Tratamento da parte inteira do troco}
Reais := Trunc(Troco);
Nota := 100;
i := 1;
while Reais > 0 do
begin
NumNotas := Reais div Nota;
if NumNotas > 0
then
begin
writeln(' ', NumNotas, ' notas de ', Nota, ' reais');
Reais := Reais mod Nota;
end;
if i mod 2 = 1
then
Nota := Nota div 2
else
Nota := Nota div 5;
i := i + 1;
end;
{tratamento dos centavos}
Troco := Frac(Troco);
Centavos := Trunc(100 * Troco);
Moeda := 50;
while Centavos > 0 do
begin
NumMoedas := Centavos div Moeda;
if NumMoedas > 0
then
begin
writeln(' ', NumMoedas,' moedas de ', Moeda, ' Centavos');
Centavos := Centavos mod moeda;
end;
if Moeda mod 10 = 0
then
Moeda := Moeda div 2
else
if Moeda = 25
then
Moeda := 10
else
Moeda := 1;
end;
end
else
if Troco = 0
then
writeln('Nao ha troco')
else
writeln('Pagamento insuficiente');
end.
14. {Programa que determina o numero de termos da serie harmonica que devem ser somados para que a soma seja maior que um 
real dado}
program SerieHarmonica;
var i : integer;
k, Soma : real;
begin
writeln('Digite o valor de k');
readln(k);
Soma := 1;
i := 1;
while Soma <= k do
begin
 i := i + 1;
 Soma := Soma + 1/i;
end;
write('O numero minimo de termos da serie harmonica que devem');
writeln(' ser somados para que a soma seja
maior que ', k, ' e ', i);
end.
15. {Programa que exibe os subconjuntos, com tres elementos do conjunto {1, 2, ..., n), n dado}
program SubConj3;
var n, i, j, k: integer;
begin
writeln('Digite o valor de n');
readln(n);
if n >= 3
then
begin
writeln('Subconjuntos, com tres elementos, do conjunto {1, 2, ...,',n,'}');
for i := 1 to n - 2 do
for j := i + 1 to n - 1 do
for k := j + 1 to n do
writeln('{',i, ', ', j, ', ', k, '}');
end
else
writeln('O valor de n deve ser maior que 2');
end.
16. {Programa que exibe os pares de numeros amigos menores que um inteiro dado}
program NumerosAmigos;
var Somai, Somak, Divisor, n, i, k, j : integer;
begin
write('Digite o valor de n: ');
readln(n);
writeln('Os numeros amigos menores que ', n, ' sao: ');
for i := 2 to n do
begin
Somai := 0;
for j := 1 to i div 2 do
if i mod j = 0
then
Somai := Somai + j;
for k := 2 to i - 1 do
begin
Somak := 0;
for j := 1 to k div 2 do
if k mod j = 0
then
Somak := Somak + j;
if (Somai = k) and (Somak = i)
then
writeln(i,' ',k);
end;
end;
end.
Capítulo 5
1. {Funcao que retorna o k-ésimo digito de um inteiro}
function DigitoK(n, k : integer) : integer;
var p : integer;
{Funcao que retorna o numero de algarismos de um inteiro positivo}
function NumAlgarismos(x : integer) : integer;
var NumAlg : integer;
begin
NumAlg := 1;
while x >= 10 do
begin
NumAlg := NumAlg + 1;
x := x div 10;
end;
NumAlgarismos := NumAlg
end;
{Comandos da funcao}
begin
if k <= NumAlgarismos(n)
then
begin
p := Trunc(Exp(k * Ln(10)));
n := n mod p;
DigitoK := n div (p div 10);
end
else
DigitoK := 0;
end;
2. {Funcao iterativa que calcula o fatorial impar de um inteiro}
function FatImpar(m : integer) : longint;
var f : longint;
i : integer;
begin
f := 1;
i := 1;
while i <= m do
begin
f := f*i;
i := i + 2;
end;
FatImpar := f;
end;
{Funcao recursiva para a determinacao do fatorial impar}
function FatImparRec(m : integer) : longint;
begin
if m = 1
then
FatImparRec := 1
else
FatImparRec := m * FatImparRec(m - 2);
end;
3. {Funcao que determina o fatorial primo de um numero primo}
function FatPrimo(m : integer) : longint;
var f : longint;
i : integer;
{Funcao que verifica se um numero eh primo}
function Primo(m : integer) : boolean;
var i : integer;
Raiz : real;
begin
i := 2;
Raiz := SqrT(m);
while (m mod i <> 0) and (i <= Raiz) do
i := i + 1;
if i <= Raiz
then
Primo := false
else
Primo := true;
end;
{Comandos da funcao}
begin
f := 2;
for i := 3 to m do
if Primo(i)
then
f := f * i;
FatPrimo := f;
end;
4. {Funcao que determina a soma dos algarismos de um inteiro}
function SomaAlgarismos(m : integer) : integer;
var Soma : integer;
begin
Soma := 0;
while m > 0 do
begin
Soma := Soma + m mod 10;
m := m div 10;
end;
SomaAlgarismos := Soma;
end;
5. {Funcao recursiva que retorna o n-esimo termo da sequencia de Fibbonaci}
function FibbRec(n : integer) : integer;
begin
if (n = 1) or (n = 2)
then
FibbRec := 1
else
FibbRec := FibbRec(n - 1) + FibbRec(n - 2)
end;
6. {Funcao para inverter um numero inteiro}
function InverteNumero(n : integer) : longint;
var i, NAlgarismos : integer;
Invertido : longint;
{Funcao para determinar o numero de algarismos de um numero inteiro}
function NumeroAlgarismos(n : integer) : integer;
var NumAlgarismos: integer;
begin
NumAlgarismos := 1;
while n >= 10 do
begin
NumAlgarismos := NumAlgarismos + 1;
n := n div 10;
end;
NumeroAlgarismos := NumAlgarismos;
end;
{Funcao para calcular potencias de dez}
function PotenciaDe10(e : integer) : longint;
var Pot : longint;
i : integer;
begin
Pot := 1;
for i := 1 to e do
Pot := Pot*10;
PotenciaDe10 := Pot;
end;
{Inicio da funcao InverteNumero}
begin
Invertido := 0;
NAlgarismos := NumeroAlgarismos(n);
for i := NAlgarismos - 1 downto 0 do
begin
Invertido := Invertido + (n mod 10) * PotenciaDe10(i);
n := n div 10;
end;
InverteNumero := Invertido;
end;
Capítulo 6
1. {Procedimento que exibe um vetor na ordem inversa}
procedure EscreveVetorNaOrdemInversa(var v : TVetor; t : integer);
var i : integer;
begin
for i := t downto 1 do
write(v[i],' ');
end;
2. {Funcao que verifica se um vetor eh palindromo}
function Palindromo(v : TVetor; t : integer) : boolean;
var i : integer;
begin
i := 1;
while (v[i] = v[t - i + 1]) and (i <= t div 2) do
i := i + 1;
if i > t div 2
then
Palindromo := true
else
Palindromo := false;
end;
3. {Procedimento que intercala dois vetores}
procedure IntercalaVetores(var v1, v2, v :TVetor; t : integer) 
var i : integer;
begin
for i := 1 to 2*t do
if i mod 2 = 1
then 
v[i] := v1[(i+1) div 2]
else
v[i] := v2[i div 2]
end.
4. {Procedimento que decompoe um vetor de inteiro em dois vetores, um com as componentes impares e outro com as componentes 
pares}
procedure DecompoeVetorParesImpares(var v, v1, v2 : TVetor; t : integer; var k, l : integer);
var i : integer;
begin
k := 0; 
l := 0;
for i := 1 to t do
if v[i] mod 2 = 1
then
begin
k := k + 1; 
v1[k] := v[i];
end
else
begin
l := l + 1; 
v2[l] := v[i];
end;
end;
5. {Funcao que determina a norma de um vetor}
function Norma(var v : TVetor; t : integer) : real;
var i : integer;
SomaQuadrados : real;
begin
SomaQuadrados := 0;
for i := 1 to t do
SomaQuadrados := SomaQuadrados + Sqr(v[i]);
Norma := SqrT(SomaQuadrados);
end;
6. {Funcao que determina o produto escalar de dois vetores}
function ProdEscalar(var v1, v2 : TVetor; t : integer) : real;
var i : integer;
p : real;
begin
p := 0;
for i := 1 to t do
p := p + v1[i] * v2[i];
ProdEscalar := p;
end;
7. {Procedimento para extrair as componentes distintas de um vetor}
procedure ComponentesDistintas(var v1, v : TVetor; t : integer; var n : integer);
var i, k : integer;
{Funcao que verifica se um valor dado esta armazenado num vetor}
function PesquisaSequencial(var v : TVetor; t : integer; x : real) : boolean;
var j : integer;
begin
PesquisaSequencial := false;
j := 1;
while (v[j] <> x) and (j < t) do
j := j + 1;
if v[j] = x
then
PesquisaSequencial := true;
end;
begin
n := 1;
v[1] := v1[1];
for i := 2 to t do
if not PesquisaSequencial(v, t, v1[i])
then
begin
n := n + 1;
v[n] := v1[i];
end;
end;
8. {Funcao para sortear um numero a partir dos ultimos algarismos dos numeros sorteados pela Loteria Federal}
function NumeroPremiado(var v : TVetor) : longint;
var i, Potencia10 : integer;
Num : longint;
begin
Potencia10 := 10000;
Num := (v[5] mod 10) * Potencia10;
for i := 4 downto 1 do
begin
Potencia10 := Potencia10 div 10;
Num := Num + (v[i] mod 10) * Potencia10;
end;
NumeroPremiado := Num;
end;
9. {Procedimento para inserir um valor dado num vetor numa posicao dada}
procedure InserePosicaoDada(var v : TVetor; t : integer; x : real; Pos : integer);
var i : integer;
begin
if Pos <= t
then
begin
for i := t downto Pos do
v[i + 1] := v[i];
v[Pos] := x;
end
else
writeln('O sistema nao pode fazer a insercao solicitada');
end;
10. {Procedimento para inserir um valor dado num vetor ordenado de modo que ele se mantenha ordenado}
procedure InsereOrdenado(var v : TVetor; t : integer; x : real);
var i, j : integer;
begin
i := 1;
while (v[i] < x) and (i <= t) do
i := i + 1;
for j := t downto i do
v[j + 1] := v[j];
v[i] := x;
end;
11. {Procedimento que exclui uma componente de um vetor}
procedure DeletaComponente(var v : TVetor; var t : integer; c : integer);
var i, j: integer;
begin
if c > t
then 
writeln('Nao existe componente de ordem ',c)
else
begin
for j := c to t do
v[j] := v[j + 1];
t := t - 1;
end;
end;
12. {Procedimento para extrair componentes comuns dois vetores}
procedure CompComuns(var
v1, v2, v : TVetor; t1, t2 : integer; var m : integer);
var k, l : integer;
{Funcao que verifica se um valor dado e componente de um vetor}
function PesquisaSequencial(var v : TVetor; t : integer; x : real) : boolean;
var j : integer;
begin
PesquisaSequencial := false;
j := 1;
while (v[j] <> x) and (j < t) do
j := j + 1;
if v[j] = x
then
PesquisaSequencial := true;
end;
begin
m := 0;
for k := 1 to t1 do
if PesquisaSequencial(v2, t2, v1[k])
then
begin
m := m + 1;
v[m] := v1[k];
end;
end;
13. {Procedimento que retorna a maior diferenca entre as componentes consecutivas de um vetor)
procedure MaiorDiferenca( var v : TVetor; t : integer; var Mai : real; var Comp : integer);
var Diferencas : TVetor;
k : integer;
{Funcao que retorna a maior componente de um vetor e a sua posicao no vetor}
function MaiorElemento(var v : TVetor; t : integer; var Pos : integer) : real;
var i : integer;
 Maior : real;
begin
Maior := v[1]; Pos := 1;
for i := 1 to t do
if v[i] > Maior
then
begin
Maior := v[i];
Pos := i;
end;
MaiorElemento := Maior;
end;
begin
for k := 1 to t - 1 do
Diferencas[k] := v[k + 1] - v[k];
Mai := MaiorElemento(Diferencas, t - 1, Comp);
end;
14. {Funcao para corrigir um teste de multipla escolha}
function CorrigeTeste(var v1, v2 : TVetor; t : integer): integer;
var i, NumPontos : integer;
begin
NumPontos := 0;
for i := 1 to t do
if v1[i] = v2[i]
then 
NumPontos := NumPontos + 1;
CorrigeTeste := NumPontos;
end;
15. {Programa para determinar o valor numerico de um polinomio}
program ValorNumericoDePolinomio;
type TPolinomio = array[1..50] of real;
var Polinomio : TPolinomio;
Grau : integer;
x, VNumerico : real;
{Procedimento para armazenar os coeficientes de um polinomio num vetor}
procedure ArmazenaPolinomio(var p : TPolinomio; var g : integer);
var i : integer;
begin
writeln('Digite o grau do polinomio');
readln(g);
writeln('Digite os coeficientes');
for i := 1 to g + 1 do
readln(p[i]);
end;
{Procedimento que exibe os coeficientes de um polinomio}
procedure ExibeCoeficientes(var v : TPolinomio; g : integer);
var i : integer;
begin
for i := 1 to g + 1 do
write(v[i]:0:2, ' ');
end;
{Funcao que calcula o valor numerico de um polinomio}
function ValorNumerico(var p : TPolinomio; g : integer; x : real) : real;
var i : integer;
ValNum : real;
function Potencia(b : real; e : integer) : real;
var i : integer;
Pot : real;
begin
Pot := 1;
for i := 1 to e do
Pot := Pot*b;
Potencia := Pot
end;
begin
ValNum := p[g + 1];
for i := g downto 1 do
ValNum := ValNum + p[i]*Potencia(x, g - i + 1);
ValorNumerico := ValNum;
end;
{Programa principal}
begin
ArmazenaPolinomio(Polinomio, Grau);
writeln('Digite o valor da variavel independente');
readln(x);
VNumerico := ValorNumerico(Polinomio, Grau, x);
writeln('O valor numerico do polinomio de grau ', Grau, ' e coeficientes ');
ExibeCoeficientes(Polinomio, Grau);
writeln;
writeln('para x = ', x:0:2 , ' eh igual a ', VNumerico:0:2);
end.
16. {Funcao para converter um numero do sistema decimal para o sistema binario}
function DecimalBinario(n : integer) : longint;
var DigBinarios : TVetor;
Binario : longint;
i, j : integer;
{Funcao para calcular potencias de dez}
function PotenciaDe10(e : integer) : longint;
var Pot : longint;
i : integer;
begin
Pot := 1;
for i := 1 to e do
Pot := Pot*10;
PotenciaDe10 := Pot;
end;
begin
if n = 0
then
DecimalBinario := 0
else
begin
i := 0;
while n > 0 do
begin
i := i + 1;
DigBinarios[i] := n mod 2;
n := n div 2;
end;
i := i - 1;
Binario := PotenciaDe10(i);
for j := 1 to i do
Binario := Binario + DigBinarios[j] * PotenciaDe10(j - 1);
DecimalBinario := Binario;
end;
end;
17. {Programa que determina a decomposicao em fatores primos de um inteiro}
program DecomposicaoEmFatoresPrimos;
type TMatriz = array[1..13, 1..2] of integer;
var Num, NFatores : integer;
Decomp : TMatriz;
{Procedimento para exibir uma matriz}
procedure ExibeMatriz(var m : TMatriz; l, c : integer);
var i, j : integer;
begin
for i := 1 to l do
begin
for j := 1 to c do
write(m[i, j],' ');
writeln;
end;
end;
{Procedimento para armazenar numa matriz a decomposicao em fatores de um inteiro}
procedure DecompFatores(x : integer; var m : TMatriz; var n : integer);
var Fator, Mult : integer;
begin
n := 0;
Fator := 2;
while x > 1 do
begin
Mult := 0;
while x mod Fator = 0 do
begin
Mult := Mult + 1;
x := x div Fator;
end;
if Mult > 0
then
begin
n := n + 1;
m[n, 1] := Fator;
m[n, 2] := Mult;
end;
Fator := Fator + 1;
end;
end;
{Programa principal}
begin
writeln('Digite um inteiro');
readln(Num);
writeln('Decomposicao em fatores de ', Num,':');
DecompFatores(Num, Decomp, NFatores);
ExibeMatriz(Decomp, NFatores, 2);
end.
18. {Programa que determina a media de um aluno da UFAL}
program Avaliacao;
type TVetor = array[1..4] of real;
var Notas : TVetor;
MedBimestral, ProvaFinal, MedFinal : real;
{Procedimento para armazenar as notas}
procedure ArmazenaNotas(var v : TVetor);
var i : integer;
begin
writeln('Digite as notas das avaliacoes bimestrais');
for i := 1 to 4 do
readln(v[i]);
end;
{Funcao para calcular a media das notas bimestrais}
function Media(var v : TVetor) : real;
var i : integer;
Soma : real;
begin
Soma := 0;
for i := 1 to 4 do
Soma := Soma + v[i];
Media := Soma/4;
end;
{Procedimento para determinar a menor nota bimestral e o bimestre em que isto ocorreu}
procedure MenorNota(var v : TVetor; var m : real; var b : integer);
var i : integer;
begin
m := v[1];
b := 1;
for i := 2 to 4 do
if v[i] < m
then
begin
m := v[i];
b := i;
end;
end;
{Procedimento para substituir a menor nota menor que 7 pela reavaliacao}
procedure Reavaliacao(var v : TVetor);
var MenNota, NotaReav : real;
Bim : integer;
Resp : char;
begin
MenorNota(Notas, MenNota, Bim);
if MenNota < 7
then
begin
writeln('O aluno fez reavaliacao (S/N)?');
readln(Resp);
if UpCase(Resp) = 'S'
then
begin
writeln('Digite a nota da reavaliacao');
readln(NotaReav);
v[Bim] := NotaReav;
end;
end;
end;
{Programa principal}
begin
ArmazenaNotas(Notas);
Reavaliacao(Notas);
MedBimestral := Media(Notas);
MedFinal := MedBimestral;
if (MedBimestral < 7) and (MedBimestral >= 5)
then
begin
writeln('Digite a nota da prova final');
readln(ProvaFinal);
MedFinal := (MedBimestral * 6 + ProvaFinal * 4)/10;
end;
if MedFinal >= 5.5
then
writeln('Aluno aprovado com media final igual a ', MedFinal:0:2)
else
writeln('Aluno reprovado com media final igual a ', MedFinal:0:2);
end.
19. {Procedimento que retorna a transposta de uma matriz}
procedure Transposta(var Mat, Transp : TMatriz; m, n : integer);
var i, j : integer;
begin
for i := 1 to m do
for j := 1 to n do
Transp[j, i] := Mat[i, j];
end;
20. {Procedimento para permutar duas linhas de uma matriz}
procedure PermutaLinhas(var Mat : TMatriz; m, n, l, c : integer);
var i, j : integer;
Aux : TMatriz;
begin
Aux[1] := Mat[l];
Mat[l] := Mat[c];
Mat[c] := Aux[1];
end;
21. {Funcao que verifica se uma matriz quadrada e triangular}
function MatrizTriangular(var Mat : TMatriz; n : integer) : boolean;
var i, j : integer;
Triangular : boolean;
begin
Triangular := true;
i := 1;
while Triangular and (i <= n) do
begin
j := i + 1;
while Triangular and (j <= n) do
if Mat[i, j] <> 0
then
Triangular := false
else
j := j + 1;
i := i + 1;
end;
MatrizTriangular := Triangular;
end;
22. {Funcao que verifica se uma matriz quadrada eh simetrica}
function MatrizSimetrica(var Mat : TMatriz; n : integer) : boolean;
var i, j : integer;
Simetrica : boolean;
begin
Simetrica := true;
i := 1;
while Simetrica and (i <= n) do
begin
j := i + 1;
while Simetrica
and (j <= n) do
if Mat[i, j] <> Mat[j, i]
then
Simetrica := false
else
j := j + 1;
i := i + 1;
end;
MatrizSimetrica := Simetrica;
end;
23. {Procedimento para multiplicar duas matrizes}
procedure MultiplicaMatrizes(var Mat1, Mat2, Mat : TMatriz; m1, n1, m2, n2 : integer);
var i, j, k : integer;
begin
if n1 = m2
then
begin
for i := 1 to m1 do
for j := 1 to n2 do
begin
Mat[i, j] := 0;
for k := 1 to n1 do
Mat[i, j] := Mat[i, j] + Mat1[i, k]*Mat2[k, j];
end;
end
else
writeln('Produto nao definido');
end;
24. {Programa para determinar os menores elementos de cada uma das linhas de uma matriz}
program MenoresElementos;
type TMatriz = array [1..10, 1..10] of integer;
var Matriz: TMatriz;
NumLinhas, NumColunas : integer;
procedure ArmazenaTabela(var Mat : TMatriz; m, n : integer);
var i, j : integer;
begin
writeln('Digite, por linha, os elementos da matriz');
for i := 1 to m do
for j := 1 to n do
readln(Mat[i, j]);
end;
procedure ExibeTabela(var Mat : TMatriz; m, n : integer);
var i, j : integer;
begin
for i := 1 to m do
begin
for j := 1 to n do
write(Mat[i, j],' ');
writeln;
end;
end;
procedure MenorElemento(var Mat : TMatriz; m, n : integer);
var i, j, Col, Menor : integer;
begin
for i := 1 to m do
begin
Menor := Mat[i, 1];
Col := 1;
for j := 2 to n do
if Mat[i, j] < Menor
then
begin
Menor := Mat[i, j];
Col := j;
end;
writeln(' ', i,' ', Menor, ' ', Col);
end;
end;
{Programa principal}
begin
writeln('Digite a ordem da matriz');
readln(NumLinhas, NumColunas);
ArmazenaTabela(Matriz, NumLinhas, NumColunas);
writeln('Tabela');
ExibeTabela(Matriz, NumLinhas, NumColunas);
writeln('Linha Menor Elemento Coluna');
MenorElemento(Matriz, NumLinhas, NumColunas);
end.
25. {Programa para determinar escalas de viagens aereas}
program EscalaViagemAerea;
type TMatriz = array[1..30, 1..30] of integer;
var Distancias : TMatriz;
 NumCidades, Orig, Dest, Escal : integer;
{Procedimento para armazenar as distancias entre as cidades}
procedure ArmazenaDistancias(var Mat : TMatriz; m : integer);
var i, j : integer;
begin
writeln('Digite as distancias entre as cidades');
for i := 1 to m do
for j := i to m do
if i = j
then
Mat[i, j] := 0
else
begin
readln(Mat[i][j]);
Mat[j][i] := Mat[i][j];
end;
end;
{Procedimento para exibir a tabela das distancias entre as cidades}
procedure ExibeDistancias(var Mat : TMatriz; m : integer);
var i, j : integer;
begin
writeln('Tabela de distancias entre as cidades');
for i := 1 to m do
begin
for j := 1 to m do
write(Mat[i, j]:8);
writeln;
end;
end;
{Funcao que determina a cidade onde deve ocorrer a escala}
function Escala(var Mat : TMatriz; m, Orig, Dest : integer) : integer;
var i, j, Menor, Esc : integer;
begin
Menor := Mat[Orig, 1] + Mat[1, Dest];
Esc := 1;
for i := 2 to m do
if (Mat[Orig, i] + Mat[i, Dest] < Menor) and (i <> Orig) and (i <> Dest)
then
begin
Menor := Mat[Orig, i] + Mat[i, Dest];
Esc := i;
end;
Escala := Esc;
end;
{Programa principal}
begin
writeln('Digite o numero de cidades');
readln(NumCidades);
ArmazenaDistancias(Distancias, NumCidades);
ExibeDistancias(Distancias, NumCidades);
writeln('Digite a origem e o destino');
readln(Orig, Dest);
if Distancias[Orig, Dest] > 400
then
begin
if Orig < Dest
then
Escal := Escala(Distancias, NumCidades, Orig, Dest)
else
Escal := Escala(Distancias, NumCidades, Dest, Orig);
writeln('Escala entre as cidades ', Orig, ' e ', Dest, ': ', Escal)
end
else
if Distancias[Orig, Dest] = 0
then
writeln('Origem e destino iguais')
else
writeln('A viagem entre as cidades ', Orig, ' e ', Dest, ' deve ser feita sem escala');
end.
26. {Procedimento que exibe as combinações dos números 1, 2, ..., n, tomadas k a k. O parâmetro i controla o número de comandos 
for e o parâmetro s controla o limite inferior de cada um destes comandos. Os parâmetros i e s recebem argumentos iguais a 1 (um) 
quando da ativação da função. }
procedure Comb(n, k, i, s : integer);
var m, j : integer;
begin
if i <= k
then
begin
for j := s to n - k + i do
begin
v[i] := j; {v deve ser uma variável global do tipo vetor}
s := j + 1;
Comb(n, k, i + 1, s);
if i = k
then
begin
for m := 1 to k do
write(v[m],' ');
writeln;
end;
end;
end;
end;
Capítulo 7
1. {Programa para verificar se uma cadeia de caracteres é palindromo}
program palindromo;
var St : string;
 i, Comp : integer;
begin
writeln('Digite a palavra');
readln(St);
Comp := Length(St);
i := 1;
while (St[i] = St[Comp - i + 1]) and (i <= Comp div 2) do
i := i + 1;
if i > Comp div 2
then
writeln(St,' eh palindromo')
else
writeln(St,' nao eh palindromo');
end.
2. {Programa para determinar o número de palavras de uma frase}
program ContaPalavras;
var Frase : string;
{Funcao para determinar a posicao da primeira letra de uma frase}
function PrimeiraLetra(var s : string): integer;
var i : integer;
begin
i := 1;
while s[i] = ' ' do
i := i + 1;
PrimeiraLetra := i;
end;
{Funcao para determinar o numero de palavras de uma frase}
function ContaPalavras(var s : string): integer;
var i, j, k, c : integer;
begin
c := Length(s);
i := PrimeiraLetra(s);
if i > c
then j := 0
else j := 1;
for k := i to c do
if (s[k] = ' ') and (s[k-1] <> ' ')
then
j := j + 1;
ContaPalavras := j;
end;
{programa principal}
begin
write('Digite a frase: '); readln(Frase);
writeln('Número de palavras: ', ContaPalavras(Frase));
end.
3. {Funcao que converte um inteiro do sistema decimal para o sistema binario, tratando o numero do sistema binario como uma 
string}
function DecimalBinario(n : integer) : string;
var s, Binario : string;
i, j : integer;
begin
i := 0;
if n = 0
then
DecimalBinario := '0'
else
begin
Binario := '';
while n > 0 do
begin
i := i + 1;
Str(n mod 2, s);
n := n div 2;
Binario := s + Binario;
end;
DecimalBinario := Binario;
end;
end;
4. {Programa para converter o numero do sistema binario, dado como uma string, para o sistema decimal}
program ConverteBinarioEmDecimal;
var Decimal : integer;
 Binario : string;
 j, c, n, r : integer;
{Funcao que calcula potencias de 2}
function potenciaDe2(e : integer) : integer;
var p, i : integer;
begin
p := 1;
for i := 1 to e do
p := 2*p;
potenciaDe2 := p;
end;
{Programa principal}
begin
writeln('Digite o numero do sistema binário');
readln(Binario);
c := Length(Binario);
Decimal := 0;
for j := 1 to c do
begin
Val(Binario[j], n, r);
Decimal := Decimal + n*potenciaDe2(c - j);
end;
writeln(Binario, ' no sistema decimal: ', Decimal);
end.
5. {Funcao para verificar se uma conta dada nao foi digitada incorretamente}
function VerificaConta( s : string) : boolean;
type TVetor = array[1..20] of byte;
var c : integer;
Digito : string;
{Procedimento para armazenar os digitos da conta}
procedure ArmazenaDigitos(var s : string; var d : TVetor; t : integer);
var j, r : integer;
begin
for j := 1 to t do
Val(s[j], d[j], r);
end;
{Funcao para determinar o digito verificador}
Function DigitoVerificador(s : string) : integer;
var i, Comp, Soma, Dv : integer;
Digitos : TVetor;
begin
Comp := Length(s) - 1;
ArmazenaDigitos(s, Digitos, Comp);
Soma := 0;
for i := Comp downto 1 do
Soma := Soma + Digitos[i]*(Comp - i + 2);
Dv := 11 - Soma mod 11;
if (Dv = 10) or (Dv = 11)
then
Dv := 0;
DigitoVerificador := Dv;
end;
{Inicio da funcao VerificaConta}
begin
c := Length(s);
Str(DigitoVerificador(s), Digito);
if s[c] = Digito[1]
then
VerificaConta := true
else
VerificaConta := false;
end;
6. {Funcao para determinacao do digito verificador de codigos de barra}
function DigitoVerificador( s : string) : integer;
type TVetor
= array[1..20] of byte;
var i, Comp, Soma, Dv : integer;
Digitos : TVetor;
{Procedimento para armazenar os digitos da conta}
procedure ArmazenaDigitos(var s : string; var d : TVetor; t : integer);
var j, r : integer;
begin
for j := 1 to t do
Val(s[j], d[j], r);
end;
{Inicio da funcao DigitoVerificador}
begin
Comp := Length(s);
ArmazenaDigitos(s, Digitos, Comp);
Soma := 0;
for i := 1 to Comp do
if i mod 2 = 1
then
Soma := Soma + Digitos[i]
else
Soma := Soma + 3*Digitos[i];
Dv := Soma mod 10;
if Dv <> 0
then
Dv := 10 - Dv;
DigitoVerificador := Dv;
end;
7. {Programa para converter um nome proprio no formato Ultimo Sobrenome/Nome}
program FormatoPassagemAerea;
var Nome, Identificacao : string;
{Funcao que retorna a primeira palavra de um texto}
function PrimPalavra(s : string) : string;
var i, c : integer;
PrimPal : string;
begin
c := Length(s);
PrimPal := '';
i := 1;
while (s[i] <> ' ') and (i <= c) do
begin
PrimPal := PrimPal + s[i];
i := i + 1;
end;
PrimPalavra := PrimPal;
end;
{Funcao que retorna a ultima palavra de um texto}
function UltPalavra(s : string) : string;
var i, c : integer;
UltPal : string;
begin
c := Length(s);
UltPal := '';
i := c;
while (s[i] <> ' ') and (i > 0) do
begin
UltPal := s[i] + UltPal;
i := i - 1;
end;
UltPalavra := UltPal;
end;
{Programa principal}
begin
writeln('Digite o nome do passageiro');
readln(Nome);
Identificacao := UltPalavra(Nome) + '/' + PrimPalavra(Nome);
writeln(Identificacao);
end.
8. {Programa para converter um nome proprio para o formato de referencia bibliografica}
program ReferenciaBibliografica
var Nome, Referencia : string;
{Funcao que retorna uma palavra de um texto a partir de uma posicao dada}
function Palavra(s : string; p : integer) : string;
var c : integer;
Pal : string;
begin
c := Length(s);
Pal := '';
while (s[p] <> ' ') and (p <= c) do
begin
Pal := Pal + s[p];
p := p + 1;
end;
Palavra := Pal;
end;
{Funcao para deteccao de particulas de, do, dos, da, das, e}
function Particula(s : string; i : integer) : boolean;
var p : string;
begin
Particula := false;
p := Palavra(s, i + 1);
if (p = 'e') or (p = 'de') or (p = 'do') or (p = 'da') or (p = 'das') or (p = 'dos')
then
Particula := true;
end;
{Funcao que retorna as iniciais dos nomes e sobrenomes}
function PrimLetras(s : string) : string;
var i, c : integer;
PrimLet : string;
begin
c := Length(s);
PrimLet := s[1];
for i := 2 to c do
if (s[i] = ' ') and (s[i + 1] <> ' ') and (not Particula(s, i))
then
PrimLet := PrimLet + '. ' + s[i + 1];
c := Length(PrimLet);
Delete(PrimLet, c - 1, 2);
PrimLetras := PrimLet;
end;
{Funcao que retorna a ultima palavra de um texto}
function UltPalavra(s : string) : string;
var i, c : integer;
UltPal : string;
begin
c := Length(s);
UltPal := ''; i := c;
while (s[i] <> ' ') and (i > 0) do
begin
UltPal := s[i] + UltPal;
i := i - 1;
end;
UltPalavra := UltPal;
end;
{Programa principal}
begin
writeln('Digite o nome do autor');
readln(Nome);
Referencia := UltPalavra(Nome) + ', ' + PrimLetras(Nome);
writeln(Referencia);
end.
Capítulo 8
2. {Programa para reunir dois arquivos}
type TRegistro = record
Mat : string[10];
Nome : string[40];
end;
TArquivo = file of TRegistro;
var a, a1, a2 : TArquivo;
Reg : TRegistro;
Narq1, Narq2, Narq : string[12];
{Funcao que verifica a existencia e um arquivo}
function ExisteArquivo(var f : TArquivo): boolean;
begin
{$I-}
Reset(f);
if IOResult = 0
then ExisteArquivo := true
else ExisteArquivo := false;
{$I+}
end;
{Funcao que verifica se uma matricula já esta cadastrada}
function Consulta(var f : TArquivo; Mat : string) : integer;
var r : TRegistro;
begin
Reset(f);
read(f, r);
while (not Eof(f)) and (r.Mat <> Mat) do
read(f, r);
if r.Mat = Mat
then
Consulta := FilePos(f) – 1
else
Consulta := -1;
end;
{Procedimento que reune dois arquivos}
procedure ReunArq(var f1, f2, f : TArquivo);
var r : TRegistro;
begin
Reset(f1);
Rewrite(f);
while not Eof(f1) do
begin
read(f1, r);
write(f, r);
end;
Reset(f2);
while not Eof(f2) do
begin
read(f2, r);
if Consulta(f, r.Mat) = -1
then
write(f, r);
end;
Close(f1);
Close(f2);
Close(f);
end;
{Programa principal}
begin
writeln('Digite os nomes dos arquivos a serem reunidos');
readln(Narq1);
readln(Narq2);
Assign(a1, Narq1);
if ExisteArquivo(a1)
then
begin
Assign(a2, Narq2);
if ExisteArquivo(a2)
then
begin
writeln('Digite o nome do novo arquivo');
readln(Narq);
Assign(a, Narq);
if not ExisteArquivo(a)
then
ReunArq(a1, a2, a);
else
writeln('Arquivo ', Narq, ' ja existe');
end
else
writeln('Arquivo ', Narq2, ' nao existe');
end
else
writeln('Arquivo ', Narq1, ' nao existe');
end.
3. {Programa para gerar um arquivo com salarios maiores que 5000}
type TRegistro = record
Mat : string[10];
Salario : real;
end;
TArquivo = file of TRegistro;
var Arq, Arq1 : TArquivo;
NomeArquivo1, NomeArquivo : string[12];
procedure AltosSalarios(var f1, f : TArquivo);
var r : TRegistro;
begin
Reset(f1);
Rewrite(f);
while not Eof(f1) do
begin
read(f1, r);
if r.Salario > 5000
then
write(f, r);
end;
end;
{Programa principal}
begin
writeln('Digite o nome do arquivo a ser pesquisado');
readln(NomeArquivo1);
Assign(Arq1, NomeArquivo1);
writeln('Digite o nome do novo arquivo');
readln(NomeArquivo);
Assign(Arq, NomeArquivo);
AltosSalarios(Arq1, Arq);
end.
4. {Procedimento para inclusao de registros num arquivo ordenado, utilizando um arquivo auxiliar}
procedure IncluiRegistroOrdenadoVersao1(var f : TArquivo; r : TRegistro);
var Aux : TArquivo;
Reg : TRegistro;
begin
Reset(f);
Assign(Aux, 'Temp');
Rewrite(Aux);
read(f, Reg);
while (r.Mat > Reg.Mat) and not Eof(f) do
begin
write(Aux, Reg);
read(f, Reg);
end;
if Eof(f)
then
write(Aux, Reg)
else
Seek(f, FilePos(f) - 1);
write(Aux, r);
while not Eof(f) do
begin
read(f, Reg);
write(Aux, Reg);
end;
Close(f);
Close(Aux);
Erase(f);
Rename(Aux, NomeArquivo);
end;
{Procedimento para inclusoes de registros num arquivo ordenado, sem a utilizacao de um arquivo auxiliar}
procedure IncluiRegistroOrdenadoVersao2(var f : TArquivo; r : TRegistro);
var Reg : TRegistro;
i, p, t : integer;
begin
Reset(f);
read(f, Reg);
while (r.Mat > Reg.Mat) and not Eof(f) do
read(f, Reg);
if Eof(f)
then
write(f, Reg)
else
begin
p := FilePos(f) - 1;
t := FileSize(f);
for i := t downto p do
begin
read(f, Reg);
write(f, Reg);
Seek(f, FilePos(f) - 2);
end;
end;
Seek(f, p);
write(f, r);
Close(f);
end;
5. {Procedimento para inserir um arquivo ordenado em outro arquivo ordenado}
procedure InsereOrdenado(var f1, f2 : TArquivo);
var r : TRegistro;
{Procedimento para incluir um registro num arquivo ordenado}
procedure IncluiRegistroOrdenado(var f : TArquivo; r : TRegistro);
var Aux : TArquivo;
Reg : TRegistro;
begin
Reset(f); 
Assign(Aux, 'Temp'); Rewrite(Aux);
read(f, Reg);
while (r.Matr > Reg.Matr) and not Eof(f) do
begin
write(Aux, Reg);
read(f, Reg);
end;
if Eof(f)
then
write(Aux, Reg)
else
Seek(f, FilePos(f) - 1);
write(Aux, r);
while not Eof(f) do
begin
read(f, Reg);
write(Aux, Reg);
end;
Close(f);
Close(Aux);
Erase(f);
Rename(Aux, NomeArquivo);
end;
{Comandos do procedimento InsereOrdenado}
begin
Reset(f1);
Reset(f2);
while not Eof(f1) do
begin
read(f1, r);
IncluiRegistroOrdenado(f2, r);
end;
end;
6. {Procedimento para "cruzamento" de dois arquivos}
procedure RegistrosComuns(var f1, f2, f : TArquivo);
var r : TRegistro;
n : integer;
begin
Reset(f1);
Reset(f2);
Rewrite(f);
while not Eof(f1) do
begin
read(f1, r);
n := Consulta(f2, r.Matr);
if Consulta(f2, r.Matr) <> -1
then
write(f, r);
end;
end;
7. {Procedimento que permuta os conteúdos de dois registros de um arquivo, dados pelos valores do campo Mat}
procedure TrocaRegistro(var f : TArquivo; Mat1, Mat2 : string);
var Reg1, Reg2 : TRegistro;
n1, n2 : integer;
begin
Reset(f);
n1 := Consulta(f, Mat1);
n2 := Consulta(f, Mat2);
Seek(f, n1);
read(f, Reg1);
Seek(f, n2);
read(f, Reg2);
Seek(f, n1);
write(f, Reg2);
Seek(f, n2);
write(f, Reg1);
end;
8. {Programa que exclui os comentarios de um programa em Pascal}
program ExcluiComentario;
var Arq : text;
NomeArquivo : string;
procedure ExcluiComentarios(var f : text);
var s : string;
Aux : text;
c : char;
begin
Reset(f);
Assign(Aux, 'Temp');
Rewrite(Aux);
while not Eof(f) do
begin
read(f, c);
if c <> '{'
then
write(Aux, c)
else
begin
read(f, c);
if c <> '$'
then
while c <> '}' do
read(f, c)
else
begin
write(Aux, '{');
write(Aux, c);
read(f, c);
while c <> '}' do
begin
write(Aux,c);
read(f, c);
end;
write(Aux, '}');
end;
end;
end;
Close(f);
Close(Aux);
Erase(f);
Rename(Aux, NomeArquivo);
end;
{Programa principal}
begin
writeln('Digite o nome do arquivo');
readln(NomeArquivo);
Assign(Arq, NomeArquivo);
ExcluiComentarios(Arq);
end.
Capítulo 9
1. {Funcao que realiza busca no inicio e no fim de um vetor, sucessivamente}
function PesquisaPessimista(var v : TVetor; t : integer; x : real) : integer;
var j : integer;
begin
PesquisaPessimista := -1;
j := 1;
while (v[j] <> x) and (v[t-j+1] <> x) and (j <= t div 2) do
j := j + 1;
if v[j] = x
then
PesquisaPessimista := j
else
if v[t-j+1] = x
then
PesquisaPessimista := t-j+1;
end;
2. {Procedimento que implementa uma versao do SelectSort}
procedure SelectSort1(var v : TVetor; t : integer);
var i, j : integer;
{Procedimento para permutar os conteúdos de duas variáveis}
procedure Troca(var x, y : integer);
begin
x := x + y;
y := x - y;
x := x - y;
end;
[Funcao que retorna o indice da componente de maior valor de um vetor}
function IndiceDoMaiorElemento(var v : TVetor; t : integer) : integer;
var i, k, Maior : integer;
begin
k := 1; Maior := v[1];
for i := 2 to t do
if (v[i] > Maior)
then
begin
Maior := v[i];
k := i;
end;
IndiceDoMaiorElemento := k;
end;
{Comandos do SelectSort}
begin
for i := t - 1 downto 1 do
begin
j := IndiceDoMaiorElemento(v, i);
if v[j] > v[i+1]
then
Troca(v[i+1], v[j]);
end;
end;
3. {Procedimento que implementa o InsertSort}
procedure InsertSort(var v : TVetor; t : integer);
var Aux : TVetor;
i : integer;
{Procedimento que insere um elemento num vetor ordenado}
procedure InsereOrdenado(var v : TVetor; t, r : integer);
var i, j : integer;
begin
i := 1;
while (v[i] < r) and (i <= t) do
i := i + 1;
for j := t downto i do
v[j + 1] := v[j];
v[i] := r;
end;
begin
Aux[1] := v[1];
for i := 2 to t do
InsereOrdenado(Aux, i - 1, v[i]);
v := Aux;
end;
4. {Procedimento para ordenar um arquivo}
procedure OrdenaArquivo(var f : TArquivo);
var r1, r2 : TRegistro;
t, i, n1, n2 : integer;
Tr : boolean;
Procedimento para troca de dois registros}
procedure TrocaRegistro(m1, m2 : integer; var Reg1, Reg2 : TRegistro);
var Aux : TRegistro;
begin
Seek(f, n1);
write(f, Reg2);
Seek(f, n2);
write(f, Reg1);
end;
{Comandos do procedimento OrdenaArquivo}
begin
Reset(f);
t := FileSize(f);
Tr := true;
while Tr do
begin
n2 := 0; Tr := false;
t := t - 1;
for i := 1 to t do
begin
Seek(f, n2);
n1 := FilePos(f);
read(f, r1);
n2 := FilePos(f);
read(f, r2);
if r1.Mat > r2.Mat
then
begin
TrocaRegistro(n1, n2, r1, r2);
Tr := true;
end;
end;
end;
end;
	Programando 
	com Pascal
	Capítulo 1
	1. {programa que implementa a funcao round}
	Capítulo 7
	Capítulo 9