(require (lib "reduction-semantics.ss" "reduction-semantics")
	 (lib "gui.ss" "reduction-semantics")
         (lib "match.ss")
         "sets.scm") ; <-- download from schedule page, too
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Expression grammar:

(define grammar
  (language (M (M M)
	       X
	       (lambda variable M))
            (X variable)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Free-vars and substitution:

(define (free-vars M)
  (match M
    [`(lambda ,X ,M1) (set-minus (free-vars M1) X)]
    [`(,M1 ,M2) (set-union (free-vars M1) (free-vars M2))]
    [X (singleton-set X)]))

;; M[Xr <- Mr]
(define (lc-subst M Xr Mr)
  (match M
    [`(lambda ,X ,M1)
     (if (eq? X Xr)
	 M
         ;; avoid generating a new name by keeping X
         ;;  if it's not free in Mr; if we keep X,
         ;;  we can also skip a substitution step below
         (let ([Y (if (is-in-set? X (free-vars Mr))
                      (variable-not-in Mr 'X)
                      X)])
           `(lambda ,Y ,(lc-subst (if (eq? X Y)
                                      M1
                                      (lc-subst M1 X Y))
                                  Xr Mr))))]
    [`(,M1 ,M2) `(,(lc-subst M1 Xr Mr) ,(lc-subst M2 Xr Mr))]
    [X (if (eq? X Xr)
	   Mr
	   M)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reduction rules:

;; beta and eta reductions

(define beta 
  (reduction 
   grammar
   ((lambda X_1 M_1) M_2)
   (lc-subst (term M_1) (term X_1) (term M_2))))

(define eta
  (reduction
   grammar
   (side-condition
    (lambda X_1 (M_1 X_1))
    (not (is-in-set? (term X_1) (free-vars (term M_1)))))
   (term M_1)))

;; ->n = union of compatible closure of beta and eta
(define ->n (map (lambda (red)
		   (compatible-closure red grammar 'M))
		 (list beta eta)))

;; Uses just beta:
(traces grammar ->n '(((lambda x (lambda z x)) (lambda y z)) y))

;; Uses both beta and eta, and shows that ->n doesn't
;; always lead to exactly the same expression, and that's
;; why alpha needs to be part of the real ->n relation
(traces grammar ->n '(lambda y (((lambda x (lambda z x)) (lambda y z)) y)))