diff options
Diffstat (limited to 'dbinterp.scm')
-rw-r--r-- | dbinterp.scm | 42 |
1 files changed, 30 insertions, 12 deletions
diff --git a/dbinterp.scm b/dbinterp.scm index 8ccb1df..2bd4e20 100644 --- a/dbinterp.scm +++ b/dbinterp.scm @@ -17,18 +17,36 @@ ;promotional, or sales literature without prior written consent in ;each case. +(require 'rev4-optional-procedures) ; list-tail + +;;; The procedures returned by MEMOIZE are not reentrant! +(define (dbinterp:memoize proc k) + (define recent (vector->list (make-vector k '(#f)))) + (let ((tailr (list-tail recent (+ -1 k)))) + (lambda args + (define asp (assoc args recent)) + (if asp + (cdr asp) + (let ((val (apply proc args))) + (set-cdr! tailr (list (cons args val))) + (set! tailr (cdr tailr)) + (set! recent (cdr recent)) + val))))) + ;;@ This procedure works only for tables with a single primary key. (define (interpolate-from-table table column) - (define get (table 'get column)) - (define prev (table 'isam-prev)) + (define get (dbinterp:memoize (table 'get column) 3)) + (define prev (dbinterp:memoize (table 'isam-prev) 3)) (define next (table 'isam-next)) - (lambda (x) - (let ((nxt (next x))) - (if nxt (set! nxt (car nxt))) - (let ((prv (prev (or nxt x)))) - (if prv (set! prv (car prv))) - (cond ((not nxt) (get prv)) - ((not prv) (get nxt)) - (else (/ (+ (* (- x prv) (get nxt)) - (* (- nxt x) (get prv))) - (- nxt prv)))))))) + (dbinterp:memoize + (lambda (x) + (let ((nxt (next x))) + (if nxt (set! nxt (car nxt))) + (let ((prv (prev (or nxt x)))) + (if prv (set! prv (car prv))) + (cond ((not nxt) (get prv)) + ((not prv) (get nxt)) + (else (/ (+ (* (- x prv) (get nxt)) + (* (- nxt x) (get prv))) + (- nxt prv))))))) + 3)) |