home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1994 #1 / monster.zip / monster / MAGAZINE / DDJ9309.ZIP / 1993-SEP.ZIP / JACAL.ASC < prev    next >
Text File  |  1993-07-26  |  6KB  |  165 lines
  1. _ALGEBRA AND THE LAMBDA CALCULUS_
  2. by Aubrey Jaffer
  3.  
  4.  
  5. LISTING ONE:
  6.  
  7. ;;; Excerpt from Jacal: Symbolic Mathematics System, written in Scheme.       
  8. ;;; Copyright 1989-1993 Aubrey Jaffer.  See the file "COPYING" in 
  9. ;;; the Jacal distribution for terms applying to this program.
  10.  
  11. ;;;; Variable elimination
  12. (define (poly:elim poleqns vars)
  13.   (cond (math:trace
  14.          (display-diag "eliminating:")
  15.          (newline-diag)
  16.          (write-sexp (math->sexp (map var->expl vars)) *output-grammar*)
  17.          (display-diag " from:")
  18.          (newline-diag)
  19.          (write-sexp (math->sexp (poleqns->licits poleqns)) *output-grammar*)))
  20.   (do ((vs vars (cdr vs)) (polys poleqns) (poly #f))
  21.       ((null? vs)
  22.        (cond (math:trace
  23.               (display-diag "yielding:")
  24.               (newline-diag)
  25.               (write-sexp (math->sexp polys) *output-grammar*)))
  26.        polys)
  27.     (do ((var (car vs))
  28.          (pl polys (if (null? pl) 
  29.                        (math-error "not enough equations" poleqns vars)
  30.                        (cdr pl)))
  31.          (npl '() (cons (car pl) npl)))
  32.         ((poly:find-var? (car pl) var)
  33.          (set! poly (promote var (car pl)))
  34.          (do ((pls (cdr pl) (cdr pls)))
  35.              ((null? pls) (set! polys npl))
  36.            (if (bunch? (car pls)) (math-error "elim bunch?" (car pls)))
  37.            (set! npl (cons (poly:resultant poly (car pls) var)
  38.                            npl))))
  39.       (if (bunch? (car pl)) (math-error "elim bunch?" (car pl))))))
  40.  
  41. (define (infinite-list-of . elts)
  42.   (let ((lst (copy-list elts)))
  43.     (nconc lst lst)))
  44.  
  45. ;;; This tries to solve the equations no matter what is involved.
  46.  
  47. ;;; It will eliminate variables in vectors of equations.
  48. (define (eliminate eqns vars)
  49.   (bunch:norm
  50.    (if (some bunch? eqns)
  51.        (apply map
  52.               (lambda arglist (eliminate arglist vars))
  53.               (map (lambda (x)
  54.                      (if (bunch? x) x (infinite-list-of x)))
  55.                    eqns))
  56.        (poly:elim eqns vars))))
  57.  
  58. (define (elim:test)
  59.   (define a (sexp->var 'A))
  60.   (define x (sexp->var 'X))
  61.   (define y (sexp->var 'Y))
  62.   (test (list (list a 0 0 124 81 11 3 45))
  63.         poly:elim
  64.         (list (list y (list x (list a 0 0 2) (list a 0 1)) 1)
  65.               (list y (list x (list a 5 1) 0 -1) 0 1)
  66.               (list y (list x (list a -1 3) 5) -1))
  67.         (list x y)))
  68.  
  69. (define (bunch:map proc b)
  70.   (cond ((bunch? b) (map (lambda (x) (bunch:map proc x)) b))
  71.         (else (proc b))))
  72. (define (licits:for-each proc b)
  73.   (cond ((bunch? b) (for-each (lambda (x) (licits:for-each proc x)) b))
  74.         ((eqn? b) (proc (eqn->poly b)))
  75.         (else (proc b))))
  76. (define (licits:map proc b)
  77.   (cond ((bunch? b) (map (lambda (x) (licits:map proc x)) b))
  78.         ((eqn? b) (poleqn->licit (proc (eqn->poly b))))
  79.         (else (proc b))))
  80. (define (implicits:map proc b)
  81.   (cond ((bunch? b) (map (lambda (x) (implicits:map proc x)) b))
  82.         ((eqn? b) (poleqn->licit (proc (eqn->poly b))))
  83.         ((expl? b) (proc (expl->impl b)))
  84.         (else (proc b))))
  85.  
  86. ;;; replaces each var in poly with (proc var).
  87. ;;; Used for substitutions in clambda and capply.
  88. (define (poly:do-vars proc poly)
  89.   (if (number? poly) poly
  90.       (univ:demote (cons (proc (car poly))
  91.                          (map (lambda (b) (poly:do-vars proc b))
  92.                               (cdr poly))))))
  93. (define (licits:do-vars proc licit)
  94.   (licits:map (lambda (poly) (poly:do-vars proc poly))
  95.               licit))
  96.  
  97. ;;;; Canonical Lambda
  98. ;;;; This needs to handle algebraic extensions as well.
  99. (define (clambda symlist body)
  100.   (let ((num-new-vars (length (remove-if lambdavar? symlist))))
  101.     (licits:do-vars
  102.  
  103.      (lambda (var)
  104.        (let ((pos (position (var:nodiffs var) symlist)))
  105.          (cond (pos (lambda-var (+ 1 pos) (var:diff-depth var)))
  106.                ((lambdavar? var) (bump-lambda-var var num-new-vars))
  107.                ((lambdavarext? var) (bump-lambda-ext))
  108.                (else var))))
  109.      body)))
  110.  
  111. (define (clambda? cexp)
  112.   (cond ((number? cexp) #f)
  113.         ((matrix? cexp) (some (lambda (row) (some clambda? row)) cexp))
  114.         ((expr? cexp) (poly:find-var-if? cexp lambdavardep?))
  115.         ((eqn? cexp) (poly:find-var-if? (eqn->poly cexp) lambdavardep?))
  116.         (else #f)))
  117.  
  118. ;;;In order to keep the lambda application hygenic (in case a function
  119. ;;;of a function is called), we need to substitute occurences of
  120. ;;;lambda variables in the body with shadowed versions of the
  121. ;;;variables before we eliminate them.  See:
  122. ;;;     Technical Report No. 194
  123. ;;;     Hygenic Macro Expansion
  124. ;;;     E.E.Kohlbecker, D.P.Friedman, M.Fellinson, and B.Duba
  125. ;;;     Indiana University
  126. ;;;     May, 1986
  127.  
  128. ;;;currently capply puts the structure of the clambda inside the
  129. ;;;structure of the arguments.
  130. (define (capply body larglist)
  131.   (let* ((arglist (licits->poleqns larglist))
  132.          (arglist-length (length arglist))
  133.          (svlist '()) (dargs '())
  134.          (sbody
  135.           (licits:do-vars
  136.            (lambda (var)
  137.              (cond
  138.               ((lambdavar? var)
  139.                (let ((lshf (- (min-lambda-position var) arglist-length)))
  140.                  (cond ((< 0 lshf) (bump-lambda-var var (- arglist-length)))
  141.                        (else (set! var (var:shadow var))
  142.                              (set! svlist (adjoin var svlist))
  143.                              var))))
  144.               ((not (lambdavarext? var)) var)
  145.               ;; must be some sort of extension
  146.               ((radicalvar? var) var)))
  147.            body)))
  148.     (set! dargs (diffargs svlist arglist))
  149.     (implicits:map (lambda (p) (eliminate (cons p dargs) svlist)) sbody)))
  150. (define (bump-lambda-var var delta)
  151.   (lambda-var (+ (lambda-position var) delta) (var:diff-depth var)))
  152. (define (diffargs vlist args)
  153.   (map (lambda (var)
  154.          (bunch:map (lambda (e)
  155.                       (univ:demote (cons var (cdr (licit->poleqn e)))))
  156.            (diffarg var args)))
  157.     vlist))
  158.  
  159. (define (diffarg var args)
  160.   (cond ((var:differential? var)
  161.          (total-differential (diffarg (var:undiff var) args)))
  162.         (else (list-ref args (- (lambda-position var) 1)))))
  163.  
  164.  
  165.