├── test.sps ├── trig.sls ├── arithmetic.sls ├── exp.sls ├── util.sls ├── leading-coefficient-gpe.sls ├── alge.sls ├── sqrt.sls ├── div.sls ├── rational-gre.sls ├── sub.sls ├── factorial.sls ├── expand-product.sls ├── alg-polynomial-gcd.sls ├── rational-variables.sls ├── log.sls ├── polynomial-expansion.sls ├── partial-fraction-1.sls ├── polynomial-gcd.sls ├── trig-substitute.sls ├── polynomial-gpe.sls ├── denominator.sls ├── numerator.sls ├── tan.sls ├── contains.sls ├── expand-exp.sls ├── monomial-gpe.sls ├── expand-power.sls ├── degree-gpe.sls ├── coeff-var-monomial.sls ├── expand-main-op.sls ├── extended-euclidean-algorithm.sls ├── simplify-trig.sls ├── polynomial-division.sls ├── rational-expand.sls ├── separate-sin-cos.sls ├── all.sls ├── rationalize-expression.sls ├── variables.sls ├── derivative.sls ├── substitute.sls ├── contract-exp.sls ├── alg-polynomial-division.sls ├── README ├── automatic-simplify.sls ├── algebraic-expand.sls ├── rnrs-base.sls ├── coefficient-gpe.sls ├── collect-terms.sls ├── misc.sls ├── mpl.org ├── cos.sls ├── sin.sls ├── order-relation.sls ├── sum-product-power.sls ├── expand-trig.sls ├── LICENSE ├── rnrs-sans.sls ├── rnrs.sls ├── contract-trig.sls ├── match.sls └── test.sls /test.sps: -------------------------------------------------------------------------------- 1 | (import (mpl test)) 2 | 3 | (test) -------------------------------------------------------------------------------- /trig.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (mpl trig) 3 | 4 | (export sin cos tan) 5 | 6 | (import (mpl sin) 7 | (mpl cos) 8 | (mpl tan))) 9 | -------------------------------------------------------------------------------- /arithmetic.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl arithmetic) 4 | 5 | (export + - * / ^) 6 | 7 | (import (mpl sum-product-power) 8 | (mpl sub) 9 | (mpl div))) -------------------------------------------------------------------------------- /exp.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl exp) 4 | 5 | (export exp) 6 | 7 | (import (rename (rnrs) (exp rnrs:exp))) 8 | 9 | (define (exp u) 10 | (if (number? u) 11 | (rnrs:exp u) 12 | `(exp ,u))) 13 | 14 | ) -------------------------------------------------------------------------------- /util.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl util) 4 | 5 | (export while) 6 | 7 | (import (rnrs)) 8 | 9 | (define-syntax while 10 | (syntax-rules () 11 | ((while test expr ...) 12 | (let loop () 13 | (when test 14 | expr 15 | ... 16 | (loop))))))) 17 | -------------------------------------------------------------------------------- /leading-coefficient-gpe.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl leading-coefficient-gpe) 4 | 5 | (export leading-coefficient-gpe) 6 | 7 | (import (rnrs) 8 | (mpl degree-gpe) 9 | (mpl coefficient-gpe)) 10 | 11 | (define (leading-coefficient-gpe u x) 12 | (coefficient-gpe u x (degree-gpe u (list x))))) 13 | -------------------------------------------------------------------------------- /alge.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl alge) 4 | 5 | (export alge) 6 | 7 | (import (rnrs) 8 | (dharmalab infix alg) 9 | (mpl automatic-simplify)) 10 | 11 | (define (alge val) 12 | (automatic-simplify 13 | (if (string? val) 14 | (alg val) 15 | val))) 16 | 17 | ) 18 | 19 | 20 | -------------------------------------------------------------------------------- /sqrt.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl sqrt) 4 | 5 | (export sqrt) 6 | 7 | (import (mpl rnrs-sans) 8 | (rename (only (rnrs) sqrt) (sqrt rnrs:sqrt)) 9 | (mpl arithmetic)) 10 | 11 | (define (sqrt x) 12 | (if (and (number? x) 13 | (exact? (rnrs:sqrt x))) 14 | (rnrs:sqrt x) 15 | (^ x 1/2))) 16 | 17 | ) 18 | -------------------------------------------------------------------------------- /div.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl div) 4 | 5 | (export / simplify-quotient) 6 | 7 | (import (except (rnrs) + - * /) 8 | (mpl match) 9 | (mpl sum-product-power)) 10 | 11 | (define (simplify-quotient u) 12 | (match u 13 | ( ('/ x y) 14 | (* x (^ y -1)) ))) 15 | 16 | (define (/ u v) 17 | (simplify-quotient `(/ ,u ,v))) 18 | 19 | ) -------------------------------------------------------------------------------- /rational-gre.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl rational-gre) 4 | 5 | (export rational-gre?) 6 | 7 | (import (except (rnrs) numerator denominator) 8 | (mpl polynomial-gpe) 9 | (mpl numerator) 10 | (mpl denominator)) 11 | 12 | (define (rational-gre? u v) 13 | (and (polynomial-gpe? (numerator u) v) 14 | (polynomial-gpe? (denominator u) v))) 15 | 16 | ) -------------------------------------------------------------------------------- /sub.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl sub) 4 | 5 | (export - simplify-difference) 6 | 7 | (import (except (rnrs) + * -) 8 | (mpl match) 9 | (mpl sum-product-power)) 10 | 11 | (define (simplify-difference u) 12 | (match u 13 | ( ('- x) (* -1 x) ) 14 | ( ('- x y) (+ x (* -1 y)) ))) 15 | 16 | (define (- . elts) 17 | (simplify-difference `(- ,@elts))) 18 | 19 | ) -------------------------------------------------------------------------------- /factorial.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl factorial) 4 | 5 | (export ! simplify-factorial) 6 | 7 | (import (rename (rnrs) (- rnrs:-) (* rnrs:*)) 8 | (mpl match)) 9 | 10 | (define (factorial n) 11 | (if (= n 0) 12 | 1 13 | (rnrs:* n (factorial (rnrs:- n 1))))) 14 | 15 | (define (simplify-factorial u) 16 | (match u 17 | ( ('! (? number? n)) (factorial n) ) 18 | ( ('! n) u ))) 19 | 20 | (define (! n) 21 | (simplify-factorial `(! ,n))) 22 | 23 | ) -------------------------------------------------------------------------------- /expand-product.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl expand-product) 4 | 5 | (export expand-product) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl misc) 9 | (mpl arithmetic)) 10 | 11 | (define (expand-product r s) 12 | 13 | (cond ( (sum? r) 14 | 15 | (let ((f (list-ref r 1))) 16 | 17 | (+ (expand-product f s) 18 | 19 | (expand-product (- r f) s))) ) 20 | 21 | ( (sum? s) (expand-product s r) ) 22 | 23 | ( else (* r s) ))) 24 | 25 | ) -------------------------------------------------------------------------------- /alg-polynomial-gcd.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl alg-polynomial-gcd) 4 | 5 | (export alg-monic 6 | alg-polynomial-gcd) 7 | 8 | (import (mpl rnrs-sans) 9 | (mpl leading-coefficient-gpe) 10 | (mpl alg-polynomial-division)) 11 | 12 | (define (alg-monic u x p a) 13 | (alg-divide u (leading-coefficient-gpe u x) p a)) 14 | 15 | (define (alg-polynomial-gcd u v x p a) 16 | (let loop ((u u) (v v)) 17 | (if (equal? v 0) 18 | (alg-monic u x p a) 19 | (loop v (alg-remainder u v x p a)))))) -------------------------------------------------------------------------------- /rational-variables.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl rational-variables) 4 | 5 | (export rational-variables) 6 | 7 | (import (except (rnrs) numerator denominator exp) 8 | (only (surfage s1 lists) lset-union) 9 | (mpl variables) 10 | (mpl numerator) 11 | (mpl denominator) 12 | ) 13 | 14 | (define (rational-variables u) 15 | (lset-union equal? 16 | (variables (numerator u)) 17 | (variables (denominator u)))) 18 | 19 | ) 20 | 21 | 22 | -------------------------------------------------------------------------------- /log.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl log) 4 | 5 | (export log) 6 | 7 | (import (rename (rnrs) (log rnrs:log)) 8 | (mpl misc)) 9 | 10 | (define log 11 | 12 | (case-lambda 13 | 14 | ( (x) 15 | 16 | (cond ( (number? x) 17 | 18 | (rnrs:log x) ) 19 | 20 | ( (exp? x) (list-ref x 1) ) 21 | 22 | ( else `(log ,x) )) ) 23 | 24 | ( (x y) 25 | 26 | (cond ( (and (number? x) (number? y)) 27 | 28 | (rnrs:log x y) ) 29 | 30 | ( else `(log ,x ,y) )) )))) 31 | 32 | -------------------------------------------------------------------------------- /polynomial-expansion.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl polynomial-expansion) 4 | 5 | (export polynomial-expansion) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl arithmetic) 9 | (mpl algebraic-expand) 10 | (mpl polynomial-division)) 11 | 12 | (define (polynomial-expansion u v x t) 13 | (if (equal? u 0) 14 | 0 15 | (let ((d (polynomial-division u v x))) 16 | (let ((q (list-ref d 0)) 17 | (r (list-ref d 1))) 18 | (algebraic-expand (+ (* t (polynomial-expansion q v x t)) 19 | r))))))) 20 | -------------------------------------------------------------------------------- /partial-fraction-1.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl partial-fraction-1) 4 | 5 | (export partial-fraction-1) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl arithmetic) 9 | (mpl algebraic-expand) 10 | (mpl polynomial-division) 11 | (mpl extended-euclidean-algorithm)) 12 | 13 | (define (partial-fraction-1 u v1 v2 x) 14 | 15 | (let ((s (extended-euclidean-algorithm v1 v2 x))) 16 | 17 | (let ((A (list-ref s 1)) 18 | (B (list-ref s 2))) 19 | 20 | (list (remainder (algebraic-expand (* B u)) v1 x) 21 | (remainder (algebraic-expand (* A u)) v2 x)))))) -------------------------------------------------------------------------------- /polynomial-gcd.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl polynomial-gcd) 4 | 5 | (export polynomial-gcd) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl arithmetic) 9 | (mpl algebraic-expand) 10 | (mpl leading-coefficient-gpe) 11 | (mpl polynomial-division)) 12 | 13 | (define (polynomial-gcd u v x) 14 | (if (and (equal? u 0) 15 | (equal? v 0)) 16 | 0 17 | (let loop ((u u) (v v)) 18 | (if (equal? v 0) 19 | (algebraic-expand 20 | (* (/ 1 (leading-coefficient-gpe u x)) 21 | u)) 22 | (loop v (remainder u v x))))))) 23 | -------------------------------------------------------------------------------- /trig-substitute.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl trig-substitute) 4 | 5 | (export trig-substitute) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl match) 9 | (mpl arithmetic) 10 | (mpl sin) 11 | (mpl cos)) 12 | 13 | (define (trig-substitute u) 14 | (if (or (number? u) 15 | (symbol? u)) 16 | u 17 | (let ((v (map trig-substitute u))) 18 | (match v 19 | (('tan x) (/ (sin x) (cos x))) 20 | (('cot x) (/ (cos x) (sin x))) 21 | (('sec x) (/ 1 (cos x))) 22 | (('csc x) (/ 1 (sin x))) 23 | (else v))))) 24 | 25 | ) -------------------------------------------------------------------------------- /polynomial-gpe.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl polynomial-gpe) 4 | 5 | (export polynomial-gpe? 6 | polynomial-gpe-in? 7 | is-polynomial-gpe?) 8 | 9 | (import (rnrs) 10 | (only (surfage s1 lists) every) 11 | (mpl misc) 12 | (mpl monomial-gpe)) 13 | 14 | (define (polynomial-gpe? u v) 15 | (or (monomial-gpe? u v) 16 | (and (sum? u) 17 | (every (monomial-gpe-in? v) (cdr u))))) 18 | 19 | (define (polynomial-gpe-in? v) 20 | (lambda (u) 21 | (polynomial-gpe? u v))) 22 | 23 | (define (is-polynomial-gpe? u) 24 | (lambda (v) 25 | (polynomial-gpe? u v))) 26 | 27 | ) -------------------------------------------------------------------------------- /denominator.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl denominator) 4 | 5 | (export denominator) 6 | 7 | (import (mpl rnrs-sans) 8 | (rename (only (rnrs) denominator) (denominator rnrs:denominator)) 9 | (mpl match) 10 | (mpl arithmetic)) 11 | 12 | (define (denominator u) 13 | 14 | (match u 15 | 16 | ( (? number?) (rnrs:denominator u) ) 17 | 18 | ( ('^ x y) 19 | (if (and (number? y) 20 | (negative? y)) 21 | (^ u -1) 22 | 1) ) 23 | 24 | ( ('* v . rest) 25 | (* (denominator v) 26 | (denominator (/ u v))) ) 27 | 28 | ( else 1 ))) 29 | 30 | ) 31 | -------------------------------------------------------------------------------- /numerator.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl numerator) 4 | 5 | (export numerator) 6 | 7 | (import (mpl rnrs-sans) 8 | (rename (only (rnrs) numerator) (numerator rnrs:numerator)) 9 | (mpl match) 10 | (mpl arithmetic)) 11 | 12 | (define (numerator u) 13 | 14 | (match u 15 | 16 | ( (? number?) (rnrs:numerator u) ) 17 | 18 | ( ('^ x y) 19 | 20 | (if (and (number? y) 21 | (negative? y)) 22 | 1 23 | u) ) 24 | 25 | ( ('* v . rest) 26 | (* (numerator v) 27 | (numerator (/ u v))) ) 28 | 29 | ( else u ))) 30 | 31 | ) 32 | 33 | 34 | -------------------------------------------------------------------------------- /tan.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl tan) 4 | 5 | (export tan) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl match) 9 | (mpl arithmetic)) 10 | 11 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | 13 | (define (simplify-tan u) 14 | 15 | (match u 16 | 17 | ( (and ('tan ('* n . elts)) 18 | (? (lambda (_) 19 | (and (number? n) 20 | (negative? n))))) 21 | 22 | (- (tan (apply * (append (list -1 n) elts)))) ) 23 | 24 | ( else u ))) 25 | 26 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | 28 | (define (tan x) 29 | (simplify-tan `(tan ,x))) 30 | 31 | ) 32 | -------------------------------------------------------------------------------- /contains.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl contains) 4 | 5 | (export contains? 6 | this-contains? 7 | contains-this? 8 | free? 9 | is-free? 10 | free-of?) 11 | 12 | (import (rnrs) 13 | (only (surfage s1 lists) any)) 14 | 15 | (define (contains-this? t) 16 | (lambda (u) 17 | (contains? u t))) 18 | 19 | (define (this-contains? u) 20 | (lambda (t) 21 | (contains? u t))) 22 | 23 | (define (contains? u t) 24 | (or (equal? u t) 25 | (and (list? u) 26 | (any (contains-this? t) u)))) 27 | 28 | (define (free? u t) 29 | (not (contains? u t))) 30 | 31 | (define (is-free? u) 32 | (lambda (t) 33 | (free? u t))) 34 | 35 | (define (free-of? t) 36 | (lambda (u) 37 | (free? u t))) 38 | 39 | ) -------------------------------------------------------------------------------- /expand-exp.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl expand-exp) 4 | 5 | (export expand-exp) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl arithmetic) 9 | (mpl exp) 10 | (mpl misc)) 11 | 12 | (define (expand-exp-rules A) 13 | (cond ( (sum? A) 14 | (let ((f (list-ref A 1))) 15 | (* (expand-exp-rules f) 16 | (expand-exp-rules (- A f)))) ) 17 | ( (product? A) 18 | (let ((f (list-ref A 1))) 19 | (if (integer? f) 20 | (^ (expand-exp-rules (/ A f)) f) 21 | (exp A))) ) 22 | (else (exp A)))) 23 | 24 | (define (expand-exp u) 25 | (if (or (number? u) (symbol? u)) 26 | u 27 | (let ((v (map expand-exp u))) 28 | (if (exp? v) 29 | (expand-exp-rules (list-ref v 1)) 30 | v)))) 31 | 32 | ) -------------------------------------------------------------------------------- /monomial-gpe.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl monomial-gpe) 4 | 5 | (export monomial-gpe? 6 | monomial-gpe-in? 7 | is-monomial-gpe?) 8 | 9 | (import (rnrs) 10 | (only (surfage s1 lists) every) 11 | (mpl misc) 12 | (mpl contains) 13 | ) 14 | 15 | (define (monomial-gpe? u v) 16 | 17 | (or (every (is-free? u) v) ;; GME-1 18 | 19 | (member u v) ;; GME-2 20 | 21 | (and (power? u) ;; GME-3 22 | (let ((n (list-ref u 2))) 23 | (integer? n) 24 | (> n 1))) 25 | 26 | (and (product? u) ;; GME-4 27 | (every (monomial-gpe-in? v) (cdr u))))) 28 | 29 | (define (monomial-gpe-in? v) 30 | (lambda (u) 31 | (monomial-gpe? u v))) 32 | 33 | (define (is-monomial-gpe? u) 34 | (lambda (v) 35 | (monomial-gpe? u v))) 36 | 37 | ) 38 | 39 | 40 | -------------------------------------------------------------------------------- /expand-power.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl expand-power) 4 | 5 | (export expand-power) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl misc) 9 | (mpl arithmetic) 10 | (mpl factorial) 11 | (mpl expand-product)) 12 | 13 | (define (expand-power u n) 14 | 15 | (if (sum? u) 16 | 17 | (let ((f (list-ref u 1))) 18 | 19 | (let ( (r (- u f)) ) 20 | 21 | (let loop ( (s 0) 22 | (k 0) ) 23 | 24 | (if (> k n) 25 | 26 | s 27 | 28 | (let ((c (/ (! n) 29 | (* (! k) 30 | (! (- n k)))))) 31 | 32 | (loop (+ s 33 | (expand-product (* c (^ f (- n k))) 34 | (expand-power r k))) 35 | (+ k 1))))))) 36 | 37 | (^ u n))) 38 | 39 | ) -------------------------------------------------------------------------------- /degree-gpe.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl degree-gpe) 4 | 5 | (export degree-gpe) 6 | 7 | (import (rnrs) 8 | (only (surfage s1 lists) every) 9 | (mpl misc) 10 | (mpl contains) 11 | ) 12 | 13 | (define (degree-monomial-gpe u v) 14 | 15 | (cond ( (every (is-free? u) v) 0 ) 16 | 17 | ( (member u v) 1 ) 18 | 19 | ( (and (power? u) 20 | (let ((n (list-ref u 2))) 21 | (integer? n) 22 | (> n 1))) 23 | 24 | (list-ref u 2) ) 25 | 26 | ( (product? u) 27 | (apply + 28 | (map 29 | (lambda (elt) 30 | (degree-monomial-gpe elt v)) 31 | (cdr u))) ) 32 | 33 | ( else 0 ))) 34 | 35 | (define (degree-gpe u v) 36 | 37 | (cond ( (sum? u) 38 | (apply max 39 | (map 40 | (lambda (elt) 41 | (degree-monomial-gpe elt v)) 42 | (cdr u))) ) 43 | 44 | ( else (degree-monomial-gpe u v) ))) 45 | 46 | ) -------------------------------------------------------------------------------- /coeff-var-monomial.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl coeff-var-monomial) 4 | 5 | (export coeff-var-monomial) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl arithmetic) 9 | (mpl contains)) 10 | 11 | ;; (define (coeff-var-monomial u v) 12 | 13 | ;; (let loop ( (coefficient-part u) 14 | ;; (variables v) ) 15 | 16 | ;; (if (null? variables) 17 | 18 | ;; (let ((variable-part (/ u coefficient-part))) 19 | 20 | ;; (list coefficient-part variable-part)) 21 | 22 | ;; (loop (/ coefficient-part (car variables)) 23 | ;; (cdr variables))))) 24 | 25 | (define (coeff-var-monomial u v) 26 | 27 | (let loop ( (coefficient-part u) 28 | (variables v) ) 29 | 30 | (cond ( (null? variables) 31 | 32 | (let ((variable-part (/ u coefficient-part))) 33 | 34 | (list coefficient-part variable-part)) ) 35 | 36 | ( (free? u (car variables)) 37 | 38 | (loop coefficient-part 39 | (cdr variables)) ) 40 | 41 | ( else 42 | 43 | (loop (/ coefficient-part (car variables)) 44 | (cdr variables)) )))) 45 | 46 | ) -------------------------------------------------------------------------------- /expand-main-op.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl expand-main-op) 4 | 5 | (export expand-main-op) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl match) 9 | (mpl arithmetic) 10 | (mpl misc) 11 | (mpl expand-product) 12 | (mpl expand-power)) 13 | 14 | ;; (define (expand-main-op u) 15 | 16 | ;; (cond ( (product? u) 17 | 18 | ;; (expand-product (list-ref u 1) 19 | ;; (list-ref u 2)) ) 20 | 21 | ;; ( (power? u) 22 | 23 | ;; (expand-power (list-ref u 1) 24 | ;; (list-ref u 2)) ) 25 | 26 | ;; ( else u ))) 27 | 28 | ;; (define (expand-main-op u) 29 | 30 | ;; (match u 31 | 32 | ;; ( ('* a . rest) 33 | 34 | ;; (expand-product a (apply * rest)) ) 35 | 36 | ;; ( ('^ a b) 37 | 38 | ;; (expand-power a b) ) 39 | 40 | ;; ( else u ))) 41 | 42 | (define (expand-main-op u) 43 | 44 | (match u 45 | 46 | ( ('* a . rest) 47 | 48 | (expand-product a 49 | (expand-main-op (apply * rest))) ) 50 | 51 | ( ('^ a b) 52 | 53 | (expand-power a b) ) 54 | 55 | ( else u ))) 56 | 57 | 58 | 59 | ) -------------------------------------------------------------------------------- /extended-euclidean-algorithm.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl extended-euclidean-algorithm) 4 | 5 | (export extended-euclidean-algorithm) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl arithmetic) 9 | (mpl leading-coefficient-gpe) 10 | (mpl algebraic-expand) 11 | (mpl polynomial-division)) 12 | 13 | (define (extended-euclidean-algorithm u v x) 14 | 15 | (if (and (equal? u 0) 16 | (equal? v 0)) 17 | 18 | (list 0 0 0) 19 | 20 | (let loop ((u u) 21 | (v v) 22 | (App 1) 23 | (Ap 0) 24 | (A #f) 25 | (Bpp 0) 26 | (Bp 1) 27 | (B #f)) 28 | 29 | (if (equal? v 0) 30 | 31 | (let ((c (leading-coefficient-gpe u x))) 32 | 33 | (list (algebraic-expand (/ u c)) 34 | (algebraic-expand (/ App c)) 35 | (algebraic-expand (/ Bpp c)))) 36 | 37 | (let ((q (quotient u v x)) 38 | (r (remainder u v x))) 39 | 40 | (let ((A (- App (* q Ap))) 41 | (B (- Bpp (* q Bp)))) 42 | 43 | (loop v r Ap A A Bp B B)))))))) -------------------------------------------------------------------------------- /simplify-trig.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl simplify-trig) 4 | 5 | (export simplify-trig) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl arithmetic) 9 | (mpl numerator) 10 | (mpl denominator) 11 | (mpl rationalize-expression) 12 | (mpl expand-trig) 13 | (mpl contract-trig) 14 | (mpl trig-substitute) 15 | (mpl algebraic-expand)) 16 | 17 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | 19 | ;; Original version from book 20 | 21 | ;; (define (simplify-trig u) 22 | ;; (let ((w (rationalize-expression (trig-substitute u)))) 23 | ;; (/ (contract-trig (expand-trig (numerator w))) 24 | ;; (contract-trig (expand-trig (denominator w)))))) 25 | 26 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | 28 | ;; 2009/10/01 29 | 30 | ;; This version calls 'algebraic-expand' between 'contract-trig' and 31 | ;; 'expand-trig'. This enables 'simplify-trig' to work on EA Example 7.16. 32 | 33 | (define (simplify-trig u) 34 | (let ((w (rationalize-expression (trig-substitute u)))) 35 | (/ (contract-trig (algebraic-expand (expand-trig (numerator w)))) 36 | (contract-trig (algebraic-expand (expand-trig (denominator w))))))) 37 | 38 | ) 39 | -------------------------------------------------------------------------------- /polynomial-division.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl polynomial-division) 4 | 5 | (export polynomial-division quotient remainder) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl arithmetic) 9 | (mpl util) 10 | (mpl degree-gpe) 11 | (mpl algebraic-expand) 12 | (mpl leading-coefficient-gpe)) 13 | 14 | (define (polynomial-division u v x) 15 | 16 | (let* ((q 0) 17 | (r u) 18 | (m (degree-gpe r (list x))) 19 | (n (degree-gpe v (list x))) 20 | (lcv (leading-coefficient-gpe v x))) 21 | 22 | (while (and (>= m n) 23 | (not (equal? r 0))) ;; see footnote 2 page 115 24 | 25 | (let* ((lcr (leading-coefficient-gpe r x)) 26 | (s (/ lcr lcv))) 27 | 28 | (set! q (+ q (* s (^ x (- m n))))) 29 | 30 | (set! r (algebraic-expand (- (- r (* lcr (^ x m))) 31 | (* (- v (* lcv (^ x n))) 32 | s 33 | (^ x (- m n)))))) 34 | 35 | (set! m (degree-gpe r (list x))))) 36 | 37 | (list q r))) 38 | 39 | (define (quotient u v x) 40 | (list-ref (polynomial-division u v x) 0)) 41 | 42 | (define (remainder u v x) 43 | (list-ref (polynomial-division u v x) 1))) -------------------------------------------------------------------------------- /rational-expand.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl rational-expand) 4 | 5 | (export rational-expand) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl arithmetic) 9 | (mpl algebraic-expand) 10 | (mpl numerator) 11 | (mpl denominator) 12 | (mpl rational-gre) 13 | (mpl rationalize-expression)) 14 | 15 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | 17 | ;; (define (rational-expand u) 18 | 19 | ;; (let ((f (algebraic-expand (numerator u))) 20 | ;; (g (algebraic-expand (denominator u)))) 21 | 22 | ;; (if (equal? g 0) 23 | 24 | ;; #f 25 | 26 | ;; (let ((h (/ f g))) 27 | 28 | ;; (if (rational-gre? h) 29 | 30 | ;; h 31 | 32 | ;; (rational-expand 33 | ;; (rationalize-expression h))))))) 34 | 35 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | 37 | (define (rational-expand u) 38 | 39 | (let ((f (algebraic-expand (numerator u))) 40 | (g (algebraic-expand (denominator u)))) 41 | 42 | (if (equal? g 0) 43 | 44 | #f 45 | 46 | (let ((h (rationalize-expression (/ f g)))) 47 | 48 | (if (equal? h u) 49 | u 50 | (rational-expand h)))))) 51 | 52 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | 54 | ) -------------------------------------------------------------------------------- /separate-sin-cos.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl separate-sin-cos) 4 | 5 | (export separate-sin-cos) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl misc) 9 | (mpl arithmetic)) 10 | 11 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | 13 | ;; (define (sin? u) 14 | ;; (and (pair? u) 15 | ;; (eq? (car u) 'sin))) 16 | 17 | ;; (define (cos? u) 18 | ;; (and (pair? u) 19 | ;; (eq? (car u) 'cos))) 20 | 21 | (define (sin-or-cos? u) 22 | (or (sin? u) 23 | (cos? u) 24 | (and (power? u) 25 | (or (sin? (base u)) 26 | (cos? (base u)))))) 27 | 28 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | 30 | (define (separate-sin-cos u) 31 | 32 | (cond ( (product? u) 33 | 34 | (let loop ((r 1) 35 | (s 1) 36 | (operands (cdr u))) 37 | 38 | (if (null? operands) 39 | 40 | (list r s) 41 | 42 | (let ((operand (car operands))) 43 | 44 | (if (sin-or-cos? operand) 45 | (loop r (* s operand) (cdr operands)) 46 | (loop (* r operand) s (cdr operands)))))) ) 47 | 48 | ( (sin-or-cos? u) (list 1 u) ) 49 | ( else (list u 1) ))) 50 | 51 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 52 | 53 | ) -------------------------------------------------------------------------------- /all.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl all) 4 | 5 | (export + - * / ^ 6 | sqrt 7 | vars 8 | alge 9 | substitute 10 | collect-terms 11 | algebraic-expand 12 | expand-exp 13 | expand-trig 14 | contract-exp 15 | contract-trig 16 | derivative 17 | polynomial-division 18 | polynomial-expansion) 19 | 20 | (import (mpl misc) 21 | (mpl contains) 22 | (mpl sum-product-power) 23 | (mpl sub) 24 | (mpl div) 25 | (mpl exp) 26 | (mpl factorial) 27 | (mpl numerator) 28 | (mpl denominator) 29 | (mpl sqrt) 30 | (mpl sin) 31 | (mpl cos) 32 | (mpl tan) 33 | (mpl automatic-simplify) 34 | (mpl alge) 35 | (mpl substitute) 36 | (mpl monomial-gpe) 37 | (mpl polynomial-gpe) 38 | (mpl variables) 39 | (mpl degree-gpe) 40 | (mpl coefficient-gpe) 41 | (mpl leading-coefficient-gpe) 42 | (mpl coeff-var-monomial) 43 | (mpl collect-terms) 44 | (mpl algebraic-expand) 45 | (mpl expand-main-op) 46 | (mpl rational-gre) 47 | (mpl rational-variables) 48 | (mpl rationalize-expression) 49 | (mpl rational-expand) 50 | (mpl expand-exp) 51 | (mpl expand-trig) 52 | (mpl contract-exp) 53 | (mpl separate-sin-cos) 54 | (mpl contract-trig) 55 | (mpl trig-substitute) 56 | (mpl simplify-trig) 57 | (mpl derivative) 58 | (mpl polynomial-division) 59 | (mpl polynomial-expansion) 60 | (mpl polynomial-gcd) 61 | (mpl extended-euclidean-algorithm) 62 | (mpl alg-polynomial-division) 63 | (mpl alg-polynomial-gcd) 64 | (mpl partial-fraction-1))) 65 | -------------------------------------------------------------------------------- /rationalize-expression.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl rationalize-expression) 4 | 5 | (export rationalize-expression) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl misc) 9 | (mpl arithmetic) 10 | (mpl numerator) 11 | (mpl denominator)) 12 | 13 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | (define (rationalize-sum u v) 16 | 17 | (let ((m (numerator u)) 18 | (r (denominator u)) 19 | (n (numerator v)) 20 | (s (denominator v))) 21 | 22 | (if (and (equal? r 1) 23 | (equal? s 1)) 24 | 25 | (+ u v) 26 | 27 | (/ (rationalize-sum (* m s) 28 | (* n r)) 29 | (* r s))))) 30 | 31 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | 33 | (define (rationalize-expression u) 34 | 35 | (cond ( (power? u) 36 | 37 | (^ (rationalize-expression (list-ref u 1)) 38 | (list-ref u 2)) ) 39 | 40 | ( (product? u) 41 | 42 | (let ((f (list-ref u 1))) 43 | 44 | (* (rationalize-expression f) 45 | (rationalize-expression (/ u f)))) ) 46 | 47 | ( (sum? u) 48 | 49 | (let ((f (list-ref u 1))) 50 | 51 | (let ((g (rationalize-expression f)) 52 | (r (rationalize-expression (- u f)))) 53 | 54 | (rationalize-sum g r))) ) 55 | 56 | ( else u ))) 57 | 58 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | 60 | ) -------------------------------------------------------------------------------- /variables.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl variables) 4 | 5 | (export variables) 6 | 7 | (import (rnrs) 8 | (mpl misc) 9 | (only (surfage s1 lists) lset-union) 10 | ) 11 | 12 | (define (union . lists) 13 | (apply lset-union (cons equal? lists))) 14 | 15 | (define (VAR-1 u) 16 | (and (number? u) '())) 17 | 18 | (define (VAR-2 u) 19 | (and (power? u) ;; VAR-2 20 | (let ((n (list-ref u 2))) 21 | (and (integer? n) 22 | (> n 1))) 23 | (list (list-ref u 1)))) 24 | 25 | (define (VAR-3 u) 26 | (and (sum? u) 27 | (apply union 28 | (map 29 | (lambda (operand) 30 | (or (VAR-1 operand) 31 | (VAR-2 operand) 32 | (VAR-4 operand) 33 | (VAR-5 operand))) 34 | (cdr u))))) 35 | 36 | (define (VAR-4 u) 37 | (and (product? u) 38 | (apply union 39 | (map 40 | (lambda (operand) 41 | (or (VAR-1 operand) 42 | (VAR-2 operand) 43 | (and (sum? operand) (list operand)) 44 | (VAR-5 operand))) 45 | (cdr u))))) 46 | 47 | (define (VAR-5 u) 48 | (list u)) 49 | 50 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51 | 52 | (define (variables u) 53 | (or (VAR-1 u) 54 | (VAR-2 u) 55 | (VAR-3 u) 56 | (VAR-4 u) 57 | (VAR-5 u))) 58 | 59 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 | 61 | ) -------------------------------------------------------------------------------- /derivative.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl derivative) 4 | 5 | (export derivative) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl misc) 9 | (mpl arithmetic) 10 | (mpl sin) 11 | (mpl cos) 12 | (mpl tan) 13 | (mpl log) 14 | (mpl contains)) 15 | 16 | (define (derivative u x) 17 | 18 | (cond ( (equal? u x) 1 ) 19 | 20 | ( (power? u) 21 | 22 | (let ((v (base u)) 23 | (w (exponent u))) 24 | 25 | (+ (* w 26 | (^ v (- w 1)) 27 | (derivative v x)) 28 | 29 | (* (derivative w x) 30 | (^ v w) 31 | (log v)))) ) 32 | 33 | ( (sum? u) 34 | 35 | (let ( (v (list-ref u 1)) ) 36 | 37 | (let ( (w (- u v)) ) 38 | 39 | (+ (derivative v x) (derivative w x)))) ) 40 | 41 | ( (product? u) 42 | 43 | (let ( (v (list-ref u 1)) ) 44 | 45 | (let ( (w (/ u v)) ) 46 | 47 | (+ (* (derivative v x) w) 48 | 49 | (* v (derivative w x))))) ) 50 | 51 | ( (sin? u) 52 | 53 | (let ( (v (list-ref u 1)) ) 54 | 55 | (* (cos v) (derivative v x))) ) 56 | 57 | ( (cos? u) 58 | 59 | (let ( (v (list-ref u 1)) ) 60 | 61 | (* (- (sin v)) (derivative v x))) ) 62 | 63 | ( (tan? u) 64 | 65 | (let ( (v (list-ref u 1)) ) 66 | 67 | (* (^ `(sec ,v) 2) (derivative v x))) ) 68 | 69 | ( (free? u x) 0 ) 70 | 71 | ( else `(derivative ,u ,x) )))) 72 | -------------------------------------------------------------------------------- /substitute.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl substitute) 4 | 5 | (export substitute 6 | substitute-this 7 | substitute-in 8 | sequential-substitute 9 | concurrent-substitute) 10 | 11 | (import (rnrs) 12 | (mpl match) 13 | (mpl automatic-simplify)) 14 | 15 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 16 | 17 | (define (substitute u t r) 18 | (automatic-simplify 19 | (cond ((equal? u t) r) 20 | ((list? u) 21 | (map (substitute-this t r) u)) 22 | (else u)))) 23 | 24 | (define (substitute-this t r) 25 | (lambda (u) 26 | (substitute u t r))) 27 | 28 | (define (substitute-in u) 29 | (lambda (t r) 30 | (substitute u t r))) 31 | 32 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | 34 | (define (sequential-substitute u L) 35 | (automatic-simplify 36 | (match L 37 | ( () u ) 38 | ( ( (t r) . rest ) 39 | (sequential-substitute (substitute u t r) 40 | rest) )))) 41 | 42 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | 44 | (define (concurrent-substitute u S) 45 | 46 | (automatic-simplify 47 | 48 | (let ((result (find (lambda (elt) 49 | (equal? u (car elt))) 50 | S))) 51 | 52 | (cond ( result (list-ref result 1) ) 53 | ( (list? u) 54 | (map (lambda (elt) 55 | (concurrent-substitute elt S)) 56 | u) ) 57 | ( else u ))))) 58 | 59 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 60 | 61 | ) 62 | 63 | -------------------------------------------------------------------------------- /contract-exp.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl contract-exp) 4 | 5 | (export contract-exp) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl misc) 9 | (mpl arithmetic) 10 | (mpl exp) 11 | (mpl expand-main-op)) 12 | 13 | (define (contract-exp-rules u) 14 | 15 | (let ((v (expand-main-op u))) 16 | 17 | (cond ( (power? v) 18 | 19 | (let ((b (list-ref v 1)) 20 | (s (list-ref v 2))) 21 | 22 | (if (exp? b) 23 | (let ((p (* (list-ref b 1) s))) 24 | (if (or (product? p) 25 | (power? p)) 26 | (exp (contract-exp-rules p)) 27 | (exp p))) 28 | v)) ) 29 | 30 | ( (product? v) 31 | 32 | (let ((p 1) 33 | (s 0)) 34 | 35 | (for-each 36 | (lambda (y) 37 | (if (exp? y) 38 | (set! s (+ s (list-ref y 1))) 39 | (set! p (* p y)))) 40 | (cdr v)) 41 | 42 | (* (exp s) p)) ) 43 | 44 | ( (sum? v) 45 | 46 | (let ((s 0)) 47 | 48 | (for-each 49 | (lambda (y) 50 | (if (or (product? y) 51 | (power? y)) 52 | (set! s (+ s (contract-exp-rules y))) 53 | (set! s (+ s y)))) 54 | (cdr v)) 55 | 56 | s) ) 57 | 58 | ( else v )))) 59 | 60 | (define (contract-exp u) 61 | 62 | (if (or (number? u) 63 | (symbol? u)) 64 | u 65 | (let ((v (map contract-exp u))) 66 | (if (or (product? v) 67 | (power? v)) 68 | (contract-exp-rules v) 69 | v)))) 70 | 71 | ) -------------------------------------------------------------------------------- /alg-polynomial-division.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl alg-polynomial-division) 4 | 5 | (export alg-mult-inverse 6 | alg-divide 7 | alg-coeff-simp 8 | alg-polynomial-division 9 | alg-quotient 10 | alg-remainder) 11 | 12 | (import (mpl rnrs-sans) 13 | (mpl arithmetic) 14 | (mpl util) 15 | (mpl degree-gpe) 16 | (mpl leading-coefficient-gpe) 17 | (mpl collect-terms) 18 | (mpl algebraic-expand) 19 | (mpl polynomial-division) 20 | (mpl extended-euclidean-algorithm)) 21 | 22 | (define (alg-mult-inverse v p a) 23 | (list-ref (extended-euclidean-algorithm v p a) 1)) 24 | 25 | (define (alg-divide u v p a) 26 | (remainder (algebraic-expand 27 | (* u (alg-mult-inverse v p a))) 28 | p a)) 29 | 30 | (define (alg-coeff-simp u x p a) 31 | (collect-terms (remainder u p a) (list x))) 32 | 33 | (define (alg-polynomial-division u v x p a) 34 | 35 | (let ((q 0) 36 | (r u) 37 | (m (degree-gpe u '(x))) 38 | (n (degree-gpe v '(x))) 39 | (lcv (leading-coefficient-gpe v x)) 40 | (lcr #f) 41 | (s #f)) 42 | 43 | (while (>= m n) 44 | 45 | (set! lcr (leading-coefficient-gpe r x)) 46 | 47 | (set! s (alg-divide lcr lcv p a)) 48 | 49 | (set! q (+ q (* s (^ x (- m n))))) 50 | 51 | (set! r (algebraic-expand 52 | (- (- r (* lcr (^ x m))) 53 | (* (- v (* lcv (^ x n))) 54 | s 55 | (^ x (- m n)))))) 56 | 57 | (set! r (alg-coeff-simp r x p a)) 58 | 59 | (set! m (degree-gpe r '(x)))) 60 | 61 | (list q r))) 62 | 63 | (define (alg-quotient u v x p a) 64 | (list-ref (alg-polynomial-division u v x p a) 0)) 65 | 66 | (define (alg-remainder u v x p a) 67 | (list-ref (alg-polynomial-division u v x p a) 1))) -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | * Setup 2 | 3 | $ cd ~/scheme # Or wherever you keep your Scheme libraries 4 | 5 | $ git clone git@github.com:dharmatech/surfage.git 6 | 7 | $ git clone git@github.com:dharmatech/dharmalab.git 8 | 9 | $ git clone git@github.com:dharmatech/mpl.git 10 | 11 | * Running the unit tests 12 | 13 | $ ikarus --r6rs-script test.sps 14 | 15 | The unit tests have been run successfully in: 16 | 17 | Ikarus (development version) 18 | Chez 8.0 19 | Ypsilon (development version) 20 | Racket 5.0.2 21 | 22 | * About 23 | 24 | Implements some of the algorithms in the books: 25 | 26 | Computer Algebra and Symbolic Computation: Elementary Algorithms 27 | 28 | and 29 | 30 | Computer Algebra and Symbolic Computation: Mathematical Methods 31 | 32 | by Joel S. Cohen. 33 | 34 | See 'test.sls' for examples. 35 | 36 | See the file 'mpl.org' for more information. 37 | 38 | * A couple of essential libraries 39 | 40 | library: (mpl rnrs-sans) 41 | 42 | Exports all of '(rnrs)' except for procedures which conflict with 43 | those provided by the mpl libraries. 44 | 45 | So basically, if you usually begin your R6RS code by importing 46 | '(rnrs)' and you'd like to make use of the MPL libraries without 47 | having to worry about naming conflicts, import '(mpl rnrs-sans)' 48 | instead. 49 | 50 | 51 | library: (mpl all) 52 | 53 | Exports the commonly used procedures and macros offered by MPL. 54 | 55 | It is generally the case each MPL component is defined in it's own 56 | library. For example, the the library '(mpl algebraic-expand)' exports 57 | the single procedure 'algebraic-expand'. When designing R6RS libraries 58 | which make use of MPL libraries, many users will choose to import 59 | individual MPL libraries a la carte. However, when you're 60 | experimenting at a REPL, it can get tedious to import the libraries 61 | individually. Thus the '(mpl all)' library is provided so that you can 62 | get the common parts of MPL in one import. 63 | -------------------------------------------------------------------------------- /automatic-simplify.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl automatic-simplify) 4 | 5 | (export automatic-simplify) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl misc) 9 | (mpl sum-product-power) 10 | (mpl sub) 11 | (mpl div) 12 | (mpl factorial) 13 | (mpl exp) 14 | (mpl log) 15 | (mpl sin) 16 | (mpl cos) 17 | (mpl tan) 18 | (mpl sqrt)) 19 | 20 | ;; (define (automatic-simplify u) 21 | ;; (if (list? u) 22 | ;; (let ((v (map automatic-simplify u))) 23 | ;; (cond ((power? v) (simplify-power v)) 24 | ;; ((product? v) (simplify-product v)) 25 | ;; ((sum? v) (simplify-sum v)) 26 | ;; ((quotient? v) (simplify-quotient v)) 27 | ;; ((difference? v) (simplify-difference v)) 28 | ;; ((factorial? v) (simplify-factorial v)) 29 | ;; (else v))) 30 | ;; u)) 31 | 32 | (define (kind v) 33 | (and (pair? v) 34 | (car v))) 35 | 36 | (define (automatic-simplify u) 37 | (if (list? u) 38 | (let ((v (map automatic-simplify u))) 39 | (cond ((power? v) (simplify-power v)) 40 | ((product? v) (simplify-product v)) 41 | ((sum? v) (simplify-sum v)) 42 | ((quotient? v) (simplify-quotient v)) 43 | ((difference? v) (simplify-difference v)) 44 | ((factorial? v) (simplify-factorial v)) 45 | 46 | ( (eq? (kind v) 'exp) (apply exp (cdr v)) ) 47 | ( (eq? (kind v) 'log) (apply log (cdr v)) ) 48 | ( (eq? (kind v) 'sin) (apply sin (cdr v)) ) 49 | ( (eq? (kind v) 'cos) (apply cos (cdr v)) ) 50 | ( (eq? (kind v) 'tan) (apply tan (cdr v)) ) 51 | 52 | ( (eq? (kind v) 'sqrt) (apply sqrt (cdr v)) ) 53 | 54 | (else v))) 55 | u)) 56 | 57 | ) -------------------------------------------------------------------------------- /algebraic-expand.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl algebraic-expand) 4 | 5 | (export algebraic-expand) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl misc) 9 | (mpl arithmetic) 10 | (mpl automatic-simplify) 11 | (mpl expand-product) 12 | (mpl expand-power)) 13 | 14 | ;; (define (algebraic-expand u) 15 | 16 | ;; (cond ( (sum? u) 17 | 18 | ;; (let ((v (list-ref u 1))) 19 | 20 | ;; (+ (algebraic-expand v) 21 | 22 | ;; (algebraic-expand (- u v)))) ) 23 | 24 | ;; ( (product? u) 25 | 26 | ;; (let ((v (list-ref u 1))) 27 | 28 | ;; (expand-product (algebraic-expand v) 29 | ;; (algebraic-expand (/ u v)))) ) 30 | 31 | ;; ( (power? u) 32 | 33 | ;; (let ((base (list-ref u 1)) 34 | ;; (exponent (list-ref u 2))) 35 | 36 | ;; (if (and (integer? exponent) 37 | ;; (>= exponent 2)) 38 | 39 | ;; (expand-power (algebraic-expand base) 40 | ;; exponent) 41 | 42 | ;; u)) ) 43 | 44 | ;; ( (list? u) 45 | ;; (automatic-simplify 46 | ;; (map algebraic-expand u)) ) 47 | 48 | ;; ( else u ))) 49 | 50 | (define (algebraic-expand u) 51 | 52 | (cond ( (sum? u) 53 | (apply + (map algebraic-expand (cdr u))) ) 54 | 55 | ( (product? u) 56 | 57 | (let ((v (list-ref u 1))) 58 | 59 | (expand-product (algebraic-expand v) 60 | (algebraic-expand (/ u v)))) ) 61 | 62 | ( (power? u) 63 | 64 | (let ((base (list-ref u 1)) 65 | (exponent (list-ref u 2))) 66 | 67 | (if (and (integer? exponent) 68 | (>= exponent 2)) 69 | 70 | (expand-power (algebraic-expand base) 71 | exponent) 72 | 73 | u)) ) 74 | 75 | ( (list? u) 76 | (automatic-simplify 77 | (map algebraic-expand u)) ) 78 | 79 | ( else u ))) 80 | 81 | 82 | 83 | ) -------------------------------------------------------------------------------- /rnrs-base.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (mpl rnrs-base) 3 | 4 | (export define define-syntax 5 | quote lambda if set! cond case and or 6 | let let* letrec letrec* let-values let*-values 7 | begin quasiquote unquote unquote-splicing 8 | let-syntax letrec-syntax syntax-rules 9 | identifier-syntax assert 10 | else => ... _ 11 | eq? 12 | eqv? 13 | equal? 14 | procedure? 15 | number? complex? real? rational? integer? 16 | real-valued? rational-valued? integer-valued? 17 | exact? inexact? 18 | inexact exact 19 | = < > <= >= 20 | zero? positive? negative? odd? even? 21 | finite? infinite? nan? 22 | max min + * - / abs 23 | div-and-mod div mod div0-and-mod0 div0 mod0 24 | gcd lcm numerator denominator 25 | floor ceiling truncate round 26 | rationalize 27 | exp log sin cos tan asin acos atan 28 | sqrt 29 | exact-integer-sqrt 30 | expt 31 | make-rectangular make-polar real-part imag-part 32 | magnitude angle 33 | number->string string->number 34 | not boolean? boolean=? 35 | pair? cons car cdr 36 | caar cadr cdar cddr caaar caadr cadar 37 | caddr cdaar cdadr cddar cdddr caaaar caaadr 38 | caadar caaddr cadaar cadadr caddar cadddr cdaaar 39 | cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr 40 | null? list? list length append reverse list-tail 41 | list-ref map for-each 42 | symbol? symbol->string string->symbol symbol=? 43 | char? char->integer integer->char 44 | char=? char? char<=? char>=? 45 | string? make-string string string-length string-ref 46 | string=? string? string<=? string>=? 47 | substring string-append string->list list->string string-copy string-for-each 48 | vector? make-vector vector vector-length vector-ref vector-set! 49 | vector->list list->vector vector-fill! 50 | vector-map vector-for-each 51 | error assertion-violation 52 | apply call-with-current-continuation call/cc 53 | values call-with-values dynamic-wind) 54 | 55 | (import (except (rnrs base) + - * / exp) 56 | (mpl automatic-simplification))) -------------------------------------------------------------------------------- /coefficient-gpe.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl coefficient-gpe) 4 | 5 | (export coefficient-gpe coefficient-monomial-gpe) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl misc) 9 | (mpl arithmetic) 10 | (mpl contains)) 11 | 12 | ;; (define (base u) 13 | ;; (list-ref u 1)) 14 | 15 | ;; (define (exponent u) 16 | ;; (list-ref u 2)) 17 | 18 | (define undefined 'undefined) 19 | 20 | (define (coefficient-monomial-gpe u x) 21 | 22 | (cond ( (equal? u x) '(1 1) ) 23 | 24 | ( (and (power? u) 25 | (equal? (base u) x) 26 | (integer? (exponent u)) 27 | (> (exponent u) 1)) 28 | 29 | (list 1 (exponent u)) ) 30 | 31 | ( (product? u) 32 | 33 | (let loop ( (m 0) 34 | (c u) 35 | (i 1) ) 36 | 37 | (if (>= i (length u)) 38 | 39 | (list c m) 40 | 41 | (let ((f (coefficient-monomial-gpe (list-ref u i) x))) 42 | 43 | (cond ( (eq? f undefined) undefined ) 44 | 45 | ( (not (equal? (list-ref f 1) 0)) 46 | 47 | (let ((m (list-ref f 1))) 48 | 49 | (let ((c (/ u (^ x m)))) 50 | 51 | (loop m c (+ i 1)))) ) 52 | 53 | ( else (loop m c (+ i 1)) ))))) ) 54 | 55 | ( (free? u x) (list u 0) ) 56 | 57 | ( else undefined ))) 58 | 59 | (define (coefficient-gpe u x j) 60 | 61 | (cond ( (not (sum? u)) 62 | 63 | (let ((f (coefficient-monomial-gpe u x))) 64 | 65 | (cond ( (eq? f undefined) undefined ) 66 | 67 | ( (equal? j (list-ref f 1)) (list-ref f 0) ) 68 | 69 | ( else 0 ))) ) 70 | 71 | ( (equal? u x) (if (equal? j 1) 1 0) ) 72 | 73 | ( else 74 | 75 | (let ((n (length u))) 76 | 77 | (let loop ( (c 0) 78 | (i 1) ) 79 | 80 | (if (>= i n) 81 | 82 | c 83 | 84 | (let ((f (coefficient-monomial-gpe (list-ref u i) x))) 85 | 86 | (cond ( (equal? f undefined) undefined ) 87 | 88 | ( (equal? (list-ref f 1) j) 89 | 90 | (loop (+ c (list-ref f 0)) 91 | (+ i 1)) ) 92 | 93 | ( else (loop c (+ i 1)) )))))) ))) 94 | 95 | ) -------------------------------------------------------------------------------- /collect-terms.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl collect-terms) 4 | 5 | (export collect-terms) 6 | 7 | (import (mpl rnrs-sans) 8 | (only (surfage s1 lists) iota) 9 | (mpl misc) 10 | (mpl arithmetic) 11 | (mpl coeff-var-monomial)) 12 | 13 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | (define-syntax while 16 | (syntax-rules () 17 | ( (while test expr ...) 18 | (let loop () 19 | (if test 20 | (begin expr 21 | ... 22 | (loop)))) ))) 23 | 24 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | 26 | (define (hashtable-values tbl) 27 | (call-with-values 28 | (lambda () 29 | (hashtable-entries tbl)) 30 | (lambda (keys vals) 31 | vals))) 32 | 33 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 | 35 | (define (print . elts) 36 | (for-each display elts)) 37 | 38 | (define (say . elts) 39 | (for-each display elts) 40 | (newline)) 41 | 42 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43 | 44 | (define (collect-terms u S) 45 | 46 | (cond ( (not (sum? u)) u ) 47 | 48 | ( (member u S) u ) 49 | 50 | ( else 51 | 52 | (let ((N 0) 53 | (T (make-eq-hashtable))) 54 | 55 | (for-each 56 | 57 | (lambda (i) 58 | 59 | (let ((f (coeff-var-monomial (list-ref u i) S))) 60 | 61 | (let ((j 1) 62 | (combined #f)) 63 | 64 | (while (and (not combined) 65 | (<= j N)) 66 | 67 | (if (equal? (list-ref f 1) 68 | (list-ref (hashtable-ref T j '(#f #f)) 1)) 69 | (begin 70 | 71 | (hashtable-set! T 72 | j 73 | (list (+ (list-ref f 0) 74 | (list-ref (hashtable-ref T j #f) 75 | 0)) 76 | (list-ref f 1))) 77 | 78 | (set! combined #t))) 79 | 80 | (set! j (+ j 1))) 81 | 82 | (if (not combined) 83 | 84 | (begin 85 | 86 | (hashtable-set! T (+ N 1) f) 87 | 88 | (set! N (+ N 1))))))) 89 | 90 | (cdr (iota (length u)))) 91 | 92 | (apply + 93 | (map 94 | (lambda (val) 95 | (apply * val)) 96 | (vector->list 97 | (hashtable-values T)))) 98 | 99 | )))) 100 | 101 | ) 102 | 103 | -------------------------------------------------------------------------------- /misc.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl misc) 4 | 5 | (export product? quotient? sum? difference? power? factorial? function? 6 | exp? 7 | sin? 8 | cos? 9 | tan? 10 | vars 11 | base 12 | exponent 13 | inexact-number?) 14 | 15 | (import (rnrs) 16 | (mpl match)) 17 | 18 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | 20 | (define (product? expr) 21 | (match expr 22 | ( ('* . elts) #t ) 23 | ( else #f ))) 24 | 25 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 | 27 | (define (quotient? expr) 28 | (match expr 29 | ( ('/ . elts) #t ) 30 | ( else #f ))) 31 | 32 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | 34 | (define (sum? expr) 35 | (match expr 36 | ( ('+ . elts) #t ) 37 | ( else #f ))) 38 | 39 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | 41 | (define (difference? expr) 42 | (match expr 43 | ( ('- . elts) #t ) 44 | ( else #f ))) 45 | 46 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | 48 | (define (power? expr) 49 | (match expr 50 | ( ('^ x y) #t ) 51 | ( else #f ))) 52 | 53 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | 55 | (define (factorial? expr) 56 | (match expr 57 | ( ('! n) #t ) 58 | ( else #f ))) 59 | 60 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | 62 | (define (exp? expr) 63 | (match expr 64 | ( ('exp n) #t ) 65 | ( else #f ))) 66 | 67 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 68 | 69 | (define (sin? expr) 70 | (and (pair? expr) 71 | (eq? (car expr) 'sin))) 72 | 73 | (define (cos? expr) 74 | (and (pair? expr) 75 | (eq? (car expr) 'cos))) 76 | 77 | (define (tan? expr) 78 | (and (pair? expr) 79 | (eq? (car expr) 'tan))) 80 | 81 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 82 | 83 | (define (function? expr) 84 | (and (list? expr) 85 | (> (length expr) 1) 86 | (symbol? (car expr)) 87 | (not (member (car expr) 88 | '(+ - * / ^ !))))) 89 | 90 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 91 | 92 | (define (base expr) 93 | (if (power? expr) 94 | (list-ref expr 1) 95 | expr)) 96 | 97 | (define (exponent expr) 98 | (if (power? expr) 99 | (list-ref expr 2) 100 | 1)) 101 | 102 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 103 | 104 | (define-syntax vars 105 | (syntax-rules () 106 | ((vars name ...) 107 | (begin (define name 'name) 108 | ...)))) 109 | 110 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | 112 | (define (inexact-number? x) 113 | (and (number? x) 114 | (inexact? x))) 115 | 116 | ) -------------------------------------------------------------------------------- /mpl.org: -------------------------------------------------------------------------------- 1 | 2 | * Introduction 3 | 4 | There are a few barriers in the way of understanding how a computer 5 | algebra system works. Commercial systems like Mathematica, Maple, and 6 | the engines in the TI-89 and HP-50 calculators are closed source. Some 7 | open source ones such as Axiom and Maxima can be incredibly complex. 8 | 9 | [[http://web.cs.du.edu/~jscohen/][Joel S. Cohen]], professor emeritus at the University of Denver, 10 | authored two volumes which can help dispel the mystery of CAS 11 | internals: 12 | 13 | [[http://web.cs.du.edu/~jscohen/ElementaryAlgorithms/index.htm][Computer Algebra and Symbolic Computation: Elementary Algorithms]] 14 | 15 | [[http://web.cs.du.edu/~jscohen/MathematicalMethods/index.htm][Computer Algebra and Symbolic Computation: Mathematical Methods]] 16 | 17 | In these texts, Cohen uses a "Mathematical Pseudo Language" (MPL) to 18 | illustrate some basic algorithms used in computer algebra systems. 19 | 20 | The [[http://github.com/dharmatech/mpl][mpl]] Scheme libraries are implementations of some of these 21 | algorithms. 22 | 23 | Up till now, I've hacked on the system while in Minneapolis Minnesota, 24 | so perhaps I should call the project 'mpls'. ;-) 25 | 26 | * Implementation support 27 | 28 | The mpl libraries are designed for Scheme systems which implement the 29 | R6RS standard. 30 | 31 | The mpl testsuite successfully runs in: 32 | 33 | - Ikarus 34 | - Ypsilon 35 | - Chez 36 | - Mosh 37 | 38 | * Other projects 39 | 40 | ** sympy 41 | 42 | [[http://code.google.com/p/sympy/][Sympy]] endows Python with symbolic math capabilities. 43 | 44 | ** JACAL 45 | 46 | [[http://people.csail.mit.edu/jaffer/JACAL][JACAL]] is a CAS written in R5RS Scheme which runs in many 47 | implementations that support SLIB. 48 | 49 | ** MIT Scheme based scmutils 50 | 51 | [[http://groups.csail.mit.edu/mac/users/gjs/6946/linux-install.htm][Software]] used for the [[http://mitpress.mit.edu/SICM/book.html][book]] Structure and Interpretation of 52 | Classical Mechanics. 53 | 54 | * A tour of mpl 55 | 56 | ** Symbolic arithmetic 57 | 58 | In standard Scheme, if you try to add two symbols, you'll get an 59 | error: 60 | 61 | :> (+ 'x 'x) 62 | :Unhandled exception 63 | :... 64 | 65 | Let's try again with the help of mpl: 66 | 67 | :> (import (mpl arithmetic)) 68 | :> (+ 'x 'x) 69 | :(* 2 x) 70 | 71 | The '(mpl arithmetic)' library offers symbolic versions of + - * / ^. 72 | 73 | ** Symbolic trigonometry 74 | 75 | The '(mpl trig)' library offers symbolic versions of sin and cos. 76 | 77 | ** Infix expressions 78 | 79 | mpl comes with a basic infix expression mechanism. 80 | 81 | :> (import (mpl alge)) 82 | :> (alge "2+x*y+z^2") 83 | :(+ 2 (* x y) (^ z 2)) 84 | 85 | ** vars 86 | 87 | You can use 'vars' to create a bunch of self-quoting symbols. For 88 | example, if you know you'll be working with x, y, and z, alot and 89 | don't want to quote them manually, you can do: 90 | 91 | :> (import (mpl misc)) 92 | :> (vars x y z) 93 | :> (/ (+ x y) z) 94 | 95 | ** collect-terms 96 | 97 | 'collect-terms' knows how to handle basic collection of terms: 98 | 99 | :> (import (mpl collect-terms)) 100 | :> (collect-terms (alge " 2 a x y + 3 b x y + 4 a x + 5 b x ") 101 | : '(x y)) 102 | :(+ (* (+ (* 4 a) (* 5 b)) x) (* (+ (* 2 a) (* 3 b)) x y)) 103 | 104 | ** algebraic-expand 105 | 106 | :> (import (mpl algebraic-expand)) 107 | :> (algebraic-expand (alge " (2 a + 3 b) x y + (4 a + 5 b) x ")) 108 | :(+ (* 4 a x) (* 5 b x) (* 2 a x y) (* 3 b x y)) 109 | 110 | ** The test suite 111 | 112 | Take a look at the file [[./test.sls]] to get more ideas of what is 113 | possible. 114 | 115 | -------------------------------------------------------------------------------- /cos.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl cos) 4 | 5 | (export cos) 6 | 7 | (import (mpl rnrs-sans) 8 | (rename (only (rnrs) cos) (cos rnrs:cos)) 9 | (mpl match) 10 | (mpl arithmetic) 11 | (mpl numerator) 12 | (mpl denominator) 13 | (mpl sqrt) 14 | (mpl misc)) 15 | 16 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | 18 | (define pi 'pi) 19 | 20 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | 22 | (define (simplify-cos-first-quadrant a/b) 23 | 24 | (cond ( (> a/b 2) (cos (* (mod a/b 2) pi)) ) 25 | 26 | ( (> a/b 1) (- (cos (- (* a/b pi) pi))) ) 27 | 28 | ( (> a/b 1/2) (- (cos (- pi (* a/b pi)))) ) 29 | 30 | ( else `(cos ,(* a/b pi)) ))) 31 | 32 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | 34 | (define (simplify-cos-k/n*pi k/n) 35 | 36 | (let ((k (numerator k/n)) 37 | (n (denominator k/n))) 38 | 39 | (case n 40 | 41 | ((1) (case (mod k 2) 42 | ((1) -1) 43 | ((0) 1))) 44 | 45 | ((2) (case (mod k 2) 46 | ((1) 0))) 47 | 48 | ((3) (case (mod k 6) 49 | ((1 5) 1/2) 50 | ((2 4) -1/2))) 51 | 52 | ((4) (case (mod k 8) 53 | ((1 7) (/ 1 (sqrt 2))) 54 | ((3 5) (- (/ 1 (sqrt 2)))))) 55 | 56 | ((6) (case (mod k 12) 57 | ((1 11) (/ (sqrt 3) 2)) 58 | ((5 7) (- (/ (sqrt 3) 2)))))))) 59 | 60 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 61 | 62 | (define (n*pi? elt) 63 | (define (n? x) 64 | (and (number? x) 65 | (exact? x) 66 | (>= (abs x) 2))) 67 | (match elt 68 | ( ('* (? n?) 'pi) #t ) 69 | ( else #f ))) 70 | 71 | (define (simplify-cos-sum-with-pi elts) 72 | (let ((pi-elt (find n*pi? elts))) 73 | (let ((n (list-ref pi-elt 1))) 74 | (cos (+ (- (apply + elts) pi-elt) 75 | (* (mod n 2) pi)))))) 76 | 77 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 78 | 79 | (define (n/2*pi? elt) 80 | (define (n/2? x) 81 | (and (number? x) 82 | (exact? x) 83 | (equal? (denominator x) 2))) 84 | (match elt 85 | ( ('* (? n/2?) 'pi) #t ) 86 | ( else #f ))) 87 | 88 | (define (simplify-cos-sum-with-n/2*pi elts) 89 | (let ((n/2*pi (find n/2*pi? elts))) 90 | (let ((other-elts (- (apply + elts) n/2*pi))) 91 | (let ((n (numerator (list-ref n/2*pi 1)))) 92 | (case (mod n 4) 93 | ((1) (- `(sin ,other-elts))) 94 | ((3) `(sin ,other-elts))))))) 95 | 96 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 97 | 98 | (define (simplify-cos u) 99 | 100 | (match u 101 | 102 | ( ('cos 0) 1 ) 103 | 104 | ( ('cos 'pi) -1 ) 105 | 106 | ( ('cos (? inexact-number? n)) (rnrs:cos n) ) 107 | 108 | ( (and ('cos n) 109 | (? (lambda (_) 110 | (and (number? n) 111 | (negative? n))))) 112 | (cos (- n)) ) 113 | 114 | ( (and ('cos ('* n . elts)) 115 | (? (lambda (_) 116 | (and (number? n) 117 | (negative? n))))) 118 | (cos (apply * (append (list -1 n) elts))) ) 119 | 120 | ( (and ('cos ('* a/b 'pi)) 121 | (? (lambda (_) 122 | (and (number? a/b) 123 | (exact? a/b) 124 | (> a/b 1/2))))) 125 | (simplify-cos-first-quadrant a/b) ) 126 | 127 | ( (and ('cos ('* k/n 'pi)) 128 | (? (lambda (_) 129 | (and (member (denominator k/n) '(1 2 3 4 6)) 130 | (integer? (numerator k/n)))))) 131 | 132 | (simplify-cos-k/n*pi k/n) ) 133 | 134 | ( (and ('cos ('+ . elts)) 135 | (? (lambda (_) 136 | (find n*pi? elts)))) 137 | (simplify-cos-sum-with-pi elts) ) 138 | 139 | ( (and ('cos ('+ . elts)) 140 | (? (lambda (_) 141 | (find n/2*pi? elts)))) 142 | (simplify-cos-sum-with-n/2*pi elts) ) 143 | 144 | ( else u ))) 145 | 146 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 | 148 | (define (cos x) 149 | (simplify-cos `(cos ,x))) 150 | 151 | ) -------------------------------------------------------------------------------- /sin.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl sin) 4 | 5 | (export sin) 6 | 7 | (import (mpl rnrs-sans) 8 | (rename (only (rnrs) sin) (sin rnrs:sin)) 9 | (mpl match) 10 | (mpl arithmetic) 11 | (mpl numerator) 12 | (mpl denominator) 13 | (mpl sqrt) 14 | (mpl misc)) 15 | 16 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | 18 | (define pi 'pi) 19 | 20 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | 22 | (define (simplify-sin-first-quadrant a/b) 23 | 24 | (cond ( (> a/b 2) 25 | 26 | (sin (* (mod a/b 2) pi)) ) 27 | 28 | ( (> a/b 1) 29 | 30 | (- (sin (- (* a/b pi) pi))) ) 31 | 32 | ( (> a/b 1/2) 33 | 34 | (sin (* (- 1 a/b) pi)) ) 35 | 36 | ( else `(sin ,(* a/b pi)) ))) 37 | 38 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 39 | 40 | (define (simplify-sin-k/n*pi k/n) 41 | 42 | (let ((k (numerator k/n)) 43 | (n (denominator k/n))) 44 | 45 | (case n 46 | 47 | ((1) 0) 48 | 49 | ((2) (case (mod k 4) 50 | ((1) 1) 51 | ((3) -1))) 52 | 53 | ((3) (case (mod k 6) 54 | ((1 2) (/ (sqrt 3) 2)) 55 | ((4 5) (- (/ (sqrt 3) 2))))) 56 | 57 | ((4) (case (mod k 8) 58 | ((1 3) (/ 1 (sqrt 2))) 59 | ((5 7) (- (/ 1 (sqrt 2)))))) 60 | 61 | ((6) (case (mod k 12) 62 | ((1 5) 1/2) 63 | ((7 11) -1/2)))))) 64 | 65 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | 67 | (define (n*pi? elt) 68 | (match elt 69 | ( (and ('* n 'pi) 70 | (? (lambda (_) 71 | (and (number? n) 72 | (exact? n) 73 | (>= (abs n) 2))))) 74 | #t ) 75 | ( else #f ))) 76 | 77 | (define (simplify-sum-with-pi elts) 78 | 79 | (let ((pi-elt (find n*pi? elts))) 80 | 81 | (let ((n (list-ref pi-elt 1))) 82 | 83 | (sin (+ (- (apply + elts) pi-elt) 84 | (* (mod n 2) pi)))))) 85 | 86 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 87 | 88 | (define (n/2*pi? elt) 89 | (define (n/2? x) 90 | (and (number? x) 91 | (exact? x) 92 | (equal? (denominator x) 2))) 93 | (match elt 94 | ( ('* (? n/2?) 'pi) #t ) 95 | ( else #f ))) 96 | 97 | (define (simplify-sin-sum-with-n/2*pi elts) 98 | (let ((n/2*pi (find n/2*pi? elts))) 99 | (let ((other-elts (- (apply + elts) n/2*pi))) 100 | (let ((n (numerator (list-ref n/2*pi 1)))) 101 | (case (mod n 4) 102 | ((1) `(cos ,other-elts)) 103 | ((3) (- `(cos ,other-elts)))))))) 104 | 105 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 106 | 107 | (define (simplify-sin u) 108 | 109 | (match u 110 | 111 | ( ('sin 0) 0 ) 112 | 113 | ( ('sin 'pi) 0 ) 114 | 115 | ( ('sin (? inexact-number? n)) (rnrs:sin n) ) 116 | 117 | ( (and ('sin n) 118 | (? (lambda (_) 119 | (and (number? n) 120 | (negative? n))))) 121 | (- (sin (* -1 n))) ) 122 | 123 | ( (and ('sin ('* n . elts)) 124 | (? (lambda (_) 125 | (and (number? n) 126 | (negative? n))))) 127 | 128 | (- (sin (apply * (append (list -1 n) elts)))) ) 129 | 130 | ( (and ('sin ('* a/b 'pi)) 131 | (? (lambda (_) 132 | (and (number? a/b) 133 | (exact? a/b) 134 | (> a/b 1/2))))) 135 | (simplify-sin-first-quadrant a/b) ) 136 | 137 | ( (and ('sin ('* k/n 'pi)) 138 | (? (lambda (_) 139 | (and (member (denominator k/n) '(1 2 3 4 6)) 140 | (integer? (numerator k/n)))))) 141 | 142 | (simplify-sin-k/n*pi k/n) ) 143 | 144 | ( (and ('sin ('+ . elts)) 145 | (? (lambda (_) 146 | (find n*pi? elts)))) 147 | (simplify-sum-with-pi elts) ) 148 | 149 | ( (and ('sin ('+ . elts)) 150 | (? (lambda (_) 151 | (find n/2*pi? elts)))) 152 | (simplify-sin-sum-with-n/2*pi elts) ) 153 | 154 | ( else u ))) 155 | 156 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 | 158 | (define (sin x) 159 | (simplify-sin `(sin ,x))) 160 | 161 | ) -------------------------------------------------------------------------------- /order-relation.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl order-relation) 4 | 5 | (export base 6 | exponent 7 | 8 | term 9 | const 10 | 11 | order-relation) 12 | 13 | (import (rnrs) 14 | (mpl match) 15 | (except (mpl misc) base exponent)) 16 | 17 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | 19 | (define (base u) 20 | (match u 21 | ( ('^ x y) x ) 22 | ( (? number?) #f ) 23 | ( else u ))) 24 | 25 | (define (exponent u) 26 | (match u 27 | ( ('^ x y) y ) 28 | ( (? number?) #f ) 29 | ( else 1 ))) 30 | 31 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | 33 | (define (term u) 34 | 35 | (match u 36 | 37 | ( (? number?) #f ) 38 | 39 | ( (and ('* u1 . u-rest) 40 | (? (lambda (_) 41 | (number? u1)))) 42 | 43 | `(* ,@u-rest) ) 44 | 45 | ( ('* . u-elts) u ) 46 | 47 | ( else `(* ,u) ))) 48 | 49 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 50 | 51 | (define (const u) 52 | (match u 53 | ( (? number?) #f ) 54 | ( (and ('* u1 . u-rest) 55 | (? (lambda (_) 56 | (number? u1)))) 57 | u1 ) 58 | ( ('* . u-elts) 1 ) 59 | ( else 1 ))) 60 | 61 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 62 | 63 | (define (O-3 u-elts v-elts) 64 | (cond ((null? u-elts) #t) 65 | ((null? v-elts) #f) 66 | (else 67 | (let ((u (car u-elts)) 68 | (v (car v-elts))) 69 | (if (not (equal? u v)) 70 | (order-relation u v) 71 | (O-3 (cdr u-elts) 72 | (cdr v-elts))))))) 73 | 74 | (define (order-relation u v) 75 | 76 | (cond ((and (number? u) 77 | (number? v)) ;; O-1 78 | (< u v)) 79 | 80 | ((and (symbol? u) 81 | (symbol? v)) ;; O-2 82 | 83 | (stringstring u) 84 | (symbol->string v))) 85 | 86 | ((or (and (product? u) 87 | (product? v)) 88 | (and (sum? u) 89 | (sum? v))) ;; O-3 90 | (O-3 (reverse (cdr u)) 91 | (reverse (cdr v)))) 92 | 93 | ((and (power? u) 94 | (power? v)) ;; O-4 95 | 96 | (if (equal? (base u) 97 | (base v)) 98 | 99 | (order-relation (exponent u) 100 | (exponent v)) 101 | 102 | (order-relation (base u) 103 | (base v)))) 104 | 105 | ((and (factorial? u) 106 | (factorial? v)) ;; O-5 107 | 108 | (order-relation (list-ref u 1) 109 | (list-ref v 1))) 110 | 111 | ((and (function? u) 112 | (function? v)) ;; O-6 113 | 114 | (if (equal? (car u) 115 | (car v)) 116 | 117 | (O-3 (cdr u) 118 | (cdr v)) 119 | 120 | (order-relation (car u) 121 | (car v)))) 122 | 123 | ((and (number? u) 124 | (not (number? v))) ;; O-7 125 | #t) 126 | 127 | ((and (product? u) 128 | (or (power? v) 129 | (sum? v) 130 | (factorial? v) 131 | (function? v) 132 | (symbol? v))) ;; O-8 133 | (order-relation u `(* ,v))) 134 | 135 | ((and (power? u) 136 | (or (sum? v) 137 | (factorial? v) 138 | (function? v) 139 | (symbol? v))) ;; O-9 140 | 141 | (order-relation u `(^ ,v 1))) 142 | 143 | ((and (sum? u) 144 | (or (factorial? v) 145 | (function? v) 146 | (symbol? v))) ;; O-10 147 | 148 | (order-relation u `(+ ,v))) 149 | 150 | ((and (factorial? u) 151 | (or (function? v) 152 | (symbol? v))) ;; O-11 153 | 154 | (if (equal? (list-ref u 1) v) 155 | #f 156 | (order-relation u `(! ,v)))) 157 | 158 | ((and (function? u) 159 | (symbol? v)) ;; O-12 160 | (if (equal? (car u) v) 161 | #f 162 | (order-relation (car u) v))) 163 | 164 | (else ;; O-13 165 | (not (order-relation v u))))) 166 | 167 | ) -------------------------------------------------------------------------------- /sum-product-power.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl sum-product-power) 4 | 5 | (export + * ^ 6 | simplify-sum 7 | simplify-product 8 | simplify-power) 9 | 10 | (import (rename (rnrs) (+ rnrs:+) (* rnrs:*)) 11 | (mpl match) 12 | (dharmalab misc equivalence) 13 | (dharmalab misc list) 14 | (mpl order-relation)) 15 | 16 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | 18 | (define (list-or-null-if-0 x) 19 | (if (equal? x 0) 20 | '() 21 | (list x))) 22 | 23 | (define (list-or-null-if-1 x) 24 | (if (equal? x 1) 25 | '() 26 | (list x))) 27 | 28 | (define any-are-zero? (any-are (equal-to 0))) 29 | 30 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | ;; ^ 32 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | 34 | (define (raise-to expo) 35 | (lambda (base) 36 | (^ base expo))) 37 | 38 | (define (^ v w) 39 | (match (list v w) 40 | ((0 w) 0) 41 | ((1 w) 1) 42 | ((v 0) 1) 43 | ((v 1) v) 44 | (((? number?) (? integer?)) (expt v w)) 45 | ((('^ r s) (? integer?)) (^ r (* s w))) 46 | ((('* . vs) (? integer?)) (apply * (map (raise-to w) vs))) 47 | (else `(^ ,v ,w) ))) 48 | 49 | (define (simplify-power u) 50 | (^ (list-ref u 1) 51 | (list-ref u 2))) 52 | 53 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | ;; * 55 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | 57 | (define (merge-products p-elts q-elts) 58 | (match (list p-elts q-elts) 59 | ( (() x) x ) 60 | ( (x ()) x ) 61 | ( ((p . ps) (q . qs)) 62 | (match (simplify-product-rec (list p q)) 63 | ( () (merge-products ps qs) ) 64 | ( (x) (cons x (merge-products ps qs)) ) 65 | ( (? (equal-to (list p q))) (cons p (merge-products ps q-elts)) ) 66 | ( (? (equal-to (list q p))) (cons q (merge-products p-elts qs)) )) ))) 67 | 68 | (define (simplify-product-rec elts) 69 | (match elts 70 | ( (('* . p-elts) ('* . q-elts)) (merge-products p-elts q-elts) ) 71 | ( (('* . p-elts) q) (merge-products p-elts (list q)) ) 72 | ( (p ('* . q-elts)) (merge-products (list p) q-elts) ) 73 | ( ((? number? p) (? number? q)) (list-or-null-if-1 (rnrs:* p q)) ) 74 | ( (1 x) (list x) ) 75 | ( (x 1) (list x) ) 76 | ( (p q) (cond ((equal? (base p) (base q)) 77 | (list-or-null-if-1 78 | (^ (base p) 79 | (+ (exponent p) 80 | (exponent q))))) 81 | 82 | ((order-relation q p) (list q p)) 83 | 84 | (else (list p q))) ) 85 | ( (('* . ps) . qs) (merge-products ps (simplify-product-rec qs)) ) 86 | ( (x . xs) (merge-products (list x) (simplify-product-rec xs)) ))) 87 | 88 | (define (simplify-product u) 89 | (match u 90 | ( ('* x) x ) 91 | ( ('* . (? any-are-zero?)) 0 ) 92 | ( ('* . elts) 93 | (match (simplify-product-rec elts) 94 | ( () 1 ) 95 | ( (x) x ) 96 | ( xs `(* ,@xs) )) ))) 97 | 98 | (define (* . elts) 99 | (simplify-product `(* ,@elts))) 100 | 101 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 102 | ;; + 103 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | 105 | (define (merge-sums p-elts q-elts) 106 | (match (list p-elts q-elts) 107 | ( (() x) x ) 108 | ( (x ()) x ) 109 | ( ((p . ps) (q . qs)) 110 | (match (simplify-sum-rec (list p q)) 111 | ( () (merge-sums ps qs) ) 112 | ( (x) (cons x (merge-sums ps qs)) ) 113 | ( (? (equal-to (list p q))) (cons p (merge-sums ps q-elts)) ) 114 | ( (? (equal-to (list q p))) (cons q (merge-sums p-elts qs)) )) ))) 115 | 116 | (define (simplify-sum-rec elts) 117 | (match elts 118 | ( (('+ . p-elts) ('+ . q-elts)) (merge-sums p-elts q-elts) ) 119 | ( (('+ . p-elts) q) (merge-sums p-elts (list q)) ) 120 | ( (p ('+ . q-elts)) (merge-sums (list p) q-elts) ) 121 | ( ((? number? p) (? number? q)) (list-or-null-if-0 (rnrs:+ p q)) ) 122 | ( (0 x) (list x) ) 123 | ( (x 0) (list x) ) 124 | ( (p q) (cond ((equal? (term p) (term q)) 125 | (list-or-null-if-0 126 | (* (term p) 127 | (+ (const p) 128 | (const q))))) 129 | 130 | ((order-relation q p) 131 | (list q p)) 132 | 133 | (else (list p q))) ) 134 | ( (('+ . ps) . qs) (merge-sums ps (simplify-sum-rec qs)) ) 135 | ( (x . xs) (merge-sums (list x) (simplify-sum-rec xs)) ))) 136 | 137 | (define (simplify-sum u) 138 | (match u 139 | ( ('+ x) x ) 140 | ( ('+ . elts) 141 | (match (simplify-sum-rec elts) 142 | ( () 0 ) 143 | ( (x) x ) 144 | ( xs `(+ ,@xs) )) ))) 145 | 146 | (define (+ . elts) 147 | (simplify-sum `(+ ,@elts))) 148 | 149 | ) -------------------------------------------------------------------------------- /expand-trig.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl expand-trig) 4 | 5 | (export expand-trig) 6 | 7 | (import (mpl rnrs-sans) 8 | (mpl misc) 9 | (mpl arithmetic) 10 | (mpl sin) 11 | (mpl cos) 12 | (mpl expand-main-op)) 13 | 14 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | 16 | (define (binomial-coefficient n k) 17 | (cond ( (= k 0) 1 ) 18 | ( (= n k) 1 ) 19 | ( else 20 | 21 | (+ (binomial-coefficient (- n 1) 22 | (- k 1)) 23 | (binomial-coefficient (- n 1) 24 | k)) ))) 25 | 26 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | 28 | (define (sigma f a b step) 29 | (let loop ((a a) (sum 0)) 30 | (if (> a b) 31 | sum 32 | (loop (+ a step) 33 | (+ sum (f a)))))) 34 | 35 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 36 | 37 | ;; (define (multiple-angle-sin n angle) 38 | 39 | ;; (let ((f (if (sum? angle) 40 | ;; (expand-trig-rules angle) 41 | ;; (list (sin angle) 42 | ;; (cos angle))))) 43 | 44 | ;; (let ((sin-angle (list-ref f 0)) 45 | ;; (cos-angle (list-ref f 1))) 46 | 47 | ;; (sigma (lambda (j) (* (^ -1 (/ (- j 1) 2)) 48 | ;; (binomial-coefficient n j) 49 | ;; (^ cos-angle (- n j)) 50 | ;; (^ sin-angle j))) 51 | ;; 1 n 2)))) 52 | 53 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 54 | 55 | (define (multiple-angle-sin n angle) 56 | 57 | (let ((f (if (sum? angle) 58 | (expand-trig-rules angle) 59 | (list (sin angle) 60 | (cos angle))))) 61 | 62 | (let ((sin-angle (list-ref f 0)) 63 | (cos-angle (list-ref f 1))) 64 | 65 | (let ((sign (if (< n 0) -1 1)) 66 | (n (abs n))) 67 | 68 | (* sign 69 | (sigma (lambda (j) (* (^ -1 (/ (- j 1) 2)) 70 | (binomial-coefficient n j) 71 | (^ cos-angle (- n j)) 72 | (^ sin-angle j))) 73 | 1 n 2)))))) 74 | 75 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 76 | 77 | (define (multiple-angle-cos n angle) 78 | 79 | (let ((f (if (sum? angle) 80 | (expand-trig-rules angle) 81 | (list (sin angle) 82 | (cos angle))))) 83 | 84 | (let ((sin-angle (list-ref f 0)) 85 | (cos-angle (list-ref f 1))) 86 | 87 | (let ((n (abs n))) 88 | 89 | (sigma (lambda (j) (* (^ -1 (/ j 2)) 90 | (binomial-coefficient n j) 91 | (^ cos-angle (- n j)) 92 | (^ sin-angle j))) 93 | 0 n 2))))) 94 | 95 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 96 | 97 | (define (expand-trig-rules A) 98 | 99 | (cond ( (sum? A) 100 | 101 | (let ((f (expand-trig-rules (list-ref A 1))) 102 | (r (expand-trig-rules (- A (list-ref A 1))))) 103 | 104 | (let ((s (+ (* (list-ref f 0) 105 | (list-ref r 1)) 106 | (* (list-ref f 1) 107 | (list-ref r 0)))) 108 | (c (- (* (list-ref f 1) 109 | (list-ref r 1)) 110 | (* (list-ref f 0) 111 | (list-ref r 0))))) 112 | 113 | (list s c))) ) 114 | 115 | ( (and (product? A) 116 | (integer? (list-ref A 1))) 117 | 118 | (let ((f (list-ref A 1))) 119 | (list (multiple-angle-sin f (/ A f)) 120 | (multiple-angle-cos f (/ A f)))) ) 121 | 122 | ( else (list (sin A) 123 | (cos A)) ))) 124 | 125 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 126 | 127 | ;; (define (expand-trig-rules A) 128 | 129 | ;; (cond ( (sum? A) 130 | 131 | ;; (let ((f (expand-trig-rules (list-ref A 1))) 132 | ;; (r (expand-trig-rules (- A (list-ref A 1))))) 133 | 134 | ;; (let ((s (+ (* (list-ref f 0) 135 | ;; (list-ref r 1)) 136 | ;; (* (list-ref f 1) 137 | ;; (list-ref r 0)))) 138 | ;; (c (- (* (list-ref f 1) 139 | ;; (list-ref r 1)) 140 | ;; (* (list-ref f 0) 141 | ;; (list-ref r 0))))) 142 | 143 | ;; (list s c))) ) 144 | 145 | ;; ( (and (product? A) 146 | ;; (integer? (list-ref A 1))) 147 | 148 | ;; (let ((f (list-ref A 1))) 149 | ;; (list (expand-main-op (multiple-angle-sin f (/ A f))) 150 | ;; (expand-main-op (multiple-angle-cos f (/ A f))))) ) 151 | 152 | ;; ( else (list (sin A) 153 | ;; (cos A)) ))) 154 | 155 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 156 | 157 | ;; (define (expand-trig-rules A) 158 | 159 | ;; (cond ( (sum? A) 160 | 161 | ;; (let ((f (expand-trig-rules (list-ref A 1))) 162 | ;; (r (expand-trig-rules (- A (list-ref A 1))))) 163 | 164 | ;; (let ((s (+ (expand-main-op (* (list-ref f 0) 165 | ;; (list-ref r 1))) 166 | ;; (expand-main-op (* (list-ref f 1) 167 | ;; (list-ref r 0))))) 168 | ;; (c (- (expand-main-op (* (list-ref f 1) 169 | ;; (list-ref r 1))) 170 | ;; (expand-main-op (* (list-ref f 0) 171 | ;; (list-ref r 0)))))) 172 | 173 | ;; (list s c))) ) 174 | 175 | ;; ( (and (product? A) 176 | ;; (integer? (list-ref A 1))) 177 | 178 | ;; (let ((f (list-ref A 1))) 179 | ;; (list (expand-main-op (multiple-angle-sin f (/ A f))) 180 | ;; (expand-main-op (multiple-angle-cos f (/ A f))))) ) 181 | 182 | ;; ( else (list (sin A) 183 | ;; (cos A)) ))) 184 | 185 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 186 | 187 | (define (kind u) 188 | (and (pair? u) 189 | (car u))) 190 | 191 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 192 | 193 | ;; Original version from book 194 | 195 | (define (expand-trig u) 196 | 197 | (if (or (number? u) 198 | (symbol? u)) 199 | 200 | u 201 | 202 | (let ((v (map expand-trig u))) 203 | 204 | (case (kind u) 205 | 206 | ( (sin) (list-ref (expand-trig-rules (list-ref v 1)) 0) ) 207 | ( (cos) (list-ref (expand-trig-rules (list-ref v 1)) 1) ) 208 | ( else v ))))) 209 | 210 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 211 | 212 | ;; (define (expand-trig u) 213 | 214 | ;; (if (or (number? u) 215 | ;; (symbol? u)) 216 | 217 | ;; u 218 | 219 | ;; (let ((v (expand-main-op (map expand-trig u)))) 220 | 221 | ;; (case (kind u) 222 | 223 | ;; ( (sin) (list-ref (expand-trig-rules (list-ref v 1)) 0) ) 224 | ;; ( (cos) (list-ref (expand-trig-rules (list-ref v 1)) 1) ) 225 | ;; ( else v ))))) 226 | 227 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 228 | 229 | ) -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright {yyyy} {name of copyright owner} 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /rnrs-sans.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | ;; (rnrs) minus items which conflict with procedures provided by mpl 4 | 5 | (library (mpl rnrs-sans) 6 | 7 | (export 8 | 9 | #; (rnrs base (6)) 10 | define define-syntax 11 | quote lambda if set! cond case and or 12 | let let* letrec letrec* let-values let*-values 13 | begin quasiquote unquote unquote-splicing 14 | let-syntax letrec-syntax syntax-rules 15 | identifier-syntax assert 16 | else => ... _ 17 | eq? 18 | eqv? 19 | equal? 20 | procedure? 21 | number? complex? real? rational? integer? 22 | real-valued? rational-valued? integer-valued? 23 | exact? inexact? 24 | inexact exact 25 | = < > <= >= 26 | zero? positive? negative? odd? even? 27 | finite? infinite? nan? 28 | max min abs 29 | div-and-mod div mod div0-and-mod0 div0 mod0 30 | gcd lcm 31 | floor ceiling truncate round 32 | rationalize 33 | ;; log 34 | ;; tan 35 | asin acos atan 36 | exact-integer-sqrt 37 | expt 38 | make-rectangular make-polar real-part imag-part 39 | magnitude angle 40 | number->string string->number 41 | not boolean? boolean=? 42 | pair? cons car cdr 43 | caar cadr cdar cddr caaar caadr cadar 44 | caddr cdaar cdadr cddar cdddr caaaar caaadr 45 | caadar caaddr cadaar cadadr caddar cadddr cdaaar 46 | cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr 47 | null? list? list length append reverse list-tail 48 | list-ref map for-each 49 | symbol? symbol->string string->symbol symbol=? 50 | char? char->integer integer->char 51 | char=? char? char<=? char>=? 52 | string? make-string string string-length string-ref 53 | string=? string? string<=? string>=? 54 | substring string-append string->list list->string string-copy string-for-each 55 | vector? make-vector vector vector-length vector-ref vector-set! 56 | vector->list list->vector vector-fill! 57 | vector-map vector-for-each 58 | error assertion-violation 59 | apply call-with-current-continuation call/cc 60 | values call-with-values dynamic-wind 61 | 62 | #;(rnrs unicode (6)) 63 | char-upcase char-downcase char-titlecase char-foldcase 64 | char-ci=? char-ci? char-ci<=? char-ci>=? 65 | char-alphabetic? char-numeric? char-whitespace? char-upper-case? char-lower-case? char-title-case? 66 | char-general-category 67 | string-upcase string-downcase string-titlecase string-foldcase 68 | string-ci=? string-ci? string-ci<=? string-ci>=? 69 | string-normalize-nfd string-normalize-nfkd string-normalize-nfc string-normalize-nfkc 70 | 71 | #;(rnrs bytevectors (6)) 72 | endianness native-endianness 73 | bytevector? make-bytevector bytevector-length bytevector=? 74 | bytevector-fill! bytevector-copy! bytevector-copy 75 | bytevector-u8-ref bytevector-s8-ref bytevector-u8-set! bytevector-s8-set! 76 | bytevector->u8-list u8-list->bytevector 77 | bytevector-u16-ref bytevector-s16-ref bytevector-u16-native-ref bytevector-s16-native-ref 78 | bytevector-u16-set! bytevector-s16-set! bytevector-u16-native-set! bytevector-s16-native-set! 79 | bytevector-u32-ref bytevector-s32-ref bytevector-u32-native-ref bytevector-s32-native-ref 80 | bytevector-u32-set! bytevector-s32-set! bytevector-u32-native-set! bytevector-s32-native-set! 81 | bytevector-u64-ref bytevector-s64-ref bytevector-u64-native-ref bytevector-s64-native-ref 82 | bytevector-u64-set! bytevector-s64-set! bytevector-u64-native-set! bytevector-s64-native-set! 83 | bytevector-ieee-single-ref bytevector-ieee-single-native-ref 84 | bytevector-ieee-single-set! bytevector-ieee-single-native-set! 85 | bytevector-ieee-double-ref bytevector-ieee-double-native-ref 86 | bytevector-ieee-double-set! bytevector-ieee-double-native-set! 87 | bytevector-uint-ref bytevector-sint-ref 88 | bytevector-uint-set! bytevector-sint-set! 89 | bytevector->uint-list bytevector->sint-list 90 | uint-list->bytevector sint-list->bytevector 91 | string->utf8 utf8->string 92 | string->utf16 utf16->string 93 | string->utf32 utf32->string 94 | 95 | #;(rnrs lists (6)) 96 | find for-all exists 97 | filter 98 | partition 99 | fold-left fold-right 100 | remp remove remv remq 101 | memp member memv memq 102 | assp assoc assv assq cons* 103 | 104 | #;(rnrs sorting (6)) 105 | list-sort vector-sort vector-sort! 106 | 107 | #;(rnrs control (6)) 108 | when unless do case-lambda 109 | 110 | #;(rnrs records syntactic (6)) 111 | define-record-type 112 | record-type-descriptor 113 | record-constructor-descriptor 114 | fields mutable immutable parent protocol sealed opaque nongenerative parent-rtd 115 | 116 | #;(rnrs records procedural (6)) 117 | make-record-type-descriptor 118 | record-type-descriptor? 119 | make-record-constructor-descriptor 120 | record-constructor 121 | record-predicate 122 | record-accessor 123 | record-mutator 124 | 125 | #;(rnrs records inspection (6)) 126 | record? 127 | record-rtd 128 | record-type-name 129 | record-type-parent 130 | record-type-uid 131 | record-type-generative? 132 | record-type-sealed? 133 | record-type-opaque? 134 | record-type-field-names 135 | record-field-mutable? 136 | 137 | #;(rnrs exceptions (6)) 138 | with-exception-handler guard raise raise-continuable 139 | 140 | #;(rnrs conditions (6)) 141 | &condition 142 | condition simple-conditions condition? 143 | condition-predicate condition-accessor 144 | define-condition-type 145 | &message make-message-condition message-condition? condition-message 146 | &warning make-warning warning? 147 | &serious make-serious-condition serious-condition? 148 | &error make-error error? 149 | &violation make-violation violation? 150 | &assertion make-assertion-violation assertion-violation? 151 | &irritants make-irritants-condition irritants-condition? condition-irritants 152 | &who make-who-condition who-condition? condition-who 153 | &non-continuable make-non-continuable-violation non-continuable-violation? 154 | &implementation-restriction make-implementation-restriction-violation implementation-restriction-violation? 155 | &lexical make-lexical-violation lexical-violation? 156 | &syntax make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform 157 | &undefined make-undefined-violation undefined-violation? 158 | 159 | #;(rnrs io ports (6)) 160 | &i/o make-i/o-error i/o-error? 161 | &i/o-read make-i/o-read-error i/o-read-error? 162 | &i/o-write make-i/o-write-error i/o-write-error? 163 | &i/o-invalid-position make-i/o-invalid-position-error i/o-invalid-position-error? i/o-error-position 164 | &i/o-filename make-i/o-filename-error i/o-filename-error? i/o-error-filename 165 | &i/o-file-protection make-i/o-file-protection-error i/o-file-protection-error? 166 | &i/o-file-is-read-only make-i/o-file-is-read-only-error i/o-file-is-read-only-error? 167 | &i/o-file-already-exists make-i/o-file-already-exists-error i/o-file-already-exists-error? 168 | &i/o-file-does-not-exist make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error? 169 | &i/o-port make-i/o-port-error i/o-port-error? i/o-error-port 170 | &i/o-decoding make-i/o-decoding-error i/o-decoding-error? 171 | &i/o-encoding make-i/o-encoding-error i/o-encoding-error? i/o-encoding-error-char 172 | 173 | file-options 174 | buffer-mode 175 | buffer-mode? 176 | utf-8-codec 177 | utf-16-codec 178 | latin-1-codec 179 | eol-style 180 | error-handling-mode 181 | make-transcoder 182 | transcoder-codec 183 | transcoder-eol-style 184 | transcoder-error-handling-mode 185 | native-transcoder 186 | native-eol-style 187 | bytevector->string 188 | string->bytevector 189 | eof-object 190 | eof-object? 191 | port? 192 | port-transcoder 193 | textual-port? 194 | binary-port? 195 | transcoded-port 196 | port-has-port-position? 197 | port-position 198 | port-has-set-port-position!? 199 | set-port-position! 200 | close-port 201 | call-with-port 202 | input-port? 203 | port-eof? 204 | open-file-input-port 205 | open-bytevector-input-port 206 | open-string-input-port 207 | standard-input-port 208 | current-input-port 209 | get-u8 210 | lookahead-u8 211 | get-bytevector-n 212 | get-bytevector-n! 213 | get-bytevector-some 214 | get-bytevector-all 215 | get-char 216 | lookahead-char 217 | get-string-n 218 | get-string-n! 219 | get-string-all 220 | get-line 221 | get-datum 222 | output-port? 223 | flush-output-port 224 | output-port-buffer-mode 225 | open-file-output-port 226 | open-bytevector-output-port 227 | call-with-bytevector-output-port 228 | open-string-output-port 229 | call-with-string-output-port 230 | standard-output-port 231 | standard-error-port 232 | current-output-port 233 | current-error-port 234 | put-u8 235 | put-bytevector 236 | put-char 237 | put-string 238 | put-datum 239 | open-file-input/output-port 240 | make-custom-binary-input-port 241 | make-custom-textual-input-port 242 | make-custom-binary-output-port 243 | make-custom-textual-output-port 244 | make-custom-binary-input/output-port 245 | make-custom-textual-input/output-port 246 | 247 | #;(rnrs io simple (6)) 248 | call-with-input-file 249 | call-with-output-file 250 | with-input-from-file 251 | with-output-to-file 252 | open-input-file 253 | open-output-file 254 | close-input-port 255 | close-output-port 256 | read-char 257 | peek-char 258 | read 259 | write-char 260 | newline 261 | display 262 | write 263 | 264 | #;(rnrs files (6)) 265 | file-exists? delete-file 266 | 267 | #;(rnrs enums (6)) 268 | make-enumeration 269 | enum-set-universe 270 | enum-set-indexer 271 | enum-set-constructor 272 | enum-set->list 273 | enum-set-member? 274 | enum-set-subset? 275 | enum-set=? 276 | enum-set-union 277 | enum-set-intersection 278 | enum-set-difference 279 | enum-set-complement 280 | enum-set-projection 281 | define-enumeration 282 | 283 | #;(rnrs programs (6)) 284 | command-line 285 | exit 286 | 287 | #;(rnrs arithmetic fixnums (6)) 288 | fixnum? 289 | fixnum-width 290 | least-fixnum 291 | greatest-fixnum 292 | fx=? 293 | fx? 295 | fx<=? 296 | fx>=? 297 | fxzero? 298 | fxpositive? 299 | fxnegative? 300 | fxodd? 301 | fxeven? 302 | fxmax 303 | fxmin 304 | fx+ 305 | fx* 306 | fx- 307 | fxdiv 308 | fxmod 309 | fxdiv-and-mod 310 | fxdiv0 311 | fxmod0 312 | fxdiv0-and-mod0 313 | fx+/carry 314 | fx-/carry 315 | fx*/carry 316 | fxnot 317 | fxand 318 | fxior 319 | fxxor 320 | fxif 321 | fxbit-count 322 | fxlength 323 | fxfirst-bit-set 324 | fxbit-set? 325 | fxcopy-bit 326 | fxbit-field 327 | fxcopy-bit-field 328 | fxarithmetic-shift 329 | fxarithmetic-shift-left 330 | fxarithmetic-shift-right 331 | fxrotate-bit-field 332 | fxreverse-bit-field 333 | 334 | #;(rnrs arithmetic flonums (6)) 335 | flonum? 336 | real->flonum 337 | fl=? 338 | fl? 340 | fl<=? 341 | fl>=? 342 | flinteger? 343 | flzero? 344 | flpositive? 345 | flnegative? 346 | flodd? 347 | fleven? 348 | flfinite? 349 | flinfinite? 350 | flnan? 351 | flmax 352 | flmin 353 | fl+ 354 | fl* 355 | fl- 356 | fl/ 357 | fldiv-and-mod 358 | fldiv 359 | flmod 360 | fldiv0-and-mod0 361 | fldiv0 362 | flmod0 363 | flnumerator 364 | fldenominator 365 | flfloor 366 | flceiling 367 | fltruncate 368 | flround 369 | flabs 370 | flexpt 371 | flsqrt 372 | flexp 373 | fllog 374 | flsin 375 | flcos 376 | fltan 377 | flasin 378 | flacos 379 | flatan 380 | fixnum->flonum 381 | &no-infinities make-no-infinities-violation no-infinities-violation? 382 | &no-nans make-no-nans-violation no-nans-violation? 383 | 384 | #;(rnrs arithmetic bitwise (6)) 385 | bitwise-not 386 | bitwise-and 387 | bitwise-ior 388 | bitwise-xor 389 | bitwise-if 390 | bitwise-bit-count 391 | bitwise-length 392 | bitwise-first-bit-set 393 | bitwise-bit-set? 394 | bitwise-copy-bit 395 | bitwise-bit-field 396 | bitwise-copy-bit-field 397 | bitwise-arithmetic-shift 398 | bitwise-arithmetic-shift-left 399 | bitwise-arithmetic-shift-right 400 | bitwise-rotate-bit-field 401 | bitwise-reverse-bit-field 402 | 403 | #;(rnrs syntax-case (6)) 404 | syntax-case syntax 405 | with-syntax 406 | make-variable-transformer 407 | identifier? bound-identifier=? free-identifier=? 408 | datum->syntax syntax->datum 409 | generate-temporaries 410 | quasisyntax 411 | unsyntax 412 | unsyntax-splicing 413 | syntax-violation 414 | 415 | #;(rnrs hashtables (6)) 416 | make-eq-hashtable 417 | make-eqv-hashtable 418 | make-hashtable 419 | hashtable? 420 | hashtable-size 421 | hashtable-ref 422 | hashtable-set! 423 | hashtable-delete! 424 | hashtable-contains? 425 | hashtable-update! 426 | hashtable-copy 427 | hashtable-clear! 428 | hashtable-keys 429 | hashtable-entries 430 | hashtable-equivalence-function 431 | hashtable-hash-function 432 | hashtable-mutable? 433 | equal-hash string-hash string-ci-hash symbol-hash) 434 | 435 | (import (rnrs)) 436 | 437 | ) -------------------------------------------------------------------------------- /rnrs.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (mpl rnrs) 3 | 4 | (export 5 | 6 | ;; (mpl automatic-simplification) 7 | 8 | ^ * + / - ! exp 9 | 10 | #; (rnrs base (6)) 11 | define define-syntax 12 | quote lambda if set! cond case and or 13 | let let* letrec letrec* let-values let*-values 14 | begin quasiquote unquote unquote-splicing 15 | let-syntax letrec-syntax syntax-rules 16 | identifier-syntax assert 17 | else => ... _ 18 | eq? 19 | eqv? 20 | equal? 21 | procedure? 22 | number? complex? real? rational? integer? 23 | real-valued? rational-valued? integer-valued? 24 | exact? inexact? 25 | inexact exact 26 | = < > <= >= 27 | zero? positive? negative? odd? even? 28 | finite? infinite? nan? 29 | max min abs 30 | div-and-mod div mod div0-and-mod0 div0 mod0 31 | gcd lcm numerator denominator 32 | floor ceiling truncate round 33 | rationalize 34 | log 35 | ;; sin 36 | ;; cos 37 | tan asin acos atan 38 | sqrt 39 | exact-integer-sqrt 40 | expt 41 | make-rectangular make-polar real-part imag-part 42 | magnitude angle 43 | number->string string->number 44 | not boolean? boolean=? 45 | pair? cons car cdr 46 | caar cadr cdar cddr caaar caadr cadar 47 | caddr cdaar cdadr cddar cdddr caaaar caaadr 48 | caadar caaddr cadaar cadadr caddar cadddr cdaaar 49 | cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr 50 | null? list? list length append reverse list-tail 51 | list-ref map for-each 52 | symbol? symbol->string string->symbol symbol=? 53 | char? char->integer integer->char 54 | char=? char? char<=? char>=? 55 | string? make-string string string-length string-ref 56 | string=? string? string<=? string>=? 57 | substring string-append string->list list->string string-copy string-for-each 58 | vector? make-vector vector vector-length vector-ref vector-set! 59 | vector->list list->vector vector-fill! 60 | vector-map vector-for-each 61 | error assertion-violation 62 | apply call-with-current-continuation call/cc 63 | values call-with-values dynamic-wind 64 | 65 | #;(rnrs unicode (6)) 66 | char-upcase char-downcase char-titlecase char-foldcase 67 | char-ci=? char-ci? char-ci<=? char-ci>=? 68 | char-alphabetic? char-numeric? char-whitespace? char-upper-case? char-lower-case? char-title-case? 69 | char-general-category 70 | string-upcase string-downcase string-titlecase string-foldcase 71 | string-ci=? string-ci? string-ci<=? string-ci>=? 72 | string-normalize-nfd string-normalize-nfkd string-normalize-nfc string-normalize-nfkc 73 | 74 | #;(rnrs bytevectors (6)) 75 | endianness native-endianness 76 | bytevector? make-bytevector bytevector-length bytevector=? 77 | bytevector-fill! bytevector-copy! bytevector-copy 78 | bytevector-u8-ref bytevector-s8-ref bytevector-u8-set! bytevector-s8-set! 79 | bytevector->u8-list u8-list->bytevector 80 | bytevector-u16-ref bytevector-s16-ref bytevector-u16-native-ref bytevector-s16-native-ref 81 | bytevector-u16-set! bytevector-s16-set! bytevector-u16-native-set! bytevector-s16-native-set! 82 | bytevector-u32-ref bytevector-s32-ref bytevector-u32-native-ref bytevector-s32-native-ref 83 | bytevector-u32-set! bytevector-s32-set! bytevector-u32-native-set! bytevector-s32-native-set! 84 | bytevector-u64-ref bytevector-s64-ref bytevector-u64-native-ref bytevector-s64-native-ref 85 | bytevector-u64-set! bytevector-s64-set! bytevector-u64-native-set! bytevector-s64-native-set! 86 | bytevector-ieee-single-ref bytevector-ieee-single-native-ref 87 | bytevector-ieee-single-set! bytevector-ieee-single-native-set! 88 | bytevector-ieee-double-ref bytevector-ieee-double-native-ref 89 | bytevector-ieee-double-set! bytevector-ieee-double-native-set! 90 | bytevector-uint-ref bytevector-sint-ref 91 | bytevector-uint-set! bytevector-sint-set! 92 | bytevector->uint-list bytevector->sint-list 93 | uint-list->bytevector sint-list->bytevector 94 | string->utf8 utf8->string 95 | string->utf16 utf16->string 96 | string->utf32 utf32->string 97 | 98 | #;(rnrs lists (6)) 99 | find for-all exists 100 | filter 101 | partition 102 | fold-left fold-right 103 | remp remove remv remq 104 | memp member memv memq 105 | assp assoc assv assq cons* 106 | 107 | #;(rnrs sorting (6)) 108 | list-sort vector-sort vector-sort! 109 | 110 | #;(rnrs control (6)) 111 | when unless do case-lambda 112 | 113 | #;(rnrs records syntactic (6)) 114 | define-record-type 115 | record-type-descriptor 116 | record-constructor-descriptor 117 | fields mutable immutable parent protocol sealed opaque nongenerative parent-rtd 118 | 119 | #;(rnrs records procedural (6)) 120 | make-record-type-descriptor 121 | record-type-descriptor? 122 | make-record-constructor-descriptor 123 | record-constructor 124 | record-predicate 125 | record-accessor 126 | record-mutator 127 | 128 | #;(rnrs records inspection (6)) 129 | record? 130 | record-rtd 131 | record-type-name 132 | record-type-parent 133 | record-type-uid 134 | record-type-generative? 135 | record-type-sealed? 136 | record-type-opaque? 137 | record-type-field-names 138 | record-field-mutable? 139 | 140 | #;(rnrs exceptions (6)) 141 | with-exception-handler guard raise raise-continuable 142 | 143 | #;(rnrs conditions (6)) 144 | &condition 145 | condition simple-conditions condition? 146 | condition-predicate condition-accessor 147 | define-condition-type 148 | &message make-message-condition message-condition? condition-message 149 | &warning make-warning warning? 150 | &serious make-serious-condition serious-condition? 151 | &error make-error error? 152 | &violation make-violation violation? 153 | &assertion make-assertion-violation assertion-violation? 154 | &irritants make-irritants-condition irritants-condition? condition-irritants 155 | &who make-who-condition who-condition? condition-who 156 | &non-continuable make-non-continuable-violation non-continuable-violation? 157 | &implementation-restriction make-implementation-restriction-violation implementation-restriction-violation? 158 | &lexical make-lexical-violation lexical-violation? 159 | &syntax make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform 160 | &undefined make-undefined-violation undefined-violation? 161 | 162 | #;(rnrs io ports (6)) 163 | &i/o make-i/o-error i/o-error? 164 | &i/o-read make-i/o-read-error i/o-read-error? 165 | &i/o-write make-i/o-write-error i/o-write-error? 166 | &i/o-invalid-position make-i/o-invalid-position-error i/o-invalid-position-error? i/o-error-position 167 | &i/o-filename make-i/o-filename-error i/o-filename-error? i/o-error-filename 168 | &i/o-file-protection make-i/o-file-protection-error i/o-file-protection-error? 169 | &i/o-file-is-read-only make-i/o-file-is-read-only-error i/o-file-is-read-only-error? 170 | &i/o-file-already-exists make-i/o-file-already-exists-error i/o-file-already-exists-error? 171 | &i/o-file-does-not-exist make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error? 172 | &i/o-port make-i/o-port-error i/o-port-error? i/o-error-port 173 | &i/o-decoding make-i/o-decoding-error i/o-decoding-error? 174 | &i/o-encoding make-i/o-encoding-error i/o-encoding-error? i/o-encoding-error-char 175 | 176 | file-options 177 | buffer-mode 178 | buffer-mode? 179 | utf-8-codec 180 | utf-16-codec 181 | latin-1-codec 182 | eol-style 183 | error-handling-mode 184 | make-transcoder 185 | transcoder-codec 186 | transcoder-eol-style 187 | transcoder-error-handling-mode 188 | native-transcoder 189 | native-eol-style 190 | bytevector->string 191 | string->bytevector 192 | eof-object 193 | eof-object? 194 | port? 195 | port-transcoder 196 | textual-port? 197 | binary-port? 198 | transcoded-port 199 | port-has-port-position? 200 | port-position 201 | port-has-set-port-position!? 202 | set-port-position! 203 | close-port 204 | call-with-port 205 | input-port? 206 | port-eof? 207 | open-file-input-port 208 | open-bytevector-input-port 209 | open-string-input-port 210 | standard-input-port 211 | current-input-port 212 | get-u8 213 | lookahead-u8 214 | get-bytevector-n 215 | get-bytevector-n! 216 | get-bytevector-some 217 | get-bytevector-all 218 | get-char 219 | lookahead-char 220 | get-string-n 221 | get-string-n! 222 | get-string-all 223 | get-line 224 | get-datum 225 | output-port? 226 | flush-output-port 227 | output-port-buffer-mode 228 | open-file-output-port 229 | open-bytevector-output-port 230 | call-with-bytevector-output-port 231 | open-string-output-port 232 | call-with-string-output-port 233 | standard-output-port 234 | standard-error-port 235 | current-output-port 236 | current-error-port 237 | put-u8 238 | put-bytevector 239 | put-char 240 | put-string 241 | put-datum 242 | open-file-input/output-port 243 | make-custom-binary-input-port 244 | make-custom-textual-input-port 245 | make-custom-binary-output-port 246 | make-custom-textual-output-port 247 | make-custom-binary-input/output-port 248 | make-custom-textual-input/output-port 249 | 250 | #;(rnrs io simple (6)) 251 | call-with-input-file 252 | call-with-output-file 253 | with-input-from-file 254 | with-output-to-file 255 | open-input-file 256 | open-output-file 257 | close-input-port 258 | close-output-port 259 | read-char 260 | peek-char 261 | read 262 | write-char 263 | newline 264 | display 265 | write 266 | 267 | #;(rnrs files (6)) 268 | file-exists? delete-file 269 | 270 | #;(rnrs enums (6)) 271 | make-enumeration 272 | enum-set-universe 273 | enum-set-indexer 274 | enum-set-constructor 275 | enum-set->list 276 | enum-set-member? 277 | enum-set-subset? 278 | enum-set=? 279 | enum-set-union 280 | enum-set-intersection 281 | enum-set-difference 282 | enum-set-complement 283 | enum-set-projection 284 | define-enumeration 285 | 286 | #;(rnrs programs (6)) 287 | command-line 288 | exit 289 | 290 | #;(rnrs arithmetic fixnums (6)) 291 | fixnum? 292 | fixnum-width 293 | least-fixnum 294 | greatest-fixnum 295 | fx=? 296 | fx? 298 | fx<=? 299 | fx>=? 300 | fxzero? 301 | fxpositive? 302 | fxnegative? 303 | fxodd? 304 | fxeven? 305 | fxmax 306 | fxmin 307 | fx+ 308 | fx* 309 | fx- 310 | fxdiv 311 | fxmod 312 | fxdiv-and-mod 313 | fxdiv0 314 | fxmod0 315 | fxdiv0-and-mod0 316 | fx+/carry 317 | fx-/carry 318 | fx*/carry 319 | fxnot 320 | fxand 321 | fxior 322 | fxxor 323 | fxif 324 | fxbit-count 325 | fxlength 326 | fxfirst-bit-set 327 | fxbit-set? 328 | fxcopy-bit 329 | fxbit-field 330 | fxcopy-bit-field 331 | fxarithmetic-shift 332 | fxarithmetic-shift-left 333 | fxarithmetic-shift-right 334 | fxrotate-bit-field 335 | fxreverse-bit-field 336 | 337 | #;(rnrs arithmetic flonums (6)) 338 | flonum? 339 | real->flonum 340 | fl=? 341 | fl? 343 | fl<=? 344 | fl>=? 345 | flinteger? 346 | flzero? 347 | flpositive? 348 | flnegative? 349 | flodd? 350 | fleven? 351 | flfinite? 352 | flinfinite? 353 | flnan? 354 | flmax 355 | flmin 356 | fl+ 357 | fl* 358 | fl- 359 | fl/ 360 | fldiv-and-mod 361 | fldiv 362 | flmod 363 | fldiv0-and-mod0 364 | fldiv0 365 | flmod0 366 | flnumerator 367 | fldenominator 368 | flfloor 369 | flceiling 370 | fltruncate 371 | flround 372 | flabs 373 | flexpt 374 | flsqrt 375 | flexp 376 | fllog 377 | flsin 378 | flcos 379 | fltan 380 | flasin 381 | flacos 382 | flatan 383 | fixnum->flonum 384 | &no-infinities make-no-infinities-violation no-infinities-violation? 385 | &no-nans make-no-nans-violation no-nans-violation? 386 | 387 | #;(rnrs arithmetic bitwise (6)) 388 | bitwise-not 389 | bitwise-and 390 | bitwise-ior 391 | bitwise-xor 392 | bitwise-if 393 | bitwise-bit-count 394 | bitwise-length 395 | bitwise-first-bit-set 396 | bitwise-bit-set? 397 | bitwise-copy-bit 398 | bitwise-bit-field 399 | bitwise-copy-bit-field 400 | bitwise-arithmetic-shift 401 | bitwise-arithmetic-shift-left 402 | bitwise-arithmetic-shift-right 403 | bitwise-rotate-bit-field 404 | bitwise-reverse-bit-field 405 | 406 | #;(rnrs syntax-case (6)) 407 | syntax-case syntax 408 | with-syntax 409 | make-variable-transformer 410 | identifier? bound-identifier=? free-identifier=? 411 | datum->syntax syntax->datum 412 | generate-temporaries 413 | quasisyntax 414 | unsyntax 415 | unsyntax-splicing 416 | syntax-violation 417 | 418 | #;(rnrs hashtables (6)) 419 | make-eq-hashtable 420 | make-eqv-hashtable 421 | make-hashtable 422 | hashtable? 423 | hashtable-size 424 | hashtable-ref 425 | hashtable-set! 426 | hashtable-delete! 427 | hashtable-contains? 428 | hashtable-update! 429 | hashtable-copy 430 | hashtable-clear! 431 | hashtable-keys 432 | hashtable-entries 433 | hashtable-equivalence-function 434 | hashtable-hash-function 435 | hashtable-mutable? 436 | equal-hash string-hash string-ci-hash symbol-hash) 437 | 438 | (import (except (rnrs) + - * / exp sin cos) 439 | (mpl automatic-simplification)) 440 | 441 | ) 442 | -------------------------------------------------------------------------------- /contract-trig.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl contract-trig) 4 | 5 | (export contract-trig 6 | contract-trig-rules 7 | contract-trig-power 8 | contract-trig-product) 9 | 10 | (import (mpl rnrs-sans) 11 | (mpl misc) 12 | (mpl arithmetic) 13 | (mpl sin) 14 | (mpl cos) 15 | (mpl automatic-simplify) 16 | (mpl separate-sin-cos) 17 | (mpl expand-main-op) 18 | (mpl algebraic-expand)) 19 | 20 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | 22 | (define (binomial-coefficient n k) 23 | (cond ( (= k 0) 1 ) 24 | ( (= n k) 1 ) 25 | ( else 26 | (+ (binomial-coefficient (- n 1) 27 | (- k 1)) 28 | (binomial-coefficient (- n 1) 29 | k)) ))) 30 | 31 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | 33 | (define (sigma f a b step) 34 | (let loop ((a a) (sum 0)) 35 | (if (> a b) 36 | sum 37 | (loop (+ a step) 38 | (+ sum (f a)))))) 39 | 40 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | 42 | ;; (define (contract-trig-power u) 43 | 44 | ;; (cond ( (and (cos? (base u)) 45 | ;; (integer? (exponent u)) 46 | ;; (positive? (exponent u)) 47 | ;; (even? (exponent u))) 48 | 49 | ;; (let ((x (list-ref (base u) 1)) 50 | ;; (n (exponent u))) 51 | 52 | ;; (+ (/ (binomial-coefficient n (/ n 2)) 53 | ;; (^ 2 n)) 54 | 55 | ;; (* (/ 1 (^ 2 (- n 1))) 56 | 57 | ;; (sigma (lambda (j) 58 | ;; (* (binomial-coefficient n j) 59 | ;; (cos (* (- n (* 2 j)) x)))) 60 | ;; 0 61 | ;; (- (/ n 2) 1) 62 | ;; 1)))) ) 63 | 64 | ;; ( (and (cos? (base u)) 65 | ;; (integer? (exponent u)) 66 | ;; (positive? (exponent u)) 67 | ;; (odd? (exponent u))) 68 | 69 | ;; (let ((x (list-ref (base u) 1)) 70 | ;; (n (exponent u))) 71 | 72 | ;; (* (/ 1 (^ 2 (- n 1))) 73 | 74 | ;; (sigma (lambda (j) 75 | ;; (* (binomial-coefficient n j) 76 | ;; (cos (* (- n (* 2 j)) x)))) 77 | ;; 0 78 | ;; (floor (/ n 2)) 79 | ;; 1))) ) 80 | 81 | ;; ( (and (sin? (base u)) 82 | ;; (integer? (exponent u)) 83 | ;; (positive? (exponent u)) 84 | ;; (even? (exponent u))) 85 | 86 | ;; (let ((x (list-ref (base u) 1)) 87 | ;; (n (exponent u))) 88 | 89 | ;; (+ (/ (* (^ -1 n) 90 | ;; (binomial-coefficient n (/ n 2))) 91 | ;; (^ 2 n)) 92 | 93 | ;; (* (/ (^ -1 (/ n 2)) 94 | ;; (^ 2 (- n 1))) 95 | 96 | ;; (sigma (lambda (j) 97 | ;; (* (^ -1 j) 98 | ;; (binomial-coefficient n j) 99 | ;; (cos (* (- n (* 2 j)) x)))) 100 | ;; 0 101 | ;; (- (/ n 2) 1) 102 | ;; 1)))) ) 103 | 104 | ;; ( (and (sin? (base u)) 105 | ;; (integer? (exponent u)) 106 | ;; (positive? (exponent u)) 107 | ;; (odd? (exponent u))) 108 | 109 | ;; (let ((x (list-ref (base u) 1)) 110 | ;; (n (exponent u))) 111 | 112 | ;; (* (/ (^ -1 (/ (- n 1) 2)) 113 | ;; (^ 2 (- n 1))) 114 | 115 | ;; (sigma (lambda (j) 116 | ;; (* (binomial-coefficient n j) 117 | ;; (^ -1 j) 118 | ;; (sin (* (- n (* 2 j)) x)))) 119 | ;; 0 120 | ;; (floor (/ n 2))))) ) 121 | 122 | ;; (else u) 123 | 124 | ;; )) 125 | 126 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 127 | 128 | (define (contract-trig-power u) 129 | 130 | (cond ( (and (cos? (base u)) 131 | (integer? (exponent u)) 132 | (positive? (exponent u)) 133 | (even? (exponent u))) 134 | 135 | (let ((x (list-ref (base u) 1)) 136 | (n (exponent u))) 137 | 138 | (contract-trig-rules 139 | 140 | (+ (/ (binomial-coefficient n (/ n 2)) 141 | (^ 2 n)) 142 | 143 | (* (/ 1 (^ 2 (- n 1))) 144 | 145 | (sigma (lambda (j) 146 | (* (binomial-coefficient n j) 147 | (cos (* (- n (* 2 j)) x)))) 148 | 0 149 | (- (/ n 2) 1) 150 | 1))))) ) 151 | 152 | ( (and (cos? (base u)) 153 | (integer? (exponent u)) 154 | (positive? (exponent u)) 155 | (odd? (exponent u))) 156 | 157 | (let ((x (list-ref (base u) 1)) 158 | (n (exponent u))) 159 | 160 | (contract-trig-rules 161 | 162 | (* (/ 1 (^ 2 (- n 1))) 163 | 164 | (sigma (lambda (j) 165 | (* (binomial-coefficient n j) 166 | (cos (* (- n (* 2 j)) x)))) 167 | 0 168 | (floor (/ n 2)) 169 | 1)))) ) 170 | 171 | ( (and (sin? (base u)) 172 | (integer? (exponent u)) 173 | (positive? (exponent u)) 174 | (even? (exponent u))) 175 | 176 | (let ((x (list-ref (base u) 1)) 177 | (n (exponent u))) 178 | 179 | (contract-trig-rules 180 | 181 | (+ (/ (* (^ -1 n) 182 | (binomial-coefficient n (/ n 2))) 183 | (^ 2 n)) 184 | 185 | (* (/ (^ -1 (/ n 2)) 186 | (^ 2 (- n 1))) 187 | 188 | (sigma (lambda (j) 189 | (* (^ -1 j) 190 | (binomial-coefficient n j) 191 | (cos (* (- n (* 2 j)) x)))) 192 | 0 193 | (- (/ n 2) 1) 194 | 1))))) ) 195 | 196 | ( (and (sin? (base u)) 197 | (integer? (exponent u)) 198 | (positive? (exponent u)) 199 | (odd? (exponent u))) 200 | 201 | (let ((x (list-ref (base u) 1)) 202 | (n (exponent u))) 203 | 204 | (contract-trig-rules 205 | 206 | (* (/ (^ -1 (/ (- n 1) 2)) 207 | (^ 2 (- n 1))) 208 | 209 | (sigma (lambda (j) 210 | (* (binomial-coefficient n j) 211 | (^ -1 j) 212 | (sin (* (- n (* 2 j)) x)))) 213 | 0 214 | (floor (/ n 2)) 215 | 1)))) ) 216 | 217 | (else u) 218 | 219 | )) 220 | 221 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 222 | 223 | ;; Original version from the book 224 | 225 | ;; (define (contract-trig-product u) 226 | 227 | ;; (if (= (length (cdr u)) 2) 228 | 229 | ;; (let ((A (list-ref u 1)) 230 | ;; (B (list-ref u 2))) 231 | 232 | ;; (cond ( (power? A) 233 | ;; (let ((A (contract-trig-power A))) 234 | ;; (contract-trig-rules (* A B))) ) 235 | 236 | ;; ( (power? B) 237 | ;; (let ((B (contract-trig-power B))) 238 | ;; (contract-trig-rules (* A B))) ) 239 | 240 | ;; ( else 241 | 242 | ;; (let ((x (list-ref A 1)) 243 | ;; (y (list-ref B 1))) 244 | 245 | ;; (cond ( (and (sin? A) (sin? B)) 246 | 247 | ;; (- (/ (cos (- x y)) 2) 248 | ;; (/ (cos (+ x y)) 2)) ) 249 | 250 | ;; ( (and (cos? A) (cos? B)) 251 | 252 | ;; (+ (/ (cos (+ x y)) 2) 253 | ;; (/ (cos (- x y)) 2)) ) 254 | 255 | ;; ( (and (sin? A) (cos? B)) 256 | 257 | ;; (+ (/ (sin (+ x y)) 2) 258 | ;; (/ (sin (- x y)) 2)) ) 259 | 260 | ;; ( (and (cos? A) (sin? B)) 261 | 262 | ;; (+ (/ (sin (+ x y)) 2) 263 | ;; (/ (sin (- y x)) 2)) ))) ))) 264 | 265 | ;; (let ((A (list-ref u 1))) 266 | ;; (let ((B (contract-trig-product (/ u A)))) 267 | ;; (contract-trig-rules (* A B)))))) 268 | 269 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 270 | 271 | ;; 2009/09/29 272 | 273 | (define (contract-trig-product u) 274 | 275 | (if (= (length (cdr u)) 2) 276 | 277 | (let ((A (list-ref u 1)) 278 | (B (list-ref u 2))) 279 | 280 | (cond ( (power? A) 281 | (let ((A (contract-trig-power A))) 282 | (contract-trig-rules (* A B))) ) 283 | 284 | ( (power? B) 285 | (let ((B (contract-trig-power B))) 286 | (contract-trig-rules (* A B))) ) 287 | 288 | ( else 289 | 290 | (let ((x (list-ref A 1)) 291 | (y (list-ref B 1))) 292 | 293 | (algebraic-expand ;; see note [1] 294 | 295 | (cond ( (and (sin? A) (sin? B)) 296 | 297 | (- (/ (cos (- x y)) 2) 298 | (/ (cos (+ x y)) 2)) ) 299 | 300 | ( (and (cos? A) (cos? B)) 301 | 302 | (+ (/ (cos (+ x y)) 2) 303 | (/ (cos (- x y)) 2)) ) 304 | 305 | ( (and (sin? A) (cos? B)) 306 | 307 | (+ (/ (sin (+ x y)) 2) 308 | (/ (sin (- x y)) 2)) ) 309 | 310 | ( (and (cos? A) (sin? B)) 311 | 312 | (+ (/ (sin (+ x y)) 2) 313 | (/ (sin (- y x)) 2)) )))) ))) 314 | 315 | (let ((A (list-ref u 1))) 316 | (let ((B (contract-trig-product (/ u A)))) 317 | (contract-trig-rules (* A B)))))) 318 | 319 | ;; note [1] 320 | ;; 321 | ;; This line is not in the original implementation from the book. 322 | ;; 323 | ;; Because of how Cohen's automatic simplification algorithm works, 324 | ;; the expressions '(- x y)' can result in expressions which are not 325 | ;; in algebraic-expanded form. For example: 326 | ;; 327 | ;; > (- a (+ b c)) 328 | ;; (+ a (* -1 (+ b c))) 329 | ;; 330 | ;; If we eventually move to have automatic simplification do: 331 | ;; 332 | ;; -1 * (x + y) => -1*x + -1*y 333 | ;; 334 | ;; we might be able to remove the call to 'algebraic-expand'. 335 | 336 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 337 | 338 | (define (contract-trig-rules u) 339 | 340 | (let ((v (expand-main-op u))) 341 | 342 | (cond ( (power? v) 343 | (contract-trig-power v) ) 344 | 345 | ( (product? v) 346 | 347 | (let ((s (separate-sin-cos v))) 348 | 349 | (let ((c (list-ref s 0)) 350 | (d (list-ref s 1))) 351 | 352 | (cond ( (or (equal? d 1) 353 | (sin? d) 354 | (cos? d)) 355 | v ) 356 | 357 | ( (power? d) 358 | 359 | (expand-main-op (* c (contract-trig-power d))) ) 360 | 361 | ( else 362 | 363 | (expand-main-op (* c (contract-trig-product d))) )))) ) 364 | 365 | ( (sum? v) 366 | 367 | (let loop ( (s 0) 368 | (exprs (cdr v)) ) 369 | 370 | (if (null? exprs) 371 | s 372 | (let ((y (car exprs))) 373 | (if (or (product? y) 374 | (power? y)) 375 | (loop (+ s (contract-trig-rules y)) 376 | (cdr exprs)) 377 | (loop (+ s y) 378 | (cdr exprs)))))) ) 379 | 380 | ( else v )))) 381 | 382 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 383 | 384 | (define (contract-trig u) 385 | (if (or (number? u) 386 | (symbol? u)) 387 | u 388 | (let ((v (automatic-simplify (map contract-trig u)))) 389 | (if (or (product? v) 390 | (power? v)) 391 | (contract-trig-rules v) 392 | v)))) 393 | 394 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 395 | 396 | ) -------------------------------------------------------------------------------- /match.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;;; match.scm -- portable hygienic pattern matcher 3 | ;; 4 | ;; This code is written by Alex Shinn and placed in the 5 | ;; Public Domain. All warranties are disclaimed. 6 | 7 | ;; Turned into an R6RS library by Derick Eddington, and modified to use 8 | ;; only-hygienic syntax-case so that ... can be used (original version 9 | ;; had to use ___), and modified to remove _ from syntax-rules/syntax-case 10 | ;; literals lists. 11 | 12 | ;; This is a full superset of the popular MATCH package by Andrew 13 | ;; Wright. 14 | 15 | ;; This is a simple generative pattern matcher - each pattern is 16 | ;; expanded into the required tests, calling a failure continuation if 17 | ;; the tests fail. This makes the logic easy to follow and extend, 18 | ;; but produces sub-optimal code in cases where you have many similar 19 | ;; clauses due to repeating the same tests. Nonetheless a smart 20 | ;; compiler should be able to remove the redundant tests. For 21 | ;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance 22 | ;; hit. 23 | 24 | ;; The original version was written on 2006/11/29 and described in the 25 | ;; following Usenet post: 26 | ;; http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd 27 | ;; and is still available at 28 | ;; http://synthcode.com/scheme/match-simple.scm 29 | ;; A variant of this file which uses COND-EXPAND in a few places can 30 | ;; be found at 31 | ;; http://synthcode.com/scheme/match-cond-expand.scm 32 | ;; 33 | ;; 2008/03/20 - fixing bug where (a ...) matched non-lists 34 | ;; 2008/03/15 - removing redundant check in vector patterns 35 | ;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell) 36 | ;; 2007/09/04 - fixing quasiquote patterns 37 | ;; 2007/07/21 - allowing ellipse patterns in non-final list positions 38 | ;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse 39 | ;; (thanks to Taylor Campbell) 40 | ;; 2007/04/08 - clean up, commenting 41 | ;; 2006/12/24 - bugfixes 42 | ;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set! 43 | 44 | (library (mpl match) 45 | 46 | (export match match-let match-let* match-letrec match-lambda match-lambda*) 47 | 48 | (import 49 | (rnrs) 50 | (rnrs mutable-pairs)) 51 | 52 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 | 54 | ;; The basic interface. MATCH just performs some basic syntax 55 | ;; validation, binds the match expression to a temporary variable `v', 56 | ;; and passes it on to MATCH-NEXT. It's a constant throughout the 57 | ;; code below that the binding `v' is a direct variable reference, not 58 | ;; an expression. 59 | 60 | (define-syntax match 61 | (lambda (stx) 62 | (syntax-case stx () 63 | ((match) 64 | (syntax-violation #f "missing match expression" stx)) 65 | ((match atom) 66 | (syntax-violation #f "missing match clause" stx)) 67 | ((match (app ...) (pat . body) ...) 68 | #'(let ((v (app ...))) 69 | (match-next v (app ...) (set! (app ...)) (pat . body) ...))) 70 | ((match #(vec ...) (pat . body) ...) 71 | #'(let ((v #(vec ...))) 72 | (match-next v v (set! v) (pat . body) ...))) 73 | ((match atom (pat . body) ...) 74 | #'(match-next atom atom (set! atom) (pat . body) ...)) 75 | ))) 76 | 77 | ;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure 78 | ;; thunk, which is expanded by recursing MATCH-NEXT on the remaining 79 | ;; clauses. `g' and `s' are the get! and set! expressions 80 | ;; respectively. 81 | 82 | (define-syntax match-next 83 | (syntax-rules (=>) 84 | ;; no more clauses, the match failed 85 | ((match-next v g s) 86 | (assertion-violation 'match "no matching pattern")) 87 | ;; named failure continuation 88 | ((match-next v g s (pat (=> failure) . body) . rest) 89 | (let ((failure (lambda () (match-next v g s . rest)))) 90 | ;; match-one analyzes the pattern for us 91 | (match-one v pat g s (match-drop-ids (begin . body)) (failure) ()))) 92 | ;; anonymous failure continuation, give it a dummy name 93 | ((match-next v g s (pat . body) . rest) 94 | (match-next v g s (pat (=> failure) . body) . rest)))) 95 | 96 | ;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to 97 | ;; MATCH-TWO. 98 | 99 | (define-syntax match-one 100 | (syntax-rules () 101 | ;; If it's a list of two values, check to see if the second one is 102 | ;; an ellipse and handle accordingly, otherwise go to MATCH-TWO. 103 | ((match-one v (p q . r) g s sk fk i) 104 | (match-check-ellipse 105 | q 106 | (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ()) 107 | (match-two v (p q . r) g s sk fk i))) 108 | ;; Otherwise, go directly to MATCH-TWO. 109 | ((match-one . x) 110 | (match-two . x)))) 111 | 112 | ;; This is the guts of the pattern matcher. We are passed a lot of 113 | ;; information in the form: 114 | ;; 115 | ;; (match-two var pattern getter setter success-k fail-k (ids ...)) 116 | ;; 117 | ;; usually abbreviated 118 | ;; 119 | ;; (match-two v p g s sk fk i) 120 | ;; 121 | ;; where VAR is the symbol name of the current variable we are 122 | ;; matching, PATTERN is the current pattern, getter and setter are the 123 | ;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding 124 | ;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure 125 | ;; continuation (which is just a thunk call and is thus safe to expand 126 | ;; multiple times) and IDS are the list of identifiers bound in the 127 | ;; pattern so far. 128 | 129 | (define-syntax match-two 130 | (lambda (stx) 131 | (define (ellipses? x) 132 | (and (identifier? x) (free-identifier=? x #'(... ...)))) 133 | (define (underscore? x) 134 | (and (identifier? x) (free-identifier=? x #'_))) 135 | (syntax-case stx (quote quasiquote ? $ = and or not set! get!) 136 | ((match-two v () g s (sk ...) fk i) 137 | #'(if (null? v) (sk ... i) fk)) 138 | ((match-two v (quote p) g s (sk ...) fk i) 139 | #'(if (equal? v 'p) (sk ... i) fk)) 140 | ((match-two v (quasiquote p) g s sk fk i) 141 | #'(match-quasiquote v p g s sk fk i)) 142 | ((match-two v (and) g s (sk ...) fk i) #'(sk ... i)) 143 | ((match-two v (and p q ...) g s sk fk i) 144 | #'(match-one v p g s (match-one v (and q ...) g s sk fk) fk i)) 145 | ((match-two v (or) g s sk fk i) #'fk) 146 | ((match-two v (or p) g s sk fk i) 147 | #'(match-one v p g s sk fk i)) 148 | ((match-two v (or p ...) g s sk fk i) 149 | #'(match-extract-vars (or p ...) 150 | (match-gen-or v (p ...) g s sk fk i) 151 | i 152 | ())) 153 | ((match-two v (not p) g s (sk ...) fk i) 154 | #'(match-one v p g s (match-drop-ids fk) (sk ... i) i)) 155 | ((match-two v (get! getter) g s (sk ...) fk i) 156 | #'(let ((getter (lambda () g))) (sk ... i))) 157 | ((match-two v (set! setter) g (s ...) (sk ...) fk i) 158 | #'(let ((setter (lambda (x) (s ... x)))) (sk ... i))) 159 | ((match-two v (? pred p ...) g s sk fk i) 160 | #'(if (pred v) (match-one v (and p ...) g s sk fk i) fk)) 161 | ((match-two v (= proc p) g s sk fk i) 162 | #'(let ((w (proc v))) 163 | (match-one w p g s sk fk i))) 164 | ((match-two v (p ___ . r) g s sk fk i) 165 | (ellipses? #'___) 166 | #'(match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())) 167 | ((match-two v (p) g s sk fk i) 168 | #'(if (and (pair? v) (null? (cdr v))) 169 | (let ((w (car v))) 170 | (match-one w p (car v) (set-car! v) sk fk i)) 171 | fk)) 172 | ((match-two v (p . q) g s sk fk i) 173 | #'(if (pair? v) 174 | (let ((w (car v)) (x (cdr v))) 175 | (match-one w p (car v) (set-car! v) 176 | (match-one x q (cdr v) (set-cdr! v) sk fk) 177 | fk 178 | i)) 179 | fk)) 180 | ((match-two v #(p ...) g s sk fk i) 181 | #'(match-vector v 0 () (p ...) sk fk i)) 182 | ((match-two v us g s (sk ...) fk i) (underscore? #'us) #'(sk ... i)) 183 | ;; Not a pair or vector or special literal, test to see if it's a 184 | ;; new symbol, in which case we just bind it, or if it's an 185 | ;; already bound symbol or some other literal, in which case we 186 | ;; compare it with EQUAL?. 187 | ((match-two v x g s (sk ...) fk (id ...)) 188 | #'(let-syntax 189 | ((new-sym? 190 | (syntax-rules (id ...) 191 | ((new-sym? x sk2 fk2) sk2) 192 | ((new-sym? y sk2 fk2) fk2)))) 193 | (new-sym? random-sym-to-match 194 | (let ((x v)) (sk ... (id ... x))) 195 | (if (equal? v x) (sk ... (id ...)) fk)))) 196 | ))) 197 | 198 | ;; QUASIQUOTE patterns 199 | 200 | (define-syntax match-quasiquote 201 | (syntax-rules (unquote unquote-splicing quasiquote) 202 | ((_ v (unquote p) g s sk fk i) 203 | (match-one v p g s sk fk i)) 204 | ((_ v ((unquote-splicing p) . rest) g s sk fk i) 205 | (if (pair? v) 206 | (match-one v 207 | (p . tmp) 208 | (match-quasiquote tmp rest g s sk fk) 209 | fk 210 | i) 211 | fk)) 212 | ((_ v (quasiquote p) g s sk fk i . depth) 213 | (match-quasiquote v p g s sk fk i #f . depth)) 214 | ((_ v (unquote p) g s sk fk i x . depth) 215 | (match-quasiquote v p g s sk fk i . depth)) 216 | ((_ v (unquote-splicing p) g s sk fk i x . depth) 217 | (match-quasiquote v p g s sk fk i . depth)) 218 | ((_ v (p . q) g s sk fk i . depth) 219 | (if (pair? v) 220 | (let ((w (car v)) (x (cdr v))) 221 | (match-quasiquote 222 | w p g s 223 | (match-quasiquote-step x q g s sk fk depth) 224 | fk i . depth)) 225 | fk)) 226 | ((_ v #(elt ...) g s sk fk i . depth) 227 | (if (vector? v) 228 | (let ((ls (vector->list v))) 229 | (match-quasiquote ls (elt ...) g s sk fk i . depth)) 230 | fk)) 231 | ((_ v x g s sk fk i . depth) 232 | (match-one v 'x g s sk fk i)))) 233 | 234 | (define-syntax match-quasiquote-step 235 | (syntax-rules () 236 | ((match-quasiquote-step x q g s sk fk depth i) 237 | (match-quasiquote x q g s sk fk i . depth)) 238 | )) 239 | 240 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 241 | ;; Utilities 242 | 243 | ;; A CPS utility that takes two values and just expands into the 244 | ;; first. 245 | (define-syntax match-drop-ids 246 | (syntax-rules () 247 | ((_ expr ids ...) expr))) 248 | 249 | ;; Generating OR clauses just involves binding the success 250 | ;; continuation into a thunk which takes the identifiers common to 251 | ;; each OR clause, and trying each clause, calling the thunk as soon 252 | ;; as we succeed. 253 | 254 | (define-syntax match-gen-or 255 | (syntax-rules () 256 | ((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...)) 257 | (let ((sk2 (lambda (id ...) (sk ... (i ... id ...))))) 258 | (match-gen-or-step 259 | v p g s (match-drop-ids (sk2 id ...)) fk (i ...)))))) 260 | 261 | (define-syntax match-gen-or-step 262 | (syntax-rules () 263 | ((_ v () g s sk fk i) 264 | ;; no OR clauses, call the failure continuation 265 | fk) 266 | ((_ v (p) g s sk fk i) 267 | ;; last (or only) OR clause, just expand normally 268 | (match-one v p g s sk fk i)) 269 | ((_ v (p . q) g s sk fk i) 270 | ;; match one and try the remaining on failure 271 | (match-one v p g s sk (match-gen-or-step v q g s sk fk i) i)) 272 | )) 273 | 274 | ;; We match a pattern (p ...) by matching the pattern p in a loop on 275 | ;; each element of the variable, accumulating the bound ids into lists. 276 | 277 | ;; Look at the body - it's just a named let loop, matching each 278 | ;; element in turn to the same pattern. This illustrates the 279 | ;; simplicity of this generative-style pattern matching. It would be 280 | ;; just as easy to implement a tree searching pattern. 281 | 282 | (define-syntax match-gen-ellipses 283 | (syntax-rules () 284 | ((_ v p () g s (sk ...) fk i ((id id-ls) ...)) 285 | (match-check-identifier p 286 | ;; simplest case equivalent to ( . p), just bind the list 287 | (let ((p v)) 288 | (if (list? p) 289 | (sk ... i) 290 | fk)) 291 | ;; simple case, match all elements of the list 292 | (let loop ((ls v) (id-ls '()) ...) 293 | (cond 294 | ((null? ls) 295 | (let ((id (reverse id-ls)) ...) (sk ... i))) 296 | ((pair? ls) 297 | (let ((w (car ls))) 298 | (match-one w p (car ls) (set-car! ls) 299 | (match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) 300 | fk i))) 301 | (else 302 | fk))))) 303 | ((_ v p (r ...) g s (sk ...) fk i ((id id-ls) ...)) 304 | ;; general case, trailing patterns to match 305 | (match-verify-no-ellipses 306 | (r ...) 307 | (let* ((tail-len (length '(r ...))) 308 | (ls v) 309 | (len (length ls))) 310 | (if (< len tail-len) 311 | fk 312 | (let loop ((ls ls) (n len) (id-ls '()) ...) 313 | (cond 314 | ((= n tail-len) 315 | (let ((id (reverse id-ls)) ...) 316 | (match-one ls (r ...) #f #f (sk ... i) fk i))) 317 | ((pair? ls) 318 | (let ((w (car ls))) 319 | (match-one w p (car ls) (set-car! ls) 320 | (match-drop-ids 321 | (loop (cdr ls) (- n 1) (cons id id-ls) ...)) 322 | fk 323 | i))) 324 | (else 325 | fk))))))) 326 | )) 327 | 328 | (define-syntax match-verify-no-ellipses 329 | (syntax-rules () 330 | ((_ (x . y) sk) 331 | (match-check-ellipse 332 | x 333 | (match-syntax-error 334 | "multiple ellipse patterns not allowed at same level") 335 | (match-verify-no-ellipses y sk))) 336 | ((_ x sk) sk) 337 | )) 338 | 339 | ;; Vector patterns are just more of the same, with the slight 340 | ;; exception that we pass around the current vector index being 341 | ;; matched. 342 | 343 | (define-syntax match-vector 344 | (lambda (stx) 345 | (define (ellipses? x) 346 | (and (identifier? x) (free-identifier=? x #'(... ...)))) 347 | (syntax-case stx () 348 | ((_ v n pats (p q) sk fk i) 349 | #'(match-check-ellipse q 350 | (match-vector-ellipses v n pats p sk fk i) 351 | (match-vector-two v n pats (p q) sk fk i))) 352 | ((_ v n pats (p ___) sk fk i) 353 | (ellipses? #'___) 354 | #'(match-vector-ellipses v n pats p sk fk i)) 355 | ((_ . x) 356 | #'(match-vector-two . x))))) 357 | 358 | ;; Check the exact vector length, then check each element in turn. 359 | 360 | (define-syntax match-vector-two 361 | (syntax-rules () 362 | ((_ v n ((pat index) ...) () sk fk i) 363 | (if (vector? v) 364 | (let ((len (vector-length v))) 365 | (if (= len n) 366 | (match-vector-step v ((pat index) ...) sk fk i) 367 | fk)) 368 | fk)) 369 | ((_ v n (pats ...) (p . q) sk fk i) 370 | (match-vector v (+ n 1) (pats ... (p n)) q sk fk i)) 371 | )) 372 | 373 | (define-syntax match-vector-step 374 | (syntax-rules () 375 | ((_ v () (sk ...) fk i) (sk ... i)) 376 | ((_ v ((pat index) . rest) sk fk i) 377 | (let ((w (vector-ref v index))) 378 | (match-one w pat (vector-ref v index) (vector-set! v index) 379 | (match-vector-step v rest sk fk) 380 | fk i))))) 381 | 382 | ;; With a vector ellipse pattern we first check to see if the vector 383 | ;; length is at least the required length. 384 | 385 | (define-syntax match-vector-ellipses 386 | (syntax-rules () 387 | ((_ v n ((pat index) ...) p sk fk i) 388 | (if (vector? v) 389 | (let ((len (vector-length v))) 390 | (if (>= len n) 391 | (match-vector-step v ((pat index) ...) 392 | (match-vector-tail v p n len sk fk) 393 | fk i) 394 | fk)) 395 | fk)))) 396 | 397 | (define-syntax match-vector-tail 398 | (syntax-rules () 399 | ((_ v p n len sk fk i) 400 | (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ())))) 401 | 402 | (define-syntax match-vector-tail-two 403 | (syntax-rules () 404 | ((_ v p n len (sk ...) fk i ((id id-ls) ...)) 405 | (let loop ((j n) (id-ls '()) ...) 406 | (if (>= j len) 407 | (let ((id (reverse id-ls)) ...) (sk ... i)) 408 | (let ((w (vector-ref v j))) 409 | (match-one w p (vector-ref v j) (vetor-set! v j) 410 | (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) 411 | fk i))))))) 412 | 413 | ;; Extract all identifiers in a pattern. A little more complicated 414 | ;; than just looking for symbols, we need to ignore special keywords 415 | ;; and not pattern forms (such as the predicate expression in ? 416 | ;; patterns). 417 | ;; 418 | ;; (match-extract-vars pattern continuation (ids ...) (new-vars ...)) 419 | 420 | (define-syntax match-extract-vars 421 | (lambda (stx) 422 | (define (ellipses? x) 423 | (and (identifier? x) (free-identifier=? x #'(... ...)))) 424 | (define (underscore? x) 425 | (and (identifier? x) (free-identifier=? x #'_))) 426 | (syntax-case stx (? $ = quote quasiquote and or not get! set!) 427 | ((match-extract-vars (? pred . p) k i v) 428 | #'(match-extract-vars p k i v)) 429 | ((match-extract-vars ($ rec . p) k i v) 430 | #'(match-extract-vars p k i v)) 431 | ((match-extract-vars (= proc p) k i v) 432 | #'(match-extract-vars p k i v)) 433 | ((match-extract-vars (quote x) (k ...) i v) 434 | #'(k ... v)) 435 | ((match-extract-vars (quasiquote x) k i v) 436 | #'(match-extract-quasiquote-vars x k i v (#t))) 437 | ((match-extract-vars (and . p) k i v) 438 | #'(match-extract-vars p k i v)) 439 | ((match-extract-vars (or . p) k i v) 440 | #'(match-extract-vars p k i v)) 441 | ((match-extract-vars (not . p) k i v) 442 | #'(match-extract-vars p k i v)) 443 | ;; A non-keyword pair, expand the CAR with a continuation to 444 | ;; expand the CDR. 445 | ((match-extract-vars (p q . r) k i v) 446 | #'(match-check-ellipse 447 | q 448 | (match-extract-vars (p . r) k i v) 449 | (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ()))) 450 | ((match-extract-vars (p . q) k i v) 451 | #'(match-extract-vars p (match-extract-vars-step q k i v) i ())) 452 | ((match-extract-vars #(p ...) k i v) 453 | #'(match-extract-vars (p ...) k i v)) 454 | ((match-extract-vars us (k ...) i v) (underscore? #'us) #'(k ... v)) 455 | ((match-extract-vars ___ (k ...) i v) (ellipses? #'___) #'(k ... v)) 456 | ;; This is the main part, the only place where we might add a new 457 | ;; var if it's an unbound symbol. 458 | ((match-extract-vars p (k ...) (i ...) v) 459 | #'(let-syntax 460 | ((new-sym? 461 | (syntax-rules (i ...) 462 | ((new-sym? p sk fk) sk) 463 | ((new-sym? x sk fk) fk)))) 464 | (new-sym? random-sym-to-match 465 | (k ... ((p p-ls) . v)) 466 | (k ... v)))) 467 | ))) 468 | 469 | ;; Stepper used in the above so it can expand the CAR and CDR 470 | ;; separately. 471 | 472 | (define-syntax match-extract-vars-step 473 | (syntax-rules () 474 | ((_ p k i v ((v2 v2-ls) ...)) 475 | (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v))) 476 | )) 477 | 478 | (define-syntax match-extract-quasiquote-vars 479 | (syntax-rules (quasiquote unquote unquote-splicing) 480 | ((match-extract-quasiquote-vars (quasiquote x) k i v d) 481 | (match-extract-quasiquote-vars x k i v (#t . d))) 482 | ((match-extract-quasiquote-vars (unquote-splicing x) k i v d) 483 | (match-extract-quasiquote-vars (unquote x) k i v d)) 484 | ((match-extract-quasiquote-vars (unquote x) k i v (#t)) 485 | (match-extract-vars x k i v)) 486 | ((match-extract-quasiquote-vars (unquote x) k i v (#t . d)) 487 | (match-extract-quasiquote-vars x k i v d)) 488 | ((match-extract-quasiquote-vars (x . y) k i v (#t . d)) 489 | (match-extract-quasiquote-vars 490 | x 491 | (match-extract-quasiquote-vars-step y k i v d) i ())) 492 | ((match-extract-quasiquote-vars #(x ...) k i v (#t . d)) 493 | (match-extract-quasiquote-vars (x ...) k i v d)) 494 | ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) 495 | (k ... v)) 496 | )) 497 | 498 | (define-syntax match-extract-quasiquote-vars-step 499 | (syntax-rules () 500 | ((_ x k i v d ((v2 v2-ls) ...)) 501 | (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d)) 502 | )) 503 | 504 | 505 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 506 | ;; Gimme some sugar baby. 507 | 508 | (define-syntax match-lambda 509 | (syntax-rules () 510 | ((_ clause ...) (lambda (expr) (match expr clause ...))))) 511 | 512 | (define-syntax match-lambda* 513 | (syntax-rules () 514 | ((_ clause ...) (lambda expr (match expr clause ...))))) 515 | 516 | (define-syntax match-let 517 | (syntax-rules () 518 | ((_ (vars ...) . body) 519 | (match-let/helper let () () (vars ...) . body)) 520 | ((_ loop . rest) 521 | (match-named-let loop () . rest)))) 522 | 523 | (define-syntax match-letrec 524 | (syntax-rules () 525 | ((_ vars . body) (match-let/helper letrec () () vars . body)))) 526 | 527 | (define-syntax match-let/helper 528 | (syntax-rules () 529 | ((_ let ((var expr) ...) () () . body) 530 | (let ((var expr) ...) . body)) 531 | ((_ let ((var expr) ...) ((pat tmp) ...) () . body) 532 | (let ((var expr) ...) 533 | (match-let* ((pat tmp) ...) 534 | . body))) 535 | ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body) 536 | (match-let/helper 537 | let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body)) 538 | ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body) 539 | (match-let/helper 540 | let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body)) 541 | ((_ let (v ...) (p ...) ((a expr) . rest) . body) 542 | (match-let/helper let (v ... (a expr)) (p ...) rest . body)) 543 | )) 544 | 545 | (define-syntax match-named-let 546 | (syntax-rules () 547 | ((_ loop ((pat expr var) ...) () . body) 548 | (let loop ((var expr) ...) 549 | (match-let ((pat var) ...) 550 | . body))) 551 | ((_ loop (v ...) ((pat expr) . rest) . body) 552 | (match-named-let loop (v ... (pat expr tmp)) rest . body)))) 553 | 554 | (define-syntax match-let* 555 | (syntax-rules () 556 | ((_ () . body) 557 | (begin . body)) 558 | ((_ ((pat expr) . rest) . body) 559 | (match expr (pat (match-let* rest . body)))))) 560 | 561 | 562 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 563 | ;; Otherwise COND-EXPANDed bits. 564 | 565 | ;; This *should* work, but doesn't :( 566 | ;; (define-syntax match-check-ellipse 567 | ;; (syntax-rules (...) 568 | ;; ((_ ... sk fk) sk) 569 | ;; ((_ x sk fk) fk))) 570 | 571 | ;; This is a little more complicated, and introduces a new let-syntax, 572 | ;; but should work portably in any R[56]RS Scheme. Taylor Campbell 573 | ;; originally came up with the idea. 574 | (define-syntax match-check-ellipse 575 | (syntax-rules () 576 | ;; these two aren't necessary but provide fast-case failures 577 | ((match-check-ellipse (a . b) success-k failure-k) failure-k) 578 | ((match-check-ellipse #(a ...) success-k failure-k) failure-k) 579 | ;; matching an atom 580 | ((match-check-ellipse id success-k failure-k) 581 | (let-syntax ((ellipse? (syntax-rules () 582 | ;; iff `id' is `...' here then this will 583 | ;; match a list of any length 584 | ((ellipse? (foo id) sk fk) sk) 585 | ((ellipse? other sk fk) fk)))) 586 | ;; this list of three elements will only many the (foo id) list 587 | ;; above if `id' is `...' 588 | (ellipse? (a b c) success-k failure-k))))) 589 | 590 | 591 | ;; This is portable but can be more efficient with non-portable 592 | ;; extensions. This trick was originally discovered by Oleg Kiselyov. 593 | 594 | (define-syntax match-check-identifier 595 | (syntax-rules () 596 | ;; fast-case failures, lists and vectors are not identifiers 597 | ((_ (x . y) success-k failure-k) failure-k) 598 | ((_ #(x ...) success-k failure-k) failure-k) 599 | ;; x is an atom 600 | ((_ x success-k failure-k) 601 | (let-syntax 602 | ((sym? 603 | (syntax-rules () 604 | ;; if the symbol `abracadabra' matches x, then x is a 605 | ;; symbol 606 | ((sym? x sk fk) sk) 607 | ;; otherwise x is a non-symbol datum 608 | ((sym? y sk fk) fk)))) 609 | (sym? abracadabra success-k failure-k))) 610 | )) 611 | ) 612 | -------------------------------------------------------------------------------- /test.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | 3 | (library (mpl test) 4 | 5 | (export test) 6 | 7 | (import (mpl rnrs-sans) 8 | (only (surfage s1 lists) lset=) 9 | (surfage s64 testing) 10 | (dharmalab infix alg) 11 | (mpl misc) 12 | (mpl contains) 13 | (mpl sum-product-power) 14 | (mpl sub) 15 | (mpl div) 16 | (mpl exp) 17 | (mpl factorial) 18 | (mpl numerator) 19 | (mpl denominator) 20 | (mpl sqrt) 21 | (mpl sin) 22 | (mpl cos) 23 | (mpl tan) 24 | (mpl automatic-simplify) 25 | (mpl alge) 26 | (mpl substitute) 27 | (mpl monomial-gpe) 28 | (mpl polynomial-gpe) 29 | (mpl variables) 30 | (mpl degree-gpe) 31 | (mpl coefficient-gpe) 32 | (mpl leading-coefficient-gpe) 33 | (mpl coeff-var-monomial) 34 | (mpl collect-terms) 35 | (mpl algebraic-expand) 36 | (mpl expand-main-op) 37 | (mpl rational-gre) 38 | (mpl rational-variables) 39 | (mpl rationalize-expression) 40 | (mpl rational-expand) 41 | (mpl expand-exp) 42 | (mpl expand-trig) 43 | (mpl contract-exp) 44 | (mpl separate-sin-cos) 45 | (mpl contract-trig) 46 | (mpl trig-substitute) 47 | (mpl simplify-trig) 48 | (mpl derivative) 49 | (mpl polynomial-division) 50 | (mpl polynomial-expansion) 51 | (mpl polynomial-gcd) 52 | (mpl extended-euclidean-algorithm) 53 | (mpl alg-polynomial-division) 54 | (mpl alg-polynomial-gcd) 55 | (mpl partial-fraction-1)) 56 | 57 | (define-syntax test-equal-anon 58 | (syntax-rules () 59 | ( (test-equal-anon a b) 60 | (test-equal 'a a b) ))) 61 | 62 | (define (test) 63 | 64 | (vars a b c d x y z pi t) 65 | 66 | (test-begin "mpl") 67 | 68 | (test-equal "Figure 1.5" 69 | (- (/ (* x y) 3)) 70 | '(* -1/3 x y) 71 | ) 72 | 73 | (test-equal "Example 3.35" 74 | (^ (^ (^ x 1/2) 1/2) 8) 75 | '(^ x 2) 76 | ) 77 | 78 | (test-equal "Example 3.36" 79 | (^ (* (^ (* x y) 1/2) (^ z 2)) 2) 80 | '(* x y (^ z 4)) 81 | ) 82 | 83 | (test-equal "3.2 Exercise 3-a" 84 | (/ x x) 85 | 1 86 | ) 87 | 88 | (test-equal "3.2 Exercise 3-b" 89 | (* (/ x y) 90 | (/ y x)) 91 | 1 92 | ) 93 | 94 | (test-equal 6 95 | (* 2 3) 96 | ) 97 | 98 | (test-equal '(* 2 x) 99 | (* 2 x) 100 | ) 101 | 102 | (test-equal '(* 2 x y z) 103 | (* z y x 2) 104 | ) 105 | 106 | (test-equal '(^ x 5) 107 | (* (^ x 2) (^ x 3)) 108 | ) 109 | 110 | (test-equal '(+ 5 (* 2 x) y (* 2 z)) 111 | (+ x y x z 5 z) 112 | ) 113 | 114 | (test-equal '(* 1/2 x) 115 | (/ x 2) 116 | ) 117 | 118 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 119 | ;; substitute 120 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 121 | 122 | (test-equal "Figure 3.23 - 2" 123 | (substitute (alg "a+b") b x) 124 | (+ a x) 125 | ) 126 | 127 | (test-equal "Figure 3.23 - 4" 128 | (substitute (alg "1/a+a") a x) 129 | (+ (^ x -1) x) 130 | ) 131 | 132 | (test-equal "Figure 3.23 - 5" 133 | (substitute (alg "(a+b)^2 + 1") (alg "a+b") x) 134 | (+ 1 (^ x 2)) 135 | ) 136 | 137 | (test-equal "Figure 3.23 - 6" 138 | (substitute '(+ a b c) '(+ a b) x) 139 | (+ a b c) 140 | ) 141 | 142 | (test-equal "Figure 3.23 - 7" 143 | (substitute (+ a b c) a (alg "x-b")) 144 | (+ c x) 145 | ) 146 | 147 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 148 | ;; sequential-substitute 149 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 150 | 151 | (test-equal "EA: Example 3.32 - 1" 152 | (sequential-substitute (alg "x+y") 153 | `( ( x ,(alg "a+1") ) 154 | ( y ,(alg "b+2") ))) 155 | (+ 3 a b) 156 | ) 157 | 158 | (test-equal "EA: Example 3.32 - 2" 159 | (sequential-substitute (alg "x+y") 160 | `( ( x ,(alg "a+1") ) 161 | ( a ,(alg "b+2") ))) 162 | (+ 3 b y) 163 | ) 164 | 165 | (test-equal "EA: Example 3.32 - 3" 166 | (sequential-substitute (alg "f(x)=a*x+b") 167 | '( ( (f x) 2 ) 168 | ( x 3 ) )) 169 | '(= 2 (+ (* 3 a) b)) 170 | ) 171 | 172 | (test-equal "EA: Example 3.32 - 4" 173 | (sequential-substitute (alg "f(x)=a*x+b") 174 | '( ( x 3 ) 175 | ( (f x) 2 ) )) 176 | '(= (f 3) (+ (* 3 a) b)) 177 | ) 178 | 179 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 180 | 181 | (test-equal "EA: Example 3.35 - 1" 182 | (concurrent-substitute (alg "(a+b)*x") 183 | `( ( ,(alg "a+b") ,(alg "x+c") ) 184 | ( x d ) )) 185 | (* d (+ c x)) 186 | ) 187 | 188 | (test-equal "EA: Example 3.35 - 2" 189 | (concurrent-substitute (alg "f(x)=a*x+b") 190 | '( ( x 3 ) 191 | ( (f x) 2 ) )) 192 | '(= 2 (+ (* 3 a) b)) 193 | ) 194 | 195 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 196 | ;; monomial-gpe? 197 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 198 | 199 | (test-equal "EA: Example 6.18 - 1" 200 | (monomial-gpe? (automatic-simplify 201 | (alg "a x^2 y^2")) 202 | '(x y)) 203 | #t) 204 | 205 | (test-equal "EA: Example 6.18 - 2" 206 | (monomial-gpe? (automatic-simplify 207 | (alg "x^2 + y^2")) 208 | '(x y)) 209 | #f) 210 | 211 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 212 | ;; polynomial-gpe? 213 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 214 | 215 | (test-equal "EA: Example 6.18 - 3" 216 | (polynomial-gpe? (automatic-simplify 217 | (alg " x^2 + y^2 ")) 218 | '(x y)) 219 | #t) 220 | 221 | (test-equal "EA: Example 6.18 - 4" 222 | (polynomial-gpe? (automatic-simplify 223 | (alg " sin(x)^2 + 2 sin(x) + 3 ")) 224 | (list (alg "sin(x)"))) 225 | #t) 226 | 227 | (test-equal "EA: Example 6.18 - 5" 228 | (polynomial-gpe? (automatic-simplify 229 | (alg " x/y + 2 y ")) 230 | '(x y)) 231 | #f) 232 | 233 | (test-equal "EA: Example 6.18 - 5" 234 | (polynomial-gpe? (automatic-simplify 235 | (alg " (x+1) * (x+3) ")) 236 | '(x)) 237 | #f) 238 | 239 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 240 | ;; variables 241 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 242 | 243 | (test-equal "EA: Example 6.20 - 1" 244 | (lset= equal? 245 | (variables 246 | (automatic-simplify 247 | (alg " x^3 + 3 x^2 y + 3 x y^2 + y^3 "))) 248 | '(x y)) 249 | #t) 250 | 251 | (test-equal "EA: Example 6.20 - 2" 252 | (lset= equal? 253 | (variables 254 | (automatic-simplify 255 | (alg " 3 x * (x+1) * y^2 * z^n "))) 256 | '((^ z n) y (+ 1 x) x)) 257 | #t) 258 | 259 | (test-equal "EA: Example 6.20 - 3" 260 | (lset= equal? 261 | (variables 262 | (automatic-simplify 263 | (alg " a sin(x)^2 + 2 b sin(x) + 3 c "))) 264 | '(a b (sin x) c)) 265 | #t) 266 | 267 | (test-equal "EA: Example 6.20 - 3" 268 | (lset= equal? 269 | (variables 270 | (automatic-simplify 271 | (alg " a sin(x)^2 + 2 b sin(x) + 3 c "))) 272 | '(a b (sin x) c)) 273 | #t) 274 | 275 | (test-equal "EA: Example 6.20 - 4" 276 | (variables 1/2) 277 | '()) 278 | 279 | (test-equal "EA: Example 6.20 - 5" 280 | (lset= equal? 281 | (variables 282 | (automatic-simplify 283 | (alg " sqrt(2) * x^2 + sqrt(3) * x + sqrt(5) "))) 284 | (list (sqrt 2) (sqrt 3) x (sqrt 5))) 285 | #t) 286 | 287 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 288 | ;; degree-gpe 289 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 290 | 291 | (test-equal "EA: Example 6.22 - 1" 292 | (degree-gpe 293 | (automatic-simplify 294 | (alg " 3 w x^2 y^3 z^4 ")) 295 | '(x z)) 296 | 6) 297 | 298 | (test-equal "EA: Example 6.22 - 2" 299 | (degree-gpe 300 | (automatic-simplify 301 | (alg " a x^2 + b x + c ")) 302 | '(x)) 303 | 2) 304 | 305 | (test-equal "EA: Example 6.22 - 3" 306 | (degree-gpe 307 | (automatic-simplify 308 | (alg " a * sin(x)^2 + b * sin(x) + c ")) 309 | '((sin x))) 310 | 2) 311 | 312 | (test-equal "EA: Example 6.22 - 4" 313 | (degree-gpe 314 | (automatic-simplify 315 | (alg " 2 x^2 y z^3 + w x z^6 ")) 316 | '(x z)) 317 | 7) 318 | 319 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 320 | 321 | (let () 322 | 323 | (define (total-degree u) 324 | (degree-gpe u (variables u))) 325 | 326 | (test-equal "EA: Example 6.25" 327 | (total-degree (automatic-simplify 328 | (alg " a x^2 + b x + c "))) 329 | 3)) 330 | 331 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 332 | ;; coefficient-gpe 333 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 334 | 335 | (test-equal "EA: Example 6.27 - 1" 336 | 337 | (coefficient-gpe (automatic-simplify 338 | (alg " a x^2 + b x + c ")) 339 | x 340 | 2) 341 | 342 | a) 343 | 344 | (test-equal "EA: Example 6.27 - 2" 345 | 346 | (coefficient-gpe (automatic-simplify 347 | (alg " 3 x y^2 + 5 x^2 y + 7 x + 9 ")) 348 | x 349 | 1) 350 | 351 | '(+ 7 (* 3 (^ y 2))) 352 | ) 353 | 354 | (test-equal "EA: Example 6.27 - 3" 355 | 356 | (coefficient-gpe (automatic-simplify 357 | (alg " 3 x y^2 + 5 x^2 y + 7 x + 9 ")) 358 | x 359 | 3) 360 | 361 | 0) 362 | 363 | (test-equal "EA: Example 6.27 - 4" 364 | 365 | (coefficient-gpe (automatic-simplify 366 | (alg " 3 * sin(x) * x^2 + 2 * ln(x) * x + 4 ")) 367 | x 368 | 2) 369 | 'undefined) 370 | 371 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 372 | ;; leading-coefficient-gpe 373 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 374 | 375 | (test-equal "EA: page 233" 376 | 377 | (leading-coefficient-gpe 378 | (automatic-simplify 379 | (alg " 3 x y^2 + 5 x^2 y + 7 x^2 y^3 + 9 ")) 380 | x) 381 | 382 | (automatic-simplify 383 | (alg " 5 y + 7 y^3 ")) 384 | 385 | ) 386 | 387 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 388 | ;; coeff-var-monomial 389 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 390 | 391 | (test-equal "coeff-var-monomial 1" 392 | 393 | (coeff-var-monomial (automatic-simplify 394 | (alg "3 x y")) 395 | '(x)) 396 | 397 | '((* 3 y) x) 398 | 399 | ) 400 | 401 | (test-equal "coeff-var-monomial 2" 402 | 403 | (coeff-var-monomial (automatic-simplify 404 | (alg "3 x y")) 405 | '(y)) 406 | 407 | '((* 3 x) y) 408 | 409 | ) 410 | 411 | (test-equal "coeff-var-monomial 3" 412 | 413 | (coeff-var-monomial (automatic-simplify 414 | (alg "3 x y")) 415 | '(x y)) 416 | 417 | '(3 (* x y)) 418 | 419 | ) 420 | 421 | (test-equal "coeff-var-monomial 4" 422 | 423 | (coeff-var-monomial (automatic-simplify 424 | (alg "3 x y")) 425 | '(3 x y)) 426 | 427 | '(1 (* 3 x y)) 428 | 429 | ) 430 | 431 | (test-equal "coeff-var-monomial 5" 432 | 433 | (coeff-var-monomial (automatic-simplify 434 | (alg "3 x y")) 435 | '()) 436 | 437 | '((* 3 x y) 1) 438 | 439 | ) 440 | 441 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 442 | ;; collect-terms 443 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 444 | 445 | (test-equal "EA: Example 6.43" 446 | 447 | (collect-terms (alge " 2 a x y + 3 b x y + 4 a x + 5 b x ") 448 | '(x y)) 449 | 450 | (alge " (2 a + 3 b) x y + (4 a + 5 b) x ") 451 | 452 | ) 453 | 454 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 455 | ;; algebraic-expand 456 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 457 | 458 | (test-equal "EA: 6.34" 459 | 460 | (algebraic-expand (alge " (x+2) * (x+3) * (x+4) ")) 461 | 462 | (alge " x^3 + 9 x^2 + 26 x + 24 ") 463 | 464 | ) 465 | 466 | (test-equal "EA: 6.35" 467 | 468 | (algebraic-expand (alge " (x+y+z)^3 ")) 469 | 470 | (alge " x^3 + y^3 + z^3 + 471 | 3 x^2 y + 3 x^2 z + 472 | 3 y^2 x + 3 y^2 z + 473 | 3 z^2 x + 3 z^2 y + 474 | 6 x y z " ) 475 | 476 | ) 477 | 478 | (test-equal "EA: 6.36" 479 | 480 | (algebraic-expand (alge " (x+1)^2 + (y+1)^2 ")) 481 | 482 | (alge " x^2 + 2 x + y^2 + 2 y + 2 ") 483 | 484 | ) 485 | 486 | (test-equal "EA: 6.37" 487 | 488 | (algebraic-expand (alge " ((x+2)^2 +3)^2 ")) 489 | 490 | (alge " x^4 + 8 x^3 + 30 x^2 + 56 x + 49 ") 491 | 492 | ) 493 | 494 | (test-equal-anon (algebraic-expand 495 | (sin (* x (+ y z)))) 496 | 497 | (sin (+ (* x y) (* x z)))) 498 | 499 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 500 | ;; expand-main-op 501 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 502 | 503 | (test-equal "EA: section 6.4 exercise 6 - a" 504 | 505 | (expand-main-op (alge " x * (2 + (1 + x)^2) ")) 506 | 507 | (alge " 2*x + x*(1+x)^2 ") 508 | 509 | ) 510 | 511 | (test-equal "EA: section 6.4 exercise 6 - b" 512 | 513 | (expand-main-op (alge " ( x + (1+x)^2 )^2 ")) 514 | 515 | (alge " x^2 + 2*x*(1+x)^2 + (1+x)^4 ") 516 | 517 | ) 518 | 519 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 520 | ;; numerator 521 | ;; denominator 522 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 523 | 524 | (test-equal "EA: Example 6.49 - numerator" 525 | 526 | (numerator (alge " 2/3 * (x*(x+1)) / (x+2) * y^n ")) 527 | 528 | (alge " 2 x * (x+1) y^n ")) 529 | 530 | (test-equal "EA: Example 6.49 - denominator" 531 | 532 | (denominator (alge " 2/3 * (x*(x+1)) / (x+2) * y^n ")) 533 | 534 | (alge " 3 * ( x + 2 ) ")) 535 | 536 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 537 | ;; rational-gre? 538 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 539 | 540 | (test-equal "EA: Example 6.54 - 1" 541 | 542 | (rational-gre? (alge " (x^2 + 1) / (2 x + 3) ") '(x)) 543 | 544 | '(x)) 545 | 546 | (test-equal "EA: Example 6.54 - 2" 547 | 548 | (rational-gre? (alge " 1/x + 1/y ") '(x y)) 549 | 550 | #f) 551 | 552 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 553 | ;; rational-variables 554 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 555 | 556 | (test-equal "EA: Example 6.56 - 1" 557 | 558 | (rational-variables (alge " (2 x + 3 y) / (z + 4) ")) 559 | 560 | '(z y x)) 561 | 562 | (test-equal "EA: Example 6.56 - 2" 563 | 564 | (rational-variables (alge " 1/x + 1/y ")) 565 | 566 | (list (alge "1/y") (alge "1/x"))) 567 | 568 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 569 | ;; rationalize-expression 570 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 571 | 572 | (test-equal "EA: page 266 - 1" 573 | 574 | (rationalize-expression (alge " (1 + 1/x)^2 ")) 575 | 576 | (alge " (x+1)^2 / x^2 ")) 577 | 578 | (test-equal "EA: page 266 - 1" 579 | 580 | (rationalize-expression (alge " (1 + 1/x)^(1/2) ")) 581 | 582 | (alge " ( (x+1)/x ) ^ (1/2) ")) 583 | 584 | (test-equal "EA: Example 6.59" 585 | 586 | (rationalize-expression 587 | (alge " 1 / (1+1/x)^(1/2) + (1+1/x)^(3/2) ")) 588 | 589 | (alge " ( x^2 + (x+1)^2 ) / ( x^2 * ( (x+1) / x ) ^ (1/2) ) ") 590 | 591 | ) 592 | 593 | (test-equal "EA: Example 6.60" 594 | 595 | (rationalize-expression (alge " a + b/2 ")) 596 | 597 | (alge " (2 a + b)/2 ") 598 | 599 | ) 600 | 601 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 602 | ;; rational-expand 603 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 604 | 605 | (test-equal "EA: Example 6.62" 606 | 607 | (rational-expand 608 | (alge 609 | " ( ( ( 1 / ( (x+y)^2 + 1 ) ) ^ (1/2) + 1 ) 610 | * 611 | ( ( 1 / ( (x+y)^2 + 1 ) ) ^ (1/2) - 1 ) ) 612 | / 613 | (x+1) ")) 614 | 615 | (alge 616 | " ( - x^2 - 2 x y - y^2 ) 617 | / 618 | ( x^3 + x^2 + 2 x^2 y + 2 x y + x y^2 + y^2 + x + 1 ) ") 619 | 620 | ) 621 | 622 | (test-equal 623 | 624 | "EA: page 269" 625 | 626 | (rational-expand 627 | (alge 628 | " 1 / ( 1/a + c / (a b) ) + ( a b c + a c^2 ) / (b+c)^2 - a ")) 629 | 630 | 0) 631 | 632 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 633 | ;; expand-exp 634 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 635 | 636 | (test-equal "EA: expression 7.1" 637 | 638 | (expand-exp (alge " exp( 2 x + y ) ")) 639 | 640 | (alge " exp(x)^2 exp(y) ")) 641 | 642 | (test-equal "EA: Example 7.2" 643 | 644 | (expand-exp (alge " exp( 2 w x + 3 y z ")) 645 | 646 | (alge " exp( w x )^2 exp( y z )^3 ")) 647 | 648 | (test-equal "EA: Example 7.3" 649 | 650 | (expand-exp (alge " exp( 2 * (x + y) ) ")) 651 | 652 | (alge " exp(x)^2 exp(y)^2 ")) 653 | 654 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 655 | ;; expand-trig 656 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 657 | 658 | (test-equal "EA: Expression 7.11" 659 | 660 | (expand-trig (alge " sin(x+y) ")) 661 | 662 | (alge " sin(x) * cos(y) + cos(x) * sin(y) ")) 663 | 664 | (test-equal "EA: Expression 7.12" 665 | 666 | (expand-trig (alge " cos(x+y) ")) 667 | 668 | (alge " cos(x) * cos(y) - sin(x) * sin(y) ")) 669 | 670 | (test-equal "EA: Example 7.5" 671 | 672 | (expand-trig (alge " sin(2x + 3y) ")) 673 | 674 | (alge " 2 * sin(x) * cos(x) * ( cos(y)^3 - 3 * cos(y) * sin(y)^2 ) 675 | + 676 | ( cos(x)^2 - sin(x)^2 ) * ( 3 cos(y)^2 sin(y) - sin(y)^3 ) ")) 677 | 678 | (test-equal "EA: Example 7.6" 679 | 680 | (expand-trig (alge " sin( 2 * (x+y) ) ")) 681 | 682 | 683 | (alge " 2 * ( sin(x) * cos(y) + cos(x) * sin(y) ) * 684 | ( cos(x) * cos(y) - sin(x) * sin(y) ) ") 685 | 686 | ) 687 | 688 | (test-equal "EA: Expression 7.18" 689 | 690 | (expand-trig (alge " cos(5x) ")) 691 | 692 | (alge "cos(x)^5 - 10 * cos(x)^3 * sin(x)^2 + 5 * cos(x) * sin(x)^4")) 693 | 694 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 695 | ;; contract-exp 696 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 697 | 698 | (test-equal "EA: Expression 7.27" 699 | 700 | (contract-exp (alge " exp(u) * exp(v) ")) 701 | 702 | (alge " exp(u+v) ")) 703 | 704 | (test-equal "EA: Expression 7.28" 705 | 706 | (contract-exp (alge " exp(u)^w ")) 707 | 708 | (alge " exp(w*u) ")) 709 | 710 | (test-equal "EA: Example 7.9 " 711 | 712 | (contract-exp (alge " exp(x) * ( exp(x) + exp(y) ) ")) 713 | 714 | (alge " exp(2*x) + exp(x+y) ")) 715 | 716 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 717 | ;; contract-trig 718 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 719 | 720 | (test-equal "EA: Expression 7.30" 721 | 722 | (contract-trig (alge " sin(x) * sin(y) ")) 723 | 724 | (alge " cos(x-y)/2 - cos(x+y)/2 ")) 725 | 726 | (test-equal "EA: Expression 7.31" 727 | 728 | (contract-trig (alge " cos(x) * cos(y) ")) 729 | 730 | (alge " cos(x+y)/2 + cos(x-y)/2 ")) 731 | 732 | (test-equal "EA: Expression 7.32" 733 | 734 | (contract-trig (alge " sin(x) * cos(y) ")) 735 | 736 | (alge " sin(x+y)/2 + sin(x-y)/2 ")) 737 | 738 | (test-equal "EA: Example 7.12" 739 | 740 | (contract-trig (alge " (sin(x) + cos(y)) * cos(y) ")) 741 | 742 | (alge " sin(x+y)/2 + sin(x-y)/2 + 1/2 + cos(2*y)/2 ")) 743 | 744 | (test-equal "EA: Example 7.13" 745 | 746 | (contract-trig (alge " sin(x)^2 * cos(x)^2 ")) 747 | 748 | (alge " 1/8 - cos(4*x)/8 ")) 749 | 750 | (test-equal "EA: Example 7.14" 751 | 752 | (contract-trig (alge " cos(x)^4 ")) 753 | 754 | (alge " 1/8 * cos(4*x) + 1/2 * cos(2*x) + 3/8 ")) 755 | 756 | (test-equal 757 | 758 | "EA: Example 7.15 - contract-trig" 759 | 760 | (contract-trig 761 | (alge 762 | " ( cos(x) + sin(x) )^4 + ( cos(x) - sin(x) )^4 + cos(4*x) - 3 ")) 763 | 764 | 0) 765 | 766 | (test-equal "EA: Example 7.16 - contract-trig" 767 | 768 | (contract-trig 769 | (alge 770 | " sin(x) + sin(y) - 2 * sin(x/2 + y/2) * cos(x/2 - y/2) ")) 771 | 772 | 0) 773 | 774 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 775 | ;; sin 776 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 777 | 778 | (test-equal (sin 0) 0) 779 | 780 | (test-equal (sin pi) 0) 781 | 782 | (test-equal (sin -5) (- (sin 5))) 783 | 784 | (test-equal (sin (- x)) (- (sin x))) 785 | 786 | (test-equal (sin (* -5 x)) (- (sin (* 5 x)))) 787 | 788 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 789 | ;; sin( k/n * pi ) for n = 1 2 3 4 6 790 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 791 | 792 | (test-equal (sin (* -2 pi)) 0) 793 | (test-equal (sin (* -1 pi)) 0) 794 | (test-equal (sin (* 2 pi)) 0) 795 | (test-equal (sin (* 3 pi)) 0) 796 | 797 | (test-equal (sin (* -7/2 pi)) 1) 798 | (test-equal (sin (* -5/2 pi)) -1) 799 | (test-equal (sin (* -3/2 pi)) 1) 800 | (test-equal (sin (* -1/2 pi)) -1) 801 | (test-equal (sin (* 1/2 pi)) 1) 802 | (test-equal (sin (* 3/2 pi)) -1) 803 | (test-equal (sin (* 5/2 pi)) 1) 804 | (test-equal (sin (* 7/2 pi)) -1) 805 | 806 | (test-equal-anon (sin (* -4/3 pi)) (alge " sqrt(3)/2 ")) 807 | (test-equal-anon (sin (* -2/3 pi)) (alge " -sqrt(3)/2 ")) 808 | (test-equal-anon (sin (* -1/3 pi)) (alge " -sqrt(3)/2 ")) 809 | (test-equal-anon (sin (* 1/3 pi)) (alge " sqrt(3)/2 ")) 810 | (test-equal-anon (sin (* 2/3 pi)) (alge " sqrt(3)/2 ")) 811 | (test-equal-anon (sin (* 4/3 pi)) (alge " -sqrt(3)/2 ")) 812 | (test-equal-anon (sin (* 5/3 pi)) (alge " -sqrt(3)/2 ")) 813 | (test-equal-anon (sin (* 7/3 pi)) (alge " sqrt(3)/2 ")) 814 | 815 | (test-equal-anon (sin (* -3/4 pi)) (alge " -1/sqrt(2) ")) 816 | (test-equal-anon (sin (* -1/4 pi)) (alge " -1/sqrt(2) ")) 817 | (test-equal-anon (sin (* 1/4 pi)) (alge " 1/sqrt(2) ")) 818 | (test-equal-anon (sin (* 3/4 pi)) (alge " 1/sqrt(2) ")) 819 | (test-equal-anon (sin (* 5/4 pi)) (alge " -1/sqrt(2) ")) 820 | (test-equal-anon (sin (* 7/4 pi)) (alge " -1/sqrt(2) ")) 821 | (test-equal-anon (sin (* 9/4 pi)) (alge " 1/sqrt(2) ")) 822 | (test-equal-anon (sin (* 11/4 pi)) (alge " 1/sqrt(2) ")) 823 | 824 | (test-equal (sin (* -5/6 pi)) (alge " -1/2 ")) 825 | (test-equal (sin (* -1/6 pi)) (alge " -1/2 ")) 826 | (test-equal (sin (* 1/6 pi)) (alge " 1/2 ")) 827 | (test-equal (sin (* 5/6 pi)) (alge " 1/2 ")) 828 | (test-equal (sin (* 7/6 pi)) (alge " -1/2 ")) 829 | (test-equal (sin (* 11/6 pi)) (alge " -1/2 ")) 830 | (test-equal (sin (* 13/6 pi)) (alge " 1/2 ")) 831 | (test-equal (sin (* 17/6 pi)) (alge " 1/2 ")) 832 | 833 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 834 | ;; sin( a/b * pi ) where a/b > 1/2 (i.e. not in first quadrant) 835 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 836 | 837 | (test-equal (sin (* 15/7 pi)) (sin (* 1/7 pi))) 838 | 839 | (test-equal (sin (* 8/7 pi)) (- (sin (* 1/7 pi)))) 840 | 841 | (test-equal (sin (* 4/7 pi)) (sin (* 3/7 pi))) 842 | 843 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 844 | ;; sin( a + b + ... + n * pi ) where abs(n) >= 2 845 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 846 | 847 | (test-equal (sin (+ x (* -3 pi))) (sin (+ pi x)) ) 848 | 849 | (test-equal (sin (+ x (* -2 pi))) (sin x) ) 850 | 851 | (test-equal (sin (+ x (* 2 pi))) (sin x) ) 852 | 853 | (test-equal (sin (+ x (* 3 pi))) (sin (+ x pi)) ) 854 | 855 | (test-equal (sin (+ x (* 7/2 pi))) (sin (+ x (* 3/2 pi)))) 856 | 857 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 858 | ;; sin( a + b + ... + n/2 * pi ) 859 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 860 | 861 | (test-equal (sin (+ x (* -3/2 pi))) (cos x) ) 862 | (test-equal (sin (+ x (* -1/2 pi))) (* -1 (cos x)) ) 863 | (test-equal (sin (+ x (* 1/2 pi))) (cos x) ) 864 | (test-equal (sin (+ x (* 3/2 pi))) (* -1 (cos x)) ) 865 | 866 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 867 | ;; cos 868 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 869 | 870 | (test-equal (cos 0) 1) 871 | 872 | (test-equal (cos pi) -1) 873 | 874 | (test-equal (cos -5) (cos 5)) 875 | 876 | (test-equal (cos (- x)) (cos x)) 877 | 878 | (test-equal (cos (* -5 x)) (cos (* 5 x))) 879 | 880 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 881 | ;; cos( a/b * pi ) where a/b > 1/2 (i.e. not in first quadrant) 882 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 883 | 884 | (test-equal (cos (* 15/7 pi)) (cos (* 1/7 pi))) 885 | 886 | (test-equal (cos (* 8/7 pi)) (- (cos (* 1/7 pi)))) 887 | 888 | (test-equal (cos (* 4/7 pi)) (- (cos (* 3/7 pi)))) 889 | 890 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 891 | ;; cos( k/n * pi ) for n = 1 2 3 4 6 892 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 893 | 894 | (test-equal (cos (* -2 pi)) 1) 895 | (test-equal (cos (* -1 pi)) -1) 896 | (test-equal (cos (* 2 pi)) 1) 897 | (test-equal (cos (* 3 pi)) -1) 898 | 899 | (test-equal (cos (* -7/2 pi)) 0) 900 | (test-equal (cos (* -5/2 pi)) 0) 901 | (test-equal (cos (* -3/2 pi)) 0) 902 | (test-equal (cos (* -1/2 pi)) 0) 903 | (test-equal (cos (* 1/2 pi)) 0) 904 | (test-equal (cos (* 3/2 pi)) 0) 905 | (test-equal (cos (* 5/2 pi)) 0) 906 | (test-equal (cos (* 7/2 pi)) 0) 907 | 908 | (test-equal (cos (* -4/3 pi)) -1/2) 909 | (test-equal (cos (* -2/3 pi)) -1/2) 910 | (test-equal (cos (* -1/3 pi)) 1/2) 911 | (test-equal (cos (* 1/3 pi)) 1/2) 912 | (test-equal (cos (* 2/3 pi)) -1/2) 913 | (test-equal (cos (* 4/3 pi)) -1/2) 914 | (test-equal (cos (* 5/3 pi)) 1/2) 915 | (test-equal (cos (* 7/3 pi)) 1/2) 916 | 917 | (test-equal-anon (cos (* -3/4 pi)) (alge " -1/sqrt(2) ")) 918 | (test-equal-anon (cos (* -1/4 pi)) (alge " 1/sqrt(2) ")) 919 | (test-equal-anon (cos (* 1/4 pi)) (alge " 1/sqrt(2) ")) 920 | (test-equal-anon (cos (* 3/4 pi)) (alge " -1/sqrt(2) ")) 921 | (test-equal-anon (cos (* 5/4 pi)) (alge " -1/sqrt(2) ")) 922 | (test-equal-anon (cos (* 7/4 pi)) (alge " 1/sqrt(2) ")) 923 | (test-equal-anon (cos (* 9/4 pi)) (alge " 1/sqrt(2) ")) 924 | (test-equal-anon (cos (* 11/4 pi)) (alge " -1/sqrt(2) ")) 925 | 926 | (test-equal-anon (cos (* -5/6 pi)) (alge " -sqrt(3)/2 ")) 927 | (test-equal-anon (cos (* -1/6 pi)) (alge " sqrt(3)/2 ")) 928 | (test-equal-anon (cos (* 1/6 pi)) (alge " sqrt(3)/2 ")) 929 | (test-equal-anon (cos (* 5/6 pi)) (alge " -sqrt(3)/2 ")) 930 | (test-equal-anon (cos (* 7/6 pi)) (alge " -sqrt(3)/2 ")) 931 | (test-equal-anon (cos (* 11/6 pi)) (alge " sqrt(3)/2 ")) 932 | (test-equal-anon (cos (* 13/6 pi)) (alge " sqrt(3)/2 ")) 933 | (test-equal-anon (cos (* 17/6 pi)) (alge " -sqrt(3)/2 ")) 934 | 935 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 936 | ;; cos( a + b + ... + n * pi ) where abs(n) >= 2 937 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 938 | 939 | (test-equal (cos (+ x (* -3 pi))) (cos (+ pi x)) ) 940 | 941 | (test-equal (cos (+ x (* -2 pi))) (cos x) ) 942 | 943 | (test-equal (cos (+ x (* 2 pi))) (cos x) ) 944 | 945 | (test-equal (cos (+ x (* 3 pi))) (cos (+ x pi)) ) 946 | 947 | (test-equal (cos (+ x (* 7/2 pi))) (cos (+ x (* 3/2 pi)))) 948 | 949 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 950 | ;; cos( a + b + ... + n/2 * pi ) 951 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 952 | 953 | (test-equal (cos (+ x (* -3/2 pi))) (* -1 (sin x)) ) 954 | (test-equal (cos (+ x (* -1/2 pi))) (sin x) ) 955 | (test-equal (cos (+ x (* 1/2 pi))) (* -1 (sin x)) ) 956 | (test-equal (cos (+ x (* 3/2 pi))) (sin x) ) 957 | 958 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 959 | ;; trig-substitute 960 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 961 | 962 | (test-equal (trig-substitute '(tan x)) 963 | (/ (sin x) (cos x))) 964 | 965 | (test-equal (trig-substitute '(cot x)) 966 | (/ (cos x) (sin x))) 967 | 968 | (test-equal (trig-substitute '(sec x)) 969 | (/ 1 (cos x))) 970 | 971 | (test-equal (trig-substitute '(csc x)) 972 | (/ 1 (sin x))) 973 | 974 | (test-equal (trig-substitute x) x) 975 | 976 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 977 | ;; simplify-trig 978 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 979 | 980 | (test-equal 981 | 982 | "EA: Example 7.15 - simplify-trig" 983 | 984 | (simplify-trig 985 | (alge 986 | " ( cos(x) + sin(x) )^4 + ( cos(x) - sin(x) )^4 + cos(4*x) - 3 ")) 987 | 988 | 0) 989 | 990 | (test-equal "EA: Example 7.16 - simplify-trig" 991 | 992 | (simplify-trig 993 | (alge 994 | " sin(x) + sin(y) - 2 * sin(x/2 + y/2) * cos(x/2 - y/2) ")) 995 | 996 | 0) 997 | 998 | (test-equal "EA: Example 7.17" 999 | 1000 | (simplify-trig 1001 | (alge " sin(x)^3 + cos(x+pi/6)^3 - sin(x+pi/3)^3 + 3*sin(3*x)/4 ")) 1002 | 1003 | 0) 1004 | 1005 | (test-equal "EA: Example 7.18" 1006 | 1007 | (simplify-trig 1008 | (- (/ (alge " sin(x) + sin(3*x) + sin(5*x) + sin(7*x) ") 1009 | (alge " cos(x) + cos(3*x) + cos(5*x) + cos(7*x) ")) 1010 | '(tan (* 4 x)))) 1011 | 1012 | 0) 1013 | 1014 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1015 | ;; derivative 1016 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1017 | 1018 | (test-equal "Mendelson: 8.1" (derivative (alge "2x-7") x) 2) 1019 | 1020 | (test-equal "Mendelson: 8.3" 1021 | 1022 | (derivative (alge "2*x^2 - 3*x + 5") x) 1023 | 1024 | (alge "4*x - 3")) 1025 | 1026 | (test-equal "Mendelson: 8.4" 1027 | 1028 | (derivative (alge " x^3 ") x) 1029 | 1030 | (alge " 3*x^2 ")) 1031 | 1032 | (test-equal "Mendelson: 8.6" 1033 | 1034 | (derivative (alge " 7*x^5 - 3*x^4 + 6*x^2 + 3*x + 4 ") x) 1035 | 1036 | (alge " 35*x^4 - 12*x^3 + 12*x + 3 ")) 1037 | 1038 | (test-equal "Mendelson: 8.8" 1039 | 1040 | (derivative 1041 | (alge " (5*x^3 - 20*x + 13) * (4*x^6 + 2*x^5 - 7*x^2 + 2*x ") 1042 | x) 1043 | 1044 | (alge 1045 | (string-append " (5*x^3 - 20*x + 13) * (24*x^5 + 10*x^4 - 14*x + 2) " 1046 | " + " 1047 | " (4*x^6 + 2*x^5 - 7*x^2 + 2*x) * (15*x^2 - 20) "))) 1048 | 1049 | (test-equal "Mendelson: 8.9" 1050 | 1051 | (derivative (alge " (3*x - 2) / (x^2 + 7) ") x) 1052 | 1053 | (alge " (-2*x*(-2 + 3*x))/(7 + x^2)^2 + 3/(7 + x^2) ")) 1054 | 1055 | (test-equal "Mendelson: 8.10" 1056 | 1057 | (derivative (alge " (3*x - 2) / (2*x + 5) ") x) 1058 | 1059 | (alge " 3 / (5 + 2*x) - 2*(-2 + 3*x)/(5 + 2*x)^2 ")) 1060 | 1061 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1062 | ;; polynomial-division 1063 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1064 | 1065 | (test-equal "MM: Example 4.4" 1066 | 1067 | (polynomial-division (alge " 5*x^2 + 4*x + 1 ") 1068 | (alge " 2*x + 3 ") 1069 | x) 1070 | 1071 | (list (alge " 5/2*x - 7/4 ") 1072 | (alge " 25/4 "))) 1073 | 1074 | (test-equal "MM: page 117" 1075 | 1076 | (polynomial-division (alge " (2+4i)*x^2 + (-1-8i)*x + (-3+3i) ") 1077 | (alge " (1+2i)*x + (1-1i) ") 1078 | x) 1079 | 1080 | (list (alge " 2*x-3 ") 1081 | 0)) 1082 | 1083 | (test-equal "MM: Example 4.10" 1084 | 1085 | (polynomial-division (alge " x^2 - 4 ") 1086 | (alge " x+2 ") 1087 | x) 1088 | 1089 | (list (alge " x - 2 ") 0)) 1090 | 1091 | (test-equal "MM: Example 4.10" 1092 | 1093 | (polynomial-division (alge " x^2 + 5*x + 6 ") 1094 | (alge " x+2 ") 1095 | x) 1096 | 1097 | (list (alge " x + 3 ") 0)) 1098 | 1099 | (test-equal "MM: Example 4.43" 1100 | 1101 | (remainder (alge " 3*x^3 + x^2 - 4 ") 1102 | (alge " x^2 - 4*x + 2 ") 1103 | x) 1104 | 1105 | (alge " -30 + 46*x ")) 1106 | 1107 | (test-equal "MM: Example 4.45" 1108 | 1109 | (let () 1110 | (vars i) 1111 | (remainder (alge " 2 + 3*i + 4*i^2 + 5*i^3 + 6*i^4 ") 1112 | (alge " i^2 + 1 ") 1113 | i)) 1114 | 1115 | (alge " 4 - 2*i ")) 1116 | 1117 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1118 | ;; polynomial-expansion 1119 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1120 | 1121 | (test-equal "MM: Example 4.18" 1122 | 1123 | (polynomial-expansion 1124 | (alge " x^5 + 11*x^4 + 51*x^3 + 124*x^2 + 159*x + 86 ") 1125 | (alge " x^2 + 4*x + 5 ") 1126 | x 1127 | t) 1128 | 1129 | (alge " x*t^2 + 3*t^2 + x*t + 2*t + x + 1 ")) 1130 | 1131 | (test-equal "MM: page 123" 1132 | 1133 | (polynomial-expansion (alge " (x+1)^3 + 2*(x+1) + 4 ") 1134 | (alge " x+1 ") 1135 | x 1136 | t) 1137 | 1138 | (alge " t^3 + 2*t + 4 ")) 1139 | 1140 | (let ((u (alge " 3*x^4 + 5*x^2 + 7 "))) 1141 | 1142 | (test-equal "MM: page 124" 1143 | 1144 | (degree-gpe (polynomial-expansion u (alge " x^2 ") x t) 1145 | '(t)) 1146 | 2) 1147 | 1148 | (test-equal "MM: page 124" 1149 | 1150 | (coefficient-gpe (polynomial-expansion u (alge " x^2 ") x t) 1151 | t 1152 | 2) 1153 | 3)) 1154 | 1155 | (let () 1156 | 1157 | (vars v) 1158 | 1159 | (test-equal "MM: page 124" 1160 | 1161 | (polynomial-expansion (alge " 2*x^4 + 4*x^3 + 9*x^2 + 7*x + 9 ") 1162 | (alge " x^2 + x + 1 ") 1163 | x 1164 | v) 1165 | 1166 | (alge " 2*v^2 + 3*v + 4 "))) 1167 | 1168 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1169 | ;; polynomial-gcd 1170 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1171 | 1172 | (test-equal "MM: Example 4.20" 1173 | 1174 | (polynomial-gcd (alge " 2*x^3 + 12*x^2 + 22*x + 12 ") 1175 | (alge " 2*x^3 + 18*x^2 + 52*x + 48 ") 1176 | x) 1177 | 1178 | (alge " x^2 + 5*x + 6 ")) 1179 | 1180 | (test-equal "MM: Example 4.24" 1181 | 1182 | (polynomial-gcd (alge " x^7 - 4*x^5 - x^2 + 4 ") 1183 | (alge " x^5 - 4*x^3 - x^2 + 4 ") 1184 | x) 1185 | 1186 | (alge " x^3 - x^2 - 4*x + 4 ")) 1187 | 1188 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1189 | ;; extended-euclidean-algorithm 1190 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1191 | 1192 | (test-equal "MM: Example 4.28" 1193 | 1194 | (extended-euclidean-algorithm (alge " x^7 - 4*x^5 - x^2 + 4 ") 1195 | (alge " x^5 - 4*x^3 - x^2 + 4 ") 1196 | x) 1197 | 1198 | (list (alge " x^3 - x^2 - 4*x + 4 ") 1199 | (alge " -x ") 1200 | (alge " x^3 + 1 "))) 1201 | 1202 | (test-equal "MM: Example 4.49" 1203 | 1204 | (list-ref 1205 | (extended-euclidean-algorithm (alge " 2 + 3*a ") 1206 | (alge " a^3 - 2 ") 1207 | a) 1208 | 1) 1209 | 1210 | (alge " 2/31 - 3/31*a + 9/62*a^2 ")) 1211 | 1212 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1213 | ;; alg-polynomial-division 1214 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1215 | 1216 | (test-equal "MM: Example 4.50" 1217 | 1218 | (alg-polynomial-division (alge " 2*x^2 + a*x ") 1219 | (alge " a*x + a ") 1220 | x 1221 | (alge " a^2 - 2 ") 1222 | a) 1223 | 1224 | (list (alge " a*x + 1 - a ") 1225 | (alge " -a + 2 "))) 1226 | 1227 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1228 | ;; alg-polynomial-gcd 1229 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1230 | 1231 | (test-equal "MM: Example 4.51" 1232 | 1233 | (alg-polynomial-gcd (alge " x^2 + (-1 - a)*x ") 1234 | (alge " x^2 + (-2 - 2*a)*x + 3 + 2*a ") 1235 | x 1236 | (alge " a^2 - 2 ") 1237 | a) 1238 | 1239 | (alge " x - 1 - a ")) 1240 | 1241 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1242 | 1243 | (test-equal "MM: Example 4.67" 1244 | 1245 | (partial-fraction-1 (alge " x^2 + 2 ") 1246 | (alge " x + 2 ") 1247 | (alge " x^2 - 1 ") 1248 | x) 1249 | 1250 | (list 2 (alge " -x + 2 "))) 1251 | 1252 | ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1253 | 1254 | (test-end "mpl") 1255 | 1256 | ) 1257 | 1258 | ) 1259 | --------------------------------------------------------------------------------