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

HOAS based self interpreter for lambda calculus

Just copied this out of Self-applicable Partial Evaluation for Pure Lambda Calculus

(define-syntax Q ; quote a lambda term
  (syntax-rules (lambda)
    ((Q (lambda (x) M)) (lambda (a)
                          (lambda (b)
                            (lambda (c)
                              (a (lambda (x) (Q M)))))))
    ((Q (M N)) (lambda (a)
                 (lambda (b)
                   (lambda (c)
                     ((b (Q M)) (Q N))))))
    ((Q x) (lambda (a)
             (lambda (b)
               (lambda (c)
                 (c x)))))))

(define E ; evaluate a quoted lambda term
  ((lambda (m)
    ((lambda (f) (m (lambda (a) ((f f) a))))
     (lambda (f) (m (lambda (a) ((f f) a))))))
   (lambda (E)
     (lambda (t)
       (((t (lambda (M) (lambda (x) (E (M x)))))
         (lambda (M) (lambda (N) ((E M) (E N)))))
        (lambda (x) x))))))

(define test-1
  (E (Q (lambda (i) i))))

(define test-2
  (E (Q (((lambda (m)
            ((lambda (f) (m (lambda (a) ((f f) a))))
             (lambda (f) (m (lambda (a) ((f f) a))))))
          (lambda (E)
            (lambda (t)
              (((t (lambda (M) (lambda (x) (E (M x)))))
                (lambda (M) (lambda (N) ((E M) (E N)))))
               (lambda (x) x)))))
         (lambda (a) (lambda (b) (lambda (c) (a (lambda (i) (lambda (a) (lambda (b) (lambda (c) (c i)))))))))))))

; ((lambda (i) i) 'ok)
; ok 
; > (test-1 'ok)
; ok
; > (test-2 'ok)
; ok

Scheme Pattern Matching with syntax-rules

(define-syntax ?member?
  (syntax-rules ()
    ((_ e () sk fk) fk)
    ((_ e (x . xs) sk fk)
     (let-syntax ((test (syntax-rules (x)
                          ((test x) sk)
                          ((test ?) (?member? e xs sk fk)))))
       (test e)))))

(define-syntax match
  (syntax-rules (quasiquote unquote make-k)
    ((match `() <exp> <env> <sk> <fk>) (if (null? <exp>) <sk> <fk>))
    ((match `,<place> <exp> <env> <sk> <fk>)
     (let-syntax ((extend-environment
                   (syntax-rules (match)
                     ((_ <ext> (match <pattern> <exp2> <env2> <sk2> <fk2>))
                      (match <pattern> <exp2> (<ext> . <env2>) <sk2> <fk2>))
                     ((_ <ext> <else>) <else>))))
       (?member? <place> <env>
                 (if (equal? <exp> <place>) <sk> <fk>)
                 (let ((<place> <exp>))
                   (extend-environment <place> <sk>)))))
    ((match `(<car> . <cdr>) <exp> <env> <sk> <fk>)
     (if (pair? <exp>)
         (let ((exp-car (car <exp>)) (exp-cdr (cdr <exp>)))
           (match `<car> exp-car <env>
                  (match `<cdr> exp-cdr <env> <sk> <fk>) <fk>))
         <fk>))
    ((match `<symbol> <exp> <env> <sk> <fk>)
     (if (equal? '<symbol> <exp>) <sk> <fk>))))

(define-syntax pattern-case*
  (syntax-rules (else)
    ((pattern-case* <exp>)
     (void))
    ((pattern-case* <exp> (else <body> ...))
     (begin <body> ...))
    ((pattern-case* <exp> (<pattern> <body> ...) <clauses> ...)
     (let ((failure (lambda ()
                      (pattern-case* <exp> <clauses> ...))))
       (match <pattern> <exp> () (begin <body> ...) (failure))))))

(define-syntax pattern-case
  (syntax-rules ()
    ((pattern-case <exp> <clauses> ...)
     (let ((exp <exp>))
       (pattern-case* exp <clauses> ...)))))

(define-syntax pattern-lambda
  (syntax-rules ()
    ((pattern-lambda (<pattern> <body> ...) ...)
     (lambda args
       (pattern-case args (<pattern> <body> ...) ...)))))


(define append
  (pattern-lambda
   (`(() ,ys) ys)
   (`((,x . ,xs) ,ys) (cons x (append xs ys)))))

(define simpl
  (pattern-lambda
   (`((+ 0 ,x)) (simpl x))
   (`((+ ,x 0)) (simpl x))
   (`((* 1 ,x)) (simpl x))
   (`((* ,x 1)) (simpl x))
   (`((- ,x 0)) (simpl x))
   (`((- ,x ,x)) 0)
   (`((/ ,x 1)) (simpl x))
   (`((/ ,x ,x)) 1)
   (`((,op ,x ,y)) `(,op ,(simpl x) ,(simpl y)))
   (`(,x) x)))

(define d
  (pattern-lambda
   (`(,x ,x)        1)
   (`(,x (+ ,u ,v)) `(+ ,(d x u) ,(d x v)))
   (`(,x (- ,u ,v)) `(- ,(d x u) ,(d x v)))
   (`(,x (* ,u ,v)) `(+ (* ,u ,(d x v)) (* ,v ,(d x u))))
   (`(,x (/ ,u ,v)) `(/ (- (* ,(d x u) ,v) (* ,(d x v) ,u)) (* ,v ,v)))))