231 lines
6.2 KiB
Scheme
231 lines
6.2 KiB
Scheme
; Time-stamp: <98/05/08 22:29:05 shriram>
|
|
|
|
; * Need to make write-holdings-to-file set permissions appropriately.
|
|
; * add-{stock,fund} should check if the entry already exists.
|
|
; * Allow update of holdings.
|
|
; * Print numbers in columns.
|
|
; * Improve output quality and media.
|
|
; * Enable queries on individual holdings.
|
|
|
|
;; Format of RC file:
|
|
;; current-seconds (when file was last written)
|
|
;; ((entity quantity price) ...)
|
|
;; <eof>
|
|
;; where entity = (stock "...") or (fund "...")
|
|
|
|
(require-library "match.ss")
|
|
(require-library "date.ss")
|
|
|
|
(require-library "qq.ss" "quasiquote")
|
|
|
|
(define rc-file "~/.qqrc")
|
|
|
|
;; entity : entity
|
|
;; quantity : num
|
|
;; price : num
|
|
|
|
(define-struct holding (entity quantity price))
|
|
|
|
;; raw-holding->holding :
|
|
;; raw-holding -> holding
|
|
|
|
(define raw-holding->holding
|
|
(lambda (rh)
|
|
(match rh
|
|
((('stock name) quantity price)
|
|
(make-holding (stock name) quantity price))
|
|
((('fund name) quantity price)
|
|
(make-holding (fund name) quantity price))
|
|
(else (error 'qq-client "~s is an invalid entry in the database" rh)))))
|
|
|
|
;; holding->raw-holding :
|
|
;; holding -> raw-holding
|
|
|
|
(define holding->raw-holding
|
|
(lambda (h)
|
|
(list
|
|
(let ((entity (holding-entity h)))
|
|
(cond
|
|
((stock? entity) `(stock ,(entity-name entity)))
|
|
((fund? entity) `(fund ,(entity-name entity)))
|
|
(else
|
|
(error 'qq-client "~s is not a valid entity" entity))))
|
|
(holding-quantity h)
|
|
(holding-price h))))
|
|
|
|
;; write-holdings-to-file :
|
|
;; list (holding) -> ()
|
|
|
|
(define write-holdings-to-file
|
|
(lambda (holdings)
|
|
(let ((p (open-output-file rc-file 'replace)))
|
|
(display "; -*- Scheme -*-" p)
|
|
(newline p) (newline p)
|
|
(display "; Do not edit directly: please use QuasiQuote clients!" p)
|
|
(newline p) (newline p)
|
|
(write (current-seconds) p)
|
|
(newline p) (newline p)
|
|
(write (map holding->raw-holding holdings) p)
|
|
(newline p)
|
|
(close-output-port p))))
|
|
|
|
;; read-holdings-from-file :
|
|
;; () -> (seconds + #f) x list (holding)
|
|
|
|
(define read-holdings-from-file
|
|
(lambda ()
|
|
(with-handlers ((exn:i/o:filesystem? (lambda (exn)
|
|
(values #f null))))
|
|
(let ((p (open-input-file rc-file)))
|
|
(values (read p)
|
|
(map raw-holding->holding
|
|
(read p)))))))
|
|
|
|
;; update-holdings :
|
|
;; list (holding) -> list (holding)
|
|
|
|
(define update-holdings
|
|
(lambda (holdings)
|
|
(map (lambda (h)
|
|
(let ((entity (holding-entity h)))
|
|
(let ((new-value (get-quote entity)))
|
|
(make-holding entity (holding-quantity h) new-value))))
|
|
holdings)))
|
|
|
|
;; changed-positions :
|
|
;; list (holding) x list (holding) ->
|
|
;; list (holding . num) x list (holding . num) x list (holding)
|
|
|
|
(define changed-positions
|
|
(lambda (old-in new-in)
|
|
(let loop ((old old-in) (new new-in)
|
|
(increases null) (decreases null) (stays null))
|
|
(if (and (null? old) (null? new))
|
|
(values increases decreases stays)
|
|
(if (or (null? old) (null? new))
|
|
(error 'qq-client "~s and ~s cannot be compared for changes"
|
|
old-in new-in)
|
|
(let ((first-old (car old)) (first-new (car new)))
|
|
(if (string=? (entity-name (holding-entity first-old))
|
|
(entity-name (holding-entity first-new)))
|
|
(let* ((price-old (holding-price first-old))
|
|
(price-new (holding-price first-new))
|
|
(difference (- price-new price-old)))
|
|
(cond
|
|
((= price-old price-new)
|
|
(loop (cdr old) (cdr new)
|
|
increases
|
|
decreases
|
|
(cons first-new stays)))
|
|
((< price-old price-new)
|
|
(loop (cdr old) (cdr new)
|
|
(cons (cons first-new difference) increases)
|
|
decreases
|
|
stays))
|
|
(else
|
|
(loop (cdr old) (cdr new)
|
|
increases
|
|
(cons (cons first-new difference) decreases)
|
|
stays))))
|
|
(error 'qq-client "~s and ~s are in the same position"
|
|
first-old first-new))))))))
|
|
|
|
;; total-value :
|
|
;; list (holding) -> num
|
|
|
|
(define total-value
|
|
(lambda (holdings)
|
|
(apply +
|
|
(map (lambda (h)
|
|
(* (holding-quantity h) (holding-price h)))
|
|
holdings))))
|
|
|
|
;; print-position-changes :
|
|
;; list (holding . num) x list (holding . num) x list (holding) -> ()
|
|
|
|
(define print-position-changes
|
|
(lambda (increases decreases stays)
|
|
(define print-entry/change
|
|
(lambda (holding change)
|
|
(printf "~a ~a ~a~a~n"
|
|
(entity-name (holding-entity holding))
|
|
(holding-price holding)
|
|
(if (> change 0) "+" "-")
|
|
(abs change))))
|
|
(define print-change
|
|
(lambda (banner changes)
|
|
(unless (null? changes)
|
|
(printf "~a:~n" banner))
|
|
(for-each (lambda (h+delta)
|
|
(print-entry/change (car h+delta) (cdr h+delta)))
|
|
changes)
|
|
(newline)))
|
|
(print-change "Increases" increases)
|
|
(print-change "Decreases" decreases)))
|
|
|
|
;; print-statement :
|
|
;; () -> ()
|
|
|
|
(define print-statement
|
|
(lambda ()
|
|
(let-values (((old-time old-holdings)
|
|
(read-holdings-from-file)))
|
|
(let ((new-holdings (update-holdings old-holdings)))
|
|
(when old-time
|
|
(printf "Changes are since ~a~n~n"
|
|
(date->string (seconds->date old-time))))
|
|
(let-values (((increases decreases stays)
|
|
(changed-positions old-holdings new-holdings)))
|
|
(print-position-changes increases decreases stays))
|
|
(let ((old-total (total-value old-holdings))
|
|
(new-total (total-value new-holdings)))
|
|
(printf "Total change: ~a~nTotal value: ~a~n"
|
|
(- new-total old-total) new-total))
|
|
(write-holdings-to-file new-holdings)))))
|
|
|
|
;; create-holding :
|
|
;; (str -> entity) -> str x num -> holding
|
|
|
|
(define create-holding
|
|
(lambda (maker)
|
|
(lambda (name quantity)
|
|
(let ((entity (maker name)))
|
|
(let ((price (get-quote entity)))
|
|
(make-holding entity quantity price))))))
|
|
|
|
;; create-holding/stock :
|
|
;; str x num -> holding
|
|
|
|
(define create-holding/stock
|
|
(create-holding stock))
|
|
|
|
;; create-holding/fund :
|
|
;; str x num -> holding
|
|
|
|
(define create-holding/fund
|
|
(create-holding fund))
|
|
|
|
;; add-holding :
|
|
;; (str x num -> holding) -> x str x num -> ()
|
|
|
|
(define add-holding
|
|
(lambda (maker)
|
|
(lambda (name quantity)
|
|
(let-values (((old-time old-holdings)
|
|
(read-holdings-from-file)))
|
|
(write-holdings-to-file
|
|
(cons (maker name quantity)
|
|
old-holdings))))))
|
|
|
|
;; add-stock :
|
|
;; str x num -> ()
|
|
|
|
(define add-stock
|
|
(add-holding create-holding/stock))
|
|
|
|
;; add-fund :
|
|
;; str x num -> ()
|
|
|
|
(define add-fund
|
|
(add-holding create-holding/fund))
|