;; -*-scheme-*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; advanced-portfolio-sorted.scm
;; by Johan van Oostrum (jvo@chaosgeordend.nl) Sept 2007,
;; for use with GnuCash 2.2.x
;; 
;; This is a modified version of:
;; advanced-portfolio.scm
;; by Martijn van Oosterhout (kleptog@svana.org) Feb 2002,
;; modified for GnuCash 1.8 by Herbert Thoma (herbie@hthoma.de) Oct 2002
;; Which in turn is heavily based on portfolio.scm
;; by Robert Merkel (rgmerk@mira.net)
;;
;; This program is free software; you can redistribute it and/or    
;; modify it under the terms of the GNU General Public License as   
;; published by the Free Software Foundation; either version 2 of   
;; the License, or (at your option) any later version.              
;;                                                                  
;; This program is distributed in the hope that it will be useful,  
;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
;; GNU General Public License for more details.                     
;;                                                                  
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation           Voice:  +1-617-542-5942
;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
;; Boston, MA  02111-1307,  USA       gnu@gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-module (gnucash report advanced-portfolio-sorted))

(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
(use-modules (srfi srfi-1))
(use-modules (ice-9 slib))
(use-modules (gnucash gnc-module))

(require 'printf)

(gnc:module-load "gnucash/report/report-system" 0)

(define reportname (N_ "Advanced Portfolio Sorted"))

(define optname-price-source  (N_ "Price Source"))
(define optname-sort-column   (N_ "Sort Column"))
(define optname-shares-digits (N_ "Share decimal places"))
(define optname-zero-shares   (N_ "Include accounts with no shares"))
(define optname-include-gains (N_ "Include gains and losses"))

(define (options-generator)
  (let* ((options (gnc:new-options)) 
         ;; This is just a helper function for making options.
         ;; See gnucash/src/scm/options.scm for details.
         (add-option 
          (lambda (new-option)
            (gnc:register-option options new-option))))
    
    ;; General Tab
    ;; date at which to report balance
    (gnc:options-add-report-date!
     options gnc:pagename-general 
     (N_ "Date") "a")
    
    (gnc:options-add-currency! 
     options gnc:pagename-general (N_ "Report Currency") "c")
    
    (add-option
     (gnc:make-multichoice-option
      gnc:pagename-general optname-sort-column
      "d" (N_ "The column on which the report is sorted") '0
      (list (vector '0 (N_ "Account") (N_ ""))
            (vector '1 (N_ "Symbol") (N_ ""))
            (vector '2 (N_ "Listing") (N_ ""))
            (vector '3 (N_ "Shares") (N_ ""))
            (vector '4 (N_ "Price") (N_ ""))
            (vector '5 (N_ "Value") (N_ ""))
            (vector '6 (N_ "Money-in") (N_ ""))
            (vector '7 (N_ "Money-out") (N_ ""))
            (vector '8 (N_ "Gain") (N_ ""))
            (vector '9 (N_ "Total return") (N_ ""))
            )))
    
    (add-option
     (gnc:make-multichoice-option
      gnc:pagename-general optname-price-source
      "d" (N_ "The source of price information") 'pricedb-nearest
      (list (vector 'pricedb-latest 
                    (N_ "Most recent")
                    (N_ "The most recent recorded price"))
            (vector 'pricedb-nearest
                    (N_ "Nearest in time")
                    (N_ "The price recorded nearest in time to the report date"))
            )))
    
    (add-option
     (gnc:make-number-range-option
      gnc:pagename-general optname-shares-digits
      "e" (N_ "The number of decimal places to use for share numbers") 2 0 6 0 1))
    
    (gnc:register-option 
     options 
     (gnc:make-simple-boolean-option
      gnc:pagename-general optname-include-gains "f" 
      (N_ "Include splits with no shares for calculating money-in and money-out")
      #f))
    
    ;; Account tab
    (add-option
     (gnc:make-account-list-option
      gnc:pagename-accounts (N_ "Accounts")
      "b"
      (N_ "Stock Accounts to report on")
      (lambda () (filter gnc:account-is-stock?
                         (gnc-account-get-descendants-sorted
                          (gnc-get-current-root-account))))
      (lambda (accounts) (list  #t 
                                (filter gnc:account-is-stock? accounts)))
      #t))
    
    (gnc:register-option 
     options 
     (gnc:make-simple-boolean-option
      gnc:pagename-accounts optname-zero-shares "e" 
      (N_ "Include accounts that have a zero share balances.")
      #f))
    
    (gnc:options-set-default-section options gnc:pagename-general)      
    options))

;; This is the rendering function. It accepts a database of options
;; and generates an object of type <html-document>.  See the file
;; report-html.txt for documentation; the file report-html.scm
;; includes all the relevant Scheme code. The option database passed
;; to the function is one created by the options-generator function
;; defined above.
(define (advanced-portfolio-sorted-renderer report-obj)
  
  (let ((work-done 0)
        (work-to-do 0))
    
    ;; These are some helper functions for looking up option values.
    (define (get-op section name)
      (gnc:lookup-option (gnc:report-options report-obj) section name))
    
    (define (get-option section name)
      (gnc:option-value (get-op section name)))
    
    (define (split-account-type? split type)
      (eq? type (xaccAccountGetType (xaccSplitGetAccount split))))
    
    (define (same-split? s1 s2)
      (string=? (gncSplitGetGUID s1) (gncSplitGetGUID s2)))
    
    ;; return list with computed values for all selected stocks
    (define (table-add-stock-rows accounts to-date
                                  currency price-fn exchange-fn include-empty include-gains
                                  total-value total-moneyin total-moneyout total-gain)
      
      (let ()
        (define (table-add-stock-rows-internal accounts)
          (if (null? accounts) (list) ; return empty list
              (let* ((current (car accounts))
                     (rest (cdr accounts))
                     
                     (name (xaccAccountGetName current))
                     (commodity (xaccAccountGetCommodity current))
                     (ticker-symbol (gnc-commodity-get-mnemonic commodity))
                     (listing (gnc-commodity-get-namespace commodity))
                     (unit-collector (gnc:account-get-comm-balance-at-date
                                      current to-date #f))
                     (units (cadr (unit-collector 'getpair commodity #f)))
                     (totalunits 0.0)
                     (totalunityears 0.0)
                     
                     ;; Counter to keep track of stuff
                     (unitscoll     (gnc:make-commodity-collector))
                     (brokeragecoll (gnc:make-commodity-collector))
                     (dividendcoll  (gnc:make-commodity-collector))
                     (moneyincoll   (gnc:make-commodity-collector))
                     (moneyoutcoll  (gnc:make-commodity-collector))
                     (gaincoll      (gnc:make-commodity-collector))
                     
                     (price-list (price-fn commodity to-date))
                     (price      (if (> (length price-list) 0)
                                     (car price-list)
                                     #f))
                     (rate       (if price
                                     (gnc:make-gnc-monetary
                                      (gnc-price-get-currency price)
                                      (gnc-price-get-value price))
                                     #f))
                     (value (exchange-fn (gnc:make-gnc-monetary commodity units) currency to-date))
                     )
                
                ;; (gnc:debug "---" name "---")
                (for-each
                 (lambda (split)
                   (set! work-done (+ 1 work-done))
                   (gnc:report-percent-done (* 100 (/ work-done work-to-do)))
                   (let ((parent (xaccSplitGetParent split)))
                     (if (gnc:timepair-le (gnc-transaction-get-date-posted parent) to-date)
                         (for-each
                          (lambda (s)
                            (cond
                              ((same-split? s split) 
                               ;; (gnc:debug "amount" (gnc-numeric-to-double (gnc:split-get-amount s)) )
                               (cond
                                 ((or include-gains (not (gnc-numeric-zero-p (xaccSplitGetAmount s))))
                                  (unitscoll 'add commodity (xaccSplitGetAmount s)) ;; Is the stock transaction?
                                  (if (< 0 (gnc-numeric-to-double
                                            (xaccSplitGetAmount s)))
                                      (set! totalunits
                                            (+ totalunits
                                               (gnc-numeric-to-double (xaccSplitGetAmount s)))))
                                  (set! totalunityears
                                        (+ totalunityears 
                                           (* (gnc-numeric-to-double (xaccSplitGetAmount s)) 
                                              (gnc:date-year-delta 
                                               (car (gnc-transaction-get-date-posted parent))
                                               (current-time))))) 
                                  (cond 
                                    ((gnc-numeric-negative-p (xaccSplitGetValue s))
                                     (moneyoutcoll
                                      'add currency
                                      (gnc-numeric-neg (xaccSplitGetValue s))))
                                    (else (moneyincoll 
                                           'add currency
                                           (gnc-numeric-neg (xaccSplitGetValue s))))))))
                              
                              ((split-account-type? s 'expense)
                               (brokeragecoll 'add currency (xaccSplitGetValue s)))
                              
                              ((split-account-type? s 'income)
                               (dividendcoll 'add currency (xaccSplitGetValue s)))
                              )
                            )
                          (xaccTransGetSplitList parent)
                          )
                         )
                     )
                   )
                 (xaccAccountGetSplitList current)
                 )
                
                ;;                (gnc:debug "totalunits" totalunits)
                ;;                (gnc:debug "totalunityears" totalunityears)
                
                (gaincoll 'merge moneyoutcoll #f)
                (gaincoll 'add (gnc:gnc-monetary-commodity value) (gnc:gnc-monetary-amount value))
                (gaincoll 'merge moneyincoll #f)
                
                (gnc-price-list-destroy price-list)
                
                (if (or include-empty (not (gnc-numeric-zero-p units)))
                    (begin
                      (total-value    'add (gnc:gnc-monetary-commodity value) (gnc:gnc-monetary-amount value))
                      (total-moneyin  'merge moneyincoll #f)
                      (total-moneyout 'merge moneyoutcoll #f)
                      (total-gain     'merge gaincoll #f)
                      
                      ;;(gnc:warn ">name: " (gnc:account-get-name current))
                      ;;(if price (gnc:warn ">price: " (gnc-numeric-to-double (gnc:gnc-monetary-amount rate))))
                      
                      (cons (list current
                                  ticker-symbol
                                  listing
                                  units
                                  rate
                                  value
                                  (gnc:monetary-neg (gnc:sum-collector-commodity moneyincoll currency exchange-fn))
                                  (gnc:sum-collector-commodity moneyoutcoll currency exchange-fn)
                                  (gnc:sum-collector-commodity gaincoll currency exchange-fn)
                                  (* 100 (/ (gnc-numeric-to-double (cadr (gaincoll 'getpair currency #f)))
                                            (gnc-numeric-to-double (cadr (moneyincoll 'getpair currency #t)))))
                                  price)
                            (table-add-stock-rows-internal rest)))
                    
                    (table-add-stock-rows-internal rest)))
              ))
        
        (set! work-to-do (gnc:accounts-count-splits accounts)) ; #splits as progress indicator
        
        (table-add-stock-rows-internal accounts)
        
        ))
    
    ;; add one row with stock-computed values to the HTML table
    (define (table-add-stock-row-html table share-print-info odd-row?
                                      current ticker-symbol listing units
                                      rate value money-in money-out gain return price)
      (let* ((row-style (if odd-row? "normal-row" "alternate-row"))
             (odd-row? (not odd-row?)))
        (gnc:html-table-append-row/markup!
         table
         row-style
         (list (gnc:html-account-anchor current)
               ticker-symbol
               listing
               (gnc:make-html-table-header-cell/markup "number-cell" (xaccPrintAmount units share-print-info))
               (gnc:make-html-table-header-cell/markup
                "number-cell"
                (if price
                    (gnc:html-price-anchor price rate)
                    #f))
               (gnc:make-html-table-header-cell/markup "number-cell" value)
               (gnc:make-html-table-header-cell/markup "number-cell" money-in)
               (gnc:make-html-table-header-cell/markup "number-cell" money-out)
               (gnc:make-html-table-header-cell/markup "number-cell" gain)
               (gnc:make-html-table-header-cell/markup "number-cell" (sprintf #f "%.2f%%" return))
               ))))
    
    ;; add all computed values off all stocks selected to the HTML table
    (define (table-add-stock-rows-html table account-totals)
      (let* 
          ;; get printing related options first
          ((share-print-info (gnc-share-print-info-places (inexact->exact (get-option gnc:pagename-general
                                                                                      optname-shares-digits))))
           (c (get-option gnc:pagename-general
                          optname-sort-column))
           (odd-row? #t)) 
        
        (for-each
         (lambda (l)
           (apply table-add-stock-row-html table share-print-info odd-row? l))
         ;; sort column (c in sort-list compare-less procedure) offsets are:
         ;; 0 account
         ;; 1 symbol
         ;; 2 listing
         ;; 3 shares (units)
         ;; 4 price (rate)
         ;; 5 value
         ;; 6 money-in
         ;; 7 money-out
         ;; 8 gain
         ;; 9 total-return
         (sort-list account-totals (cond 
                                     ((= c 0)
                                      (lambda (list1 list2)
                                        (if (string<? (xaccAccountGetName (list-ref list1 c))
                                                      (xaccAccountGetName (list-ref list2 c))) #t #f)))
                                     ((and (> c 0) (< c 3))
                                      (lambda (list1 list2)
                                        (if (string<? (list-ref list1 c) (list-ref list2 c)) #t #f)))
                                     ((= c 3)
                                      (lambda (list1 list2)
                                        (if (< (gnc-numeric-to-double(list-ref list1 c))
                                               (gnc-numeric-to-double(list-ref list2 c))) #t #f)))
                                     ((= c 4)
                                      (lambda (list1 list2)
                                        (if (< (if (list-ref list1 c) (gnc-numeric-to-double (gnc:gnc-monetary-amount (list-ref list1 c))) 0.0)
                                               (if (list-ref list2 c) (gnc-numeric-to-double (gnc:gnc-monetary-amount (list-ref list2 c))) 0.0)) #t #f)))
                                     ((and (> c 4) (< c 9))
                                      (lambda (list1 list2)
                                        (if (< (gnc-numeric-to-double (gnc:gnc-monetary-amount (list-ref list1 c)))
                                               (gnc-numeric-to-double (gnc:gnc-monetary-amount (list-ref list2 c)))) #t #f)))
                                     ((> c 8)
                                      (lambda (list1 list2)
                                        (if (< (list-ref list1 c) (list-ref list2 c)) #t #f)))
                                     )))))
    
    ;; Tell the user that we're starting.
    (gnc:report-starting reportname)
    
    ;; The first thing we do is make local variables for all the specific
    ;; options in the set of options given to the function. This set will
    ;; be generated by the options generator above.
    (let ((to-date       (gnc:date-option-absolute-time
                          (get-option gnc:pagename-general "Date")))
          (accounts      (get-option gnc:pagename-accounts "Accounts"))
          (currency      (get-option gnc:pagename-general "Report Currency"))
          (price-source  (get-option gnc:pagename-general
                                     optname-price-source))
          (report-title  (get-option gnc:pagename-general 
                                     gnc:optname-reportname))
          (include-empty (get-option gnc:pagename-accounts
                                     optname-zero-shares))
          (include-gains (get-option gnc:pagename-general
                                     optname-include-gains))
          
          (total-value    (gnc:make-commodity-collector))
          (total-moneyin  (gnc:make-commodity-collector))
          (total-moneyout (gnc:make-commodity-collector))
          (total-gain     (gnc:make-commodity-collector))
          ;; document will be the HTML document that we return.
          (table (gnc:make-html-table))
          (document (gnc:make-html-document)))
      
      (gnc:html-document-set-title!
       document (string-append 
                 report-title
                 (sprintf #f " %s" (gnc-print-date to-date))))
      
      ;;    (gnc:debug "accounts" accounts)
      (if (not (null? accounts))
          ; at least one account selected
          (let* ((exchange-fn
                  (case price-source
                    ('pricedb-latest 
                      (lambda (foreign domestic date)
                        (gnc:exchange-by-pricedb-latest foreign domestic)))
                    ('pricedb-nearest gnc:exchange-by-pricedb-nearest)))
                 (pricedb (gnc-pricedb-get-db (gnc-get-current-book)))
                 (price-fn
                  (case price-source
                    ('pricedb-latest 
                      (lambda (foreign date) 
                        (gnc-pricedb-lookup-latest-any-currency pricedb foreign)))
                    ('pricedb-nearest 
                      (lambda (foreign date) 
                        (gnc-pricedb-lookup-nearest-in-time-any-currency pricedb foreign date))))))
            
            (gnc:html-table-set-col-headers!
             table
             (list (_ "Account")
                   (_ "Symbol")
                   (_ "Listing")
                   (_ "Shares")
                   (_ "Price")
                   (_ "Value")
                   (_ "Money In")
                   (_ "Money Out")
                   (_ "Gain")
                   (_ "Total Return")))
            
            (table-add-stock-rows-html table
                                       (table-add-stock-rows accounts to-date
                                                             currency price-fn exchange-fn
                                                             include-empty include-gains
                                                             total-value total-moneyin total-moneyout total-gain))
            
            (gnc:html-table-append-row/markup!
             table
             "grand-total"
             (list
              (gnc:make-html-table-cell/size
               1 10 (gnc:make-html-text (gnc:html-markup-hr)))))
            
            (gnc:html-table-append-row/markup!
             table
             "grand-total"
             (list (gnc:make-html-table-cell/markup
                    "total-label-cell" (_ "Total"))
                   ""
                   ""
                   ""
                   ""
                   (gnc:make-html-table-cell/markup
                    "total-number-cell" (gnc:sum-collector-commodity total-value currency exchange-fn))
                   (gnc:make-html-table-cell/markup
                    "total-number-cell" (gnc:monetary-neg (gnc:sum-collector-commodity total-moneyin currency exchange-fn)))
                   (gnc:make-html-table-cell/markup
                    "total-number-cell" (gnc:sum-collector-commodity total-moneyout currency exchange-fn))
                   (gnc:make-html-table-cell/markup
                    "total-number-cell" (gnc:sum-collector-commodity total-gain currency exchange-fn))
                   (gnc:make-html-table-cell/markup
                    "total-number-cell" (sprintf #f "%.2f%%" (* 100 (/ (gnc-numeric-to-double (cadr (total-gain 'getpair currency #f)))
                                                                       (gnc-numeric-to-double (cadr (total-moneyin 'getpair currency #t)))))))
                   ))
            
            ;;          (total-value
            ;;           'format 
            ;;           (lambda (currency amount)
            ;;             (gnc:html-table-append-row/markup! 
            ;;              table
            ;;              "grand-total"
            ;;              (list (gnc:make-html-table-cell/markup
            ;;                     "total-label-cell" (_ "Total"))
            ;;                    (gnc:make-html-table-cell/size/markup
            ;;                     1 5 "total-number-cell"
            ;;                     (gnc:make-gnc-monetary currency amount)))))
            ;;           #f)
            
            (gnc:html-document-add-object! document table))
          
          ;if no accounts selected.
          (gnc:html-document-add-object!
           document
           (gnc:html-make-no-account-warning 
            report-title (gnc:report-id report-obj))))
      
      (gnc:report-finished)
      document)))

(gnc:define-report
 'version 1
 'name reportname
 'menu-path (list gnc:menuname-asset-liability)
 'options-generator options-generator
 'renderer advanced-portfolio-sorted-renderer)