Board index » delphi » Look for source of perpetual calendar

Look for source of perpetual calendar

I am looking for the source Pascal code of a perpetual calendar.
Thank you in advance.
Marcello.
rava...@cra.enel.it

 

Re:Look for source of perpetual calendar


Quote
rava...@cra.enel.it (Marcello) wrote:
>I am looking for the source Pascal code of a perpetual calendar.
>Thank you in advance.
>Marcello.
>rava...@cra.enel.it

Sounds like this might be a resourceful way of restating a
class assignment.  If I'm wrong, then I apologize for the
assumption.  But it does look suspiciously like some of
last year's assignments.  ;-)

Get Timo's FAQ at ftp://garbo.uwasa.fi/pc/link/tsfaqp.zip
presents a function for determining the day-of-the-week for
any given date.  Armed with that information, it should be
relatively easy to create a calendar for any given month.

    ...red

--
Support the anti-Spam amendment
  Join at http://www.cauce.org/

Re:Look for source of perpetual calendar


In article <34168d0d.219564...@news.southeast.net> of Tue, 9 Sep 1997
20:38:00 in comp.lang.pascal.borland, "R.E.Donais"

Quote
<rdon...@southeast.net> wrote:
>rava...@cra.enel.it (Marcello) wrote:

>>I am looking for the source Pascal code of a perpetual calendar.
>>Thank you in advance.
>>Marcello.
>>rava...@cra.enel.it

>Sounds like this might be a resourceful way of restating a
>class assignment.  If I'm wrong, then I apologize for the
>assumption.  But it does look suspiciously like some of
>last year's assignments.  ;-)

It would be a careless assigner who asked for something which is given
in the BP7 TVDEMO examples as CALENDAR.PAS - unless he checked that this
code was not on any of the available systems.  It was in TP6 TV too.
Mind you, AFAIR it assumes a leap year every four years.

I expect someone has done a *truly* perpetual calendar, which chooses as
appropriate O.S. or N.S., A.D. or A.U.C., etc., etc.  What did we in
England actually use before Dionysius Exiguus?

--
John Stockton, Surrey, UK.    j...@merlyn.demon.co.uk    Turnpike v1.12    MIME.
  Web URL: http://www.merlyn.demon.co.uk/ -- includes FAQqish topics and links.
  Correct 4-line sig separator is as above, a line comprising "-- " (SoRFC1036)
  Before a reply, quote with ">" / "> ", known to good news readers (SoRFC1036)

Re:Look for source of perpetual calendar


I wrote

Quote
>I am looking for the source Pascal code of a perpetual calendar.

The question is not clear.
I try to explain the problem better:

I need a function that receives a string (dd-mm-yyyy) or three
integers (dd,mm,yyyy) and that returns
 -1         if the date is not valid (example 45-01-1997)
a longint   that let you determine comparisons between two dates
            (if the first day of the calendar is 1st January 1400
             this date returns 1)

Obviously a second function returns a date as a string when a longist
is given.

Thank you in advance.
Marcello.
rava...@cra.enel.it

Re:Look for source of perpetual calendar


On 12 Sep 1997 06:53:48 GMT, rava...@cra.enel.nospam.it (Marcello)
wrote:

Quote
>I wrote
>>I am looking for the source Pascal code of a perpetual calendar.

>The question is not clear.
>I try to explain the problem better:

>I need a function that receives a string (dd-mm-yyyy) or three
>integers (dd,mm,yyyy) and that returns
> -1         if the date is not valid (example 45-01-1997)
>a longint   that let you determine comparisons between two dates
>            (if the first day of the calendar is 1st January 1400
>             this date returns 1)

The following is not perfect.... and please, no 'style' flames... I
KNOW it has rough spots... but it should work.

One possible source of error... I didn't do anything about the rules I
can't quite remember for whether centurys are leap years, e.g. 1900,
2000.

Worth what it cost you... at least!

Tom

function liQuatDateNo(d,m,y:byte):longint;
(*ver 1Sept96*)
(*Written for speed. Worst shortcut... no validation of d,m,y*)

(*Year must be passed to routine as 98 for 1998, 102 for 2002, etc,
     and 1900 was NOT a leap year, despite being divisible by 4,
     so routine valid only for 1/1/1901-31/12/2155 inclusive.
Optimised
     for a selection of years... see 'case y of...'*)

