Later, they wanted their inhouse app to do something similar during shipping estimates ("Since that's a holiday,shipping will be delayed")
Here's what I came up with before they went out of business..
isHoliday.pbi
Code: Select all
;----------------------
;----[ Holiday ]-------
;----------------------
;-
; determins if a a date is a holiday. Holidays are not always 'static dates'
; and this calculates the date. It has some built in holidays,but you can specify your own
; but if you specify one, you need to specify all the holidays you want,it's either your list or built-in
; If you use it for business "closed"sort of thing, you can specify the days the business is closed (ie: sat/sun)
;
; not fully tested. Project that I did this for got "cancelled" and I'm not sure I want to keep at this just for fun.
;XIncludeFile "easter.pbi"
DeclareModule holiday
EnumerationBinary 0 ;- Exclude Days
#excludeNone
#excludeSunday
#excludeMonday
#excludeTuesday
#excludeWednesday
#excludeThursday
#excludeFriday
#excludeSaturday
#excludeClosestBusinsesDay
EndEnumeration
;- Decalred procedures
Declare.s getName( date.q = #NUL, bIncludeLesser=#False ) ; lesser only applies to built in holidays
Declare setNonWorkDays( dayFlags = #excludeNone )
Declare loadHolidayFile( cFile.s )
;- Declared macros
Macro isHoliday( date = #NUL ) : Bool( holiday::getName( date ) <> "" ) : EndMacro
EndDeclareModule
Module holiday
EnableExplicit
;- ---[ Constants ]---
Enumeration 0 ;- Days of week
#sunday
#monday
#tuesday
#wednesday
#thursday
#friday
#saturday
EndEnumeration
Enumeration 1 ;- Months
#january
#february
#march
#april
#may
#june
#july
#august
#september
#october
#november
#december
EndEnumeration
Enumeration -1 ;- oridinals
#last
#now
#first
#second
#third
#fourth
EndEnumeration
#error = -10
;- ---[ Structures ]---
Structure aDate
month.b
StructureUnion
day.b
dow.b
EndStructureUnion
occurance.b
EndStructure
Structure myHoliday
name.s
what.c
StructureUnion
date.adate
*function
EndStructureUnion
EndStructure
;- ---[ X Import Section ]---
;abandoned this, in case they don't want easter, this would cause an error load
;Import "easter.lib"
; easter( year )
;EndImport
;- ---[ Prototypes ]---
PrototypeC.q ptEaster( year.q ) ;can take full date
;- ---[ Data section ]---
DataSection ; Days of the Month (yes, I know, feb)
months:
Data.s "jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"
dom:
Data.b 31,29,31,30,31,30,31,31,30,31,30,31
occurances:
Data.s "5th","4th","3rd","2nd","las","","fir","sec","thi","fou","fif"
days:
Data.s "sun","mon","tue","wed","Thu","fri","sat"
EndDataSection
;- ---[ global vars ]---
Global gExcludedDays = #excludeNone
Global fnEaster.ptEaster
;info I'm lazy here. but to make it thread safe, I just went
; with one mutex... Should really have individual mutexes.
Global gLock = CreateMutex()
Global NewList myHolidays.myHoliday()
Global NewMap Months()
Global NewMap occurances()
Global NewMap Days()
;- ---[ Support Macros ]---
;Macro hDate( year, month, day ) : Date( year, month, day, 0,0,0) : EndMacro
; initial testing (not confirmed on multiple machinse) is that this is faster, but it may just be my machine.
Macro hDate( year, month, day ) : makeDateVal( year, month, day ) : EndMacro
Macro removeTime( date ) : hDate( Year(date), Month(Date), Day(date) ) : EndMacro
Macro ceiling( n ) : Round(n, #PB_Round_Up ) : EndMacro
Macro dow( day ) : DayOfWeek( day ) : EndMacro
Macro between( n, l, h ) : Bool(n>=l And n<=h) : EndMacro
Macro lockThings() : LockMutex( glock ) : EndMacro
Macro unlockThings() : UnlockMutex( glock ) : EndMacro
CompilerIf #PB_Compiler_Debugger ;- True Assert Macro
Macro dq
"
EndMacro
Macro assert(exp)
If Not (exp)
Debug "Assert FAIL [" + dq#Exp#dq +"] ("+#PB_Compiler_Filename+" @ " + #PB_Compiler_Line + ")"
CallDebugger
EndIf
EndMacro
CompilerElse ;- Non debug assert
Macro assert( exp ) : EndMacro
CompilerEndIf
;----[ Support Procedures ]---
;{ Support Procedures
;----[ includes ]---
XIncludeFile "MakeDateC.pbi"
;now called via import/dll or holidays.txt
; IncludeFile "easter.pbi" ; Returns date of easter for a given year.
;todo check for handling negative occurance (-1) in matchDynamicDate()
;todo need to test dynamic holidays falling on sat/sun in matchDynamicDate()
Procedure matchDynamicDate( matchDate, month, dow, occurance, bRecursed=#False )
Protected d, matched
If Month(matchDate) = month And dow(matchDate) = dow
If occurance > 0
matched = Bool( occurance = ceiling( Day(matchDate) / 7 ) )
Else
d = AddDate(matchDate, #PB_Date_Day, 7 )
matched = Bool( Month(d) > Month(matchDate) )
EndIf
EndIf
If Not matched And
Not bRecursed And
Not (gExcludedDays & #excludeClosestBusinsesDay)
Select DayOfWeek( matchDate )
Case #friday
matchDate = AddDate( matchDate, #PB_Date_Day, 1 )
matched = matchDynamicDate( matchDate, month, dow, occurance, #True)
Case #monday
matchDate = AddDate( matchDate, #PB_Date_Day, -1 )
matched = matchDynamicDate( matchDate, month, dow, occurance, #True)
EndSelect
; If dow( matchDate ) = #saturday ; let's check the day before
; dow - 1
; ElseIf dow( matchDate ) = #sunday ; let's check teh day after
; dow + 1
; EndIf
; matched = matchDynamicDate( matchDate, month, dow, occurance, #True)
EndIf
ProcedureReturn matched
EndProcedure
Procedure matchStaticDate( matchDate.q, year, month, day, bRecursed=#False)
Protected.q targetDate = hDate( year, month, day )
Protected matched
matchDate = removeTime( matchDate )
matched = Bool( matchDate = targetDate )
If Not matched And
Not bRecursed And
Not (gExcludedDays & #excludeClosestBusinsesDay)
; if the holday falls on a weekend, match closest workday
Select DayOfWeek( matchDate )
Case #friday
matchDate = AddDate( matchDate, #PB_Date_Day, 1 )
matched = matchStaticDate( matchDate, Year(matchDate), month, day, #True )
Case #monday
matchDate = AddDate( matchDate, #PB_Date_Day, -1 )
matched = matchStaticDate( matchDate, Year(matchDate), month, day, #True )
EndSelect
EndIf
ProcedureReturn matched
EndProcedure
Procedure excludedDay( day )
Protected excluded=#False
Select day
Case #sunday : excluded = Bool( gExcludedDays & #excludeSunday )
Case #monday : excluded = Bool( gExcludedDays & #excludeMonday )
Case #tuesday : excluded = Bool( gExcludedDays & #excludeTuesday )
Case #wednesday : excluded = Bool( gExcludedDays & #excludeWednesday )
Case #thursday : excluded = Bool( gExcludedDays & #excludeThursday )
Case #friday : excluded = Bool( gExcludedDays & #excludeFriday )
Case #saturday : excluded = Bool( gExcludedDays & #excludeSaturday )
EndSelect
ProcedureReturn excluded
EndProcedure
Procedure valMonth( cMonth.s)
Protected nMonth
cMonth=LCase(Left(Trim(cMonth),3))
cmonth = LTrim(cMonth,"0")
If FindMapElement( months(), cMonth )
lockThings()
nMonth = months(cMonth)
unlockThings()
Else
nMonth = #error
EndIf
ProcedureReturn nMonth
EndProcedure
Procedure valDay( cDay.s )
Protected nDay
cDay = LCase( Left( Trim( cDay ),3) )
cday = LTrim(cDay,"0")
If FindMapElement(days(),cday)
lockThings()
nday=days(cday)
unlockThings()
Else
nday=#error
EndIf
ProcedureReturn nDay
EndProcedure
Procedure valOccurance( cOccurance.s )
Protected nOccurance
cOccurance = LCase( Left( Trim( cOccurance),3))
If FindMapElement( occurances(), cOccurance )
lockThings()
nOccurance = occurances( cOccurance )
unlockThings()
Else
nOccurance=#error
EndIf
ProcedureReturn nOccurance
EndProcedure
Procedure initialize()
Protected i, tmp.s
lockThings()
Restore months
For i = #january To #december
Read.s tmp
months( tmp ) = i
months( Str(i) ) = i
Next
Restore occurances
For i = -5 To 5
Read.s tmp
occurances(tmp)=i
Next
Restore days
For i = 0 To 6
Read.s tmp
days( tmp ) = i
Next
For i = 1 To 31
days(Str(i))=i
Next
unlockThings()
loadHolidayFile("holidays.txt")
CompilerIf Defined(Easter,#PB_Module)
fnEaster=easter::@calculate()
CompilerElse
If FileSize( "easter.dll" ) > 0 ; only external, but builtin call
i = OpenLibrary( #PB_Any, "calculateEaster.dll" )
If i
fnEaster = GetFunction(i, "calculateEaster" );
EndIf
EndIf
CompilerEndIf
EndProcedure
Procedure.s checkBuiltIN( date.q, bIncludeLesser )
Protected holidayName.s
If matchStaticDate(date, Year(date), #january, 01 )
holidayName = "New years Day"
ElseIf matchStaticDate(date, Year(Date), #july, 04 )
holidayName = "4th of July"
ElseIf matchStaticDate(date, Year(Date), #december, 25 )
holidayName = "Christmas"
; Dynamic Holidays:
ElseIf matchDynamicDate( date, #may, #monday, #last )
holidayName = "Memorial Day"
ElseIf matchDynamicDate( date, #september, #monday, #first )
holidayName = "Labour Day"
ElseIf matchDynamicDate( date, #november, #thursday, #fourth ) Or
matchDynamicDate( date, #november, #friday, #fourth )
holidayName = "Thanksgiving"
ElseIf bIncludeLesser
If matchStaticDate(date, Year(Date), #november, 11 )
holidayName = "Veterans Day"
ElseIf matchStaticDate(date, Year(date), #september, 19 )
holidayName = "Juneteenth"
ElseIf fnEaster And date = fnEaster( Year(Date()) )
holidayName = "Easter"
ElseIf matchDynamicDate( date, #january, #monday, #third )
holidayName = "Martin Luther King Day"
ElseIf matchDynamicDate( date, #february, #monday, #third )
holidayName = "Presidents Day"
ElseIf matchDynamicDate( date, #october, #monday, #second )
holidayName = "Columbus Day"
EndIf
EndIf
ProcedureReturn holidayName
EndProcedure
;} End support prcedures
;- ---[ Exposed Procedures ]---
Procedure setNonWorkDays( dayFlags=#excludeNone )
Protected hold = gExcludedDays
gExcludedDays = dayFlags
ProcedureReturn hold
EndProcedure
Procedure loadHolidayFile( cFile.s )
Protected line.s,hFile, name.s, month, day, occurance, hDLL, *func
Protected Dim dom.b(12)
ClearList( myholidays() )
If FileSize(cFile)>0
hFile = ReadFile(#PB_Any, cFile, #PB_File_SharedRead)
If hFile
Restore dom
For month=#january To #december
Read.b dom(month)
Next
While Not Eof( hFile)
*func=#Null
line = Trim(ReadString(hFile))
If line<>"" And Left(line,1)<>"#" ;comment
;name|month|day/dow|occurance
If between(CountString(line,"|"), 2, 3)
name = StringField(line,1,"|")
If FileSize(StringField(line,2,"|")) > 0
hDLL = OpenLibrary(#PB_Any,StringField(line,2,"|"))
If hDLL
*func = GetFunction(hDLL, ReplaceString(StringField(line,3,"|"),"()",""))
If Not *func
CloseLibrary(hDLL)
EndIf
EndIf
Else
month = valMonth( StringField(line,2,"|") )
day = valDay( StringField(line,3,"|") )
occurance = valOccurance( StringField(line,4,"|") )
EndIf
If *func
lockThings()
AddElement(myHolidays())
With myHolidays()
\name = name
\what = 'F'
\function = *func
EndWith
unlockThings()
ElseIf name<>"" And
between( month, #january, #december ) And
between( day, 1, dom(month) ) And
(CountString(line,"|")=2 Or (occurance<>0 And between(occurance,-4,4)))
lockThings()
AddElement(myHolidays())
With myHolidays()
\name = name
If occurance
\what = 'D'
\date\dow = day
Else
\what = 'S'
\date\day = day
EndIf
\date\month = month
\date\occurance = occurance
EndWith
unlockThings()
EndIf
EndIf
EndIf
Wend
CloseFile( hFile )
EndIf
EndIf
ProcedureReturn ListSize( myHolidays() )
EndProcedure
Procedure.s getName( date.q = #NUL, bIncludeLesser=#False );, nonBusinessDays=#NUL )
Protected holidayName.s = ""
If date = #NUL
date = Date()
EndIf
If excludedDay( dow(date) )
holidayName = "Business Closed"
Else
lockThings()
ForEach myHolidays()
With myHolidays()
Select \what
Case 'F'
If date = CallCFunctionFast(\function, Date())
holidayName = \name
EndIf
Case 'D' ;\occurance
If matchDynamicDate(date,\date\month,\date\dow,\date\occurance)
holidayName = \name
Break
EndIf
Case 'S'
If matchStaticDate( date, Year(date),\date\month,\date\day)
holidayName = \name
Break
EndIf
EndSelect
EndWith
Next
unlockThings()
EndIf
If holidayName="" And ListSize( myHolidays() ) = 0
holidayName = checkBuiltIN( date, bIncludeLesser )
EndIf
ProcedureReturn holidayName
EndProcedure
initialize()
EndModule
;---------------------
;- ---[ DLL code ] ---
;---------------------
CompilerIf #PB_Compiler_ExecutableFormat=#PB_Compiler_DLL
IncludeFile "dll_load_kit.pbi"
ProcedureDLL loadHolidayFile( cFile.s )
ProcedureReturn holiday::loadHolidayFile( cFile )
EndProcedure
ProcedureDLL setNonWorkDays( flags = holiday::#excludeNone )
ProcedureReturn holiday::setNonWorkDays( flags )
EndProcedure
ProcedureDLL isHoliday( date.q=#NUL )
ProcedureReturn holiday::isHoliday( date )
EndProcedure
ProcedureDLL getHolidayName( date.q=#NUL, bIncludeLesser=#False )
Protected name.s = holiday::getName( Date, bIncludeLesser )
Protected *p = #NUL
If name <> ""
*p = dllAllocateString( name )
EndIf
ProcedureReturn *p
EndProcedure
CompilerEndIf
;---------------------
;- ---[ Test code ]---
;---------------------
CompilerIf #PB_Compiler_IsMainFile ;- Test stuff.
CompilerIf #True ; (use file/source, otherwise, use dll )
;Debug holiday::loadHolidayFile()
Debug "My "+holiday::getName( Date( 2024, 05, 12, 0,0,0) )
Debug "NY "+holiday::getName( Date( 2028, 01, 01, 0,0,0) ) ; a saturday
; should be empty....
Debug "nothing "+holiday::getName( Date( 2028, 01, 02, 0,0,0) ) ; a saturday
holiday::setNonWorkDays(holiday::#excludeSaturday|holiday::#excludeSunday)
Debug "Closed "+holiday::getName( Date( 2028, 01, 02, 0,0,0) ) ; a saturday
Debug "NY "+holiday::getName( Date( 2024, 01, 01, 0,0,0) ) ; NY
Debug "Labour "+holiday::getName( Date( 2024, 09, 02, 0,0,0) ) ; Labour Day
Debug "Memorial "+holiday::getName( Date( 2024, 05, 27, 0,0,0) ) ; Memorial Day
Debug "easter "+holiday::getName( Date(2024,03,31,0,0,0), #True) ; easter
holiday::setNonWorkDays( holiday::#excludeNone )
Debug "easter "+holiday::getName( Date(2024,03,31,0,0,0), #True) ; easter
Debug "NY "+holiday::getName( Date( 2028, 01, 01, 0,0,0) ) ; saturday NY
Debug Str( DayOfWeek( Date(2028,01,01, 0,0,0) ) ) + " (Saturday = 6, Sunday = 0)"
;fixme this should also be flagged as "NY"
Debug "NY (day before) "+holiday::getName( Date( 2027, 12, 31, 0,0,0) ) ; Friday - before actual NY
Debug "NY "+holiday::getName( Date( 2034, 01, 01, 0,0,0) ) ; sunday NY
Debug "NY (day after) "+holiday::getName( Date( 2034, 01, 02, 0,0,0) ) ; Monday
CompilerElse ;{ DLL Test code
EnumerationBinary 0 ; Exclude Days
#excludeNone
#excludeSunday
#excludeMonday
#excludeTuesday
#excludeWednesday
#excludeThursday
#excludeFriday
#excludeSaturday
#excludeClosestBusinsesDay
EndEnumeration
; (Use DLL)
Import "isHoliday.lib"
setNonWorkDays( flags=#excludeNone )
loadHolidayFile( cFile.s )
isHoliday( date.q=#Null )
getHolidayName( date.q=#Null, bIncludeLesser=#False)
dllFreeMemory( *p ) ; should be called after getHolidayDate()
EndImport
Procedure.s getName( date.q )
Protected name.s, *p
*p = getHolidayName( date )
If *p
name=PeekS(*p)
dllFreeMemory( *p )
EndIf
ProcedureReturn name
EndProcedure
Debug getName( Date( 2028, 01, 01, 0,0,0) ) ; a saturday
; should be empty....
Debug getName( Date( 2028, 01, 02, 0,0,0) ) ; a saturday
setNonWorkDays(#excludeSaturday|#excludeSunday)
Debug getName( Date( 2028, 01, 02, 0,0,0) ) ; a saturday
Debug getName( Date( 2024, 01, 01, 0,0,0) ) ; NY
Debug getName( Date( 2024, 09, 02, 0,0,0) ) ; Labour Day
Debug getName( Date( 2024, 05, 27, 0,0,0) ) ; Memorial Day
setNonWorkDays( #excludeNone )
Debug getName( Date( 2028, 01, 01, 0,0,0) ) ; saturday NY
Debug Str( DayOfWeek( Date(2028,01,01, 0,0,0) ) ) + " (Saturday = 6, Sunday = 0)"
;fixme this should also be flagged as "NY"
Debug getName( Date( 2027, 12, 31, 0,0,0) ) ; Friday - before actual NY
Debug getName( Date( 2034, 01, 01, 0,0,0) ) ; sunday NY
Debug getName( Date( 2034, 01, 02, 0,0,0) ) ; Monday
;}
CompilerEndIf
CompilerEndIf
Code: Select all
; as a module so it's accessible in other modules.
DeclareModule easter
Declare.q calculate( year.l )
EndDeclareModule
Module easter
Procedure.q calculate( year.l )
Protected day, month, easter.q ;,nulPassed=#False
;If year = #NUL
; nulPassed = #True
; year = Year(Date())
;EndIf
; original algorithm by Samuel Butcher, 1877
; Modified & now the Meeus/Jones/Butcher alogithm
; https://en.wikipedia.org/wiki/Date_of_Easter#Anonymous_Gregorian_algorithm
CompilerIf #PB_Compiler_Backend=#PB_Backend_C
; Yes c code has a slight advantage (no casting?)
; and about 2x faster if debugger is enabled
; Every bit helps when scanning against large data sets...
!{
! int a,b,c,d,e,f,g,h,i,k,l,m; //,n,o
! a = v_year%19; b = v_year/100; c = v_year%100; d = b/4;
! e = b%4; f = (b+8)/25; g = (b-f+1)/3; h = (19*a+b-d-g+15)%30;
! i = c/4; k = c%4; l = (32+2*e+2*i-h-k)%7; m = (a+11*h+22*l)/451;
!
! v_month = (h+l-7*m+114)/31; // 'n' in aglorithm
! v_day = (h+l-7*m+114)%31 + 1; // 'o' in algorithm NB: I added the "+ 1"
!}
CompilerElse
Protected a,b,c,d,e,f,g,h,i,k,l,m ;,n,o
a = year%19 : b = year/100 : c = year%100 : d = b/4
e = b%4 : f = (b+8)/25 : g = (b-f+1)/3 : h = (19*a+b-d-g+15)%30
i = c/4 : k = c%4 : l = (32+2*e+2*i-h-k)%7 : m = (a+11*h+22*l)/451
month = (h+l-7*m+114)/31 ; 'n' in aglorithm
day = (h+l-7*m+114)%31 + 1 ; 'o' in algorithm NB: I added the "+ 1"
CompilerEndIf
easter = Date( year, month, day, 0,0,0)
;If nulPassed And easter < Date()
; easter = easter( year + 1 )
;EndIf
ProcedureReturn easter
EndProcedure
EndModule
CompilerIf #PB_Compiler_IsMainFile And #PB_Compiler_ExecutableFormat=#PB_Compiler_Executable
#ymd = "%yyyy-%mm-%dd"
Debug FormatDate( #ymd, easter::calculate(1961) ) ; 2 April
Debug FormatDate( #ymd, easter::calculate(2024) ) ; 31 March
Debug FormatDate( #ymd, easter::calculate(2025) ) ; 20 April
CompilerElseIf #PB_Compiler_ExecutableFormat = #PB_Compiler_DLL
ProcedureDLL.q calculateEaster( year.l )
ProcedureReturn easter::calculate(year)
EndProcedure
CompilerEndIf
Code: Select all
# static dates are>> name | month | day-of-month (1-31)
My Holiday|May|12
New Years|January|01
4th of July|July|04
Christmas|December|25
# dynamic dates are>> name |month | day-of-week | occurance
Memorial Day|May|Monday|Last
Labour Day|September|Monday|First
Thanksgiving|November|Thursday|Fourth
Thanksgiving|November|Friday|Fourth
Veterans Day|November|11
Juneteenth|September|19
# DLL based is>> name | dll file name | function-name, do not specify parameters here.
# It MUST accept 1 parameter: Year,
# and return a date (use tools.dll, makeDate(year,month,day), or pb's date(year,month,day,0,0,0))
Resurrection|easter.dll|easter()
Martin Luther, Jr Day|January|Monday|Third
Presidents Day|February|Monday|Third
Columbus Day|October|Monday|Second
# Here is a simple function to return a datevalue
# #define daysUntil1970 719163
# #define secondsPerDay 86400
# int makeDateVal( int year, int month, int day ) {
# int ds;
# ds = (month-1)*31+day;
# if( month >= 3 )
# ds += (( year%400 && (year%4 && year%100)?0:1) - (int)(0.4*month + 2.3));
# ds += (--year*365 + (year/4));
# ds = ds - (year/100) + (year/400);
# ds -= daysUntil1970; ds *= secondsPerDay;
# return( ds );
# }