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
/
ext.scm
< prev
next >
Wrap
Text File
|
1992-12-23
|
6KB
|
182 lines
;;; JACAL: Symbolic Mathematics System. -*-scheme-*-
;;; Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.
;;; See the file "COPYING" for terms applying to this program.
;;; An algebraic extension is the root of a polynomial with more than
;;; one distinct value. These values are not linked; the difference
;;; between two algebraic extensions which are roots of identical
;;; polynomials is not 0. Radicals have an additional rule that
;;; exponents of "positive" radicands commute. For instance:
;;; (x^2)^(1/2) ==> x. Notice that ((-x)^2)^(1/2) ==> x also.
;;; (-x^2)^(1/2) ==> (-1)^(1/2)*x. Therefore "deep" squarefree
;;; factorization forms the backbone of radical simplification and
;;; denesting. This seems to be a radical departure from previous work.
;;; algebraic extensions
;;; we want to find all extensions used by this poly except this poly.
(define (alg_exts poly)
(let ((elts '()))
(poly_for-each-var
(lambda (v)
(let ((er (extrule v)))
(if (and er (not (eq? er poly)))
(set! elts (adjoin v elts)))))
poly)
elts))
;;;alg_vars returns a list of all vars used in this or in extensions
;;;used in this.
(define (alg_vars poly)
(let ((deps '()) (exts '()))
(poly_for-each-var
(lambda (v) (if (extrule v)
(set! exts (adjoin v exts))
(set! deps (adjoin v deps))))
poly)
(for-each (lambda (v) (set! deps (union (var_depends v) deps)))
exts)
deps))
(define (alg_square-free-var p var)
(alg_/ p (alg_gcd p (alg_diff p var))))
;;; This is for equations
;;; Don't simplify a rule with itself
(define (alg_simplify p)
(let ((exrls (map extrule (sort (alg_exts p) var_>))))
(if (memv p exrls)
p
(reduce-init poly_prem p exrls))))
(define (alg_clear-denoms p)
(do ((v (poly_find-var-if? (rat_denom p) extrule)
(poly_find-var-if? (rat_denom p) extrule))
(oldv "foo" (car v)))
((not v) p)
(if (eq? (car v) oldv)
(eval-error "could not clear denominator of: " p))
(set! p (alg_simplify
(poly_* p (alg_conjugate (rat_denom p) v))))))
;;; This generates conjugates for any algebraic by a wonderful theorem of mine.
;;; 4/30/90 jaffer
(define (alg_conjugate poly extpoly)
(let* ((var (car extpoly))
(pdiv (univ_pdiv extpoly (promote var poly)))
(pquo (car pdiv))
(prem (cadr pdiv)))
(if (zero? (univ_degree prem var))
pquo
(poly_* pquo (alg_conjugate prem extpoly)))))
;;;This currently works only for univ extpoly
(define (alg_mod poly extpoly)
(let ((p (poly_prem poly extpoly)))
(if (and (rat? p) (pair? extpoly)
(pair? (rat_denom p)) (eq? (car extpoly) (car (rat_denom p))))
(poly_prem
(poly_* p (alg_conjugate (rat_denom p) extpoly))
extpoly)
p)))
;;; This section attempts to implement an incremental version of
;;; Caviness, B.F., Fateman, R.:
;;; Simplification of Radical Expressions.
;;; SYMSAC 1976, 329-338
;;; as described in
;;; Buchberger, B., Collins, G.E., Loos, R.:
;;; Computer Algebra, Symbolic and Algebraic Computation. Second Edition
;;; Springer-Verlag/Wein 1983, 20-22
;;; This algorithm for canonical simplification of UNNESTED radical expressions
;;; also has the convention that (s * t)^r = s^r * t^r.
;;; If the variable LINK-RADICANDS is #f then a new multiple value expression
;;; is returned for each radical.
;;; this is actually alg_depth
(define (rad_depth imp)
(let ((exts (alg_exts imp)))
(if (null? exts)
0
(+ 1 (apply max (map (lambda (x) (rad_depth (extrule x))) exts))))))
;;; Integer power of EXPR
(define (ipow a pow)
(if (not (integer? pow)) (math-error "non-integer power? " pow))
(cond ((expl? a) (if (< pow 0)
(make-rat 1 (poly_^ a (- pow)))
(poly_^ a pow)))
((rat? a) (if (< pow 0)
(make-rat (ipow (rat_denom a) (- pow))
(ipow (rat_num a) (- pow)))
(make-rat (ipow (rat_num a) pow)
(ipow (rat_denom a) pow))))
(else (if (< pow 0)
(app* (list _@ 1 (univ_monomial -1 (- pow) _@1)) a)
(app* (univ_monomial 1 pow _@1) a)))))
(define (^ a pow)
(cond
((not (rat_number? pow)) (deferop '^ a pow))
((eqn? a) (math-error "Expt of equation?: " a))
(else
(set! pow (expr_normalize pow))
(let ((tmp #f)
(expnum (num pow))
(expdenom (denom pow)))
(cond
((eqv? 1 expdenom) (ipow a expnum))
(link-radicands
(set! a (expr_normalize a))
(cond ((expl? a) (ipow (make-radical-ext a expdenom) expnum))
((not (rat? a)) (math-error "Non-rational radicand: " a))
((rat_unit-denom? a)
(ipow (make-radical-ext (poly_* (denom a) (num a)) expdenom)
expnum))
(else (ipow (make-rat (make-radical-ext (rat_num a) expdenom)
(make-radical-ext (rat_denom a) expdenom))
expnum))))
(else
(app* (cond ((> expnum 0)
(set! tmp (univ_monomial -1 expdenom _@))
(set-car! (cdr tmp) (univ_monomial 1 expnum _@1))
tmp)
(else
(set! tmp (univ_monomial
(univ_monomial -1 (- expnum) _@1)
expdenom
_@))
(set-car! (cdr tmp) 1)
tmp))
a)))))))
;;; Generate extensions for radicals of polynomials
;;; Currently this does not split previously defined radicands.
;;; It will as soon as expression rework is added.
(define (make-radical-ext p r)
(set! p (licit->polxpr p))
(let ((prest #f)
(pegcd #f)
(radrest #f)
(en #f)
(e (member-if (lambda (e) (equal? p (cadr e))) radical-defs)))
(cond (e (if (divides? r (length (cddr (car e))))
(radpow (car e) r)
(var->expl (make-rad-var p r))))
((begin (set! e (member-if (lambda (rule)
(set! en (cadr rule))
(set! pegcd (poly_gcd en p))
(not (eqv? 1 pegcd)))
radical-defs))
e)
(set! prest (poly_/ p pegcd))
(set! radrest (poly_/ en pegcd))
(if (and (eqv? 1 radrest) (divides? r (length (cddr (car e)))))
(app* _@1*@2 (make-radical-ext prest r) (radpow (car e) r))
(var->expl (make-rad-var p r))))
(else (var->expl (make-rad-var p r))))))
(define (radpow radrule r)
(univ_monomial 1 (quotient (length (cddr radrule)) r) (car radrule)))
;;; Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.