var liA,liy:longint;
    iA:integer;
begin
 (*Start by calc days for completed months so far this year...*)
 case m of
 1:iA:=0;(*Days since start at Jan 1*)
 2:iA:=31;
 3:iA:=59;
 4:iA:=90;
 5:iA:=120;
 6:iA:=151;
 7:iA:=181;
 8:iA:=212;
 9:iA:=243;
 10:iA:=273;
 11:iA:=304;
 12:iA:=334;
 end;(*case*)

 iA:=iA+d;
 (* Add 1 if this is a leap year and date is after 28 Feb...
      earlier leaps in amnt added later for earlier years. NB, this
      would add 1 for 1900 when nothing should be added.
      2000 IS a leap year, though*)
 if (iA>59) and ((y mod 4)=0) then inc(iA);

 (*now add in days-before-1st-of-this-year....*)
 liA:=iA;(*For years below 90, system 'sees' two integers being added,
and
        doesn't return longint. After 89, one is a longint, so result
is too*)
 case y of
   88:liA:=liA+32142;(*Add Quattro number for 31/12 of prev year*)
   89:liA:=liA+32508;
   90:liA:=iA+32873;
   91:liA:=iA+33238;
   92:liA:=iA+33603;
   93:liA:=iA+33969;
   94:liA:=iA+34334;
   95:liA:=iA+34699;
   96:liA:=iA+35064;
   97:liA:=iA+35430;
   98:liA:=iA+35795;
   99:liA:=iA+36160;
   100:liA:=iA+36525;(*Year 2000*)
   101:liA:=iA+36891;
   102:liA:=iA+37256;
   103:liA:=iA+37621;
   104:liA:=iA+37986;
   105:liA:=iA+38352;
   (*if y>88 then y*365 gives overflow problems. Result is put in
    integer space, needs longint*)
   else begin
          if y<88 then liA:=liA+(y*365)+((y-1) div 4)+1;
          if y>105 then begin
             liy:=y;
             liA:=liA+(liy*365)+((y-1) div 4)+1;
             end;
          end;
   end; (*case*)
 liQuatDateNo:=liA
end;

