summaryrefslogtreecommitdiffstats
path: root/cring.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commitfa3f23105ddcf07c5900de47f19af43d1db1b597 (patch)
treeb2c6cce6b97698098f50cbc78c23fdc0f8d401ab /cring.scm
parentf24b9140d6f74804d5599ec225717d38ca443813 (diff)
downloadslib-fa3f23105ddcf07c5900de47f19af43d1db1b597.tar.gz
slib-fa3f23105ddcf07c5900de47f19af43d1db1b597.zip
Import Upstream version 2c3upstream/2c3
Diffstat (limited to 'cring.scm')
-rw-r--r--cring.scm137
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)))