;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; ;-*-
;;; Touched: Tue Sep  3 10:37:25 2002 <enometh@meer.net>
;;; Time-stamp: <2002-09-04 21:48:14>
(in-package "CL-USER")
(unless (find-package "LAMBDA2")
  (defpackage "LAMBDA2"))
(in-package "LAMBDA2")
(pushnew :tests *features*)

;;; ---------------------------------------------------------------------------
;;; Assignment 1 due 8/4 cs555 fall 2002 [for darko@cs]

;; MAPPING - Internal representation using CLOS classes
;; lambda-expr = var-expr (string)
;;             | app-expr (lambda-expr * lambda-expr)
;;             | abs-expr (string * lambda-expr)

;; ASSUMPTIONS on representing lambda expressions

;; There is no whitespace in the character string representation of
;; lambda expressions

;; Variables are either a single lowercase character eg. "x", or can
;; be a word consisting of uppercase characters and digits (they
;; should begin with an uppercase character.) eg. "TRUE" or "V1344"
;; (so we can use Common Lisp #'gensym)

;; These are also treated as top level identifiers to name lambda
;; expressions

;; LIMITATION: this assumption makes it impossible to parse loose
;; syntax because of ambiguities such as (TRUEFALSE). Parsing loose
;; syntax is therefore not yet implemented. The fix is to allow
;; variables of multiple characters to be delimited by ||,
;; eg. "|True|" (TODO).

(defclass lambda-expr () ())

(defclass var-expr (lambda-expr)
  ((name :initform nil :initarg :name :accessor name)))

(defclass app-expr (lambda-expr)
  ((expr1 :initform nil :initarg :expr1 :accessor expr1)
   (expr2 :initform nil :initarg :expr2 :accessor expr2)))

(defclass abs-expr (lambda-expr)
  ((name :initform nil :initarg :name  :accessor name )
   (expr :initform nil :initarg :expr  :accessor expr)))


;;; ---------------------------------------------------------------------------
;;; Q1 lexp-print - strict printer.

(defmethod to-string1 ((e var-expr))
  (name e))

(defmethod to-string1 ((e app-expr))
  (concatenate 'string "("  (to-string1 (expr1 e)) (to-string1 (expr2 e)) ")"))

(defmethod to-string1 ((e abs-expr))
  (concatenate 'string "(#" (name e) "." (to-string1 (expr e)) ")"))

(defun LEXP-PRINT (e) (to-string1 e))

(defmethod print-object ((expr lambda-expr) stream) ; CLOS protocol
  (print-unreadable-object (expr stream)
    (call-next-method)
    (format stream "~T~A" (lexp-print expr))))

#+tests
(progn 
  (setq x1 (make-instance 'var-expr :name "X1"))
  (setq x2 (make-instance 'var-expr :name "X2"))
  (setq x3 (make-instance 'var-expr :name "X3"))
  (setq a1 (make-instance 'app-expr :expr1 x1 :expr2 x2))
  (setq b1 (make-instance 'abs-expr :name "B1" :expr a1))
  (lexp-print b1))

;;; ---------------------------------------------------------------------------
;;; Q2 lexp-pretty-print - to loose syntax according to the rules:

;; R1)  APP associates to left.
;; E1 E2 .. En = (((..((E1 E2) .. En))))
;; (Eg). E1 E2 E3 = ((E1 E2) E3)

;; R2) ABS extends as far to the right as possible
;; \v. E2 .. En = (\v.(E1 E2 En))))

;; R3) Several immediately nested abstractions can be abbreviated
;; \v1 v2 v3 ... vn . E = (\ v1 (... (\vn.E)))

(defgeneric to-string2 (e &optional recursive-p))

(defmethod to-string2 ((e var-expr) &optional (recursive-p nil))
  (declare (ignore recursive-p))
  (name e))

(defmethod to-string2 ((e app-expr) &optional (recursive-p nil))
  (declare (ignore recursive-p))
  (with-slots (expr1 expr2) e
    (etypecase expr1 ;; this is pretty horrible but at least it works
      (app-expr
       (etypecase expr2
	 (var-expr (concatenate 'string (to-string2 expr1)
				(to-string2 expr2)))
	 (app-expr (concatenate 'string "(" (to-string2 expr1) ")("
				(to-string2 expr2) ")"))
	 (abs-expr (concatenate 'string (to-string2 expr1)
				"(" (to-string2 expr2) ")"))))
      (abs-expr
       (etypecase expr2
	 (var-expr (concatenate 'string "(" (to-string2 expr1) ")"
				(to-string2 expr2)))
	 (app-expr (concatenate 'string "(" (to-string2 expr1) ")("
				(to-string2 expr2) ")"))
	 (abs-expr (concatenate 'string "(" (to-string2 expr1) ")"
				"(" (to-string2 expr2) ")") )))
      (var-expr
       (etypecase expr2
	 (var-expr (concatenate 'string (to-string2 expr1)
				(to-string2 expr2)))
	 (app-expr (concatenate 'string (to-string2 expr1) "("
				(to-string2 expr2) ")"))
	 (abs-expr (concatenate 'string (to-string2 expr1)
				"(" (to-string2 expr2) ")") ))))))
      

(defmethod to-string2 ((e abs-expr) &optional (recursive-p nil))
  (if (not recursive-p)
      (if (typep (expr e) 'abs-expr)
	  (concatenate 'string "#" (name e) (to-string2 (expr e) t))
	  (concatenate 'string "#" (name e) "." (to-string2 (expr e) t)))
      (if (typep (expr e) 'abs-expr)
	  (concatenate 'string (name e) (to-string2 (expr e) t))
	  (concatenate 'string (name e) "." (to-string2 (expr e) t)))))


(defun LEXP-PRETTY-PRINT (e)  (to-string2 e))

#+tests
(progn 
  (setq a2 (make-instance 'app-expr :expr1 a1 :expr2 a1))
  (setq a3 (make-instance 'app-expr :expr1 a2 :expr2 a1))
  (setq b2 (make-instance 'abs-expr :name "X1" :expr a3))
  (setq b3 (make-instance 'abs-expr
			  :name "X1"
			  :expr (make-instance 'abs-expr
					       :name "X2"
					       :expr a1))))

;;; ---------------------------------------------------------------------------
;;; Q3 (see ASSUMPTIONS above)

;;; TODO finish implementing loose syntax after deciding on a way to
;;; delimit identifiers such as for an app-expr like (|TRUE||FALSE|)

(defun read-expr (&optional (stream *standard-input*)
		  (eof-errorp t)
		  (eof-value nil)
		  (recursive-p nil))
  (declare (ignore eof-errorp eof-value recursive-p))
  (let ((c (read-char stream)))
    (if (char-equal  c #\()
	(let ((ret (if (char-equal (peek-char nil stream) #\#)
		       (let ((lambda (read-char stream))
			     (name (read-expr stream))
			     (dot (read-char stream))
			     (expr (read-expr stream)))
			 (assert (char-equal dot #\.))
			 (assert (char-equal lambda #\#))
			 (make-instance 'abs-expr
					:name (name name) :expr expr))
		       (let ((expr1 (read-expr stream))
			     (expr2 (read-expr stream)))
			 (make-instance 'app-expr
					:expr1 expr1 :expr2 expr2)))))
	  (let ((rparen (read-char stream)))
	    (assert (char-equal rparen #\))))
	  ret)
	(cond				; we have a character (variable)
	  ((lower-case-p c) (make-instance 'var-expr :name (string c)))
	  ((char-equal c #\|)
	   (loop for x = (peek-char nil stream)
		 until (char-equal x #\|)
		 collect (read-char stream) into s 
		 finally
		 (assert (char-equal (read-char stream) #\|))
		 (return (make-instance
				  'var-expr :name (coerce s 'string)))))
	  (t (loop for x  = (peek-char nil stream nil)
		   while (and x (or (upper-case-p x) (digit-char-p x)))
		   collect (read-char stream) into s
		   finally (return (make-instance 'var-expr
						  :name (coerce
							 (cons c s)
							 'string)))))))))
(defun	LEXP-PARSE (string)
  (with-input-from-string (stream string)
    (read-expr stream t nil nil)))

#+tests
(progn
  (lexp-parse  "(#x.(xx))"))

;;; ---------------------------------------------------------------------------
;;; Q4 Our Environment is just Common Lisp hashtable of string -> lambda-expr

(defvar *environment* (make-hash-table :test #'equal))

(defun clone-environment (&optional (environment *environment*))
  (let ((h (make-hash-table :test #'equal)))
    (maphash #'(lambda (k e) (setf (gethash k h) e)) environment)
    h))

(defun print-environment (&optional (environment *environment*)
			  (stream *standard-output*))
  (maphash #'(lambda (k e)
	       (format stream "~A~T=~T~A~&" k (lexp-print e))) environment))

;; Set/Get identified expressions in/from environment 

(defun setenv (name expr &optional (environment *environment*))
  (check-type name base-string)
  (check-type expr lambda-expr)
  (setf (gethash name environment) expr))

(defun getenv (name  &optional (environment *environment*)
	       &key (if-does-not-exist :soft)) ;todo
  (check-type name base-string)
  (let ((expr (gethash name environment)))
    (when expr (check-type expr lambda-expr))
    expr))
    
;; build the given library into the default environment
(setenv "ONE" (lexp-parse "(#x.x)" ))
(setenv "K" (lexp-parse "(#x.(#y.x))"))
(setenv "S" (lexp-parse "(#f.(#g.(#x.((fx)(gx)))))"))
(setenv "B" (lexp-parse "(#f.(#g.(#x.(f(gx)))))"))
(setenv "C" (lexp-parse "(#f.(#g.(#x.((fx)g))))"))
(setenv "Y" (lexp-parse "(#f.((#x.(f(xx)))(#x.(f(xx)))))"))
(setenv "OMEGA" (lexp-parse "(#x.(xx))" ))
(setenv "PAIR" (lexp-parse "(#E1.(#E2.(#f.((fE1)E2))))"))
(setenv "TRUE" (lexp-parse "(#x.(#y.x))"))
(setenv "FALSE" (lexp-parse "(#x.(#y.x))"))
(setenv "ZERO" (lexp-parse "(#f.(#x.x))"))
(setenv "I" (lexp-parse "(#x.x)"))


;;; ---------------------------------------------------------------------------
;;; Q5 top level loop = common lisp REPL (read-eval-print-loop)

;; Eg:
;; -> (setenv "name" (lexp-parse <string>))
;;           parses <string> into a lambda expression and puts it in
;;           the top level environment with the identifier "name" and
;;           prints a representation in strict syntax

;; -> (reduction <lambda-expr> <keyword-args>)
;;           reduces <lambda-expr> by rewriting according to rules
;;           specified in keyword-args and prints the steps. This
;;           function is defined below



;; The framework ought to be able to print reduction steps at each
;; step.  It ought to allow interleaving reductions.

;; These requirements motivate the following design decisions. We have
;; three types of functions. [1] redex-MAPPER functions that take two
;; arguments (a lambda-expr and a function), that find a suitable
;; redex and applies f to it. [2] CONVERT functions that take an
;; expression and convert it (or leave it unchanged) [3] REDUCE
;; functions that repeatedly apply conversions until no more
;; reductions are possible.

;; We choose to use CommonLisp features to implement these functions.

;; We return multiple-values in the mapper functions, in particular
;; using a boolean second value to terminate recursion.

;; We carefully write the mapper functions so that they copy
;; expressions only on "write" so we can use Common Lisp object
;; identity to test whether they are unchanged (in the reduce
;; functions).



;;; ---------------------------------------------------------------------------
;;; Q6 BETA ETA and ZETA reductions


(defun freevars (expr)			; list of string names
  (etypecase expr
    (var-expr (list (name expr)))
    (app-expr (union (freevars (expr1 expr)) (freevars (expr2 expr))
		     :test #'equalp))
    (abs-expr (set-difference (freevars (expr expr))
			      (list (name expr)) :test #'equalp))))
#+tests
(progn 
  (freevars (lexp-parse "((#x.x)x)")))

(defun substitution (e x v)		; substitite v for x in e, x string
  (etypecase e				; from class notes
    (var-expr (if (string-equal (name e) x)  (setq e v)  e))
    (app-expr (make-instance 'app-expr
			     :expr1 (substitution (expr1 e) x v)
			     :expr2 (substitution (expr2 e) x v)))
    (abs-expr
     (let ((a (name e)) (b (expr e)))
       (cond ((or (string-equal a x) 
		  (not (find x (freevars b) :test #'equal)))
	      e)
	     ((and (not (string-equal a x))
		   (not (find a (freevars v) :test #'equal)))
	      (make-instance 'abs-expr :name (name e)
			     :expr (substitution b x v)))
	     ((and (not (string-equal a x))
		   (find a (freevars v) :test #'equal))
	      (let ((z (make-instance 'var-expr :name (string (gensym "V")))))
		(substitution (make-instance 'abs-expr
					     :name (name z)
					     :expr (substitution b a z))
			      x v)))
	     (t (error "fell through")))))))

#+tests
(progn
  (substitution (lexp-parse "(#y.(yx))") "x" (lexp-parse "y")))


;;; Beta conversion  ((#v.L) m) -> l[v:=m]
;;; ======================================

;; convert a beta-redex if applicable
(defun BETA-CONVERT (expr)
  (if (and (typep expr 'app-expr)
	   (typep (expr1 expr) 'abs-expr))
      (substitution (expr (expr1 expr)) (name (expr1 expr))
		    (expr2 expr))
      expr))

;; We need to find the leftmost outermost and leftmost innermost beta
;; redexes in lambda expressions. These two continuations apply the
;; given function f to the appropriate redex and return the new
;; expression. f is of type beta-redex => lambda-expr

;; leftmost-outer-redex is a mapper that applies f to the leftmost
;; outermost beta-redex of the given expr
(defun leftmost-outermost-redex (expr f)
  (etypecase expr
    (var-expr (values expr t))
    (app-expr
     (or 
      (if (typep (expr1 expr) 'abs-expr)
	  (values (funcall f expr) nil))
      (multiple-value-bind (r p) (leftmost-outermost-redex (expr1 expr) f)
	(unless p 
	  (values (make-instance 'app-expr :expr1 r :expr2 (expr2 expr)) nil)))
      (multiple-value-bind (r p) (leftmost-outermost-redex (expr2 expr) f)
	(unless p
	  (values (make-instance 'app-expr :expr1 (expr2 expr) :expr2 r) nil)))
      (values expr t)))
    (abs-expr
     (multiple-value-bind (r p) (leftmost-outermost-redex (expr expr) f)
       (if (not p)
	   (values (make-instance 'abs-expr :name (name expr) :expr r) nil)
	   (values expr t))))))


;; leftmost-innermost-redex is a mapper that applies f to the leftmost
;; innermost beta-redex of the given expr
(defun leftmost-innermost-redex (expr f)
  (etypecase expr
    (var-expr (values expr t))
    (app-expr 
     (or
      (multiple-value-bind (r p) (leftmost-innermost-redex (expr1 expr) f)
	(unless p
	  (values (make-instance 'app-expr :expr1 r :expr2 (expr2 expr)) nil)))
      (multiple-value-bind (r p) (leftmost-innermost-redex (expr2 expr) f)
	(unless p
	  (values (make-instance 'app-expr :expr1 (expr2 expr) :expr2 r) nil)))
      (if (typep (expr1 expr) 'abs-expr)
	  (values (funcall f expr) nil))
      (values expr t)))
    (abs-expr
     (multiple-value-bind (r p) (leftmost-innermost-redex (expr expr) f)
       (if (not p)
	   (values (make-instance 'abs-expr :name (name expr) :expr r) nil)
	   (values expr t))))))

#+tests
(progn
  (let ((expr (lexp-parse "((#x.(#y.y))((#z.(zz))(#z.(zz))))")))
    (flet ((f (x)
	     (warn "<~A>" x) (values x nil)))
      (leftmost-outermost-redex expr #'f)
      (leftmost-innermost-redex expr #'f) nil)))


;; repeatedly perform Beta conversions
(defun beta-reduce (expr &key (normal t) (stream *standard-output*))
  (format stream "BETA-REDUCE ~A-ORDER~&  ~A~&"
	  (if normal "NORMAL" "APPLICATIVE") (lexp-print expr))
  (loop
   (multiple-value-bind (r p)
       (if normal
	   (leftmost-outermost-redex expr #'beta-convert)
	   (leftmost-innermost-redex expr #'beta-convert))
     (cond ((eq r expr) (assert p) (return))
	   (t (format stream "--> ~A~&" (lexp-print r))
	      (setq expr r))))))

#+tests
(progn
  (let ((expr (lexp-parse "(((#y.(#z.(zy)))c)(#x.x))")))
    (beta-reduce expr :normal nil))
  (let ((expr (lexp-parse  "((#x.(#y.y))((#z.(zz))(#z.(zz))))")))
    (beta-reduce expr :normal t)) )


;;; Eta Converion:  (#v.(Lv)) --> l if v isnt in FV[l]
;;; =================================================

;; convert one eta-redex if applicable
(defun eta-convert (expr)
  (if (and (typep expr 'abs-expr)
	   (typep (expr expr) 'app-expr)
	   (typep (expr2 (expr expr)) 'var-expr)
	   (string-equal (name expr) (name (expr2 (expr expr))))
	   (not (find (name expr) (freevars (expr1 (expr expr))))))
      (expr2 (expr expr))
      expr))


;; mapper function that applies f to an Eta-redex of expr
(defun map-eta-redex (expr f)
  (etypecase expr
    (var-expr (values expr t))
    (app-expr
     (or
      (multiple-value-bind (r p) (map-eta-redex (expr1 expr) f)
       (unless p
	 (values (make-instance 'app-expr :expr1 r :expr2 (expr2 expr)) nil)))
      (multiple-value-bind (r p) (map-eta-redex (expr2 expr) f)
	(unless p
	  (values (make-instance 'app-expr :expr1 (expr1 expr) :expr2 r) nil)))
      (values expr t)))
    (abs-expr
     (if (and (typep (expr expr) 'app-expr)
	      (typep (expr2 (expr expr)) 'var-expr)
	      (string-equal (name expr) (name (expr2 (expr expr))))
	      (not (find (name expr) (freevars (expr1 (expr expr))))))
	 (values (funcall f expr) nil)
	 (values expr t)))))

;; repeatedly do eta-conversions
(defun eta-reduce (expr &key (stream *standard-output*))
  (format stream "ETA-REDUCE~&   ~A~&" (lexp-print expr))
  (loop
   (multiple-value-bind (r p) (map-eta-redex expr #'eta-convert)
     (cond ((or p(eq r expr)) (assert p) (return r))
	   (t (format stream "--> ~A~&" (lexp-print r))
	      (setq expr r))))))

;;; ZETAS
;;; =====

;;; This is currently a hack. Zeta-reduce-1 macro-expands all top
;;; level variables in the given expression. This works because all
;;; top level variables are UPPERCASE (with digit characters) anyways.
;;; So it is not possible to define recursive defintions in the
;;; top-level

(defun ZETA-REDUCE-1 (expr &optional (env *environment*))
  (etypecase expr
    (var-expr
     (let ((term (getenv (name expr) env)))
       (when term term)))
    (app-expr
     (let ((expr1 (zeta-reduce-1 (expr1 expr) env))
	   (expr2 (zeta-reduce-1 (expr2 expr) env)))
       (if expr1
	   (if expr2
	       (make-instance 'app-expr :expr1 expr1 :expr2 expr2)
	       (make-instance 'app-expr :expr1 expr1 :expr2 (expr2 expr)))
	   (if expr2
	       (make-instance 'app-expr :expr1 (expr1 expr) :expr2 expr2)))))
    (abs-expr 				;; names dont get expanded anyway
     (let ((e (zeta-reduce-1 (expr expr) env)))
       (when e (make-instance 'abs-expr :name (name expr) :expr e))))))


;; add some more library expressions to top level, since we can
;; macroexpand now
(setenv "NOT" (lexp-parse "(#t.((tFALSE)TRUE))"))
(setenv "FST" (lexp-parse "(#p.(p|TRUE|))"))


#+tests
(progn
  (zeta-reduce-1 (getenv "NOT")))


;; generic reduction framework for Q5
;; ==================================

;; repeatedly applies the conversions specified in the order
;; specified.  the conversions and their order are listed in
;; `conversions', a keyword argument that specifies a list such as
;; (:eta :beta)
(defun reduction (expr &key (normal t) (conversions '(:beta))
		  (stream *standard-output*) &aux (changed nil))
  (assert (listp conversions))
  (when (find :beta conversions)
    (format stream "~A-ORDER BETA-REDUCTIONS~&"
	    (if normal "NORMAL" "APPLICATIVE")))
  (format stream "applying REDUCTIONs ~A on ~A~&"
	  conversions (lexp-print expr))
  ;; hack:  macro expand all identifiers first
  (let ((e (zeta-reduce-1 expr)))	
    (when e
      (unless (eq e expr)
	(format stream "ZETA:~T~T--> ~A~&" (lexp-print e))
	(setq expr e))))
  (loop
   (setq changed nil)
   (multiple-value-bind (r p)
       (loop for x in conversions do
	     (multiple-value-bind (r p)
		 (ecase x
		   (:eta
		    (format stream " ETA:")
		    (map-eta-redex expr #'eta-convert))
		   (:beta
		    (format stream "BETA:")
		    (if normal
			(leftmost-outermost-redex expr #'beta-convert)
			(leftmost-innermost-redex expr #'beta-convert))))
	       (format stream "~T~T-->~A~&" (lexp-print r))
	       (cond ((eq expr r) (assert p) r)
		     (t (setq changed t)
			(setq expr r))))
	     finally (return (values expr t)))
     (cond ((not changed) (assert p) (return r))
	   (t (format stream "     ~T~T-->~A~&" (lexp-print r))
	      (setq expr r))))))
	     
			   
#+tests
(progn
  (let ((expr (lexp-parse  "((#x.(#y.y))((#z.(zz))(#z.(zz))))")))
    (reduction  expr :normal t :conversions '(:beta)))
  #+nil
  (let ((expr (lexp-parse "((|S||K|)K)")))
    (reduction expr :conversions '(:zeta))))

;;; ---------------------------------------------------------------------------
;;; Q7

#+tests
(progn 
  (setq c1 (lexp-parse "((|S||K|)K)"))
  (setq c2 (lexp-parse "(K((|S||I|)I))"))
  (setq c3 (lexp-parse "((S((S(|K||S|))(|K||I|)))(|K||I|))"))
  (setq c4 (lexp-parse "((((((|S||S|)S)S)S)S)S)"))
)


#|
TRANSCRIPT

* (load "hw1")
; Loading #p"/home/madhu/compiler/cs555/hw1.lisp".
<snip>
T


* (in-package :lambda2)
#<The LAMBDA2 package, 160/192 internal, 0/2 external>


*  (reduction c1 :conversions '(:beta :eta))
NORMAL-ORDER BETA-REDUCTIONS
applying REDUCTIONs (BETA ETA) on ((SK)K)
ZETA:  --> (((#f.(#g.(#x.((fx)(gx)))))(#x.(#y.x)))(#x.(#y.x)))
BETA:  -->((#g.(#x.(((#x.(#y.x))x)(gx))))(#x.(#y.x)))
 ETA:  -->((#g.(#x.(((#x.(#y.x))x)(gx))))(#x.(#y.x)))
       -->((#g.(#x.(((#x.(#y.x))x)(gx))))(#x.(#y.x)))
BETA:  -->(#x.(((#x.(#y.x))x)((#x.(#y.x))x)))
 ETA:  -->(#x.(((#x.(#y.x))x)((#x.(#y.x))x)))
       -->(#x.(((#x.(#y.x))x)((#x.(#y.x))x)))
BETA:  -->(#x.((#y.x)((#x.(#y.x))x)))
 ETA:  -->(#x.((#y.x)((#x.(#y.x))x)))
       -->(#x.((#y.x)((#x.(#y.x))x)))
BETA:  -->(#x.x)
 ETA:  -->(#x.x)
       -->(#x.x)
BETA:  -->(#x.x)
 ETA:  -->(#x.x)
#<#<ABS-EXPR {48964325}> (#x.x)>

*  (beta-reduce (zeta-reduce-1 c1))
BETA-REDUCE NORMAL-ORDER
  (((#f.(#g.(#x.((fx)(gx)))))(#x.(#y.x)))(#x.(#y.x)))
--> ((#g.(#x.(((#x.(#y.x))x)(gx))))(#x.(#y.x)))
--> (#x.(((#x.(#y.x))x)((#x.(#y.x))x)))
--> (#x.((#y.x)((#x.(#y.x))x)))
--> (#x.x)
NIL


* (beta-reduce (zeta-reduce-1 c2))
BETA-REDUCE NORMAL-ORDER
  ((#x.(#y.x))(((#f.(#g.(#x.((fx)(gx)))))(#x.x))(#x.x)))
--> (#y.(((#f.(#g.(#x.((fx)(gx)))))(#x.x))(#x.x)))
--> (#y.((#g.(#x.(((#x.x)x)(gx))))(#x.x)))
--> (#y.(#x.(((#x.x)x)((#x.x)x))))
--> (#y.(#x.(x((#x.x)x))))
--> (#y.(#x.(((#x.x)x)x)))
--> (#y.(#x.(xx)))
NIL


* (beta-reduce (zeta-reduce-1 c3))
BETA-REDUCE NORMAL-ORDER
  (((#f.(#g.(#x.((fx)(gx)))))(((#f.(#g.(#x.((fx)(gx)))))((#x.(#y.x))(#f.(#g.(#x.((fx)(gx)))))))((#x.(#y.x))(#x.x))))((#x.(#y.x))(#x.x)))
--> ((#g.(#x.(((((#f.(#g.(#x.((fx)(gx)))))((#x.(#y.x))(#f.(#g.(#x.((fx)(gx)))))))((#x.(#y.x))(#x.x)))x)(gx))))((#x.(#y.x))(#x.x)))
--> (#x.(((((#f.(#g.(#x.((fx)(gx)))))((#x.(#y.x))(#f.(#g.(#x.((fx)(gx)))))))((#x.(#y.x))(#x.x)))x)(((#x.(#y.x))(#x.x))x)))
--> (#x.((((#g.(#x.((((#x.(#y.x))(#f.(#g.(#x.((fx)(gx))))))x)(gx))))((#x.(#y.x))(#x.x)))x)(((#x.(#y.x))(#x.x))x)))
--> (#x.(((#x.((((#x.(#y.x))(#f.(#g.(#x.((fx)(gx))))))x)(((#x.(#y.x))(#x.x))x)))x)(((#x.(#y.x))(#x.x))x)))
--> (#x.(((((#x.(#y.x))(#f.(#g.(#x.((fx)(gx))))))x)(((#x.(#y.x))(#x.x))x))(((#x.(#y.x))(#x.x))x)))
--> (#x.((((#y.(#f.(#g.(#x.((fx)(gx))))))x)(((#x.(#y.x))(#x.x))x))(((#x.(#y.x))(#x.x))x)))
--> (#x.(((#f.(#g.(#x.((fx)(gx)))))(((#x.(#y.x))(#x.x))x))(((#x.(#y.x))(#x.x))x)))
--> (#x.((#g.(#V4209.(((((#x.(#y.x))(#x.x))x)V4209)(gV4209))))(((#x.(#y.x))(#x.x))x)))
--> (#x.(#V4209.(((((#x.(#y.x))(#x.x))x)V4209)((((#x.(#y.x))(#x.x))x)V4209))))
--> (#x.(#V4209.((((#y.(#x.x))x)V4209)((((#x.(#y.x))(#x.x))x)V4209))))
--> (#x.(#V4209.(((#x.x)V4209)((((#x.(#y.x))(#x.x))x)V4209))))
--> (#x.(#V4209.(V4209((((#x.(#y.x))(#x.x))x)V4209))))
--> (#x.(#V4209.(((((#x.(#y.x))(#x.x))x)V4209)(((#y.(#x.x))x)V4209))))
--> (#x.(#V4209.((((#y.(#x.x))x)V4209)(((#y.(#x.x))x)V4209))))
--> (#x.(#V4209.(((#x.x)V4209)(((#y.(#x.x))x)V4209))))
--> (#x.(#V4209.(V4209(((#y.(#x.x))x)V4209))))
--> (#x.(#V4209.((((#y.(#x.x))x)V4209)((#x.x)V4209))))
--> (#x.(#V4209.(((#x.x)V4209)((#x.x)V4209))))
--> (#x.(#V4209.(V4209((#x.x)V4209))))
--> (#x.(#V4209.(((#x.x)V4209)V4209)))
--> (#x.(#V4209.(V4209V4209)))
NIL


*  (reduction  (lexp-parse "((((((|S||S|)S)S)S)S)S)") :normal t)
<SNIP-MEGABYTES-OF-CONVERSION>
#<#<ABS-EXPR
    {4823F7DD}> (#x.(#V1720.(((((x(#V3565.((xV3565)(V1720V3565))))(V1720(#V3565.((xV3565)(V1720V3565)))))((x(#V3565.((xV3565)(V1720V3565))))(V1720(#V3565.((xV3565)(V1720V3565))))))(((x(#V3565.((xV3565)(V1720V3565))))(V1720(#V3565.((xV3565)(V1720V3565)))))((x(#V3565.((xV3565)(V1720V3565))))(V1720(#V3565.((xV3565)(V1720V3565)))))))((((x(#V3565.((xV3565)(V1720V3565))))(V1720(#V3565.((xV3565)(V1720V3565)))))((x(#V3565.((xV3565)(V1720V3565))))(V1720(#V3565.((xV3565)(V1720V3565))))))(((x(#V3565.((xV3565)(V1720V3565))))(V1720(#V3565.((xV3565)(V1720V3565)))))((x(#V3565.((xV3565)(V1720V3565))))(V1720(#V3565.((xV3565)(V1720V3565))))))))))>
* 

|#