diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index be8a6ac..af73e59 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -15626,6 +15626,430 @@ The result is an augmented SL, if d has x, 'failed otherwise. \end{chunk} +\defun{unifyStructVar}{unifyStructVar} +The first argument is a pattern variable, which is not substituted by sl +\calls{unifyStructVar}{contained} +\calls{unifyStructVar}{lassoc} +\calls{unifyStructVar}{unifyStruct} +\calls{unifyStructVar}{constructor?} +\calls{unifyStructVar}{subCopy} +\calls{unifyStructVar}{containsVars} +\calls{unifyStructVar}{canCoerce} +\calls{unifyStructVar}{resolveTT} +\calls{unifyStructVar}{nequal} +\calls{unifyStructVar}{isPatternVar} +\calls{unifyStructVar}{augmentSub} +\refsdollar{unifyStructVar}{domPvar} +\refsdollar{unifyStructVar}{Coerce} +\refsdollar{unifyStructVar}{Subst} +\defsdollar{unifyStructVar}{hope} +\begin{chunk}{defun unifyStructVar} +(defun |unifyStructVar| (v ss sl) + (let (ps s1 s0 s ns0 ns1 s3) + (declare (special |$domPvar| |$hope| |$Coerce| |$Subst|)) + (cond + ((contained v ss) '|failed|) + (t + (setq ps (lassoc ss sl)) + (setq s1 (if ps ps ss)) + (cond + ((or (setq s0 (lassoc v sl)) (setq s0 (lassoc v |$Subst|))) + (setq s (|unifyStruct| s0 s1 (copy sl))) + (cond + ((eq s '|failed|) + (cond + ((and |$Coerce| (null (atom s0)) (|constructor?| (car s0))) + (cond + ((or (|containsVars| s0) (|containsVars| s1)) + (setq ns0 (|subCopy| s0 sl)) + (setq ns1 (|subCopy| s1 sl)) + (cond + ((or (|containsVars| ns0) (|containsVars| ns1)) + (setq |$hope| t) + '|failed|) + (t + (cond + ((|canCoerce| ns0 ns1) (setq s3 s1)) + ((|canCoerce| ns1 ns0) (setq s3 s0)) + (t (setq s3 nil))) + (cond + (s3 + (cond + ((nequal s3 s0) + (setq sl (|augmentSub| v s3 sl)))) + (cond + ((and (nequal s3 s1) (|isPatternVar| ss)) + (setq sl (|augmentSub| ss s3 sl)))) + sl) + (t '|failed|))))) + (|$domPvar| + (setq s3 (|resolveTT| s0 s1)) + (cond + (s3 + (cond + ((nequal s3 s0) + (setq sl (|augmentSub| v s3 sl)))) + (cond + ((and (nequal s3 s1) (|isPatternVar| ss)) + (setq sl (|augmentSub| ss s3 sl)))) + sl) + (t '|failed|))) + (t '|failed|))) + (t '|failed|))) + (t (|augmentSub| v ss s)))) + (t (|augmentSub| v ss sl))))))) + +\end{chunk} + +\defun{containsVars}{containsVars} +The function containsVars tests whether term t contains a * variable. +\calls{containsVars}{isPatternVar} +\calls{containsVars}{containsVars1} +\begin{chunk}{defun containsVars} +(defun |containsVars| (arg) + (if (atom arg) + (|isPatternVar| arg) + (|containsVars1| arg))) + +\end{chunk} + +\defun{containsVars1}{containsVars1} +The function containsVars1 tests whether term t contains a * variable. +This is a recursive version, which works on a list. +\calls{containsVars1}{isPatternVar} +\calls{containsVars1}{containsVars1} +\begin{chunk}{defun containsVars1} +(defun |containsVars1| (arg) + (let ((t1 (car arg)) (t2 (cdr arg))) + (if (atom t1) + (or (|isPatternVar| t1) + (if (atom t2) (|isPatternVar| t2) (|containsVars1| t2))) + (or (|containsVars1| t1) + (if (atom t2) (|isPatternVar| t2) (|containsVars1| t2)))))) + +\end{chunk} + +\defun{hasCaty1}{hasCaty1} +The cond is either a (has a b) or an OR clause of such conditions. +SL is augmented, if cond is true, otherwise the result is 'failed +\calls{hasCaty1}{hasCate} +\calls{hasCaty1}{hasCaty1} +\calls{hasCaty1}{keyedSystemError} +\defsdollar{hasCaty1}{domPvar} +\begin{chunk}{defun hasCaty1} +(defun |hasCaty1| (cond sl) + (let (|$domPvar| args tmp1 tmp2 a tmp3 b S) + (declare (special |$domPvar|)) + (setq |$domPvar| nil) + (cond + ((and (consp cond) (eq (qcar cond) '|has|) + (consp (qcdr cond)) (consp (qcddr cond)) (eq (qcdddr cond) nil)) + (|hasCate| (qcadr cond) (qcaddr cond) sl)) + ((and (consp cond) (EQ (qcar cond) 'and)) + (loop for x in (qcdr cond) + while (not (eq s '|failed|)) + do + (setq s + (cond + ((and (consp x) (eq (qcar x) '|has|) + (consp (qcdr x)) (consp (qcddr x)) (eq (qcdr (qcddr x)) nil)) + (|hasCate| (qcadr x) (qcaddr x) sl)) + ((and (consp x) (eq (qcdr x) nil) + (consp (qcar x)) (eq (qcaar x) '|has|) + (consp (qcdar x)) (consp (qcddar x)) + (eq (qcdr (qcddar x)) nil)) + (|hasCate| a (qcaddar x) sl)) + (t (|hasCaty1| x sl))))) + s) + ((and (consp cond) (eq (qcar cond) 'or)) + (do ((next (qcdr cond) (cdr next)) (x nil) + (nextitem nil (null (eq s '|failed|)))) + ((or (atom next) + (progn (setq x (car next)) nil) + nextitem) + nil) + (setq s + (cond + ((and (consp x) (eq (qcar x) '|has|) + (consp (qcdr x)) (consp (qcddr x)) (eq (qcdddr x) nil)) + (|hasCate| (qcadr x) (qcaddr x) (copy sl))) + ((and (consp x) (eq (qcdr x) nil) (consp (qcar x)) + (eq (qcaar x) '|has|) (consp (qcdar x)) (consp (qcddar x)) + (eq (qcdddar x) nil)) + (|hasCate| (qcadar x) (qcaddar x) (copy sl))) + (t (|hasCaty1| x (copy sl)))))) + s) + (t + (|keyedSystemError| 'S2GE0016 + (list "hasCaty1" "unexpected condition from category table")))))) + +\end{chunk} + +\defun{mkDomPvar}{mkDomPvar} +\calls{mkDomPvar}{domArg} +\calls{mkDomPvar}{length} +\refsdollar{mkDomPvar}{FormalMapVariableList} +\begin{chunk}{defun mkDomPvar} +(defun |mkDomPvar| (p d subs y) + (let (l) + (declare (special |$FormalMapVariableList|)) + (if (setq l (member p |$FormalMapVariableList|)) + (|domArg| d (- (|#| |$FormalMapVariableList|) (|#| l)) subs y) + d))) + +\end{chunk} + +\defun{hasCate}{hasCate} +\calls{hasCate}{isPatternVar} +\calls{hasCate}{hasCate1} +\calls{hasCate}{hasCateSpecial} +\calls{hasCate}{nequal} +\calls{hasCate}{containsVariables} +\calls{hasCate}{subCopy} +\calls{hasCate}{hasCaty} +\refsdollar{hasCate}{EmptyMode} +\refsdollar{hasCate}{Subst} +\defsdollar{hasCate}{hope} +\begin{chunk}{defun hasCate} +(defun |hasCate| (dom cat sl) + (let (nsl p s v d sl1) + (declare (special |$hope| |$Subst| |$EmptyMode|)) + (cond + ((equal dom |$EmptyMode|) nil) + ((|isPatternVar| dom) + (cond + ((and (setq p (assq dom sl)) + (nequal (setq nsl (|hasCate| (cdr p) cat sl)) '|failed|)) + nsl) + ((or (setq p (assq dom |$Subst|)) (setq p (assq dom sl))) + (setq s (|hasCate1| (cdr p) cat sl dom)) + (cond + ((null (eq s '|failed|)) s) + (t (|hasCateSpecial| dom (cdr p) cat sl)))) + (t + (when (nequal sl '|failed|) (setq |$hope| t)) + '|failed|))) + (t + (setq sl1 + (loop for item in sl + when (null (|containsVariables| (cdr item))) + collect item)) + (when sl1 (setq cat (|subCopy| cat sl1))) + (|hasCaty| dom cat sl))))) + +\end{chunk} + +\defun{constructSubst}{constructSubst} +\calls{constructSubst}{internl} +\calls{constructSubst}{stringimage} +\begin{chunk}{defun constructSubst} +(defun |constructSubst| (d) + (let (sl (i 0)) + (setq sl (list (cons '$ d))) + (when (listp d) + (dolist (x (cdr d)) + (setq i (1+ i)) + (setq sl (cons (cons (internl "#" (stringimage i)) x) sl)))) + sl)) + +\end{chunk} + +\defun{hasCateSpecial}{hasCateSpecial} +The variable v is a pattern variable, dom is its binding under \verb|$Subst|. +We try to change dom so that it has category cat under sl. +The result is a substitution list or 'failed. +\calls{hasCateSpecial}{eqcar} +\calls{hasCateSpecial}{isSubDomain} +\calls{hasCateSpecial}{canCoerceFrom} +\calls{hasCateSpecial}{containsVars} +\calls{hasCateSpecial}{augmentSub} +\calls{hasCateSpecial}{hasCate} +\calls{hasCateSpecial}{hasCaty} +\calls{hasCateSpecial}{hasCateSpecialNew} +\refsdollar{hasCateSpecial}{Integer} +\refsdollar{hasCateSpecial}{QuotientField} +\begin{chunk}{defun hasCateSpecial} +(defun |hasCateSpecial| (v dom cat sl) + (let (arg tmp1 d domp nsl) + (declare (special |$Integer| |$QuotientField|)) + (cond + ((and (consp dom) (eq (qcar dom) '|FactoredForm|) + (consp (qcdr dom)) (eq (qcddr dom) nil)) + (setq arg (qcadr dom)) + (when (|isSubDomain| arg |$Integer|) (setq arg |$Integer|)) + (setq d (list '|FactoredRing| arg)) + (setq sl (|hasCate| arg '(|Ring|) (|augmentSub| v d sl))) + (if (eq sl '|failed|) + '|failed| + (|hasCaty| d cat sl))) + ((or (eqcar cat '|Field|) (eqcar cat '|DivisionRing|)) + (when (|isSubDomain| dom |$Integer|) (setq dom |$Integer|)) + (setq d (list |$QuotientField| dom)) + (|hasCaty| dom '(|IntegralDomain|) (|augmentSub| v d sl))) + ((and (consp cat) (eq (qcar cat) '|PolynomialCategory|) + (consp (qcdr cat))) + (setq domp (cons '|Polynomial| (list (qcadr cat)))) + (and (or (|containsVars| (qcadr cat)) (|canCoerceFrom| dom domp)) + (|hasCaty| domp cat (|augmentSub| v domp sl)))) + ((|isSubDomain| dom |$Integer|) + (setq nsl (|hasCate| |$Integer| cat (|augmentSub| v |$Integer| sl))) + (if (eq nsl '|failed|) + (|hasCateSpecialNew| v dom cat sl) + (|hasCaty| |$Integer| cat nsl))) + (t + (|hasCateSpecialNew| v dom cat sl))))) + +\end{chunk} + +\defun{hasCateSpecialNew}{hasCateSpecialNew} +\calls{hasCateSpecialNew}{member} +\calls{hasCateSpecialNew}{eqcar} +\calls{hasCateSpecialNew}{augmentSub} +\calls{hasCateSpecialNew}{defaultTargetFE} +\calls{hasCateSpecialNew}{isEqualOrSubDomain} +\calls{hasCateSpecialNew}{underDomainOf} +\calls{hasCateSpecialNew}{hasCaty} +\refsdollar{hasCateSpecialNew}{Integer} +\refsdollar{hasCateSpecialNew}{ComplexInteger} +\refsdollar{hasCateSpecialNew}{RationalNumber} +\begin{chunk}{defun hasCateSpecialNew} +(defun |hasCateSpecialNew| (v dom cat sl) + (let (fe alg fefull d partialResult) + (declare (special |$RationalNumber| |$ComplexInteger| |$Integer|)) + (setq fe + (|member| (qcar cat) + '(|ElementaryFunctionCategory| + |TrigonometricFunctionCategory| + |ArcTrigonometricFunctionCategory| + |HyperbolicFunctionCategory| + |ArcHyperbolicFunctionCategory| + |PrimitiveFunctionCategory| + |SpecialFunctionCategory| + |Evalable| + |CombinatorialOpsCategory| + |TranscendentalFunctionCategory| + |AlgebraicallyClosedFunctionSpace| + |ExpressionSpace| + |LiouvillianFunctionCategory| + |FunctionSpace|))) + (setq alg + (|member| (qcar cat) + '(|RadicalCategory| + |AlgebraicallyClosedField|))) + (setq fefull + (or fe alg (eqcar cat '|CombinatorialFunctionCategory|))) + (setq partialResult + (cond + ((or (eqcar dom '|Variable|) (eqcar dom '|Symbol|)) + (cond + ((|member| (car cat) + '(|SemiGroup| + |AbelianSemiGroup| + |Monoid| + |AbelianGroup| + |AbelianMonoid| + |PartialDifferentialRing| + |Ring| + |InputForm|)) + (setq d (list '|Polynomial| |$Integer|)) + (|augmentSub| v d sl)) + ((eqcar cat '|Group|) + (setq d (list '|Fraction| (list '|Polynomial| |$Integer|))) + (|augmentSub| v d sl)) + (fefull + (setq d (|defaultTargetFE| dom)) + (|augmentSub| v d sl)) + (t '|failed|))) + ((|isEqualOrSubDomain| dom |$Integer|) + (cond + (fe + (setq d (|defaultTargetFE| |$Integer|)) + (|augmentSub| v d sl)) + (alg + (setq d '(|AlgebraicNumber|)) + (|augmentSub| v d sl)) + (t '|failed|))) + ((equal (|underDomainOf| dom) |$ComplexInteger|) + (setq d (|defaultTargetFE| |$ComplexInteger|)) + (|hasCaty| d cat (|augmentSub| v d sl))) + ((and (equal dom |$RationalNumber|) alg) + (setq d '(|AlgebraicNumber|)) + (|augmentSub| v d sl)) + (fefull + (setq d (|defaultTargetFE| dom)) + (|augmentSub| v d sl)) + (t '|failed|))) + (if (eq partialResult '|failed|) + '|failed| + (|hasCaty| d cat partialResult)))) + +\end{chunk} + +\defun{defaultTargetFE}{defaultTargetFE} +\calls{defaultTargetFE}{typeIsASmallInteger} +\calls{defaultTargetFE}{isEqualOrSubDomain} +\calls{defaultTargetFE}{ifcar} +\calls{defaultTargetFE}{defaultTargetFE} +\refsdollar{defaultTargetFE}{FunctionalExpression} +\refsdollar{defaultTargetFE}{Integer} +\refsdollar{defaultTargetFE}{Symbol} +\refsdollar{defaultTargetFE}{RationalNumber} +\begin{chunk}{defun defaultTargetFE} +(defun |defaultTargetFE| (&rest dom) + (let (a options d ud tmp1) + (declare (special |$FunctionalExpression| |$Integer| |$Symbol| + |$RationalNumber|)) + (setq a (car dom)) + (setq options (cdr dom)) + (cond + ((or (and (consp a) (eq (qcar a) '|Variable|) + (consp (qcdr a)) (eq (qcddr a) nil)) + (equal a |$RationalNumber|) + (member (qcar a) (list (qcar |$Symbol|) '|RationalRadicals| '|Pi|)) + (|typeIsASmallInteger| a) + (|isEqualOrSubDomain| a |$Integer|) + (equal a '(|AlgebraicNumber|))) + (if (ifcar options) + (list |$FunctionalExpression| (list '|Complex| |$Integer|)) + (list |$FunctionalExpression| |$Integer|))) + ((and (consp a) (eq (qcar a) '|Complex|) + (consp (qcdr a)) (eq (qcddr a) nil)) + (|defaultTargetFE| (qcadr a) t)) + ((and (consp a) (consp (qcdr a)) (eq (qcddr a) nil) + (member (qcar a) '(|Polynomial| |RationalFunction| |Fraction|))) + (|defaultTargetFE| (qcadr a) (ifcar options))) + ((and (consp a) (equal (qcar a) |$FunctionalExpression|) + (consp (qcdr a)) (eq (qcddr a) nil)) + a) + ((ifcar options) + (list |$FunctionalExpression| (list '|Complex| a))) + (t + (list |$FunctionalExpression| a))))) + +\end{chunk} + +\defun{isEqualOrSubDomain}{isEqualOrSubDomain} +\calls{isEqualOrSubDomain}{isSubDomain} +\begin{chunk}{defun isEqualOrSubDomain} +(defun |isEqualOrSubDomain| (d1 d2) + (let (tmp1) + (or (equal d1 d2) + (|isSubDomain| d1 d2) + (and (atom d1) + (or (and (consp d2) (eq (qcar d2) '|Variable|) + (consp (qcdr d2)) (eq (qcddr d2) nil) + (equal (qcadr d2) d1)) + (and (consp d2) (eq (qcdr d2) nil) + (equal (qcar d2) d1)))) + (and (atom d2) + (or (and (consp d1) (eq (qcar d1) '|Variable|) + (consp (qcdr d1)) (eq (qcddr d1) nil) + (equal (qcadr d1) d2)) + (and (consp d1) (eq (qcdr d1) nil) + (equal (qcar d1) d2))))))) + +\end{chunk} + \chapter{System Command Handling} The system commands are the top-level commands available in Axiom that can all be invoked by prefixing the symbol with a closed-paren. @@ -43575,11 +43999,15 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun compiledLookupCheck} \getchunk{defun compressOpen} \getchunk{defun constoken} +\getchunk{defun constructSubst} +\getchunk{defun containsVars} +\getchunk{defun containsVars1} \getchunk{defun copyright} \getchunk{defun countCache} \getchunk{defun DaaseName} \getchunk{defun decideHowMuch} +\getchunk{defun defaultTargetFE} \getchunk{defun defiostream} \getchunk{defun deldatabase} \getchunk{defun deleteFile} @@ -43715,8 +44143,12 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun hasAtt} \getchunk{defun hasAttSig} \getchunk{defun hasCatExpression} +\getchunk{defun hasCate} +\getchunk{defun hasCateSpecial} +\getchunk{defun hasCateSpecialNew} \getchunk{defun hasCate1} \getchunk{defun hasCaty} +\getchunk{defun hasCaty1} \getchunk{defun hashable} \getchunk{defun hasOption} \getchunk{defun hasPair} @@ -43803,6 +44235,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun iostat} \getchunk{defun isDomainOrPackage} \getchunk{defun isDomainValuedVariable} +\getchunk{defun isEqualOrSubDomain} \getchunk{defun isExposedConstructor} \getchunk{defun isgenvar} \getchunk{defun isInterpOnlyMap} @@ -43881,6 +44314,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun messageprint} \getchunk{defun messageprint-1} \getchunk{defun messageprint-2} +\getchunk{defun mkDomPvar} \getchunk{defun mkEvalable} \getchunk{defun mkEvalableMapping} \getchunk{defun mkEvalableRecord} @@ -44649,6 +45083,7 @@ This needs to work off the internal exposure list, not the file. \getchunk{defun undoSteps} \getchunk{defun unescapeStringsInForm} \getchunk{defun unifyStruct} +\getchunk{defun unifyStructVar} \getchunk{defun unsqueeze} \getchunk{defun untrace} \getchunk{defun untraceDomainConstructor} diff --git a/changelog b/changelog index 30cdc50..57856df 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,6 @@ +20111208 tpd src/axiom-website/patches.html 20111208.03.tpd.patch +20111208 tpd src/interp/i-funsel.lisp treeshake interpreter +20111208 tpd books/bookvol5 treeshake interpreter 20111208 tpd src/axiom-website/patches.html 20111208.02.tpd.patch 20111208 tpd src/axiom-website/documentation update contributor list 20111208 tpd src/axiom-website/patches.html 20111208.01.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index fd5b86a..8d29af9 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3729,5 +3729,7 @@ src/axiom-website/axiomgraph/index.html add graphs
books/bookvolbib add additional Axiom literature references
20111208.02.tpd.patch src/axiom-website/documentation update contributor list
+20111208.03.tpd.patch +books/bookvol5 treeshake interpreter
diff --git a/src/interp/i-funsel.lisp.pamphlet b/src/interp/i-funsel.lisp.pamphlet index 519b74b..b5cd117 100644 --- a/src/interp/i-funsel.lisp.pamphlet +++ b/src/interp/i-funsel.lisp.pamphlet @@ -1634,67 +1634,6 @@ (defun |mkRationalFunction| (d) `(|Fraction| (|Polynomial| ,d))) -;defaultTargetFE(a,:options) == -; a is ['Variable,.] or a = $RationalNumber or MEMQ(QCAR a, -; [QCAR $Symbol, 'RationalRadicals, -; 'Pi]) or typeIsASmallInteger(a) or isEqualOrSubDomain(a, $Integer) or -; a = '(AlgebraicNumber) => -; IFCAR options => [$FunctionalExpression, ['Complex, $Integer]] -; [$FunctionalExpression, $Integer] -; a is ['Complex,uD] => defaultTargetFE(uD, true) -; a is [D,uD] and MEMQ(D, '(Polynomial RationalFunction Fraction)) => -; defaultTargetFE(uD, IFCAR options) -; a is [=$FunctionalExpression,.] => a -; IFCAR options => [$FunctionalExpression, ['Complex, a]] -; [$FunctionalExpression, a] - -(DEFUN |defaultTargetFE| (&REST G166758 &AUX |options| |a|) - (DSETQ (|a| . |options|) G166758) - (PROG (D |uD| |ISTMP#1|) - (declare (special |$FunctionalExpression| |$Integer| |$Symbol| - |$RationalNumber|)) - (RETURN - (COND - ((OR (AND (CONSP |a|) (EQ (QCAR |a|) '|Variable|) - (PROGN - (setq |ISTMP#1| (QCDR |a|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - (BOOT-EQUAL |a| |$RationalNumber|) - (member (QCAR |a|) - (CONS (QCAR |$Symbol|) - (CONS '|RationalRadicals| (CONS '|Pi| NIL)))) - (|typeIsASmallInteger| |a|) - (|isEqualOrSubDomain| |a| |$Integer|) - (BOOT-EQUAL |a| '(|AlgebraicNumber|))) - (COND - ((IFCAR |options|) - (CONS |$FunctionalExpression| - (CONS (CONS '|Complex| (CONS |$Integer| NIL)) NIL))) - (t (CONS |$FunctionalExpression| (CONS |$Integer| NIL))))) - ((AND (CONSP |a|) (EQ (QCAR |a|) '|Complex|) - (PROGN - (setq |ISTMP#1| (QCDR |a|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (setq |uD| (QCAR |ISTMP#1|)) t)))) - (|defaultTargetFE| |uD| t)) - ((AND (CONSP |a|) - (PROGN - (setq D (QCAR |a|)) - (setq |ISTMP#1| (QCDR |a|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (setq |uD| (QCAR |ISTMP#1|)) t))) - (member D '(|Polynomial| |RationalFunction| |Fraction|))) - (|defaultTargetFE| |uD| (IFCAR |options|))) - ((AND (CONSP |a|) (EQUAL (QCAR |a|) |$FunctionalExpression|) - (PROGN - (setq |ISTMP#1| (QCDR |a|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL)))) - |a|) - ((IFCAR |options|) - (CONS |$FunctionalExpression| - (CONS (CONS '|Complex| (CONS |a| NIL)) NIL))) - (t (CONS |$FunctionalExpression| (CONS |a| NIL))))))) - ;altTypeOf(type,val,$declaredMode) == ; (EQCAR(type,'Symbol) or EQCAR(type,'Variable)) and ; (a := getMinimalVarMode(objValUnwrap getValue(val),$declaredMode)) => @@ -3458,23 +3397,6 @@ the types A and B themselves are not sorted by preference. ((|isPartialMode| |t1|) (|resolveTM| |t2| |t1|)) (t (|canCoerceFrom| |t2| |t1|)))))))))) -;constructSubst(d) == -; -- constructs a substitution which substitutes d for $ -; -- and the arguments of d for #1, #2 .. -; SL:= list CONS('$,d) -; for x in CDR d for i in 1.. repeat -; SL:= CONS(CONS(INTERNL('"#",STRINGIMAGE i),x),SL) -; SL - -(defun |constructSubst| (d) - (let (sl (i 0)) - (setq sl (list (cons '$ d))) - (when (listp d) - (dolist (x (cdr d)) - (setq i (1+ i)) - (setq sl (cons (cons (internl "#" (stringimage i)) x) sl)))) - sl)) - ;filterModemapsFromPackages(mms, names, op) == ; -- mms is a list of modemaps ; -- names is a list of domain constructors @@ -5140,537 +5062,6 @@ the types A and B themselves are not sorted by preference. ((NEQUAL |op| '|coerce|) '|failed|)))) (t NSL))))))) -;hasCate(dom,cat,SL) == -; -- asks whether dom has cat under SL -; -- augments substitution SL or returns 'failed -; dom = $EmptyMode => NIL -; isPatternVar dom => -; (p:= ASSQ(dom,SL)) and ((NSL := hasCate(CDR p,cat,SL)) ^= 'failed) => -; NSL -; (p:= ASSQ(dom,$Subst)) or (p := ASSQ(dom, SL)) => -;-- S:= hasCate(CDR p,cat,augmentSub(CAR p,CDR p,copy SL)) -; S:= hasCate1(CDR p,cat,SL, dom) -; not (S='failed) => S -; hasCateSpecial(dom,CDR p,cat,SL) -; if SL ^= 'failed then $hope:= t -; 'failed -; SL1 := [[v,:d] for [v,:d] in SL | not containsVariables d] -; if SL1 then cat := subCopy(cat, SL1) -; hasCaty(dom,cat,SL) - -(DEFUN |hasCate| (|dom| |cat| SL) - (PROG (NSL |p| S |v| |d| SL1) - (declare (special |$hope| |$Subst| |$EmptyMode|)) - (RETURN - (SEQ (COND - ((BOOT-EQUAL |dom| |$EmptyMode|) NIL) - ((|isPatternVar| |dom|) - (COND - ((AND (setq |p| (ASSQ |dom| SL)) - (NEQUAL (setq NSL - (|hasCate| (CDR |p|) |cat| SL)) - '|failed|)) - NSL) - ((OR (setq |p| (ASSQ |dom| |$Subst|)) - (setq |p| (ASSQ |dom| SL))) - (setq S (|hasCate1| (CDR |p|) |cat| SL |dom|)) - (COND - ((NULL (BOOT-EQUAL S '|failed|)) S) - (t (|hasCateSpecial| |dom| (CDR |p|) |cat| SL)))) - (t (COND ((NEQUAL SL '|failed|) (setq |$hope| t))) - '|failed|))) - (t - (setq SL1 - (PROG (G168806) - (setq G168806 NIL) - (RETURN - (DO ((G168813 SL (CDR G168813)) - (G168795 NIL)) - ((OR (ATOM G168813) - (PROGN - (SETQ G168795 (CAR G168813)) - NIL) - (PROGN - (PROGN - (setq |v| (CAR G168795)) - (setq |d| (CDR G168795)) - G168795) - NIL)) - (NREVERSE0 G168806)) - (SEQ (EXIT (COND - ((NULL - (|containsVariables| |d|)) - (SETQ G168806 - (CONS (CONS |v| |d|) - G168806)))))))))) - (COND (SL1 (setq |cat| (|subCopy| |cat| SL1)))) - (|hasCaty| |dom| |cat| SL))))))) - -;hasCateSpecial(v,dom,cat,SL) == -; -- v is a pattern variable, dom it's binding under $Subst -; -- tries to change dom, so that it has category cat under SL -; -- the result is a substitution list or 'failed -; dom is ['FactoredForm,arg] => -; if isSubDomain(arg,$Integer) then arg := $Integer -; d := ['FactoredRing,arg] -; SL:= hasCate(arg,'(Ring),augmentSub(v,d,SL)) -; SL = 'failed => 'failed -; hasCaty(d,cat,SL) -; EQCAR(cat,'Field) or EQCAR(cat, 'DivisionRing) => -; if isSubDomain(dom,$Integer) then dom := $Integer -; d:= eqType [$QuotientField, dom] -; hasCaty(dom,'(IntegralDomain),augmentSub(v,d,SL)) -; cat is ['PolynomialCategory, d, :.] => -; dom' := ['Polynomial, d] -; (containsVars d or canCoerceFrom(dom, dom')) -; and hasCaty(dom', cat, augmentSub(v,dom',SL)) -; isSubDomain(dom,$Integer) => -; NSL:= hasCate($Integer,cat,augmentSub(v,$Integer,SL)) -; NSL = 'failed => -; hasCateSpecialNew(v, dom, cat, SL) -; hasCaty($Integer,cat,NSL) -; hasCateSpecialNew(v, dom, cat, SL) - -(DEFUN |hasCateSpecial| (|v| |dom| |cat| SL) - (PROG (|arg| |ISTMP#1| |d| |dom'| NSL) - (declare (special |$Integer| |$QuotientField|)) - (RETURN - (COND - ((AND (CONSP |dom|) (EQ (QCAR |dom|) '|FactoredForm|) - (PROGN - (setq |ISTMP#1| (QCDR |dom|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (setq |arg| (QCAR |ISTMP#1|)) t)))) - (COND - ((|isSubDomain| |arg| |$Integer|) - (setq |arg| |$Integer|))) - (setq |d| (CONS '|FactoredRing| (CONS |arg| NIL))) - (setq SL - (|hasCate| |arg| '(|Ring|) (|augmentSub| |v| |d| SL))) - (COND - ((BOOT-EQUAL SL '|failed|) '|failed|) - (t (|hasCaty| |d| |cat| SL)))) - ((OR (EQCAR |cat| '|Field|) (EQCAR |cat| '|DivisionRing|)) - (COND - ((|isSubDomain| |dom| |$Integer|) - (setq |dom| |$Integer|))) - (setq |d| - (CONS |$QuotientField| (CONS |dom| NIL))) - (|hasCaty| |dom| '(|IntegralDomain|) - (|augmentSub| |v| |d| SL))) - ((AND (CONSP |cat|) (EQ (QCAR |cat|) '|PolynomialCategory|) - (PROGN - (setq |ISTMP#1| (QCDR |cat|)) - (AND (CONSP |ISTMP#1|) - (PROGN (setq |d| (QCAR |ISTMP#1|)) t)))) - (setq |dom'| (CONS '|Polynomial| (CONS |d| NIL))) - (AND (OR (|containsVars| |d|) (|canCoerceFrom| |dom| |dom'|)) - (|hasCaty| |dom'| |cat| (|augmentSub| |v| |dom'| SL)))) - ((|isSubDomain| |dom| |$Integer|) - (setq NSL - (|hasCate| |$Integer| |cat| - (|augmentSub| |v| |$Integer| SL))) - (COND - ((BOOT-EQUAL NSL '|failed|) - (|hasCateSpecialNew| |v| |dom| |cat| SL)) - (t (|hasCaty| |$Integer| |cat| NSL)))) - (t (|hasCateSpecialNew| |v| |dom| |cat| SL)))))) - -;-- to be used in $newSystem only -;hasCateSpecialNew(v,dom,cat,SL) == -; fe := member(QCAR cat, '(ElementaryFunctionCategory -; TrigonometricFunctionCategory ArcTrigonometricFunctionCategory -; HyperbolicFunctionCategory ArcHyperbolicFunctionCategory -; PrimitiveFunctionCategory SpecialFunctionCategory Evalable -; CombinatorialOpsCategory TranscendentalFunctionCategory -; AlgebraicallyClosedFunctionSpace ExpressionSpace -; LiouvillianFunctionCategory FunctionSpace)) -; alg := member(QCAR cat, '(RadicalCategory AlgebraicallyClosedField)) -; fefull := fe or alg or EQCAR(cat, 'CombinatorialFunctionCategory) -; partialResult := -; EQCAR(dom, 'Variable) or EQCAR(dom, 'Symbol) => -; CAR(cat) in -; '(SemiGroup AbelianSemiGroup Monoid AbelianGroup AbelianMonoid -; PartialDifferentialRing Ring InputForm) => -; d := ['Polynomial, $Integer] -; augmentSub(v, d, SL) -; EQCAR(cat, 'Group) => -; d := ['Fraction, ['Polynomial, $Integer]] -; augmentSub(v, d, SL) -; fefull => -; d := defaultTargetFE dom -; augmentSub(v, d, SL) -; 'failed -; isEqualOrSubDomain(dom, $Integer) => -; fe => -; d := defaultTargetFE $Integer -; augmentSub(v, d, SL) -; alg => -; d := '(AlgebraicNumber) -; --d := defaultTargetFE $Integer -; augmentSub(v, d, SL) -; 'failed -; underDomainOf dom = $ComplexInteger => -; d := defaultTargetFE $ComplexInteger -; hasCaty(d,cat,augmentSub(v, d, SL)) -; (dom = $RationalNumber) and alg => -; d := '(AlgebraicNumber) -; --d := defaultTargetFE $Integer -; augmentSub(v, d, SL) -; fefull => -; d := defaultTargetFE dom -; augmentSub(v, d, SL) -; 'failed -; partialResult = 'failed => 'failed -; hasCaty(d, cat, partialResult) - -(DEFUN |hasCateSpecialNew| (|v| |dom| |cat| SL) - (PROG (|fe| |alg| |fefull| |d| |partialResult|) - (declare (special |$RationalNumber| |$ComplexInteger| |$Integer|)) - (RETURN - (PROGN - (setq |fe| - (|member| (QCAR |cat|) - '(|ElementaryFunctionCategory| - |TrigonometricFunctionCategory| - |ArcTrigonometricFunctionCategory| - |HyperbolicFunctionCategory| - |ArcHyperbolicFunctionCategory| - |PrimitiveFunctionCategory| - |SpecialFunctionCategory| |Evalable| - |CombinatorialOpsCategory| - |TranscendentalFunctionCategory| - |AlgebraicallyClosedFunctionSpace| - |ExpressionSpace| - |LiouvillianFunctionCategory| - |FunctionSpace|))) - (setq |alg| - (|member| (QCAR |cat|) - '(|RadicalCategory| |AlgebraicallyClosedField|))) - (setq |fefull| - (OR |fe| |alg| - (EQCAR |cat| '|CombinatorialFunctionCategory|))) - (setq |partialResult| - (COND - ((OR (EQCAR |dom| '|Variable|) - (EQCAR |dom| '|Symbol|)) - (COND - ((|member| (CAR |cat|) - '(|SemiGroup| |AbelianSemiGroup| |Monoid| - |AbelianGroup| |AbelianMonoid| - |PartialDifferentialRing| |Ring| - |InputForm|)) - (setq |d| - (CONS '|Polynomial| - (CONS |$Integer| NIL))) - (|augmentSub| |v| |d| SL)) - ((EQCAR |cat| '|Group|) - (setq |d| - (CONS '|Fraction| - (CONS - (CONS '|Polynomial| - (CONS |$Integer| NIL)) - NIL))) - (|augmentSub| |v| |d| SL)) - (|fefull| (setq |d| (|defaultTargetFE| |dom|)) - (|augmentSub| |v| |d| SL)) - (t '|failed|))) - ((|isEqualOrSubDomain| |dom| |$Integer|) - (COND - (|fe| (setq |d| - (|defaultTargetFE| |$Integer|)) - (|augmentSub| |v| |d| SL)) - (|alg| (setq |d| '(|AlgebraicNumber|)) - (|augmentSub| |v| |d| SL)) - (t '|failed|))) - ((BOOT-EQUAL (|underDomainOf| |dom|) - |$ComplexInteger|) - (setq |d| (|defaultTargetFE| |$ComplexInteger|)) - (|hasCaty| |d| |cat| (|augmentSub| |v| |d| SL))) - ((AND (BOOT-EQUAL |dom| |$RationalNumber|) |alg|) - (setq |d| '(|AlgebraicNumber|)) - (|augmentSub| |v| |d| SL)) - (|fefull| (setq |d| (|defaultTargetFE| |dom|)) - (|augmentSub| |v| |d| SL)) - (t '|failed|))) - (COND - ((BOOT-EQUAL |partialResult| '|failed|) '|failed|) - (t (|hasCaty| |d| |cat| |partialResult|))))))) - -;mkDomPvar(p, d, subs, y) == -; l := MEMQ(p, $FormalMapVariableList) => -; domArg(d, #$FormalMapVariableList - #l, subs, y) -; d - -(defun |mkDomPvar| (p d subs y) - (let (l) - (declare (special |$FormalMapVariableList|)) - (if (setq l (member p |$FormalMapVariableList|)) - (|domArg| d (- (|#| |$FormalMapVariableList|) (|#| l)) subs y) - d))) - -;hasCaty1(cond,SL) == -; -- cond is either a (has a b) or an OR clause of such conditions -; -- SL is augmented, if cond is true, otherwise the result is 'failed -; $domPvar: local := NIL -; cond is ['has,a,b] => hasCate(a,b,SL) -; cond is ['AND,:args] => -; for x in args while not (S='failed) repeat S:= -; x is ['has,a,b] => hasCate(a,b, SL) -; -- next line is for an obscure bug in the table -; x is [['has,a,b]] => hasCate(a,b, SL) -; --'failed -; hasCaty1(x, SL) -; S -; cond is ['OR,:args] => -; for x in args until not (S='failed) repeat S:= -; x is ['has,a,b] => hasCate(a,b,copy SL) -; -- next line is for an obscure bug in the table -; x is [['has,a,b]] => hasCate(a,b,copy SL) -; --'failed -; hasCaty1(x, copy SL) -; S -; keyedSystemError("S2GE0016", -; ['"hasCaty1",'"unexpected condition from category table"]) - -(DEFUN |hasCaty1| (|cond| SL) - (PROG (|$domPvar| |args| |ISTMP#1| |ISTMP#2| |a| |ISTMP#3| |b| S) - (DECLARE (SPECIAL |$domPvar|)) - (RETURN - (SEQ (PROGN - (setq |$domPvar| NIL) - (COND - ((AND (CONSP |cond|) (EQ (QCAR |cond|) '|has|) - (PROGN - (setq |ISTMP#1| (QCDR |cond|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |a| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (setq |b| (QCAR |ISTMP#2|)) - t)))))) - (|hasCate| |a| |b| SL)) - ((AND (CONSP |cond|) (EQ (QCAR |cond|) 'AND) - (PROGN (setq |args| (QCDR |cond|)) t)) - (DO ((G169191 |args| (CDR G169191)) (|x| NIL)) - ((OR (ATOM G169191) - (PROGN (SETQ |x| (CAR G169191)) NIL) - (NULL (NULL (BOOT-EQUAL S '|failed|)))) - NIL) - (SEQ (EXIT (setq S - (COND - ((AND (CONSP |x|) - (EQ (QCAR |x|) '|has|) - (PROGN - (setq |ISTMP#1| - (QCDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |a| - (QCAR |ISTMP#1|)) - (setq |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (setq |b| - (QCAR |ISTMP#2|)) - t)))))) - (|hasCate| |a| |b| SL)) - ((AND (CONSP |x|) - (EQ (QCDR |x|) NIL) - (PROGN - (setq |ISTMP#1| - (QCAR |x|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) - '|has|) - (PROGN - (setq |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |a| - (QCAR |ISTMP#2|)) - (setq |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND - (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) - NIL) - (PROGN - (setq |b| - (QCAR |ISTMP#3|)) - t)))))))) - (|hasCate| |a| |b| SL)) - (t (|hasCaty1| |x| SL))))))) - S) - ((AND (CONSP |cond|) (EQ (QCAR |cond|) 'OR) - (PROGN (setq |args| (QCDR |cond|)) t)) - (DO ((G169218 |args| (CDR G169218)) (|x| NIL) - (G169219 NIL (NULL (BOOT-EQUAL S '|failed|)))) - ((OR (ATOM G169218) - (PROGN (SETQ |x| (CAR G169218)) NIL) - G169219) - NIL) - (SEQ (EXIT (setq S - (COND - ((AND (CONSP |x|) - (EQ (QCAR |x|) '|has|) - (PROGN - (setq |ISTMP#1| - (QCDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |a| - (QCAR |ISTMP#1|)) - (setq |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (setq |b| - (QCAR |ISTMP#2|)) - t)))))) - (|hasCate| |a| |b| (COPY SL))) - ((AND (CONSP |x|) - (EQ (QCDR |x|) NIL) - (PROGN - (setq |ISTMP#1| - (QCAR |x|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) - '|has|) - (PROGN - (setq |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |a| - (QCAR |ISTMP#2|)) - (setq |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND - (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) - NIL) - (PROGN - (setq |b| - (QCAR |ISTMP#3|)) - t)))))))) - (|hasCate| |a| |b| (COPY SL))) - (t (|hasCaty1| |x| (COPY SL)))))))) - S) - (t - (|keyedSystemError| 'S2GE0016 - (CONS "hasCaty1" - (CONS "unexpected condition from category table" - NIL)))))))))) - -;unifyStructVar(v,s,SL) == -; -- the first argument is a pattern variable, which is not substituted -; -- by SL -; CONTAINED(v,s) => 'failed -; ps := LASSOC(s, SL) -; s1 := (ps => ps; s) -; (s0 := LASSOC(v, SL)) or (s0 := LASSOC(v,$Subst)) => -; S:= unifyStruct(s0,s1,copy SL) -; S='failed => -; $Coerce and not atom s0 and constructor? CAR s0 => -; containsVars s0 or containsVars s1 => -; ns0 := subCopy(s0, SL) -; ns1 := subCopy(s1, SL) -; containsVars ns0 or containsVars ns1 => -; $hope:= t -; 'failed -; if canCoerce(ns0, ns1) then s3 := s1 -; else if canCoerce(ns1, ns0) then s3 := s0 -; else s3 := nil -; s3 => -; if (s3 ^= s0) then SL := augmentSub(v,s3,SL) -; if (s3 ^= s1) and isPatternVar(s) then SL := augmentSub(s,s3,SL) -; SL -; 'failed -; $domPvar => -; s3 := resolveTT(s0,s1) -; s3 => -; if (s3 ^= s0) then SL := augmentSub(v,s3,SL) -; if (s3 ^= s1) and isPatternVar(s) then SL := augmentSub(s,s3,SL) -; SL -; 'failed -;-- isSubDomain(s,s0) => augmentSub(v,s0,SL) -; 'failed -; 'failed -; augmentSub(v,s,S) -; augmentSub(v,s,SL) - -(DEFUN |unifyStructVar| (|v| |s| SL) - (PROG (|ps| |s1| |s0| S |ns0| |ns1| |s3|) - (declare (special |$domPvar| |$hope| |$Coerce| |$Subst|)) - (RETURN - (COND - ((CONTAINED |v| |s|) '|failed|) - (t (setq |ps| (LASSOC |s| SL)) - (setq |s1| (COND (|ps| |ps|) (t |s|))) - (COND - ((OR (setq |s0| (LASSOC |v| SL)) - (setq |s0| (LASSOC |v| |$Subst|))) - (setq S (|unifyStruct| |s0| |s1| (COPY SL))) - (COND - ((BOOT-EQUAL S '|failed|) - (COND - ((AND |$Coerce| (NULL (ATOM |s0|)) - (|constructor?| (CAR |s0|))) - (COND - ((OR (|containsVars| |s0|) (|containsVars| |s1|)) - (setq |ns0| (|subCopy| |s0| SL)) - (setq |ns1| (|subCopy| |s1| SL)) - (COND - ((OR (|containsVars| |ns0|) - (|containsVars| |ns1|)) - (setq |$hope| t) '|failed|) - (t - (COND - ((|canCoerce| |ns0| |ns1|) - (setq |s3| |s1|)) - ((|canCoerce| |ns1| |ns0|) - (setq |s3| |s0|)) - (t (setq |s3| NIL))) - (COND - (|s3| (COND - ((NEQUAL |s3| |s0|) - (setq SL - (|augmentSub| |v| |s3| SL)))) - (COND - ((AND (NEQUAL |s3| |s1|) - (|isPatternVar| |s|)) - (setq SL - (|augmentSub| |s| |s3| SL)))) - SL) - (t '|failed|))))) - (|$domPvar| (setq |s3| (|resolveTT| |s0| |s1|)) - (COND - (|s3| (COND - ((NEQUAL |s3| |s0|) - (setq SL - (|augmentSub| |v| |s3| SL)))) - (COND - ((AND (NEQUAL |s3| |s1|) - (|isPatternVar| |s|)) - (setq SL - (|augmentSub| |s| |s3| SL)))) - SL) - (t '|failed|))) - (t '|failed|))) - (t '|failed|))) - (t (|augmentSub| |v| |s| S)))) - (t (|augmentSub| |v| |s| SL)))))))) - ;printMms(mmS) == ; -- mmS a list of modemap signatures ; sayMSG '" "