home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / DATE.ZIP / DATE.INC next >
Encoding:
Text File  |  1986-12-23  |  3.5 KB  |  180 lines
  1.  
  2. {This program appeared in the book entitled TURBO PASCAL LIBRARY by Douglas
  3.  Stivison. It computes the day of the week a certain date appeared on.
  4.  It also gives the Julian value for the date. }
  5.  
  6.  
  7. const
  8.    dayarray : array [0..6] of string [9] =
  9.        ('Sunday',
  10.         'Monday',
  11.         'Tuesday',
  12.         'Wednesday',
  13.         'Thursday',
  14.         'Friday',
  15.         'Saturday');
  16.  
  17.    montharray : array [1..12] of string [9] =
  18.        ('January',
  19.         'February',
  20.         'March',
  21.         'April',
  22.         'May',
  23.         'June',
  24.         'July',
  25.         'August',
  26.         'September',
  27.         'October',
  28.         'November',
  29.         'December');
  30.  
  31.    monthdays : array [1..12] of integer =
  32.         (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  33.  
  34. type
  35.    datestr =   string [8];
  36.  
  37.  
  38. procedure datetoint (date:       datestr;
  39.                      var month,
  40.                      day,
  41.                      year:       integer);
  42. var
  43.    position:    integer;
  44.  
  45.  
  46.    function parsedate (var i:   integer;
  47.                        dat:     datestr): integer;
  48.    var
  49.       num:     integer;
  50.  
  51.    begin
  52.  
  53.       while not (dat [i] in ['0'..'9']) and (i <= length (date)) do
  54.          i := i + 1;
  55.  
  56.       num := 0;
  57.  
  58.       while (dat [i] in ['0'..'9']) and (i <= length (date)) do
  59.       begin
  60.          num :=(ord (dat [i])- ord ('0'))+(num * 10);
  61.          i := i + 1;
  62.       end;
  63.  
  64.       parsedate := num;
  65.    end;
  66.  
  67. begin
  68.    position := 1;
  69.    month := parsedate (position, date);
  70.    day := parsedate (position, date);
  71.    year := parsedate (position, date)+ 1900;
  72. end;
  73.  
  74.  
  75. function caljul (m,
  76.                  d,
  77.                  y:   integer): real;
  78. var
  79.    x:   real;
  80.  
  81. begin
  82.    x := int (30.57 * m)+ int (365.25 * y - 395.25)+ d;
  83.  
  84.    if m > 2 then
  85.       if int (y / 4)= y / 4 then
  86.          x := x - 1
  87.       else
  88.          x := x - 2;
  89.  
  90.    caljul := x;
  91. end;
  92.  
  93.  
  94. procedure julcal (x:          real;
  95.                   var month,
  96.                   day,
  97.                   year:       integer);
  98. var
  99.    m,
  100.    d,
  101.    y:     real;
  102.    d1:    integer;
  103.    
  104. begin
  105.    y := int (x / 365.26)+ 1;
  106.    d := x + int (395.25 - 365.25 * y);
  107.    
  108.    if int (y / 4)* 4 = y then
  109.       d1 := 1
  110.    else
  111.       d1 := 2;
  112.    
  113.    if d >(91 - d1) then
  114.       d := d + d1;
  115.  
  116.    m := int (d / 30.57);
  117.    d := d - int (30.57 * m);
  118.  
  119.    if m > 12 then
  120.    begin
  121.       m := 1;
  122.       y := y + 1;
  123.    end;
  124.  
  125.    month := trunc (m);
  126.    day := trunc (d);
  127.    year := trunc (y);
  128. end;
  129.  
  130.  
  131. function inttodate (m,
  132.                     d,
  133.                     y:    integer): datestr;
  134. var
  135.    i:        integer;
  136.    month,
  137.    day,
  138.    year:     string [2];
  139.    date:     datestr;
  140.  
  141. begin
  142.  
  143.    if y >= 1900 then
  144.       y := y - 1900;
  145.  
  146.    str(m : 2, month);
  147.    str(d : 2, day);
  148.    str(y : 2, year);
  149.    date := month + '/' + day + '/' + year;
  150.  
  151.    for i := 1 to length (date) do
  152.       if date [i]= ' ' then
  153.          date[i]:= '0';
  154.  
  155.    inttodate := date;
  156. end;
  157.  
  158. function dayofweek (month,
  159.                     day,
  160.                     year:      integer): integer;
  161. var
  162.    century:   integer;
  163.  
  164. begin
  165.  
  166.    if month > 2 then
  167.       month := month - 2
  168.    else
  169.    begin
  170.       month := month + 10;
  171.       year := pred (year);
  172.    end;
  173.  
  174.    century := year div 100;
  175.    year := year mod 100;
  176.    dayofweek := (day - 1 +((13 * month - 1) div 5) +
  177.                           (5 * year div 4) +
  178.                           (century div 4) -
  179.                           (2 * century) + 1) mod 7;
  180. end;