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
/
types.scm
< prev
next >
Wrap
Text File
|
1992-12-23
|
12KB
|
343 lines
;;; JACAL: Symbolic Mathematics System. -*-scheme-*-
;;; Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.
;;; See the file "COPYING" for terms applying to this program.
;;; We define proc so that scl.lisp will correctly funcallize it.
(define proc 'proc)
;;; Scheme doesn't allow for definition of new types which are
;;; distinct from existing types. So we will carefully use BUNCH
;;; instead of LIST in order to distinguish the types.
;;; This requires that boolean?, pair?, symbol?, number?,
;;; string?, vector? and procedure? be disjoint as outlined in:
;;; Jonathan Rees and William Clinger, editors. The Revised^3
;;; Report on the algorithmic language Scheme, ACM SIGPLAN Notices
;;; 21(12), ACM, December 1986.
;;; If the types are not disjoint you WILL lose.
;;; The following types are mutually exclusive:
;;; SEXP, VARIABLE, EXPL, IMPL, EQLT, BUNCH
;;; INTEGERs are EXPL
;;; An EXPR is an EXPL or IMPL
;;; A LICIT is an EXPL, IMPL, or EQLT.
;;; VARIBLEs can only occur as part of EXPRS and EQLTS.
;;; SYMBOLs can only occur in SEXP.
;;; BUNCHES can contain SYMBOLs, LICITs, and BUNCHEs.
;;; An EXPL, IMPL, or EQLT, or BUNCH of these can be a
;;; lambda expression.
;;; A VAR is a vector which consists of:
;;; 0 var->sexp - s-expression ;lambda vars have leading "@"
;shadowed vars have leading ":"
;;; 1 var_pri - string ;ordering priority
;first char is priority override
;last char is differential order
;;; 2 var_def - poleq ;ext defining equation
;;; or - integer ;lambda position
;;; or - procedure ;
;;; 3 var_depends - list of vars ;vars used in var_def
;;;; THE REST ARE FOR FUNCTIONS ONLY
;;; 4 func-arglist ;list of argument names.
;;; 5 func-parity - list ;EVEN, ODD, 0, or #F
;;; 6 func-syms - list of lists ;of positions of arguments
;;; 7 func-anti-syms - list of lists ;of positions of arguments
;;; 8 func-dists - list of lists ;of functions which distribute
;;; 9 func-anti-dists - list of lists ;of functions which anti-distribute
;;; 10 func-idems - list ;of positions of arguments
; perserved in idempotency
(define poly_var? vector?)
(define (var->sexp v) (vector-ref v 0))
(define (var_pri v) (char->integer (string-ref (vector-ref v 1) 0)))
(define (var_set-pri! v i) (string-set! (vector-ref v 1) 0 (integer->char i)))
(define (var_def v) (vector-ref v 2))
(define (var_set-def! v i) (vector-set! v 2 i) v)
(define (var_depends v) (vector-ref v 3))
(define (var_set-depends! v i) (vector-set! v 3 i) v)
(define (func-arglist f) (vector-ref f 4))
(define (func-set-arglist f i) (vector-set! f 4 i))
(define func? func-arglist)
(define (func-parity f) (vector-ref f 5))
(define (func-syms f) (vector-ref f 9))
(define (func-anti-syms f) (vector-ref f 10))
(define (func-dists f) (vector-ref f 11))
(define (func-anti-dists f) (vector-ref f 12))
(define (func-idems f) (vector-ref f 13))
(define (var_> v2 v1)
(string>? (vector-ref v2 1) (vector-ref v1 1)))
(define var-tab (make-hash-table 43))
(define var-tab-lookup (predicate->hash-asso equal?))
(define var-tab-define (hash-associator equal?))
(define (sexp->var sexp)
(let ((vcell (var-tab-lookup sexp var-tab)))
(if vcell (cdr vcell)
(let ((val (make-var sexp)))
(var-tab-define var-tab sexp val)
val))))
(define (string->var s) (sexp->var (string->symbol s)))
(define (deferop name . args)
(var->expl (sexp->var (cons name (map math->sexp args)))))
(define lambda-var-pri (+ -5 char-code-limit))
(define lambda-var-pri-str (string (integer->char lambda-var-pri)))
(define median-pri-str (string (integer->char (quotient char-code-limit 2))))
(require 'object->string)
(define (make-var v)
(let ((base v)
(diffs 0))
(do () ((not (and (pair? base) (eq? 'differential (car base)))))
(set! base (cadr base))
(set! diffs (+ 1 diffs)))
(let* ((s (object->string base))
(sl (string-length s)))
(vector v
(string-append (case (string-ref s 0)
((#\@ #\:) lambda-var-pri-str)
(else median-pri-str))
s
(string (integer->char diffs)))
(if (and (char=? #\@ (string-ref s 0))
(not (= sl 1))
(not (char=? #\^ (string-ref s 1))))
(string->number (substring s 1 sl))
#f)
#f))))
;;; This checks for unshadowing :@
;(define (var->symbol v)
; (let ((s (var->sexp-string v)))
; (string->symbol
; (string-append (if (char=? #\: (string-ref s 0))
; (substring s 1 (string-length s))
; s)
; (make-string (var_diff-depth v) #\')))))
(define (var->string v)
(let ((sexp (var->sexp v)))
(math-assert (symbol? sexp) "expected simple symbol" sexp)
(symbol->string sexp)))
(define (make-rad-var radicand n)
(let ((e (univ_monomial -1 n _@)))
(set-car! (cdr e) radicand)
(let ((v (defext (sexp->var (list '^ (poly->sexp radicand) (list '/ 1 n)))
e)))
(set! radical-defs (cons (extrule v) radical-defs))
v)))
(define (make-subscripted-var v . indices)
(string->var
(apply string-append (var->string v)
(map (lambda (i) (string-append "_" (number->string i)))
indices))))
(define (var_nodiffs v)
(do ((base (vector-ref v 0) (cadr base)))
((not (and (pair? base) (eq? 'differential (car base))))
(if (eq? base (vector-ref v 0)) v (sexp->var base)))))
(define (var_differential? v)
(not (zero? (var_diff-depth v))))
(define (var_diff-depth v)
(let ((s (vector-ref v 1)))
(char->integer (string-ref s (+ -1 (string-length s))))))
(define (var_differential v)
(sexp->var (list 'differential (var->sexp v))))
(define (var_undiff v)
(sexp->var (cadr (var->sexp v))))
(define (lambdavar? v)
(= lambda-var-pri (var_pri v)))
(define (lambda-var i diff-depth)
(if (zero? diff-depth)
(var_set-def! (sexp->var
(string->symbol
(string-append "@" (number->string i))))
i)
(var_differential (lambda-var i (+ -1 diff-depth)))))
;;; This sometimes is called with shadowed variables (:@4)
(define lambda-position var_def)
(define (var->sexp-string v)
(var->string (var_nodiffs v)))
(define (var->sexp-apply proc var)
(if (var_differential? var)
(var_differential (var->sexp-apply proc (var_undiff var)))
(apply proc var '())))
(define (var_shadow v)
(var->sexp-apply (lambda (v)
(var_set-def!
(string->var (string-append ":" (var->sexp-string v)))
(var_def v)))
v))
(define (extrule e) (and (pair? (var_def e)) (var_def e)))
(define (defext var impl)
(let ((fees '()) (deps '()))
(poly_for-each-var
(lambda (v) (if (not (_@? v)) (if (extrule v)
(set! fees (adjoin v fees))
(set! deps (adjoin v deps)))))
impl)
(for-each (lambda (fee) (set! deps (union (var_depends fee) deps)))
fees)
(var_set-depends! var deps)
(set! fees (nconc fees deps))
(var_set-pri! var (if (null? fees) 10 ;must be a constant.
(+ 1 (apply max (map var_pri fees)))))
(var_set-def! var (vsubst var _@ impl))
var))
;;; IMPL is a data type consisting of a poly with major variable
;;; _@. The value of the IMPL is negative of the poly solved for _@.
;;; Using this representation, if poly is square-free and has no
;;; content (gcd (coefficients) = 1), we can express any
;;; algebraic function or number uniquely, even those with no standard
;;; representation (order > 4 roots).
(define (expr? p)
(or (number? p)
(and (pair? p)
(poly_var? (car p)))))
(define (impl? p) (and (pair? p) (poly_var? (car p)) (_@? (car p))))
(define (rat_number? p)
(or (number? p)
(and (impl? p)
(= 3 (length p))
(number? (cadr p))
(number? (caddr p)))))
(define (expr_0? p) (or (eqv? 0 p) (and (impl? p) (eqv? 0 (rat_num p)))))
(define (expl? p)
(or (number? p)
(and (pair? p)
(poly_var? (car p))
(not (_@? (car p))))))
;;; Rational impl?
(define (rat? p) (and (impl? p) (= 3 (length p))))
(define (make-rat num denom) (list _@ num (poly_negate denom)))
(define rat_num cadr)
(define (rat_denom p) (poly_negate (caddr p)))
(define (rat_unit-denom? p) (unit? (caddr p)))
(define (bunch? p)
(or (null? p)
(and (pair? p)
(not (poly_var? (car p)))
(not (eqv? _@= (car p))))))
(define (bunch_map proc b)
(if (bunch? b)
(map (lambda (x) (bunch_map proc x)) b)
(proc b)))
(define (bunch_for-each proc b)
(if (bunch? b)
(for-each (lambda (x) (bunch_for-each proc x)) b)
(proc b)))
(define _@= "=")
(define (eqn? p) (and (pair? p) (eqv? _@= (car p))))
(define (eqns? p) (if (bunch? p) (some eqns? p) (eqn? p)))
(define (licit? p)
(or (number? p)
(and (pair? p)
(or (poly_var? (car p))
(eqv? _@= (car p))))))
(define eqn->poly cdr)
(define (poly->eqn p) (cons _@= p))
(define (polys->eqns p) (if (bunch? p) (map polys->eqns p) (poly->eqn p)))
(define (var->expl v) (list v 0 1))
(define (expl->impl p) (make-rat p 1))
(define (var->impl v) (make-rat (var->expl v) 1))
;;; Two paradigms for doing algebra on equations and expressions:
;;; Polynomials as expressions and Polynomials as equations.
;;; Polynomials are used as expressions in GCD.
;;; Polynomials are used as equations in ELIMINATE.
;;; licit-> polxpr poleqn
;;; eqn expl expl
;;; expl expl impl
;;; impl expl(?) impl
;;; After the operation is done, we need to convert back. For
;;; Polynomials as expressions, the result is already expl. For
;;; polynomials as equations:
;;; poleqn->licit
;;; expl eqn
;;; impl expr
(define (licit->poleqn p)
(cond ((symbol? p) (var->impl (sexp->var p)))
((eqn? p) (eqn->poly p))
((impl? p) p)
((expl? p) (expl->impl p))
(else (math-error "cannot be coerced to implicit: " p))))
(define (licits->poleqns p)
(if (bunch? p) (map licits->poleqns p) (licit->poleqn p)))
(define (poleqn->licit p)
(cond ((impl? p) (expr_norm p))
((expl? p) (poly->eqn p))
(else (math-error "not a polynomial equation" p))))
(define (poleqns->licits p)
(if (bunch? p) (map poleqns->licits p) (poleqn->licit p)))
(define (licit->polxpr p)
(cond ((symbol? p) (var->expl (sexp->var p)))
((eqn? p) (eqn->poly p))
((expl? p) p)
((and (impl? p) (poly_/? (rat_num p) (rat_denom p))))
(else (math-error "cannot be coerced to explicit: " p))))
(define (expr p)
(cond ((symbol? p) (var->expl (sexp->var p)))
((expr? p) p)
(else (math-error "cannot be coerced to expr: " p))))
(define (exprs p)
(if (bunch? p) (map exprs p) (expr p)))
(define (explicit->var p)
(cond ((symbol? p) (sexp->var p))
; ((poly_var? p) p)
((and (pair? p)
(expl? p)
(equal? (cdr p) '(0 1)))
(car p))
(else (math-error "not a simple variable: " p))))
(define (variables p)
(cond ((symbol? p) (list (sexp->var p)))
; ((poly_var? p) (list p))
((and (pair? p)
(expl? p)
(equal? (cdr p) '(0 1)))
(list (car p)))
((list? p) (map explicit->var p))
((else (math-error "not a simple variable: " p)))))
(define (plicit->integer p)
(cond ((integer? p) p)
((not (rat_number? p)) (math-error "not an integer " p))
((rat_unit-denom? p) (* (rat_denom p) (rat_num p) -1))
(else (math-error "not an integer " p))))
(define (unit? x) (member x '(1 -1)))
(define (expr_norm p)
(if (and (rat? p) (rat_unit-denom? p))
(poly_* (rat_num p) (rat_denom p))
p))
(define (expr_norm-or-signcan p)
(if (and (rat? p) (rat_unit-denom? p))
(poly_* (rat_num p) (rat_denom p))
(signcan p)))
;;; These two functions return type expl
(define (num p)
(cond ((impl? p) (rat_num p))
((expl? p) p)
(else (math-error "cannot extract numerator " p))))
(define (denom p)
(cond ((rat? p) (rat_denom p))
((expl? p) 1)
(else (math-error "cannot extract denominator " p))))
(define (sexp? e)
(cond ((number? e) #t)
((symbol? e) #t)
((pair? e) (symbol? (car e)))
((vector? e) #t)
(else #f)))