home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-387-Vol-3of3.iso
/
j
/
jacal1a0.zip
/
jacal
/
sexp.scm
< prev
next >
Wrap
Text File
|
1992-12-24
|
13KB
|
401 lines
;;; JACAL: Symbolic Mathematics System. -*-scheme-*-
;;; Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.
;;; See the file "COPYING" for terms applying to this program.
;;; our local environments
(define heqput! (hash-associator eq?))
(define heqrem! (hash-remover eq?))
(define hassq (predicate->hash-asso eq?))
(define (defsym sym value)
(heqput! *symdefs* sym value) value)
(define (undefsym sym)
(heqrem! *symdefs* sym)
(var->expl (sexp->var sym)))
(define infodefs (make-hash-table 27))
(define (infodef sym) (let ((p (hassq sym infodefs))) (and p (cdr p))))
(define (defbltn sym val . info)
(var_set-def! (sexp->var sym) val)
(heqput! infodefs sym info)
sym)
;;; hdns here is a list of lexically bound symbols as in lambda or suchthat.
;;; so it is really a list of things not to look up.
(define (symdef-lookup sym hdns)
(cond ((null? hdns)
(let ((p (hassq sym *symdefs*)))
(if p (cdr p) (var->expl (sexp->var sym)))))
((eq? sym (car hdns)) (var->expl (sexp->var sym)))
((symbol? (car hdns)) (symdef-lookup sym (cdr hdns)))
((memq sym (car hdns)) (var->expl (sexp->var sym)))
(else (symdef-lookup sym (cdr hdns)))))
;;;now for the read-eval-print stuff
(define var-news '())
(define (math . batches)
(set-handlers!)
(for-each (lambda (file)
(batch (if (symbol? file) (symbol->string file) file)))
batches)
(display "type ")
(write-sexp '(qed) *input-grammar*)
(display " to return to ")
(display base-language)
(batch1)
(cleanup-handlers!)
base-language)
(define (batch file)
(with-input-from-file file batch1))
(define (batch1)
(do ((math_exit-saved math_exit)
(var-news-saved var-news)
(math_prompt #f))
((call-with-current-continuation
(lambda (math_exit-cnt)
(define obj #f)
(set! math_exit math_exit-cnt)
(newline) ;find unused var
(do () ((not (or (var-tab-lookup newlabelsym var-tab)
(hassq newlabelsym *symdefs*))))
(set! newlabelstr (sect:next-string newlabelstr))
(set! newlabelsym (string->symbol newlabelstr)))
(set! math_prompt (string-append newlabelstr " : "))
(let loop ()
(define echoing (not (eq? (get-grammar 'null) *echo-grammar*)))
(set! var-news '())
(cond (echoing)
(else (display math_prompt)
(force-output)
(lex:bump-column (string-length math_prompt))))
(set! obj (read-sexp *input-grammar*))
(lex:bump-column 0)
(cond ((not obj) (loop))
((eof-object? obj) (math_exit #t))
(else
(write-sexp obj *echo-grammar*)
(if (and (pair? obj) (eq? 'define (car obj)))
(let* ((var (cadr obj)) (val (sexp->math obj)))
(out-new-vars var-news)
(newline)
(cond ((novalue? val)
(sexp->math (list 'define var var))
(math-error "no value to set" (cadr obj)))
(else
(set! % val)
(write-sexp (list 'define var (math->sexp val))
*output-grammar*))))
(let* ((var newlabelsym)
(val (sexp->math (list 'define var obj))))
(out-new-vars var-news)
(newline)
(cond ((novalue? val)
(sexp->math (list 'define var var))
(loop))
(else
(set! % val)
(write-sexp (list 'define var (math->sexp val))
*output-grammar*))))))))
#f))
(set! math_exit math_exit-saved)
(set! var-news var-news-saved)
novalue)))
(define (out-new-vars var-news)
(for-each (lambda (x)
(newline)
(write-sexp (list 'define
(var->sexp x)
(math->sexp (vsubst _@ x (extrule x))))
*output-grammar*))
var-news))
(define (clambda symlist body)
(if (eqn? body) (poly->eqn (clambda1 symlist (eqn->poly body)))
(clambda1 symlist body)))
(define (clambda1 symlist body)
(polys_do-vars
(lambda (var)
(let ((pos (position (var_nodiffs var) symlist)))
(if pos (lambda-var (+ 1 pos) (var_diff-depth var))
var)))
body))
(define (clambda? cexp)
(cond ((number? cexp) #f)
((matrix? cexp) (some (lambda (row) (some clambda? row)) cexp))
((expr? cexp) (poly_find-var-if? cexp lambdavar?))
((eqn? cexp) (poly_find-var-if? (eqn->poly cexp) lambdavar?))
(else #f)))
;;;In order to keep the lambda application hygenic (in case a function
;;;of a function is called), we need to substitute occurences of
;;;lambda variables in the body with shadowed versions of the
;;;variables before we eliminate them. See:
;;; Technical Report No. 194
;;; Hygenic Macro Expansion
;;; E.E.Kohlbecker, D.P.Friedman, M.Fellinson, and B.Duba
;;; Indiana University
;;; May, 1986
;;;currently capply puts the structure of the clambda inside the
;;;structure of the arguments.
(define (capply body arglist)
(set! arglist (licits->poleqns arglist))
(let ((sbody 0) (svlist '()) (dargs '()) (arglist-length (length arglist)))
(set! sbody
(poleqns_do-vars
(lambda (var)
(if (lambdavar? var)
(let ((lshf (- (lambda-position var) arglist-length)))
;(print 'lambda-position (lambda-position var) 'arglist-length arglist-length 'lshf lshf)
(cond ((< 0 lshf) (lambda-var lshf (var_diff-depth var)))
(else (set! var (var_shadow var))
(set! svlist (adjoin var svlist))
var)))
var))
body))
(set! dargs (diffargs svlist arglist))
(set! sbody (bunch_map (lambda (p) (eliminate (cons p dargs) svlist))
sbody))
(if (eqns? body) (polys->eqns sbody) sbody)))
(define (diffargs vlist args)
(map (lambda (var)
(bunch_map (lambda (e)
(univ_demote (cons var (cdr (licit->poleqn e)))))
(diffarg var args)))
vlist))
(define (diffarg var args)
(cond ((var_differential? var)
(total-differential (diffarg (var_undiff var) args)))
(else (list-ref args (- (lambda-position var) 1)))))
;;; _@=fc(_@1) --> _@=fc^^-1(_@1)
(define (fcinverse fc)
(extize (normalize
(vsubst _@1 __@
(vsubst _@ _@1
(vsubst __@ _@ (licit->poleqn fc)))))))
;;; fc(fc(...fc(_@1)))
(define (fcexpt fc pow)
(if (negative? pow)
(fcexpt (fcinverse fc) (- pow))
(ipow-by-squaring fc pow cidentity app*)))
(define (rapply ob . arglist)
(cond ((null? arglist) ob)
((bunch? ob)
(apply rapply
(list-ref ob (+ -1 (plicit->integer (car arglist))))
(cdr arglist)))
(else #f)))
(define (sapply fun args)
(cond ((procedure? fun) (apply fun args))
((clambda? fun)
(cond (math_trace
(newline-diag)
(write-sexp (math->sexp fun) *output-grammar*)
(newline-diag)
(display-diag "applied to:")
(map (lambda (x)
(newline-diag)
(write-sexp (math->sexp x) *output-grammar*))
args)
(newline-diag)
(display-diag "yielding:")
(newline-diag)
(let ((ans (capply fun args)))
(write-sexp (math->sexp ans) *output-grammar*)
(newline-diag)
ans))
(else (capply fun args))))
((rat_number? fun) (eval-error "wrong type to apply: " fun))
(else (apply deferop (math->sexp fun) args))))
(define (app* fun . args) (sapply fun args))
(define (seval f hdns)
(cond ((number? f)
(if (inexact? f) (eval-error "Inexact number to eval: "))
(cond ((integer? f) f)
((rational? f) (make-rat (numerator f) (denominator f)))))
((vector? f) (map (lambda (x) (seval x hdns)) (vector->list f)))
((symbol? f) (symdef-lookup f hdns))
((boolean? f) f)
((null? f) f)
((not (pair? f)) (eval-error "Wrong type to eval: " f))
((eqv? (car f) 'lambda)
(let ((vars (variables
(cond ((symbol? (cadr f)) (list (cadr f)))
((vector? (cadr f)) (vector->list (cadr f)))
((pair? (cadr f)) (cadr f))
(else (eval-error "Bad arglist in lambda: " f))))))
(clambda vars (seval (caddr f) (cons vars hdns)))))
((eqv? (car f) 'suchthat)
(suchthat (sexp->var (cadr f))
(seval (caddr f) (cons (cadr f) hdns))))
((eqv? (car f) 'define)
(cond ((symbol? (cadr f))
(if (eq? (cadr f) (caddr f))
(undefsym (cadr f))
(defsym (cadr f)
(normalize (seval (caddr f) (cons (cadr f) hdns))))))
((eqv? (caadr f) 'rapply)
(defsym (cadadr f)
(rlambda (cddadr f)
(normalize (seval (caddr f)
(cons (cdadr f) hdns))))))
(else ;must be capply
(defsym (caadr f)
(clambda (variables (cdadr f))
(normalize (seval (caddr f)
(cons (cadr f) hdns))))))))
(else
(let ((ff (seval (car f) hdns)))
(sapply (or (and (pair? ff)
(expl? ff)
(equal? (cdr ff) '(0 1))
(not (number? (var_def (car ff))))
(var_def (car ff)))
ff)
(map (lambda (x) (seval x hdns)) (cdr f)))))))
(define (sexp->math f) (seval f '()))
;;; These routines convert LICITs or parts of LICITs to S-EXPRESSIONs
(define (cmprs_+ res)
(cond ((null? (cdr res)) (car res))
((and (pair? (cadr res)) (eq? 'negate (caadr res)))
(cmprs_+ (cons (list '- (car res) (cadadr res)) (cddr res))))
((and (pair? (car res)) (eq? '+ (caar res)))
(if (null? (cddr res)) (nconc (car res) (cdr res))
(cmprs_+ (cons (nconc (car res) (list (cadr res))) (cddr res)))))
((null? (cddr res)) (cons '+ res))
(else (cmprs_+ (cons (list '+ (car res) (cadr res)) (cddr res))))))
(define (cmprs_* mu mex)
(cond ((pair? mu)
(cond ((eq? '* (car mu)) (nconc mu (list mex)))
((eq? 'negate (car mu))
(list 'negate (cmprs_* (cadr mu) mex)))
(else (list '* mu mex))))
((and (number? mu) (negative? mu))
(if (eq? -1 mu)
(list 'negate mex)
(list 'negate (list '* (- mu) mex))))
(else (if (eq? 1 mu) mex (list '* mu mex)))))
(define (cmprs_^ var exp)
(cond ((one? exp) var)
((and (pair? var)
(eq? '^ (car var)))
(list '^
(cadr var)
(if (and (pair? (caddr var))
(eq? '/ (caaddr var))
(one? (cadr (caddr var))))
(list '/ exp (caddr (caddr var)))
(cmprs_* exp (caddr var)))))
(else (list '^ var exp))))
;POLY->SEXP converts a polynomial to SEXPRESSION.
(define (poly->sexp p)
(cond ((number? p) p)
(horner (coes->horner-sexp (var->sexp (car p)) 0 (cdr p)))
(else (cmprs_+ (coes->sexp (var->sexp (car p)) 0 (cdr p))))))
(define (coes->horner-sexp var exp colist)
(cond ((eqv? 0 (car colist)) (coes->horner-sexp var (+ 1 exp) (cdr colist)))
((null? (cdr colist))
(if (zero? exp) (poly->sexp (car colist))
(cmprs_* (poly->sexp (car colist)) (cmprs_^ var exp))))
((zero? exp)
(cmprs_+ (list (poly->sexp (car colist))
(coes->horner-sexp var 1 (cdr colist)))))
(else
(cmprs_*
(cmprs_+ (list (poly->sexp (car colist))
(coes->horner-sexp var 1 (cdr colist))))
(cmprs_^ var exp)))))
(define (coes->sexp var exp colist)
(cond ((null? colist) colist)
((eqv? 0 (car colist)) (coes->sexp var (+ 1 exp) (cdr colist)))
((zero? exp) (cons (poly->sexp (car colist))
(coes->sexp var (+ 1 exp) (cdr colist))))
((eqv? 1 (car colist))
(cons (cmprs_^ var exp) (coes->sexp var (+ 1 exp) (cdr colist))))
(else (cons (cmprs_* (poly->sexp (car colist)) (cmprs_^ var exp))
(coes->sexp var (+ 1 exp) (cdr colist))))))
;RAT->SEXP converts a rational polynomial to SEXPRESSION.
(define (rat->sexp n d)
(if (unit? d)
(poly->sexp (poly_* n d))
(list 'over (poly->sexp n) (poly->sexp d))))
(define (impl_radical? p) (one? (length (or (memv 0 (cddr p)) '()))))
;;;IMPOLY->SEXP converts an implicit polynomial to SEXPRESSION.
(define (impoly->sexp p)
(if (impl_radical? p)
(list '=
(if (null? (cdddr p))
(var->sexp (car p))
;;I cant exercise this clause:
(list '^ (var->sexp (car p)) (length (cddr p))))
(rat->sexp (cadr p) (car (last-pair p))))
(list '= 0 (poly->sexp p))))
;;;IRIMPL->SEXP converts an irreducible implicit expression to SEXPRESSION.
(define (irimpl->sexp p)
(let ((dgr (poly_degree p _@)))
(cond ((zero? dgr) (math:warn "not canonical " p) p)
((one? dgr) (rat->sexp (rat_num p) (rat_denom p)))
(else (list 'suchthat (var->sexp (car p)) (impoly->sexp p))))))
(define (bunch->sexp p)
(cond ((bunch? p) (list->vector (map bunch->sexp p))) ;inefficient
((symbol? p) p)
((expl? p) (poly->sexp p))
((impl? p)
(let ((dgr (poly_degree p _@)))
(cond ((zero? dgr) (math:warn "not canonical " p) p)
((one? dgr) (rat->sexp (rat_num p) (rat_denom p)))
(else
(let ((fcts (map irimpl->sexp (univ_split-all p))))
(if (null? (cdr fcts)) (car fcts)
(cons 'or fcts)))))))
((eqn? p) (list '= 0 (poly->sexp (eqn->poly p))))
(else (eval-error "unknown type to display " p))))
(define (highest-lambda-var polys)
(let ((maxpos 0) (deps '()))
(polys_for-each-var
(lambda (v) (if (lambdavar? v)
(if (extrule v)
(set! deps (adjoin v deps))
(set! maxpos (max maxpos (lambda-position v))))))
polys)
(for-each
(lambda (v)
(for-each
(lambda (x) (if (lambdavar? x)
(set! maxpos (max maxpos (lambda-position x)))))
(var_depends v)))
deps)
maxpos))
(define (get-lambda-list poly)
(do ((j (highest-lambda-var poly) (+ -1 j))
(ll '()
(cons (string->symbol (string-append "@" (number->string j))) ll)))
((< j 1) ll)))
;;;MATH->SEXP converts expressions or equations to SEXPRESSIONS.
(define (math->sexp p)
(if (clambda? p)
(list 'lambda (list->vector (get-lambda-list
(if (eqn? p) (eqn->poly p) p)))
(bunch->sexp p))
(bunch->sexp p)))
;;; Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.