(module libs mzscheme
  (require (planet "" ("lizorkin" "sxml.plt" 1 4))
           (lib "" "srfi" "1")
           (lib "" "srfi" "19")
           (lib "")
           (planet "" ("dherman" "memoize.plt" 2 1)))
  ;; this provide is way too coarse, but I can't be bothered to fix it.
  (provide (all-defined))

  ;; this explicit init is gross, but fixing it would require going to units.
  (define book-ids #f)
  (define count-data #f)
  (define commodities #f)
  (define accounts #f)
  (define transactions #f)
  (define (init-libs list-of-things)
    (set! book-ids (tag-filter book-id-tag list-of-things))
    (set! count-data (tag-filter count-data-tag list-of-things))
    (set! commodities (tag-filter commodity-tag list-of-things))
    (set! accounts (tag-filter account-tag list-of-things))
    (set! transactions (tag-filter transaction-tag list-of-things)))
  (define book-id-tag (string->symbol ""))
  (define count-data-tag (string->symbol ""))
  (define commodity-tag (string->symbol ""))
  (define pricedb-tag (string->symbol ""))
  (define account-tag (string->symbol ""))
  (define transaction-tag (string->symbol ""))
  (define date-tag '||)
  (define date-posted-tag '||)
  (define account-name-tag '||)
  (define account-parent-tag '||)
  (define account-id-tag '||)
  (define transaction-currency-tag '
  (define splits-tag '||)
  (define split-account-tag '||)
  (define split-value-tag '
  (define dollars
      ( "ISO4217")
      ( "USD")))
  (define (tag-filter tag elts)
    (filter (lambda (elt)
              (eq? (car elt) tag))

  ;; return elt for lists of length one
  (define oo
      ((x) (match x
             [(elt) elt]
             [any #;(error 'oo "zap")
                  (error 'oo "expected list of length one, got: ~v" any)]))
      ((x fail) (match x
             [(elt) elt]
             [any (error 'oo (fail))]))))
  ;; return true for lists of length one or zero
  (define (oof x)
    (match x
      [(elt) elt]
      [() #f]
      [any (error 'oo "expected list of length one or zero, got: ~v" any)]))
  (define (transaction-date transaction) 
    (string->date (oo (sxml:content (oo ((sxpath (list date-posted-tag date-tag)) transaction)))) "~Y-~m-~d ~H:~M:~S ~z"))
  (define (account-name account)
    (match (sxml:content (oo ((sxpath (list account-name-tag)) account)))
      [() #f]
      [(name) name]
      [any (error 'account-parent "expected one or zero names, got: ~v" any)]))
  (define (account-parent account)
    (match ((sxpath (list account-parent-tag)) account)
      [(parent) (oo (sxml:content parent))]
      [() #f]
      [any (error 'account-parent "expected one or zero parents, got: ~v" any)]))
  (define (account-id account)
    (oo (sxml:content (oo ((sxpath (list account-id-tag)) account) 
                          (lambda () (format "account-id-tag not found in: ~v" account))))
        (lambda () (format "content of account-id-tag not found in: ~v" account))))
  (define (transaction-splits t)
    (sxml:content (oo ((sxpath (list splits-tag)) t)
                      (lambda () (format "transaction has no splits: ~v" t)))))
  (define (transaction-currency t)
    (oo ((sxpath (list transaction-currency-tag)) t)))
  (define (split-account s)
    (oo (sxml:content (oo ((sxpath (list split-account-tag)) s)))))
  (define (split-value s)
    (string->number (oo (sxml:content (oo ((sxpath (list split-value-tag)) s))))))
  (define (id->account id)
    (oo (filter (lambda (account) (string=? id (account-id account))) accounts)))
  (define/memo (account-name-path account)
    (reverse (let loop ([account account])
               (let ([maybe-parent (account-parent account)])
                 (cons (account-name account)
                       (if maybe-parent
                           (loop (id->account maybe-parent))
  (define (find-account name-path)
    (oo (filter (lambda (acct) (equal? (account-name-path acct) name-path))
        (lambda () (format "no account named ~v" name-path))))
  (define (find-account/prefix name-path)
    (filter (lambda (acct) (prefix? name-path (account-name-path acct)))
  (define (prefix? a b)
    (match (list a b)
      [(() any) #t]
      [((a . arest) (b . brest)) (and (equal? a b) (prefix? arest brest))]
      [else (#f)]))
  #;(begin (>>> (prefix? `() `()))
  (>>> (prefix? `(a) `(a)))
  (>>> (not (prefix? `(a b) `(a c))))
  (>>> (prefix? `(a b c) `(a b c d))))

  (define (make-date-filter start end)
    (lambda (transaction)
      (let ([ttime (date->time-utc (transaction-date transaction))]
            [stime (date->time-utc start)]
            [etime (date->time-utc end)])
        (and (time<=? stime ttime)
             (time<? ttime etime)))))
  (define (make-year-filter year)
    (make-date-filter (make-srfi:date 0 0 0 0 1 1 year 0)
                      (make-srfi:date 0 0 0 0 1 1 (+ year 1) 0)))
  (define (year->transactions year) (filter (make-year-filter year) transactions))
  ;; find all transactions where at least one split is in the list of account ids and one split is outside the list.
  (define (crossers transactions account-ids)
    (filter (lambda (transaction)
              (let ([split-account-ids (map split-account (sxml:content (transaction-splits transaction)))])
                (and (ormap (lambda (id) (member id account-ids))
                     (ormap (lambda (id) (not (member id account-ids)))
  ;; compute the net of the transaction w.r.t. the given accounts.
  (define (net transaction acct-ids currency)
    (unless (equal? (transaction-currency transaction) currency)
      (error 'net "transaction has wrong currency; expected ~v, got ~v" currency (transaction-currency transaction)))
    (let ([splits (sxml:content (transaction-splits transaction))])
      (fold + 0 (map split-value (filter (lambda (s) (not (member (split-account s) acct-ids))) splits)))))
  ;; returns the splits of the transaction that do not involve the given accounts
  (define (external-splits transaction account-ids)
    (let* ([splits (sxml:content (transaction-splits transaction))])
      (filter (lambda (s) (not (member (split-account s) account-ids))) splits)))
  (define (print-transaction t)
    (printf "~a\n" (date->string (transaction-date t)))
    (unless (equal? (transaction-currency t) dollars)
      (printf "NON-DOLLAR TRANSACTION\n"))
    (for-each print-split (transaction-splits t)))
  (define (print-split s)
    (printf "~v : ~v\n" (account-name-path (id->account (split-account s))) (split-value s)))

  ;; ********
  (define (jan-one year) (make-srfi:date 0 0 0 0 1 1 year 0))
  (define (apr-one year) (make-srfi:date 0 0 0 0 1 4 year 0))
  (define (jul-one year) (make-srfi:date 0 0 0 0 1 7 year 0))
  (define (oct-one year) (make-srfi:date 0 0 0 0 1 10 year 0))

  (define (group-by-account splits)
    (let* ([ht (make-hash-table 'equal)])
      (for-each (lambda (split) 
                  (let ([id (split-account split)])
                    (hash-table-put! ht id (cons split (hash-table-get ht id (lambda () `())))))) 
      (hash-table-map ht list)))
  (define (generate-budget-report grouped)
    (map (match-lambda [(id splits) (list (account-name-path (id->account id)) (apply + (map split-value splits)))]) grouped))

  (define (budget-report s e accounts)
    (generate-budget-report (splits-by-account s e (map account-id accounts))))
  (define (splits-by-account s e acct-ids)
    (let* ([crossers (crossers (filter (make-date-filter s e) transactions) acct-ids)]
           [external-motion (apply append (map (lambda (transaction)
                                                 (external-splits transaction acct-ids))
      (group-by-account external-motion)))
  (define (pair-up a b)
    (let ([ht (make-hash-table 'equal)])
      (for-each (match-lambda [(k v) (hash-table-put! ht k (list v))]) a)
      (for-each (match-lambda [(k v) (hash-table-put! ht k (cons v (hash-table-get ht k (lambda () (list 0)))))]) b)
      (hash-table-map ht (lambda (k v) (match v 
                                         [(a b) (list k b a)]
                                         [(a) (list k a 0)])))))
  (define (expenses-only br)
    (filter (match-lambda [(name a b)
                           (cond [(and (>= a 0) (>= b 0))
                                 [(or (> a 0) (> b 0))
                                  (error 'expenses-only "account ~v has mixed-sign numbers: ~v and ~v" name a b)]
                                 [else #f])])
  (define (print-it a)
    (for-each (match-lambda [(name a b) (printf "~a\t~v\t~v\n" (colonsep name) (digfmt a) (digfmt b))]) a))
  (define (colonsep strlist)
    (apply string-append (cons (car strlist) (map (lambda (x) (string-append ":" x)) (cdr strlist)))))
  (define (digfmt n)
    (/ (* n 100) 100.0))