Programando com Pascal

domingo, 6 de fevereiro de 2011

PREÇO DO PRODUTO

program preco_do_produto;
uses crt;
var pp,pp1,d:real;

begin
   clrscr;
   writeln ('Digite Preco do Produto');
   readln (pp);
   d:=(pp*10/100);
   writeln ('O valor do desconto e: ',d);
   pp1:=(pp-d);
   writeln ('O valor com desconto e: ',pp1);
   readkey;
end.

Potenciação

program potenciacao;
uses crt;
  function potencia(x,z:integer):integer;
  var cont, mult:integer;
  begin
   mult:= 1;
   for cont := 1 to z do
   begin
   mult:= mult*x;
   potencia:=mult;
   end;
  end;
  var a,b,mult:integer;
  begin
   clrscr;
   writeln ('Digite os numeros');
   readln (a, b);
   while A<>0 do
   begin
   writeln ('Potencia:',potencia(a,b));
   writeln ('Digite os numeros');
   readln (a, b);
   end;
   readkey;
  end.

Positivo e primo

program positivo;
uses crt;
var i, cont:integer;
  function posit(num: integer):boolean;
  begin
   for i:= 1 to num do
   begin
   if ( num mod i = 0) then cont:= cont + 1;
   if (cont = 2 ) then posit:= true
   else posit := false;
   end;
   end;
   var num:integer;
   begin
   clrscr;
   writeln ('Digite o numero');
   readln (num);
   writeln ('O numero digitado foi:',num);
   writeln ('ele e primo? ' , posit(num));
   readkey;
   end.

Positivo e negativo

program posit_negat;
uses crt;
  function verif(num: integer):boolean;
  begin
   if (num>0) then verif:=true
   else verif:=false;
  end;
  var num: integer;
   msg: string;
  begin
   clrscr;
   writeln ('digite um numero');
   readln (num);
   if (verif(num)=true) then msg:='positivo'
   else
   if (verif(num)=false) then msg:='negativo';
   writeln ('O numero digitado foi:', num ,', ele e: ', msg);
   readkey;
  end.

PESO IDEAL

program peso_ideal;
uses crt;
  function pideal(h:real;sexo:char):real;
  begin
   if (sexo = 'm') then pideal:= (62.1*h-44.7)
   else
   if (sexo = 'h') then pideal:= (72.7*h-58);
  end;
  var alt:real;
   s:char;
  begin
   clrscr;
   writeln ('Digite a Altura');
   readln (alt);
   writeln ('Digite o sexo: (M - mulher, H - Homem');
   readln (s);
   writeln ('O peso ideal e:', pideal(alt,s):2:2);
   readkey;
  end.

Peso em gramas

program peso_gramas;
uses crt;
var pk,pg:real;

begin
   clrscr;
   writeln ('digite o peso da pessoa em kilos');
   readln (pk);
   pg:=(pk*1000);
   writeln ('O peso da pessoa em gramas e: ',pg);
   readkey;
end.

Programa Peso

program peso;
uses crt;
var p, p1, p2:real;

begin
   clrscr;
   writeln ('digite o peso da pessoa');
   readln (p);
   p1:=p+(p*15/100);
   writeln ('o peso com 15% de aumento e: ',p1);
   p2:=p-(p*20/100);
   writeln ('o peso com 20% a menos e: ',p2);
   readkey;
end.

Quantidade de par e impar

{Escrever um programa que le 5 valores para NUM, um de cada vez, e conta
quanto destes valores sao pares e quantos sao impares, escrevendo esta
informacao.}

Program QuantParImpar
uses CRT;
Var
   Num, Cont,QPar, QImpar: Integer;
Begin
   Cont := 1;
   Qpar := 0;
   QImpar := 0;
   Clrscr;
   While Cont <= 5 Do
   Begin
   Writeln('Digite o N£mero: ', Cont);
   Read(Num);
   If (Num MOD 2) = 0 Then
   QPar := QPar + 1
   Else
   QImpar := QImpar + 1;
   Cont := Cont + 1;
   End;
   Writeln('O Total de N£meros Pares ‚: ', QPar);
   Writeln('O Total de N£meros Impares ‚: ', QImpar);
   Readkey;
