Re: Jon Harrop rewrite benchmark; Qi, Lisp and OCaml

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