home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / maths / b116_1 / jacal / sexp < prev    next >
Text File  |  1993-10-18  |  12KB  |  367 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1989, 1990, 1991, 1992, 1993 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;;; our local environments
  6. (define heqput! (alist-associator eq?))
  7. (define heqrem! (alist-remover eq?))
  8. (define hassq (predicate->asso eq?))
  9. (define (list-of-procedure-defsyms)
  10.   (define proc-defs '())
  11.   (alist-for-each (lambda (k v)
  12.             (if (procedure? (var:def v))
  13.             (set! proc-defs (cons k proc-defs))))
  14.           var-tab)
  15.   proc-defs)
  16.  
  17. ;(define heqput! (hash-associator eq?))
  18. ;(define heqrem! (hash-remover eq?))
  19. ;(define hassq (predicate->hash-asso eq?))
  20. ;(define (list-of-procedure-defsyms)
  21. ;  (define proc-defs '())
  22. ;  (hash-for-each
  23. ;   (lambda (k v) (set! proc-defs (cons k proc-defs)))
  24. ;   var-tab)
  25. ;  proc-defs)
  26.  
  27. (define (defsym sym value)
  28.   (set! *symdefs* (heqput! *symdefs* sym value)) value)
  29. (define (undefsym sym)
  30.   (set! *symdefs* (heqrem! *symdefs* sym))
  31.   (var->expl (sexp->var sym)))
  32.  
  33. (define (defbltn sym val)
  34.   (cond ((list? sym)
  35.      (for-each (lambda (v) (apply defbltn v val)) sym))
  36.     (else
  37.      (var:set-def! (sexp->var sym) val)
  38.      sym)))
  39.  
  40. ;;; hdns here is a list of lexically bound symbols as in lambda or suchthat.
  41. ;;; so it is really a list of things not to look up.
  42. (define (symdef-lookup sym hdns)
  43.   (cond ((null? hdns)
  44.      (let ((p (hassq sym *symdefs*)))
  45.        (if p (cdr p) (var->expl (sexp->var sym)))))
  46.     ((eq? sym (car hdns)) (var->expl (sexp->var sym)))
  47.     ((symbol? (car hdns)) (symdef-lookup sym (cdr hdns)))
  48.     ((memq sym (car hdns)) (var->expl (sexp->var sym)))
  49.     (else (symdef-lookup sym (cdr hdns)))))
  50.  
  51. ;;;now for the read-eval-print stuff
  52. (define var-news '())
  53. (define (math . batches)
  54.   (set-handlers!)
  55.   (for-each (lambda (file)
  56.           (batch (if (symbol? file) (symbol->string file) file)))
  57.         batches)
  58.   (tran:display 'type)
  59.   (write-sexp '(qed) *input-grammar*)
  60.   (tran:display 'to-return-to-)
  61.   (display base-language)
  62.   (tran:display 'type-)
  63.   (write-sexp '(help) *input-grammar*)
  64.   (tran:display 'for-help.)
  65.   (batch1)
  66.   (cleanup-handlers!)
  67.   base-language)
  68.  
  69. (define (batch file)
  70.   (let* ((save-page #f)
  71.      (swapmodes (lambda ()
  72.               (let ((tmp page-height))
  73.             (set! page-height save-page)
  74.             (set! save-page tmp)))))
  75.     (dynamic-wind swapmodes
  76.           (lambda () (with-input-from-file file batch1))
  77.           swapmodes)))
  78.  
  79. (define (batch1)
  80.   (do ((math:exit-saved math:exit)
  81.        (var-news-saved var-news)
  82.        (math:prompt #f))
  83.       ((call-with-current-continuation
  84.     (lambda (math:exit-cnt)
  85.       (define obj #f)
  86.       (set! math:exit math:exit-cnt)
  87.       (newline)            ;find unused var
  88.       (do () ((not (or (var-tab-lookup newlabelsym var-tab)
  89.                (hassq newlabelsym *symdefs*))))
  90.         (set! newlabelstr (sect:next-string newlabelstr))
  91.         (set! newlabelsym  (string->symbol newlabelstr)))
  92.       (set! math:prompt (string-append newlabelstr " : "))
  93.       (let loop ()
  94.         (define echoing (not (eq? (get-grammar 'null) *echo-grammar*)))
  95.         (set! var-news '())
  96.         (cond (echoing)
  97.           ((output-port? (current-input-port))
  98.            (let ((cip (current-input-port)))
  99.              (display math:prompt cip)
  100.              (force-output cip)
  101.              (lex:bump-column (string-length math:prompt))))
  102.           (else (display math:prompt)
  103.             (force-output)
  104.             (lex:bump-column (string-length math:prompt))))
  105.         (set! obj (read-sexp *input-grammar*))
  106.         (lex:bump-column 0)
  107.         (cond ((not obj) (loop))
  108.           ((eof-object? obj) (math:exit #t))
  109.           ((and (symbol? obj) (symdef-lookup obj '()))
  110.            (write-sexp (list 'define obj
  111.                      (math->sexp (symdef-lookup obj '())
  112.                          horner))
  113.                    *output-grammar*)
  114.            (newline)
  115.            (loop))
  116.           (else
  117.            (set! linum 0)
  118.            (write-sexp obj *echo-grammar*)
  119.            (if (and (pair? obj) (eq? 'define (car obj)))
  120.                (let* ((var (cadr obj)) (val (sexp->math obj)))
  121.              (out-new-vars var-news)
  122.              (newline)
  123.              (cond ((novalue? val)
  124.                 (sexp->math (list 'define var var))
  125.                 (eval-error 'no-value-to-set (cadr obj)))
  126.                    ((eq? 'null (grammar-name *output-grammar*))
  127.                 (set! % val))
  128.                    (else
  129.                 (set! % val)
  130.                 (write-sexp (list 'define var
  131.                           (math->sexp val horner))
  132.                         *output-grammar*)
  133.                 (newline))))
  134.                (let* ((var newlabelsym)
  135.                   (val (sexp->math (list 'define var obj))))
  136.              (out-new-vars var-news)
  137.              (newline)
  138.              (cond ((novalue? val)
  139.                 (sexp->math (list 'define var var))
  140.                 (loop))
  141.                    ((eq? 'null (grammar-name *output-grammar*))
  142.                 (set! % val))
  143.                    (else
  144.                 (set! % val)
  145.                 (write-sexp (list 'define var
  146.                           (math->sexp val horner))
  147.                         *output-grammar*)
  148.                 (newline))))))))
  149.       #f))
  150.        (set! math:exit math:exit-saved)
  151.        (set! var-news var-news-saved))))
  152.  
  153. (define (out-new-vars var-news)
  154.   (if (not (eq? 'null (grammar-name *output-grammar*)))
  155.       (for-each (lambda (x)
  156.           (newline)
  157.           (write-sexp (list 'define
  158.                     (var:sexp x)
  159.                     (math->sexp (vsubst $ x (extrule x))
  160.                         horner))
  161.                   *output-grammar*))
  162.         var-news)))
  163.  
  164. ;;; $=fc($1) --> $=fc^^-1($1)
  165. (define (fcinverse fc)
  166.   (extize (normalize (swapvars $1 $ (licit->impl fc)))))
  167.  
  168. ;;; fc(fc(...fc($1)))
  169. (define (fcexpt fc pow)
  170.   (if (negative? pow)
  171.       (fcexpt (fcinverse fc) (- pow))
  172.     (ipow-by-squaring fc pow cidentity app*)))
  173.  
  174. (define (rapply ob . arglist)
  175.   (cond ((null? arglist) ob)
  176.     ((bunch? ob)
  177.      (apply rapply
  178.         (list-ref ob (+ -1 (plicit->integer (car arglist))))
  179.         (cdr arglist)))
  180.     ((expl? ob) (apply deferop _rapply ob arglist))
  181.     (else (eval-error 'rapply 'wta ob))))
  182.  
  183. (define (sapply fun args)
  184.   (cond ((procedure? fun) (apply fun args))
  185.     ((clambda? fun)
  186.      (capply fun args))
  187.     ((rat:number? fun) (eval-error 'apply 'wta fun))
  188.     (else (apply deferop fun args))))
  189.  
  190. (define (app* fun . args) (sapply fun args))
  191.  
  192. (define (seval f hdns)
  193.   (cond ((number? f)
  194.      (if (inexact? f) (eval-error 'Inexact-number-to-eval:-))
  195.        (cond ((integer? f) f)
  196.              ((rational? f) (make-rat (numerator f) (denominator f)))))
  197.     ((vector? f) (map (lambda (x) (seval x hdns)) (vector->list f)))
  198.     ((symbol? f) (symdef-lookup f hdns))
  199.     ((boolean? f) f)
  200.     ((null? f) f)
  201.     ((not (pair? f)) (eval-error 'eval 'wta f))
  202.     ((eq? 'lambda (car f))
  203.      (let ((vars (variables
  204.               (cond ((symbol? (cadr f)) (list (cadr f)))
  205.                 ((vector? (cadr f)) (vector->list (cadr f)))
  206.                 ((pair? (cadr f)) (cadr f))
  207.                 (else (eval-error 'lambda 'bad-arglist f))))))
  208.        (clambda vars (seval (caddr f) (cons vars hdns)))))
  209.     ((eqv? (car f) 'suchthat)
  210.      (suchthat (sexp->var (cadr f))
  211.            (seval (caddr f) (cons (cadr f) hdns))))
  212.     ((eqv? (car f) 'define)
  213.      (cond ((symbol? (cadr f))
  214.         (if (eq? (cadr f) (caddr f))
  215.             (undefsym (cadr f))
  216.             (defsym (cadr f)
  217.               (normalize (seval (caddr f) (cons (cadr f) hdns))))))
  218.            ((eqv? (caadr f) 'rapply)
  219.         (defsym (cadadr f)
  220.           (rlambda (cddadr f)
  221.                (normalize (seval (caddr f)
  222.                          (cons (cdadr f) hdns))))))
  223.            (else            ;must be capply
  224.         (defsym (caadr f)
  225.           (clambda (variables (cdadr f))
  226.                (normalize (seval (caddr f)
  227.                          (cons (cadr f) hdns))))))))
  228.     (else
  229.      (let ((ff (seval (car f) hdns)))
  230.        (sapply (or (and (pair? ff)
  231.                 (expl? ff)
  232.                 (equal? (cdr ff) '(0 1))
  233.                 (procedure? (var:def (car ff)))
  234.                 (var:def (car ff)))
  235.                ff)
  236.            (map (lambda (x) (seval x hdns)) (cdr f)))))))
  237. (define (sexp->math f) (seval f '()))
  238.  
  239. (define (bunch->sexp p horner)
  240. ;;; These routines convert LICITs or parts of LICITs to S-EXPRESSIONs
  241.   (define (cmprs:+ res)
  242.     (cond ((null? (cdr res)) (car res))
  243.       ((and (pair? (cadr res)) (eq? 'negate (caadr res)))
  244.        (cmprs:+ (cons (list '- (car res) (cadadr res)) (cddr res))))
  245.       ((and (pair? (car res)) (eq? '+ (caar res)))
  246.        (if (null? (cddr res)) (nconc (car res) (cdr res))
  247.            (cmprs:+ (cons (nconc (car res) (list (cadr res))) (cddr res)))))
  248.       ((null? (cddr res)) (cons '+ res))
  249.       (else (cmprs:+ (cons (list '+ (car res) (cadr res)) (cddr res))))))
  250.  
  251.   (define (cmprs:* mu mex)
  252.     (cond ((pair? mu)
  253.        (cond ((eq? '* (car mu)) (nconc mu (list mex)))
  254.          ((eq? 'negate (car mu))
  255.           (list 'negate (cmprs:* (cadr mu) mex)))
  256.          (else (list '* mu mex))))
  257.       ((and (number? mu) (negative? mu))
  258.        (if (eq? -1 mu)
  259.            (list 'negate mex)
  260.            (list 'negate (list '* (- mu) mex))))
  261.       (else (if (eq? 1 mu) mex (list '* mu mex)))))
  262.  
  263.   (define (cmprs:^ var exp)
  264.     (cond ((one? exp) var)
  265.       ((and (pair? var)
  266.         (eq? '^ (car var)))
  267.        (list '^
  268.          (cadr var)
  269.          (if (and (pair? (caddr var))
  270.               (eq? '/ (caaddr var))
  271.               (one? (cadr (caddr var))))
  272.              (list '/ exp (caddr (caddr var)))
  273.              (cmprs:* exp (caddr var)))))
  274.       (else (list '^ var exp))))
  275.  
  276.                     ;POLY->SEXP converts a polynomial to SEXPRESSION.
  277.   (define (poly->sexp p)
  278.     (cond ((number? p) p)
  279.       (horner (coes->horner-sexp (var:sexp (car p)) 0 (cdr p)))
  280.       (else (cmprs:+ (coes->sexp (var:sexp (car p)) 0 (cdr p))))))
  281.   (define (coes->horner-sexp var exp colist)
  282.     (cond ((eqv? 0 (car colist)) (coes->horner-sexp var (+ 1 exp) (cdr colist)))
  283.       ((null? (cdr colist))
  284.        (if (zero? exp) (poly->sexp (car colist))
  285.            (cmprs:* (poly->sexp (car colist)) (cmprs:^ var exp))))
  286.       ((zero? exp)
  287.        (cmprs:+ (list (poly->sexp (car colist))
  288.               (coes->horner-sexp var 1 (cdr colist)))))
  289.       (else
  290.        (cmprs:*
  291.         (cmprs:+ (list (poly->sexp (car colist))
  292.                (coes->horner-sexp var 1 (cdr colist))))
  293.         (cmprs:^ var exp)))))
  294.   (define (coes->sexp var exp colist)
  295.     (cond ((null? colist) colist)
  296.       ((eqv? 0 (car colist)) (coes->sexp var (+ 1 exp) (cdr colist)))
  297.       ((zero? exp) (cons (poly->sexp (car colist))
  298.                  (coes->sexp var (+ 1 exp) (cdr colist))))
  299.       ((eqv? 1 (car colist))
  300.        (cons (cmprs:^ var exp) (coes->sexp var (+ 1 exp) (cdr colist))))
  301.       (else (cons (cmprs:* (poly->sexp (car colist)) (cmprs:^ var exp))
  302.               (coes->sexp var (+ 1 exp) (cdr colist))))))
  303.                     ;RAT->SEXP converts a rational polynomial to SEXPRESSION.
  304.   (define (rat->sexp n d)
  305.     (if (unit? d)
  306.     (poly->sexp (poly:* n d))
  307.     (list 'over (poly->sexp n) (poly->sexp d))))
  308.  
  309.   (define (impl:radical? p) (one? (length (or (memv 0 (cddr p)) '()))))
  310. ;;;IMPOLY->SEXP converts an implicit polynomial to SEXPRESSION.
  311.   (define (impoly->sexp p)
  312.     (if (impl:radical? p)
  313.     (list '=
  314.           (if (null? (cdddr p))
  315.           (var:sexp (car p))
  316.           ;;I cant exercise this clause:
  317.           (list '^ (var:sexp (car p)) (length (cddr p))))
  318.           (rat->sexp (cadr p) (car (last-pair p))))
  319.     (list '= 0 (poly->sexp p))))
  320.  
  321. ;;;IRIMPL->SEXP converts an irreducible implicit expression to SEXPRESSION.
  322.   (define (irimpl->sexp p)
  323.     (let ((dgr (poly:degree p $)))
  324.       (cond ((zero? dgr) (math:warn 'not-canonical p) p)
  325.         ((one? dgr) (rat->sexp (rat:num p) (rat:denom p)))
  326.         (else (list 'suchthat (var:sexp (car p)) (impoly->sexp p))))))
  327.  
  328.   (define (ibunch->sexp p)
  329.     (cond ((bunch? p) (list->vector (map ibunch->sexp p))) ;inefficient
  330.       ((symbol? p) p)
  331.       ((expl? p) (poly->sexp p))
  332.       ((impl? p)
  333.        (let ((dgr (poly:degree p $)))
  334.          (cond ((zero? dgr) (math:warn 'not-canonical p) p)
  335.            ((one? dgr) (rat->sexp (rat:num p) (rat:denom p)))
  336.            (else
  337.             (let ((fcts (map irimpl->sexp (univ:split-all p))))
  338.               (if (null? (cdr fcts)) (car fcts)
  339.               (cons 'or fcts)))))))
  340.       ((eqn? p) (list '= 0 (poly->sexp (eqn->poly p))))
  341.       (else (eval-error 'unknown 'type p))))
  342.   (ibunch->sexp p))
  343.  
  344. (define (get-lambda-list poly)
  345.   (do ((j (licits:max-lambda-position poly) (+ -1 j))
  346.        (ll '()
  347.        (cons (string->symbol (string-append "@" (number->string j))) ll)))
  348.       ((< j 1) ll)))
  349.  
  350. ;;;MATH->SEXP converts expressions or equations to SEXPRESSIONS. 
  351. (define (math->sexp p horner)
  352.   (if (clambda? p)
  353.       (list 'lambda (list->vector (get-lambda-list
  354.                    (if (eqn? p) (eqn->poly p) p)))
  355.         (bunch->sexp p horner))
  356.       (bunch->sexp p horner)))
  357.  
  358. (define (deferedmath->sexp args)
  359.   (let ((form (map (lambda (arg) (bunch->sexp arg #t)) args)))
  360.     (if (some clambda? (cdr args))
  361.     (list 'lambda
  362.           (list->vector (get-lambda-list (cdr args)))
  363.           form)
  364.     form)))
  365.  
  366. ;;;    Copyright 1989, 1990, 1991, 1992, 1993 Aubrey Jaffer.
  367.