Zip File view

{

    calendar.pas
    1-19-1990

    Copyright 1990
    John W. Small
    All rights reserved

    PSW / Power SoftWare
    P.O. Box 10072
    McLean, Virginia 22102 8072


    The Gregorian calendar is valid for September 15, 1752
    to the present.  It is based on a 400 year cycle with
        every fourth year a leap year unless divisible by 100.
        Years divisible by 400 are also leap years.  There are
        then 100 - 4 + 1 = 97 leap days in 400 years.  97 +
        400 * 365 = 146097 days.  Thus the number of days in
        400 years is evenly divisible by seven.

    The Julian date is the number of the days starting
    from year 1 A.D.

}

unit calendar;

interface

        uses crt;

        const

                DaysInMonth : array[1..12] of integer = (
                        31,28,31,30,31,30,31,31,30,31,30,31
                );

                months : array[1..12] of string[9] = (
                        'January', 'February', 'March',
                        'April', 'May', 'June',
                        'July', 'August', 'September',
                        'October', 'November', 'December'
                );

                days : array[1..7] of string[9] = (
                        'Sunday', 'Monday','Tuesday', 'Wednesday',
                        'Thursday', 'Friday', 'Saturday'
                );

                function  DayOfTheWeek(year,month,day : integer):integer;
                function  LeapYear(year : integer) : boolean;
                function  DayOfTheYear(year,month,day : integer):integer;
                procedure CalendarRC(year, month, day : integer;
                                        var r, c : byte);
                procedure WriteCalendar(year, month : integer);


implementation

        function  DayOfTheWeek(year,month,day : integer):integer;
                var y,c,m,d : integer;
                begin
                        { Zeller's congruence }
                        dec(month,2);
                        if month <= 0 then begin
                                inc(month,12);
                                dec(year)
                                end;
                        y := year mod 100;
                        c := year div 100;
                        d :=  (26 * month - 2) div 10 +
                                day + y + y div 4 + c div 4 - 2 * c;
                        while (d < 0) do
                                inc(d,7);
                        DayOfTheWeek := d mod 7 + 1
                end;

        function  LeapYear(year : integer) : boolean;
                begin
                        if not boolean(year mod 4) and
                                boolean(year mod 100) or
                                not boolean(year mod 400)
                                then LeapYear := true
                                else LeapYear := false
                end;

        function  DayOfTheYear(year,month,day : integer):integer;
                var m, d : integer;
                begin
                        d := 0;
                        for m := 1 to month - 1 do
                                inc(d,DaysInMonth[m]);
                        if (not boolean(year mod 4) and
                                boolean(year mod 100) or
                                not boolean(year mod 400)) and
                                (month > 2) then
                                inc(d);
                        DayOfTheYear := d + day
                end;

        procedure CalendarRC(year, month, day : integer;
                                var r, c : byte);
                var firstOfs :  integer;
                begin
                        firstOfs := DayOfTheWeek(year,month,1) - 1;
                        r := (day - 1 + firstOfs) div 7 + 1;
                        c := (day - 1 + firstOfs) mod 7 + 1
                end;

        procedure WriteCalendar(year, month : integer);
                const  WeekDays = '  S  M Tu  W Th  F  S ';
                var x, y, r, c : byte;
                        day : integer;
                begin
                        x := wherex; y := wherey;
                        write('   ',months[month],'  ',year);
                        inc(y);
                        gotoxy(x,y);
                        write(WeekDays);
                        for day := 1 to DaysInMonth[month] do begin
                                CalendarRC(year,month,day,r,c);
                                gotoxy((c-1)*3+x,r+y);
                                write(day:3);
                                end;

                end;

        begin
        end.