gistfile1.lisp

(defun singlep (x) (and (consp x) (not (consp (cdr x)))))

(defun lambda-form? (form)
  (and (consp form)
       (eq (car form) 'lambda)
       (every #'atom (cadr form))
       (singlep (cddr form))))

(defun normalize-lambda-form (form)
  (labels ((devide-lambda-list (vars body)
	     (if vars
		 `(lambda (,(car vars)) ,(devide-lambda-list (cdr vars) body))
		 body))
	   (normalize-application (application)
	     (if (>= (length application) 3)
		 (normalize-application `((,(first application) ,(second application)) ,@(cddr application)))
		 application)))
    (cond ((atom form) form)
	  ((lambda-form? form) (devide-lambda-list (second form) (normalize-lambda-form (third form))))
	  ((>= (length form) 3) (normalize-lambda-form (normalize-application form)))
	  (t (mapcar #'normalize-lambda-form form)))))

(defun deepest-lambda? (tree)
  (if (lambda-form? tree)
      (not (find-tree 'lambda (third tree)))))

(defun find-tree (q tree)
  (if (consp tree)
      (or (find-tree q (car tree)) (find-tree q (cdr tree)))
      (eq q tree)))

(defun free-variable? (var form)
  (cond ((atom form)                 (not (eq var form)))
	((and (lambda-form? form) 
	      (eq (caadr form) var)) t)
	((lambda-form? form)         (free-variable? var (third form)))
	(t                           (every #'(lambda (x) (free-variable? var x)) form))))

(defun skconvert-1 (nlambda)
  "converts lambda expression to sk combination. nlambda must be lambda expression"
  (destructuring-bind (_ (x) application) nlambda
    (declare (ignore _))
    (cond ((eq x application) 
	   '((S K) k))
	  ((or (atom application) (free-variable? x application)) 
	   `(K ,application))
	  ((and (eq (second application) x) (free-variable? x (first application)))
	   (first application)) ;eta-convertion
	  (t
	   `((S (lambda (,x) ,(car application))) (lambda (,x) ,(cadr application)))))))

(defun skconvert-all (nlambda)
    (cond ((atom nlambda) nlambda)
	((deepest-lambda? nlambda) (skconvert-1 nlambda))
	((lambda-form? nlambda)    `(lambda ,(second nlambda) ,(skconvert-all (third nlambda))))
	((consp nlambda)            `(,(skconvert-all (first nlambda)) ,(skconvert-all (second nlambda))))))

(defun skconvert (nlambda)
  (loop 
     for sk = (normalize-lambda-form nlambda) then (skconvert-all sk)
     while (find-tree 'lambda sk)
     finally (return (simplize-sk sk))))

(defun simplize-sk (sk)
  (if (consp sk)
      (destructuring-bind (l r) sk
	(let ((nl (simplize-sk l))
	      (nr (simplize-sk r)))
	  (if (consp nl) 
	      `(,@nl ,nr)
	      (list nl nr))))
      sk))