Respostas Pascal Jaime Evaristo

Programando com Pascal

Respostas dos Exercícios Propostos

Jaime EvaristoInstituto de Computação

Universidade Federal de Alagoas

Capítulo 11. 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ção3. 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 73. 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 21a. 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 31. {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

thenArredonda := Trunc(x)

elseArredonda := 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

thenwriteln(x, ' eh quadrado perfeito de raiz quadrada igual a ', Raiz:0:0)

elsewriteln(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)

thenif y > z

thenMaior := y

elseMaior := 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)

thenif (x = y) and (y = z)

thenwriteln('O triangulo de lados ', x, ', ', y, ' eh ', z, 'e equilatero')

elseif (x = y) or (x = z) or (y = z)

thenwriteln('O triangulo de lados ', x, ', ', y, ' eh ', z, ' e isosceles')

elsewriteln('O triangulo de lados ', x, ', ', y, ' eh ', z, ' e escaleno')

elsewriteln('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)

thenbegin

Hip := x;Cat1 := y;Cat2 := z;if (y > Hip) or (z > Hip)

thenif (y > z)

thenbegin

Hip := y;Cat1 := x;

endelse

beginHip := z;Cat2 := x;

end;if Sqr(Hip) = Sqr(Cat1) + Sqr(Cat2)

thenwrite('O triangulo de lados ', x, ', ', y, ' e ', z, ' eh retangulo de hipotenusa ', Hip, ' e catetos ', Cat1, ' e

', Cat2);

elsewriteln('O triangulo de lados ', x, ', ', y, ' e ', z, ' nao e retangulo');

endelse

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

thenbegin

Delta := Sqr(b) - 4*a*c;ParteReal := -b/(2*a);ParteImag := SqrT(abs(Delta))/(2*a);if Delta >= 0

thenbegin

x1 := ParteReal + ParteImag;x2 := ParteReal - ParteImag;writeln('As raizes da equacao dada sao ', x1, ' e ', x2);

endelse

write('As raizes da equacao dada sao complexas: ', ParteReal:0:2,' + ', ParteImag:0:2,'i e ', ParteReal:0:2, ' - ', ParteImag:0:2,'i');

endelse

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))

thenwriteln('Data de nascimento invalida')

elsebegin

if Meses < 0then

beginAnos := Anos + 1;Meses := Meses + 12;

end;if Dias < 0

thenbegin

if Meses > 0then

Meses := Meses – 1else

beginAnos := Anos - 1;Meses := 11;

end;case MesNasc of

2 : if AnoAt mod 4 = 0then

Dias := Dias + 29

elseDias := 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)

thenbegin

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

elsewriteln('Um aluno que notas ', Av1:0:2, ', ', Av2:0:2, ', ', Av3:0:2, ' e ', Av4:0:2, ' nao faz prova final');

end.

Capítulo 41. A configuração da tela após a execução deste programa será

1) 5 15 452) 4 12 363) 3 9 274) 2 6 185) 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

beginNumerador := 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

beginif i mod 2 = 0

thenSoma := Soma - 1/i

elseSoma := 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

beginSoma := 0;for j := 1 to i div 2 do

if i mod j = 0then

Soma := Soma + j;if Soma = i

