Import Upstream version 2c3upstream/2c3

1 files changed, 47 insertions, 90 deletions

diff --git a/cring.scm b/cring.scm
index 3f594bc..c3d67cd 100644
--- a/cring.scm
+++ b/cring.scm
@@ -81,40 +81,6 @@
 (define number0? zero?)
 (define (zero? x) (and (number? x) (number0? x)))
 
-(define (make-rat n d)
-  (let* ((g (if (negative? d) (number- (gcd n d)) (gcd n d)))
-	 (n/g (quotient n g))
-	 (d/g (quotient d g)))
-    (case d/g
-      ((1) n/g)
-      (else
-       (case n/g
-	 ((0) 0)
-	 ((1) (list '/ d/g))
-	 (else (list '/ n/g d/g)))))))
-
-(define (rat-number? r)
-  (and (list? r)
-       (<= 2 (length r) 3)
-       (eq? '/ (car r))
-       (every number? (cdr r))))
-
-(define (rat-numerator r)
-  (cond ((number? r) r)
-	((rat-number? r)
-	 (case (length r)
-	   ((2) 1)
-	   ((3) (cadr r))))
-	(else (slib:error 'rat-numerator "of non-rat" r))))
-
-(define (rat-denominator r)
-  (cond ((number? r) 1)
-	((rat-number? r)
-	 (case (length r)
-	   ((2) (cadr r))
-	   ((3) (caddr r))))
-	(else (slib:error 'rat-denominator "of non-rat" r))))
-
 ;; To convert to CR internal form, NUMBER-op all the `numbers' in the
 ;; argument list and remove them from the argument list.  Collect the
 ;; remaining arguments into equivalence classes, keeping track of the
@@ -124,55 +90,41 @@
 ;;; Converts * argument list to CR internal form
 (define (cr*-args->fcts args)
   ;;(print (cons 'cr*-args->fcts args) '==>)
-  (let loop ((args args) (pow 1) (nums 1) (denoms 1) (arg.exps '()))
+  (let loop ((args args) (pow 1) (nums 1) (arg.exps '()))
     ;;(print (list 'loop args pow nums denoms arg.exps) '==>)
-    (cond ((null? args) (cons (make-rat nums denoms) arg.exps))
+    (cond ((null? args) (cons nums arg.exps))
 	  ((number? (car args))
 	   (let ((num^pow (number^ (car args) (abs pow))))
 	     (if (negative? pow)
-		 (loop (cdr args) pow nums (number* num^pow denoms) arg.exps)
-		 (loop (cdr args) pow (number* num^pow nums) denoms arg.exps))))
-	  ((rat-number? (car args))
-	   (let ((num^pow (number^ (rat-numerator (car args)) (abs pow)))
-		 (den^pow (number^ (rat-denominator (car args)) (abs pow))))
-	     (if (negative? pow)
-		 (loop (cdr args) pow
-		       (number* den^pow nums)
-		       (number* num^pow denoms) arg.exps)
-		 (loop (cdr args) pow
-		       (number* num^pow nums)
-		       (number* den^pow denoms) arg.exps))))
+		 (loop (cdr args) pow (number/ (number* num^pow nums))
+		       arg.exps)
+		 (loop (cdr args) pow (number* num^pow nums) arg.exps))))
 	  ;; Associative Rule
 	  ((is-term-op? (car args) '*) (loop (append (cdar args) (cdr args))
-					     pow
-					     nums denoms
-					     arg.exps))
+					     pow nums arg.exps))
 	  ;; Do singlet -
 	  ((and (is-term-op? (car args) '-) (= 2 (length (car args))))
 	   ;;(print 'got-here (car args))
-	   (set! arg.exps (loop (cdar args) pow (number- nums) denoms arg.exps))
+	   (set! arg.exps (loop (cdar args) pow (number- nums) arg.exps))
 	   (loop (cdr args) pow
-		 (rat-numerator (car arg.exps))
-		 (rat-denominator (car arg.exps))
+		 (car arg.exps)
 		 (cdr arg.exps)))
 	  ((and (is-term-op? (car args) '/) (= 2 (length (car args))))
 	   ;; Do singlet /
 	   ;;(print 'got-here=cr+ (car args))
-	   (set! arg.exps (loop (cdar args) (number- pow) nums denoms arg.exps))
+	   (set! arg.exps (loop (cdar args) (number- pow) nums arg.exps))
 	   (loop (cdr args) pow
-		 (rat-numerator (car arg.exps))
-		 (rat-denominator (car arg.exps))
+		 (car arg.exps)
 		 (cdr arg.exps)))
 	  ((is-term-op? (car args) '/)
 	   ;; Do multi-arg /
 	   ;;(print 'doing '/ (cddar args) (number- pow))
 	   (set! arg.exps
-		 (loop (cddar args) (number- pow) nums denoms arg.exps))
+		 (loop (cddar args) (number- pow) nums arg.exps))
 	   ;;(print 'finishing '/ (cons (cadar args) (cdr args)) pow)
 	   (loop (cons (cadar args) (cdr args))
 		 pow
-		 (rat-numerator (car arg.exps))
-		 (rat-denominator (car arg.exps))
+		 (car arg.exps)
 		 (cdr arg.exps)))
 	  ;; Pull out numeric exponents as powers
 	  ((and (is-term-op? (car args) '^)
@@ -180,17 +132,15 @@
 		(number? (caddar args)))
 	   (set! arg.exps (loop (list (cadar args))
 				(number* pow (caddar args))
-				nums denoms
+				nums
 				arg.exps))
-	   (loop (cdr args) pow
-		 (rat-numerator (car arg.exps))
-		 (rat-denominator (car arg.exps)) (cdr arg.exps)))
+	   (loop (cdr args) pow (car arg.exps) (cdr arg.exps)))
 	  ;; combine with same terms
 	  ((assoc (car args) arg.exps)
 	   => (lambda (pair) (set-cdr! pair (number+ pow (cdr pair)))
-		      (loop (cdr args) pow nums denoms arg.exps)))
+		      (loop (cdr args) pow nums arg.exps)))
 	  ;; Add new term to arg.exps
-	  (else (loop (cdr args) pow nums denoms
+	  (else (loop (cdr args) pow nums
 		      (cons (cons (car args) pow) arg.exps))))))
 
 ;;; Converts + argument list to CR internal form
@@ -282,6 +232,7 @@
 (define (* . args)
   (cond
    ((null? args) 1)
+   ;;This next line is commented out so ^ will collapse numerical expressions.
    ;;((null? (cdr args)) (car args))
    (else
     (let ((in (cr*-args->fcts args)))
@@ -295,18 +246,25 @@
 		     '* 1 '/ '^
 		     (apply
 		      (lambda (numeric red.cofs res.cofs)
+			(set! num numeric)
 			(append
-			 (cond ((number? numeric)
-				(set! num numeric)
-				(list (cons (abs numeric) 1)))
-			       (else
-				(set! num (rat-numerator numeric))
-				(list (cons (abs num) 1)
-				      (cons (rat-denominator numeric) -1))))
+			 ;;(list (cons (abs numeric) 1))
 			 red.cofs
 			 res.cofs))
 		      (cr1 '* number* '^ '/ (car in) (cdr in))))))
-	  (if (negative? num) (list '- ans) ans))))))))
+	  (cond ((number0? (+ -1 num)) ans)
+		((number? ans) (number* num ans))
+		((number0? (+ 1 num))
+		 (if (and (list? ans) (= 2 (length ans)) (eq? '- (car ans)))
+		     (cadr ans)
+		     (list '- ans)))
+		((not (pair? ans)) (list '* num ans))
+		(else
+		 (case (car ans)
+		   ((*) (append (list '* num) (cdr ans)))
+		   ((+) (apply + (map (lambda (mon) (* num mon)) (cdr ans))))
+		   ((-) (apply - (map (lambda (mon) (* num mon)) (cdr ans))))
+		   (else (list '* num ans))))))))))))
 
 (define (+ . args)
   (cond ((null? args) 0)
@@ -360,23 +318,21 @@
 (define (cr1 op number-op hop inv-op numeric in)
   (define red.pows '())
   (define res.pows '())
+  (define (cring:apply-rule->terms exp1 exp2) ;(display op)
+    (let ((ans (cring:apply-rule op exp1 exp2)))
+      (cond ((not ans) #f)
+	    ((number? ans) (list ans))
+	    (else (list (cons ans 1))))))
+  (define (cring:apply-inv-rule->terms exp1 exp2) ;(display inv-op)
+    (let ((ans (cring:apply-rule inv-op exp1 exp2)))
+      (cond ((not ans) #f)
+	    ((number? ans) (list ans))
+	    (else (list (cons ans 1))))))
   (let loop.arg.pow.s ((arg (caar in)) (pow (cdar in)) (arg.pows (cdr in)))
     (define (arg-loop arg.pows)
-      (if (null? arg.pows)
-	  (list numeric red.pows res.pows)
-	  (loop.arg.pow.s (caar arg.pows) (cdar arg.pows) (cdr arg.pows))))
-    (define (cring:apply-rule->terms exp1 exp2)
-      ;;(display op)
-      (let ((ans (cring:apply-rule op exp1 exp2)))
-	(cond ((not ans) #f)
-	      ((number? ans) (list ans))
-	      (else (list (cons ans 1))))))
-    (define (cring:apply-inv-rule->terms exp1 exp2)
-      ;;(display inv-op)
-      (let ((ans (cring:apply-rule inv-op exp1 exp2)))
-	(cond ((not ans) #f)
-	      ((number? ans) (list ans))
-	      (else (list (cons ans 1))))))
+      (cond ((not (null? arg.pows))
+	     (loop.arg.pow.s (caar arg.pows) (cdar arg.pows) (cdr arg.pows)))
+	    (else (list numeric red.pows res.pows)))) ; Actually return!
     (define (merge-res tmp.pows multiplicity)
       (cond ((null? tmp.pows))
 	    ((number? (car tmp.pows))
@@ -452,7 +408,8 @@
 	    (else #f)))
     ;;(print op numeric 'arg arg 'pow pow 'arg.pows arg.pows 'red.pows red.pows 'res.pows res.pows)
     ;;(trace arg-loop cring:apply-rule->terms merge-res try-fct.pow) (set! *qp-width* 333)
-    (cond ((or (zero? pow) (number? arg)) (arg-loop arg.pows))
+    (cond ((or (zero? pow) (eqv? 1 arg)) ;(number? arg) arg seems to always be 1
+	   (arg-loop arg.pows))
 	  ((assoc arg res.pows) => (lambda (pair)
 				     (set-cdr! pair (number+ pow (cdr pair)))
 				     (arg-loop arg.pows)))