;; -*-scheme-*-
;; $Id: balance-and-pnl.scm,v 1.20 2000/06/09 23:59:40 peticolas Exp $
;; Balance and Profit/Loss Reports

(gnc:support "report/balance-and-pnl.scm")
(gnc:depend "text-export.scm")
(gnc:depend "report-utilities.scm")
(gnc:depend "options.scm")



;; Just a private scope.
(let 
    ((l0-collector (make-stats-collector))
     (l1-collector (make-stats-collector))
     (l2-collector (make-stats-collector))
     (l3-collector (make-stats-collector))
     (equity-collector (make-stats-collector))
     (debug-string '()))
     

  (define string-db (gnc:make-string-database))

  (define (balsht-options-generator)
    (define gnc:*balsht-report-options* (gnc:new-options))
    (define (gnc:register-balsht-option new-option)
      (gnc:register-option gnc:*balsht-report-options* new-option)) 

    (gnc:register-balsht-option
     (gnc:make-date-option
      "Report Options" "To"
      "a" "Calculate balance sheet up to this date"
      (lambda ()
        (let ((bdtime (localtime (current-time))))
          (set-tm:sec bdtime 59)
          (set-tm:min bdtime 59)
          (set-tm:hour bdtime 23)
          (let ((time (car (mktime bdtime))))
            (cons time 0))))
      #f))
 
   (gnc:register-balsht-option
     (gnc:make-simple-boolean-option
      "Report Options" "Render level 3 account"
      "a" "This is a boolean option." #f))

   gnc:*balsht-report-options*)

  (define  (pnl-options-generator)
    (define gnc:*pnl-report-options* (gnc:new-options))
    (define (gnc:register-pnl-option new-option)
      (gnc:register-option gnc:*pnl-report-options* new-option))

   (gnc:register-pnl-option
     (gnc:make-number-range-option
      "Report Options" "Month"
      "ee" "This is a number option."
      (string->number (strftime "%m" (localtime (current-time)))) ;; default is current month
      1     ;; lower bound
      12 ;; upper bound
      0     ;; number of decimals
      1    ;; step size
      ))

   (gnc:register-pnl-option
     (gnc:make-number-range-option
      "Report Options" "Year"
      "ee" "This is a number option."
      (string->number (strftime "%Y" (localtime (current-time)))) ;; default is current year
      0     ;; lower bound
      3000 ;; upper bound
      0     ;; number of decimals
      1    ;; step size
      ))
 
   (gnc:register-pnl-option
     (gnc:make-simple-boolean-option
      "Report Options" "Render level 3 account"
      "a" "This is a boolean option." #t))

    gnc:*pnl-report-options*)

  (define (render-level-3-account level-3-account l3-value)
    (let ((account-name (string-append "        "
                                       (gnc:account-get-full-name
                                        level-3-account)))
          (type-name (gnc:account-get-type-string
                      (gnc:account-get-type level-3-account))))
      (html-table-row-align
       (list
	account-name type-name (gnc:amount->formatted-string l3-value #f))
       (list "left" "center" "right"))))

  (define (render-level-2-account level-2-account l2-value)
    (let ((account-name (string-append "    "
                                       (gnc:account-get-full-name
                                        level-2-account)))
          (type-name (gnc:account-get-type-string
                      (gnc:account-get-type level-2-account))))
      (html-table-row-align
       (list
	account-name type-name " " (gnc:amount->formatted-string l2-value #f))
       (list "left" "center" "right" "right"))))

  (define (render-level-1-account account l1-value)
    (let ((name (gnc:account-get-full-name account))
          (type (gnc:account-get-type-string (gnc:account-get-type account))))
      (html-table-row-align
       (list name type " " " "
             (gnc:amount->formatted-string l1-value #f)
	     " " " ")
       (list "left" "center" "right" "right" "right" "right" "right"))))

  (define (render-total l0-value)
    (html-table-row-align
     (list " " " " " " " "
           (html-strong (string-db 'lookup 'net))
           " "
           (gnc:amount->formatted-string l0-value #f))
     (list "left" "center" "right" "right" "right" "right" "right")))

  (define (render-gross l0-value-gross)
    (html-table-row-align
     (list " " " " " " " "
           (html-strong (string-db 'lookup 'gross))
           " "
           (gnc:amount->formatted-string l0-value-gross #f))
     (list "left" "center" "right" "right" "right" "right" "right")))

  (define blank-line
    (html-table-row '()))

  (define (is-it-on-balance-sheet? type balance?)
    (eq? 
     (not (member type '(INCOME EXPENSE)))
     (not balance?)))


  (define (generate-balance-sheet-or-pnl report-name
					 report-description
					 options
					 balance-sheet?)

    (let* ((month-option (gnc:lookup-option options "Report Options" "Month"))
	   (month-value (if month-option (inexact->exact (- (gnc:option-value month-option) 1))))
	   (year-option (gnc:lookup-option options "Report Options" "Year"))
	   (year-value (if year-option (inexact->exact (- (gnc:option-value year-option) 1900))))
	   (from-value (if month-option 
			   (let ((bdtime (localtime (current-time))))
			     (set-tm:sec bdtime 0)
			     (set-tm:min bdtime 0)
			     (set-tm:hour bdtime 0)
			     (set-tm:mday bdtime -2)
			     (set-tm:mon bdtime month-value)
			     (set-tm:year bdtime year-value)
;			     (set-tm:year bdtime 99)
			     (let ((time (car (mktime bdtime))))
			       (cons time 0)))))

	   (to-value (if balance-sheet?
			 (gnc:timepair-end-day-time
			  (gnc:option-value
			   (gnc:lookup-option options "Report Options" "To")))
			 (let ((bdtime (localtime (current-time))))
			   (set-tm:sec bdtime 0)
			   (set-tm:min bdtime 0)
			   (set-tm:hour bdtime 0)
			   (set-tm:mday bdtime -2)
			   (set-tm:mon bdtime (+ 1 month-value))
			   (set-tm:year bdtime year-value)
			   (let ((time (car (mktime bdtime))))
			     (cons time 0)))))

	   (from-date-string (if balance-sheet?
				 '()
				 (string-append " for " 
						(strftime "%B" (localtime (car to-value)))
						": From " (strftime "%x" (localtime (car from-value))))))

	   (to-date-string (if balance-sheet? 
			       (string-append " as of " (strftime "%x" (localtime (car to-value))))
			       (string-append " To " (strftime "%x" (localtime (car to-value))))))
	   (render-l3-account? (gnc:option-value (gnc:lookup-option options "Report Options" "Render level 3 account"))))
			       
      (define (handle-level-1-account account options)
        (let ((type (gnc:account-type->symbol (gnc:account-get-type account))))
          (if (is-it-on-balance-sheet? type balance-sheet?)
              ;; Ignore
              '()
              (let* ((children (gnc:account-get-children account))
                     (num-children (gnc:group-get-num-accounts children))

                     (childrens-output (gnc:group-map-accounts
                                        (lambda (x)
                                          (handle-level-2-account x options))
                                        children))

                     (account-balance (if balance-sheet?
                                          (gnc:account-get-balance-at-date
                                           account
                                           to-value #f)
                                          (gnc:account-get-balance-interval
                                           account
                                           from-value
                                           to-value #f))))

                (if (not balance-sheet?)
                    (set! account-balance (- account-balance)))
                (l1-collector 'add account-balance)
                (l0-collector 'add (l1-collector 'total #f))
		(if (eq? (not (member type '(EQUITY))) #f) (equity-collector 'add (l1-collector 'total #f)))
                (let ((level-1-output
                       (render-level-1-account account
                                               (l1-collector 'total #f))))
                  (l1-collector 'reset #f)
                  (l2-collector 'reset #f)
                  (if (null? childrens-output)
                      level-1-output
                      (list blank-line
                            level-1-output
                            childrens-output
                            blank-line)))))))

      (define (handle-level-2-account account options)
        (let ((type (gnc:account-type->symbol (gnc:account-get-type account))))
          (if (is-it-on-balance-sheet? type balance-sheet?)
              ;; Ignore
              '()
              (let* ((children (gnc:account-get-children account))
                     (num-children (gnc:group-get-num-accounts children))

                     (childrens-output (gnc:group-map-accounts
                                        (lambda (x)
                                          (handle-level-3-account x options))
                                        children))

                     (account-balance (if balance-sheet?
                                          (gnc:account-get-balance-at-date
                                           account
                                           to-value #f)
                                          (gnc:account-get-balance-interval
                                           account
                                           from-value
                                           to-value #f))))

                (if (not balance-sheet?)
                    (set! account-balance (- account-balance)))
                (l2-collector 'add account-balance)
                (l2-collector 'add (l3-collector 'total #f))
                (l1-collector 'add (l2-collector 'total #f))
		(let ((level-2-output
                       (render-level-2-account account
                                               (l2-collector 'total #f))))
                  (l2-collector 'reset #f)
                  (l3-collector 'reset #f)
                  (if (null? childrens-output)
                      level-2-output
		      (if render-l3-account?
			  (list blank-line
				level-2-output
				childrens-output
				blank-line)
			  level-2-output)))))))

    (define (handle-level-3-account account options)
      (let
 	  ((type (gnc:account-type->symbol (gnc:account-get-type account)))
	   (balance (make-stats-collector))
	   (rawbal
	    (if balance-sheet?
		(gnc:account-get-balance-at-date account to-value #f)
		(gnc:account-get-balance-interval 
		 account 
		 from-value
		 to-value #f))))
	(balance 'add 
		 (if balance-sheet? 
		     rawbal
		     (- rawbal)))
	(if (is-it-on-balance-sheet? type balance-sheet?)
	    ;; Ignore
	    '()
	    ;; add in balances for any sub-sub groups
	    (let ((grandchildren (gnc:account-get-children account)))
	      (if (not (pointer-token-null? grandchildren))
		  (balance 'add 
			   ((if balance-sheet? + -) 
			    0
			    (if balance-sheet? 
				(gnc:group-get-balance-at-date grandchildren 
                                                               to-value)
				(gnc:group-get-balance-interval grandchildren
								from-value
								to-value)))))
	      (l3-collector 'add (balance 'total #f))
	      

	      (render-level-3-account account (balance 'total #f))))))


    (let
	((current-group (gnc:get-current-group))
	 (output '()))

      ;; Now, the main body
      ;; Reset all the balance collectors
      (l0-collector 'reset #f)
      (l1-collector 'reset #f)
      (l2-collector 'reset #f)
      (equity-collector 'reset #f)
      (if (not (pointer-token-null? current-group))
	  (set! output
		(list
		 (gnc:group-map-accounts
		  (lambda (x) (handle-level-1-account x options))
		  current-group)
		 (render-total  (l0-collector 'total #f))
		 (if balance-sheet? (render-gross  (- (l0-collector 'total #f) (equity-collector 'total #f)))))))
      
      (list
       "<html>\n"
       "<head>\n"
       "<title>" report-name "</title>\n"
       "</head>\n"
       (if balance-sheet?
           "<body bgcolor=#fffde6>\n"
           "<body bgcolor=#f6ffdb>\n")
;       Debugging
;       (number->string year-value) ", "
;       (number->string (tm:year (localtime (current-time))))
       "<center>\n"
       "<table cellpadding=1 width=100%>\n"
       "<caption><b>" report-name from-date-string to-date-string "</b></caption>\n"
       "<tr>\n"
       "<th>" (string-db 'lookup 'account-name) "</th>\n"
       "<th align=center>" (string-db 'lookup 'type)  "</th>\n"
       (if render-l3-account? (list "<th align=right>" (string-db 'lookup 'subaccounts) "</th>\n") "<th></th>")
       "<th align=right>" (string-db 'lookup 'subaccounts) "</th>\n"
       "<th align=right>" (string-db 'lookup 'balance) "</th>\n"
       "</tr>\n"

       output

       "</table>\n"
       "</center>\n"
       "</body>\n"
       "</html>\n"))))

  (string-db 'store 'net "Net")
  (string-db 'store 'gross "Gross")
  (string-db 'store 'type "Type")
  (string-db 'store 'account-name "Account Name")
  (string-db 'store 'subaccounts "(subaccounts)")
  (string-db 'store 'balance "Balance")
  (string-db 'store 'bal-title "Balance Sheet")
  (string-db 'store 'bal-desc "This page shows your net worth.")
  (string-db 'store 'pnl-title "Profit and Loss")
  (string-db 'store 'pnl-desc "This page shows your profits and losses.")

  (gnc:define-report
   'version 1
   'name "Level 3 Balance sheet"
   'options-generator balsht-options-generator
   'renderer (lambda (options)
               (generate-balance-sheet-or-pnl
                (string-db 'lookup 'bal-title)
                (string-db 'lookup 'bal-desc)
                options
                #t)))

  (gnc:define-report
   'version 1
   'name "Monthly Profit and Loss"
   'options-generator pnl-options-generator
   'renderer (lambda (options)
               (generate-balance-sheet-or-pnl 
                (string-db 'lookup 'pnl-title)
                (string-db 'lookup 'pnl-desc)
                options
                #f))))