pricedb.scm

pricedb.scm

(use-modules (srfi srfi-2))
(use-modules (srfi srfi-9))
(use-modules (srfi srfi-26))

(define USD 'USD)
(define GBP 'GBP)
(define CAD 'CAD)
(define EUR 'EUR)

(define-record-type :price
  (make-price date from to ratio)
  price? (date price-date) (from price-from) (to price-to) (ratio price-ratio))

(define pricedb
  (list (make-price 1 USD CAD 11/12)    ;ie 11 USD = 12 CAD
        (make-price 2 USD CAD 11/13)
        (make-price 3 USD CAD 12/13)
        (make-price 4 CAD USD 14/11)
        (make-price 5 USD CAD 12/13)
        (make-price 6 USD CAD 13/12)

        (make-price 1 USD EUR 4/7)
        (make-price 2 USD EUR 5/7)
        (make-price 3 USD EUR 5/6)

        (make-price 5 EUR GBP 9/10)
        (make-price 6 EUR GBP 10/11)

        (make-price 1 GBP CAD 5/4)
        (make-price 2 GBP CAD 6/4)
        (make-price 3 CAD GBP 5/7)      ;tests price inversion
        (make-price 5 GBP CAD 8/6)
        (make-price 6 GBP CAD 9/5)

        (make-price 4 EUR GBP 8/9)      ;** 8 eur = 9 gbp
        (make-price 4 CAD GBP 5/8)
        ))

(define (price-delta p date) (abs (- (price-date p) date)))

(define (get-price from to date)
  (define indirect-matches-from (make-hash-table)) ;matches 'to' commodity
  (define indirect-matches-to (make-hash-table))   ;matches 'from' commodity
  (define direct-ratio #f)                         ;direct price found
  (define direct-score +inf.0)                     ;direct price score (price-date - date)

  (define (process-direct this-price invert?)
    (define this-score (price-delta this-price date))
    (when (< this-score direct-score)
      (set! direct-ratio ((if invert? / identity) (price-ratio this-price)))
      (set! direct-score this-score)))

  (define (process-indirect this-price hash price->common invert?)
    (let* ((this-score (price-delta this-price date))
           (this-ratio ((if invert? / identity) (price-ratio this-price)))
           (prev (hash-ref hash (price->common this-price))))
      (when (or (not prev) (< this-score (car prev)))
        (hash-set! hash (price->common this-price) (cons this-score this-ratio)))))

  (define (get-indirect-ratio return)
    (define best-score +inf.0)
    (define retval #f)
    (define (search-from key from-val)
      (define (found-to to-val)
        (let ((score (+ (car to-val) (car from-val))))
          (cond
           ;;bingo indirect price on exact date. return early.
           ((= score 0) (return (* (cdr to-val) (cdr from-val))))
           ((< score best-score)
            (set! best-score score)
            (set! retval (* (cdr to-val) (cdr from-val)))))))
      (and=> (hash-ref indirect-matches-to key) found-to))
    (hash-for-each search-from indirect-matches-from)
    retval)

  (let lp ((pricedb pricedb))

    (cond
     ((or (zero? direct-score)          ;bingo. exact direct price. return early.
          (null? pricedb))
      (format #t "from ~s to ~s date ~s price ~s\n" from to date
              (or direct-ratio (call/cc get-indirect-ratio))))

     ((and (eq? (price-from (car pricedb)) from) (eq? (price-to (car pricedb)) to))
      (process-direct (car pricedb) #f)
      (lp (cdr pricedb)))

     ((and (eq? (price-from (car pricedb)) to) (eq? (price-to (car pricedb)) from))
      (process-direct (car pricedb) #t)
      (lp (cdr pricedb)))

     ;; the following shortcuts because it looks like direct prices
     ;; exist, so we don't need to bother with indirect comparisons
     (direct-ratio (lp (cdr pricedb)))

     ((eq? (price-from (car pricedb)) from)
      (process-indirect (car pricedb) indirect-matches-from price-to #f)
      (lp (cdr pricedb)))

     ((eq? (price-from (car pricedb)) to)
      (process-indirect (car pricedb) indirect-matches-to price-to #t)
      (lp (cdr pricedb)))

     ((eq? (price-to (car pricedb)) from)
      (process-indirect (car pricedb) indirect-matches-from price-from #t)
      (lp (cdr pricedb)))

     ((eq? (price-to (car pricedb)) to)
      (process-indirect (car pricedb) indirect-matches-to price-from #f)
      (lp (cdr pricedb)))

     (else (lp (cdr pricedb))))))

(get-price USD CAD 4)
(get-price USD EUR 4)
(get-price CAD EUR 4)
(get-price EUR CAD 4)
(get-price CAD GBP 3)

modify - send this-price components as args