(*Quattro       Ususal
  -18260      1 Jan 1850
       2      1 Jan 1900     1996 is a leap year.
   34700      1 Jan 1995     2000 is a leap year (according to Quattro
                               which is 2000 ready, 'tho '00 taken as
1900 *)

Re:Look for source of perpetual calendar


Quote
>Subject: Re: Look for source of perpetual calendar
>From: 100665.1...@compuserve.com (TK Boyd)
>Date: Fri, Oct 3, 1997 11:47 EDT
>Message-id: <343513a6.686896...@news.arunet.co.uk>

>On 12 Sep 1997 06:53:48 GMT, rava...@cra.enel.nospam.it (Marcello)
>wrote:
><snip>
>>I need a function that receives a string (dd-mm-yyyy) or three
>>integers (dd,mm,yyyy) and that returns
>> -1         if the date is not valid (example 45-01-1997)
>>a longint   that let you determine comparisons between two dates
>>            (if the first day of the calendar is 1st January 1400
>>             this date returns 1)
>The following is not perfect.... and please, no 'style' flames... I
>KNOW it has rough spots... but it should work.

>One possible source of error... I didn't do anything about the rules I
>can't quite remember for whether centurys are leap years, e.g. 1900,
>2000.

Leap Year Rules:
1. all century years (years ending in 00) divisible by *400* are leap years
 (eg. 1600, 2000 are leap years, but 1700, 1800, 1900 are not)
2. otherwise, any year divisible by 4 are leap years

<snip code>

Re:Look for source of perpetual calendar


In article <343513a6.686896...@news.arunet.co.uk> of Fri, 3 Oct 1997
15:47:54 in comp.lang.pascal.borland, TK Boyd

Quote
<100665.1...@compuserve.com> wrote:

>One possible source of error... I didn't do anything about the rules I
>can't quite remember for whether centurys are leap years, e.g. 1900,
>2000.

See references in my
        http://www.merlyn.demon.co.uk/miscinfo.htm#Leap
and my code in
        http://www.merlyn.demon.co.uk/programs/leapyear.pas
or, of course, Timo's FAQ #91.

One expression is
  Leap := (Y mod 4 = 0) xor (Y mod 100 = 0) xor (Y mod 400 = 0) ;

--
John Stockton, Surrey, UK.    j...@merlyn.demon.co.uk    Turnpike v1.12    MIME.
  Web URL: http://www.merlyn.demon.co.uk/ - FAQqish topics, acronyms and links.
  Correct 4-line sig separator is as above, a line comprising "-- " (SoRFC1036)
  Before a reply, quote with ">" / "> ", known to good news readers (SoRFC1036)

Re:Look for source of perpetual calendar


Quote
TK Boyd wrote:

> On 12 Sep 1997 06:53:48 GMT, rava...@cra.enel.nospam.it (Marcello)
> wrote:

> >I wrote
> >>I am looking for the source Pascal code of a perpetual calendar.

> >The question is not clear.
> >I try to explain the problem better:

> >I need a function that receives a string (dd-mm-yyyy) or three
> >integers (dd,mm,yyyy) and that returns
> > -1         if the date is not valid (example 45-01-1997)
> >a longint   that let you determine comparisons between two dates
> >            (if the first day of the calendar is 1st January 1400
> >             this date returns 1)

May I offer another solution? I hope it is not long enough to offend.
The only look-up table is the lengths of months in a normal year. The
code goes from day 1 = 1st Jan 1AD (proleptic Gregorian calendar) to day
3652059 = 31.12.9999AD. Proleptic meaning they didn't use this calendar
back then. They probably won't be using it in 9999 either. I tested it
by incrementing a date and a count, then comparing the count with what
the code below calculated. So I'm sure it works. If you want to base
your calendar on 1.1.1400 subtract DateToNumber(1.1.1400) (i.e.510975).

Leap years: years divisible by 4 are leap, except for century years that
are not also divisible by 400. So 2000 is, 1900 was not.

I'm afraid the code does not validate dates as it stands, because I did
not need to do that (the code that was calling DateToNumber had a
reliable source of dates). But given the DaysInMonth array (and the
function IsLeapYear to correct DaysInMonth[2]) the validation function
should be trivial.

Frank
------------------------------------------------------------------
{ Code to convert dates to and from a day number
  FP 1997

Quote
}

Unit uDate;

Interface

Function DateToNumber(d,m,y:word):LongInt;
  { Return the number of day between 1.1.1 and the specified date,
    inclusive.
    - d: Date in month, 1..31
    - m: Month, 1..12
    - y: Year including century, 1..9999
    No validation of the given date is done, so e.g. 31.2.97 would
    return a number (actually the number for 3.3.0097)
  }

Procedure NumberToDate(Num:LongInt; var d,m,y:Word);
  { Convert the day number back into a date.
    - Num: Date expressed as a number. 1 = 1.1.1
    - d,m,y: Date, month and year are returned in these.
  }

Function IsLeapYear(y:Integer):Boolean;
  { Return True iff y is a leap year.
  }

Function DayOfWeek(Date:LongInt):Integer;
  { Return the day of the week, where 1 = Monday, 7 = Sunday.
  }

Implementation

Const
  DaysInNormalYear    = 365;
  DaysIn4Years        = DaysInNormalYear*4 + 1;    { 4th year is leap }
  DaysInNormalCentury = DaysIn4Years*25 - 1;      
                                             { 100th year is not leap }
  DaysIn400Years      = DaysInNormalCentury*4 + 1;
                                           { 4th century year is leap }

Type
  tMonthArray = Array[1..12] of Integer;

Const
  JanDays = 31; { never varies but it's needed in the code as well }
  FebDays = 28; { February is FebDays or FebDays+1 (leap years) }
  DaysInMonth : tMonthArray = (
    { Jan } JanDays,
    { Feb } FebDays,
    { Mar } 31,
    { Apr } 30,
    { May } 31,
    { Jun } 30,
    { Jul } 31,
    { Aug } 31,
    { Sep } 30,
    { Oct } 31,
    { Nov } 30,
    { Dec } 31
  );

Function IsLeapYear(y:Integer):Boolean;
Begin
  IsLeapYear := ((y mod 4 = 0) and (y mod 100 <> 0)) or (y mod 400 = 0);
End;

Function DateToNumber(d,m,y:word):LongInt;
Var
  ql, rl:LongInt; { Long variables for quotient and remainder }
  nDays : LongInt;
  IsLeap : Boolean;
Begin
  { Conversion is as folllows:
    1. Divide the year by 400. This gives the number of 400-year
       periods, which have a fixed number of days, so we can calculate
       the number of days up to and including the last leap century year
    2. Divide the remainder from step 1, by 100. This gives the number
       of centuries which do not have leap century years since the end
       of the last leap century year. So we have the number of days up
       to and including the last century year.
    3. Divide the remainder from step 2, by 4, hence getting the number
       of days up to the end of the last leap year.
    4. Add the number of days in the remaining years, each of which has
       365 days, and the necessary months and days.
  }
  IsLeap := IsLeapYear(Y);
  dec(y); { don't include all days of current year }
  ql := Y div 400;
  rl := Y mod 400;
  nDays := ql*DaysIn400Years;
  ql := rl div 100;
  rl := rl mod 100;
  Inc(nDays, ql*DaysInNormalCentury);
  ql := rl div 4;
  rl := rl mod 4;
  Inc(nDays, ql*DaysIn4Years);
  Inc(nDays, rl*DaysInNormalYear);

  { Add days of all months already passed }
  If (M>2) and IsLeap then
    Inc(nDays);
  While (M>1) do
  Begin
    Dec(M);
    Inc(nDays, DaysInMonth[M]);
  End;

  { Finally add days passed in this month }
  Inc(nDays, D);

  DateToNumber := nDays;
End;

Procedure NumberToDate(Num:LongInt; var d,m,y:Word);
Var
  Months:tMonthArray;
Begin
  { The Gregorian calendar has cycles within cycles. The 400-year cycle
    contains 4 x 100-year cycles and one day, the 100-year cycle is 25 x
    4-year cycles less a day, the 4-year cycle is 4 x 1-year cycles and
    one day. When we find the number of cycles of a particular type that
    have passed up to the current day, we have to massage the remainder
    to look like it is entirely made up of cycles of the next type. This
    is easiest if the only exceptional year is the first in the cycle.
    Therefore we add the number of days in a year to the date to get the
    number of days before the current date from 1.1.0 (adding the number
    of days in year 0 would leave Num inclusive, i.e. give the number of
    days including the current date, so 1 would have to be subtracted
    again).
  }
  Months := DaysInMonth;

  Inc(Num, DaysInNormalYear); { Num := days from 1.1.0 to Num-1 }
  y :=   (Num div DaysIn400Years)*400;
  Num :=  Num Mod DaysIn400Years;
  { Now y = years up to current 400-year period, which is made up of
    normal centuries except that the first year is leap.
  }
  If Num<=(DaysInNormalYear) then
    Inc(Months[2]) { Have year, but correct Month table for leap year }
  else
  Begin
    Dec(Num);
      { Adjust day within 400-year period to look as if the first year
        was not leap
      }
    Inc(y, (Num div DaysInNormalCentury)*100);
    Num :=  Num Mod DaysInNormalCentury;
      { Now we have the year up to the current century, which is made up
        of normal 4-year periods except that the first year is not leap.
      }
    If Num>=(DaysInNormalYear) then
    Begin
      Inc(Num); { Make the 1st 4-year period like all the others }
      Inc(y, (Num div DaysIn4Years)*4);
      Num :=  Num Mod DaysIn4Years;
      If Num<=(DaysInNormalYear) then
        Inc(Months[2])
      else
      Begin
        Dec(Num); { Pretend 1st year of 4 was not leap }
        Inc(y, (Num div DaysInNormalYear));
        Num :=  Num Mod DaysInNormalYear;
      End;
    End;
  End;

  { Now y is the correct year, and Num is the number of days that have
    elapsed in this year before the day of interest. "Months" holds the
    correct count of days in each month of this year, the February entry
    has been adjusted for a leap year if necessary.
  }
  m := 1;
  While Num>=Months[m] do
  Begin
    dec(Num,Months[m]);
    Inc(m);
  End;

  d := Num+1 { Now we _want_ to include the current day }
End;

Function DayOfWeek(Date:LongInt):Integer;
Begin
  DayOfWeek := 1 + ((Date+6) mod 7);
End;

End.

Other Threads