Download text file
$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,Year AS LONG,Month AS LONG,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, _
Year AS LONG, _
Month AS LONG, _
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