home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / DATETP.ZIP / TPDATE.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1986-08-09  |  5.9 KB  |  207 lines
  1. program DateConversion;  {convert text dates to julian values and back}
  2.  
  3. {
  4.    This file is a rather literal translation of algorithims originally
  5.    coded in BASIC, to demonstrate conversion of dates between Julian
  6.    (sequential) and Gregorian (MM/DD/YY) notation.
  7.  
  8.    For the sake of clarity, I have made all variables (except three used
  9.    internally in the CONVERT_GREGORIAN routine) global.  Only one routine
  10.    (CONVERT_JULIAN) makes use of a variable (WEEKDAY) whose value is set by
  11.    a separate function (TEXTDATE), to reference the array constant DAYS.
  12.    All other routines operate independently of one another.
  13.  
  14.    Thanks to John O'Boyle and Mike Todd on The Source IBMSIG for providing
  15.    me with the original BASIC program.  As with their code, this program is
  16.    donated to the public domain.
  17.  
  18.    Ben Bacon - Source ID BDX678
  19. }
  20.  
  21. type
  22.   mthval = array [1..12] of integer;
  23.   wkdays = array [1..7] of string[9];
  24.   dstr   = string[10];
  25.   element = string[4];
  26.  
  27. const
  28.   Mths : mthval = (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334);
  29.   Days : wkdays = ('Monday', 'Tuesday', 'Wednesday', 'Thursday',
  30.                    'Friday', 'Saturday', 'Sunday');
  31.  
  32. var
  33.   i, j : integer;
  34.   DateStr : dstr;
  35.   InptJDate : real;
  36.   InptChar : char;
  37.   continue : boolean;
  38.  
  39.   Weekday, DayNum, MthNum, YearNum, DaysLeft : real;
  40.   LeapYr : integer;
  41.   MthStr, DayStr : string[2];
  42.   YearStr : string[4];
  43.  
  44. procedure clr_eos;
  45.   begin
  46.     for i := 7 to 25 do
  47.       begin
  48.         gotoxy (1, i);
  49.         clreol
  50.       end;
  51.     gotoxy (1, 7)
  52.   end;
  53.  
  54. procedure do_wait;
  55.   var
  56.     dummy : char;
  57.   begin
  58.     writeln ('Press any key to continue');
  59.     read (KBD, dummy)
  60.   end;
  61.  
  62. function JulianDate (M, D, Y : integer) : real;   {input MM/DD/YY}
  63.   begin
  64.     JulianDate := int ((Y * 365.25) + D + mths[M] + (M * 0.01) - 0.03)
  65.   end;
  66.  
  67. function TextDate (JDate : real) : dstr;
  68.   begin
  69.     LeapYr := 0;
  70.     Weekday := JDate - 1 - int ((JDate - 1) / 7) * 7 + 1;
  71.     YearNum := int (JDate / 365.25);
  72.     if (trunc (YearNum) mod 4) = 0 then
  73.       LeapYr := 1;
  74.     DaysLeft := JDate - int (YearNum * 365.25 - 0.25);
  75.     for i := 1 to 12 do
  76.       begin
  77.         if (i < 3) and (mths[i] < DaysLeft) then
  78.           MthNum := i;
  79.         if (i >= 3) and ((mths[i] + LeapYr) < DaysLeft) then
  80.           MthNum := i
  81.       end;
  82.     if MthNum < 3 then
  83.       DayNum := DaysLeft - mths[trunc (MthNum)]
  84.     else
  85.       DayNum := DaysLeft - mths[trunc (MthNum)] - LeapYr;
  86.     str (MthNum:2:0, MthStr);
  87.     if MthNum <= 9 then
  88.       MthStr[1] := '0';
  89.     str (DayNum:2:0, DayStr);
  90.     if DayNum <= 9 then
  91.       DayStr[1] := '0';
  92.     str ((YearNum + 1900):4:0, YearStr);
  93.     TextDate := MthStr + '/' + DayStr + '/' + YearStr
  94.   end;
  95.  
  96. procedure convert_gregorian;
  97.   var
  98.     MoVal, DyVal, YrVal : integer;
  99.  
  100.   begin
  101.     writeln;
  102.     repeat
  103.       continue := true;
  104.       write ('Enter 4-digit Year: ');
  105.       readln (YrVal);
  106.       if (YrVal < -999) or (YrVal > 9999) then
  107.         begin
  108.           continue := false;
  109.           writeln ('ERROR - Valid years are -999 through 9999');
  110.         end;
  111.     until continue;
  112.     repeat
  113.       continue := true;
  114.       write ('Enter # Of Month:   ');
  115.       readln (MoVal);
  116.       if not (MoVal in [1..12]) then
  117.         begin
  118.           continue := false;
  119.           writeln ('ERROR - Valid months are 1 through 12 (Jan - Dec)');
  120.         end;
  121.     until continue;
  122.     repeat
  123.       continue := true;
  124.       write ('Enter Day:          ');
  125.       readln (DyVal);
  126.       if (MoVal in [4, 6, 9, 11]) and not (DyVal in [1..30]) then
  127.         begin
  128.           continue := false;
  129.           writeln ('ERROR - Valid days for this month are 1 through 30');
  130.         end;
  131.       if (MoVal in [1, 3, 5, 7, 8, 10, 12]) and not (DyVal in [1..31]) then
  132.         begin
  133.           continue := false;
  134.           writeln ('ERROR - Valid days for this month are 1 through 31');
  135.         end;
  136.       if (MoVal = 2) and not (DyVal in [1..29]) then
  137.         begin
  138.           continue := false;
  139.           writeln ('ERROR - Valid days for this month are 1 through 28');
  140.           writeln ('        (or 1 through 29 in a leap year)');
  141.         end;
  142.       if (MoVal = 2) and (DyVal = 29) and not ((YrVal mod 4) = 0) then
  143.         begin
  144.           continue := false;
  145.           writeln ('ERROR - Not a leap year, day value incorrect');
  146.         end;
  147.     until continue;
  148.     YrVal := YrVal - 1900;
  149.     writeln;
  150.     writeln ('Julian Date = ', JulianDate (MoVal, DyVal, YrVal):7:0);
  151.     writeln
  152.   end;
  153.  
  154. procedure convert_julian;
  155.   var
  156.     InptJDate : real;
  157.   begin
  158.     writeln;
  159.     write ('Enter A Julian Date: ');
  160.     readln (InptJDate);
  161.     writeln;
  162.     if (InptJDate >= -1058859.0) and (InptJDate <= 2958524.0) then
  163.       begin
  164.         writeln ('Gregorian Date = ', TextDate (InptJDate):12);
  165.         writeln ('Day Of Week =    ', days[trunc (WeekDay)]:10);
  166.         writeln
  167.       end
  168.     else
  169.       begin
  170.         writeln ('ERROR - Julian dates are integer numbers between');
  171.         writeln ('-1,058,859 (1/1/-999) and 2,958,524 (12/31/9999).');
  172.         writeln;
  173.         writeln ('Press any key to continue');
  174.         repeat until keypressed
  175.       end;
  176.   end;
  177.  
  178.  
  179. begin  {DateConversion}
  180.   clrscr;
  181.   gotoxy (1, 1);
  182.   writeln ('Date Conversion Routines in TURBO PASCAL');
  183.   writeln;
  184.   writeln ('Type "J" to convert a Julian date to a Gregorian date,');
  185.   writeln ('"G" to convert a Gregorian date to a Julian date, or');
  186.   writeln ('<ESC> to exit the program.');
  187.   writeln;
  188.   repeat
  189.     clr_eos;
  190.     read (KBD, InptChar);
  191.     InptChar := upcase (InptChar);
  192.     if not (InptChar in ['G', 'J', #27]) then
  193.       write (^G)
  194.     else
  195.       case InptChar of
  196.         'J' : begin
  197.                 convert_julian;
  198.                 do_wait
  199.               end;
  200.         'G' : begin
  201.                 convert_gregorian;
  202.                 do_wait
  203.               end;
  204.       end;
  205.   until InptChar = #27;
  206. end.
  207.