(******************************************)
(* Realizado en turbo pascal 7.0 *)
(* Armando Fuenmayor *)
(* corre
[email protected] *)
(******************************************)
uses crt;
var
fecha : string[20];
aa : string[20];
continuar : char;
(******************************************************)
(* Esta funcion convierte una cadena en numero *)
(*****************************************************)
function car_numero(S:string) : Integer;
var
aa,code : integer;
begin
val(S, aa,code);
car_numero := aa;
end;
(*****************************************************)
(* Esta funcion convierte un numero en cadena *)
(****************************************************)
function numero_car(I: integer): String;
var
S , s1: string[11];
begin
S := '';
s1 := '';
if (I >= 0) and (I <= 9) then
begin
Str(I, S);
s1 := '0'+ S ;
S := s1 ;
end
else
begin
Str(I, S);
end;
numero_car := S;
end;
(************************************************)
(* Esta funcion convierte un a¤os a cadena *)
(************************************************)
function annos_car(I: integer): String;
var
S ,s1: string[11];
n :integer;
begin
Str(I, S);
n := 0 ;
n := length(S) ;
case n of
1 : begin
s1 := '000'+ S ;
S := s1 ;
end;
2 : begin
s1 := '00'+ S ;
S := s1 ;
end;
3 : begin
s1 := '0'+ S ;
S := s1 ;
end;
end;
annos_car := S;
end;
(************************************************************)
(* Esta funcion extrae los a¤os meses y dias de fecha *)
(************************************************************)
function extraer(S:string;inicio,final : integer) : string;
begin
extraer := Copy(S, inicio, final);
end;
(**********************************************************)
(* Esta funcion determina si un a¤o es biciesto o no *)
(**********************************************************)
function bisiesto(aaaa:integer ): boolean;
var
verdad : boolean;
begin
verdad := false;
if ((aaaa mod 4 = 0 ) and
(aaaa mod 100 <> 0 ) or (aaaa mod 400 = 0 ))
then
begin
verdad := true;
end;
bisiesto := verdad ;
end;
(**********************************)
(* Esta funcion valida los dias *)
(**********************************)
function vali_dias( S:string ):boolean;
var
dia, mes, anno : integer;
cad_dia, cad_mes, cad_anno : string;
cierto : boolean;
begin
dia := 0 ; mes:= 0; anno := 0;
cad_dia := ''; cad_mes := ''; cad_anno := '';
cierto := false ;
cad_dia := extraer(S,1,2);
cad_mes := extraer(S,4,2);
cad_anno:= extraer(S,7,4);
dia := car_numero(cad_dia);
mes := car_numero(cad_mes);
anno:= car_numero(cad_anno);
case mes of
1, 3, 5, 7, 8, 10, 12 :
begin
if (dia>=1) and (dia<=31) then cierto := true ;
end;
4, 6, 9, 11:
begin
if (dia>=1) and (dia<=30) then cierto := true ;
end;
2 :
begin
if (bisiesto(anno) = true) then
begin
if (dia>=1) and (dia<=29) then cierto := true ;
end
else
begin
if (dia>=1) and (dia<=28) then cierto := true ;
end;
end;
end;
vali_dias := cierto ;
end;
(**********************************************)
(* Esta funcion valida los meses del año *)
(*********************************************)
function vali_meses( S:string ):boolean;
var
mes : integer;
cad_mes : string;
cierto : boolean;
begin
mes:= 0;
cad_mes := '';
cierto := false ;
cad_mes := extraer(S,4,2);
mes := car_numero(cad_mes);
case mes of
1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12 :
begin
cierto := true ;
end;
end;
vali_meses := cierto ;
end;
(***********************************************)
(* Esta funcion valida el año de la fecha *)
(**********************************************)
function vali_annos( S:string ):boolean;
var
anno : integer;
cad_anno : string;
cierto : boolean;
begin
anno := 0;
cad_anno := '';
cierto := false ;
cad_anno := extraer(S,7,4);
anno := car_numero(cad_anno);
if (anno > 0) then
begin
cierto := true ;
end;
vali_annos := cierto ;
end;
(********************************************)
(* Esta funcion retorna el dia siguiente *)
(********************************************)
function dia_siguiente( S:string ): string ;
var
dia, mes, anno : integer;
cad_dia, cad_mes, cad_anno : string;
cadena, temp_fecha : string ;
begin
dia := 0 ; mes:= 0; anno := 0;
cad_dia := ''; cad_mes := ''; cad_anno := '';
cadena := '' ; temp_fecha := '' ;
cad_dia := extraer(S,1,2);
cad_mes := extraer(S,4,2);
cad_anno:= extraer(S,7,4);
dia := car_numero(cad_dia);
mes := car_numero(cad_mes);
anno:= car_numero(cad_anno);
case mes of
4, 6, 9, 11, 1, 3, 5, 7, 8, 10, 11 :
begin
dia := dia + 1;
temp_fecha := numero_car(dia)+'/'+numero_car(mes)+'/'+annos_car(anno);
if vali_dias(temp_fecha) then
begin
cadena := temp_fecha
end
else
begin
dia := 1;
mes := mes + 1;
temp_fecha := numero_car(dia)+'/'+numero_car(mes)+'/'+annos_car(anno);
cadena := temp_fecha
end;
end;
12: begin
dia := dia + 1;
temp_fecha := numero_car(dia)+'/'+numero_car(mes)+'/'+annos_car(anno);
if vali_dias(temp_fecha) then
begin
cadena := temp_fecha
end
else
begin
dia := 1;
mes := 1;
anno:= anno + 1;
temp_fecha := numero_car(dia)+'/'+numero_car(mes)+'/'+annos_car(anno);
cadena := temp_fecha
end;
end;
2 :
begin
dia := dia + 1;
temp_fecha := numero_car(dia)+'/'+numero_car(mes)+'/'+annos_car(anno);
if vali_dias(temp_fecha) then
begin
cadena := temp_fecha
end
else
begin
dia := 1;
mes := 3;
anno:= anno ;
temp_fecha := numero_car(dia)+'/'+numero_car(mes)+'/'+annos_car(anno);
cadena := temp_fecha
end;
end;
end;
dia_siguiente := cadena ;
end;
(**************************)
(* programa principal *)
(**************************)
begin
clrscr;
fecha := '';
aa := '';
continuar := 'S';
repeat
clrscr;
gotoxy(1,1);
write('Ingrese la fecha en el siguiente formato DD/MM/AAAA: ');
readln(fecha);
if ( vali_dias(fecha) and vali_meses(fecha) and vali_annos(fecha)) then
begin
gotoxy(1,3);
writeln('El dia siguiente es: ', dia_siguiente(fecha));
aa := extraer(fecha,7,4);;
if bisiesto(car_numero(aa)) then
begin
gotoxy(1,6);
writeln('El año ', aa, ' es biciesto');
end
else
begin
gotoxy(1,6);
writeln('El año ', aa, ' no es biciesto');
end
end
else
begin
gotoxy(1,4);
write(' Introdujo la fecha invalida ');
end;
gotoxy(1,10);
write(' Desea continua [S/N]');
continuar := upcase(readkey);
if ( continuar = 'N') then
begin
writeln;
writeln;
writeln;
writeln('Enter <--------- para salir ');
end;
until (continuar= 'N');
readln;
end.