End.

programa par e impar

Program par_impar;
uses crt;
  function ver(num:integer):boolean;
  begin
   if (num mod 2 = 0) then ver:= true
   else ver:= false;
  end;
  var num: integer;
   msg : string;
  begin
   clrscr;
   writeln ('Digite numero');
   readln (num);
   while num <> 0 do
   begin
   if ver(num)= true then msg:='PAR'
   else
   if ver(num)= false then msg := 'ÖMPAR';
   writeln ('O numero digitado foi:', num, ', ele e:', msg);
   writeln;
   writeln ('Digite numero');
   readln (num);
   end;
   readkey;
end.

Ordem crescente de 3 números

program ordem_crescente;
uses crt;
procedure crescente (var a, b, c: integer);
begin
   if (a<b) and (a<c) and (b<c) then writeln ('Ordem crescente:',a,',',b,',',c)
   else
   if (a<b) and (a<c) and (c<b) then writeln ('Ordem crescente:',a,',',c,',',b)
   else
   if (b<a) and (b<c) and (a<c) then writeln ('Ordem crescente:',b,',',a,',',c)
   else
   if (b<a) and (b<c) and (c<a) then writeln ('Ordem crescente:',b,',',c,',',a)
   else
   if (c<a) and (c<b) and (a<b) then writeln ('Ordem crescente:',c,',',a,',',b)
   else
   if (c<a) and (c<b) and (b<a) then writeln ('Ordem crescente:',c,',',b,',',a)
   end;
   var x, y, z: integer;
   begin
   clrscr;
   writeln ('Digite os numeros');
   readln (x, y, z);
   writeln ('Os numeros digitados sao:', x,',', y,',', z);
   crescente(x,y,z);
   readkey;
   end.

Programa Opinião

program opiniao;
uses crt;
var QtdP,Id, Sx, ContQ, ContOp: Integer;
   Op, A, B, C, D , E :Char;

Begin
clrscr;
writeln ('Digite a quantidade de pesquisados');
readln (QtdP);
for contQ := 1 to QtdP do
  begin
   writeln ('Digite a idade doe pesquisado');
   readln (Id);
   writeln ('Digite o sexo do(a) pesquisado(a)');
   readln (Sx);
   for ContOp := 1 to 5 do
   Begin
   writeln ('Digite a opini o do','ContOp', 'pesquisado');
   readln (Op);
   If op <>'A' and 'B' and 'C' and 'D' and 'E'
   Then Writeln ('Opiniao Errada')
   Else
   Begin
   If (Op<>'A') then OpA := Op + 1;
   If (Op<>'B') then OpB := Op + 1;
   If (Op<>'C') then OpC := Op + 1;
   If (Op<>'D') then OpD := Op + 1;
   If (Op<>'E') then OpE := Op + 1;
   End;
   End;
   If (sexo = 'M') and (Id > 21) then QtdH := QtdH + 1;
   If (sexo = 'H') and (id < 18) Then QtdM := QtdM + 1;
   SomaId := SomaId + Id;
   End;
MedId := SomaId / QtdP;
TotOp := OpA + OpB + OpC + OpD + OpE;
writeln;
End.

Médias diversas

PROGRAM NOTAS;
USES CRT;
  FUNCTION MEDIA (N1,N2,N3:REAL):REAL;
  VAR LETRA:CHAR;
  BEGIN
   IF (LETRA ='A') THEN MEDIA := N1+N2+N3/3
   ELSE IF (LETRA = 'P') THEN MEDIA := (N1*5)+(N2*3)+(N3*2)/10
   ELSE IF (LETRA = 'H') THEN MEDIA:=10;
  END;
  VAR NOTA1, NOTA2, NOTA3:REAL;
   LETRA: CHAR;
   BEGIN
   CLRSCR;
   WRITELN ('DIGITE AS NOTAS DO ALUNO');
   READLN (NOTA1, NOTA2, NOTA3);
   WRITELN ('DIGITE A LETRA PARA O CALCULO DA MEDIA');
   WRITELN ('A: ARITMETICA, P: PONDERADA, H: HARMONICA');
   READLN (LETRA);
   WRITELN ('MEDIA',MEDIA(NOTA1,NOTA2,NOTA3):5:2);
   READKEY;
   END.

