Robert Graham Merkel's scheme date patch.

git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2518 57a11ea4-9604-0410-9ed3-97b8803252fd

ChangeLog

@@ -1,3 +1,11 @@
+2000-06-27  Robert Graham Merkel  <rgmerk@mira.net>
+
+	* src/scm/date-utilities.scm: Added date-granularity timepair comparison
+	functions.
+
+	* src/scm/report/transaction-report.scm: Changed to use date
+	comparison functions in date-utilities.scm
+
 2000-06-26  Robert Graham Merkel  <rgmerk@mira.net>
 
 	* src/guile/global-options.[ch] (gnc_option_refresh_ui_by_name):

src/scm/date-utilities.scm

@@ -33,24 +33,27 @@
 (define (gnc:date-get-week-day datevec)
   (+ (vector-ref datevec 6) 1))
 ;; jan 1 == 1
+
 (define (gnc:date-get-year-day datevec)
   (+ (vector-ref datevec 7) 1))
 
-;; fixme: internationalize
+(define (gnc:timepair-get-year tp)
+  (gnc:date-get-year (localtime (gnc:timepair->secs tp))))
+
+(define (gnc:timepair-get-month-day tp)
+  (gnc:date-get-month (localtime (gnc:timepair->secs tp))))
+
+(define (gnc:timepair-get-month tp)
+  (gnc:date-get-month (localtime (gnc:timepair->secs tp))))
+
+(define (gnc:timepair-get-week-day tp)
+  (gnc:date-get-week-day (localtime (gnc:timepair->secs tp))))
+
+(define (gnc:timepair-get-year-day tp)
+  (gnc:date-get-year-day (localtime (gnc:timepair->secs tp))))
+
 (define (gnc:date-get-month-string datevec)
-  (case (gnc:date-get-month datevec)
-    ((1) "January")
-    ((2) "February")
-    ((3) "March")
-    ((4) "April")
-    ((5) "May")
-    ((6) "June")
-    ((7) "July")
-    ((8) "August")
-    ((9) "September")
-    ((10) "October")
-    ((11) "November")
-    ((12) "December")))
+  (strftime "%B" datevec))
 
 ;; is leap year?
 (define (gnc:leap-year? year)
@@ -144,15 +147,41 @@
 
 (define gnc:timepair-lt gnc:timepair-later)
 
+(define (gnc:timepair-earlier t1 t2)
+  (gnc:timepair-later t2 t1))
+
 ;; t1 <= t2
 (define (gnc:timepair-le t1 t2)
   (cond ((< (car t1) (car t2)) #t)
         ((= (car t1) (car t2)) (<= (cdr t2) (cdr t2)))
         (else #f)))
 
+(define (gnc:timepair-ge t1 t2)
+  (gnc:timepair-le t2 t1))
+
 (define (gnc:timepair-eq t1 t2)
   (and (= (car t1) (car t2)) (= (cdr t1) (cdr t2))))
 
+;; date-granularity comparison functions.
+
+(define (gnc:timepair-earlier-date t1 t2)
+  (gnc:timepair-earlier (gnc:timepair-canonical-day-time t1)
+			(gnc:timepair-canonical-day-time t2)))
+
+(define (gnc:timepair-later-date t1 t2)
+  (gnc:timepair-earlier-date t2 t1))
+
+(define (gnc:timepair-le-date t1 t2)
+  (gnc:timepair-le (gnc:timepair-canonical-day-time t1)
+		   (gnc:timepair-canonical-day-time t2)))
+
+(define (gnc:timepair-ge-date t1 t2)
+  (gnc:timepair-le t2 t1))
+
+(define (gnc:timepair-eq-date t1 t2)
+  (gnc:timepair-eq (gnc:timepair-canonical-day-time t1)
+		   (gnc:timepair-canonical-day-time t2)))
+
 ;; Build a list of time intervals 
 (define (dateloop curd endd incr) 
   (cond ((gnc:timepair-later curd endd)
@@ -211,6 +240,9 @@
    (+ (car tp)
       (/ (cdr tp) 1000000000))))
 
+(define (gnc:timepair->date tp)
+  (localtime (gnc:timepair->secs tp)))
+
 ;; Find difference in seconds time 1 and time2
 (define (gnc:timepair-delta t1 t2)
   (- (gnc:timepair->secs t2) (gnc:timepair->secs t1)))
@@ -221,7 +253,7 @@
 ;;; Added from transaction-report.scm
 
 (define (gnc:timepair-to-datestring tp)
-  (let ((bdtime (localtime (car tp))))
+  (let ((bdtime (localtime (gnc:timepair->secs tp))))
     (strftime "%x" bdtime)))
 
 ;; given a timepair contains any time on a certain day (local time)

src/scm/report/transaction-report.scm

@@ -253,9 +253,9 @@
 	(lambda (split) 
 	  (gnc:transaction-get-date-posted (gnc:split-get-parent split)))
 	(if ascending? 
-	    (lambda (a b) (< (car a) (car b)))
-	    (lambda (a b) (> (car a) (car b))))
-	(lambda (a b) (= (car a) (car b)))
+	    gnc:timepair-later-date
+	    gnc:timepair-earlier-date)
+	gnc:timepair-eq-date
 	#f
 	#f))
 
@@ -264,37 +264,37 @@
 	(lambda (split) 
 	  (gnc:transaction-get-date-posted (gnc:split-get-parent split)))
 	(if ascending? 
-	    (lambda (a b) (< (car a) (car b)))
-	    (lambda (a b) (> (car a) (car b))))
-	(lambda (a b) (= (car a) (car b)))
+	    gnc:timepair-later-date
+	    gnc:timepair-earlier-date)
+	gnc:timepair-eq-date
 	(lambda (a b)
-	  (= (gnc:date-get-month (localtime (car a)))
-	     (gnc:date-get-month (localtime (car b)))))
+	  (= (gnc:timepair-get-month a)
+	     (gnc:timepair-get-month b)))
 	(lambda (date) 
-	  (gnc:date-get-month-string (localtime (car date))))))
+	  (gnc:date-get-month-string (localtime (gnc:timepair->secs date))))))
 
       ((date-yearly)
        (make-report-sort-spec
 	(lambda (split) 
 	  (gnc:transaction-get-date-posted (gnc:split-get-parent split)))
 	(if ascending? 
-	    (lambda (a b) (< (car a) (car b)))
-	    (lambda (a b) (> (car a) (car b))))
-	(lambda (a b) (= (car a) (car b)))
+	    gnc:timepair-later-date
+	    gnc:timepair-earlier-date)
+	gnc:timepair-eq-date
 	(lambda (a b)
-	  (= (gnc:date-get-year (localtime (car a)))
-	     (gnc:date-get-year (localtime (car b)))))
+	  (= (gnc:timepair-get-year a)
+	     (gnc:timepair-get-year b)))
 	(lambda (date) 
-	  (number->string (gnc:date-get-year (localtime (car date)))))))
+	  (number->string (gnc:timepair-get-year date)))))
 
       ((time)
        (make-report-sort-spec
 	(lambda (split) 
 	  (gnc:transaction-get-date-entered (gnc:split-get-parent split)))
 	(if ascending?
-	    (lambda (a b) (< (car a) (car b)))
-	    (lambda (a b) (> (car a) (car b))))
-	(lambda (a b) (and (= (car a) (car b)) (= (cdr a) (cdr b))))
+	    gnc:timepair-later
+	    gnc:timepair-earlier)
+	gnc:timepair-eq
 	#f
 	#f))
 
@@ -377,15 +377,14 @@
 
   ;; returns a predicate that returns true only if a split is
   ;; between early-date and late-date
-  (define (split-report-make-date-filter-predicate begin-date-secs
-                                                   end-date-secs)
+  (define (split-report-make-date-filter-predicate begin-date-tp
+                                                   end-date-tp)
     (lambda (split) 
-      (let ((date 
-	     (car (gnc:timepair-canonical-day-time 
-		   (gnc:transaction-get-date-posted
-		    (gnc:split-get-parent split))))))
-	(and (>= date begin-date-secs)
-	     (<= date end-date-secs)))))
+      (let ((tp
+	     (gnc:transaction-get-date-posted
+	      (gnc:split-get-parent split))))
+	(and (gnc:timepair-ge-date tp begin-date-tp)
+	     (gnc:timepair-le-date tp end-date-tp)))))
 
   ;; register a configuration option for the transaction report
   (define (trep-options-generator)
@@ -600,9 +599,9 @@
 					       "Style"))
            (accounts (gnc:option-value tr-report-account-op))
            (date-filter-pred (split-report-make-date-filter-predicate
-                              (car (gnc:option-value begindate))
-                              (car (gnc:timepair-end-day-time
-                                    (gnc:option-value enddate)))))
+                              (gnc:option-value begindate)
+                              (gnc:timepair-end-day-time
+			       (gnc:option-value enddate))))
 	   (s1 (split-report-get-sort-spec-entry
 		(gnc:option-value tr-report-primary-key-op)
 		(eq? (gnc:option-value tr-report-primary-order-op) 'ascend)