'=========================================================================== ' Subject: DAY COUNTER FOR PBCC Date: 11-04-98 (07:03) ' Author: Eustace Frilingos/Don Schullian Code: PBCC ' Origin: d83@ath.forthnet.gr Packet: PBCC.ABC '=========================================================================== $if 0 These routines are Y5M compliant! This code was reworked from code I was given by Eustice Frilingos so most of the credit goes to him. All I did was convert it into PB code to take advantage of the goodies found therein. These two functions pack the three date elements (Y,M,D) into a long integer by counting the number of days since 1-1-0001 then unpacking that number into the three date elements. The last possible date is in the year 5.8M so it's safe to say that the Y2K thingie isn't a problem! The fly in the ointment is that somewhere in the 12th century 11 days were cut or added to the calendar (don't remember which) so if you're an historian you'll need to modify the routines to work around that little chronological blip. The reason I've not messed with it is two fold: 1) I don't plan on going back that far 2) that 11 day blip is ONLY good in so many countries. Other countries and/or religious and/or ethnic groups did things differently so the whole sheebang gets totally mind boggling if one wants to make this routine work 100% for all conditions. The benefits of storing dates in this manner are many fold and not limited to the list below: 1) DayOfTheWeek = (Days MOD 7) ' Sunday = 0 and Saturday = 6 2) The system is country independent 3) ToDay + 7 = SameDay_NextWeek ToDay + 28 = SameDay_NextMonth (4 weeks) 4) Validation of an incoming date is fast and quick using the same two routines and comparing the returned Y,M,D with what was sent. (You need to build such a checking routine) fYMD2Days& returns the number of days since 1-1-0001 fDays2YMD& returns the year, month, day and day of the week for a day number fJulianDay& returns the day number in a given year fLeapYear& returns 0 or 1 if the year is, in fact, a leap year. There's one more 'trick' you can use. If you're only going to be dealing with this code in a business situation and won't have to worry about archaic dates then you can store only the LOW WORD and add/subtract the HI WORD automatically. This will cut your storage space in half. Your first acceptable date would be 1-1-1877 and run through 6-6-2056. You'll add or subtract &hA748B from the incoming/outgoing day counts and store returned value in a WORD. (NOTE: Remove the REMed values in fYMD2Days and fDays2YMD) Hope these routines help you out. d83) $endif DECLARE FUNCTION fLEAPYEAR (BYVAL Year AS LONG) AS LONG DECLARE FUNCTION fYMD2Days (BYVAL Year AS LONG,BYVAL Month AS LONG,BYVAL Day AS LONG) AS LONG DECLARE FUNCTION fJulianDay (BYVAL Year AS LONG,BYVAL Month AS LONG,BYVAL Day AS LONG) AS LONG DECLARE FUNCTION fDays2YMD (BYVAL Days AS LONG,SEG Year AS LONG,SEG Month AS LONG,SEG Day AS LONG) AS LONG '--------------------------------------------------------- '------- start of test code ------------------------------ '--------------------------------------------------------- %QualityCheck = 0 FUNCTION PBmain () LOCAL Y1 AS LONG LOCAL M1 AS LONG LOCAL D1 AS LONG LOCAL Y2 AS LONG LOCAL M2 AS LONG LOCAL D2 AS LONG LOCAL Dz1 AS LONG LOCAL DoM AS LONG LOCAL T1 AS SINGLE fDays2YMD 2147483647, Y1, M1, D1 PRINT "These routines are Y5M compliant!" PRINT "The last date serviced is "; PRINT FORMAT$(Y1,"#,###,###\-"); PRINT FORMAT$(M1,"00\-"); PRINT FORMAT$(D1,"00") T1 = TIMER FOR Y1 = 1 TO 4000 $if %QualityCheck IF (Y1 MOD 100 ) = 0 THEN PRINT Y1 $endif DoM = &h3DFF7F9F IF fLeapYear(Y1) THEN BIT SET DoM, 5 FOR M1 = 1 TO 12 FOR D1 = 1 TO (DoM AND 31) Dz1 = fYMD2Days(Y1,M1,D1) fDays2YMD Dz1, Y2, M2, D2 $if %QualityCheck IF INSTAT THEN GOTO BailOut IF (Y1 <> Y2) OR (M1 <> M2) OR (D1 <> D2) THEN PRINT "ERROR" PRINT Dz1 PRINT Y1, M1, D1 PRINT Y2, M2, D2 GOTO BailOut END IF $endif NEXT SHIFT RIGHT DoM, 5 IF DoM = 0 THEN DoM = &h3FEFFBFF NEXT NEXT T1 = TIMER - T1 BailOut: PRINT STRING$(79,45) PRINT FORMAT$(Dz1, "Checked #,###,###,### days in " ); PRINT FORMAT$(T1, "###.#### seconds") PRINT "<>"; INPUT FLUSH WAITKEY$ END FUNCTION '--------------------------------------------------------- '------- end of test code -------------------------------- '--------------------------------------------------------- FUNCTION fDays2YMD (BYVAL Days AS LONG, _ SEG Year AS LONG, _ SEG Month AS LONG, _ SEG Day AS LONG ) AS LONG LOCAL D AS LONG LOCAL DoM AS LONG Year = 1 'load/reset outgoing params Month = 1 ' Day = Days -1 ' + &hA748B 'unREM if using WORDs ' IF Day > 146096 THEN 'check for Epochs (400years) Year = Year + (Day \ 146097) * 400 ' Day = (Day MOD 146097) ' take what's left END IF ' IF Day > 36523 THEN 'check for centuries (100years) D = (Day \ 36524) ' number of centuries IF D < 4 THEN ' we're working Year = Year + (D * 100) ' Day = (Day MOD 36524) ' ELSE ' we're on an even number of days Year = Year + 300 ' Day = 36524 ' reset day count END IF ' END IF ' IF Day > 1460 THEN 'check olympiads (4years) Year = Year + (Day \ 1461) * 4 ' Day = (Day MOD 1461) ' END IF ' IF Day > 364 THEN 'check years D = (Day \ 365) ' number of years IF D < 4 THEN ' we're working Year = Year + D ' Day = (Day MOD 365) ' ELSE ' we're on an even number of days Year = Year + 3 ' Day = 365 ' reset day count END IF ' END IF ' INCR Day ' put back lost day ' IF Day > 31 THEN 'compute month number (Month = 1 now) DoM = &h3DFF7F9F ' binary days of the months IF Day > 58 AND fLeapYear(Year) THEN BIT SET DoM, 5 ' it's leap year so Feb gains a day DO ' start checking D = (DoM AND 31) ' strip off day count for the month IF D => Day THEN EXIT LOOP ' we have a winner! Day = Day - D ' reduce days left by day count INCR Month ' add a month SHIFT RIGHT DoM, 5 ' shift day count into position IF DoM = 0 THEN DoM = &h3FEFFBFF ' July is next so load last 6 months LOOP ' END IF ' ' FUNCTION = (Days MOD 7) 'RETURN day of the week END FUNCTION FUNCTION fYMD2Days (BYVAL Year AS LONG, _ BYVAL Month AS LONG, _ BYVAL Day AS LONG ) AS LONG DIM DoM AS LONG IF Month > 1 THEN Day = fJulianDay(Year,Month,Day) 'compute Julian day DECR Year 'don't count 'this year' Day = Day + (Year * 365) + _ ' add full years (Year \ 4) - _ ' add a day for each olympiad (Year \ 100) + _ ' subtract a day for each century (Year \ 400) ' add a day for each epoch ' FUNCTION = Day ' - &hA748B 'RETURN day count ' unREM to use WORDs END FUNCTION FUNCTION fJulianDay (BYVAL Year AS LONG, _ BYVAL Month AS LONG, _ BYVAL Day AS LONG ) AS LONG DIM DoM AS LONG IF Month > 1 THEN 'if still Jan then nothing to do DoM = &h3DFF7F9F ' load in days of the months Jan - Jun IF Month > 2 AND fLeapYear(Year) THEN BIT SET DoM, 5 ' check for leap year & add 1 to Feb DO ' start counting Day = Day + (DoM AND 31) ' strip off day of the month IF Month = 2 THEN EXIT LOOP ' end of search DECR Month ' subtract a month SHIFT RIGHT DoM, 5 ' shift day count into position IF DoM = 0 THEN DoM = &h3FEFFBFF ' July is next so load last 6 months LOOP ' END IF ' ' FUNCTION = Day 'RETURN Day number for the year END FUNCTION FUNCTION fLeapYear (BYVAL Year AS LONG) AS LONG IF ( ( Year MOD 4 ) = 0 ) AND _ 'a leap year ( ( Year MOD 100 ) > 0 ) OR _ 'not a century ( ( Year MOD 400 ) = 0 ) THEN FUNCTION = 1 'or it _is_ an Epoc END FUNCTION