Notas de alunos com médias diferentes

program notas;
uses crt;
  procedure media(n1,n2,n3:real);
  var letra: char;
   med: real;
  begin
   if (letra = 'A') then med := (n1 + n2 + n3 / 3)
   else
   if (letra = 'P') then med := (n1*5) + (n2*3) + (n3*2) / 10;
  end;
  var nota1, nota2, nota3: real;
   letra: char;
  Begin
   clrscr;
   writeln ('digite as notas do aluno');
   readln (nota1,nota2,nota3);
   writeln ('Digite a letra para o calculo da media');
   readln (letra);
   media(nota1,nota2,nota3);
   readkey;
  end.

domingo, 30 de janeiro de 2011

Multiplicação de Matriz

PROGRAM MultMatriz;
USES CRT;
VAR MAT: ARRAY [1..2,1..2] OF INTEGER;
   RESULTADO: ARRAY [1..2,1..2] OF INTEGER;
   M,N, MAIOR : INTEGER;
BEGIN
CLRSCR;
FOR M:= 1 TO 2 DO
  BEGIN
   WRITELN ('DIGITE A LINHA ', M, ' DA MATRIZ');
   FOR N:= 1 TO 2 DO
   READLN (MAT[M,N]);
  END;
MAIOR := MAT [1,1];
FOR M:= 1 TO 2 DO
  BEGIN
   FOR N:= 1 TO 2 DO
   IF MAT [M,N] > MAIOR THEN MAIOR := MAT [M,N];
  END;
FOR M:= 1 TO 2 DO
  BEGIN
   FOR N:= 1 TO 2 DO
   BEGIN
   RESULTADO[M,N] := MAIOR * MAT[M,N];
   END;
  END;
WRITELN ('O RESULTADO DA MULTIPLICACAO DA MATRIZ FOI :',RESULTADO[M,N]);
READKEY;
END.

Relatório de notas de alunos

PROGRAM RelaórioNotas;
USES CRT;
VAR NOME: ARRAY [1..2] OF STRING;
   NOTA: ARRAY [1..2] OF REAL;
   I, J,CONTJ: INTEGER;

BEGIN
  CLRSCR;
  FOR I:= 1 TO 2 DO
  BEGIN
   WRITELN ('DIGITE O NOME DO ',I,' ALUNO');
   BEGIN
   READLN (NOME[I]);
   BEGIN
   WRITELN ('DIGITE A NOTA DO ',NOME[I]);
   BEGIN
   READLN (NOTA[J]);
   CONTJ:= J + 1;
   END;
   END;
   END;
  END;
WRITELN ('RELATORIO DE NOTAS');
WRITELN ('ALUNO ',' NOTA');
FOR I:= 1 TO 2 DO
BEGIN
   WRITELN (NOME [I] ,NOTA[J]:2:2);
   FOR I:= 1 TO CONTJ DO
   WRITELN (NOME[I] , NOTA[J]:2:2);

END;
READKEY;
END.

Mostra os números digitados

PROGRAM EP12;
USES CRT;
VAR A: ARRAY [1..5] OF INTEGER;
   I, ACUM: INTEGER;
   SOMA: STRING;
BEGIN
CLRSCR;
FOR I:= 1 TO 5 DO
BEGIN
   WRITELN ('DIGITE O',I,' NUMERO');
   BEGIN
   READLN (A[I]);
   END;
END;
ACUM:= 0;
FOR I:= 1 TO 5 DO
BEGIN
   ACUM:= ACUM + A[I];
