Christian Stimming's patch to use gnc-numerics in the balance collectors.

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

src/scm/report-utilities.scm

@@ -21,7 +21,10 @@
 (gnc:depend "engine-utilities.scm")
 
 (define (gnc:amount->string amount info)
-  (gnc:amount->string-helper (exact->inexact amount) info))
+  (d-gnc:amount->string-helper (exact->inexact amount) info))
+
+(define (gnc:commodity-amount->string amount info)
+  (gnc:amount->string-helper amount info))
 
 (define (gnc:account-has-shares? account)
   (let ((type (gw:enum-GNCAccountType-val->sym
@@ -236,79 +239,109 @@
 	('total value)
 	(else (gnc:warn "bad value-collector action: " action))))))
 
-;; A currency collector. This is intended to handle multiple currencies' 
+;; Same as above but with gnc:numeric
-;; amounts. The amounts are accumulated via 'add, the result can be 
+(define (make-numeric-collector)
-;; fetched via 'format.
+  (let ;;; values
-;; Example: (define a (make-currency-collector)) ... (a 'add 'USD 12) ...
+      ((value (gnc:numeric-zero)))
-;; (a 'format (lambda(x y)(list x y)) #f) 
+    (lambda (action amount)  ;;; Dispatch function
-;; gives you something like ((USD 123.4) (DEM 12.21) (FRF -23.32))
+      (case action
+	('add (if (gnc:gnc-numeric? amount) 
+		  (set! value (gnc:numeric-add-fixed amount value))))
+	('total value)
+	(else (gnc:warn "bad numeric-collector action: " action))))))
+
+;; A commodity collector. This is intended to handle multiple
+;; currencies' amounts. The amounts are accumulated via 'add, the
+;; result can be fetched via 'format.  Used to work with strings as
+;; currencies and doubles as values, but now it uses <gnc:commodity*>
+;; as commodity and <gnc:numeric> as value. 
+;; Old Example: (define a (make-commodity-collector)) ... 
+;; (a 'add 'USD 12) ...  (a 'format (lambda(x y)(list x y)) #f) 
+;; used to give you something like 
+;; ((USD 123.4) (DEM 12.21) (FRF -23.32))
 ;;
 ;; The functions:
-;;   'add <currency> <amount>: Add the given amount to the 
+;;   'add <commodity> <amount>: Add the given amount to the 
 ;;       appropriate currencies' total amount.
-;;   'format <fn> #f: Call the function <fn> (where fn takes two arguments) for 
+;;   'format <fn> #f: Call the function <fn> (where fn takes two
-;;       each currency with the arguments <currency> and the corresponding 
+;;       arguments) for each commodity with the arguments <commodity>
-;;       total <amount>. The results is a list of each call's result.
+;;       and the corresponding total <amount>. The results is a list
-;;   'merge <currency-collector> #f: Merge the given other currency-collector into
+;;       of each call's result.
-;;       this one, adding all currencies' amounts, respectively.
+;;   'merge <commodity-collector> #f: Merge the given other
-;;   'minusmerge <currency-collector> #f: Merge the given other 
+;;       commodity-collector into this one, adding all currencies'
-;;       currency-collector into this one (like above) but subtract the other's
+;;       amounts, respectively.
-;;       currencies' amounts from this one's amounts, respectively.
+;;   'minusmerge <commodity-collector> #f: Merge the given other 
+;;       commodity-collector into this one (like above) but subtract
+;;       the other's currencies' amounts from this one's amounts,
+;;       respectively.
 ;;   'reset #f #f: Delete everything that has been accumulated 
-;;       (even the fact that any currency showed up at all).
+;;       (even the fact that any commodity showed up at all).
-;;   (internal) 'list #f #f: get the association list of currency->value-collector
+;;   (internal) 'list #f #f: get the association list of 
+;;        commodity->numeric-collector
 
-(define (make-currency-collector)
+(define (make-commodity-collector)
   (let 
-      ;; the association list of (currency -> value-collector) pairs.
+      ;; the association list of (commodity -> value-collector) pairs.
-      ((currencylist '()))
+      ((commoditylist '()))
     
-    ;; helper function to add a currency->value pair to our list. 
+    ;; helper function to add a commodity->value pair to our list. 
-    ;; If no pair with this currency exists, we will create one.
+    ;; If no pair with this commodity exists, we will create one.
-    (define (add-currency-value currency value)
+    (define (add-commodity-value commodity value)
       ;; lookup the corresponding pair
-      (let ((pair (assoc currency currencylist)))
+      (let ((pair (assoc commodity commoditylist)))
 	(if (not pair)
 	    (begin
-	      ;; create a new pair, using the value-collector
+	      ;; create a new pair, using the gnc:numeric-collector
-	      (set! pair (list currency (make-value-collector)))
+	      (set! pair (list commodity (make-numeric-collector)))
 	      ;; and add it to the alist
-	      (set! currencylist (cons pair currencylist))))
+	      (set! commoditylist (cons pair commoditylist))))
 	;; add the value
 	((cadr pair) 'add value)))
     
     ;; helper function to walk an association list, adding each
-    ;; (currency -> collector) pair to our list
+    ;; (commodity -> collector) pair to our list at the appropriate 
-    (define (add-currency-clist clist)
+    ;; place
+    (define (add-commodity-clist clist)
       (cond ((null? clist) '())
-	    (else (add-currency-value (caar clist) 
+	    (else (add-commodity-value (caar clist) 
 				       ((cadar clist) 'total #f))
-		  (add-currency-clist (cdr clist)))))
+		  (add-commodity-clist (cdr clist)))))
 
-    (define (minus-currency-clist clist)
+    (define (minus-commodity-clist clist)
       (cond ((null? clist) '())
-	    (else (add-currency-value (caar clist) 
+	    (else (add-commodity-value (caar clist) 
-				      (* -1 
+				       (gnc:numeric-sub-fixed 
+					gnc:numeric-zero 
 					((cadar clist) 'total #f)))
-		  (minus-currency-clist (cdr clist)))))
+		  (minus-commodity-clist (cdr clist)))))
 
     ;; helper function walk the association list doing a callback on
     ;; each key-value pair.
-    (define (process-currency-list fn clist)
+    (define (process-commodity-list fn clist)
       (cond ((null? clist) '())
 	    (else (cons (fn (caar clist) ((cadar clist) 'total #f))
-			(process-currency-list fn (cdr clist))))))
+			(process-commodity-list fn (cdr clist))))))
+
+    ;; helper function which is given a commodity and returns, if
+    ;; existing, a list (gnc-commodity gnc:numeric) 
+    (define (getpair c)
+      (let ((pair (assoc c commoditylist)))
+	(list c 
+	      (if (not pair)
+		  (gnc:numeric-zero)
+		  ((cadr pair) 'total #f)))))
 
     ;; Dispatch function
-    (lambda (action currency amount)
+    (lambda (action commodity amount)
       (case action
-	('add (add-currency-value currency amount))
+	('add (add-commodity-value commodity amount))
-	('merge (add-currency-clist (currency 'list #f #f)))
+	('merge (add-commodity-clist (commodity 'list #f #f)))
-	('minusmerge (minus-currency-clist (currency 'list #f #f)))
+	('minusmerge (minus-commodity-clist (commodity 'list #f #f)))
-	('format (process-currency-list currency currencylist))
+	('format (process-commodity-list commodity commoditylist))
-	('reset (set! currencylist '()))
+	('reset (set! commoditylist '()))
-	('list currencylist) ; this one is only for internal use
+	('getpair (getpair commodity))
-	(else (gnc:warn "bad currency-collector action: " action))))))
+	('list commoditylist) ; this one is only for internal use
+	(else (gnc:warn "bad commodity-collector action: " action))))))
 
 ;; Add x to list lst if it is not already in there
 (define (addunique lst x)
@@ -360,27 +393,34 @@
         (+ balance children-balance)
         balance)))    
 
-;; This works similar as above but returns a currency-collector, 
+;; This works similar as above but returns a commodity-collector, 
 ;; thus takes care of children accounts with different currencies.
-(define (gnc:account-get-curr-balance-at-date account 
+;;
+;; Note that the commodity-collector contains <gnc:numeric> values
+;; rather than double values.
+(define (gnc:account-get-comm-balance-at-date account 
 					      date include-children?)
   (let ((balance-collector
          (if include-children?
-             (gnc:group-get-curr-balance-at-date
+             (gnc:group-get-comm-balance-at-date
               (gnc:account-get-children account) date)
-             (make-currency-collector))))
+             (make-commodity-collector)))
-    (let loop ((index 0)
+        (query (gnc:malloc-query))
-	       (balance 0)
+        (splits #f))
-	       (split (gnc:account-get-split account 0)))
+
-      (if (not split)
+    (gnc:query-set-group query (gnc:get-current-group))
-	  (balance-collector 'add (gnc:account-get-currency account)
+    (gnc:query-add-single-account-match query account 'query-and)
-			     balance)
+    (gnc:query-add-date-match-timepair query #f date #t date 'query-and) 
-	  (if (gnc:timepair-lt date (gnc:split-get-transaction-date split))
+    (gnc:query-set-sort-order query 'by-date 'by-standard 'by-none)
-	      (balance-collector 'add (gnc:account-get-currency account)
+    (gnc:query-set-sort-increasing query #t)
-				 balance)
+    (gnc:query-set-max-splits query 1)
-	      (loop (+ index 1)
+
-		    (d-gnc:split-get-balance split)
+    (set! splits (gnc:glist->list 
-		    (gnc:account-get-split account (+ index 1))))))
+                  (gnc:query-get-splits query) 
+                  <gnc:Split*>))
+    (if (and splits (not (null? splits)))
+	(balance-collector 'add (gnc:account-get-commodity account)
+			   (gnc:split-get-balance (car splits))))
     balance-collector))
 
 ;; get the balance of a group of accounts at the specified date.
@@ -392,13 +432,15 @@
             (gnc:account-get-balance-at-date account date #t)) 
           group)))
 
-;; returns a currency-collector
+;; returns a commodity-collector
-(define (gnc:group-get-curr-balance-at-date group date)
+(define (gnc:group-get-comm-balance-at-date group date)
-  (let ((this-collector (make-currency-collector)))
+  (let ((this-collector (make-commodity-collector)))
     (for-each (lambda (x) (this-collector 'merge x #f))
 	      (gnc:group-map-accounts
 	       (lambda (account)
-		 (gnc:account-get-curr-balance-at-date account date #t)) group))
+		 (gnc:account-get-comm-balance-at-date 
+		  account date #t)) 
+	       group))
     this-collector))
 
 ;; get the change in balance from the 'from' date to the 'to' date.
@@ -408,12 +450,12 @@
   (- (d-gnc:account-get-balance-at-date account to include-children?)
      (d-gnc:account-get-balance-at-date account from include-children?)))
 
-;; the version which returns a currency-collector
+;; the version which returns a commodity-collector
-(define (gnc:account-get-curr-balance-interval 
+(define (gnc:account-get-comm-balance-interval 
 	 account from to include-children?)
-  (let ((this-collector (gnc:account-get-curr-balance-at-date 
+  (let ((this-collector (gnc:account-get-comm-balance-at-date 
 			 account to include-children?)))
-    (this-collector 'minusmerge (gnc:account-get-curr-balance-at-date 
+    (this-collector 'minusmerge (gnc:account-get-comm-balance-at-date 
 				 account from include-children?) #f)
     this-collector))
 
@@ -423,13 +465,13 @@
           (lambda (account)
             (d-gnc:account-get-balance-interval account from to #t)) group)))
 
-;; the version which returns a currency-collector
+;; the version which returns a commodity-collector
-(define (gnc:group-get-curr-balance-interval group from to)
+(define (gnc:group-get-comm-balance-interval group from to)
-  (let ((this-collector (make-currency-collector)))
+  (let ((this-collector (make-commodity-collector)))
     (for-each (lambda (x) (this-collector 'merge x #f))
 	      (gnc:group-map-accounts
 	       (lambda (account)
-		 (gnc:account-get-curr-balance-interval 
+		 (gnc:account-get-comm-balance-interval 
 		  account from to #t)) group))
     this-collector))
 

src/scm/report/account-summary.scm

@@ -119,7 +119,15 @@
       (gnc:html-table-append-column! 
        table
        (map (lambda (acct)
-              (gnc:account-get-balance-at-date acct end-date sub-balances?))
+              (let ((pair 
+		     ((gnc:account-get-comm-balance-at-date 
+		       acct end-date sub-balances?) 
+		      'getpair (gnc:account-get-commodity acct) #f)))
+		;; pair is a list of one gnc:commodity and 
+		;; one gnc:numeric value
+		 (gnc:commodity-amount->string 
+		  (cadr pair) 
+		  (gnc:commodity-print-info (car pair) #t))))
 	    accounts))
       
       ;; set column and table styles