PREGUNTAS CONTESTADAS - Pascal/Turbo Pascal

program fechahora;

uses

  crt, Dos;

const

  days : array [0..6] of String[9] =

         ('domingo','lunes','martes',

          'mi‚rcoles','jueves','viernes',

          'S bado');

var

  h, m, s, hund : Word; { Para GetTime}

  y, ms, d, dow : Word;  { para Getdate}



function colocozero(w : Word) : String;

var

  s : String;

begin

  Str(w:0,s);

  if Length(s) = 1 then

    s := '0' + s;

  colocozero := s;

end;



begin

  clrscr;

  GetTime(h,m,s,hund);

  GetDate(y,ms,d,dow);

  textcolor(14);

  gotoxy(13,11);write('Hora  /  Minuto  /  Segundo');

  textcolor(10);

  gotoxy(13,13);write(colocozero(h),'    /   ',colocozero(m),'     /   ',colocozero(s));

  textcolor(14);

  gotoxy(13,15);write('Hoy es   /   Dia   /   Mes   /   A¤o');

  textcolor(10);

  gotoxy(13,17);write(days[dow],'  /    ',d:0,'   /   ',ms:0,'    /   ',y:0);

  textcolor(0);

  readln;

end.

program grafi;

uses

   crt, graph;

  var

    datos : array[1..6] of real;

    drive, modo : integer;

    tt, x, y, i : integer;

    tecla : char;

    temp : real;



   procedure entradas;

   var

      dat : string[6];

      ra : real;

      err : integer;

   begin

      i := 1;

      gotoxy(10,10);write('Entre N : ');

      gotoxy(19,10);clreol;

    repeat

    tecla := readkey;

    if tecla in[#48..#57,#46] then

    begin

        dat[i] := tecla;

        dat[0] := chr(i);

        gotoxy(18 + i,10);write(dat[i]);

        i := i + 1;

        if i > 6 then

        i := 6;

    end;

    if tecla = #8 then

    begin

        i := i - 1;

        if i < 1 then

        i := 1;

        dat[i] := ' ';

        dat[0] := chr(i);

        gotoxy(18 + i,10);write(dat[i]);

      end;

    until tecla = #13;

   if i > 1 then

   begin

       val(dat,ra,err);

       datos[tt] := ra;

   end;

  end;



   begin

       clrscr;

     for tt := 1 to 6 do

     begin

     entradas;

     end;

   clrscr;

   gotoxy(10,10);write('Presentacion Ordenada o Normal [O/N]');

   repeat

       tecla := upcase(readkey);

   until tecla in[#79,#78];

   if tecla = #79 then

   begin

    temp := 0;

    for i := 1 to 6 do

    begin

     for tt := 1 to 6 do

     begin

        if datos[i] < datos[tt] then

        begin

           temp := datos[tt];

           datos[tt] := datos[i];

           datos[i] := temp;

        end;

          temp := 0;

       end;

     end;

  end;

     clrscr;

     drive := detect;

     initgraph(drive,modo,'C:	pgi'); {Fijate en esto C:	pgi ponlo como lo tengas tu}

     if graphresult <> 0 then

     halt(1);

     setcolor(15);

     x := 10;

     outtextxy((getmaxx div 2) - 40,(getmaxy div 2) + 20,'Grafico de Barras');

     for i := 1 to 6 do

     begin

     bar(((getmaxx div 2)- 36) + i + x,getmaxy div 2,

                      ((getmaxx div 2) - 36) + (i + x) + 10,

                         (getmaxy div 2) - trunc(datos[i]));

         x := x + 12;

     end;

    readln;

    closegraph;

   end.

program  ejecuci;

{$M $4000,0,0 }  {asignacion de memoria}

uses Dos;

var

  Programanombre, comandoLinea : string;

begin

  Write('Programa a ejecutar (path completo): ');

  ReadLn(Programanombre);

  Write('L¡nea de comandos a pasar a ', Programanombre, ': ');

  ReadLn(comandoLinea);

  WriteLn('A punto de ejecutar...');

  SwapVectors;

  Exec(Programanombre, comandoLinea);

  SwapVectors;

  WriteLn('...de vuelta');

  if DosError <> 0 then{ ¨Error? }

    WriteLn('Dos error #', DosError)

  else

    WriteLn('Ejecuci¢n satisfactoria. ',

            'C¢digo de salida de proceso hijo = ',

            DosExitCode);

end.

program cuentas;

 uses

     crt, dos;

  type

     string12 = string[12];

  var

     dat1, dat2, dat3 : real;

     tecla : char;

     cade1, cade2, cade3 : string12;



   function combierte(ent : string12) : real;

   var

      num : real;

      erro : integer;

   begin

       val(ent,num,erro);

       if erro <> 0 then

       exit;

       combierte := num;

  end;



  function entra_dato(x,y : integer) : string12;

  var

     conta : integer;

     cadena : string12;

  begin

      conta := 1;

      fillchar(cadena,13,' ');

      cadena[0] := chr(12);

      textcolor(1);

    repeat

      tecla := readkey;

      if tecla in[#47..#57,#42,#43,#45] then

      begin

          cadena[conta] := tecla;

          cadena[0] := chr(conta);

          conta := conta + 1;

          if conta > 12 then

          conta := 12;

          gotoxy(x,y);write(cadena);

      end;

      if tecla = #32 then

      begin

         conta := conta - 1;

         if conta < 1 then

         conta := 1;

         cadena[conta] := ' ';

         cadena[0] := chr(conta);

         gotoxy(x,y);write(cadena);

      end;

    until (tecla = #13) or (tecla = #27);

    textcolor(15);

    if tecla = #13 then

    entra_dato := copy(cadena,1,length(cadena))

  else

    entra_dato := ' ';

  end;



   function operacion(como : string12) : real;

   var

      n, cu : integer;

      da1, da2 : string12;

      nu1, nu2 : real;

      dos : boolean;

      opera : char;

   begin

       dos := false;

       cu := 1;

       n := 1;

       fillchar(da1,13,' ');

       da1[0] := chr(12);

       fillchar(da2,13,' ');

       da2[0] := chr(12);

       repeat

          if como[cu] in [#42,#43,#45,#47] then

          begin

               opera := como[cu];

               dos := true;

          end

     else

         begin

            if dos = false then

            begin

            da1[cu] := como[cu];

            da1[0] := chr(cu);

            end

         else

            begin

            da2[n] := como[cu];

            da2[0] := chr(n);

            n := n + 1;

            end;

         end;

         cu := cu + 1;

       until cu > Length(como);

       nu1 := combierte(da1);

       nu2 := combierte(da2);

       case opera of

   #42 : begin

            operacion := nu1 * nu2;

         end;

   #43 : begin

            operacion := nu1 + nu2;

         end;

   #45 : begin

            operacion := nu1 - nu2;

         end;

   #47 : begin

             operacion := nu1 / nu2;

         end;

       end;

   end;



  begin

      clrscr;

      gotoxy(10,20);write('Entre dato : ');

      TextBackground(7);

      gotoxy(9,22);write('            ');

      gotoxy(9,22);

      cade1 := entra_dato(10,22);

      TextBackground(0);

      textcolor(14);

      gotoxy(22,20);write(operacion(cade1):8:2);

      textcolor(15);

      readln;



  end.

program biseccion;

 uses

  crt;

 var

   p, a, b, c, n : real;

   cc, ca, cb, resultado, resul : real;

   error, cont, l : integer;

   sal : boolean;



 function calculo(a : real) : real;

 begin

     calculo := cos(a) / a;

 end;



 function dato(x, y : integer) : integer;

 var

   tec : char;

   pos : integer;

   tex : string[5];

   valo : integer;

 begin

    dato := 0;

    fillchar(tex,6,' ');

    tex[0] := chr(5);

    pos := 1;

    gotoxy(x,y);

  repeat

     tec := readkey;

     if tec in[#48..#57] then

     begin

        tex[pos] := tec;

        tex[0] := chr(pos);

        gotoxy(x + pos,y);write(tex[pos]);

        pos := pos + 1;

        if pos > 5 then

        pos := 5;

     end;

     if tec = #8 then

     begin

         pos := pos - 1;

         if pos < 1 then

         pos := 1;

         tex[pos] := ' ';

        tex[0] := chr(pos);

        gotoxy(x + pos,y);write(tex[pos]);

     end;

  until (tec = #13) or (tec = #27);

  if tec = #27 then

  sal := true;

  if tec = #13 then

  begin

     val(tex,valo,error);

     dato := valo;

  end;

 end;



  procedure entrada_datos;

  begin

      gotoxy(10,1);write('<<< Programa De biseccion >>>');

      gotoxy(10,3);write('*** Entre los Datos ***');

      gotoxy(10,4);write('Valor de A = ','     ','Primer Valor');

      gotoxy(10,5);write('Valor de B = ','     ','Segundo Valor');

      gotoxy(10,6);write('Valor de p = ','     ','Veces de Intentos');

    a := dato(22,4);

    if sal = false then

    b := dato(22,5);

    if sal = false then

    p := dato(22,6);

  end;



  procedure calculamos;

  begin

      clrscr;

      entrada_datos;

      c := (a + b) / 2;

      cc := calculo(c);

      cont := 0;

    repeat

       n := b - c;

      if (abs(n) < p) or (cc = 0.0) then

      resultado := c

  else

    begin

       cc := calculo(c);

       cb := calculo(b);

       resul := cb * cc;

    if (resul < 0.0) then

     a := c

  else

     b := c

  end;

    cont := cont + 1;

    gotoxy(10,8);write(' Intentos : ',cont,'  Salio : ',c);

    c := (a + b) / 2;

  until (abs(n) < p) or (cc = 0.0);

  gotoxy(10,10);write(' El Resultado Es : ',resultado : 8:8);

  end;



  begin

     clrscr;

     calculamos;

     readln;

 end.