summaryrefslogtreecommitdiffstats
path: root/cring.scm
diff options
context:
space:
mode:
Diffstat (limited to 'cring.scm')
-rw-r--r--cring.scm266
1 files changed, 133 insertions, 133 deletions
diff --git a/cring.scm b/cring.scm
index 76459a2..6f33027 100644
--- a/cring.scm
+++ b/cring.scm
@@ -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*