arithmetic.egi

;;;;;
;;;;;
;;;;; Arithmetic Operation
;;;;;
;;;;;

(define $to-math-expr (macro [$arg] (math-normalize b.+ 0 (apply to-math-expr' arg))))

(define $+' (cambda $xs (foldl b.+' (car xs) (cdr xs))))
(define $-' (cambda $xs (foldl b.-' (car xs) (cdr xs))))
(define $*' (cambda $xs (foldl b.*' (car xs) (cdr xs))))
(define $/' b./')
(define $.' (cambda $xs (foldl b..' (car xs) (cdr xs))))

(define $b.+
  (lambda [$x1 $x2]
    (match [x1 x2] [math-expr math-expr]
      {[[<div $p1 (& !,1 $p2)> <div $q1 ,p2>]
        (b./ (b.+ p1 q1) p2)]
       [[_ _] (reduce-fraction (math-normalize b.+' x1 x2))]})))

(define $b.-
  (lambda [$x1 $x2]
    (match [x1 x2] [math-expr math-expr]
      {[[<div $p1 (& !,1 $p2)> <div $q1 ,p2>]
        (b./ (b.- p1 q1) p2)]
       [[_ _] (reduce-fraction (math-normalize b.+' x1 (b.*' -1 x2)))]})))

(define $b.*
  (lambda [$x1 $x2]
    (reduce-fraction (math-normalize b.*' x1 x2))))

(define $b./
  (lambda [$x1 $x2]
    (reduce-fraction (math-normalize b.*' x1 (b./' 1 x2)))))

(define $+ (cambda $xs (foldl b.+ (car xs) (cdr xs))))
(define $- (cambda $xs (foldl b.- (car xs) (cdr xs))))
(define $* (cambda $xs (foldl b.* (car xs) (cdr xs))))
(define $/ b./)


(define $reduce-fraction
  (lambda [$mexpr]
    (match mexpr math-expr
      {[<div <poly $ts1>
             <poly $ts2>>
        (let* {[$d1 (capply gcd ts1)]
               [$d2 (capply gcd ts2)]
               [$d (capply gcd {@ts1 @ts2})]}
          (if (eq? (-' (sum' (map (/' $ d1) ts1)) (sum' (map (/' $ d2) ts2))) 0)
            (/' (/' d1 d) (/' d2 d))
            (/' (sum' (map (/' $ d) ts1)) (sum' (map (/' $ d) ts2)))))]})))

;            (let* {[$e1 (expand-all' (sum' (map (/' $ d) ts1)))]
;                   [$qexprs (match-all (/' d2 d) math-expr
;                              [<term _ <cons <quote $qexpr> _>> qexpr])]
;                   [$dps (filter 1#(eq? 0 (2#%2 (P./ e1 %1 (car (find-symbols-from-poly %1)))))
;                                 qexprs)]}
;              (if (eq? dps {})
;                (/' (sum' (map (/' $ d) ts1)) (sum' (map (/' $ d) ts2)))
;                (let {[$dp (car dps)]}
;                  (reduce-fraction (/' (2#%1 (P./ e1 dp (car (find-symbols-from-poly dp))))
;                                       (sum' (map (/' $ (*' d 'dp)) ts2))))
;                  )))))]})))

(define $sum
  (lambda [$xs]
    (foldl + 0 xs)))

(define $sum'
  (lambda [$xs]
    (foldl +' 0 xs)))

(define $product
  (lambda [$xs]
    (foldl * 1 xs)))

(define $product'
  (lambda [$xs]
    (foldl *' 1 xs)))

(define $power
  (lambda [$x $n]
    (foldl * 1 (take n (repeat1 x)))))

(define $power'
  (lambda [$x $n]
    (foldl *' 1 (take n (repeat1 x)))))

(define $**
  (lambda [$x $n]
    (if (eq? x e)
      (exp n)
      (if (rational? n)
        (if (gte? n 0)
          (if (integer? n)
            (power x n)
            (`** x n))
          (/ 1 (** x (neg n))))
        (`** x n)))))

(define $**'
  (lambda [$x $n]
    (if (eq? x e)
      (exp n)
      (if (rational? n)
        (if (gte? n 0)
          (if (integer? n)
            (power' x n)
            (`** x n))
          (/' 1 (**' x (neg n))))
        (`** x n)))))

(define $gcd
  (cambda $xs
    (foldl b.gcd (car xs) (cdr xs))))

(define $gcd'
  (cambda $xs
    (foldl b.gcd' (car xs) (cdr xs))))

(define $b.gcd
  (lambda [$x $y]
    (match [x y] [term-expr term-expr]
      {[[_ ,0] x]
       [[,0 _] y]
       [[<term $a $xs> <term $b $ys>]
        (*' (b.gcd' (abs a) (abs b)) (foldl *' 1 (map 2#(**' %1 %2) (AC.intersect xs ys))))]})))

(define $b.gcd'
  (lambda [$x $y]
    (match [x y] [integer integer]
      {[[_ ,0] x]
       [[,0 _] y]
       [[_ ?(gte? $ x)] (b.gcd' (modulo y x) x)]
       [[_ _] (b.gcd' y x)]})))

(define $P./
  (lambda [$fx $gx $x]
    (let* {[$as (reverse (coefficients fx x))]
           [$bs (reverse (coefficients gx x))]
           [[$zs $rs] (L./ as bs)]}
      [(sum' (map2 2#(*' %1 (**' x %2)) (reverse zs) nats0))
       (sum' (map2 2#(*' %1 (**' x %2)) (reverse rs) nats0))])))