;;;;;
;;;;;
;;;;; Term Rewriting
;;;;;
;;;;;

;(set-term-rewriting-rule {[(rt $n $x)^,n x]
;                          [(* (sqrt $x) (sqrt $y)) (* (gcd x y) (sqrt (/ (* x y) (gcd x y))))]
;                          [(rtu $n)^,n 1]
;                          [w^3 1]
;                          [w^2 (- -1 w)]
;                          [i^2 -1]})

(define $math-normalize
  (lambda [$mexpr]
    (if (tensor? mexpr)
      (tensor-map math-normalize mexpr)
      (if (number? mexpr)
        (if (rational? mexpr)
          mexpr
          (map-terms rewrite-rule-rt
                     (map-terms rewrite-rule-sqrt
                                (map-terms rewrite-rule-rtu
                                           (map-terms rewrite-rule-w
                                                      (map-terms rewrite-rule-i
                                                                 mexpr
                                                                 ))))))
        mexpr))))

(define $rewrite-rule-i
  (lambda [$term]
    (match term term-expr
      {[<term $a <ncons (& ?even? $k) ,i $ts>>
        (*' a (**' -1 (quotient k 2)) (foldl *' 1 (map 2#(**' %1 %2) ts)))]
       [<term $a <ncons $k ,i $ts>>
        (*' a (**' -1 (quotient k 2)) i (foldl *' 1 (map 2#(**' %1 %2) ts)))]
       [_ term]})))

(define $rewrite-rule-w
  (lambda [$term]
    (match term term-expr
      {[<term $a <ncons (& ?(gte? $ 3) $k) ,w $ts>>
        (*' a (**' w (remainder k 3)) (foldl *' 1 (map 2#(**' %1 %2) ts)))]
       [<term $a <ncons ,2 ,w $ts>>
        (*' a (- -1 w) (foldl *' 1 (map 2#(**' %1 %2) ts)))]
       [_ term]})))

(define $rewrite-rule-rtu
  (lambda [$term]
    (match term term-expr
      {[<term $a <ncons $k (,rtu (& ?(gte? k $) $n)) $ts>>
        (*' a (**' (rtu n) (remainder k n)) (foldl *' 1 (map 2#(**' %1 %2) ts)))]
       [_ term]})))

(define $rewrite-rule-sqrt
  (lambda [$term]
    (match term term-expr
      {[<term $a <cons (,sqrt $x) <cons (,sqrt ,x) $ts>>>
        (* a x (foldl *' 1 (map 2#(**' %1 %2) ts)))]
       [<term $a <cons (,sqrt (& ?term? $x)) <cons (,sqrt (& ?term? $y)) $ts>>>
        (let* {[$d (gcd x y)]
               [[$a1 $x1] (from-monomial (/ x d))]
               [[$a2 $y1] (from-monomial (/ y d))]}
            (*' a d
               (sqrt (*' a1 a2)) (sqrt x1) (sqrt y1)
               (foldl *' 1 (map 2#(**' %1 %2) ts))))]
       [_ term]})))

(define $rewrite-rule-rt
  (lambda [$term]
    (match term term-expr
      {[<term $a <ncons $k (,rt (& ?(gte? k $) $n) $x) $ts>>
        (*' a (**' x (quotient k n)) (**' (rt n x) (remainder k n)) (foldl *' 1 (map 2#(**' %1 %2) ts)))]
       [_ term]})))