home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Tools⁄Additions / MacScheme20 / Mathlib / lagrange.scm < prev    next >
Encoding:
Text File  |  1989-04-27  |  2.2 KB  |  62 lines  |  [TEXT/????]
  1. ;;; $Header: lagrange.scm,v 1.2 87/08/28 00:53:44 GMT gjs Exp $
  2. ;;;;                       LAGRANGE.SCM
  3. ;;; produces an interpolation polynomial expression for a given
  4. ;;; set of values at a given set of points.
  5. ;;;             (lagrange ys xs) |--> (lambda (t) ...)
  6. ;;;    For example, if we do:
  7. ;;; (define xs '(.1 .2 .3 .4 .5 .6))
  8. ;;; (define bar (lagrange (map sin xs) xs))
  9. ;;; (define foo (lambda->procedure bar))
  10. ;;; Then BAR is a lambda-expression, and FOO is the procedure that 
  11. ;;; evaluates the polynomial interpolating SIN at the given points.
  12. ;;; 
  13.  
  14. (if-mit
  15.  (declare (usual-integrations = + - * /
  16.                  zero? 1+ -1+
  17.                  ;; truncate round floor ceiling
  18.                  sqrt exp log sin cos)))
  19.  
  20. ;;; Needs: ALGCON.SCM (for algebraic constructors)
  21. ;;;        COMCON.SCM (for LAMBDAFY, LETIFY utilities)
  22.  
  23. (define lagrange
  24.   (lambda (ys xs)
  25.       (lambdafy 1
  26.         (lambda (bvl)
  27.           (let ((var (car bvl)))
  28.             (letify (map (lambda (x) (make-diff var x)) xs)
  29.               (lambda (diffs)
  30.                 (triangle-iterate xs ys
  31.                   (make-linear-interpolator (table-of eqv? xs diffs))))))))))
  32.  
  33. (define triangle-iterate
  34.   (lambda (xs v f)                        ;(f x0 x1 v0 v1)
  35.     (define (all-except-ends l)
  36.       (reverse (cdr (reverse (cdr l)))))
  37.     (define map-consec-pairs
  38.       (lambda (x0s x1s vs)
  39.         (if (null? x1s)
  40.             '()
  41.             (cons (f (car x0s) (car x1s) (car vs) (cadr vs))
  42.                   (map-consec-pairs (cdr x0s) (cdr x1s) (cdr vs))))))
  43.     (let level ((x1s (cdr xs)) (vs v))
  44.       (if (null? (cdr vs))
  45.           (car vs)
  46.           (let ((nvs (map-consec-pairs xs x1s vs)))
  47.             (if (null? (cdr nvs))
  48.                 (car nvs)
  49.                 (letify (all-except-ends nvs)
  50.                         (lambda (names)
  51.                           (level (cdr x1s)
  52.                                  (append (list (car nvs))
  53.                                          names
  54.                                          (last-pair nvs)))))))))))
  55.  
  56. (define make-linear-interpolator
  57.   (lambda (lookup)
  58.     (lambda (x0 x1 v0 v1)
  59.       (make-quo (make-diff (make-prod v1 (lookup x0))
  60.                            (make-prod v0 (lookup x1)))
  61.                 (make-diff x1 x0)))))
  62.