From 65bfeaf5de8c52c77ba0f4e8f4d5d6ceeb45b33e Mon Sep 17 00:00:00 2001 From: Christopher Lam Date: Sun, 3 Feb 2019 09:26:24 +0800 Subject: [PATCH] [date-utilities] bugfix: date-intervals produces good month deltas Instead of recursing the date, we calculate the next month using an index-based multiplier, and apply modulo/remainder as appropriate to determine the next month/year. Then we attempt to create new mktime, and if the resulting mktime's month is not as expected, reduce the mday by 1 until resulting month is correct. This fixes monthly intervals for end-of-month days. Test via monthly/quarterly deltas, and also includes leapyear calculation. --- libgnucash/app-utils/date-utilities.scm | 85 ++++++++++--- .../app-utils/test/test-date-utilities.scm | 112 ++++++++++++++++++ 2 files changed, 181 insertions(+), 16 deletions(-) diff --git a/libgnucash/app-utils/date-utilities.scm b/libgnucash/app-utils/date-utilities.scm index 1e6b2f6a8d..1d6606189e 100644 --- a/libgnucash/app-utils/date-utilities.scm +++ b/libgnucash/app-utils/date-utilities.scm @@ -215,32 +215,78 @@ (define (gnc:time64-ge-date t1 t2) (gnc:time64-le-date t2 t1)) -;; Build a list of time intervals. +(define (incdate-months date nmonths) + (let* ((new-date (gnc-localtime date)) + (newmonth (+ (tm:mon new-date) nmonths)) + (new-month-proper (floor-remainder newmonth 12)) + (new-year-proper (+ (tm:year new-date) (floor-quotient newmonth 12)))) + (set-tm:year new-date new-year-proper) + (set-tm:mon new-date new-month-proper) + (let loop ((new-mday (tm:mday new-date))) + (set-tm:mday new-date new-mday) + (let ((res (gnc-mktime new-date))) + (if (= new-month-proper (tm:mon (gnc-localtime res))) + res + (loop (1- new-mday))))))) + +;; Build a list of time intervals. ;; ;; Note that the last interval will be shorter than if ;; (-) is not an integer multiple of . If you don't ;; want that you'll have to write another function. -(define (gnc:make-date-interval-list current-date end-date increment) - (if (< current-date end-date) - (let ((next-date (incdate current-date increment))) - (if (< next-date end-date) - (cons (list current-date (decdate next-date SecDelta) '()) - (gnc:make-date-interval-list next-date end-date increment)) - (cons (list current-date end-date '()) - '()))) - '())) - +(define (gnc:make-date-interval-list startdate enddate incr) + (define month-delta + (assv-ref MonthDeltas incr)) + (let loop ((result '()) + (date startdate) + (idx 0)) + (cond + ((>= date enddate) + (reverse result)) + (month-delta + (let* ((curr (incdate-months startdate (* month-delta idx))) + (next (incdate-months startdate (* month-delta (1+ idx))))) + (loop (cons (list curr + (if (< next enddate) + (decdate next SecDelta) + enddate)) + result) + next + (1+ idx)))) + (else + (let ((next (incdate date incr))) + (loop (cons (list date + (if (< next enddate) + (decdate next SecDelta) + enddate)) + result) + next + (1+ idx))))))) + ;; Build a list of times. The dates are evenly spaced with the ;; stepsize 'incr'. If the difference of 'startdate' and 'enddate' is ;; not an integer multiple of 'incr', 'enddate' will be added as the ;; last element of the list, thus making the last interval smaller ;; than 'incr'. (define (gnc:make-date-list startdate enddate incr) - (if (< startdate enddate) - (cons startdate - (gnc:make-date-list (incdate startdate incr) - enddate incr)) - (list enddate))) + (define month-delta + (assv-ref MonthDeltas incr)) + (let loop ((result '()) + (date startdate) + (idx 0)) + (cond + ((>= date enddate) + (reverse (cons enddate result))) + (month-delta + (let* ((curr (incdate-months startdate (* month-delta idx))) + (next (incdate-months startdate (* month-delta (1+ idx))))) + (loop (cons curr result) + next + (1+ idx)))) + (else + (loop (cons date result) + (incdate date incr) + (1+ idx)))))) ; A reference zero date - the Beginning Of The Epoch ; Note: use of eval is evil... by making this a generator function, @@ -310,6 +356,13 @@ (set-tm:mday ddt 90) ddt)) +(define MonthDeltas + (list + (cons MonthDelta 1) + (cons QuarterDelta 3) + (cons HalfYearDelta 6) + (cons YearDelta 12))) + ;; if you add any more FooDeltas, add to this list!!! (define deltalist diff --git a/libgnucash/app-utils/test/test-date-utilities.scm b/libgnucash/app-utils/test/test-date-utilities.scm index 51eb9814ff..2f548e7939 100644 --- a/libgnucash/app-utils/test/test-date-utilities.scm +++ b/libgnucash/app-utils/test/test-date-utilities.scm @@ -57,6 +57,118 @@ (not (weeknums-equal? (cons '(1969 12 28 0 0 1) '(1970 1 5 0 0 1)))))) +(define (test-make-date-list) + (test-equal "make-date-list" + (list (create-time64 '(1969 12 18 0 0 1)) + (create-time64 '(1969 12 25 0 0 1)) + (create-time64 '(1970 1 1 0 0 1)) + (create-time64 '(1970 1 2 0 0 1))) + (gnc:make-date-list + (create-time64 '(1969 12 18 0 0 1)) + (create-time64 '(1970 1 2 0 0 1)) + WeekDelta)) + + (test-equal "make-date-list exact" + (list (create-time64 '(1970 1 1 0 0 1)) + (create-time64 '(1970 1 8 0 0 1)) + (create-time64 '(1970 1 15 0 0 1))) + (gnc:make-date-list + (create-time64 '(1970 1 1 0 0 1)) + (create-time64 '(1970 1 15 0 0 1)) + WeekDelta)) + + (test-equal "make-date-list 31-dec-1970 to 15-4-1972 monthly including leapyear" + (list (create-time64 '(1970 12 31 0 0 1)) + (create-time64 '(1971 1 31 0 0 1)) + (create-time64 '(1971 2 28 0 0 1)) + (create-time64 '(1971 3 31 0 0 1)) + (create-time64 '(1971 4 30 0 0 1)) + (create-time64 '(1971 5 31 0 0 1)) + (create-time64 '(1971 6 30 0 0 1)) + (create-time64 '(1971 7 31 0 0 1)) + (create-time64 '(1971 8 31 0 0 1)) + (create-time64 '(1971 9 30 0 0 1)) + (create-time64 '(1971 10 31 0 0 1)) + (create-time64 '(1971 11 30 0 0 1)) + (create-time64 '(1971 12 31 0 0 1)) + (create-time64 '(1972 1 31 0 0 1)) + (create-time64 '(1972 2 29 0 0 1)) + (create-time64 '(1972 3 31 0 0 1)) + (create-time64 '(1972 4 15 0 0 1))) + (gnc:make-date-list + (create-time64 '(1970 12 31 0 0 1)) + (create-time64 '(1972 4 15 0 0 1)) + MonthDelta)) + + (test-equal "make-date-list 30-aug-1970 to 15-4-1972 quarterly including leapyear" + (list (create-time64 '(1970 8 31 0 0 1)) + (create-time64 '(1970 11 30 0 0 1)) + (create-time64 '(1971 2 28 0 0 1)) + (create-time64 '(1971 5 31 0 0 1)) + (create-time64 '(1971 8 31 0 0 1)) + (create-time64 '(1971 11 30 0 0 1)) + (create-time64 '(1972 2 29 0 0 1)) + (create-time64 '(1972 4 15 0 0 1))) + (gnc:make-date-list + (create-time64 '(1970 8 31 0 0 1)) + (create-time64 '(1972 4 15 0 0 1)) + QuarterDelta)) + + (test-equal "make-date-list 30-aug-1970 to 15-4-1972 half-yearly including leapyear" + (list (create-time64 '(1970 8 30 0 0 1)) + (create-time64 '(1971 2 28 0 0 1)) + (create-time64 '(1971 8 30 0 0 1)) + (create-time64 '(1972 2 29 0 0 1)) + (create-time64 '(1972 4 15 0 0 1))) + (gnc:make-date-list + (create-time64 '(1970 8 30 0 0 1)) + (create-time64 '(1972 4 15 0 0 1)) + HalfYearDelta)) + + (test-equal "make-date-interval-list" + (list (list (create-time64 '(1969 12 18 0 0 1)) + (create-time64 '(1969 12 25 0 0 0))) + (list (create-time64 '(1969 12 25 0 0 1)) + (create-time64 '(1970 1 1 0 0 0))) + (list (create-time64 '(1970 1 1 0 0 1)) + (create-time64 '(1970 1 2 0 0 1)))) + (gnc:make-date-interval-list + (create-time64 '(1969 12 18 0 0 1)) + (create-time64 '(1970 1 2 0 0 1)) + WeekDelta)) + + (test-equal "make-date-interval-list exact" + (list (list (create-time64 '(1970 1 1 0 0 1)) + (create-time64 '(1970 1 8 0 0 0))) + (list (create-time64 '(1970 1 8 0 0 1)) + (create-time64 '(1970 1 15 0 0 1)))) + (gnc:make-date-interval-list + (create-time64 '(1970 1 1 0 0 1)) + (create-time64 '(1970 1 15 0 0 1)) + WeekDelta)) + + (test-equal "make-date-interval-list 31/12/71 to 15/3/72 monthly incl leapyear" + (list (list (create-time64 '(1971 12 31 0 0 1)) + (create-time64 '(1972 1 31 0 0 0))) + (list (create-time64 '(1972 1 31 0 0 1)) + (create-time64 '(1972 2 29 0 0 0))) + (list (create-time64 '(1972 2 29 0 0 1)) + (create-time64 '(1972 3 15 0 0 1)))) + (gnc:make-date-interval-list + (create-time64 '(1971 12 31 0 0 1)) + (create-time64 '(1972 03 15 0 0 1)) + MonthDelta)) + + (test-equal "make-date-interval-list exact monthly" + (list (list (create-time64 '(1970 1 31 0 0 1)) + (create-time64 '(1970 2 28 0 0 0))) + (list (create-time64 '(1970 2 28 0 0 1)) + (create-time64 '(1970 3 31 0 0 1)))) + (gnc:make-date-interval-list + (create-time64 '(1970 1 31 0 0 1)) + (create-time64 '(1970 3 31 0 0 1)) + MonthDelta))) + (define (test-date-get-quarter-string) (test-equal "14/02/2001 = Q1" "Q1"