;;;;;
;;;;;
;;;;; Mathematics Expressions
;;;;;
;;;;;

(define $math-expr
  (matcher
    {[,$val []
      {[$tgt (if (eq? val tgt)
               {[]}
               {})]}]
     [$ [math-expr']
      {[<Div $p1 $p2> {<Div p1 p2>}]
       [$tgt {(from-math-expr tgt)}]}]
     }))

(define $math-expr'
  (matcher
    {[<div $ $> [poly-expr poly-expr]
      {[<Div $p1 $p2> {[(to-math-expr' p1) (to-math-expr' p2)]}]
       [_ {}]}]
     [$ [something]
      {[$tgt {(to-math-expr' tgt)}]}]
     }))

(define $poly-expr
  (matcher
    {[,$val []
      {[$tgt (if (eq? val tgt)
               {[]}
               {})]}]
     [$ [poly-expr']
      {[<Plus $ts> {<Plus ts>}]
       [<Div <Plus $ts> <Plus {<Term 1 {}> @{}}>> {<Plus ts>}]
       [$tgt {(from-math-expr tgt)}]}]
     }))

(define $poly-expr'
  (matcher
    {[<plus $> [(multiset term-expr)]
      {[<Plus $ts> {(map to-math-expr' ts)}]
       [<Div <Plus $ts> <Plus {<Term 1 {}> @{}}>> {(map to-math-expr' ts)}]
       [_ {}]}]
     [$ [something]
      {[$tgt {(to-math-expr' tgt)}]}]
     }))

(define $term-expr
  (matcher
    {[,$val []
      {[$tgt (if (eq? val tgt)
               {[]}
               {})]}]
     [<mult ,$val $> [term-expr]
      {[$tgt (if (term? (/ tgt val))
               {(/ tgt val)}
               {})]}]
     [$ [term-expr']
      {[<Term $n $xs> {<Term n xs>}]
       [<Div <Plus {<Term $n $xs> @{}}> <Plus {<Term 1 {}> @{}}>> {<Term n xs>}]
       [$tgt {(from-math-expr tgt)}]}]
     }))

(define $term-expr'
  (matcher
    {[<term $ $> [integer (assoc-multiset symbol-expr)]
      {[<Term $n $xs> {[n (map 2#[(to-math-expr' %1) %2] xs)]}]
       [<Div <Plus {<Term $n $xs> @{}}> <Plus {<Term 1 {}> @{}}>> {[n (map 2#[(to-math-expr' %1) %2] xs)]}]
       [_ {}]}]
     [$ [something]
      {[$tgt {(to-math-expr' tgt)}]}]
     }))

(define $symbol-expr
  (matcher
    {[,$val []
      {[$tgt (if (eq? val tgt)
                 {[]}
                 {})]}]
     [$ [symbol-expr']
      {[<Symbol $v> {<Symbol v>}]
       [<Div <Plus {<Term 1 {[<Symbol $v> 1] @{}}> @{}}> <Plus {<Term 1 {}> @{}}>> {<Symbol v>}]
       [<Apply $v $mexprs> {<Apply v mexprs>}]
       [<Div <Plus {<Term 1 {[<Apply $v $mexprs> 1] @{}}> @{}}> <Plus {<Term 1 {}> @{}}>> {<Apply v mexprs>}]
       [$tgt {(from-math-expr tgt)}]}]
     }))

(define $symbol-expr'
  (matcher
    {[<symbol $> [string]
      {[<Symbol $v> {v}]
       [<Div <Plus {<Term 1 {[<Symbol $v> 1] @{}}> @{}}> <Plus {<Term 1 {}> @{}}>> {v}]
       [_ {}]}]
     [<apply $ $> [eq (list math-expr)]
      {[<Apply $v $mexprs> [v mexprs]]
       [<Div <Plus {<Term 1 {[<Apply $v $mexprs> 1] @{}}> @{}}>
             <Plus {<Term 1 {}> @{}}>> {[v (map to-math-expr' mexprs)]}]
       [_ {}]}]
     [$ [something]
      {[$tgt {(to-math-expr' tgt)}]}]
     }))

(define $symbol?
  (lambda [$mexpr]
    (match mexpr math-expr
      {[<div <plus <cons <term ,1 <cons <symbol _> <nil>>> <nil>>>
             <plus <cons <term ,1 <nil>> <nil>>>>
        #t]
       [_ #f]})))

(define $simple-term?
  (lambda [$mexpr]
    (match mexpr math-expr
      {[<div <plus <cons <term ,1 <cons _ <nil>>> <nil>>>
             <plus <cons <term ,1 <nil>> <nil>>>>
        #t]
       [,0 #t]
       [_ #f]})))

(define $term?
  (lambda [$mexpr]
    (match mexpr math-expr
      {[<div <plus <cons _ <nil>>>
             <plus <cons <term ,1 <nil>> <nil>>>>
        #t]
       [,0 #t]
       [_ #f]})))

(define $polynomial?
  (lambda [$mexpr]
    (match mexpr math-expr
      {[<div _
             <plus <cons <term ,1 <nil>> <nil>>>>
        #t]
       [,0 #t]
       [_ #f]})))

(define $monomial?
  (lambda [$mexpr]
    (match mexpr math-expr
      {[<div <plus <cons <term _ _> <nil>>>
             <plus <cons <term _ _> <nil>>>>
        #t]
       [,0 #t]
       [_ #f]})))

(define $from-monomial
  (lambda [$mexpr]
    (match mexpr math-expr
      {[<div <plus <cons <term $a $xs> <nil>>>
             <plus <cons <term $b $ys> <nil>>>>
        [(/ a b)
         (/ (foldl *' 1 (map 2#(**' %1 %2) xs))
            (foldl *' 1 (map 2#(**' %1 %2) ys)))]]})))

;;
;; Map
;;
(define $map-terms
  (lambda [$fn $mexpr]
    (match mexpr math-expr
      {[<div <plus $ts1> <plus $ts2>>
        (/' (foldl +' 0 (map fn ts1))
            (foldl +' 0 (map fn ts2)))]})))

(define $map-symbols
  (lambda [$fn $mexpr]
    (map-terms (lambda [$term]
                 (match term term-expr
                   {[<term $a $xs>
                     (*' a (foldl *' 1 (map 2#(match %1 symbol-expr
                                                {[<symbol _> (**' (fn %1) %2)]
                                                 [<apply $g $args>
                                                  (** (fn (capply g (map (map-symbols fn $) args)))
                                                      %2)
                                                  ]})
                                            xs)))]}))
               mexpr)))

(define $contain-symbol?
  (lambda [$x $mexpr]
    (any id (match mexpr math-expr
              {[<div <plus $ts1> <plus $ts2>>
                (map (lambda [$term]
                       (match term term-expr
                         {[<term _ $xs>
                           (any id (map 2#(match %1 symbol-expr
                                            {[,x #t]
                                             [<apply _ $args> (any id (map (contain-symbol? x $) args))]
                                             [_ #f]})
                                        xs))]}))
                     {@ts1 @ts2})]}))))

;;;
;;; Substitute
;;;
(define $substitute
  (lambda [$ls $mexpr]
    (if (tensor? mexpr)
      (tensor-map (substitute ls $) mexpr)
      (match ls (list [symbol-expr math-expr])
        {[<nil> mexpr]
         [<cons [$x $a] $rs>
          (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]})))

;;;
;;; Coefficient
;;;
(define $coefficients
  (lambda [$f $x]
    (let {[$m (capply max {0 @(match-all f math-expr
                                [<div <plus <cons <term $a <ncons $k ,x $ts>> _>> _> k])})]}
      (map (coefficient f x $) (between 0 m)))))

(define $coefficient
  (lambda [$f $x $m]
    (if (eq? m 0)
      (/ (sum (match-all f math-expr
                [<div <plus <cons <term $a (& !<cons ,x _> $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
              [<div <plus <cons <term $a <ncons $k ,x $ts>> _>> _>
               (if (eq? m k)
                 (foldl *' a (map 2#(**' %1 %2) ts))
                 0)]))
       (denominator f))))