Success & Fixes...

Christopher Browne cbbrowne@hex.net
Thu, 17 Aug 2000 08:14:25 -0500


After installing still-some-further-dev-packages that came available
this week in Helix Gnome, GnuCash again became buildable and runnable.

With the next result that I have done some testing of the "new
reporting code" that uses lists rather than appending strings
together.

Attached are the three files that have changed lately...

1.  report.scm

;; 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

(require 'hash-table)

(require 'record)
(gnc:support "report.scm")

;; We use a hash to store the report info so that whenever a report
;; is requested, we'll look up the action to take dynamically. That
;; makes it easier for us to allow changing the report definitions
;; on the fly later, and it should have no appreciable performance
;; effect.

(define *gnc:_report-info_* (make-hash-table 23))
;; This hash should contain all the reports available and will be used
;; to generate the reports menu whenever a new window opens and to
;; figure out what to do when a report needs to be generated.
;;
;; The key is the string naming the report and the value is the report
;; structure.

(define (gnc:run-report report-name options)
  ;; Return a string consisting of the contents of the report.

  (define (display-report-list-item item port)
    (cond
     ((string? item) (display item port))
     ((null? item) #t)
     ((list? item) (map (lambda (item) (display-report-list-item item port))
                        item))
     (else (gnc:warn "gnc:run-report - " item " is the wrong type."))))

;; Old version assumed flat lists
;   (define (report-output->string lines)
;     (call-with-output-string
;      (lambda (port)
;        (for-each
;         (lambda (item) (display-report-list-item item port))
;         lines))))

;; New version that processes a _tree_ rather than a flat list of
;; strings.  This means that we can pass in somewhat "more structured"
;; data.

  (define (output-tree-to-port tree port)
    (cond 
     ((pair? tree)
      (output-tree-to-port (car tree) port) 
      (output-tree-to-port (cdr tree) port))
     ((string? tree)
      (display-report-list-item tree port)
      (newline port))
     ((null? tree)
      #f) ;;; Do Nothing...
     (tree  ;;; If it's not #f
      (display-report-list-item "<B> Error - Bad atom! </b>" port)
      (display-report-list-item tree port)
      (display "Err: (")
      (write tree)
      (display ")")
      (newline)
      (newline port))))
  
    (define (report-output->string tree)
      (display "(Report-Tree ")
      (display tree)
      (display ")")
      (newline)
      (call-with-output-string
       (lambda (port)
	 (output-tree-to-port tree port))))
  
    (let ((report (hash-ref *gnc:_report-info_* report-name)))
      (if report
	  (let* ((renderer (gnc:report-renderer report))
		 (lines    (renderer options))
		 (output   (report-output->string lines)))
	    output)
	  #f)))

(define (gnc:report-menu-setup win)
  (define menu (gnc:make-menu "_Reports" (list "_Accounts")))
  (define menu-namer (gnc:new-menu-namer))

  (define (add-report-menu-item name report)
    (let* ((report-string "Report")
           (title (string-append (gnc:_ report-string) ": " (gnc:_ name)))
           (item #f))

      (if (gnc:debugging?)
          (let ((options (false-if-exception (gnc:report-new-options report))))
            (if options
                (gnc:options-register-translatable-strings options))
            (gnc:register-translatable-strings report-string name)))

      (set! item
            (gnc:make-menu-item
             ((menu-namer 'add-name) name)
             (string-append "Display the " name " report.")
             (list "_Reports" "")
             (lambda ()
               (let ((options (false-if-exception
                               (gnc:report-new-options report))))
                 (gnc:report-window title
                                    (lambda () (gnc:run-report name options))
                                    options)))))
      (gnc:add-extension item)))

  (gnc:add-extension menu)

  (hash-for-each add-report-menu-item *gnc:_report-info_*))

(define report-record-structure
  (make-record-type "report-record-structure"
                    ; The data items in a report record
                    '(version name options-generator renderer)))

(define (gnc:define-report . args) 
  ;; For now the version is ignored, but in the future it'll let us
  ;; change behaviors without breaking older reports.
  ;;
  ;; The renderer should be a function that accepts one argument,
  ;; a set of options, and generates the report.
  ;;
  ;; This code must return as its final value a collection of strings in
  ;; the form of a list of elements where each element (recursively) is
  ;; either a string, or a list containing nothing more than strings and
  ;; lists of strings.  Any null lists will be ignored.  The final html
  ;; output will be produced by an in-order traversal of the tree
  ;; represented by the list.  i.e. ("a" (("b" "c") "d") "e") produces
  ;; "abcde" in the output.
  ;;
  ;; For those who speak BNF-ish the output should look like
  ;;
  ;; report -> string-list
  ;; string-list -> ( items ) | ()
  ;; items -> item items | item
  ;; item -> string | string-list
  ;; 
  ;; Valid examples:
  ;;
  ;; ("<html>" "</html>")
  ;; ("<html>" " some text " "</html>")
  ;; ("<html>" ("some" ("other" " text")) "</html>")

  (define (blank-report)
    ;; Number of #f's == Number of data members
    ((record-constructor report-record-structure) #f #f #f #f))

  (define (args-to-defn in-report-rec args)
    (let ((report-rec (if in-report-rec
                          in-report-rec
                          (blank-report))))
     (if (null? args)
         in-report-rec
         (let ((id (car args))
               (value (cadr args))
               (remainder (cddr args)))
           ((record-modifier report-record-structure id) report-rec value)
           (args-to-defn report-rec remainder)))))

  (let ((report-rec (args-to-defn #f args)))
    (if (and report-rec
             (gnc:report-name report-rec))
        (hash-set! *gnc:_report-info_*
                   (gnc:report-name report-rec) report-rec)
        (gnc:warn "gnc:define-report: bad report"))))

(define gnc:report-version
  (record-accessor report-record-structure 'version))
(define gnc:report-name
  (record-accessor report-record-structure 'name))
(define gnc:report-options-generator
  (record-accessor report-record-structure 'options-generator))
(define gnc:report-renderer
  (record-accessor report-record-structure 'renderer))

(define (gnc:report-new-options report)
  (let ((generator (gnc:report-options-generator report)))
    (if (procedure? generator)
        (generator)
        #f)))

(gnc:hook-add-dangler gnc:*main-window-opened-hook* gnc:report-menu-setup)

2.  html-generator.scm
;; html-generator.scm -- HTML Support functions 
;; Bryan Larsen (blarsen@ada-works.com) with help from
;; pretty much everybody involved with reports.
;;
;; 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

(gnc:support "html-generator.scm")
 
;; How this mechanism works:
;;
;; To do a report, first collect all of your results into a list.
;; Each item in the list corresponds to one entry.  One entry may
;; correspond to more than one line in the report, though.
;; 
;; Assemble a list of report-spec-structure's.  Each entry in the
;; report-spec-structure corresponds to one column in the HTML report.
;; Perhaps the most important parameter in the structure is
;; get-value-proc, which extracts the value to print in the column
;; from the entry.
;;
;; If total-proc and total-html-proc are defined, the column is totalled.
;;
;; Subentries are handled several different ways, depending on what
;; function is used to convert the results into an html table.  If
;; subs-list-proc and subentry-html-proc are #f, there are no
;; subentries in this column.  
;;
;; Subsections (which are not yet implemented) are defined in the
;; report-sort-spec-structure.  Define subtotal-html-proc to allow
;; this column to be totalled.
;;
;; Note that pretty much every parameter may be set to #f.  For
;; example, to define a "total column", you may wish to add an entry
;; to the spec list that sets html-proc to #f, but sets
;; total-html-proc and subtotal-html-proc.  This way, subtotals really
;; stand out.
;; 
;; report-spec-structure 
;;  header: string describing the column
;;  get-value-proc:  given the entry, finds the value
;;  html-proc: converts the value into html
;;  total-proc:  usually + or #f
;;  subtotal-html-proc: converts the subtotal into html
;;  total-html-proc: converts the total into html
;;  first-last-preference: #t if, for this column, entries should be
;;                         displayed before subentries.  #f is
;;                         subentries before entries.  This parameter
;;                         may be ignored, depending on the report
;;                         style chosen.
;;  subs-list-proc: a procedure that returns a list of subentry values
;;  subentry-html-proc: converts a subentry value into html

(define NBSP "&nbsp;")  ;;; Non-breaking space
;;; <http://www.sightspecific.com/~mosh/WWW_FAQ/nbsp.html>
;;; Primarily "correctly" used in order to put _something_ into an
;;; otherwise blank table cell because some web browsers do not cope
;;; well with truly empty table cells

(define report-spec-structure
  (make-record-type
   "report-spec-structure"
   '(header get-value-proc html-proc total-proc
	    subtotal-html-proc total-html-proc
	    first-last-preference subs-list-proc subentry-html-proc)))

;; The proposed sorting mechanism.  Of course, if you just wanted it
;; sorted, you could sort the list before converting it into HTML.
;; However, by doing it this way, we can divide things into
;; subsections as well.
;;
;; To sort, collect a list of report-sort-spec-structure's.  The first
;; item in the list is the primary sort, and so on down.
;;
;; Optionally, one can divide the report into subsections.  To do so,
;; set the subsection-pred.  subsection-pred returns true if two
;; values are in the same subsection.  All values in the subsection
;; must be adjacent for the sort-pred.  For example, one could sort by
;; date, and then supply a subsection-pred that determines whether two
;; dates are within the same month.
;;
;; report-sort-spec-structure
;;  get-value-proc:  given the entry, finds the value.  Required.
;;  sort-pred:  usually <.  Required.
;;  equal-pred: usually =.  Required.  This is used during sorting for
;;              multi-key sorting.
;;  subsection-pred: often = or #f.  Returns #t if both values are in
;;                   the same subsection
;;  subsection-title-proc: returns the title of the subsection given a
;;                         value.  #f indicates no title.
(define report-sort-spec-structure
  (make-record-type
   "report-sort-spec-structure"
   '(get-value-proc sort-pred equal-pred subsection-pred
		    subsection-title-proc)))

(define make-report-sort-spec
  (record-constructor report-sort-spec-structure))

(define report-sort-spec-get-get-value-proc
  (record-accessor report-sort-spec-structure 'get-value-proc))

(define report-sort-spec-get-sort-pred
  (record-accessor report-sort-spec-structure 'sort-pred))

(define report-sort-spec-get-equal-pred
  (record-accessor report-sort-spec-structure 'equal-pred))

(define report-sort-spec-get-subsection-pred
  (record-accessor report-sort-spec-structure 'subsection-pred))

(define report-sort-spec-get-subsection-title-proc
  (record-accessor report-sort-spec-structure 'subsection-title-proc))

(define report-spec-constructor
  (record-constructor report-spec-structure))

(define (make-report-spec . args)
  (let ((spec (apply report-spec-constructor args)))
    (gnc:register-translatable-strings (report-spec-get-header spec))
    spec))

(define report-spec-get-header
  (record-accessor report-spec-structure 'header))

(define report-spec-get-get-value-proc
  (record-accessor report-spec-structure 'get-value-proc))

(define report-spec-get-html-proc
  (record-accessor report-spec-structure 'html-proc))

(define report-spec-get-total-proc
  (record-accessor report-spec-structure 'total-proc))

(define report-spec-get-subtotal-html-proc
  (record-accessor report-spec-structure 'subtotal-html-proc))

(define report-spec-get-total-html-proc
  (record-accessor report-spec-structure 'total-html-proc))

(define report-spec-get-subs-list-proc
  (record-accessor report-spec-structure 'subs-list-proc))

(define report-spec-get-subentry-html-proc
  (record-accessor report-spec-structure 'subentry-html-proc))

(define report-spec-get-first-last-preference
  (record-accessor report-spec-structure 'first-last-preference))

;; convert a list of entries into html
(define (html-table-render-entries entry-list specs sort-specs
                                   line-render-proc count-subentries-proc)
  (html-table-do-subsection
   (html-table-sort entry-list sort-specs)
   specs sort-specs line-render-proc count-subentries-proc 1))

;; the next 3 functions can be passed to html-table-render-entries

;; convert an entry into html.  subentries follow entries
(define (html-table-entry-render-entries-first line specs
                                               count-subentries-proc)
  (html-table-row-group
   (cons
    (html-table-row-manual (html-table-do-entry line specs))
    (map
     html-table-row-manual
     (html-table-collect-subentries line specs count-subentries-proc)))))

;; convert an entry into html.  first subentry is merged with the entry
(define (html-table-entry-render-subentries-merged line specs
                                                   count-subentries-proc)
  (let ((subs-lines (html-table-collect-subentries line specs
                                                   count-subentries-proc)))
    (html-table-row-group
     (if (null? subs-lines)
	 (html-table-row-manual (html-table-do-entry line specs))
	 (list
	  (html-table-row-manual
	   (map
	    (lambda (entry sub)
	      (if (not sub) entry sub))
	    (html-table-do-entry line specs)
	    (car subs-lines)))
	  (map html-table-row-manual (cdr subs-lines)))))))


;; convert an entry into html.  ignore sub entries
(define (html-table-entry-render-entries-only line specs count-subentries-proc)
  (html-table-row-group
   (html-table-row-manual (html-table-do-entry line specs))))

;; convert totals to html
(define (html-table-totals lst specs)
  (html-table-totals-row
   (map
    (lambda (spec)
      (cond ((report-spec-get-total-html-proc spec)
	     ((report-spec-get-total-html-proc spec)
	      (apply
	       (report-spec-get-total-proc spec)
	       (map (report-spec-get-get-value-proc spec) lst))))
	    (else #f)))
    specs)))

;; convert headers to html
(define (html-table-headers specs)
  (html-table-headers-row
   (map
    (lambda (spec) 
      (html-header-cell 
       (gnc:_ (report-spec-get-header spec))))
    specs)))

;;;;;;;;;;;;;;;;
;; the rest are just helper functions

;; convert subtotals to html
(define (html-table-subtotals lst sort-spec specs depth)
  (html-table-subtotals-row
   depth
   (map
    (lambda (spec)
      (cond ((report-spec-get-subtotal-html-proc spec)
	     ((report-spec-get-subtotal-html-proc spec)
	      (apply
	       (report-spec-get-total-proc spec)
	       (map (report-spec-get-get-value-proc spec) lst))))
	    (else #f)))
    specs)))


(define (html-table-sort lst sort-specs)
  (sort lst (html-table-make-sort-pred sort-specs)))

(define (html-table-do-subsection lst specs sort-specs line-render-proc
                                  count-subentries-proc depth)
  (cond
   ((null? sort-specs)
    (map 
     (lambda (line) (line-render-proc line specs count-subentries-proc))
     lst))
   (else
    (let loop ((lst2 lst))
      (cond 
       ((null? lst2) '())
       (else
	(let* ((front '())
	       (back '())
	       (sort-spec (car sort-specs))
	       (subsection-pred (report-sort-spec-get-subsection-pred
                                 sort-spec))
	       (get-value-proc (report-sort-spec-get-get-value-proc sort-spec))
	       (value1 (get-value-proc (car lst2))))
	  (cond 
	   (subsection-pred
	    (set! front
		  (remove-if-not
		   (lambda (line)
		     (subsection-pred value1 (get-value-proc line)))
		   lst2))
	    (set! back (set-difference lst2 front)))
	   (else
	    (set! front lst2)
	    (set! back '())))
	  (list
	   (cond ((report-sort-spec-get-subsection-title-proc sort-spec)
		  (html-table-subsection-title 
		   ((report-sort-spec-get-subsection-title-proc sort-spec)
		    (get-value-proc (car front)))
		   depth))
		 (else '()))
	   (html-table-do-subsection 
	    front specs (cdr sort-specs) line-render-proc
            count-subentries-proc (+ depth 1))
	   (cond (subsection-pred
		  (html-table-subtotals front sort-spec specs depth))
		 (else '()))
	   (loop back)))))))))
	    
     
	   
(define (html-table-make-sort-pred sort-specs)
  (lambda (entry1 entry2)
    (let loop ((specs sort-specs))
      (cond ((null? specs) #f)
	    (else
	     (let* ((spec (car specs))
		    (gv-proc (report-sort-spec-get-get-value-proc spec))
		    (value1 (gv-proc entry1))
		    (value2 (gv-proc entry2)))
	       (cond (((report-sort-spec-get-sort-pred spec) value1 value2) #t)
		     (((report-sort-spec-get-equal-pred spec) value1 value2)
		      (loop (cdr specs)))
		     (else #f))))))))

;; converts from col order to row order.
;; ex.  ((a b) (c d) (e f)) -> ((a c e) (b d f))
(define (col-list->row-list lst)
  (apply map list lst))

;; converts subentries into html and collects into a list of lists of
;; html cells.
(define (html-table-collect-subentries line specs count-subentries-proc)
  (col-list->row-list
   (map
    (lambda (spec)
      (cond ((report-spec-get-subs-list-proc spec) 
	     (map
	      (report-spec-get-subentry-html-proc spec)
	      ((report-spec-get-subs-list-proc spec) line)))
	    (else (gnc:map-for
		   (lambda (n) #f)
		   0 (count-subentries-proc line) 1))))
    specs)))

;; converts entry into a list of html cells.
(define (html-table-do-entry line specs)
  (map
   (lambda (spec)
     (cond ((and (report-spec-get-get-value-proc spec)
		 (report-spec-get-html-proc spec))
	    ((report-spec-get-html-proc spec)
	     ((report-spec-get-get-value-proc spec) line)))
	   (else #f)))
   specs))

(define (html-table-headers-row headers)
  (list
   "<TR bgcolor=#96b284 cellspacing=10 rules=\"rows\">"
   headers
   "</TR>\n"))

(define (html-table-totals-row cells)
  (list
   "<TR bgcolor=#bfdeba cellspacing=10 rules=\"rows\">"
   (map
    (lambda (cell)
      (cond (cell cell)
	    (else html-blank-cell)))
    cells)
   "</TR>\n"))

(define (html-table-subtotals-row depth cells)
  (list
   "<TR bgcolor=" 
   (number->string (+ #xf6ffdb (* depth #x8)) 16)
   "cellspacing=10 rules=\"rows\">"
   (map
    (lambda (cell)
      (cond (cell cell)
	    (else html-blank-cell)))
    cells)
   "</TR>\n"))
   

(define (html-table-row-manual items)
  (list
   "<TR bgcolor=" html-table-group-color ">"
   (map
    (lambda (cell)
      (cond (cell cell)
	    (else html-blank-cell)))
    items)
   "</TR>\n"))

(define (html-table-subsection-title title depth)
  (list "<TR bgcolor=#"
        (number->string (+ #x96b284 (* depth #x8)) 16)
        "><TH>" title "</TH></TR>"))

;; help! this doesn't work!  I want something to group several rows
;; together so that an "entry" is noticably one unit.
;; netscape & our html widget do not support tbody.
;;(define (html-table-row-group rows)
;;  (list  "</TR><TBODY>" rows  "</TBODY>"))

(define html-table-group-color "#f6ffdb")

(define (html-table-row-group row)
  (set! html-table-group-color 
	(if (string=? html-table-group-color "#f6ffdb")
	    "#ffffff"
	    "#f6ffdb"))
  row)

(define (string-html-strong html)
  (if html 
      (string-append "<STRONG>" html "</STRONG>")
      #f))

(define (html-strong html)
  (if html 
      (list "<STRONG>" html "</STRONG>")
      #f))

(define (html-make-strong proc)
  (lambda (val)
    (html-strong (proc val))))

(define (string-html-ital html)
  (if html
      (string-append  "<i>"  html "</i>")
      #f))

(define (html-ital html)
  (if html
      (list "<I>" html "</I>")
      #f))

(define (html-make-ital proc)
  (lambda (val)
    (html-ital (proc val))))

(define (string-html-currency amount)
  (if amount
      (string-append
       "<font face=\"Courier\""
       (if (< amount 0)
	   (string-append
	    "color=#ff0000>("
	    (gnc:amount->string (- amount) #f #t #f)
	    ")")
	   (string-append
	    ">&nbsp;"
	    (gnc:amount->string amount #f #t #f)
	    "&nbsp;"))
       "</font>")
      #f))

(define (html-font-and-color face color contents)
  (list
   "<font"
   (if face
       (list "face=\"" face "\"")
       #f)
   (if color
       (list "color=#" color)
       #f)
   ">"
   contents
   "</font>"))

(define (html-currency amount)
  (if amount
      (let* 
	  ((neg (< amount 0))
	   (absamt (if neg (- amount) amount))
	   (color (if neg "ff0000" #f))
	   (prefix (if neg "(" NBSP))
	   (suffix (if neg ")" NBSP))
	   (displayamt (gnc:amount->string absamt #f #t #f)))
	
	(html-font-and-color "Courier" color
			     (list prefix displayamt suffix)))
      #f))

(define (html-left-cell item)
  (if item
      (html-table-col-align item #f)
      #f))

(define (html-make-left-cell proc)
  (lambda (val)
    (html-left-cell (proc val))))

(define (html-right-cell item)
  (if item
      (html-table-col-align item "right")
      #f))

(define html-blank-cell
  (list "<TD>" NBSP "</TD>"))

(define (html-make-right-cell proc)
  (lambda (val)
    (html-right-cell (proc val))))

(define (string-html-header-cell item)
  (string-append "<TH justify=left>" item "</TH>"))

(define (html-header-cell item)
  (html-table-headcol-justified item "left"))

(define (html-string string)
  (if string string #f))

(define (html-number format number)
  (if number (sprintf #f format number) #f))

(define (string-html-para text)
  (string-append "<P>" text "</P>\n"))

(define (html-para text)
  (list "<P>" text "</P>\n"))

(define (html-start-document-title title color)
  (list 
   "<HTML>"
   "<HEAD>"
   "<TITLE>" title "</TITLE>"
   "</HEAD>"
   (if color
       (list "<BODY bgcolor=" color ">")
       "<BODY>")))

(define (html-start-document-color color)
  (list
   "<HTML>"
   "<BODY bgcolor=" color ">"))

(define (html-start-document)
  (list 
   "<HTML>"
   "<BODY bgcolor=#99ccff>"))

(define (html-end-document)
  (list
   "</BODY>"
   "</HTML>"))

(define (html-start-table)
  (list "<TABLE>"))  ;; border=2 rules=\"groups\"

(define (html-end-table)
  (list "</table>"))


;;;;;;;;;;;;;;;;;;;;
;; HTML Table
;; This is used by balance-and-pnl.
;;;;;;;;;;;;;;;;;;;;

; Convert to string
(define (tostring val) 
  (if (number? val) 
      (sprintf #f "%.2f" val)
      (call-with-output-string 
       (lambda (p)
	 (display val p)))))

; Create a column entry
(define (html-table-col val)
  (html-table-col-align "right" val))

(define (string-html-table-col-align val align)
  (string-append "<TD align=" align ">" (tostring val) "</TD>"))

(define (html-table-col-align val align)
  (list "<TD"
	(if align
	    (list "align=" align)
	    #f)
	">" 
	(tostring val) "</TD>"))

; Create an html table row from a list of entries
(define (string-html-table-row lst)
  (cond ((string? lst) lst)
	(else
	 (string-append
	  "<TR>"
	  (apply string-append (map html-table-col lst))
	  "</TR>"))))

(define (html-table-row lst)
  (if (string? lst)
      lst
      (list "<TR>"
	    (map html-table-col lst)
	    "</TR>")))

; Create an html table row from a list of entries
(define (string-html-table-row-align lst align-list)
  (cond ((string? lst) lst)
	(else
	 (string-append
	  "<TR>"
	  (apply string-append (map html-table-col-align lst align-list))
	  "</TR>"))))

(define (html-table-row-align lst align-list)
  (if (string? lst) 
      lst
      (list "<TR>"
	    (map html-table-col-align lst align-list)
	    "</TR>")))

; Create an html table from a list of rows, each containing 
;   a list of column entries
(define (string-html-table caption hdrlst llst)
  (string-append
   (html-table-header caption hdrlst)
   (apply string-append (map html-table-row llst))
   (html-table-footer)))

(define (html-table caption hdrlst llst)
  (list
   (html-table-header caption hdrlst)
   (map html-table-row llst)
   (html-table-footer)))

(define (string-html-table-headcol val)
  (string-append "<TH justify=center>" (tostring val) "</TH>"))

(define (html-table-headcol-justified val justification)
  (list "<TH"
	(if justification
	    (list "justify=" justification)
	    #f)
	">"
	(tostring val)
	"</TH">))

(define (html-table-headcol val)
  (html-table-headcol-justified val "center"))

(define (string-html-table-header caption vec)
   (apply string-append
          "<TABLE cellspacing=10 rules=\"rows\">\n"
          (if caption
              (string-append "<caption><b>" caption "</b></caption>")
              "")
          (map html-table-headcol vec)))

(define (html-table-header caption vec)
   (list
    "<TABLE cellspacing=10 rules=\"rows\">\n"
    (if caption
	(list "<caption><b>" caption "</b></caption>")
	"")
    (map html-table-headcol vec)))

(define (html-table-footer)
  "</TABLE>")

3.  balance-and-pnl.scm

;; -*-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 "html-generator.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)))
  
  (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:*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-date-option
      "Report Options" "From"
      "a" "Start of reporting period"
      (lambda ()
        (let ((bdtime (localtime (current-time))))
          (set-tm:sec bdtime 0)
          (set-tm:min bdtime 0)
          (set-tm:hour bdtime 0)
          (set-tm:mday bdtime 1)
          (set-tm:mon bdtime 0)
          (let ((time (car (mktime bdtime))))
            (cons time 0))))
      #f)) 

    (gnc:register-pnl-option
     (gnc:make-date-option
      "Report Options" "To"
      "b" "End of reporting period"
      (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:*pnl-report-options*)

  (define (render-level-2-account level-2-account l2-value)
    (let ((account-name (list NBSP NBSP NBSP NBSP 
					(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"))))

  (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 NBSP 
             (gnc:amount->formatted-string l1-value #f)
	     NBSP NBSP)
       (list "left" "center" "right" "right" "right" "right"))))

  (define (render-total l0-value)
    (html-table-row-align
     (list (html-strong (string-db 'lookup 'net))
           NBSP NBSP 
           (gnc:amount->formatted-string l0-value #f)
	   NBSP NBSP 
	   )
     (list "left" "center" "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* ((from-option (gnc:lookup-option options "Report Options" "From"))
           (from-value (if from-option (gnc:option-value from-option) #f))
           (to-value (gnc:timepair-end-day-time
                      (gnc:option-value
                       (gnc:lookup-option options "Report Options" "To")))))

      (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)
                (l1-collector 'add (l2-collector 'total #f))
                (l0-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)))
	   (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)))))
	      (l2-collector 'add (balance 'total #f))
              (render-level-2-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)
      (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)))))

      (list
       "<html>"
       "<head>"
       "<title>" report-name "</title>"
       "</head>"

       (if balance-sheet?
           "<body bgcolor=#fffde6>"
           "<body bgcolor=#f6ffdb>")

       "<table cellpadding=1>"
       "<caption><b>" report-name "</b></caption>"
       "<tr>"
       "<th>" (string-db 'lookup 'account-name) "</th>"
       "<th align=center>" (string-db 'lookup 'type)  "</th>"
       "<th align=right>" (string-db 'lookup 'subaccounts) "</th>"
       "<th align=right>" (string-db 'lookup 'balance) "</th>"
       "</tr>"

       output

       "</table>"
       "</body>"
       "</html>"))))

  (string-db 'store 'net "Net")
  (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 "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 "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))))


--
cbbrowne@hex.net - <http://www.hex.net/~cbbrowne/linux.html>
"I don't well know whether to go back and strike him, or--what's
that?--down here on my knees and pray for him?  Yes, that was the
thought coming up in me; but it would be the first time I ever *did*
pray.  It's queer; very queer [...]" -- Moby Dick, Ch 29