1373 lines
43 KiB
Racket
1373 lines
43 KiB
Racket
#lang racket
|
|
|
|
;;; An ATOMIC EXPRESSION is an
|
|
; - number (integer, real, complex)
|
|
; - reserved symbol (pi, e, i, inf, true, false)
|
|
; - identifier
|
|
|
|
;;; A COMPOUND EXPRESSION
|
|
; - (operand expression ...)
|
|
; where operand can be
|
|
; - operators: + - * / ^ !
|
|
; - function forms
|
|
; - relational operators and expressions: = ≠ < ≤ > ≥
|
|
; - logical operations and expressions: or and not
|
|
; - 'Set
|
|
; - 'List
|
|
|
|
; Variable Initialization and assignment
|
|
; - all variables are initially undefined symbols
|
|
; - assignments :=
|
|
|
|
; Representation:
|
|
; Identifiers are represented as Racket symbols
|
|
; Numbers are represented as Racket numbers
|
|
; Operators are represented as Racket symbols
|
|
; Lists are represented as ?
|
|
; ...
|
|
|
|
; Simplified expressions
|
|
; (Plus op1 op2 op ...)
|
|
; - n-ary, n>=2
|
|
; - at most one operand is a number
|
|
; - no operands are sums
|
|
; (Times op1 op2 op ...)
|
|
; - n-ary, n>=2
|
|
; - no operands are products
|
|
; - at most one operand is a number
|
|
; - when a number is an operand, it is the first operand
|
|
; (Power a n)
|
|
; - if n is an integer,
|
|
; then a is not an integer, rational, product or power.
|
|
; Minus
|
|
; - unary and binary does not occur in simplified expressions
|
|
; - (Minus x) => (Times -1 x)
|
|
; - (Minus a b) => (Plus a (Times -1 b))
|
|
; Quotient
|
|
; - binary quotient does not appear is simplified expressions
|
|
; - (Quotient a b) => (Times a (Power b -1))
|
|
|
|
; COMPLETE SUBEXPRESSION
|
|
; Let u be an automatically simplified expression.
|
|
; A complete sub-expression of u is either the
|
|
; expression u itself or an operand of some
|
|
; operator in u.
|
|
|
|
(module number-theory racket/base
|
|
(provide binomial)
|
|
|
|
; binomial : natural natural -> natural
|
|
; compute the binomial coeffecient n choose k
|
|
(define (binomial n k)
|
|
; <http://www.swox.com/gmp/manual/Binomial-Coefficients-Algorithm.html>
|
|
; http://lavica.fesb.hr/cgi-bin/info2html?(gmp)Binomial%20Coefficients%20Algorithm
|
|
; TODO: Check range of n and k
|
|
(cond
|
|
[(= k 0) 1]
|
|
[(= k 1) n]
|
|
[(= k 2) (/ (* n (- n 1)) 2)]
|
|
[(> k (/ n 2)) (binomial n (- n k))]
|
|
[else (* (+ n (- k) 1)
|
|
(for/product ([i (in-range 2 (+ k 1))])
|
|
(/ (+ n (- k) i)
|
|
i)))])))
|
|
|
|
(module undefined racket/base
|
|
(provide undefined undefined?)
|
|
(define undefined 'undefined)
|
|
(define (undefined? e) (eq? e 'undefined)))
|
|
|
|
(module identifiers racket
|
|
(provide symbolic-id? reserved?)
|
|
(define (reserved? v)
|
|
(and (symbol? v)
|
|
(memv v '(@pi @e @i @inf))))
|
|
(define (symbolic-id? id)
|
|
(or (symbol? id)
|
|
(and (syntax? id)
|
|
(memv (syntax-e id)
|
|
'(Plus Minus Times Quotient Power =))))))
|
|
|
|
(module symbolic-application racket
|
|
(provide (rename-out [sym-app #%app]))
|
|
(require (for-syntax (submod ".." identifiers)))
|
|
|
|
(define (holdable? o)
|
|
(and (symbol? o)
|
|
(memq o '(Hold))))
|
|
|
|
; In the BRACKET language an application of
|
|
; a non-function evaluates to an expression.
|
|
(define-syntax (sym-app stx)
|
|
(syntax-case stx ()
|
|
[(_ op arg ...)
|
|
(quasisyntax/loc stx
|
|
(let ([o op])
|
|
(if (procedure? o)
|
|
#,(syntax/loc stx (#%app o arg ...))
|
|
(if (holdable? o)
|
|
(cons o '(arg ...))
|
|
(cons o (list arg ...))))))]))
|
|
|
|
; This version prevents duplication of args.
|
|
; But uses apply in place of #%app
|
|
#;(define-syntax (sym-app stx)
|
|
(syntax-case stx ()
|
|
[(_ op arg ...)
|
|
(quasisyntax/loc stx
|
|
(let ([o op]
|
|
[as (λ () (list arg ...))])
|
|
; TODO: 1. If o is Flat, then flattened nested expression with o.
|
|
; TODO: 2. If o is Listable, then ...
|
|
; TODO: 3. If o is Orderless then ...
|
|
; TODO: 4. If o has associated rules ...
|
|
; TODO:
|
|
; REF: http://reference.wolfram.com/mathematica/tutorial/Evaluation.html
|
|
(if (procedure? o)
|
|
#,(syntax/loc stx (apply o (as)))
|
|
(if (holdable? o)
|
|
(cons o '(arg ...))
|
|
(cons o (as))))))])))
|
|
|
|
(module expression-core racket
|
|
(require (submod ".." identifiers)
|
|
(submod ".." undefined))
|
|
(provide atomic-expression?
|
|
compound-expression?
|
|
list-expression?
|
|
set-expression?
|
|
power-expression?
|
|
times-expression?
|
|
plus-expression?
|
|
base exponent
|
|
term const
|
|
construct
|
|
kind
|
|
operator
|
|
operands
|
|
number-of-operands
|
|
operand last-operand
|
|
free-of
|
|
complete-sub-expressions)
|
|
(define (atomic-expression? v)
|
|
(or (number? v)
|
|
(reserved? v)
|
|
(symbolic-id? v)
|
|
(boolean? v)))
|
|
|
|
(define (set-expression? v)
|
|
(and (list? v) (eq? (first v) 'Set)))
|
|
(define (list-expression? v)
|
|
(and (list? v) (not (empty? v)) (eq? (first v) 'List)))
|
|
(define (power-expression? v)
|
|
(and (list? v) (eq? (first v) 'Power)))
|
|
(define (times-expression? v)
|
|
(and (list? v) (eq? (first v) 'Times)))
|
|
(define (plus-expression? v)
|
|
(and (list? v) (eq? (first v) 'Plus)))
|
|
|
|
(define (base u)
|
|
(cond
|
|
[(number? u) undefined]
|
|
[(power-expression? u) (operand u 0)]
|
|
[else u]))
|
|
|
|
(define (exponent u)
|
|
(cond
|
|
[(number? u) undefined]
|
|
[(power-expression? u) (operand u 1)]
|
|
[else 1]))
|
|
|
|
(define (term u)
|
|
(cond
|
|
[(number? u) undefined]
|
|
[(and (times-expression? u)
|
|
(number? (operand u 0)))
|
|
(let ([v (rest (operands u))])
|
|
(if (empty? (rest v))
|
|
(first v)
|
|
(construct 'Times v)))]
|
|
[else u]))
|
|
|
|
(define (const u)
|
|
(cond
|
|
[(number? u) undefined]
|
|
[(times-expression? u)
|
|
(define u1 (operand u 0))
|
|
(if (number? u1) u1 1)]
|
|
[else 1]))
|
|
|
|
(define recent-compound-expressions (make-weak-hasheq))
|
|
(define (compound-expression? e)
|
|
(or (hash-has-key? recent-compound-expressions e)
|
|
(let ([compound? (list? e)]) ; TODO: Improve check
|
|
(when compound?
|
|
(hash-set! recent-compound-expressions e #t))
|
|
compound?)))
|
|
|
|
(define (construct operator operands)
|
|
(cons operator operands))
|
|
|
|
(define (operator e)
|
|
(and (list? e) (first e)))
|
|
(define (operands e)
|
|
; Old defi: (and (list? e) (rest e))
|
|
(if (list? e) (rest e) '()))
|
|
(define (number-of-operands e)
|
|
(if (list? e)
|
|
(length (rest e))
|
|
undefined))
|
|
(define (operand u i)
|
|
(if (compound-expression? u)
|
|
(list-ref (rest u) i)
|
|
undefined))
|
|
(define (last-operand u)
|
|
(operand u (- (number-of-operands u) 1)))
|
|
(define (kind u)
|
|
(cond
|
|
[(number? u)
|
|
(cond [(integer? u) 'integer]
|
|
[(and (exact? u) (rational? u)) 'rational]
|
|
[(rational? u) 'real]
|
|
[(complex? u) 'complex]
|
|
[else (error 'kind "Internal error: A number type is missing: " u)])]
|
|
[(reserved? u) 'reserved]
|
|
[(symbolic-id? u) 'symbolic-id]
|
|
[(list? u) (operator u)]
|
|
[else (error 'kind "Internal error: Unhandled simplified expression type: " u)]))
|
|
|
|
(define (complete-sub-expressions u)
|
|
; return a list of all complete sub-expressions of u
|
|
(if (atomic-expression? u)
|
|
(list u)
|
|
(cons u
|
|
(append-map complete-sub-expressions
|
|
(operands u)))))
|
|
|
|
(define (free-of u t)
|
|
; is t identical to a complete subexpression of u,
|
|
; if so return #f otherwise #t
|
|
(cond
|
|
[(equal? u t) #f]
|
|
[(atomic-expression? u) #t]
|
|
[else (andmap (curryr free-of t)
|
|
(operands u))])))
|
|
|
|
(module simplify racket
|
|
(require (submod ".." expression-core)
|
|
(submod ".." undefined)
|
|
(submod ".." identifiers))
|
|
(require (planet dherman/memoize:3:1))
|
|
|
|
(provide simplify
|
|
simplify-plus
|
|
simplify-minus
|
|
simplify-times
|
|
simplify-quotient
|
|
simplify-power
|
|
before?)
|
|
|
|
(define (simplify e)
|
|
(cond
|
|
[(atomic-expression? e)
|
|
e]
|
|
[(compound-expression? e)
|
|
(let ([op (simplify (operator e))]
|
|
[us (map simplify (operands e))])
|
|
(case op
|
|
[(Plus) (simplify-plus us)]
|
|
[(Times) (simplify-times us)]
|
|
[(Power) (simplify-power us)]
|
|
[(Minus) (simplify-minus us)]
|
|
[(Quotient) (simplify-quotient us)]
|
|
[else (construct op us)]))]
|
|
[else
|
|
(error 'simplify "received non-expression, in: " e)]))
|
|
|
|
(define (original-if-equal original new)
|
|
(if (equal? original new)
|
|
original
|
|
new))
|
|
|
|
(define (flatten-operator operator ops)
|
|
; Example (f (f x1 x2) x3 (f x4)) -> (f x1 x2 x3 x4)
|
|
(define (loop ops flattened)
|
|
(cond
|
|
[(empty? ops)
|
|
(original-if-equal (reverse flattened) ops)]
|
|
[(eq? (kind (first ops)) operator)
|
|
(loop (rest ops)
|
|
(append (operands (first ops)) flattened))]
|
|
[else
|
|
(loop (rest ops) (cons (first ops) flattened))]))
|
|
(loop ops '()))
|
|
|
|
(define (simplify-plus ops)
|
|
; (Plus op1 op2 op ...)
|
|
; - n-ary, n>=2
|
|
; - at most one operand is a number
|
|
; - no operands are sums
|
|
; - when an operand is a number, it is the first operand
|
|
(cond
|
|
[(ormap undefined? ops) undefined]
|
|
[else
|
|
(define n (length ops))
|
|
(case n
|
|
[(0) 0]
|
|
[(1) (first ops)]
|
|
[else
|
|
(define vs (simplify-plus-rec ops))
|
|
(if (list-expression? vs)
|
|
vs
|
|
(case (length vs)
|
|
[(1) (first vs)]
|
|
[(0) 0]
|
|
[else (construct 'Plus vs)]))])]))
|
|
|
|
(define (simplify-plus-rec us)
|
|
; a list of terms is received,
|
|
; a list of simplified terms is returned.
|
|
(define n (length us)) ; n>=2
|
|
(define u1 (first us))
|
|
(define u2 (second us))
|
|
(cond
|
|
[(and (= n 2)
|
|
(not (plus-expression? u1))
|
|
(not (plus-expression? u2)))
|
|
(cond
|
|
[(and (number? u1) (number? u2))
|
|
(let ([s (+ u1 u2)])
|
|
(if (equal? s 0) '() (list s)))]
|
|
[(equal? u1 0) (list u2)]
|
|
[(equal? u2 0) (list u1)]
|
|
[(equal? (term u1) (term u2))
|
|
(define c (simplify-plus (list (const u1) (const u2))))
|
|
(define t (simplify-times (list c (term u1))))
|
|
(if (equal? t 0) '() (list t))]
|
|
[(and (list-expression? u1) (list-expression? u2)
|
|
(= (length u1) (length u2)))
|
|
(construct
|
|
'List (append-map (λ (u1i u2i) (simplify-plus-rec (list u1i u2i)))
|
|
(operands u1) (operands u2)))]
|
|
[(and (list-expression? u1) (list-expression? u2))
|
|
; lists of different lengths => do nothing
|
|
(list u1 u2)]
|
|
[(list-expression? u1)
|
|
(construct
|
|
'List
|
|
(map (λ (u1i)
|
|
(let ([us (simplify-plus-rec (cons u2 (list u1i)))])
|
|
; If length(us)>=2 wrap with Plus
|
|
(if (empty? (rest us))
|
|
(first us)
|
|
(construct 'Plus us))))
|
|
(operands u1)))]
|
|
[(list-expression? u2)
|
|
(construct
|
|
'List
|
|
(map
|
|
(λ (u2i)
|
|
(let ([us (simplify-plus-rec (cons u1 (list u2i)))])
|
|
; If length(us)>=2 wrap with Plus
|
|
(if (empty? (rest us))
|
|
(first us)
|
|
(construct 'Plus us))))
|
|
(operands u2)))]
|
|
[(before? u2 u1) (list u2 u1)]
|
|
[else (list u1 u2)])]
|
|
[(= n 2)
|
|
; at least one of u1 or u2 is a sum
|
|
(cond
|
|
[(and (plus-expression? u1) (plus-expression? u2))
|
|
(merge-sums (operands u1) (operands u2))]
|
|
[(plus-expression? u1)
|
|
(merge-sums (operands u1) (list u2))]
|
|
[(plus-expression? u2)
|
|
(merge-sums (list u1) (operands u2))]
|
|
[else (error)])]
|
|
[else
|
|
(define w (simplify-plus-rec (rest us)))
|
|
(if (plus-expression? u1)
|
|
(merge-sums (operands u1) w)
|
|
(merge-sums (list u1) w))]))
|
|
|
|
(define (merge-sums p q)
|
|
; receives two lists of terms
|
|
(cond
|
|
[(empty? p) q]
|
|
[(empty? q) p]
|
|
[else
|
|
(define p1 (first p))
|
|
(define q1 (first q))
|
|
(define h (simplify-plus-rec (list p1 q1)))
|
|
(case (length h)
|
|
[(0) (merge-sums (rest p) (rest q))]
|
|
[(1) (cons (first h) (merge-sums (rest p) (rest q)))]
|
|
[(2) (if (equal? (first h) q1)
|
|
(cons q1 (merge-sums p (rest q)))
|
|
(cons p1 (merge-sums (rest p) q)))]
|
|
[else (error)])]))
|
|
|
|
(define/memo (simplify-times ops)
|
|
;(displayln (list 'simplify-times ops))
|
|
; the operands os are simplified
|
|
; (Times op1 op2 op ...)
|
|
; - n-ary, n>=2
|
|
; - no operands are products
|
|
; - at most one operand is a number
|
|
; - when a number is an operand, it is the first operand
|
|
;(define os (flatten-operator 'Times ops))
|
|
;(define-values (ns es) (partition number? os))
|
|
;(define n (apply * ns))
|
|
(cond
|
|
[(ormap undefined? ops) undefined]
|
|
[(ormap (λ (u) (and (number? u) (zero? u))) ops) 0]
|
|
[else
|
|
(define n (length ops))
|
|
(case n
|
|
[(0) 1]
|
|
[(1) (first ops)]
|
|
[else
|
|
(define vs (simplify-times-rec ops))
|
|
(if (list-expression? vs)
|
|
vs
|
|
(case (length vs)
|
|
[(1) (first vs)]
|
|
[(0) 1]
|
|
[else (construct 'Times vs)]))])]))
|
|
|
|
(define (simplify-times-rec us)
|
|
; a list of factors are received,
|
|
; a list of simplified factors are returned.
|
|
(define n (length us)) ; n>=2
|
|
(define u1 (first us))
|
|
(define u2 (second us))
|
|
(cond
|
|
[(and (= n 2)
|
|
(not (times-expression? u1))
|
|
(not (times-expression? u2)))
|
|
(cond
|
|
[(and (number? u1) (number? u2))
|
|
(let ([p (* u1 u2)])
|
|
(if (equal? p 1) '() (list p)))]
|
|
[(equal? u1 1) (list u2)]
|
|
[(equal? u2 1) (list u1)]
|
|
[(and (list-expression? u1) (list-expression? u2)
|
|
(= (length u1) (length u2)))
|
|
(construct
|
|
'List (append-map (λ (u1i u2i) (simplify-times-rec (list u1i u2i)))
|
|
(operands u1) (operands u2)))]
|
|
[(and (list-expression? u1) (list-expression? u2))
|
|
; lists of different lengths => do nothing
|
|
(list u1 u2)]
|
|
[(list-expression? u1)
|
|
(construct
|
|
'List
|
|
(map (λ (u1i)
|
|
(construct 'Times
|
|
(simplify-times-rec (cons u2 (list u1i)))))
|
|
(operands u1)))]
|
|
[(list-expression? u2)
|
|
(construct
|
|
'List
|
|
(map (λ (u2i)
|
|
(construct 'Times
|
|
(simplify-times-rec (cons u1 (list u2i)))))
|
|
(operands u2)))]
|
|
[(equal? (base u1) (base u2))
|
|
(define s (simplify-plus (list (exponent u1) (exponent u2))))
|
|
(define p (simplify-power (list (base u1) s)))
|
|
(if (equal? p 1) '() (list p))]
|
|
[(before? u2 u1) (list u2 u1)]
|
|
[else (list u1 u2)])]
|
|
[(= n 2)
|
|
; at least one of u1 or u2 is a product
|
|
(cond
|
|
[(and (times-expression? u1) (times-expression? u2))
|
|
(merge-products (operands u1) (operands u2))]
|
|
[(times-expression? u1)
|
|
(merge-products (operands u1) (list u2))]
|
|
[(times-expression? u2)
|
|
(merge-products (list u1) (operands u2))]
|
|
[else (error)])]
|
|
[else
|
|
(define w (simplify-times-rec (rest us)))
|
|
(if (times-expression? u1)
|
|
(merge-products (operands u1) w)
|
|
(merge-products (list u1) w))]))
|
|
|
|
(define (merge-products p q)
|
|
; receives two lists of factors
|
|
(cond
|
|
[(empty? p) q]
|
|
[(empty? q) p]
|
|
[else
|
|
(define p1 (first p))
|
|
(define q1 (first q))
|
|
(define h (simplify-times-rec (list p1 q1)))
|
|
(if (list-expression? h)
|
|
(simplify-times-rec (cons h (append (merge-products (rest p) (rest q)))))
|
|
(case (length h)
|
|
[(0) (merge-products (rest p) (rest q))]
|
|
[(1) (let ([m (merge-products (rest p) (rest q))])
|
|
(if (list-expression? m)
|
|
(simplify-times-rec (cons (first h) m))
|
|
(cons (first h) m)))]
|
|
[(2) (if (equal? (first h) q1)
|
|
(let ([m (merge-products p (rest q))])
|
|
(if (list-expression? m)
|
|
(simplify-times-rec (cons q1 m))
|
|
(cons q1 m)))
|
|
(let ([m (merge-products (rest p) q)])
|
|
(if (list-expression? m)
|
|
(simplify-times-rec (cons q1 m))
|
|
(cons p1 m))))]
|
|
[else (error 'merge-products (format "got ~a and ~a" p q))]))]))
|
|
|
|
(define (before? u v)
|
|
;(display (list 'before? u v))
|
|
; This an order relation between expressions.
|
|
; See [Cohen] for the complete algorithm and explanation.
|
|
(define result
|
|
(cond
|
|
[(and (number? u) (number? v))
|
|
; straightforward for two real numbers,
|
|
; but complex numbers must be handled too.
|
|
(if (= u v)
|
|
#t
|
|
(if (real? u)
|
|
(if (real? v) (< u v) v)
|
|
(if (real? v)
|
|
v
|
|
(if (= (imag-part u) (imag-part v))
|
|
(< (real-part u) (real-part v))
|
|
(< (imag-part u) (imag-part v))))))]
|
|
; Number always come first
|
|
[(number? u) #t]
|
|
[(number? v) #f]
|
|
; Symbols are sorted in alphabetical order
|
|
[(and (symbol? u) (symbol? v))
|
|
(string<? (symbol->string u) (symbol->string v))]
|
|
; For products and sums order on the last different
|
|
; factor or term. Thus x+y < y+z.
|
|
[(or (and (times-expression? u) (times-expression? v))
|
|
(and (plus-expression? u) (plus-expression? v)))
|
|
(define first-non-equal
|
|
(for/first ([ui (in-list (reverse (operands u)))]
|
|
[vi (in-list (reverse (operands v)))]
|
|
#:unless (equal? ui vi))
|
|
(list ui vi)))
|
|
(if first-non-equal
|
|
(apply before? first-non-equal)
|
|
(< (length (operands u)) (length (operands v))))]
|
|
; When comparing a product with something else, use the last factor.
|
|
; Thus x*y < z and y < x*z.
|
|
; Note: This is consistent with comparisons of two products since
|
|
; x*y < 1*z and 1*y < x*z.
|
|
[(and (times-expression? u)
|
|
(or ;(power-expression? v)
|
|
;(plus-expression? v)
|
|
(symbolic-id? v)
|
|
(compound-expression? v)))
|
|
(let ([un (last-operand u)])
|
|
(or (equal? un v) (before? un v)))]
|
|
[(and (times-expression? v)
|
|
(or ;(power-expression? v)
|
|
;(plus-expression? v)
|
|
(symbolic-id? u)
|
|
(compound-expression? u)))
|
|
(define vn (last-operand v))
|
|
(or (equal? vn u) (before? u vn))]
|
|
; Powers with smallest base are first. 2^z < 3^y
|
|
[(and (power-expression? u) (power-expression? v))
|
|
(if (equal? (base u) (base v))
|
|
(before? (exponent u) (exponent v))
|
|
(before? (base u) (base v)))]
|
|
; When comparing a product with something else, pretend
|
|
; the else part is a power with exponent 1.
|
|
; Thus x^2 > x.
|
|
[(and (power-expression? u)
|
|
(or ; (plus-expression? v)
|
|
(symbolic-id? v)
|
|
(compound-expression? v)))
|
|
(before? u (construct 'Power (list v 1)))]
|
|
[(and (power-expression? v)
|
|
(or ; (plus-expression? v)
|
|
(symbolic-id? u)
|
|
(compound-expression? u)))
|
|
(before? (construct 'Power (list u 1)) v)]
|
|
; Same trick with sums. Thus x+(-1) < x (+0)
|
|
[(and (plus-expression? u)
|
|
(or (symbolic-id? v)
|
|
(compound-expression? v)))
|
|
(before? u (construct 'Plus (list v)))]
|
|
[(and (plus-expression? v)
|
|
(or (symbolic-id? u)
|
|
(compound-expression? u)))
|
|
(before? (construct 'Plus (list u)) v)]
|
|
; Here only function applications are left.
|
|
; Sort after name.
|
|
[(and (compound-expression? u) (compound-expression? v))
|
|
(if (not (equal? (kind u) (kind v)))
|
|
(before? (kind u) (kind v))
|
|
(let ()
|
|
; If the names are equal, sort after the first
|
|
; non-equal operand.
|
|
(define first-non-equal
|
|
(for/first ([ui (in-list (operands u))]
|
|
[vi (in-list (operands v))]
|
|
#:unless (equal? ui vi))
|
|
(list ui vi)))
|
|
(if first-non-equal
|
|
(apply before? first-non-equal)
|
|
(< (length (operands u)) (length (operands v))))))]
|
|
[(compound-expression? u)
|
|
#f]
|
|
[(compound-expression? v)
|
|
#t]
|
|
[else
|
|
(error 'before? "Internal error: A case is missing, got ~a and ~a" u v)]
|
|
; TODO : This isn't done
|
|
; some rules are missing ... functions????
|
|
))
|
|
;(displayln (format " => ~a" result))
|
|
result
|
|
)
|
|
|
|
|
|
|
|
(define (simplify-minus ops)
|
|
; - unary and binary does not occur in simplified expressions
|
|
; - (Minus x) => (Times -1 x)
|
|
; - (Minus a b) => (Plus a (Times -1 b))
|
|
(case (length ops)
|
|
[(1) (simplify-times (list -1 (first ops)))]
|
|
[(2) (simplify-plus
|
|
(list (first ops)
|
|
(simplify-times (list -1 (second ops)))))]
|
|
[else undefined]))
|
|
|
|
(define (simplify-power ops)
|
|
(case (length ops)
|
|
[(2)
|
|
(let ([v (first ops)]
|
|
[w (second ops)])
|
|
(cond
|
|
[(undefined? v) undefined]
|
|
[(undefined? w) undefined]
|
|
[(and (equal? v 0) (number? w) (positive? w)) 0]
|
|
[(equal? v 0) undefined]
|
|
[(equal? v 1) 1]
|
|
[(list-expression? v)
|
|
(construct
|
|
'List (map (λ (vi) (simplify-power (list vi w)))
|
|
(operands v)))]
|
|
[(integer? w) (simplify-integer-power v w)]
|
|
|
|
[else (construct 'Power (list v w))]))]
|
|
[else undefined]))
|
|
|
|
(define (simplify-integer-power v n)
|
|
; n integer, v≠0
|
|
(cond
|
|
[(number? v) (expt v n)]
|
|
[(= n 0) 1]
|
|
[(= n 1) v]
|
|
[(power-expression? v)
|
|
(let* (; w = r^s
|
|
[r (operand v 0)]
|
|
[s (operand v 1)]
|
|
[p (simplify-times (list s n))])
|
|
(if (integer? p)
|
|
(simplify-integer-power r p)
|
|
(construct 'Power (list r p))))]
|
|
[(times-expression? v)
|
|
(simplify-times
|
|
(map (λ (f) (simplify-power (list f n)))
|
|
(operands v)))]
|
|
[else (construct 'Power (list v n))]))
|
|
|
|
(define (simplify-quotient ops)
|
|
; - binary quotient does not appear is simplified expressions
|
|
; - (Quotient a b) => (Times a (Power b -1))
|
|
(case (length ops)
|
|
[(1) (simplify-power (list (first ops) -1))]
|
|
[(2) (simplify-times
|
|
(list (first ops)
|
|
(simplify-power (list (second ops) -1))))]
|
|
[else undefined])))
|
|
|
|
(module expression racket
|
|
(require (submod ".." expression-core)
|
|
(submod ".." simplify))
|
|
(provide (all-from-out (submod ".." expression-core))
|
|
(all-from-out (submod ".." simplify))
|
|
substitute
|
|
sequential-substitute
|
|
concurrent-substitute)
|
|
|
|
(define (substitute u t r)
|
|
; return new expression where each occurrence
|
|
; of the target expression t in u is replaced
|
|
; with the replacement r. The substituion takes
|
|
; place whenever t is structurally identical to
|
|
; a complete sub-expression of u.
|
|
(cond
|
|
[(equal? u t) r]
|
|
[(atomic-expression? u) u]
|
|
[else
|
|
(simplify
|
|
(construct
|
|
(kind u)
|
|
(map (λ (ui) (substitute ui t r))
|
|
(operands u))))]))
|
|
|
|
(define (sequential-substitute u ts rs)
|
|
(if (empty? ts)
|
|
u
|
|
(sequential-substitute
|
|
(substitute u (first ts) (first rs))
|
|
(rest ts) (rest rs))))
|
|
|
|
(define (concurrent-substitute u ts rs)
|
|
(cond
|
|
[(empty? ts) u]
|
|
[(for/first ([t ts]
|
|
[r rs]
|
|
#:when (equal? u t))
|
|
r) => values]
|
|
[(atomic-expression? u) u]
|
|
[else
|
|
(simplify
|
|
(construct
|
|
(kind u)
|
|
(map (λ (ui) (concurrent-substitute ui ts rs))
|
|
(operands u))))])))
|
|
|
|
|
|
|
|
#;(module pattern-matching racket
|
|
(require (submod ".." expression))
|
|
(define (linear-form u x)
|
|
; u expression, x a symbol
|
|
(if (eq? u x)
|
|
(list 1 0)
|
|
(case (kind u)
|
|
[(symbol-id integer fraction real complex)
|
|
(list 0 u)]
|
|
[(Times)
|
|
(if (free-of u x)
|
|
(list 0 u)
|
|
(let ([u/x (Quotient u x)])
|
|
(if (Free-of u/x x)
|
|
(list u/x 0)
|
|
#f)))]
|
|
[(Plus)
|
|
(let ([f (linear-form (operand u 1) x)])
|
|
(and f
|
|
(let ([r (linear-form (Minus u (operand u 1)))])
|
|
(and r
|
|
(list (+ (operand f 0) (operand r 0))
|
|
(+ (operand f 1) (operand r 1)))))))]
|
|
[else
|
|
(and (free-of u x)
|
|
(list 0 u))]))))
|
|
|
|
(module equation-expression racket
|
|
(require (submod ".." expression))
|
|
(provide equations->sides
|
|
equation->sides)
|
|
|
|
(define (equation->sides t=r)
|
|
(values (operand t=r 0) (operand t=r 1)))
|
|
|
|
(define (equations->sides t=r-List)
|
|
(values (map (curryr operand 0) (operands t=r-List))
|
|
(map (curryr operand 1) (operands t=r-List)))))
|
|
|
|
(module mpl-graphics racket
|
|
(require "../graphics.rkt")
|
|
|
|
(define-syntax (declare/provide-vars stx)
|
|
(syntax-case stx ()
|
|
[(_ id ...)
|
|
#'(begin
|
|
(define id 'id) ...
|
|
(provide id) ...)]))
|
|
|
|
(provide Graphics)
|
|
(declare/provide-vars
|
|
Blend Darker Hue Lighter
|
|
Circle Disk Line Point Rectangle
|
|
Text Thickness
|
|
; Colors
|
|
Red Blue Green Black White Yellow
|
|
; Options
|
|
ImageSize PlotRange
|
|
))
|
|
|
|
(module bracket racket
|
|
(require (submod ".." number-theory)
|
|
(submod ".." expression)
|
|
(submod ".." undefined)
|
|
(submod ".." equation-expression)
|
|
(submod ".." mpl-graphics))
|
|
(provide ; (all-from-out (submod ".." symbolic-application))
|
|
(rename-out [free-of Free-of]
|
|
[base Base]
|
|
[const Const]
|
|
[term Term]
|
|
[exponent Exponent]
|
|
[before? Before?]
|
|
[kind Kind])
|
|
(all-from-out (submod ".." mpl-graphics))
|
|
Operand
|
|
Operands
|
|
Hold
|
|
Complete-sub-expressions
|
|
Substitute
|
|
Sequential-substitute
|
|
Concurrent-substitute
|
|
Cons
|
|
List
|
|
List-ref
|
|
Plus Minus Times Quotient Power
|
|
Equal
|
|
Expand
|
|
Set Member?
|
|
Variables
|
|
Map
|
|
Apply
|
|
Append
|
|
AppendStar
|
|
Sin Cos Tan Sqrt
|
|
Solve-quadratic
|
|
Solve-linear
|
|
List->Set
|
|
Define
|
|
Range
|
|
Plot)
|
|
|
|
;;;
|
|
;;; INVARIANT
|
|
;;;
|
|
;;; The following invariant holds for functions in the bracket module.
|
|
;;;
|
|
;;; All functions receiving expressions can rely
|
|
;;; on the expressions to be in automated simplified form (ASF).
|
|
;;;
|
|
;;; All functions creating expressions, must make sure
|
|
;;; the expressions returned are in ASF.
|
|
;;;
|
|
|
|
(define Operand operand)
|
|
(define Kind kind)
|
|
|
|
(define (Operands u)
|
|
(construct 'List (operands u)))
|
|
|
|
(define Hold 'Hold)
|
|
|
|
(define (Plus . expressions)
|
|
(simplify-plus expressions))
|
|
|
|
(define (Minus . us)
|
|
(simplify-minus us))
|
|
|
|
(define (Times . us)
|
|
(simplify-times us))
|
|
|
|
(define (Quotient u1 u2)
|
|
(simplify-quotient (list u1 u2)))
|
|
|
|
(define (Power u1 u2)
|
|
(simplify-power (list u1 u2)))
|
|
|
|
(define (List . us)
|
|
(construct 'List us))
|
|
|
|
(define (Cons u1 u2)
|
|
(construct 'List (cons u1 (List->list u2))))
|
|
|
|
(define (Set . us)
|
|
(construct 'Set (set->list (list->set us))))
|
|
|
|
(define (Complete-sub-expressions u)
|
|
(construct 'List (complete-sub-expressions u)))
|
|
|
|
(define (Substitute u t=r)
|
|
(define-values (t r) (equation->sides t=r))
|
|
(substitute u t r))
|
|
|
|
(define (Sequential-substitute u t=r-list)
|
|
(define-values (ts rs) (equations->sides t=r-list))
|
|
(sequential-substitute u ts rs))
|
|
|
|
(define (Concurrent-substitute u t=r-list)
|
|
(define-values (ts rs) (equations->sides t=r-list))
|
|
(concurrent-substitute u ts rs))
|
|
|
|
(define (Equal u1 u2)
|
|
(cond
|
|
[(and (number? u1) (number? u2))
|
|
(= u1 u2)]
|
|
[(and (string? u1) (string? u2))
|
|
(string=? u1 u2)]
|
|
[else (construct 'Equal (list u1 u2))]))
|
|
|
|
(define (Expand u)
|
|
; [Cohen, Elem, p.253]
|
|
(case (kind u)
|
|
[(Plus)
|
|
(define v (Operand u 0))
|
|
(Plus (Expand v)
|
|
(Expand (Minus u v)))]
|
|
[(Times)
|
|
(define v (Operand u 0))
|
|
(Fix-point ; TODO: neeeded ?
|
|
(λ (u) (cond
|
|
[(times-expression? u)
|
|
(Expand-product (Operand u 0)
|
|
(Quotient u (Operand u 0)))]
|
|
[(power-expression? u) (Expand-power u)]
|
|
[else u]))
|
|
(Expand-product (Expand v)
|
|
(Expand (Quotient u v))))]
|
|
[(Power)
|
|
(define base (Operand u 0))
|
|
(define exponent (Operand u 1))
|
|
(if (and (eq? (Kind exponent) 'integer)
|
|
(>= exponent 2))
|
|
(Expand-power (Expand base) exponent)
|
|
u)]
|
|
[else u]))
|
|
|
|
(define (Expand-product r s)
|
|
; [Cohen, Elem, p.253]
|
|
(cond
|
|
[(eq? (Kind r) 'Plus)
|
|
(define f (Operand r 0))
|
|
(Plus (Expand-product f s)
|
|
(Expand-product (Minus r f) s))]
|
|
[(eq? (Kind s) 'Plus)
|
|
(Expand-product s r)]
|
|
[else
|
|
(Fix-point ; TODO: neeeded ?
|
|
(λ (u)
|
|
(if (power-expression? u)
|
|
(let ([n (exponent u)])
|
|
(if (and (integer? n) (>= n 0))
|
|
(Expand-power (base u) n)
|
|
u)
|
|
u)
|
|
u))
|
|
(Times r s))]))
|
|
|
|
(define (Fix-point f u)
|
|
; Apply f repeatedly to u until
|
|
; a value u1 with f(u1)=u1 is found.
|
|
; The the fixpoint u1 is returned.
|
|
(define u1 (f u))
|
|
(if (equal? u u1)
|
|
u
|
|
(Fix-point f u1)))
|
|
|
|
(define (Expand-power u n)
|
|
; [Cohen, Elem, p.253]
|
|
(unless (and (integer? n) (>= n 0))
|
|
(error 'Expand-power
|
|
"expected natural number as exponent, got ~a" n))
|
|
(cond
|
|
[(eq? (Kind u) 'Plus)
|
|
; u^n = (f +(u-f))^n = sum C(n,k) f^i (u-f)^(n-i)
|
|
(define f (Operand u 0))
|
|
(define r (Minus u f))
|
|
(define s 0)
|
|
(for ([k (+ n 1)])
|
|
(define c (binomial n k))
|
|
(set! s
|
|
(Plus s
|
|
(Fix-point ; TODO: neeeded ?
|
|
(λ (u)
|
|
(if (times-expression? u)
|
|
(Expand u)
|
|
u))
|
|
(Expand-product
|
|
(Times c (Power f (- n k)))
|
|
(Expand-power r k))))))
|
|
s]
|
|
[else
|
|
(Power u n)]))
|
|
|
|
(define (Member? x s)
|
|
(and (member x (operands s)) #t))
|
|
|
|
(define (Rational? u)
|
|
(and (number? u)
|
|
(exact? u)))
|
|
|
|
(define (Append L1 L2)
|
|
(construct 'List
|
|
(append (Operands L1)
|
|
(Operands L2))))
|
|
|
|
(define (AppendStar Ls)
|
|
(list->List
|
|
(append*
|
|
(map List->list
|
|
(List->list
|
|
(Operands Ls))))))
|
|
|
|
(define (list->List l)
|
|
(construct 'List l))
|
|
|
|
(define List->list cdr)
|
|
|
|
(define (List-ref L n)
|
|
(if (and (List? L) (integer? n))
|
|
(list-ref (List->list L) n)
|
|
(construct 'List-ref (list L n))))
|
|
|
|
(define (Map f L)
|
|
; The output of f must be a
|
|
; simplified expression.
|
|
(if (procedure? f)
|
|
(list->List
|
|
(map f (List->list (Operands L))))
|
|
(list->List
|
|
(map (λ (o) (list f o))
|
|
(List->list (Operands L))))))
|
|
|
|
(define (List->Set L)
|
|
(Apply Set (Operands L)))
|
|
|
|
(define (Variables u)
|
|
(define (Vars u)
|
|
(cond
|
|
[(eq? (Kind u) 'symbolic-id)
|
|
(List u)]
|
|
[(atomic-expression? u)
|
|
(List)]
|
|
[(or (plus-expression? u)
|
|
(times-expression? u)
|
|
(and (power-expression? u)
|
|
; Mathematica considers only rational
|
|
; powers. Check [Cohen].
|
|
(Rational? (exponent u))))
|
|
(AppendStar (Map Vars (Operands u)))]
|
|
[(compound-expression? u)
|
|
(List u)]
|
|
[else
|
|
(List)]))
|
|
(List->Set (Vars u)))
|
|
|
|
(define (Sqrt u)
|
|
(cond
|
|
[(and (number? u) (negative? u))
|
|
undefined]
|
|
[(and (number? u) (integer? u))
|
|
(define-values (s r) (integer-sqrt/remainder u))
|
|
(if (zero? r) s (Power u 1/2))]
|
|
[else (Power u 1/2)]))
|
|
|
|
(define-syntax (define-listable stx)
|
|
(syntax-case stx ()
|
|
[(_ (name arg) body ...)
|
|
#'(define (name arg)
|
|
(if (List? arg)
|
|
(Map name arg)
|
|
(let () body ...)))]))
|
|
|
|
(define-syntax (Define stx)
|
|
(syntax-case stx ()
|
|
[(_ (var arg ...) val)
|
|
#'(Define var (lambda (arg ...) val))]
|
|
[(_ var val)
|
|
(with-syntax
|
|
([set!define
|
|
(if (identifier-binding #'var 0)
|
|
#'set!
|
|
#'define)])
|
|
#'(set!define var val))]))
|
|
|
|
(define builtin-db
|
|
(make-hash (list (cons Plus 'Plus)
|
|
(cons Minus 'Minus)
|
|
(cons Times 'Times)
|
|
(cons Quotient 'Quotient)
|
|
(cons Power 'Power))))
|
|
|
|
(define (Apply f L)
|
|
(if (and (procedure? f) (List? L))
|
|
(apply f (List->list L))
|
|
(list->List
|
|
(let ([f (hash-ref builtin-db f f)])
|
|
; TODO: BUG HERE ...........................
|
|
(construct f (Operands L))))))
|
|
|
|
(define (List? u)
|
|
(and (list? u)
|
|
(eq? (Kind u) 'List)))
|
|
|
|
(define-listable (Sqr u)
|
|
(cond
|
|
[(real? u) (sqr u u)]
|
|
[else (Power u 2)]))
|
|
|
|
(define-syntax (define-real-function stx)
|
|
(syntax-case stx ()
|
|
[(_ new old)
|
|
#'(begin
|
|
(provide new)
|
|
(define-listable (new u)
|
|
(cond
|
|
[(number? u) (old u)]
|
|
[else (construct 'new (list u))])))]))
|
|
|
|
(define-real-function Sin sin)
|
|
(define-real-function Cos cos)
|
|
(define-real-function Tan tan)
|
|
(define-real-function Asin asin)
|
|
(define-real-function Acos acos)
|
|
(define-real-function Atan atan)
|
|
(define-real-function Sinh sinh)
|
|
(define-real-function Cosh cosh)
|
|
(define-real-function Tanh tanh)
|
|
;(define-real-function Asinh asinh) ; in the Science collection
|
|
;(define-real-function Acosh acosh)
|
|
;(define-real-function Atanh atanh)
|
|
(define-real-function Round round)
|
|
(define-real-function Floor floor)
|
|
(define-real-function Ceiling ceiling)
|
|
(define-real-function Truncate truncate)
|
|
(define-real-function Sgn sgn)
|
|
|
|
(define (Solve-quadratic a b c)
|
|
; return List of all solutions to ax^2+bx+c=0
|
|
(define d (Minus (Power b 2) (Times 4 a c)))
|
|
(if (rational? d)
|
|
(cond
|
|
[(< d 0) (List)]
|
|
[(= d 0) (List (Quotient (Minus b) (Times 2 a)))]
|
|
[else (List (Quotient (Minus (Minus b) (Sqrt d)) (Times 2 a))
|
|
(Quotient (Plus (Minus b) (Sqrt d)) (Times 2 a)))])
|
|
; Mathematica and NSpire pretends d>0 ...
|
|
(List (Quotient (Minus (Minus b) (Sqrt d)) (Times 2 a))
|
|
(Quotient (Plus (Minus b) (Sqrt d)) (Times 2 a)))))
|
|
|
|
(define (Solve-linear a b)
|
|
; return List of all solutions to ax+b=0
|
|
(if (and (number? a) (not (zero? a)))
|
|
(List (Minus (Quotient b a)))
|
|
(List)))
|
|
|
|
(define Range
|
|
(case-lambda
|
|
[()
|
|
(list 'Range)]
|
|
[(imax)
|
|
(if (number? imax) (range imax) `(Range ,imax))]
|
|
[(imin imax)
|
|
(if (and (number? imin) (number? imax))
|
|
(range imin imax)
|
|
`(Range ,imin ,imax))]
|
|
[(imin imax di)
|
|
(if (and (number? imin)
|
|
(number? imax)
|
|
(number? di))
|
|
(range imin imax di)
|
|
`(Range ,imin ,imax ,di))]
|
|
[args `(Range . ,args)]))
|
|
|
|
(require "../adaptive-plotting.rkt")
|
|
|
|
(define-match-expander List:
|
|
(λ (stx)
|
|
(syntax-case stx ()
|
|
[(_ pat ...) #'(list 'List pat ...)])))
|
|
|
|
(define-namespace-anchor a)
|
|
(define ns (namespace-anchor->namespace a))
|
|
|
|
(define (N u)
|
|
; TODO: Improve this
|
|
(eval u ns))
|
|
|
|
(define (Plot f range [options '(List)])
|
|
; TODO: Implement options
|
|
(displayln (list f range))
|
|
(define y-min -5)
|
|
(define y-max +5)
|
|
(define excluded? #f)
|
|
(match range
|
|
[(List: var x-min x-max)
|
|
(plot2d (if (procedure? f)
|
|
(λ (x) (displayln x) (f x))
|
|
(λ (x) (N (Substitute f (Equal var x)))))
|
|
x-min x-max y-min y-max excluded?)]
|
|
[else (error)]))
|
|
|
|
#;(and (real? x-min) (real? x-max) (real? y-min) (real? y-max)
|
|
(< x-min x-max) (< y-min y-max))
|
|
|
|
; (define (Monomial-gpe u v)
|
|
; (define s (if (eq? (Kind v) 'set) (list v) v))
|
|
; (cond
|
|
; [(Member? u (operands s)) #t]
|
|
; [else
|
|
; (if(power-expression? u)
|
|
; (define base (Operand u 0))
|
|
; (define exponent (Operand u 1))
|
|
; (if (and (Member? base s)
|
|
; (eq? (Kind exponent) 'integer)
|
|
; (> exponent 1))
|
|
)
|
|
|
|
|
|
(module test racket
|
|
(require (submod ".." symbolic-application)
|
|
(submod ".." bracket)
|
|
rackunit)
|
|
(define x 'x)
|
|
(define y 'y)
|
|
(define z 'z)
|
|
(define a 'a)
|
|
(define b 'b)
|
|
(define c 'c)
|
|
(define d 'd)
|
|
(define f 'f)
|
|
|
|
(displayln "TEST - Running tests in mpl.rkt")
|
|
|
|
;;; Kind
|
|
(check-equal? (Kind 1) 'integer)
|
|
(check-equal? (Kind 1/2) 'rational)
|
|
(check-equal? (Kind (sqrt 2)) 'real)
|
|
(check-equal? (Kind 1+5i) 'complex)
|
|
(check-equal? (Kind (Plus 1 x)) 'Plus)
|
|
(check-equal? (Kind (Times 2 x)) 'Times)
|
|
(check-equal? (Kind (Power 2 x)) 'Power)
|
|
;;; Plus
|
|
(check-equal? (Plus 1 1) 2)
|
|
(check-equal? (Plus x 0) x)
|
|
(check-equal? (Plus 0 x) x)
|
|
(check-equal? (Plus x 3 x) '(Plus 3 (Times 2 x)))
|
|
(check-equal? (Plus x 3 (Times x 4)) '(Plus 3 (Times 5 x)))
|
|
(check-equal? (Plus x 3 (Minus x)) 3)
|
|
(check-equal? (Plus x 3 (Minus x) (Times x 5)) (Plus 3 (Times 5 x)))
|
|
;
|
|
(check-equal? (Plus 1) 1)
|
|
(check-equal? (Plus x) x)
|
|
|
|
;;; Times
|
|
(check-equal? (Times 2 3) 6)
|
|
(check-equal? (Times x 2) (Times 2 x))
|
|
(check-equal? (Times 3 x 2) (Times 6 x))
|
|
(check-equal? (Times 3 x 2 x) (Times 6 (Power x 2)))
|
|
(check-equal? (Times 0 x 2 x) 0)
|
|
(check-equal? (Times 1 x x) (Power x 2))
|
|
;;; Power
|
|
(check-equal? (Power x 0) 1)
|
|
(check-equal? (Power 0 0) 'undefined)
|
|
(check-equal? (Power (Power x 2) 3) (Power x 6))
|
|
;;; Minus
|
|
(check-equal? (Minus a b) (Plus a (Times -1 b)))
|
|
; ...
|
|
;;; Quotient and Power
|
|
(check-equal? (Minus (Quotient (Times x y) 3))
|
|
'(Times -1/3 x y))
|
|
(check-equal? (Power (Power (Power x 1/2) 1/2) 8)
|
|
'(Power x 2))
|
|
(check-equal? (Power (Times (Power (Times x y) 1/2) (Power z 2)) 2)
|
|
'(Times x y (Power z 4)))
|
|
|
|
(check-equal? (Quotient x x) 1)
|
|
(check-equal? (Times (Quotient x y) (Quotient y x)) 1)
|
|
(check-equal? (Times 2 3) 6)
|
|
(check-equal? (Times 2 x) '(Times 2 x))
|
|
(check-equal? (Times z y x 2) '(Times 2 x y z))
|
|
(check-equal? (Times (Power x 2) (Power x 3))
|
|
'(Power x 5))
|
|
(check-equal? (Plus x y x z 5 z)
|
|
'(Plus 5 (Times 2 x) y (Times 2 z)))
|
|
(check-equal? '(Times 1/2 x) (Quotient x 2))
|
|
|
|
; Threading of Plus, Times and Power
|
|
(check-equal? (Plus (List 1 x)) (List 1 x))
|
|
(check-equal? (Plus (List 1 2) (List 4 5)) (List 5 7))
|
|
(check-equal? (Plus (List 1 x) 3) (List 4 (Plus x 3)))
|
|
(check-equal? (Plus 3 (List 1 x)) (List 4 (Plus x 3)))
|
|
(check-equal? (Plus y (List 1 x)) (List (Plus 1 y) (Plus x y)))
|
|
(check-equal? (Times (List 1 x)) (List 1 x))
|
|
(check-equal? (Times (List 1 2) (List 4 5)) (List 4 10))
|
|
(check-equal? (Power (List 3 x) 2) (List 9 (Power x 2)))
|
|
|
|
;;; Substitute
|
|
(check-equal? (Substitute (Plus a b) (Equal b x))
|
|
(Plus a x))
|
|
(check-equal? (Substitute (Plus (Quotient 1 a) a) (Equal a x))
|
|
(Plus (Power x -1) x))
|
|
(check-equal? (Substitute (Plus (Power (Plus a b) 2) 1) (Equal (Plus a b) x))
|
|
(Plus 1 (Power x 2)))
|
|
(check-equal? (Substitute (Plus a b c) (Equal (Plus a b) x))
|
|
(Plus a b c))
|
|
(check-equal? (Substitute (Plus a b c) (Equal a (Minus x b)))
|
|
(Plus c x))
|
|
;;; Sequential-substitute
|
|
(check-equal? (Sequential-substitute
|
|
(Plus x y)
|
|
(List (Equal x (Plus a 1))
|
|
(Equal y (Plus b 2))))
|
|
(Plus 3 a b))
|
|
(check-equal? (Sequential-substitute
|
|
(Plus x y)
|
|
(List (Equal x (Plus a 1))
|
|
(Equal a (Plus b 2))))
|
|
(Plus 3 b y))
|
|
(check-equal? (Sequential-substitute
|
|
(Equal (f x) (Plus (Times a x) b))
|
|
(List (Equal (f x) 2)
|
|
(Equal x 3)))
|
|
(Equal 2 (Plus (Times 3 a) b)))
|
|
(check-equal? (Sequential-substitute
|
|
(Equal (f x) (Plus (Times a x) b))
|
|
(List (Equal x 3)
|
|
(Equal (f x) 2)))
|
|
(Equal (f 3) (Plus (Times 3 a) b)))
|
|
;;; Concurrent-substitute
|
|
(check-equal? (Concurrent-substitute
|
|
(Times (Plus a b) x)
|
|
(List (Equal (Plus a b) (Plus x c))
|
|
(Equal x d)))
|
|
(Times d (Plus c x)))
|
|
(check-equal? (Concurrent-substitute
|
|
(Equal (f x) (Plus (Times a x) b))
|
|
(List (Equal x 3)
|
|
(Equal (f x) 2)))
|
|
(Equal 2 (Plus (Times 3 a) b)))
|
|
; Expand
|
|
(check-equal? (Expand (Power (Plus a b) 2))
|
|
(Plus (Power a 2) (Times 2 a b) (Power b 2)))
|
|
(check-equal? (Expand (Times a (Plus x y)))
|
|
(Plus (Times a x) (Times a y)))
|
|
|
|
|
|
)
|
|
|
|
|
|
#;(require (submod "." symbolic-application)
|
|
(submod "." mpl))
|
|
|
|
;(define x 'x)
|
|
;(define y 'y)
|
|
;(define z 'z)
|
|
;(define a 'a)
|
|
;(define b 'b)
|
|
;(define c 'c)
|
|
;(define d 'd)
|
|
;(define f 'f)
|
|
|
|
;;; Problem: (Power (Plus 1 y) 2) is not expanded
|
|
; > (Algebraic-expand (Power (Plus (Times x (Power (Plus y 1) 1/2)) 1) 4))
|
|
; '(Plus 1 (Times 4 x) (Times 6 (Power x 2)) (Times 4 (Power x 3)) (Times (Power x 4) (Power (Plus 1 y) 2)))
|