PureBasic Forums - English

Code: Select all

Procedure.i MonthLen(date)

	date=Date(Year(date),Month(date),28,0,0,0)+864000
	ProcedureReturn Day(Date(Year(date),Month(date),1,0,0,0)-86400)

EndProcedure


For i=1 To 12
	Debug MonthLen(Date(2016,i,i,0,0,0))
Next i

Code: Select all

Procedure DaysInMonth(DateQ.q)
  Protected I.DateQInfo : DateQInfo(@I, DateQ)
  If I\month < 8
    If I\month = 2
      ProcedureReturn 28 + IsLeapYear(I\year)
    Else
      ProcedureReturn 30 + I\month & 1  
    EndIf
  Else
    ProcedureReturn 31 - I\month & 1 
  EndIf
EndProcedure

Code: Select all

Procedure DaysInMonth(DateQ.q)
	
	Protected I.DateQInfo : DateQInfo(@I, DateQ)
	
	If I\month = 2
		ProcedureReturn 28 + IsLeapYear(I\year)
	Else
		ProcedureReturn (30 + I\month & 1) ! (I\month>>3)
	EndIf

EndProcedure

Code: Select all

DisableDebugger
Procedure TakesAWhile()
	ProcedureReturn Random(1)
EndProcedure
Procedure DaysInMonth(month.i)

	If month-2
		ProcedureReturn (30 + month & 1) ! (month>>3)
	Else
		ProcedureReturn 28 + TakesAWhile()
	EndIf

EndProcedure

ti-ElapsedMilliseconds()
For i=0 To 999999
	For m=1 To 12
		z+DaysInMonth(m)
	Next m
Next i
ti+ElapsedMilliseconds()
EnableDebugger
Debug ti

Code: Select all

; Calendar functions library written with FASM assembler.
;
; Abilities:
;	* works with dates from the interval of 11 million years:
;		- from 1 Jan 5843880 BCE to 3 Aug 5915100 for the Julian calendar,
;		- from 30 Dec 5844001 BCE to 17 Jan 5915222 for the Gregorian calendar,
;	* convenient conversions between Julian and Gregorian calendars for dates
;	  from supported time interval,
;	* calculation of the day of the week for the given date,
;	* calculation of the number of the day in the year,
;	* determining if the given year is leap in chosen calendar,
;	* calculation of the "absolute" day number for the given date (it could be
;	  used to calculation of the distance between two dates).	  
;
; (C) Mikołaj Hajduk, 16.06.2008.
;
format PE GUI 4.0 DLL
entry DllEntryPoint

include 'win32a.inc'

; Definitions of the used constants.
;
C1	= 365			; Number of days in a normal year.

C4	= 4*C1 + 1		; Number of days in the 4-year cycle (base cycle of the Julian
				; calendar).
				
C100	= 25*C4 - 1		; Number of days in a "normal" century in the Gregorian calendar
				; (i.e. century ending with a normal, 365-day, year).

C400	= 4*C100 + 1		; Number of days in the complete 400-year cycle of the Gregorian
				; calendar. 

k	= 30

J	= 194796		; The constants J and G are equal to the numbers of the complete years
G	= 194800		; of the Julian and Gregorian calendars respectively contained in the 
				; time interval given by "Great Cycle" T.


section '.data' data readable writeable

; Table containing lengths of months of a normal year (first 12 elements) and a leap year 
; (next 12 elements).
;
MonthLen	db 31,  28,  31,  30,  31,  30,  31,  31,  30,  31,  30,  31
		db 31,  29,  31,  30,  31,  30,  31,  31,  30,  31,  30,  31

; Table containing values of the function 'DaySum' for every pair (month number, leap year flag).
;
DaySum		dw  0,  31,  59,  90, 120, 151, 181, 212, 243, 273, 304, 334
		dw  0,  31,  60,  91, 121, 152, 182, 213, 244, 274, 305, 335


section '.code' code readable executable

proc	DllEntryPoint, hinstDLL, fdwReason, lpvReserved
	mov	eax, TRUE
	ret
endp

; DWORD DayOfWeek(DWORD Y, DWORD M, DWORD D, DWORD Gregorian)
;
; This function calculates the day of the week for the given date. Each day of the week is identified by number:
; 0 - Sunday, 1 - Monday, 2 - Tuesday, 3 - Wednesday, 4 - Thursday, 5 - Friday, 6 - Saturday.
;
; Parameters:
;	Y - year,
;	M - month,
;	D - day,
;	Gregorian - chosen calendar (0 - Julian, 1 - Gregorian).
;
; Returned values:
;	* 0, 1, ..., 6 if the date is valid,
;	* -1 for the invalid parameters.
;
proc	DayOfWeek, Y, M, D, Gregorian

	pushfd
	push	ebx edx

	stdcall DateToAbsDayNum, [Y], [M], [D], [Gregorian]		; eax := N
	test	eax, eax
	jz	.Error

	mov	ebx, 7							;
	xor	edx, edx						;
	add	eax, 5							; edx := (eax + 5) mod 7 = (N + 5) mod 7
	adc	edx, edx						;
	div	ebx							;

	xchg	eax, edx						; eax := edx
	jmp	.End

	.Error:
		mov	eax, -1
	.End:

	pop	edx ebx
	popfd

	ret
