diff options
Diffstat (limited to 'cring.scm')
| -rw-r--r-- | cring.scm | 266 |
1 files changed, 133 insertions, 133 deletions
@@ -127,144 +127,144 @@ ;;; 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) (arg.exps '())) - ;;(print (list 'loop args pow nums denoms arg.exps) '==>) - (cond ((null? args) (cons nums 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 nums arg_exps)) ((number? (car args)) (let ((num^pow (number^ (car args) (abs pow)))) (if (negative? pow) (loop (cdr args) pow (number/ (number* num^pow nums)) - arg.exps) - (loop (cdr args) pow (number* num^pow nums) arg.exps)))) + 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 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) arg.exps)) + (set! arg_exps (loop (cdar args) pow (number- nums) arg_exps)) (loop (cdr args) pow - (car arg.exps) - (cdr 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 arg.exps)) + (set! arg_exps (loop (cdar args) (number- pow) nums arg_exps)) (loop (cdr args) pow - (car arg.exps) - (cdr 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 arg.exps)) + (set! 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 - (car arg.exps) - (cdr arg.exps))) + (car arg_exps) + (cdr arg_exps))) ;; Pull out numeric exponents as powers ((and (is-term-op? (car args) '^) (= 3 (length (car args))) (number? (caddar args))) - (set! arg.exps (loop (list (cadar args)) + (set! arg_exps (loop (list (cadar args)) (number* pow (caddar args)) nums - arg.exps)) - (loop (cdr args) pow (car arg.exps) (cdr arg.exps))) + arg_exps)) + (loop (cdr args) pow (car arg_exps) (cdr arg_exps))) ;; combine with same terms - ((assoc (car args) arg.exps) + ((assoc (car args) arg_exps) => (lambda (pair) (set-cdr! pair (number+ pow (cdr pair))) - (loop (cdr args) pow nums arg.exps))) - ;; Add new term to arg.exps + (loop (cdr args) pow nums arg_exps))) + ;; Add new term to arg_exps (else (loop (cdr args) pow nums - (cons (cons (car args) pow) arg.exps)))))) + (cons (cons (car args) pow) arg_exps)))))) ;;; Converts + argument list to CR internal form (define (cr+-args->trms args) - (let loop ((args args) (cof 1) (numbers 0) (arg.exps '())) - (cond ((null? args) (cons numbers arg.exps)) + (let loop ((args args) (cof 1) (numbers 0) (arg_exps '())) + (cond ((null? args) (cons numbers arg_exps)) ((number? (car args)) (loop (cdr args) cof (number+ (number* (car args) cof) numbers) - arg.exps)) + arg_exps)) ;; Associative Rule ((is-term-op? (car args) '+) (loop (append (cdar args) (cdr args)) cof numbers - arg.exps)) + arg_exps)) ;; Idempotent singlet * ((and (is-term-op? (car args) '*) (= 2 (length (car args)))) (loop (cons (cadar args) (cdr args)) cof numbers - arg.exps)) + arg_exps)) ((and (is-term-op? (car args) '-) (= 2 (length (car args)))) ;; Do singlet - - (set! arg.exps (loop (cdar args) (number- cof) numbers arg.exps)) - (loop (cdr args) cof (car arg.exps) (cdr arg.exps))) + (set! arg_exps (loop (cdar args) (number- cof) numbers arg_exps)) + (loop (cdr args) cof (car arg_exps) (cdr arg_exps))) ;; Pull out numeric factors as coefficients ((and (is-term-op? (car args) '*) (some number? (cdar args))) ;;(print 'got-here (car args) '=> (cons '* (remove-if number? (cdar args)))) - (set! arg.exps + (set! arg_exps (loop (list (cons '* (remove-if number? (cdar args)))) (apply number* cof (remove-if-not number? (cdar args))) numbers - arg.exps)) - (loop (cdr args) cof (car arg.exps) (cdr arg.exps))) + arg_exps)) + (loop (cdr args) cof (car arg_exps) (cdr arg_exps))) ((is-term-op? (car args) '-) ;; Do multi-arg - - (set! arg.exps (loop (cddar args) (number- cof) numbers arg.exps)) + (set! arg_exps (loop (cddar args) (number- cof) numbers arg_exps)) (loop (cons (cadar args) (cdr args)) cof - (car arg.exps) - (cdr arg.exps))) + (car arg_exps) + (cdr arg_exps))) ;; combine with same terms - ((assoc (car args) arg.exps) + ((assoc (car args) arg_exps) => (lambda (pair) (set-cdr! pair (number+ cof (cdr pair))) - (loop (cdr args) cof numbers arg.exps))) - ;; Add new term to arg.exps + (loop (cdr args) cof numbers arg_exps))) + ;; Add new term to arg_exps (else (loop (cdr args) cof numbers - (cons (cons (car args) cof) arg.exps)))))) + (cons (cons (car args) cof) arg_exps)))))) ;;; Converts + or * internal form to Scheme expression -(define (cr-terms->form op ident inv-op higher-op res.cofs) - (define (negative-cof? fct.cof) - (negative? (cdr fct.cof))) +(define (cr-terms->form op ident inv-op higher-op res_cofs) + (define (negative-cof? fct_cof) + (negative? (cdr fct_cof))) (define (finish exprs) (if (null? exprs) ident (if (null? (cdr exprs)) (car exprs) (cons op exprs)))) - (define (do-terms sign fct.cofs) + (define (do-terms sign fct_cofs) (expression-sort - (map (lambda (fct.cof) - (define cof (number* sign (cdr fct.cof))) - (cond ((eqv? 1 cof) (car fct.cof)) - ((number? (car fct.cof)) (number* cof (car fct.cof))) - ((is-term-op? (car fct.cof) higher-op) + (map (lambda (fct_cof) + (define cof (number* sign (cdr fct_cof))) + (cond ((eqv? 1 cof) (car fct_cof)) + ((number? (car fct_cof)) (number* cof (car fct_cof))) + ((is-term-op? (car fct_cof) higher-op) (if (eq? higher-op '^) - (list '^ (cadar fct.cof) (* cof (caddar fct.cof))) - (cons higher-op (cons cof (cdar fct.cof))))) - ((eqv? -1 cof) (list inv-op (car fct.cof))) - (else (list higher-op (car fct.cof) cof)))) - fct.cofs))) - (let* ((all.cofs (remove-if (lambda (fct.cof) - (or (zero? (cdr fct.cof)) - (eqv? ident (car fct.cof)))) - res.cofs)) - (cofs (map cdr all.cofs)) + (list '^ (cadar fct_cof) (* cof (caddar fct_cof))) + (cons higher-op (cons cof (cdar fct_cof))))) + ((eqv? -1 cof) (list inv-op (car fct_cof))) + (else (list higher-op (car fct_cof) cof)))) + fct_cofs))) + (let* ((all_cofs (remove-if (lambda (fct_cof) + (or (zero? (cdr fct_cof)) + (eqv? ident (car fct_cof)))) + res_cofs)) + (cofs (map cdr all_cofs)) (some-positive? (some positive? cofs))) - ;;(print op 'positive? some-positive? 'negative? (some negative? cofs) all.cofs) + ;;(print op 'positive? some-positive? 'negative? (some negative? cofs) all_cofs) (cond ((and some-positive? (some negative? cofs)) (append (list inv-op (finish (do-terms - 1 (remove-if negative-cof? all.cofs)))) - (do-terms -1 (remove-if-not negative-cof? all.cofs)))) - (some-positive? (finish (do-terms 1 all.cofs))) + 1 (remove-if negative-cof? all_cofs)))) + (do-terms -1 (remove-if-not negative-cof? all_cofs)))) + (some-positive? (finish (do-terms 1 all_cofs))) ((not (some negative? cofs)) ident) - (else (list inv-op (finish (do-terms -1 all.cofs))))))) + (else (list inv-op (finish (do-terms -1 all_cofs))))))) (define (* . args) (cond @@ -282,12 +282,12 @@ (ans (cr-terms->form '* 1 '/ '^ (apply - (lambda (numeric red.cofs res.cofs) + (lambda (numeric red_cofs res_cofs) (set! num numeric) (append ;;(list (cons (abs numeric) 1)) - red.cofs - res.cofs)) + red_cofs + res_cofs)) (cr1 '* number* '^ '/ (car in) (cdr in)))))) (cond ((number0? (+ -1 num)) ans) ((number? ans) (number* num ans)) @@ -312,14 +312,14 @@ (car in) (cr-terms->form '+ 0 '- '* - (apply (lambda (numeric red.cofs res.cofs) + (apply (lambda (numeric red_cofs res_cofs) (append (list (if (and (number? numeric) (negative? numeric)) (cons (abs numeric) -1) (cons numeric 1))) - red.cofs - res.cofs)) + red_cofs + res_cofs)) (cr1 '+ number+ '* '- (car in) (cdr in))))))))) (define (- arg1 . args) @@ -353,8 +353,8 @@ ;; class if not. (define (cr1 op number-op hop inv-op numeric in) - (define red.pows '()) - (define res.pows '()) + (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) @@ -365,101 +365,101 @@ (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) - (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)) + (let loop_arg_pow_s ((arg (caar in)) (pow (cdar in)) (arg_pows (cdr in))) + (define (arg-loop arg_pows) + (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)) (do ((m (number+ -1 (abs multiplicity)) (number+ -1 m)) - (n numeric (number-op n (abs (car tmp.pows))))) + (n numeric (number-op n (abs (car tmp_pows))))) ((negative? m) (set! numeric n))) - (merge-res (cdr tmp.pows) multiplicity)) - ((or (assoc (car tmp.pows) res.pows) - (assoc (car tmp.pows) arg.pows)) + (merge-res (cdr tmp_pows) multiplicity)) + ((or (assoc (car tmp_pows) res_pows) + (assoc (car tmp_pows) arg_pows)) => (lambda (pair) (set-cdr! pair (number+ - pow (number-op multiplicity (cdar tmp.pows)))) - (merge-res (cdr tmp.pows) multiplicity))) - ((assoc (car tmp.pows) red.pows) + pow (number-op multiplicity (cdar tmp_pows)))) + (merge-res (cdr tmp_pows) multiplicity))) + ((assoc (car tmp_pows) red_pows) => (lambda (pair) - (set! arg.pows - (cons (cons (caar tmp.pows) + (set! arg_pows + (cons (cons (caar tmp_pows) (number+ (cdr pair) - (number* multiplicity (cdar tmp.pows)))) - arg.pows)) + (number* multiplicity (cdar tmp_pows)))) + arg_pows)) (set-cdr! pair 0) - (merge-res (cdr tmp.pows) multiplicity))) - (else (set! arg.pows - (cons (cons (caar tmp.pows) - (number* multiplicity (cdar tmp.pows))) - arg.pows)) - (merge-res (cdr tmp.pows) multiplicity)))) - (define (try-fct.pow fct.pow) - ;;(print 'try-fct.pow fct.pow op 'arg arg 'pow pow) - (cond ((or (zero? (cdr fct.pow)) (number? (car fct.pow))) #f) - ((not (and (number? pow) (number? (cdr fct.pow)) - (integer? pow) ;(integer? (cdr fct.pow)) + (merge-res (cdr tmp_pows) multiplicity))) + (else (set! arg_pows + (cons (cons (caar tmp_pows) + (number* multiplicity (cdar tmp_pows))) + arg_pows)) + (merge-res (cdr tmp_pows) multiplicity)))) + (define (try-fct_pow fct_pow) + ;;(print 'try-fct_pow fct_pow op 'arg arg 'pow pow) + (cond ((or (zero? (cdr fct_pow)) (number? (car fct_pow))) #f) + ((not (and (number? pow) (number? (cdr fct_pow)) + (integer? pow) ;(integer? (cdr fct_pow)) )) #f) ;;((zero? pow) (slib:error "Don't try exp-0 terms") #f) - ;;((or (number? arg) (number? (car fct.pow))) - ;; (slib:error 'found-number arg fct.pow) #f) - ((and (positive? pow) (positive? (cdr fct.pow)) - (or (cring:apply-rule->terms arg (car fct.pow)) - (cring:apply-rule->terms (car fct.pow) arg))) + ;;((or (number? arg) (number? (car fct_pow))) + ;; (slib:error 'found-number arg fct_pow) #f) + ((and (positive? pow) (positive? (cdr fct_pow)) + (or (cring:apply-rule->terms arg (car fct_pow)) + (cring:apply-rule->terms (car fct_pow) arg))) => (lambda (terms) ;;(print op op terms) - (let ((multiplicity (min pow (cdr fct.pow)))) - (set-cdr! fct.pow (number- (cdr fct.pow) multiplicity)) + (let ((multiplicity (min pow (cdr fct_pow)))) + (set-cdr! fct_pow (number- (cdr fct_pow) multiplicity)) (set! pow (number- pow multiplicity)) (merge-res terms multiplicity)))) - ((and (negative? pow) (negative? (cdr fct.pow)) - (or (cring:apply-rule->terms arg (car fct.pow)) - (cring:apply-rule->terms (car fct.pow) arg))) + ((and (negative? pow) (negative? (cdr fct_pow)) + (or (cring:apply-rule->terms arg (car fct_pow)) + (cring:apply-rule->terms (car fct_pow) arg))) => (lambda (terms) ;;(print inv-op inv-op terms) - (let ((multiplicity (max pow (cdr fct.pow)))) - (set-cdr! fct.pow (number+ (cdr fct.pow) multiplicity)) + (let ((multiplicity (max pow (cdr fct_pow)))) + (set-cdr! fct_pow (number+ (cdr fct_pow) multiplicity)) (set! pow (number+ pow multiplicity)) (merge-res terms multiplicity)))) - ((and (positive? pow) (negative? (cdr fct.pow)) - (cring:apply-inv-rule->terms arg (car fct.pow))) + ((and (positive? pow) (negative? (cdr fct_pow)) + (cring:apply-inv-rule->terms arg (car fct_pow))) => (lambda (terms) ;;(print op inv-op terms) - (let ((multiplicity (min pow (number- (cdr fct.pow))))) - (set-cdr! fct.pow (number+ (cdr fct.pow) multiplicity)) + (let ((multiplicity (min pow (number- (cdr fct_pow))))) + (set-cdr! fct_pow (number+ (cdr fct_pow) multiplicity)) (set! pow (number- pow multiplicity)) (merge-res terms multiplicity)))) - ((and (negative? pow) (positive? (cdr fct.pow)) - (cring:apply-inv-rule->terms (car fct.pow) arg)) + ((and (negative? pow) (positive? (cdr fct_pow)) + (cring:apply-inv-rule->terms (car fct_pow) arg)) => (lambda (terms) ;;(print inv-op op terms) - (let ((multiplicity (max (number- pow) (cdr fct.pow)))) - (set-cdr! fct.pow (number- (cdr fct.pow) multiplicity)) + (let ((multiplicity (max (number- pow) (cdr fct_pow)))) + (set-cdr! fct_pow (number- (cdr fct_pow) multiplicity)) (set! pow (number+ pow multiplicity)) (merge-res terms multiplicity)))) (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) + ;;(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) (eqv? 1 arg)) ;(number? arg) arg seems to always be 1 - (arg-loop arg.pows)) - ((assoc arg res.pows) => (lambda (pair) + (arg-loop arg_pows)) + ((assoc arg res_pows) => (lambda (pair) (set-cdr! pair (number+ pow (cdr pair))) - (arg-loop arg.pows))) + (arg-loop arg_pows))) ((and (> (abs pow) 1) (cring:apply-rule->terms arg arg)) => (lambda (terms) (merge-res terms (quotient pow 2)) (if (odd? pow) - (loop.arg.pow.s arg 1 arg.pows) - (arg-loop arg.pows)))) - ((or (some try-fct.pow res.pows) (some try-fct.pow arg.pows)) - (loop.arg.pow.s arg pow arg.pows)) - (else (set! res.pows (cons (cons arg pow) res.pows)) - (arg-loop arg.pows))))) + (loop_arg_pow_s arg 1 arg_pows) + (arg-loop arg_pows)))) + ((or (some try-fct_pow res_pows) (some try-fct_pow arg_pows)) + (loop_arg_pow_s arg pow arg_pows)) + (else (set! res_pows (cons (cons arg pow) res_pows)) + (arg-loop arg_pows))))) (define (cring:try-rule op sop1 sop2 exp1 exp2) (and *ruleset* |