Calendaring FB Port

[Richard Kelly]

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.

[Paul Squires]

Sounds like a great project! It should also help you to get acquainted with the differences between FB and PB.

[Richard Kelly]

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.

[Richard Kelly]

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:

Code Select Expand


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?

[Richard Kelly]

Here's my small, initial proof of concept.

Code Select Expand


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...

Code Select Expand


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......