z

z.lisp

(defmacro z (expr)
  (z-unintern 0 (z-rename (z-intern-expr expr))))

(defun z-intern-expr (expr)
  (cond
   ((and (consp expr)
         (eq 'lambda (car expr)))
    (list :tag '$lam
          :var (caadr expr)
          :body (z-intern-expr (caddr expr))))
   ((and (symbolp expr)
         (string-match "^\\$.*$" (symbol-name expr) 0))
    (list :tag '$cons :sym expr))
   ((symbolp expr)
    (list :tag '$var :sym expr))
   ((consp expr)
    (list :tag '$app
          :func (z-intern-expr (car expr))
          :arg (z-intern-expr (cadr expr))))
   (t expr)))

(defun z-unintern (index expr)
  (cl-case (plist-get expr :tag)
    ($app
     (cons (z-unintern index (plist-get expr :func))
           (list (z-unintern index (plist-get expr :arg)))))
    ($var
     (plist-get expr :sym))
    ($debruijn
     (intern (format "v%d" (1- (- index (plist-get expr :index))))))
    ($lam
     (let ((var (plist-get expr :var)))
       (list 'lambda
             (list (intern (format "v%d" index)))
             (z-unintern
              (+ 1 index)
              (plist-get expr :body)))))))

(defun z-rename (expr)
  (z-rename-expr nil 0 expr))

(defun z-rename-expr (vars index expr)
  (cl-case (plist-get expr :tag)
    ($app
     (list :tag '$app
           :func (plist-get expr :func)
           :arg (z-rename-expr vars index (plist-get expr :arg))))
    ($var
     (let ((index. (cdr (assoc (plist-get expr :sym) vars))))
       (if index.
           (list :tag '$debruijn :index (1- (- index index.)))
         (error "renamer: variable not in scope: %s" (plist-get expr :sym)))))
    ($lam
     (let ((var (plist-get expr :var)))
       (list :tag '$lam
             :body (z-rename-expr
                    (cons (cons var index) vars)
                    (+ 1 index)
                    (plist-get expr :body)))))))