endp

; DWORD IsLeapYear(DWORD Y, DWORD Gregorian)
;
; This function determines if the given year is leap in the chosen calendar.
;
; Parameters:
;	Y - year,
;	Gregorian - chosen calendar (0 - Julian, 1 - Gregorian).
;
; Returned values:
;	* 1 if the year Y is leap, 0 - in opposite case,
;	* -1 for the invalid parameters.
;
proc	IsLeapYear, Y, Gregorian

	pushfd
	push	ebx edx

	.CheckParameters:
		test	[Gregorian], -2					; 0 <= Gregorian <= 1
		jnz	.Error						;

	.IsYNegative:
		mov	eax, [Y]					; eax := Y
		test	eax, eax
		jz	.Error
		jns	.CheckCalendar
									; eax < 0 (Y < 0)
									;
		inc	eax						; eax := eax + 1
		neg	eax						; eax := -eax = -(Y + 1) = -Y - 1 =
									;      = |Y| - [Y < 0] = Y'

	.CheckCalendar:
		cmp	[Gregorian], 0
		je	.mod4

	.Gregorian:
		xor	edx, edx					; eax := E(eax / 100) = E(Y' / 100)
		mov	ebx, 100					; edx := eax mod 100 = Y' mod 100
		div	ebx						; 

		test	edx, edx
		jz	.mod4

		mov	eax, edx					; eax := edx = Y' mod 100
									; 
									; {(Y' mod 100) mod 4 = Y' mod 4} 

	.mod4:
		shr	eax, 1						; eax := E(eax / 2); CF := eax mod 2
		jc	.Result						; 

		shr	eax, 1						; eax := E(eax / 2); CF := eax mod 2
		jmp	.Result						;

	.Error:
		mov	eax, -1
		jmp	.End

	.Result:
		setnc	al						; eax := not CF
		movzx	eax, al						;

	.End:

	pop	edx ebx
	popfd

	ret
endp

; DWORD MDToDayNum(DWORD M, DWORD D, DWORD LeapYearFlag)
;
; This function calculates the ordinal number of the day in the year.
;
; Parameters:
;	M - month,
;	D - day,
;	LeapYearFlag - flag determining if the year is leap (0 - normal year, 1 - leap year).
;
; Returned values:
;	* 1, 2, ..., 365 for the normal year, 1, 2, ..., 366 for the leap year,
;	* -1 for the invalid parameters.
;
proc	MDToDayNum, M, D, LeapYearFlag

	pushfd
	push	ebx edx

	.LeapYearFlag:
		test	[LeapYearFlag], -2				; 0 <= LeapYearFlag <= 1
		jnz	.Error						;

	.Month:
		cmp	[M], 1						;
		jb	.Error						; 1 <= M <= 12
		cmp	[M], 12						;
		ja	.Error						;

	.Day:
		cmp	[D], 1						; D >= 1
		jb	.Error						;

		mov	ebx, [LeapYearFlag]				; ebx := LeapYearFlag
		lea	ebx, [ebx + 2*ebx]				; ebx := 3*ebx = 3*LeapYearFlag
		shl	ebx, 2						; ebx := 4*ebx = 12*LeapYearFlag

		mov	edx, [M]					; eax := MonthLen[M - 1 + 12*LeapYearFlag]
		movzx	eax, [MonthLen - 1 + ebx + edx]			;

		cmp	[D], eax					; D <= MonthLen[M - 1 + 12*LeapYearFlag]
		ja	.Error						;

	.CalculateDayNum:
		shl	ebx, 1						; ebx := 2*ebx = 24*LeapYearFlag
		movzx	eax, [DaySum - 2 + ebx + 2*edx]			; eax := DaySum(M, LeapYearFlag)
		add	eax, [D]					; eax := eax + D = DaySum(M, LeapYearFlag) + D 
		jmp	.End

	.Error:
		mov	eax, -1

	.End:

	pop	edx ebx
	popfd

	ret
endp

; DWORD DayNumToMD(DWORD n, DWORD LeapYearFlag, DWORD* M, DWORD* D)
;
; This function converts the ordinal number of the day in the year to the adequate month and day numbers. 
; The result strongly depends on the flag determining if the year is leap.
;
; Parameters:
;	n - number of the day in the year,
;	LeapYearFlag - flag determining if the year is leap (0 - normal year, 1 - leap year),
;	M - pointer to variable where the calculated month number will be stored,
;	D - pointer to variable where the calculated day number will be stored. 
;
; Returned values:
;	* 0 for the valid parameters (n, LeapYearFlag),
;	* -1 in opposite case.
;
proc	DayNumToMD, n, LeapYearFlag, M, D

	pushfd
	push	ebx ecx edx

	.CheckParameters:
		test	[LeapYearFlag], -2				; 0 <= LeapYearFlag <= 1
		jnz	.Error

		cmp	[n], 1						; n >= 1
		jb	.Error						;

		mov	eax, 365					;
		add	eax, [LeapYearFlag]				; eax := 365 + LeapYearFlag
		cmp	[n], eax					; n <= eax
		ja	.Error						;

	.CalculateMD:
		mov	ebx, [LeapYearFlag]				; ebx := LeapYearFlag
		lea	ebx, [ebx + 2*ebx]				; ebx := 3*ebx = 3*LeapYearFlag
		shl	ebx, 3						; ebx := 8*ebx = 24*LeapYearFlag

		mov	ecx, 12						;
									;
		.Loop:							; ecx := max{i; 1 <= i <= 12, DaySum(i, LeapYearFlag) < n} = m
			movzx	edx, [DaySum - 2 + ebx + 2*ecx]		;
			cmp	[n], edx				; edx := DaySum(m, LeapYearFlag)
			ja	.LoopEnd				;
			loop	.Loop					;

		.LoopEnd:
			mov	eax, [M]				; M := ecx = m
			mov	[eax], ecx				;

			mov	ecx, [n]				; ecx := n
			sub	ecx, edx				; ecx := ecx - edx = n - DaySum(m, LeapYearFlag)

			mov	eax, [D]				; D := ecx
			mov	[eax], ecx				;

			xor	eax, eax

			jmp	.End

	.Error:
		mov	eax, -1

	.End:

	pop	edx ecx ebx
	popfd

	ret
endp

; DWORD DateToAbsDayNum(DWORD Y, DWORD M, DWORD D, DWORD Gregorian)
;
; This function calculates the absolute day number for the given date.
;
; Parameters:
;	Y - year,
;	M - month,
;	D - day,
;	Gregorian - chosen calendar (0 - Julian, 1 - Gregorian).
;
; Returned values:
;	* 1, 2, ..., 2^32-1 for the valid date in the chosen calendar,
;	* 0 for the invalid parameters.
;
proc	DateToAbsDayNum, Y, M, D, Gregorian

	pushfd
	push	ebx ecx edx

	test	[Gregorian], -2						; 0 <= Gregorian <= 1
	jnz	.Error							;

	stdcall	IsLeapYear, [Y], [Gregorian]				;
	cmp	eax, -1							; eax := IsLeapYear(Y, Gregorian)
	je	.Error							;

									; Y <> 0

	mov	ebx, eax						; ebx := eax

	stdcall	MDToDayNum, [M], [D], ebx				;
	cmp	eax, -1							; eax := MDToDayNum(M, D, ebx) = n
	je	.Error							;

	mov	ecx, [Y]						;
	cmp	ecx, 0							; ecx := Y
	jg	.CalculateDayNum					;

	inc	ecx							; Y < 0
									; ecx := ecx + 1 = Y + 1 = Y + [Y < 0]

	.CalculateDayNum:
		add	ecx, k*J					; 
		cmp	[Gregorian], 0					; ecx := ecx + kJ + k(G-J)[Gregorian = 1] =
		je	.Yprim0						;      = Y + [Y < 0] + kJ + k(G-J)[Gregorian = 1] = Y'
		add	ecx, k*(G-J)					; 

	.Yprim0:
		cmp	ecx, 0						;
		jne	.YprimPositive					; Y' = 0
		sub	eax, 364					; eax := eax - 364 = n - 364
		jmp	.End						;

	.YprimPositive:							; Y' > 0
									;
		dec	ecx						; ecx := ecx - 1 = Y' - 1
		mov	ebx, eax					; ebx := eax = n

		mov	eax, 365					; eax := 365
		mul	ecx						; eax := 365 * ecx = 365(Y' - 1)
		
		shr	ecx, 2						; ecx := E(ecx / 4) = E((Y' - 1) / 4)
		add	eax, ecx					; eax := eax + ecx = 365(Y' - 1) + E((Y' - 1) / 4)
		add	eax, ebx					; eax := eax + ebx = eax + n =
									;      = 365(Y' - 1) + E((Y' - 1) / 4) + n

		cmp	[Gregorian], 0
		jz	.End

	.Gregorian:
		push	eax						; X := eax

		xor	edx, edx					;
		mov	eax, ecx					; eax := ecx = E((Y' - 1) / 4)
		mov	ebx, 25						;
		div	ebx						; eax := E(eax / 25) = E(E((Y' - 1) / 4) / 25) =
									;      = E((Y' - 1) / 100)

		mov	ecx, eax					; ecx := eax = E((Y' - 1) / 100)
		pop	eax						; eax := X = 365(Y' - 1) + E((Y' - 1) / 4) + n

		sub	eax, ecx					; eax := eax - ecx = 365(Y' - 1) + E((Y' - 1) / 4) + n -
									;                    - E((Y' - 1) / 100)

		shr	ecx, 2						; ecx : = E(ecx / 4) = E(E((Y' - 1) / 100) / 4) =
									;       = E((Y' - 1) / 400)


		add	eax, ecx					; eax := eax + ecx = 365(Y' - 1) + E((Y' - 1) / 4) + n -
									;                    - E((Y' - 1) / 100) + E((Y' - 1) / 400)

		add	eax, 2						; eax := eax + 2 = 365(Y' - 1) + E((Y' - 1) / 4) + n -
									;                  - E((Y' - 1) / 100) + E((Y' - 1) / 400) + 2 =
									;                = N

		jmp	.End

	.Error:
		xor	eax, eax

	.End:

	pop	edx ecx ebx
	popfd

	ret
endp

; DWORD AbsDayNumToDate(DWORD N, DWORD Gregorian, DWORD* Y, DWORD* M, DWORD* D)
;
; This function converts the absolute day number N = 1, 2, ..., 2^32-1 to the adequate date (for the chosen calendar).
;
; Parameters:
;	N - absolute day number,
;	Gregorian - chosen calendar (0 - Julian, 1 - Gregorian),
;	Y - pointer to variable where the calculated year number will be stored,
;	M - pointer to variable where the calculated month number will be stored,
;	D - pointer to variable where the calculated day number will be stored.
;
; Returned values:
;	* 0 for the valid parameters (N, Gregorian),
;	* -1 in opposite case.
;
proc	AbsDayNumToDate, N, Gregorian, Y, M, D

	pushfd
	push	ebx ecx edx

	cmp	[N], 0							; N <> 0
	je	.Error							;

	test	[Gregorian], -2						; 0 <= Gregorian <= 1
	jnz	.Error							;

	xor	ecx, ecx						; ecx := 0
	
	mov	eax, [N]						; eax := N - 1
	dec	eax							;

	cmp	[Gregorian], 0
	je	.Julian

	.Gregorian:
		cmp	eax, 1
		ja	.NextDays

									; 0 <= eax <= 1 (1 <= N <= 2)

		mov	ebx, [M]					; M := 12
		mov	dword [ebx], 12					;

		add	eax, 30						; eax := eax + 30 = N - 1 + 30 = N + 29 

		mov	ebx, [D]					; D := eax = N + 29
		mov	[ebx], eax					;

		mov	ecx, -k*G - 1					; ecx := -kG - 1

		jmp	.ReturnY

	.NextDays:							; eax > 1 (N > 2)

		sub	eax, 2						; eax := eax - 2 = N - 1 - 2 = N - 3

		xor	edx, edx					;
		mov	ebx, C400					; eax := E(eax / C400) = E((N - 3) / C400)
		div	ebx						; edx := eax mod C400 = (N - 3) mod C400

		lea	eax, [eax + 4*eax]				; eax := 5*eax = 5*E((N - 3) / C400)
		lea	eax, [eax + 4*eax]				; eax := 5*eax = 5*(5*E((N - 3) / C400)) =
									;              = 25*E((N - 3) / C400)

		shl	eax, 4						; eax := 16*eax = 16*(25*E((N - 3) / C400)) =
									;               = 400*E((N - 3) / C400)

		xchg	ecx, eax					; ecx := eax = 400*E((N - 3) / C400)
									; 

		xchg	eax, edx					; eax := edx = (N - 3) mod C400
									; 

		.Centuries:						;
			cmp	eax, C100				;
			jb	.Julian					;
									;
			add	ecx, 100				;
			sub	eax, C100				;
									;
			cmp	eax, C100				; (eax, ecx) := P(eax, ecx) = 
			jb	.Julian					;             = P((N - 3) mod C400, 400*E((N - 3) / C400)) =
									;             = (N100, Y100)
			add	ecx, 100				;
			sub	eax, C100				;
									;
			cmp	eax, C100				;
			jb	.Julian					;
									;
			add	ecx, 100				;
			sub	eax, C100				;

	.Julian:
									;                             /
									;                             |  (N - 1, 0)                                 ; Gregorian = 0
									; (N100, Y100) = (eax, ecx) = <
									;                             |  P((N - 3) mod C400, 400*E((N - 3) / C400)) ; Gregorian = 1
									;                             \

		xor	edx, edx					;
		mov	ebx, C4						; eax := E(eax / C4) = E(N100 / C4)
		div	ebx						; edx := eax mod C4 = N100 mod C4

		shl	eax, 2						; eax := 4*eax = 4*E(N100 / C4)

		add	ecx, eax					; ecx := ecx + eax = Y100 + 4*E(N100 / C4)

		.Years:							;
			inc	ecx					;
			cmp	edx, C1					;
			jb	.MD					;
									;
			sub	edx, C1					;
									;
			inc	ecx					; (edx, ecx) := Q(edx, ecx) =
			cmp	edx, C1					;             = Q(N100 mod C4, Y100 + 4*E(N100 / C4)) =
			jb	.MD					;             = (N', Y*)
									;
			sub	edx, C1					;
									;
			inc	ecx					;
			cmp	edx, C1					;
			jb	.MD					;
									;
			sub	edx, C1					;
									;
			inc	ecx					;

	.MD:
		inc	edx						; edx := edx + 1 = N' + 1

		stdcall	IsLeapYear, ecx, [Gregorian]			; eax := IsLeapYear(ecx, Gregorian) =
									;      = IsLeapYear(Y*, Gregorian)

		stdcall	DayNumToMD, edx, eax, [M], [D]			; eax := DayNumToMD(edx, eax, M, D) =
									;      = DayNumToMD(N' + 1, IsLeapYear(Y*, Gregorian), M, D)

		cmp	[Gregorian], 0
		je	.JulianYears

		.GregorianYears:					;
			sub	ecx, k*(G - J)				;
									; ecx := ecx - kJ - k(G - J)[Gregorian = 1] =
		.JulianYears:						;      = Y* - kJ - k(G - J)[Gregorian = 1] = 
			sub	ecx, k*J				;      = Y'

			cmp	ecx, 0
			jg	.ReturnY
									; ecx <= 0 (Y' <= 0)

			dec	ecx					; ecx := ecx - 1 = Y' - 1 = Y' - [Y' <= 0]

		.ReturnY:
			mov	eax, [Y]				; Y := ecx
			mov	[eax], ecx				;

		xor	eax, eax
		jmp	.End

	.Error:
		mov	eax, -1

	.End:

	pop	edx ecx ebx
	popfd

	ret
endp

; DWORD GregorianToJulian(DWORD Yg, DWORD Mg, DWORD Dg, DWORD* Yj, DWORD* Mj, DWORD* Dj)
;
; This function converts the Gregorian date to the adequate Julian date.
;
; Parameters:
;	Yg - year of the Gregorian date,
;	Mg - month of the Gregorian date,
;	Dg - day of the Gregorian date,
;	Yj - pointer to variable where the calculated year number of the Julian date will be stored,
;	Mj - pointer to variable where the calculated month number of the Julian date will be stored,
;	Dj - pointer to variable where the calculated day number of the Julian date will be stored.
;
; Returned values:
;	* 0 for the valid Gregorian date,
;	* -1 in opposite case.
;
proc	GregorianToJulian, Yg, Mg, Dg, Yj, Mj, Dj

	.GregorianToNum:
		stdcall DateToAbsDayNum, [Yg], [Mg], [Dg], 1
		test	eax, eax
		jz	.Error

	.NumToJulian:
		stdcall AbsDayNumToDate, eax, 0, [Yj], [Mj], [Dj]
		jmp	.End

	.Error:
		mov	eax, -1

	.End:

	ret
endp

; DWORD JulianToGregorian(DWORD Yj, DWORD Mj, DWORD Dj, DWORD* Yg, DWORD* Mg, DWORD* Dg)
;
; This function converts the Julian date to the adequate Gregorian date.
;
; Parameters:
;	Yj - year of the Julian date,
;	Mj - month of the Julian date,
;	Dj - day of the Julian date,
;	Yg - pointer to variable where the calculated year number of the Gregorian date will be stored,
;	Mg - pointer to variable where the calculated month number of the Gregorian date will be stored,
;	Dg - pointer to variable where the calculated day number of the Gregorian date will be stored.
;
; Returned values:
;	* 0 for the valid Julian date,
;	* -1 in opposite case.
;
proc	JulianToGregorian, Yj, Mj, Dj, Yg, Mg, Dg

	.JulianToNum:
		stdcall DateToAbsDayNum, [Yj], [Mj], [Dj], 0
		test	eax, eax
		jz	.Error

	.NumToGregorian:
		stdcall AbsDayNumToDate, eax, 1, [Yg], [Mg], [Dg]
		jmp	.End

	.Error:
		mov	eax, -1

	.End:

	ret
endp


section '.edata' export data readable

	export	'Calendar.dll',\
		AbsDayNumToDate,	'AbsDayNumToDate',\
		DateToAbsDayNum,	'DateToAbsDayNum',\
		DayNumToMD,		'DayNumToMD',\
		DayOfWeek,		'DayOfWeek',\
		GregorianToJulian,	'GregorianToJulian',\
		IsLeapYear,		'IsLeapYear',\
		JulianToGregorian,	'JulianToGregorian',\
		MDToDayNum,		'MDToDayNum'


section '.reloc' fixups data discardable

Code: Select all

; http://www.purebasic.fr/english/viewtopic.php?p=421612#p421612
; By wilbert

DeclareModule QDate
  
Structure DateQInfo
  yday.w    ; offset 0    : days since Jan 1 [1-366]
  year.w    ; offset 2    : year [1600-9999]   
  month.b   ; offset 4    : months [1-12]
  day.b     ; offset 5    : day of the month [1-31]
  hour.b    ; offset 6    : hours [0-23]
  min.b     ; offset 7    : minutes [0-59]
  sec.b     ; offset 8    : seconds [0-59]
  wday.b    ; offset 9    : days since Sunday [0-6]
EndStructure

Structure DateQ_CharArray
  c.c[0]
EndStructure 

  Declare.q DateQ(year, month = 1, day = 1, hour = 0, min = 0, sec = 0)
  Declare DateQInfo(*Info.DateQInfo, DateQ.q)
  Declare IsLeapYear(Year) 
  Declare YearQ(DateQ.q) 
  Declare MonthQ(DateQ.q) 
  Declare DayQ(DateQ.q)
  Declare HourQ(DateQ.q)
  Declare MinuteQ(DateQ.q)
  Declare SecondQ(DateQ.q)
  Declare DayOfWeekQ(DateQ.q)
  Declare DayOfYearQ(DateQ.q)
  Declare.q AddDateQ(DateQ.q, Type, Value)
  Declare WeekISO(DateQ.q)
EndDeclareModule

Module QDate
; 
; Please don't blame me for using ASM. I know it can easily be done without but that's just the fun part For me  :wink: 
; You can use these procedures If you need To support dates prior To 1970 Or If you need the speed As they same To be faster compared To the built in routines.
; Dates have To be between 1582/10/15 (-12219292800) And 9999/12/31 (253402300799)
; 
; Supported procedures :
; DateQ(year, month, day, hour, min, sec)
; DateQInfo(*Info.DateQInfo, DateQ.q)
; 
; AddDateQ(DateQ.q, Type, Value)
; DayFromYMW(Year, Month, Weekday, n)
; DayOfWeekQ(DateQ.q)
; DayOfYearQ(DateQ.q)
; DayQ(DateQ.q)
; FormatDateQ(Mask$, DateQ.q)
; HourQ(DateQ.q)
; IsLeapYear(Year)
; MinuteQ(DateQ.q)
; MonthQ(DateQ.q)
; SecondQ(DateQ.q)
; WeekISO(DateQ.q)
; YearQ(DateQ.q)

Code:
; *** DateQ.pbi   v 1.03 2013/08/18 ***


; *** Structures ***




; *** Create lookup tables (about 65 KiB) ***

Global Dim DateQ_LUT.l(16384)
Global Dim DateQ_LUT2.w(2024)

Procedure DateQ_LUT_Init()
  Protected.i y, y_, d, d_, w, m
  While y < 16384
    d = y >> 2 : y_ = d / 25 : d - y_ : y_ >> 2 : d + y_
    y + 1
    y_ = d - d_ : w + 1 + y_ : d_ = d
    If w > 6 : w - 7 : EndIf
    DateQ_LUT(y - 1) |  y_ << 4
    DateQ_LUT(y) = (d + y * 365 + 1) << 8 | w << 5
  Wend
  y = 0 : y_ = 512
  For m = 1 To 12
    If m = 2
      For d = 1 To 28
        w = m | d << 8
        DateQ_LUT2(y) = w : y + 1
        DateQ_LUT2(y_) = w : y_ + 1
      Next
      DateQ_LUT2(y_) = 2 | 29 << 8 : y_ + 1
    Else
      d_ = 30 + (m & 1) ! (m >> 3)
      For d = 1 To d_
        w = m | d << 8
        DateQ_LUT2(y) = w : y + 1
        DateQ_LUT2(y_) = w : y_ + 1
      Next
    EndIf
  Next
EndProcedure

DateQ_LUT_Init()


; *** ASM procedures ***

Procedure.q DateQ(year, month = 1, day = 1, hour = 0, min = 0, sec = 0)
  !mov ecx, [p.v_year]
  !and ecx, 16383
  CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
    !mov rdx, [qdate.a_DateQ_LUT]
    !mov eax, [rdx + rcx * 4]
    !mov rcx, [p.v_month]
    !or rcx, rax
    !and rcx, 31
    !lea rdx, [dateq_oday_table]
    !movsx rcx, word [rdx + rcx * 2]
    !shr rax, 8
    !add rax, rcx
    !add rax, [p.v_day]
    !sub rax, 0xafaa9
    !imul rax, 86400
    !mov rcx, [p.v_hour]
    !lea rcx, [rcx + rcx * 4]; *5
    !lea rcx, [rcx + rcx * 2]; *3
    !sal rcx, 2; *4
    !add rcx, [p.v_min]
    !lea rcx, [rcx + rcx * 4]; *5
    !lea rcx, [rcx + rcx * 2]; *3
    !sal rcx, 2; *4
    !add rcx, [p.v_sec]
    !add rax, rcx
  CompilerElse
    !mov edx, [qdate.a_DateQ_LUT]
    !mov eax, [edx + ecx * 4]
    !mov ecx, [p.v_month]
    !or ecx, eax
    !and ecx, 31
    !movsx ecx, word [dateq_oday_table + ecx * 2]
    !shr eax, 8
    !add eax, ecx
    !add eax, [p.v_day]
    !sub eax, 0xafaa9
    !mov ecx, 86400
    !imul ecx
    !mov ecx, [p.v_hour]
    !lea ecx, [ecx + ecx * 4]; *5
    !lea ecx, [ecx + ecx * 2]; *3
    !sal ecx, 2; *4
    !add ecx, [p.v_min]
    !lea ecx, [ecx + ecx * 4]; *5
    !lea ecx, [ecx + ecx * 2]; *3
    !sal ecx, 2; *4
    !add ecx, [p.v_sec]
    !add eax, ecx
    !adc edx, 0
    !sar ecx, 31
    !add edx, ecx
  CompilerEndIf  
  ProcedureReturn
  !dateq_oday_table:
  !dw -31,0,31,59,90,120,151,181,212,243,273,304,334,365,396,-61  ; normal year
  !dw -31,0,31,60,91,121,152,182,213,244,274,305,335,366,397,-61  ; leap year
EndProcedure

Procedure DateQInfo(*Info.DateQInfo, DateQ.q)
  !mov eax, [p.v_DateQ]
  !mov edx, [p.v_DateQ + 4]
  ; split into date and time
  !add eax, 0x79747c00
  !adc edx, 0xe
  !and edx, 0x7f
  !mov ecx, 86400
  !div ecx
  CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
    !mov r8, [p.p_Info]
    !mov r9, rax
    ; process the time part
    !mov eax, edx
    !xor edx, edx
    !mov ecx, 60
    !div ecx
    !mov [r8 + 8], dl
    !div cl
    !mov [r8 + 6], ax
    ; process the date part
    !mov rax, r9
    ; guess the year
    !mov ecx, 0xb36d83
    !mul ecx
    !and rdx, 16383
    ; correct it if wrong
    !mov rcx, [qdate.a_DateQ_LUT]
    !mov eax, [rcx + rdx * 4 + 4]
    !shr rax, 8
    !cmp r9, rax
    !cmc
    !adc rdx, 0
    !mov [r8 + 2], dx; year
    !mov eax, [rcx + rdx * 4]
    ; get the other info    
    !movzx rcx, al
    !shr rax, 8
    !sub r9, rax
    !and r9, 511
    !lea rdx, [r9 + 1]
    !mov [r8], dx; yday
    !mov rdx, rcx
    !shl rdx, 5
    !and rdx, 512
    !or rdx, r9
    !mov rax, [qdate.a_DateQ_LUT2]
    !mov dx, [rax + rdx * 2]
    !mov [r8 + 4], dx; day and month
    !mov rax, r9
    !shr rcx, 5
    !add rax, rcx
    !mov cl, 7
    !div cl
    !mov al, ah
    !mov [r8 + 9], al; wday
  CompilerElse
    !mov ecx, [p.p_Info]
    !push edi
    !push ebx
    !mov edi, ecx
    !mov ebx, eax
    ; process the time part
    !mov eax, edx
    !xor edx, edx
    !mov ecx, 60
    !div ecx
    !mov [edi + 8], dl
    !div cl
    !mov [edi + 6], ax
    ; process the date part
    !mov eax, ebx
    ; guess the year
    !mov ecx, 0xb36d83
    !mul ecx
    !and edx, 16383
    ; correct it if wrong
    !mov ecx, [qdate.a_DateQ_LUT]
    !mov eax, [ecx + edx * 4 + 4]
    !shr eax, 8
    !cmp ebx, eax
    !cmc
    !adc edx, 0
    !mov [edi + 2], dx; year
    !mov eax, [ecx + edx * 4]
    ; get the other info    
    !movzx ecx, al
    !shr eax, 8
    !sub ebx, eax
    !and ebx, 511
    !lea edx, [ebx + 1]
    !mov [edi], dx; yday
    !mov edx, ecx
    !shl edx, 5
    !and edx, 512
    !or edx, ebx
    !mov eax, [qdate.a_DateQ_LUT2]
    !mov dx, [eax + edx * 2]
    !mov [edi + 4], dx; day and month
    !mov eax, ebx
    !shr ecx, 5
    !add eax, ecx
    !mov cl, 7
    !div cl
    !mov [edi + 9], ah; wday
    !pop ebx
    !pop edi
  CompilerEndIf
EndProcedure


; *** Non ASM procedures ***

Procedure IsLeapYear(Year)
  ProcedureReturn DateQ_LUT(Year) >> 4 & 1
EndProcedure

Procedure YearQ(DateQ.q)
  Protected I.DateQInfo : DateQInfo(@I, DateQ) : ProcedureReturn I\year
EndProcedure

Procedure MonthQ(DateQ.q)
  Protected I.DateQInfo : DateQInfo(@I, DateQ) : ProcedureReturn I\month
EndProcedure

Procedure DayQ(DateQ.q)
  Protected I.DateQInfo : DateQInfo(@I, DateQ) : ProcedureReturn I\day
EndProcedure

Procedure HourQ(DateQ.q)
  Protected I.DateQInfo : DateQInfo(@I, DateQ) : ProcedureReturn I\hour
EndProcedure

Procedure MinuteQ(DateQ.q)
  Protected I.DateQInfo : DateQInfo(@I, DateQ) : ProcedureReturn I\min
EndProcedure

Procedure SecondQ(DateQ.q)
  Protected I.DateQInfo : DateQInfo(@I, DateQ) : ProcedureReturn I\sec
EndProcedure

Procedure DayOfWeekQ(DateQ.q)
  Protected I.DateQInfo : DateQInfo(@I, DateQ) : ProcedureReturn I\wday
EndProcedure

Procedure DayOfYearQ(DateQ.q)
  Protected I.DateQInfo : DateQInfo(@I, DateQ) : ProcedureReturn I\yday
EndProcedure

Procedure.q AddDateQ(DateQ.q, Type, Value)
  Protected I.DateQInfo, D.q
  Select Type
    Case #PB_Date_Year
      DateQInfo(@I, DateQ) : I\year + Value
      If I\month = 2 And I\yday = 60
        If IsLeapYear(I\year) = 0 : I\day = 28 : EndIf  
      EndIf
      DateQ = DateQ(I\year, I\month, I\day, I\hour, I\min, I\sec)
    Case #PB_Date_Month
      DateQInfo(@I, DateQ) : I\month + Value
      While I\month < 1 : I\year - 1 : I\month + 12 : Wend 
      While I\month > 12 : I\year + 1 : I\month - 12 : Wend 
      DateQ = DateQ(I\year, I\month, I\day, I\hour, I\min, I\sec)
      D = DateQ(I\year, I\month + 1, 0, I\hour, I\min, I\sec)
      If DateQ > D : DateQ = D : EndIf
    Case #PB_Date_Week : DateQ + Value * 604800
    Case #PB_Date_Day : DateQ + Value * 86400
    Case #PB_Date_Hour : DateQ + Value * 3600
    Case #PB_Date_Minute : DateQ + Value * 60
    Case #PB_Date_Second : DateQ + Value
  EndSelect
  ProcedureReturn DateQ
EndProcedure

Procedure FormatDateQ_Set(*addr.DateQ_CharArray, value, size = 2)
  While size
    size - 1 : *addr\c[size] = $30 | value % 10 : value / 10 
  Wend
EndProcedure

Procedure.s FormatDateQ(Mask$, DateQ.q)
  Protected *a.DateQ_CharArray = @Mask$ 
  Protected.i r, w, l, I.DateQInfo, c1.c, c2.c, c.c = *a\c[0]
  DateQInfo(@I, DateQ)
  While c
    If c = 37; %
      c1 = *a\c[r + 1]
      If c1
        c1 | 32 : c2 = *a\c[r + 2] | 32
        If c1 = c2
          Select c1
            Case 121; yy
              l = 2 : c1 = *a\c[r + 3]
              If c1
                c1 | 32 : c2 = *a\c[r + 4] | 32
                If c1 = 121 And c2 = 121 : l = 4 : EndIf
              EndIf
              FormatDateQ_Set(@*a\c[w], I\year, l) : w + l : r + l + 1
            Case 109; mm
              FormatDateQ_Set(@*a\c[w], I\month) : w + 2 : r + 3
            Case 100; dd
              FormatDateQ_Set(@*a\c[w], I\day) : w + 2 : r + 3
            Case 104; hh
              FormatDateQ_Set(@*a\c[w], I\hour) : w + 2 : r + 3
            Case 105; ii
              FormatDateQ_Set(@*a\c[w], I\min) : w + 2 : r + 3
            Case 115; ss
              FormatDateQ_Set(@*a\c[w], I\sec) : w + 2 : r + 3
            Default
              *a\c[w] = c : w + 1 : r + 1
          EndSelect
        EndIf
      EndIf
    Else
      *a\c[w] = c : w + 1 : r + 1
    EndIf
    c = *a\c[r]
  Wend
  *a\c[w] = 0
  ProcedureReturn Mask$
EndProcedure

Procedure WeekISO(DateQ.q)
  Protected.i week1_prev, week1_this, week1_next, y = YearQ(DateQ)
  Protected.i d = DateQ / 86400 + $afaa8
  week1_prev = DateQ_LUT(y - 1)
  week1_prev = (week1_prev >> 8) + 3 - (week1_prev >> 5 & 7 + 2) % 7
  week1_this = DateQ_LUT(y)
  week1_this = (week1_this >> 8) + 3 - (week1_this >> 5 & 7 + 2) % 7
  week1_next = DateQ_LUT(y + 1)
  week1_next = (week1_next >> 8) + 3 - (week1_next >> 5 & 7 + 2) % 7
  If d < week1_this
    ProcedureReturn (d - week1_prev) / 7 + 1
  ElseIf d >= week1_next
    ProcedureReturn 1
  Else  
    ProcedureReturn (d - week1_this) / 7 + 1
  EndIf
EndProcedure

Procedure DayFromYMW(Year, Month, Weekday, n = 1)
  Protected I.DateQInfo, D.q = DateQ(Year, Month)
  DateQInfo(@I, D)
  D = DateQ(I\year, I\month, I\day + (Weekday - I\wday + 7) % 7 + n * 7 - 7)
  DateQInfo(@I, D)
  If I\month = Month
    ProcedureReturn I\day
  Else
    ProcedureReturn -1
  EndIf
EndProcedure
EndModule




Debug QDate::Date())