oldk1331 / fricas Goto Github PK

diff --git a/src/algebra/attribs.spad b/src/algebra/attribs.spad
index 16dbd857..303f3efd 100644
--- a/src/algebra/attribs.spad
+++ b/src/algebra/attribs.spad
@@ -52,7 +52,7 @@

 )abbrev category ATAPPRO Approximate
 ++ Description:
-++ An approximation to the real numbers.
+++ An approximation to numbers.
 Approximate() : Category == with ()

 )abbrev category ATADDVA additiveValuation
diff --git a/src/algebra/combfunc.spad b/src/algebra/combfunc.spad
index 4f821f5a..d2d33327 100644
--- a/src/algebra/combfunc.spad
+++ b/src/algebra/combfunc.spad
@@ -318,7 +318,7 @@
       zero? second l => 1
       kernel(opperm, l)

-    if R has RetractableTo Z then
+    if R has RetractableTo Z and not R has Approximate then
       iidsum l ==
         (r1 := retractIfCan(fourth l)@Union(Z,"failed"))
          case "failed" or
@@ -360,8 +360,8 @@
       ipow l ==
         zero?(x := first l) =>
           zero? second l => error "0 ^ 0"
-          0
-        (x = 1) or zero?(n : F := second l) => 1
+          kernel(oppow, l)
+        zero?(n : F := second l) => 1
         (n = 1) => x
         (u := isExpt(x, OPEXP)) case "failed" => kernel(oppow, l)
         rec := u::Record(var : K, exponent : Z)
diff --git a/src/algebra/gaussian.spad b/src/algebra/gaussian.spad
index 21c8c593..8fc0fb15 100644
--- a/src/algebra/gaussian.spad
+++ b/src/algebra/gaussian.spad
@@ -40,6 +40,7 @@
        abs : % -> %
          ++ abs(x) returns the absolute value of x = sqrt(norm(x)).
      if R has arbitraryPrecision then arbitraryPrecision
+     if R has Approximate then Approximate
      if R has TranscendentalFunctionCategory then
        TranscendentalFunctionCategory

--- a/src/interp/nrunfast.boot
+++ b/src/interp/nrunfast.boot
@@ -424,6 +424,8 @@
                        newHasTest(w1,w2)
                   l is [ w1, ['SIGNATURE, :w2]] =>
                       compiledLookup(first w2, CADR w2, eval mkEvalable w1)
+                  -- if the pred is "if $ has aCat then aCat", return false
+                  w1 = '$ => false
                   newHasTest(first  l ,first rest l)
              pred = 'OR => or/[evalCond i for i in l]
              pred = 'AND => and/[evalCond i for i in l]

diff --git a/src/algebra/expr.spad b/src/algebra/expr.spad
index 684f6165..ecaba08d 100644
--- a/src/algebra/expr.spad
+++ b/src/algebra/expr.spad
@@ -32,8 +32,6 @@
         ++ present in f by applying their defining relations.
       number? : % -> Boolean
         ++ number?(f) tests if f is rational
-      simplifyPower : (%, Integer) -> %
-        ++ simplifyPower(f, n) \undocumented{}
       if R has PolynomialFactorizationExplicit then
           PolynomialFactorizationExplicit
       setSimplifyDenomsFlag : Boolean -> Boolean
@@ -90,6 +88,7 @@
             algkernels : List K -> List K
             evl       : (MP, K, SparseUnivariatePolynomial %) -> Fraction MP
             evl0      : (MP, K) -> SparseUnivariatePolynomial Fraction MP
+            simplifyPower : (%, Integer) -> %
 
             Rep := Fraction MP
             0                == 0$Rep

--- a/src/algebra/float.spad
+++ b/src/algebra/float.spad
@@ -690,6 +690,7 @@
             return ((-x)^r)
          error "negative root"
       if d = 2 then
+         n = 1 => return sqrt(x)
          inc LENGTH n; y := sqrt(x); y := y^n; dec LENGTH n
          return normalize y
       y := [n, 0]/[d, 0]

--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -576,7 +576,7 @@
     --  u := removeZeroOneDestructively u
     null u => u          -- this can happen for Object
     CAAR u = '_$unique => rest u
-    f := addConsDB '(NIL T ELT)
+    f := '(NIL T ELT)
     for [op, :sigList] in u repeat
         for items in tails sigList repeat
             [sig, :r] := first items
@@ -586,7 +586,7 @@
                     else RPLACD(s, QCDDR f)
                 else RPLACD(r, QCDR f)
             else RPLACD(first items, f)
-            RPLACA(items, addConsDB first items)
+            RPLACA(items, first items)
     u and markUnique u

 markUnique x ==
@@ -594,9 +594,3 @@
     RPLACA(x, '(_$unique))
     RPLACD(x, [u, :rest x])
     rest x
-
---=======================================================================
---          Creation of System Sig/Pred Vectors & Hash Tables
---=======================================================================
-
-addConsDB x == x

--- a/src/algebra/algfunc.spad
+++ b/src/algebra/algfunc.spad
@@ -529,9 +529,14 @@
         if R has RadicalCategory then
           if R has imaginary : () -> R then iroot(r, n) == nthRoot(r, n)::F
           else
-            iroot(r, n) ==
-              odd? n or not(smaller?(r, 0)) => nthRoot(r, n)::F
-              iroot0(r, n)
+              if R has FloatingPointSystem then
+                  iroot(r, n) ==
+                      odd? n or not(smaller?(r, 0)) => nthRoot(r, n)::F
+                      hackroot(r::F, n)
+              else
+                  iroot(r, n) ==
+                      odd? n or not(smaller?(r, 0)) => nthRoot(r, n)::F
+                      iroot0(r, n)

         else iroot(r, n) == iroot0(r, n)