On Sun, 05 Mar 2000 04:19:14 CST, the world broke into rejoicing as
Bryan Larsen <[EMAIL PROTECTED]> said:
> my "learn scheme" project was to support multi-splits on the account
> transactions report.
>
> I'm not sending it out as a patch because I have a bunch of budget crap
> littering the file as well.
>
> as this is my first scheme code, if you scheme experts could comment, that
> would be appreciated.
>
> for src/scm/report/transaction-report.scm
> et voila,
Not bad; I suggest couple of refinements, involving adding some useful
abstractions that essentially pull out the HTML dependancy.
a) By creating a debit/credit "collector," lots of set! instances get
to go away, and you don't have to track "inflow" and "outflow."
This isn't shorter the *first* time it gets used, but as soon as you
need to have multiple collectors, this gets worthwhile.
A later extension to this would be to pass in not merely the value,
but a tuple of value, line number, and field number. That would allow
the collector to support generating FORMULAE for totals, which would
be useful when generating a spreadsheet.
(define (makedrcr-collector)
(let
((debits 0)
(credits 0)
(totalitems 0))
(let
((adder (lambda (amount)
(if (> 0 amount)
(set! credits (- credits amount))
(set! debits (+ debits amount)))
(set! totalitems (+ 1 totalitems))))
(getdebits (lambda () debits))
(getcredits (lambda () credits))
(setdebits (lambda (amount)
(set! debits amount)))
(getitems (lambda () totalitems))
(reset-all (lambda ()
(set! credits 0)
(set! debits 0)
(set! totalitems 0))))
(lambda (action value)
(case action
('add (adder value))
('debits (getdebits))
('credits (getcredits))
('items (getitems))
('reset (reset-all)))))))
b) Generate HTML in an automated manner, rather than by hand:
;;; This generates a cell, with several bits of special behaviour
(define (make-html-cell header? item)
(let ((pre (cond
(header? "<TH justify=center>")
((number? item) "<TD ALIGN=RIGHT>")
(else "<TD>")))
(post (if header? "</TH>""</TD>")))
(sprintf #f
(string-append
pre
(cond
((string? item) item)
((number? item) (sprintf #f "%.2f" item))
(else ""))
post))))
;;; Add in wrappers for header vs body for natural use with
;;; map
(define (make-html-cell-header item)
(make-html-cell #t item))
(define (make-html-cell-body item)
(make-html-cell #f item))
;;; Add an HTML cell to a string
(define (add-html-cell header? cline item)
(string-append cline (make-html-cell header? item)))
;;; Better: Create a whole row of a table at one fell swoop
;;; by passing in all the cells at once.
(define (html-table-row header? . items)
(let loop
((cline "<TR>")
(ilist items))
(if (pair? ilist)
(loop (add-html-cell header? cline (car ilist))
(cdr ilist))
(string-append cline "</TR>"))))
;;; the above function is a sample of looping via "named let," which is
;;; one of the nicest ways of managing loops...
Thus, the "big function" turns into this:
(define rptdrcrs (makedrcr-collector)) ;;; Collector for this report
(define (gnc:tr-report-split-to-html split-scm
starting-balance)
(let
((other-splits (gnc:tr-report-get-other-splits split-scm))
(report-string ""))
;;; The collector makes this nigh unto disappear...
(rptdrcrs 'add ((gnc:tr-report-get-value split-scm)))
(for-each
(lambda (split-sub first last)
(set! report-string
(string-append
report-string
;;; Make HTML coding disappear...
(html-table-row #f
(if first (gnc:timepair-to-datestring
(gnc:tr-report-get-date split-scm)) "")
(if first (gnc:tr-report-get-num split-scm) "")
(if first (gnc:tr-report-get-description split-scm) "")
(if first (gnc:tr-report-get-memo split-scm) "")
(car split-sub)
;;; Watch a *barrel* of code disappear...
(abs (cadr split-sub))
(if last
(- (+ starting-balance
(rptdrcrs 'debits #f))
(rptdrcrs 'credits #f))
"")))))
other-splits
(append (list #t) (make-list (- (length other-splits) 1) #f))
(append (make-list (- (length other-splits) 1) #f) (list #t)))))
;;; The four recurrences of
; (if first (gnc:some-function split-scm) "")
; is suggestive that there May Be A Better Way; I don't think
; that can be made *much* better without resorting to macros, and
; we Don't Want To Go There Now...
Note: I've spent some time Messing Seriously With Reports, and haven't
yet checked anything in. I suspect that what I should do is to check
in the utility functions that have fallen out of it, and drop the
reports proper, to redo the work once some further code gets checked
in.
To that end, here is, pretty raw, what I've added as new files, for:
- rptutils.scm - Some utility functions used in multiple reports
- htmlgen.scm - HTML table generation functions
- xmlgen.scm - A generalized XML generator function set
- gnm.scm - Uses xmlgen.scm to build a GNumeric spreadsheet
;;; $ID$
;;; Reporting utilities
(gnc:support "rptutils.scm")
(define (gnc:filter-list the-list predicate)
(cond ((not (list? the-list))
(gnc:error("Attempted to filter a non-list object")))
((null? the-list) '())
((predicate (car the-list))
(cons (car the-list)
(gnc:filter-list (cdr the-list) predicate)))
(else (gnc:filter-list (cdr the-list) predicate))))
;; like map, but restricted to one dimension, and
;; guaranteed to have inorder semantics.
(define (gnc:inorder-map the-list fn)
(cond ((not (list? the-list))
(gnc:error("Attempted to map a non-list object")))
((not (procedure? fn))
(gnc:error("Attempted to map a non-function object to a list")))
((eq? the-list '()) '())
(else (cons (fn (car the-list))
(gnc:inorder-map (cdr the-list) fn)))))
(define (gnc:for-loop thunk first last step)
(cond ((< first last) (thunk first)
(gnc:for-loop thunk (+ first step) last step))
(else #f)))
;;; applies thunk to each split in account account
(define (gnc:for-each-split-in-account account thunk)
(gnc:for-loop (lambda (x) (thunk (gnc:account-get-split account x)))
0 (gnc:account-get-split-count account) 1))
(define (gnc:group-map-accounts thunk group)
(let loop
((num-accounts (gnc:group-get-num-accounts group))
(i 0))
(if (= i num-accounts)
'()
(cons (thunk (gnc:group-get-account group i))
(loop num-accounts (+ i 1))))))
; (define (gnc:account-transactions-for-each thunk account)
; ;; You must call gnc:group-reset-write-flags on the account group
; ;; before using this...
; (let loop ((num-splits (gnc:account-get-split-count account))
; (i 0))
; (if (< i num-splits)
; (let* ((split (gnc:account-get-split account i))
; (transaction (gnc:split-get-parent split)))
; ;; We don't use the flags just like FileIO does (only 1 pass here)...
; (if (= (gnc:transaction-get-write-flag transaction) 0)
; (begin
; (thunk transaction)
; (gnc:transaction-set-write-flag transaction 2)))
; (loop num-splits (+ i 1))))))
(define (gnc:transaction-map-splits thunk transaction)
(let loop ((num-splits (gnc:transaction-get-split-count transaction))
(i 0))
(if (< i num-splits)
(cons
(thunk (gnc:transaction-get-split transaction i))
(loop num-splits (+ i 1)))
'())))
(define (makedrcr-collector)
(let
((debits 0)
(credits 0)
(totalitems 0))
(let
((adder (lambda (amount)
(if (> 0 amount)
(set! credits (- credits amount))
(set! debits (+ debits amount)))
(set! totalitems (+ 1 totalitems))))
(getdebits (lambda () debits))
(getcredits (lambda () credits))
(setdebits (lambda (amount)
(set! debits amount)))
(getitems (lambda () totalitems))
(reset-all (lambda ()
(set! credits 0)
(set! debits 0)
(set! totalitems 0))))
(lambda (action value)
(case action
('add (adder value))
('debits (getdebits))
('credits (getcredits))
('items (getitems))
('reset (reset-all)))))))
;; Add x to list lst if it is not already in there
(define (addunique lst x)
(if (null? lst)
(list x) ; all checked add it
(if (equal? x (car lst))
lst ; found, quit search and don't add again
(cons (car lst) (addunique (cdr lst) x))))) ; keep searching
;;;; $Id: htmlgen.scm,v 1.1 2000/02/29 04:08:14 cbbrowne Exp cbbrowne $
;;;; HTML Support functions
(gnc:support "htmlgen.scm")
(define (html-table-row header? . items)
(let loop
((cline "<TR>")
(ilist items))
(if (pair? ilist)
(loop (add-html-cell header? cline (car ilist))
(cdr ilist))
(string-append cline "</TR>"))))
(define (html-strong cell)
(string-append
"<STRONG>"
cell
"</STRONG>"))
(define (add-html-cell header? cline item)
(string-append cline (make-html-cell header? item)))
(define (make-html-cell header? item)
(let ((pre ;;; Opening tag
(cond
(header? "<TH justify=center>")
((number? item) "<TD ALIGN=RIGHT>")
(else "<TD>")))
(post ;;; Closing tag
(if header? "</TH>" "</TD>")))
(sprintf #f
(string-append
pre ;;; Start with opening tag
(cond ;;; Body
((string? item) item)
((number? item) (sprintf #f "%.2f" item))
(else ""))
post)))) ;;; closing tag
(define (make-html-cell-header item)
(make-html-cell #t item))
(define (make-html-cell-body item)
(make-html-cell #f item))
;;;;;;;;;;;;;
;;;; $Id: xmlgen.scm,v 1.1 2000/02/29 04:08:14 cbbrowne Exp cbbrowne $
;;;;;;;;;;;;; Generating XML out of Scheme Lists
(gnc:support "xmlgen.scm")
;;;;;;;;;;;;;
;;;; by Christopher Browne
;;;; <[EMAIL PROTECTED]>, <[EMAIL PROTECTED]>
;;;;
;;;; This was created for GnuCash to assist in creating
;;;; XML output to generate spreadsheets readable by
;;;; Gnumeric.
;;;;
;;;; The model is that an element consists of a list with
;;;; three entries. Elements are created thus:
;;;; (define (make-xml-element tag attributes children)
;;;; (list tag attributes children))
;;;; - The first entry is the tag name.
;;;; - The second entry optionally consists of an association list
;;;; containing the attributes of the element, or is #f.
;;;; - The third entry is either a list of children, or is #f.
;;;;
;;;; Notable idiosyncracies aka "features" aka "misfeatures":
;;;; - All elements may come in the form of symbols, strings, or
;;;; numbers. output-xml-element (and helpers) transform these all
;;;; into strings.
;;;; - It is possible that efficiency could be improved by memoizing
;;;; the strings that get generated. That way, we don't need to
;;;; generate a new string each time a symbol gets hit.
;;;; - The "children" can have three values:
;;;; a) #f, indicating that there are no children, as with:
;;;; (NoEndTag ((Att1 . 1) (Att2 . 2)) #f) which turns into
;;;; <NoEndTag Att1="1" Att2="2"/>
;;;; b) It may be a simple attribute, like "Contents" or 1.5, as
;;;; with (SimpleEndTag #f "Contents") which transforms to:
;;;; <SimpleEndTag>Contents</SimpleEndTag>
;;;; c) Otherwise, it must consist of a list of elements, thusly:
;;;; (Parent #f ((Child #f Value1) (Child #f Value2)) which turns
;;;; to: <Parent> <Child>Value1</Child> <Child>Value2</Child> </Parent>
;;;;
;;;; Usage
;;;; -------
;;;; The driver of it is (output-xml-element element port).
;;;; One might output an XML document with a root node, ROOT, thus:
;;;;(let ((port (open-output-file "/tmp/sampleoutput")))
;;;; (display "<?xml version=\"1.0\"?>" port)
;;;; (newline port)
;;;; (output-xml-element ROOT port)
;;;; (close-output-port port))
;;;;
;;;; If you have a Very Large Document, you might not want to
;;;; construct the whole document as One Big List;
;;;; output-xml-element will be useful for generating subtree output.
;;;; Your control structure will need to duplicate the structure of
;;;; output-xml-element. Alternatively, it would be a slick idea to
;;;; change output-xml-element so that "children" could be a thunk
;;;; (function with no arguments) that invokes output-xml-element
;;;; internally as needed.
(define xml-indentation 0)
(define (xml-display x port)
(if port
(display x port)
(display x)))
(define (xml-newline port)
(if port
(newline port)
(newline)))
(define (make-tabs port)
(let loop
((i 0))
(if (>= i xml-indentation)
#f
(begin
(xml-display " " port)
(loop (+ i 1)))))
(set! xml-indentation (+ xml-indentation 1)))
(define (output-xml-element-name elname port)
(xml-newline port)
(make-tabs port)
(xml-display
(string-append
"<"
(element-to-string elname))
port))
(define (output-xml-element-name-end elname port)
(set! xml-indentation (- xml-indentation 1))
(xml-display
(string-append
"</"
(element-to-string elname)
">")
port))
(define (output-xml-attribute att port)
; (display "output-xml-attribute: ") (display attribute) (newline)
(xml-display (string-append
" "
(element-to-string (car att))
"=\""
(element-to-string (cdr att))
"\"")
port))
(define (element-to-string obj)
; (display "[element-to-string: ") (display obj) (display "]") (newline)
(cond
((string? obj) obj)
((symbol? obj) (symbol->string obj))
((number? obj) (number->string obj))
(else
(string-append "[ERROR in element-to-string: "
(list->string (list obj))
" not a symbol, string or number.]"))))
(define (output-xml-attributes attributes port)
;(display "output-xml-attributes: ") (display attributes) (newline)
(if attributes
(for-each
(lambda (attribute)
(output-xml-attribute attribute port))
attributes)))
(define (output-xml-children children port)
; (display "[output-xml-children: ") (display children) (display "]")(newline)
(cond
((list? children)
(for-each (lambda (child)
(output-xml-element child port))
children))
(else
(xml-display (element-to-string children) port))))
(define (output-xml-element element port)
(let ((elname (car element))
(attributes (cadr element))
(children (caddr element)))
(output-xml-element-name elname port)
(output-xml-attributes attributes port)
(cond
((not children) ;;; If children is blank
(xml-display "/>" port)) ;;; Short result
((procedure? children) ;;; children is a function
(xml-display ">" port)
(children port) ;;; Invoke the function
(output-xml-element-name-end elname port))
(else
(xml-display ">" port)
(output-xml-children children port)
(output-xml-element-name-end elname port)))))
(define (xml-element tag attributes children)
(list tag attributes children))
(define (xml-attribute name value)
(cons name value))
(define (xml-attributes . alist)
alist)
;;; (if (> 0 (length alist)) ;;; If there's anything in the list
;;; alist ;;; Return the list
;;; #f)) ;;; Otherwise, blank to #f
(define no-attributes
(xml-attributes))
(define no-children
#f)
;;;; $Id$
;;;; gnm.scm - Gnumeric spreadsheet generation functions
(gnc:support "gnm.scm")
(gnc:depend "xmlgen.scm")
;;;; Gnumeric spreadsheet consists of:
;;;; gmr:Workbook
;;;; gmr:Summary Done
;;;; gmr:Geometry Done
;;;; gmr:Sheets
;;;; gmr:Sheet
;;;; gmr:Name - Need the Sheet name
;;;; gmr:MaxCol - omission OK
;;;; gmr:MaxRow - omission OK
;;;; gmr:Zoom - omission OK
;;;; gmr:PrintInformation - omission OK
;;;; gmr:Styles - Ok to omit
;;;; gmr:StyleRegion - optional
;;;; gmr:Style - optional
;;;; gmr:Font - optional
;;;; gmr:StyleBorder - optional
;;;; gmr:Top - optional
;;;; gmr:Bottom - optional
;;;; gmr:Left - optional
;;;; gmr:Right - optional
;;;; gmr:Diagonal - optional
;;;; gmr:Rev-Diagonal - optional
;;;; gmr:Cols - Optional, but should have this one...
;;;; gmr:ColInfo (No Unit MarginA MarginB HardSize Hidden)
;;;; gmr:Rows - Quite Optional
;;;; gmr:RowInfo (No Unit MarginA MarginB HardSize Hidden)
;;;; gmr:Cells - This is the meat of the matter...
;;;; gmr:Cell (Col Row Style)
;;;; gmr:Content
;;; Here's a kludgy function that is intended to compute the number of
;;; days since December 31, 1899. It is only approximate; feel free
;;; to suggest a better function.
;;; The point of this is that Gnumeric uses this as the "native" data
;;; representation.
(define (ymd->number y m d)
(+
1 ;;; Start at 1
(* (- y 1900) 365) ;;; 365 days per year
d ;;; Add the number of days
(vector-ref #(0 31 59 90 120 151 181 212 243 273 304 334)
(- m 1));;; Add in days associated with month
(truncate (/ (- y 1900) 4)) ;;; Add in leap days, valid 'til
;;; year 2100...
(if
(and (= 0 (modulo y 4)) ;;; If a leap year,
(> m 2)) ;;; and month is post-Feb
1 ;;; add an extra day
0)))
;;; gmr:Summary appears to be some metadata about who/what generated
;;; the document.
(define (make-gmr-summary)
(define (make-gmr-item name value)
(xml-element
'gmr:Item no-attributes
(list (xml-element 'gmr:name no-attributes name)
(xml-element 'gmr:val-string no-attributes value))))
(xml-element
'gmr:Summary no-attributes
(list
(make-gmr-item "application"
"gnumeric")
(make-gmr-item "Author"
"GnuCash Generator"))))
;;; This function generates a goodly chunk of the document structure;
;;; gmr:Workbook is the base element for Gnumeric
(define (gnumeric-workbook sheets)
(xml-element
'gmr:Workbook '((xmlns:gmr . "http://www.gnome.org/gnumeric/v2"))
(list
(make-gmr-summary)
(xml-element 'gmr:Geometry '((Width . 912) (Height . 720)) no-children)
(xml-element 'gmr:Sheets no-attributes sheets))))
(define (gnumeric-xml-cell row col contents)
(xml-element
'gmr:Cell
(xml-attributes (xml-attribute 'Col col)
(xml-attribute 'Row row)
(xml-attribute 'Style 0))
(list (xml-element 'gmr:Content no-attributes contents))))
;;; Generate a set of style regions for a given Sheet
;;; This ought also to support the notion of named styles, but that
;;; can wait
(define (gnumeric-styles rows colassoc)
(xml-element
'gmr:Styles no-attributes
(map
(lambda (coll)
(let ((col (car coll))
(fmt (cdr coll)))
(gnumeric-style-column rows col fmt)))
colassoc)))
;;; Generate a StyleRegion for the given column
(define (gnumeric-style-column totalrows col format)
(xml-element
'gmr:StyleRegion
(xml-attributes (xml-attribute 'startCol col)
(xml-attribute 'endCol col)
(xml-attribute 'startRow 0)
(xml-attribute 'endRow totalrows))
(list (xml-element 'gmr:Style
(xml-attributes
(xml-attribute 'Format format))
no-children))))
(define (gmr:cell col row cell-value)
(xml-element
'gmr:Cell
(xml-attributes
(xml-attribute 'Col col)
(xml-attribute 'Row row))
cell-value))
;;; Each Sheet requires Cols to define the widths of columns.
;;; Don't omit this.
(define (gnumeric-columns collist)
(xml-element 'gmr:Cols no-attributes
(map (lambda (colassoc)
(xml-element 'gmr:ColInfo colassoc no-children))
collist)))
;;; And here's a function that generates a whole Sheet.
;;; It forces in style info; that's probably not the best thing to do.
(define (gnumeric-sheet name rows cols cells)
(let ((namelst (xml-element 'gmr:Name no-attributes name))
(stylelst (gnumeric-styles
rows our-style-list))
(celllst (xml-element 'gmr:Cells no-attributes cells)))
(xml-element 'gmr:Sheet no-attributes
(list
namelst
cols
stylelst
celllst))))
;;; Define some wild accounting-oriented display formats
(define our-style-list
(let ((acctgstyle "_($*#,##0.00_);_($(#,##0.00);_($*"-"??_);(@_)")
(coloredstyle "$0.00_);[Red]($0.00)"))
(list (cons 0 "yyyy-mm-dd")
(cons 2 acctgstyle)
(cons 3 coloredstyle))))
(define (gen-cells-for-txn txn row)
(display txn) (newline)
(apply
(lambda (y m d descr amt)
(list
(gmr:cell 0 row (ymd->number y m d))
(gmr:cell 1 row descr)
(gmr:cell 2 row amt)
(gmr:cell 3 row (string-append "=D" (number->string row)
"+C"
(number->string (+ row 1))))))
txn))
(define (sample-cells)
(let loop
((txns
(sort
(append
'((1998 12 31 "Opening Balance" 0))
(map (lambda (x) (list 1999 x 1 "Rent" -500))
'(1 2 3 4 5 6 7 8 9 10 11 12))
(map (lambda (x) (list 1999 x 1 "Salary" 1200))
'(1 2 3 4 5 6 7 8 9 10 11 12))
(map (lambda (x) (list 1999 x 15 "Salary" 1200))
'(1 2 3 4 5 6 7 8 9 10 11 12))
(map (lambda (x) (list 1999 x 12 "Phone" -35))
'(1 2 3 4 5 6 7 8 9 10 11 12)))
(lambda (lst1 lst2)
(if (= (car lst1) (car lst2))
(if (= (cadr lst1) (cadr lst2))
(if (= (caddr lst1) (caddr lst2))
(if (string=? (cadddr lst1) (cadddr lst2))
#t
(string<? (cadddr lst1) (cadddr lst2)))
(< (caddr lst1) (caddr lst2)))
(< (cadr lst1) (cadr lst2)))
(< (car lst1) (car lst2))))))
(row 1)
(cells '()))
(if (null? txns)
cells
(loop (cdr txns)
(+ row 1)
(let* ((txn (car txns)))
(append cells (gen-cells-for-txn txn row)))))))
(define (build-full-sample)
(let*
((cells (sample-cells))
(cols 4)
(collist '(((No . 0) (Unit . 85))
((No . 1) (Unit . 150))
((No . 2) (Unit . 75))
((No . 3) (Unit . 75))))
(rows (/ (length cells) cols))
(cols (gnumeric-columns collist))
(sheet (gnumeric-sheet "Sample" rows cols cells))
(sheets (list sheet)))
(gnumeric-workbook sheets)))
;;; This function generates a whole whack of cells and formulae
(define (generate-sampl filename)
(let ((p (open-output-file filename))
(ss (build-full-sample)))
(display "<?xml version=\"1.0\"?>" p)
(output-xml-element ss p)
(close-output-port p)))
--
Zaphod's just zis guy, you know?
[EMAIL PROTECTED] - <http://www.hex.net/~cbbrowne/lsf.html>
--
Gnucash Developer's List
To unsubscribe send empty email to: [EMAIL PROTECTED]
