diff options
Diffstat (limited to 'cring.scm')
| -rw-r--r-- | cring.scm | 137 |
1 files changed, 47 insertions, 90 deletions
@@ -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))) |