;; Execute this code in the "(module ...)" language in DrScheme, then
;;  try out an evaluation like this:
;;     (gui iswim-grammar ->v '(("lam" x ("+" x ("-" 4 3))) 7))
(module iswim mzscheme
  (require (lib "reduction-semantics.ss" "reduction-semantics")
	   (lib "match.ss")
           (lib "subst.ss" "reduction-semantics")
           (lib "gui.ss" "reduction-semantics"))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Expression grammar:
  
  (define iswim-grammar
    (language (M (M M)
		 (o1 M)
		 (o2 M M)
		 V)
	      (V X
		 ("lam" X M)
		 b)
	      (X variable)
	      (b number)
	      (o1 "add1" "sub1" "iszero")
	      (o2 "+" "-" "*" "^")
	      (on o1 o2)
             
	      ;; Evaluation contexts:
	      (E hole
		 (E M)
		 (V E)
		 (o1 E)
		 (o2 E M)
		 (o2 V E))))

  (define M? (language->predicate iswim-grammar 'M))
  (define V? (language->predicate iswim-grammar 'V))

  (define X? (language->predicate iswim-grammar 'X))
  (define b? (language->predicate iswim-grammar 'b))
  (define o1? (language->predicate iswim-grammar 'o1))
  (define o2? (language->predicate iswim-grammar 'o2))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Substitution from first principles:
  ;; (as defined in the lecture notes)
  
  ;; ----------------------------------------
  ;; Generic implementation of sets:
  
  (define empty-set (make-hash-table))

  (define (singleton-set v)
    (let ([h (make-hash-table)])
      (hash-table-put! h v #t)
      h))

  (define (set-union s1 s2)
    (let ([h (make-hash-table)])
      (hash-table-for-each
       s1
       (lambda (k v)
	 (hash-table-put! h k #t)))
      (hash-table-for-each
       s2
       (lambda (k v)
	 (hash-table-put! h k #t)))
      h))

  (define (set-minus s1 x)
    (if (hash-table-get s1 x (lambda () #f))
	(let ([h (set-union s1 empty-set)])
	  (hash-table-remove! h x)
	  h)
	s1))

  (define (is-in-set? x s1)
    (hash-table-get s1 x (lambda () #f)))

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

  (define (free-vars M)
    (match M
      [(? b?) empty-set]
      [(? X?) (singleton-set M)]
      [`("lam" ,X ,M1) (set-minus (free-vars M1) X)]
      [`(,(? o1?) ,M1) (free-vars M1)]
      [`(,(? o2?) ,M1 ,M2) (set-union (free-vars M1) (free-vars M2))]
      [`(,M1 ,M2) (set-union (free-vars M1) (free-vars M2))]))
  
  ;; M[Xr <- Mr]
  (define (iswim-subst-fp M Xr Mr)
    (match M
      [(? b?) M]
      [(? X?) (if (eq? M Xr)
		  Mr
		  M)]
      [`("lam" ,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)])
	     `("lam" ,Y ,(iswim-subst-fp (if (eq? X Y)
					     M1
					     (iswim-subst-fp M1 X Y))
					 Xr Mr))))]
      [`(,(and o1 (? o1?)) ,M1) `(,o1 ,(iswim-subst-fp M1 Xr Mr))]
      [`(,(and o2 (? o2?)) ,M1 ,M2)
       `(,o2 ,(iswim-subst-fp M1 Xr Mr) ,(iswim-subst-fp M2 Xr Mr))]
      [`(,M1 ,M2) `(,(iswim-subst-fp M1 Xr Mr) ,(iswim-subst-fp M2 Xr Mr))]))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Substitution using a helper library:
  
  ;; The `subst' form makes implemention of capture-avoiding
  ;; easier. We just have to describe how variables bind
  ;; in our language's forms.
  
  (define iswim-subst/backwards
    (subst
     [(? X?) (variable)]
     [(? b?) (constant)]
     [`("lam" ,X ,M)
      (all-vars (list X))
      (build (lambda (X-list M) `("lam" ,(car X-list) ,M)))
      (subterm (list X) M)]
     [`(,(and o (? o1?)) ,M1)
      (all-vars '())
      (build (lambda (vars M1) `(,o ,M1)))
      (subterm '() M1)]
     [`(,(and o (? o2?)) ,M1 ,M2)
      (all-vars '())
      (build (lambda (vars M1 M2) `(,o ,M1 ,M2)))
      (subterm '() M1)
      (subterm '() M2)]
     [`(,M1 ,M2)
      (all-vars '())
      (build (lambda (empty-list M1 M2) `(,M1 ,M2)))
      (subterm '() M1)
      (subterm '() M2)]))

  ;; the argument order for the subst-generated function
  ;; doesn't match the order in the notes:
  (define (iswim-subst M Xr Mr)
    (iswim-subst/backwards Xr Mr M))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Reductions:
  
  ;; beta_v reduction
  (define beta_v
    (reduction iswim-grammar
               (("lam" X_1 M_1) V_1)
               (iswim-subst M_1 X_1 V_1))) ; or use iswim-subst-fp
  
  ;; delta reduction
  (define delta
    (list
     (reduction iswim-grammar ("add1" b_1) (add1 b_1))
     (reduction iswim-grammar ("sub1" b_1) (sub1 b_1))
     (reduction iswim-grammar ("iszero" b_1)
                (if (zero? b_1) 
                    '("lam" x ("lam" y x))
                    '("lam" x ("lam" y y))))
     (reduction iswim-grammar ("+" b_1 b_2) (+ b_1 b_2))
     (reduction iswim-grammar ("-" b_1 b_2) (- b_1 b_2))
     (reduction iswim-grammar ("*" b_1 b_2) (* b_1 b_2))
     (reduction iswim-grammar ("^" b_1 b_2) (expt b_1 b_2))))
  
  ;; ->v
  (define ->v (map (lambda (red)
                     (compatible-closure red iswim-grammar 'M))
                   (cons beta_v delta)))
  
  ;; :->v
  (define :->v (map (lambda (red)
                      (context-closure red iswim-grammar 'E))
                    (cons beta_v delta)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Abbreviations:
  
  (define (if0 test then else)
    (let ([X (variable-not-in `(,then ,else) 'X)])
      `(((("iszero" ,test) ("lam" ,X ,then)) ("lam" ,X ,else)) 77)))
  
  (define true '("lam" x ("lam" y x)))
  (define false '("lam" x ("lam" y y)))
  (define boolean-not `("lam" x ((x ,false) ,true)))
  
  (define mkpair '("lam" x ("lam" y ("lam" s ((s x) y)))))
  (define fst '("lam" p (p ("lam" x ("lam" y x)))))
  (define snd '("lam" p (p ("lam" x ("lam" y y)))))
  
  (define Y_v '("lam" f ("lam" x
			 ((("lam" g (f ("lam" x ((g g) x))))
			   ("lam" g (f ("lam" x ((g g) x)))))
			  x))))
  
  (define mksum `("lam" s
		  ("lam" x 
		   ,(if0 'x 0 '("+" x (s ("sub1" x)))))))
  (define sum `(,Y_v ,mksum))

  (define (run-example)
    (initial-font-size 18)
    (gui
     iswim-grammar
     :->v
     `(("lam" x ("+" 10 ("-" 11 x))) (("lam" z z) 12)))))