;;;;; ;;;;; ;;;;; Mathematics Expressions ;;;;; ;;;;; (define $math-expr (matcher {[,$val [] {[$tgt (if (eq? val tgt) {[]} {})]}] [$ [math-expr'] {[$tgt {(from-math-expr tgt)}]}] })) (define $math-expr' (matcher {[
[math-expr math-expr] {[
{[(to-math-expr' p1) (to-math-expr' p2)]}] [_ {}]}] [ [(multiset math-expr)] {[
@{}}>> {(map to-math-expr' ts)}] [_ {}]}] [ [plus-expr] {[
@{}}>> {(to-math-expr'
}>>)}] [_ {}]}] [ [integer (assoc-multiset math-expr)] {[
@{}}> @{}}>> {[n (map 2#[(to-math-expr' %1) %2] xs)]}] [_ {}]}] [ [integer mult-expr] {[
@{}}> @{}}>> {[n (product' (map 2#(**' (to-math-expr' %1) %2) xs))]}] [_ {}]}] ; [ [eq] ; {[
1] @{}}> @{}}> @{}}>> {v}] ; [_ {}]}] [ [eq (list index-expr)] {[
1] @{}}> @{}}> @{}}>> {[v js]}] [_ {}]}] [ [eq (list math-expr)] {[
1] @{}}> @{}}> @{}}>> {[v (map to-math-expr' mexprs)]}] [_ {}]}] [ [math-expr] {[
1] @{}}> @{}}> @{}}>> {(to-math-expr' mexpr)}] [_ {}]}] [ [math-expr (list math-expr) (list math-expr) (list index-expr)] {[
1] @{}}> @{}}> @{}}>> {[name argnames args js]}] [_ {}]}] [$ [something] {[$tgt {(to-math-expr' tgt)}]}] })) (define $index-expr (algebraic-data-matcher { })) (define $poly-expr math-expr) (define $term-expr math-expr) (define $symbol-expr math-expr) (define $plus-expr (matcher {[ [] {[$tgt (if (eq? tgt 0) {[]} {})]}] [ [math-expr plus-expr] {[$tgt (match-all tgt math-expr [> [t (sum' ts)]])]}] [$ [math-expr] {[$tgt {tgt}]}] })) (define $mult-expr (matcher {[ [] {[$tgt (match tgt math-expr {[,0 {[]}] [_ {}]})]}] [ [math-expr mult-expr] {[$tgt (match tgt math-expr {[ (match-all xs (assoc-multiset math-expr) [ [x (product' (map 2#(**' %1 %2) rs))]])] [_ {}]})]}] [ [math-expr mult-expr] {[$tgt (match tgt math-expr {[ (match-all xs (list [math-expr integer]) [> [x (product' (map 2#(**' %1 %2) {@hs [x (- n k)] @ts}))]])] [_ {}]})]}] [ [math-expr integer mult-expr] {[$tgt (match tgt math-expr {[ (match-all xs (list [math-expr integer]) [> [x n (product' (map 2#(**' %1 %2) {@hs @ts}))]])] [_ {}]})]}] [$ [math-expr] {[$tgt {tgt}]}] })) ;; ;; Predicate ;; (define $symbol? (lambda [$mexpr] (match mexpr math-expr {[ #t] [_ #f]}))) (define $tensor-symbol? (lambda [$mexpr] (match mexpr math-expr {[ ) _>>> #t] [_ #f]}))) (define $apply? (lambda [$mexpr] (match mexpr math-expr {[ #t] [_ #f]}))) (define $simple-term? 1#(or (symbol? %1) (apply? %1))) (define $term? (lambda [$mexpr] (match mexpr math-expr {[ #t] [,0 #t] [_ #f]}))) (define $polynomial? (lambda [$mexpr] (match mexpr math-expr {[ #t] [,0 #t] [_ #f]}))) (define $monomial? (lambda [$mexpr] (match mexpr math-expr {[
>> >>> #t] [,0 #t] [_ #f]}))) ;; ;; Accessor ;; (define $symbol-indices (lambda [$mexpr] (match mexpr math-expr {[ js] [_ undefined]}))) (define $from-monomial (lambda [$mexpr] (match mexpr math-expr {[
> [(/ a b) (/ (foldl *' 1 (map 2#(**' %1 %2) xs)) (foldl *' 1 (map 2#(**' %1 %2) ys)))]]}))) ;; ;; Map ;; (define $map-polys (lambda [$fn $mexpr] (match mexpr math-expr {[
(/' (fn p1) (fn p2))]}))) (define $from-poly (lambda [$mexpr] (match mexpr math-expr {[
$q> (map (lambda [$t1] (/' t1 q)) ts1)]}))) (define $map-poly (lambda [$fn $mexpr] (match mexpr math-expr {[
$q> (foldl +' 0 (map (lambda [$t1] (fn (/' t1 q))) ts1))]}))) (define $map-terms (lambda [$fn $mexpr] (match mexpr math-expr {[
> (/' (foldl +' 0 (map fn ts1)) (foldl +' 0 (map fn ts2)))]}))) (define $map-symbols (lambda [$fn $mexpr] (map-terms (lambda [$term] (match term term-expr {[ (*' a (foldl *' 1 (map 2#(match %1 symbol-expr {[ (**' (fn %1) %2)] [ (let {[$args'(map (map-symbols fn $) args)]} (if (eq? args args') (**' %1 %2) (**' (fn (capply g args')) %2))) ]}) xs)))]})) mexpr))) (define $contain-symbol? (lambda [$x $mexpr] (any id (match mexpr math-expr {[
> (map (lambda [$term] (match term term-expr {[ (any id (map 2#(match %1 symbol-expr {[,x #t] [ (any id (map (contain-symbol? x $) args))] [_ #f]}) xs))]})) {@ts1 @ts2})]})))) (define $contain-function? (lambda [$f $mexpr] (any id (match mexpr math-expr {[
> (map (lambda [$term] (match term term-expr {[ (any id (map 2#(match %1 symbol-expr {[ (if (eq? f g) #t (any id (map (contain-function? f $) args)))] [_ #f]}) xs))]})) {@ts1 @ts2})]})))) (define $contain-function-with-order? (lambda [$f $n $mexpr] (any id (match mexpr math-expr {[
> (map (lambda [$term] (match term term-expr {[ (any id (map 2#(match %1 symbol-expr {[ (if (and (eq? f g) (gte? %2 n)) #t (any id (map (contain-function-with-order? f n $) args)))] [_ #f]}) xs))]})) {@ts1 @ts2})]})))) (define $contain-function-with-index? (lambda [$mexpr] (any id (match mexpr math-expr {[
> (map (lambda [$term] (match term term-expr {[ (any id (map 2#(match %1 symbol-expr {[ (match f math-expr {[> #t] [_ (any id (map (contain-function-with-index? $) args))]})] [ (any id (map (contain-function-with-index? $) args))] [_ #f]}) xs))]})) {@ts1 @ts2})]})))) (define $find-symbols-from-poly (lambda [$poly] (match-all poly math-expr [ $s) _>> _>> s]))) ;;; ;;; Substitute ;;; (define $substitute (lambda [$ls $mexpr] (match ls (list [symbol-expr math-expr]) {[ mexpr] [ (substitute rs (substitute' x a mexpr))]}))) (define $substitute' (lambda [$x $a $mexpr] (map-symbols (rewrite-symbol x a $) mexpr))) (define $rewrite-symbol (lambda [$x $a $sexpr] (match sexpr symbol-expr {[,x a] [_ sexpr]}))) (define $V.substitute (lambda [%xs %ys $mexpr] (substitute (zip (tensor-to-list xs) (tensor-to-list ys)) mexpr))) (define $expand-all (lambda [$mexpr] (match mexpr math-expr { [?symbol? mexpr] ; function application [ (capply g (map expand-all args))] ; quote [ g] ; term (multiplication) [ (* a (product (map 2#(** (expand-all %1) (expand-all %2)) ps)))] ; polynomial [ (sum (map (expand-all $) ts))] ; quotient [(/ $p1 $p2) (let {[$p1' (expand-all p1)] [$p2' (expand-all p2)]} (/ p1' p2'))] }))) (define $expand-all' (lambda [$mexpr] (match mexpr math-expr { [?symbol? mexpr] ; function application [ (capply g (map expand-all' args))] ; quote [ g] ; term (multiplication) [ (*' a (product' (map 2#(**' (expand-all' %1) (expand-all' %2)) ps)))] ; polynomial [ (sum' (map (expand-all' $) ts))] ; quotient [(/ $p1 $p2) (let {[$p1' (expand-all' p1)] [$p2' (expand-all' p2)]} (/' p1' p2'))] }))) ;;; ;;; Coefficient ;;; (define $coefficients (lambda [$f $x] (let {[$m (capply max {0 @(match-all f math-expr [
> _>> _> k])})]} (map (coefficient f x $) (between 0 m))))) (define $coefficient (lambda [$f $x $m] (if (eq? m 0) (/ (sum (match-all f math-expr [
$ts)> _>> _> (foldl *' a (map 2#(**' %1 %2) ts))])) (denominator f)) (coefficient' f x m)))) (define $coefficient' (lambda [$f $x $m] (/ (sum (match-all f math-expr [
> _>> _> (if (eq? m k) (foldl *' a (map 2#(**' %1 %2) ts)) 0)])) (denominator f)))) (define $coefficient2 (lambda [$f $x $y] (/ (sum (match-all f math-expr [
>> _>> _> (foldl *' a (map 2#(**' %1 %2) ts)) ])) (denominator f))))