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.