thenwrite(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

beginDezena := i div 100;Unidade := i mod 100;if Sqr(Dezena + Unidade) = i

thenwrite(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

beginInvi := (i mod 10)*10 + i div 10;for j := 10 to 99 do

beginInvj := (j mod 10)* 10 + j div 10;if i * j = Invi * Invj

thenwriteln(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

thenbegin

Fator2 := Num div Fator1;Raiz := SqrT(Fator2);i := 2;while (Fator2 mod i <> 0) and (i <= Raiz) do

i := i + 1;if i <= Raiz

thenwriteln(Num, ' nao eh produto de dois primos')

elsewriteln(Num, ' eh o produto dos primos ', Fator1, ' e ', Fator2);

endelse

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

beginMult := 0;while x mod Fator = 0 do

beginMult := Mult + 1;x := x div Fator;

end;if Mult > 0

thenwriteln('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;

beginCont := 'S';Alibaba := 0; Alcapone := 0; Brancos := 0; Nulos := 0;while UpCase(Cont) = 'S' do

beginrepeat

Corrige := false;writeln('Digite seu voto');readln(Voto);case Voto of

83 : beginwriteln('Voce votou em Alibaba. Confirma seu voto (S/N)?');readln(Conf);if UpCase(Conf) = 'S'

thenbegin

Alibaba := Alibaba + 1;writeln('Voto confirmado! Obrigado!');

endelse

Corrige := true;end;

93 : beginwriteln('Voce votou em Alcapone. Confirma seu voto (S/N)?');readln(Conf);if UpCase(Conf) = 'S'

thenbegin

Alcapone := Alcapone + 1;writeln('Voto confirmado! Obrigado!');

endelse


00 : beginwriteln('Voce votou em branco. Confirma seu voto (S/N)?');readln(Conf);if UpCase(Conf) = 'S'

thenbegin

Brancos := Brancos + 1;writeln('Voto confirmado! Obrigado!');

endelse


elsebegin

writeln('Voce anulou seu votou. Confirma seu voto (S/N)?');readln(Conf);if UpCase(Conf) = 'S'

thenbegin

Nulos := Nulos + 1;writeln('Voto confirmado! Obrigado!');

endelse


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

thenwriteln('Alibaba')

elseif Alibaba < Alcapone

thenwriteln('Alcapone')

elsewriteln('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

beginTermo := 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

thenbegin

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

beginNumNotas := Reais div Nota;if NumNotas > 0

then

beginwriteln(' ', NumNotas, ' notas de ', Nota, ' reais');Reais := Reais mod Nota;

end;if i mod 2 = 1

thenNota := Nota div 2

elseNota := Nota div 5;

i := i + 1;end;

{tratamento dos centavos}Troco := Frac(Troco);Centavos := Trunc(100 * Troco);Moeda := 50;while Centavos > 0 do

beginNumMoedas := Centavos div Moeda;if NumMoedas > 0

thenbegin

writeln(' ', NumMoedas,' moedas de ', Moeda, ' Centavos');Centavos := Centavos mod moeda;

end;if Moeda mod 10 = 0

thenMoeda := Moeda div 2

elseif Moeda = 25

thenMoeda := 10

elseMoeda := 1;

end;end

elseif Troco = 0

thenwriteln('Nao ha troco')

elsewriteln('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

thenbegin

writeln('Subconjuntos, com tres elementos, do conjunto {1, 2, ...,',n,'}');for i := 1 to n - 2 do

for j := i + 1 to n - 1 dofor k := j + 1 to n do

writeln('{',i, ', ', j, ', ', k, '}');end

elsewriteln('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

beginSomai := 0;for j := 1 to i div 2 do

if i mod j = 0then

Somai := Somai + j;for k := 2 to i - 1 do

beginSomak := 0;for j := 1 to k div 2 do

if k mod j = 0then

Somak := Somak + j;if (Somai = k) and (Somak = i)

thenwriteln(i,' ',k);

end;end;

end.

Capítulo 51. {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

beginNumAlg := NumAlg + 1;x := x div 10;

end;NumAlgarismos := NumAlg

end;{Comandos da funcao}begin

if k <= NumAlgarismos(n)then

beginp := Trunc(Exp(k * Ln(10)));n := n mod p;DigitoK := n div (p div 10);

endelse

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

beginf := 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 = 1then

FatImparRec := 1else

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

thenPrimo := false

elsePrimo := 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

beginSoma := 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 := 1else

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

beginNumAlgarismos := 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}

beginInvertido := 0;NAlgarismos := NumeroAlgarismos(n);for i := NAlgarismos - 1 downto 0 do

beginInvertido := Invertido + (n mod 10) * PotenciaDe10(i);n := n div 10;

end;InverteNumero := Invertido;

end;

Capítulo 61. {Procedimento que exibe um vetor na ordem inversa}

procedure EscreveVetorNaOrdemInversa(var v : TVetor; t : integer);var i : integer;begin

for i := t downto 1 dowrite(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

thenPalindromo := true

elsePalindromo := 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 doif 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 = 1then

begink := k + 1; v1[k] := v[i];

endelse

beginl := 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

thenPesquisaSequencial := true;

end;begin

n := 1;v[1] := v1[1];for i := 2 to t do

if not PesquisaSequencial(v, t, v1[i])then

beginn := 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

beginPotencia10 := 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 <= tthen

beginfor i := t downto Pos do

v[i + 1] := v[i];v[Pos] := x;

endelse

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 > tthen

writeln('Nao existe componente de ordem ',c)else

beginfor 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

thenPesquisaSequencial := true;

end;begin

m := 0;for k := 1 to t1 doif PesquisaSequencial(v2, t2, v1[k])

thenbegin

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] > Maiorthen

beginMaior := v[i];Pos := i;

end;MaiorElemento := Maior;

end;begin

for k := 1 to t - 1 doDiferencas[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 dowrite(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 := 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 := Pot*10;PotenciaDe10 := Pot;

end;begin

if n = 0then

DecimalBinario := 0else

begini := 0;while n > 0 do

begini := 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 dobegin

for j := 1 to c dowrite(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

beginMult := 0;while x mod Fator = 0 do

beginMult := Mult + 1;x := x div Fator;

end;if Mult > 0

thenbegin

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] < mthen

beginm := 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;

beginMenorNota(Notas, MenNota, Bim);if MenNota < 7

thenbegin

writeln('O aluno fez reavaliacao (S/N)?');readln(Resp);if UpCase(Resp) = 'S'

thenbegin

writeln('Digite a nota da reavaliacao');readln(NotaReav);v[Bim] := NotaReav;

end;end;


ArmazenaNotas(Notas);Reavaliacao(Notas);MedBimestral := Media(Notas);MedFinal := MedBimestral;if (MedBimestral < 7) and (MedBimestral >= 5)

thenbegin

writeln('Digite a nota da prova final');readln(ProvaFinal);MedFinal := (MedBimestral * 6 + ProvaFinal * 4)/10;

end;if MedFinal >= 5.5

thenwriteln('Aluno aprovado com media final igual a ', MedFinal:0:2)

elsewriteln('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 dofor 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

beginj := i + 1;while Triangular and (j <= n) do

if Mat[i, j] <> 0then

Triangular := falseelse

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

beginj := i + 1;while Simetrica and (j <= n) do

if Mat[i, j] <> Mat[j, i]then

Simetrica := falseelse

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 = m2then

beginfor i := 1 to m1 do

for j := 1 to n2 dobegin

Mat[i, j] := 0;for k := 1 to n1 do

Mat[i, j] := Mat[i, j] + Mat1[i, k]*Mat2[k, j];end;

endelse

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;

beginwriteln('Digite, por linha, os elementos da matriz');for i := 1 to m do

for j := 1 to n doreadln(Mat[i, j]);

end;procedure ExibeTabela(var Mat : TMatriz; m, n : integer);var i, j : integer;begin

for i := 1 to m dobegin

for j := 1 to n dowrite(Mat[i, j],' ');

writeln;end;

end;procedure MenorElemento(var Mat : TMatriz; m, n : integer);var i, j, Col, Menor : integer;begin


Menor := Mat[i, 1];Col := 1;for j := 2 to n do

if Mat[i, j] < Menorthen

beginMenor := Mat[i, j];Col := j;

end;writeln(' ', i,' ', Menor, ' ', Col);

end;end;


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 doif i = j

thenMat[i, j] := 0

elsebegin

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 j := 1 to m dowrite(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

beginMenor := Mat[Orig, i] + Mat[i, Dest];Esc := i;

end;Escala := Esc;


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

thenbegin

if Orig < Destthen

Escal := Escala(Distancias, NumCidades, Orig, Dest)else

Escal := Escala(Distancias, NumCidades, Dest, Orig);writeln('Escala entre as cidades ', Orig, ' e ', Dest, ': ', Escal)

endelse

if Distancias[Orig, Dest] = 0then

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 <= kthen

beginfor j := s to n - k + i do

beginv[i] := j; {v deve ser uma variável global do tipo vetor}s := j + 1;Comb(n, k, i + 1, s);if i = k

thenbegin

for m := 1 to k dowrite(v[m],' ');

writeln;end;

end;

end;end;

Capítulo 71. {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

thenwriteln(St,' eh palindromo')

elsewriteln(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 := 0else j := 1;

for k := i to c doif (s[k] = ' ') and (s[k-1] <> ' ')

thenj := 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

thenDecimalBinario := '0'

elsebegin

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;

beginp := 1;for i := 1 to e do

p := 2*p;potenciaDe2 := p;


writeln('Digite o numero do sistema binário');readln(Binario);c := Length(Binario);Decimal := 0;for j := 1 to c do

beginVal(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 doVal(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)

thenDv := 0;

DigitoVerificador := Dv;end;

{Inicio da funcao VerificaConta}begin

c := Length(s);Str(DigitoVerificador(s), Digito);if s[c] = Digito[1]

then

VerificaConta := trueelse

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 doVal(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 = 1then

Soma := Soma + Digitos[i]else

Soma := Soma + 3*Digitos[i];Dv := Soma mod 10;if Dv <> 0

thenDv := 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

beginPrimPal := 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

beginUltPal := s[i] + UltPal;i := i - 1;

end;UltPalavra := UltPal;


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 ReferenciaBibliograficavar 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

beginPal := 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')

thenParticula := 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

beginUltPal := s[i] + UltPal;i := i - 1;

end;UltPalavra := UltPal;


writeln('Digite o nome do autor');readln(Nome);Referencia := UltPalavra(Nome) + ', ' + PrimLetras(Nome);writeln(Referencia);

end.

Capítulo 82. {Programa para reunir dois arquivos}

type TRegistro = recordMat : 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 := trueelse 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

thenConsulta := FilePos(f) – 1

elseConsulta := -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

beginread(f1, r);write(f, r);

end;Reset(f2);while not Eof(f2) do

beginread(f2, r);if Consulta(f, r.Mat) = -1

thenwrite(f, r);

end;Close(f1);Close(f2);Close(f);


writeln('Digite os nomes dos arquivos a serem reunidos');readln(Narq1);readln(Narq2);Assign(a1, Narq1);if ExisteArquivo(a1)

thenbegin

Assign(a2, Narq2);if ExisteArquivo(a2)

then

beginwriteln('Digite o nome do novo arquivo');readln(Narq);Assign(a, Narq);if not ExisteArquivo(a)

thenReunArq(a1, a2, a);

elsewriteln('Arquivo ', Narq, ' ja existe');

endelse

writeln('Arquivo ', Narq2, ' nao existe');end

elsewriteln('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

beginread(f1, r);if r.Salario > 5000

thenwrite(f, r);

end;end;


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

beginwrite(Aux, Reg);read(f, Reg);

end;if Eof(f)

thenwrite(Aux, Reg)

elseSeek(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)

thenwrite(f, Reg)

elsebegin

p := FilePos(f) - 1;t := FileSize(f);for i := t downto p do

beginread(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

beginwrite(Aux, Reg);read(f, Reg);

end;if Eof(f)

thenwrite(Aux, Reg)

elseSeek(f, FilePos(f) - 1);

write(Aux, r);while not Eof(f) do

beginread(f, Reg);write(Aux, Reg);


end;{Comandos do procedimento InsereOrdenado}begin

Reset(f1);Reset(f2);while not Eof(f1) do

beginread(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

beginread(f1, r);n := Consulta(f2, r.Matr);if Consulta(f2, r.Matr) <> -1

thenwrite(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;

beginReset(f);Assign(Aux, 'Temp');Rewrite(Aux);while not Eof(f) do

beginread(f, c);if c <> '{'

thenwrite(Aux, c)

elsebegin

read(f, c);if c <> '$'

thenwhile c <> '}' do

read(f, c)else

beginwrite(Aux, '{');write(Aux, c);read(f, c);while c <> '}' do

beginwrite(Aux,c);read(f, c);

end;write(Aux, '}');

end;end;



writeln('Digite o nome do arquivo');readln(NomeArquivo);Assign(Arq, NomeArquivo);ExcluiComentarios(Arq);

end.

Capítulo 91. {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

thenPesquisaPessimista := j

elseif v[t-j+1] = x

thenPesquisaPessimista := 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

beginMaior := v[i];k := i;

end;IndiceDoMaiorElemento := k;

end;{Comandos do SelectSort}

beginfor i := t - 1 downto 1 do

beginj := IndiceDoMaiorElemento(v, i);if v[j] > v[i+1]

thenTroca(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

beginn2 := 0; Tr := false;t := t - 1;for i := 1 to t do

beginSeek(f, n2);n1 := FilePos(f);read(f, r1);n2 := FilePos(f);read(f, r2);if r1.Mat > r2.Mat

thenbegin

TrocaRegistro(n1, n2, r1, r2);Tr := true;

end;end;

end;end;

Documents

Respostas Pascal Jaime Evaristo