home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TPTSR.ZIP / CALENDAR.PAS next >
Encoding:
Pascal/Delphi Source File  |  1990-01-19  |  3.0 KB  |  133 lines
  1. {
  2.  
  3.     calendar.pas
  4.     1-19-1990
  5.  
  6.     Copyright 1990
  7.     John W. Small
  8.     All rights reserved
  9.  
  10.     PSW / Power SoftWare
  11.     P.O. Box 10072
  12.     McLean, Virginia 22102 8072
  13.  
  14.  
  15.     The Gregorian calendar is valid for September 15, 1752
  16.     to the present.  It is based on a 400 year cycle with
  17.     every fourth year a leap year unless divisible by 100.
  18.     Years divisible by 400 are also leap years.  There are
  19.     then 100 - 4 + 1 = 97 leap days in 400 years.  97 +
  20.     400 * 365 = 146097 days.  Thus the number of days in
  21.     400 years is evenly divisible by seven.
  22.  
  23.     The Julian date is the number of the days starting
  24.     from year 1 A.D.
  25.  
  26. }
  27.  
  28. unit calendar;
  29.  
  30. interface
  31.  
  32.     uses crt;
  33.  
  34.     const
  35.  
  36.         DaysInMonth : array[1..12] of integer = (
  37.             31,28,31,30,31,30,31,31,30,31,30,31
  38.         );
  39.  
  40.         months : array[1..12] of string[9] = (
  41.             'January', 'February', 'March',
  42.             'April', 'May', 'June',
  43.             'July', 'August', 'September',
  44.             'October', 'November', 'December'
  45.         );
  46.  
  47.         days : array[1..7] of string[9] = (
  48.             'Sunday', 'Monday','Tuesday', 'Wednesday',
  49.             'Thursday', 'Friday', 'Saturday'
  50.         );
  51.  
  52.         function  DayOfTheWeek(year,month,day : integer):integer;
  53.         function  LeapYear(year : integer) : boolean;
  54.         function  DayOfTheYear(year,month,day : integer):integer;
  55.         procedure CalendarRC(year, month, day : integer;
  56.                     var r, c : byte);
  57.         procedure WriteCalendar(year, month : integer);
  58.  
  59.  
  60. implementation
  61.  
  62.     function  DayOfTheWeek(year,month,day : integer):integer;
  63.         var y,c,m,d : integer;
  64.         begin
  65.             { Zeller's congruence }
  66.             dec(month,2);
  67.             if month <= 0 then begin
  68.                 inc(month,12);
  69.                 dec(year)
  70.                 end;
  71.             y := year mod 100;
  72.             c := year div 100;
  73.             d :=  (26 * month - 2) div 10 +
  74.                 day + y + y div 4 + c div 4 - 2 * c;
  75.             while (d < 0) do
  76.                 inc(d,7);
  77.             DayOfTheWeek := d mod 7 + 1
  78.         end;
  79.  
  80.     function  LeapYear(year : integer) : boolean;
  81.         begin
  82.             if not boolean(year mod 4) and
  83.                 boolean(year mod 100) or
  84.                 not boolean(year mod 400)
  85.                 then LeapYear := true
  86.                 else LeapYear := false
  87.         end;
  88.  
  89.     function  DayOfTheYear(year,month,day : integer):integer;
  90.         var m, d : integer;
  91.         begin
  92.             d := 0;
  93.             for m := 1 to month - 1 do
  94.                 inc(d,DaysInMonth[m]);
  95.             if (not boolean(year mod 4) and
  96.                 boolean(year mod 100) or
  97.                 not boolean(year mod 400)) and
  98.                 (month > 2) then
  99.                 inc(d);
  100.             DayOfTheYear := d + day
  101.         end;
  102.  
  103.     procedure CalendarRC(year, month, day : integer;
  104.                 var r, c : byte);
  105.         var firstOfs :  integer;
  106.         begin
  107.             firstOfs := DayOfTheWeek(year,month,1) - 1;
  108.             r := (day - 1 + firstOfs) div 7 + 1;
  109.             c := (day - 1 + firstOfs) mod 7 + 1
  110.         end;
  111.  
  112.     procedure WriteCalendar(year, month : integer);
  113.         const  WeekDays = '  S  M Tu  W Th  F  S ';
  114.         var x, y, r, c : byte;
  115.             day : integer;
  116.         begin
  117.             x := wherex; y := wherey;
  118.             write('   ',months[month],'  ',year);
  119.             inc(y);
  120.             gotoxy(x,y);
  121.             write(WeekDays);
  122.             for day := 1 to DaysInMonth[month] do begin
  123.                 CalendarRC(year,month,day,r,c);
  124.                 gotoxy((c-1)*3+x,r+y);
  125.                 write(day:3);
  126.                 end;
  127.  
  128.         end;
  129.  
  130.     begin
  131.     end.
  132.  
  133.