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))

--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)