END;
WRITELN ('OS NUMEROS DIGITADOS FORAM:');
BEGIN
WRITELN (ACUM);
END;
READKEY;
END.

Elementos de um vetor

PROGRAM EP1;
USES CRT;
VAR VETOR:ARRAY[1..6] OF INTEGER;
   PAR: ARRAY[1..6] OF INTEGER;
   IMPAR: ARRAY[1..6] OF INTEGER;
   I,J,AUX, QTDP, QTDI: INTEGER;

BEGIN
CLRSCR;
FOR I:= 1 TO 6 DO
BEGIN
   WRITELN ('DIGITE O ',I,' NUMERO DO VETOR');
   READLN (VETOR[I]);
   IF (VETOR[I] MOD 2 = 0) THEN (QTDP):= (QTDP + 1)
   ELSE (QTDI):= (QTDI + 1);
END;
WRITELN ('O VETOR POSSUI ',QTDP,' ELEMENTOS PARES QUE SAO:');
FOR I:= 1 TO 6 DO
BEGIN
   IF (VETOR[I] MOD 2 = 0) THEN WRITE (VETOR[I],',');
END;
WRITELN;
WRITELN ('O VETOR POSSUI ',QTDI,' ELEMENTOS IMPARES QUE SAO:');
FOR I:= 1 TO 6 DO
BEGIN
   IF (VETOR[I] MOD 2 <> 0) THEN WRITE (VETOR[I],',');
END;
READKEY;
END.

Determinante: Matrix de ordem 4

Program Determinante;
Uses CRT;
Var
  M: Array [0..4,0..4] OF Integer;
  Li, Co, Det, A11, A12, A13, A14: Integer;
Begin
clrscr;
Writeln ('Calcular o determinante de uma matriz de ordem n=4 e alertar quando essa ordem nao for cumprida');
writeln;
writeln;
   Writeln('Informe os termos da Matriz de orden n=4: ');
   For Li := 0 to 3 Do
   For Co := 0 to 3 Do
   Begin
   M[Li,Co] := 0;
   Writeln('Linha = ' , Li , ' Coluna = ' , Co);
   Readln(M[Li,Co]);
   End;
   ClrScr;
   A11 := M[0,0]*( (M[1,1]*M[2,2]*M[3,3]) + (M[1,2]*M[2,3]*M[3,1]) +
   (M[1,3]*M[2,1]*M[3,2]) - (M[1,3]*M[2,2]*M[3,1]) -
   (M[1,1]*M[2,3]*M[3,2]) - (M[1,2]*M[2,1]*M[3,3]) );

   A12 := M[0,1]*( (M[1,0]*M[2,2]*M[3,3]) + (M[1,2]*M[2,3]*M[3,0]) +
   (M[1,3]*M[2,0]*M[3,2]) - (M[1,3]*M[2,2]*M[3,0]) -
   (M[1,0]*M[2,3]*M[3,2]) - (M[1,2]*M[2,0]*M[3,3]) )*(-1);

   A13 := M[0,2]*( (M[1,0]*M[2,1]*M[3,3]) + (M[1,1]*M[2,3]*M[3,0]) +
   (M[1,3]*M[2,0]*M[3,1]) - (M[1,3]*M[2,1]*M[3,0]) -
   (M[1,0]*M[2,3]*M[3,1]) - (M[1,1]*M[2,0]*M[3,3]) );

   A14 := M[0,3]*( (M[1,0]*M[2,1]*M[3,2]) + (M[1,1]*M[2,2]*M[3,0]) +
   (M[1,2]*M[2,0]*M[3,1]) - (M[1,2]*M[2,1]*M[3,0]) -
   (M[1,0]*M[2,2]*M[3,1]) - (M[1,1]*M[2,0]*M[3,2]) )*(-1);
   Writeln('I11 = ', M[0,0] , ' I12 = ', M[0,1] , ' I13 = ', M[0,2] , ' I14 = ', M[0,3]);
   Writeln('A11 = ', A11, ' A12 = ', A12, ' A13 = ', A13, ' A14 = ', A14);
   Det := A11 + A12 + A13 + A14;
   writeln;
   Writeln('O determinante da matriz e:',Det);
   Readkey;
