Mark Tarver wrote:

> The problem is to simplify symbolic expressions by applying the
> following rewrite rules from the leaves up:
>
> rational n + rational m -> rational(n + m)
> rational n * rational m -> rational(n * m)
> symbol x -> symbol x
> 0+f -> f
> f+0 -> f
> 0*f -> 0
> f*0 -> 0
> 1*f -> f
> f*1 -> f
> a+(b+c) -> (a+b)+c
> a*(b*c) -> (a*b)*c

> Language: OCaml
> Author: Jon Harrop
> Length: 15 lines
>
> let rec ( +: ) f g = match f, g with
> | `Int n, `Int m -> `Int (n +/ m)
> | `Int (Int 0), e | e, `Int (Int 0) -> e
> | f, `Add(g, h) -> f +: g +: h
> | f, g -> `Add(f, g)
>
>
> let rec ( *: ) f g = match f, g with
> | `Int n, `Int m -> `Int (n */ m)
> | `Int (Int 0), e | e, `Int (Int 0) -> `Int (Int 0)
> | `Int (Int 1), e | e, `Int (Int 1) -> e
> | f, `Mul(g, h) -> f *: g *: h
> | f, g -> `Mul(f, g)
>
>
> let rec simplify = function
> | `Int _ | `Var _ as f -> f
> | `Add (f, g) -> simplify f +: simplify g
> | `Mul (f, g) -> simplify f *: simplify g

> Language: Lisp
> Author: Andre Thieme
> Length: 23 lines
>
> (defun simplify (a)
> (if (atom a)
> a
> (destructuring-bind (op x y) a
> (let* ((f (simplify x))
> (g (simplify y))
> (nf (numberp f))
> (ng (numberp g))
> (+? (eq '+ op))
> (*? (eq '* op)))
> (cond
> ((and +? nf ng) (+ f g))
> ((and +? nf (zerop f)) g)
> ((and +? ng (zerop g)) f)
> ((and (listp g) (eq op (first g)))
> (destructuring-bind (op2 u v) g
> (simplify `(,op (,op ,f ,u) ,v))))
> ((and *? nf ng) (* f g))
> ((and *? (or (and nf (zerop f))
> (and ng (zerop g)))) 0)
> ((and *? nf (= 1 f)) g)
> ((and *? ng (= 1 g)) f)
> (t `(,op ,f ,g)))))))

Testing:

(simplify '(+ x (+ y z)))

(+ (+ X Y) Z)

(simplify '(* x (+ (+ (* 12 0) (+ 23 8)) y)))

(* X (+ 31 Y))

(simplify '(* (+ z (* 1 x)) (+ (+ (* (+ 2 -2) (+ (* z 0) 7)) (+ (+ 7 23) 8)) y)))

(* (+ Z X) (+ 38 Y))

Language: Qi
Author: Mark Tarver

> (define simplify
> [Op A B] -> (s [Op (simplify A) (simplify B)])
> A -> A)
>
> (define s
> [+ M N] -> (+ M N) where (and (number? M) (number? N))
> [+ 0 F] -> F
> [+ F 0] -> F
> [+ A [+ B C]] -> [+ [+ A B] C]
> [* M N] -> (* M N) where (and (number? M) (number? N))
> [* 0 F] -> 0
> [* F 0] -> 0
> [* F 1] -> F
> [* 1 F] -> F
> [* A [* B C]] -> [* [* A B] C]
> A -> A)

newLISP

(define (ub pat xs) (if (unify pat xs) (bind $it) nil))

;; Without the evil "eval", it's one line longer.
(define (s x , O A B C)
(if (and (ub '(O A B) x) (int A) (int B)) (eval x)
(ub '(+ 0 A) x) A
(ub '(+ A 0) x) A
(ub '(* 1 A) x) A
(ub '(* A 1) x) A
(ub '(* 0 A) x) 0
(ub '(* A 0) x) 0
(ub '(+ A (+ B C)) x) (list '+ (list '+ A B) C)
(ub '(* A (* B C)) x) (list '* (list '* A B) C)
x))

(define (simplify x , Op A B)
(if (ub '(Op A B) x) (s (list Op (simplify A) (simplify B)))
x))

(simplify '(+ x (+ y z)))

(+ (+ x y) z)

(simplify '(* x (* y z)))

(* (* x y) z)

(simplify '(* x (+ (+ (* 12 0) (+ 23 8)) y)))

(* x (+ 31 y))

(simplify '(* (+ z (* 1 x)) (+ (+ (* (+ 2 -2) (+ (* z 0) 7))
(+ (+ 7 23) 8)) y)))

(* (+ z x) (+ 38 y))

;; The evil "eval" enables it partially to handle "-" and "/".
(simplify '(* (+ z (* 1 x)) (+ (+ (* (- 2 2) (+ (* z 0) 7))
(+ (/ 35 7) 8)) y)))

(* (+ z x) (+ 13 y))