I'm working on my calendaring routines port to FB. Some of the highlights are:
The FB version is based on the basic date and time format as a 64 bit LONGINT representing the number of milliseconds since January 1, 1 at midnight.
Dates can be cast as GREGORIAN, JULIAN, EGYPTIAN, ARMENIAN, COPTIC, ETHIOPIC, ISLAMIC (astronomical on international dateline as defined on moonsighting.com), HEBREW, HINDU (lunar and solar), CHINESE (multiple locations), PERSIAN, BAHAI, EXCEL (1900 and 1904 based), or UNIX.
Rules based date calculations that can be tied to any supported calendar and mixed together in one calculation invocation. (Also used to support business day calculations)
Straight forward arithmetical date and time calculations such as adding or subtracting.
Fiscal years and rolling 13 month summaries supported.
Range from -10,000 to +10,000 years supported.
Solar and lunar events supported. (sunrise/set, moonrise/set, lunar illumination, lunar/solar distances, etc)
Miscellaneous calculations such as day of week, leap year, sabbatical year (hebrew), etc.
Goal is pure FB code without any required includes. When the preliminary coding is complete and I've run test scripts until my eyes ache, I'll look at building it all into an object class.
Sounds like a great project! It should also help you to get acquainted with the differences between FB and PB.
:)
I agree in that I'll learn most of the quirks and differences. The MOD workaround I posted was the first big difference I came across. It took me a bit to realize that FB MOD was integers only.
It looks like Jose is being Jose and FF will be an interesting effort to get the full benefit of his work. I wasn't sure of what I was going to do until his FB includes started sprouting wings. It's the synergy of FF and his includes that gives me the foundation for going forward.
Before I get to committed to a way to encapsulate all the functions, I thought I would query the sage minds here for the best organization. Here is my first cut:
Type cCalendar
Private:
nAnything as Long
Declare Function privateFunction() as Long
Public:
Declare Function myFunction() as Long
End Type
Function cCalendar.myFunction() as Long
Function = privateFunction()
End Function
Function cCalendar.privateFunction() as Long
Function = 1
End Function
Thoughts?
Here's my small, initial proof of concept.
Const GREGORIAN_EPOCH = 1 ' January 1, 0001
' Time
Const ONE_DAY as LongInt = 86400000 ' Milliseconds in a day
Const ONE_HOUR as LongInt = 3600000 ' Milliseconds in a hour
Const ONE_MINUTE as LongInt = 60000 ' Milliseconds in a minute
Const ONE_SECOND as LongInt = 1000 ' Milliseconds in a second
' Gregorian Months
Const JANUARY = 1
Const FEBRUARY = 2
Const MARCH = 3
Const APRIL = 4
Const MAY = 5
Const JUNE = 6
Const JULY = 7
Const AUGUST = 8
Const SEPTEMBER = 9
Const OCTOBER = 10
Const NOVEMBER = 11
Const DECEMBER = 12
' Defined date types
Type GREGORIAN_DATE
Month as Short
Day as Short
Year as Long
Hour as Short
Minute as Short
Second as Short
Millisecond as Short
Weekday as Short
LeapYear as BOOLEAN
End Type
' The basic date and time format is a 64 bit LONGINT representing the number of
' milliseconds since January 1, 1 at midnight referred to as a serial date.
' A moment is a double precision value representing the days since January 1, 1
' with the fractional part representing a portion of one day.
' Calculations involving astronomical events use algorithms that are fairly precise
' within +- 2000 years or so. Outside that range, errata increase the farther from
' that range. Sunrise, Sunset, Moonrise, Moonset times are +- 10 min or so from
' published values
' ########################################################################################
' cCalendar Class
' ########################################################################################
Type cCalendar Extends Object
Private:
' Gregorian support
Declare Function cmGregorianLeapYear (ByVal nYear as Long) as BOOLEAN
Declare Function cmDaysFromGregorian(ByVal nMonth as Long, _
ByVal nDay as Long, _
ByVal nYear as Long) as Long
Declare Sub cmGregorianFromDays(ByVal nDays as Long, _
ByRef nMonth as Short, _
ByRef nDay as Short, _
ByRef nYear as Long)
Declare Function cmGregorianWeekDay (ByVal nDays as Long) as Short
Declare Function cmGregorianYearFromDays (ByVal nDays as Long) as Long
Declare Sub cmGregorianYearRange(ByVal nYear as Long, _
ByRef nYearStart as Long, _
ByRef nYearEnd as Long)
' Common support
Declare Sub cmTimeFromSerial(ByVal nTime as Long, _
ByRef nHour as Short, _
ByRef nMinute as Short, _
ByRef nSecond as Short, _
ByRef nMillisecond as Short)
Declare Function cmTimeToSerial(ByVal nHour as Short, _
ByVal nMinute as Short, _
ByVal nSecond as Short, _
ByVal nMillisecond as Short) as Long
Declare Sub cmSerialBreakApart(ByRef nSerial as LongInt, _
ByRef nDays as Long, _
ByRef nTime as Long)
Declare Function cmAMod(ByVal x as Double, ByVal y as Double) as Double
Declare Function cmMod(ByVal x as Double, ByVal y as Double) as Double
Declare Function cmRound(ByVal x as Double) as Long
Declare Function cmCeiling(ByVal x as Double) as Long
Declare Function cmFloor(ByVal x as Double) as Long
Declare Function cmSignum (ByVal nAny as Double) as Long
Public:
Declare Constructor
Declare Destructor
' Gregorian Interface
Declare Sub GregorianFromSerial(ByVal nSerial as LongInt, _
ByRef uDate as GREGORIAN_DATE)
Declare Function SerialFromGregorian(ByRef uDate as GREGORIAN_DATE) as LongInt
End Type
Constructor cCalendar()
End Constructor
Destructor cCalendar()
End Destructor
' ========================================================================================
' Gregorian Date from Serial
' ========================================================================================
Sub cCalendar.GregorianFromSerial(ByVal nSerial as LongInt, _
ByRef uDate as GREGORIAN_DATE)
Dim nDays as Long
Dim nTime as Long
cmSerialBreakApart(nSerial,nDays,nTime)
cmGregorianFromDays(nDays,uDate.Month,uDate.Day,uDate.Year)
cmTimeFromSerial(nTime,uDate.Hour,uDate.Minute,uDate.Second,uDate.Millisecond)
uDate.Weekday = cmGregorianWeekDay(nDays)
End Sub
' ========================================================================================
' Serial Date from Gregorian
' ========================================================================================
Function cCalendar.SerialFromGregorian(ByRef uDate as GREGORIAN_DATE) as LongInt
Dim nSerialDays as LongInt
Dim nSerialTime as LongInt
nSerialDays = cmDaysFromGregorian(uDate.Month,uDate.Day,uDate.Year)
nSerialTime = cmTimeToSerial(uDate.Hour,uDate.Minute,uDate.Second,uDate.Millisecond)
Function = (Abs(nSerialDays) * ONE_DAY + nSerialTime) * IIf(nSerialDays < 0,-1,1)
End Function
' ########################################################################################
' Gregorian Support
' ########################################################################################
' ========================================================================================
' Return the Gregorian month,day, and year from a days date
' ========================================================================================
Sub cCalendar.cmGregorianFromDays(ByVal nDays as Long, _
ByRef nMonth as Short, _
ByRef nDay as Short, _
ByRef nYear as Long)
Dim nPriorDays as Long
' Calculate Year
nYear = cmGregorianYearFromDays(nDays)
' Calculate Prior Days
nPriorDays = nDays _
- cmDaysFromGregorian(JANUARY, _
1, _
nYear)
' Adjust for assumption in above calculation
' that Feb always has 30 days
Select Case nDays
Case Is < cmDaysFromGregorian(MARCH, _
1, _
nYear)
Case Else
nPriorDays = nPriorDays + 1
nPriorDays = nPriorDays _
+ IIf(cmGregorianLeapYear(nYear) = True,0,1)
End Select
'
' Calculate Month
'
nMonth = cmFloor((12 * nPriorDays + 373) / 367)
'
' Calculate Day
'
nDay = nDays _
- cmDaysFromGregorian(nMonth,1,nYear) _
+ 1
End Sub
' ========================================================================================
' Given a Days date, return the gregorian year
' ========================================================================================
Function cCalendar.cmGregorianYearFromDays (ByVal nDays as Long) as Long
' 146097 represents the last day of a leap year of a 400 year cycle
' 1461 represents the last day of a 4 year cycle
' 36524 is the average length in days of one gregorian century
Dim nCenturies400 as Long
Dim nCenturies100 as Long
Dim nFourYearCycles as Long
Dim nYears as Long
Dim nD1 as Long
Dim nD2 as Long
Dim nD3 as Long
Dim nYear as Long
nDays = nDays - 1
' Number of Leap Year Centuries
nCenturies400 = cmFloor(nDays / 146097)
' Number of Centuries
nD1 = cmMod(nDays,146097)
nCenturies100 = cmFloor(nD1 / 36524)
nD2 = cmMod(nD1,36524)
' Number of 4 year cycles
nFourYearCycles = cmFloor(nD2 / 1461)
' Number of Years
nD3 = cmMod(nD2,1461)
nYears = cmFloor(nD3 / 365)
nYear = (400 * nCenturies400) _
+ (100 * nCenturies100) _
+ (4 * nFourYearCycles) _
+ nYears
' Adjustment for leap years past
' If nCenturies = 4 or nYears = 4 then we need to increment the year returned
If nCenturies100 = 4 Then
Else
If nYears = 4 Then
Else
nYear = nYear + 1
End If
End If
Function = nYear
End Function
' ========================================================================================
' Given a Gregorian month, day, and year, return the days date version.
' The days date represents the number of days since Jan 1, 1.
' ========================================================================================
Function cCalendar.cmDaysFromGregorian(ByVal nMonth as Long, _
ByVal nDay as Long, _
ByVal nYear as Long) as Long
Dim nDaysDate as Long
Dim nPriorYear as Long
nMonth = Abs(nMonth)
nDay = Abs(nDay)
nPriorYear = nYear - 1
' Add:
'
' Number of days in prior years
' Number of days in prior months of current year
' Number of days in current month
'
' Assumption at this point is that Feb has 30 days
nDaysDate = GREGORIAN_EPOCH - 1 _
+ cmFloor(365 * nPriorYear) _ ' Days in prior years
+ cmFloor(nPriorYear / 4) _ ' Leap Year days
- cmFloor(nPriorYear / 100) _ ' Century Years Adjust
+ cmFloor(nPriorYear / 400) _ ' Century Years Adjust
+ cmFloor(((367 * nMonth) - 362) / 12) ' Days in prior months this year
' Adjust for assumption that Feb has 30 days
Select Case nMonth
Case Is < 3
Case Else
nDaysDate = nDaysDate - IIf(cmGregorianLeapYear(nYear) = True,1,2)
End Select
Function = nDaysDate + nDay
End Function
' ========================================================================================
' Determine if a Gregorian year is a leap year
' ========================================================================================
Function cCalendar.cmGregorianLeapYear (ByVal nYear as Long) as BOOLEAN
' Year is a leap year if evenly divisible by 4
' and if Year is a century year (ends with 00)
' it is also evenly divisible by 400
Dim nLeapYear as BOOLEAN
nLeapYear = False
Select Case cmMod(nYear,4)
Case Is <> 0
Case Else
Select Case cmMod(nYear,400)
Case 100
Case 200
Case 300
Case Else
nLeapYear = True
End Select
End Select
Function = nLeapYear
End Function
' ========================================================================================
' Calculate the Gregorian day of the week
' ========================================================================================
Function cCalendar.cmGregorianWeekDay (ByVal nDays as Long) as Short
' Sun = 0
' Mon = 1
' Tue = 2
' Wed = 3
' Thu = 4
' Fri = 5
' Sat = 6
Function = Abs(cmFloor(cmMod(nDays,7)))
End Function
' ########################################################################################
' Common Support
' ########################################################################################
' ========================================================================================
' Convert time to serial time which is the number of milliseconds
' since midnight for one day. It's possible to provide a mix of
' time that exceeds one day.
' ========================================================================================
Function cCalendar.cmTimeToSerial(ByVal nHour as Short, _
ByVal nMinute as Short, _
ByVal nSecond as Short, _
ByVal nMillisecond as Short) as Long
Function = Abs(nHour) * ONE_HOUR _
+ Abs(nMinute) * ONE_MINUTE _
+ Abs(nSecond) * ONE_SECOND _
+ Abs(nMillisecond)
End Function
' ========================================================================================
' Extract time from a serial period
' ========================================================================================
Sub cCalendar.cmTimeFromSerial(ByVal nTime as Long, _
ByRef nHour as Short, _
ByRef nMinute as Short, _
ByRef nSecond as Short, _
ByRef nMillisecond as Short)
Dim nDays as Long
' Remove anything that might exceed one day
nDays = cmFloor(nTime / ONE_DAY)
nTime = nTime - nDays * ONE_DAY
' If nTime is < 0 assume it has wrapped back past midnight
If nTime < 0 Then
nTime = cmFloor(cmMod(nTime,ONE_DAY))
End If
nHour = cmFloor(nTime / ONE_HOUR)
nTime = nTime - nHour * ONE_HOUR
nMinute = cmFloor(nTime / ONE_MINUTE)
nTime = nTime - nMinute * ONE_MINUTE
nSecond = cmFloor(nTime / ONE_SECOND)
nMillisecond = nTime - nSecond * ONE_SECOND
End Sub
' ========================================================================================
' Breakapart nSerial representing the number of milliseconds since January 1, 1 at midnight
' ========================================================================================
Sub cCalendar.cmSerialBreakApart(ByRef nSerial as LongInt, _
ByRef nDays as Long, _
ByRef nTime as Long)
' nDays = days since January 1, 0001
' nTime = number of milliseconds for partial day
nDays = cmFloor(Abs(nSerial) / ONE_DAY) * IIf(nSerial < 0,-1,1)
nTime = cmMod(Abs(nSerial),ONE_DAY)
End Sub
' ========================================================================================
' Variation of x MOD y for Real Numbers adjusted so that the modulus
' of a multiple of the divisor is the divisor itself rather than zero.
'
' If x MOD y = 0 then result is adjusted to y
' ========================================================================================
Function cCalendar.cmAMod(ByVal x as Double, ByVal y as Double) as Double
Function = x - y * (cmCeiling(x / y) - 1)
End Function
' ========================================================================================
' x MOD y for Real Numbers, y<>0
' ========================================================================================
Function cCalendar.cmMod(ByVal x as Double, ByVal y as Double) as Double
Function = x - y * cmFloor(x / y)
End Function
' ========================================================================================
' Round x up to nearest integer
' ========================================================================================
Function cCalendar.cmRound(ByVal x as Double) as Long
Function = cmFloor(x + .5)
End Function
' ========================================================================================
' Return smallest integer greater than or equal to x
' ========================================================================================
Function cCalendar.cmCeiling(ByVal x as Double) as Long
Function = cmFloor(x * -1) * -1
End Function
' ========================================================================================
' Return largest integer less than or equal to x
' ========================================================================================
Function cCalendar.cmFloor(ByVal x as Double) as Long
Function = Int(x)
End Function
' ========================================================================================
' Return the sign of nAny
' ========================================================================================
Function cCalendar.cmSignum (ByVal nAny as Double) as Long
' Return the sign of nAny
Dim nSign as Long
Select Case nAny
Case Is < 0
nSign = -1
Case Is > 0
nSign = 1
Case Else
nSign = 0
End Select
Function = nSign
End Function
And a quick test...
Dim oCalendar as cCalendar
Dim uGregIn as GREGORIAN_DATE
Dim uGregOut as GREGORIAN_DATE
Dim nSerial as LongInt
uGregIn.Month = 9
uGregIn.Day = 8
uGregIn.Year = 2016
nSerial = oCalendar.SerialFromGregorian(uGregIn)
oCalendar.GregorianFromSerial(nSerial,uGregOut)
Print Str(uGregOut.Month) + "." + Str(uGregOut.Day) + "." + Str(uGregOut.Year) + " weekday is " + Str(uGregOut.Weekday)
A long way to go still......