End.

Calculo de determinante

Program Determinante;
Uses CRT;
Var
  M: Array [0..4,0..4] OF Integer;
  Li, Co, Det, A11, A12, A13, A14: Integer;
Begin
   ClrScr;
   Writeln('Informe os termos da Matriz (4x4): ');
   For Li := 0 to 3 Do
   For Co := 0 to 3 Do
   Begin
   M[Li,Co] := 0;
   Writeln('Linha = ' , Li , ' Coluna = ' , Co);
   Readln(M[Li,Co]);
   End;
   ClrScr;
   A11 := M[0,0]*( (M[1,1]*M[2,2]*M[3,3]) + (M[1,2]*M[2,3]*M[3,1]) +
   (M[1,3]*M[2,1]*M[3,2]) - (M[1,3]*M[2,2]*M[3,1]) -
   (M[1,1]*M[2,3]*M[3,2]) - (M[1,2]*M[2,1]*M[3,3]) );

   A12 := M[0,1]*( (M[1,0]*M[2,2]*M[3,3]) + (M[1,2]*M[2,3]*M[3,0]) +
   (M[1,3]*M[2,0]*M[3,2]) - (M[1,3]*M[2,2]*M[3,0]) -
   (M[1,0]*M[2,3]*M[3,2]) - (M[1,2]*M[2,0]*M[3,3]) )*(-1);

   A13 := M[0,2]*( (M[1,0]*M[2,1]*M[3,3]) + (M[1,1]*M[2,3]*M[3,0]) +
   (M[1,3]*M[2,0]*M[3,1]) - (M[1,3]*M[2,1]*M[3,0]) -
   (M[1,0]*M[2,3]*M[3,1]) - (M[1,1]*M[2,0]*M[3,3]) );

   A14 := M[0,3]*( (M[1,0]*M[2,1]*M[3,2]) + (M[1,1]*M[2,2]*M[3,0]) +
   (M[1,2]*M[2,0]*M[3,1]) - (M[1,2]*M[2,1]*M[3,0]) -
   (M[1,0]*M[2,2]*M[3,1]) - (M[1,1]*M[2,0]*M[3,2]) )*(-1);
   Writeln('I11 = ', M[0,0] , ' I12 = ', M[0,1] , ' I13 = ', M[0,2] , ' I14 = ', M[0,3]);
   Writeln('A11 = ', A11, ' A12 = ', A12, ' A13 = ', A13, ' A14 = ', A14);
   Det := A11 + A12 + A13 + A14;
   Writeln(Det);
   Readkey;
End.

Mostra o valor lido e o total de notas R$.

{15 - Escrever um algoritmo que le um valor em reais e calcula qual o menor
numero possivel de notas de 100, 50, 10, 5 e 1 em que o valor lido pode ser
decomposto. Escrever o valor lido e a relacao de notas necessarias.}

Program decompornotas;
uses crt;
var valor, relac100, relac50, relac10, relac5, resto,
   resto1, resto2, resto3: integer;

Begin
  Clrscr;
  writeln ('Digite o valor em reais');
  readln (valor);
  if (valor >= 100) then Begin
   relac100 := valor div 100;
   resto := valor mod 100;
   relac50 := resto div 50;
   resto1 := resto mod 50;
   relac10 := resto1 div 10;
   resto2 := resto1 mod 10;
   relac5 := resto2 div 5;
   resto3 := resto2 mod 5;
   end;
  writeln;
  writeln ('Valor lido: ', valor ,',',' decomposto nas seguintes cedulas:');
  writeln;
  writeln (relac100 ,' cedulas de 100 reais');
  writeln (relac50 ,' cedulas de 50 reais');
  writeln (relac10 ,' cedulas de 10 reais');
  writeln (relac5 ,' cedulas de 5 reais');
  writeln (resto3 ,' cedulas de 1 real');
  readkey;
end.