;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; ;-*- ;;; Touched: Tue Sep 17 09:10:47 2002 ;;; Time-stamp: <2002-09-18 20:51:46> (in-package "CL-USER") ;;; CS555 Fall 2002 Hw 2 due 2002-09-18 for ;; This file depends on hw1.lisp for lambda-expr classes. That was ;; submitted and is expected to be in the same directory (eval-when (load eval compile) (require 'hw1 "hw1.lisp")) (in-package "LAMBDA2") #+cmu ;; cmucl pcl quirks (shadowing-import '(pcl::standard-class pcl::built-in-class pcl::find-class pcl:class-name pcl::class-of)) ;;; --------------------------------------------------------------------------- ;; datatype CExpr = K|S|I|B|C|Cvar of String| Capp of expr*expr (defclass cexpr () () (:documentation "combinatory expression")) (defclass term-cexpr (cexpr) ((name :initform nil :initarg :name :accessor name))) (defclass app-cexpr (cexpr) ((expr1 :initform nil :initarg :expr1 :accessor expr1) (expr2 :initform nil :initarg :expr2 :accessor expr2))) (defvar K (make-instance 'term-cexpr :name "K")) (defvar S (make-instance 'term-cexpr :name "S")) (defvar I (make-instance 'term-cexpr :name "I")) (defvar C (make-instance 'term-cexpr :name "C")) (defvar B (make-instance 'term-cexpr :name "B")) ;; use lisp object equality (defmethod make-instance ((class (eql (find-class 'term-cexpr))) &key name) (cond ((string-equal name "K") K) ((string-equal name "I") I) ((string-equal name "C") C) ((string-equal name "B") B) ((string-equal name "S") B) (t (call-next-method)))) (defmethod print-object ((e term-cexpr) stream) (format stream "~A" (name e))) ;; quick hack using before and after specializers into CLOS protocol (defmethod print-object ((e app-cexpr) stream)) (defmethod print-object :before ((e app-cexpr) stream) (format stream "(~A" (expr1 e))) (defmethod print-object :after ((e app-cexpr) stream) (format stream "~A)" (expr2 e))) ;;; --------------------------------------------------------------------------- ;;; ;;; Q1 & 2 ;;; ;;; Curry's rules of reduction can be hacked directly into CLOS object ;;; creation. This way expressions are reduced when constrcuted, ;;; thereby answering the questions of space. that graph reduction ;;; truly shares nodes is achieved by lisp object identity. ;;; Using this scheme (make-cexpr lambda-expr) produces a reduced ;;; result rather than constructing a long cexpr and then manipulating ;;; it during reductions ;;; I have throw-away code that actually implements a full combinatory ;;; expression and then reduces it step by step (ala hw1 ;;; mappers/reducers). The scheme I use here seems more practical ;;; (efficient) and more elegant. I'll show the older code if ;;; necessary. (defmethod make-instance ((class (eql (find-class 'app-cexpr))) &key expr1 expr2) (cond ;; S (K E1) (K E2) = ((S (K E1)) (K E2)) --> K (E1 E2) ((and (typep expr1 'app-cexpr) (eq (expr1 expr1) S) (typep (expr2 expr1) 'app-cexpr) (eq (expr1 (expr2 expr1)) K) (typep expr2 'app-cexpr) (eq (expr1 expr2) K)) (call-next-method class :expr1 K :expr2 (make-instance 'app-cexpr :expr1 (expr2 (expr2 expr1)) :expr2 (expr2 expr2)))) ;; S (K E) I = (S (K E)) I = E ((and (typep expr1 'app-cexpr) (eq (expr1 expr1) S) (typep (expr2 expr1) 'app-cexpr) (eq (expr1 (expr2 expr1)) K) (eq expr2 I)) (expr2 (expr2 expr1))) ;; S (K E1) E2 = (S (K E1)) E2 --> B E1 E2 = (B E1) E2 ((and (typep expr1 'app-cexpr) (eq (expr1 expr1) S) (typep (expr2 expr1) 'app-cexpr) (eq (expr1 (expr2 expr1)) K)) (call-next-method class :expr1 (make-instance 'app-cexpr :expr1 B :expr2 (expr2 (expr2 expr1))) :expr2 expr2)) ;; S E1 (K E2) = (S E1) (K E2) --> C E1 E2 = (C E1) E2 ((and (typep expr1 'app-cexpr) (eq (expr1 expr1) S) (typep expr2 'app-cexpr) (eq (expr1 expr2) K)) (call-next-method class :expr1 (make-instance 'app-cexpr :expr1 C :expr2 (expr2 expr1)) :expr2 (expr2 expr2))) ((call-next-method class :expr1 expr1 :expr2 expr2)))) ;;; 8.2 Functional Completeness [p131] to simulate lambda abstraction. (defgeneric make-abs-cexpr (V E)) ;; (i) #*V.V = I ;; (ii) #*V.V' = K V' V,V' different ;; (iii) #*V.C = K C C combinator ;; (iv) #*V.(E1 E2) = S(#*V.E1)(#*V.E2) = ((S expr1) expr2) (defmethod make-abs-cexpr ((V term-cexpr) (E term-cexpr)) (if (string-equal (name V) (name E)) I ; case (i) (make-instance 'app-cexpr ; case (ii), (iii) :expr1 K :expr2 E))) (defmethod make-abs-cexpr ((V term-cexpr) (E app-cexpr)) ; case (iv) (let ((expr1 (make-abs-cexpr V (expr1 E))) (expr2 (make-abs-cexpr V (expr2 E)))) ;; we're generating an S expr1 expr2 -try curry reduce rules below (make-instance 'app-cexpr :expr1 (make-instance 'app-cexpr :expr1 S :expr2 expr1) :expr2 expr2))) ;;; p 133 (E)_C Combinatory expression of a lambda expression (defgeneric make-cexpr (lambda-expr)) (defmethod make-cexpr ((lambda-expr var-expr)) ; (V)_C = V (make-instance 'term-cexpr :name (name lambda-expr))) (defmethod make-cexpr ((lambda-expr app-expr)) ; (E1 E2)_C = ((E1)_C (E2)_C) (make-instance 'app-cexpr :expr1 (make-cexpr (expr1 lambda-expr)) :expr2 (make-cexpr (expr2 lambda-expr)))) (defmethod make-cexpr ((lambda-expr abs-expr)) ; (#V.E)_C = #*V.(E)_C (make-abs-cexpr (make-instance 'term-cexpr :name (name lambda-expr)) (make-cexpr (expr lambda-expr)))) #+tests (progn (setq e1 (make-instance 'term-cexpr :name "E1") e2 (make-instance 'term-cexpr :name "E2") e3 (make-instance 'term-cexpr :name "E3")) (setq bs (make-instance 'app-cexpr :expr1 B :expr2 S)) (defmethod cexpr2lambda ((expr term-cexpr)) (cond ((string-equal (name expr) "K") (getenv "K")) ((string-equal (name expr) "S") (getenv "S")) ((string-equal (name expr) "I") (getenv "I")) ((string-equal (name expr) "B") (getenv "B")) ((string-equal (name expr) "C") (getenv "C")) (t (make-instance 'var-expr :name (name expr))))) (defmethod cexpr2lambda ((expr app-cexpr)) (with-slots (expr1 expr2) expr (make-instance 'app-expr :expr1 (cexpr2lambda expr1) :expr2 (cexpr2lambda expr2)))) (setq e95 ;; S (S (K S) (S (K K) I)) (K (S I I)) (make-instance 'app-cexpr :expr1 ;; S (S (K S) (S (K K) I)) (make-instance 'app-cexpr :expr1 S :expr2 ;; S (K S) (S (K K) I) (make-instance 'app-cexpr :expr1 ;; S (K S) (make-instance 'app-cexpr :expr1 S :expr2 (make-instance 'app-cexpr :expr1 K :expr2 S)) :expr2 ;; (S (K K)) I (make-instance 'app-cexpr :expr1 ;; S (K K) (make-instance 'app-cexpr :expr1 S :expr2 ;; K K (make-instance 'app-cexpr :expr1 K :expr2 K)) :expr2 I))) :expr2 (make-instance ;; K ((S I) I) 'app-cexpr :expr1 K :expr2 (make-instance 'app-cexpr :expr1 (make-instance 'app-cexpr :expr1 S :expr2 I) :expr2 I))) ) (warn "Y=~A" (make-cexpr (getenv "Y"))) (setq e950 (cexpr2lambda e95)) (warn "ex.95=~A" (make-cexpr e950))) #| * (load "hw2.lisp") ; Loading #p"/home/madhu/compiler/cs555/hw2.lisp". ;; Loading #p"/home/madhu/compiler/cs555/hw1.lisp". ;; Warning: Y=((S((CB)((SI)I)))((CB)((SI)I))) Warning: ex.95=((C((BS)K))((SI)I)) T * (in-package :lambda2) # ;;; Note exercise 95 is incorrect in the handout. ;;; working out on paper yields the above result. ;;; print out combinatory expressions for all top level lambda exprs * (let ((x nil)) (maphash #'(lambda (k v) (push k x)) *environment*) x) ;;; ("FST" "NOT" "I" "ZERO" "FALSE" "TRUE" "PAIR" "OMEGA" "Y" "C" "B" "S" "K" "ONE") * (make-cexpr (getenv "FST")) ((CI)TRUE) * (make-cexpr (getenv "NOT")) ((C((CI)FALSE))TRUE) * (make-cexpr (getenv "I")) I * (make-cexpr (getenv "ZERO")) (KI) * (make-cexpr (getenv "FALSE")) K * (make-cexpr (getenv "TRUE")) K * (make-cexpr (getenv "PAIR")) ((BC)(CI)) * (make-cexpr (getenv "OMEGA")) ((SI)I) * (make-cexpr (getenv "Y")) ((S((CB)((SI)I)))((CB)((SI)I))) * (make-cexpr (getenv "C")) C * (make-cexpr (getenv "B")) B * (make-cexpr (getenv "S")) S * (make-cexpr (getenv "K")) K * (make-cexpr (getenv "ONE")) I * |#