Common Subexpression Elimination

;; My example of when mutation is a useful tool that simplifies things.

(define (identity i) i)
(define (concat xs) (apply append xs))
(define (concat-map f x) (concat (map f x)))
(define (sort by xs)
  (define (insert by x xs)
    (if (null? xs)
        (list x)
        (if (< (by x) (by (car xs)))
            (cons x xs)
            (cons (car xs) (insert by x (cdr xs))))))
  (if (null? xs) '()
      (insert by (car xs) (sort by (cdr xs)))))

;; <variadic-tree> ::= <leaf> | (<variadic-tree> ...)
;; <leaf> is any non-list datum

(define (leaf? datum) (not (list? datum)))

(define (variadic-tree leaf nodes)
  (lambda (tree)
    (if (leaf? tree)
        (leaf tree)
        (apply nodes (map (variadic-tree leaf nodes) tree)))))

(define copy-tree (variadic-tree identity list))

(define exp-1
  (copy-tree
   '(+ (* (- x-1 x-2) (- x-1 x-2))
       (* (- y-1 y-2) (- y-1 y-2))
       (* (- z-1 z-2) (- z-1 z-2)))))

(define (splat tree)
  (if (leaf? tree)
      '()
      (cons tree (concat-map splat tree))))

(define (subexpressions tree) (sort length (cdr (splat tree))))

(define (eliminate exp sub sym)
  (cond ((null? exp) exp)
        ((leaf? exp) exp)
        ((cond ((equal? sub (car exp)) (set-car! exp sym))
               (else (eliminate (car exp) sub sym)))
         (eliminate (cdr exp) sub sym)
         exp)))

(define gensym
  (let ((n 0))
    (lambda ()
      (set! n (+ n 1))
      (string->symbol (string-append "g" (number->string n))))))

(define (eliminate-subexpressions env exp subs)
  (cond ((null? subs) `(let ,(reverse env) ,exp))
        (else
         (let* ((g (gensym))
                (sub (car subs))
                (exp-2 (eliminate exp sub g)))
           (eliminate-subexpressions (cons (list g sub) env) exp-2 (subexpressions exp-2))))))

;; (eliminate-subexpressions '() exp-1 (subexpressions exp-1))
;; =>
;; (let ((g1 (- z-1 z-2))
;;       (g2 (* g1 g1))
;;       (g3 (- y-1 y-2))
;;       (g4 (* g3 g3))
;;       (g5 (- x-1 x-2))
;;       (g6 (* g5 g5)))
;;   (+ g6 g4 g2))