(require (lib "reduction-semantics.ss" "reduction-semantics")
	 (lib "gui.ss" "reduction-semantics")
         (lib "subst.ss" "reduction-semantics")
	 (lib "match.ss")
         (lib "list.ss"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Extra library: 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)))


  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Expression grammar:

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reduciton rules:

;; beta and eta reductions
(define beta 
  (reduction 
   grammar
   ((lambda (name X1 variable) (name M1 M)) (name M2 M))
   (lc-subst M1 X1 M2)))
(define eta
  (reduction
   grammar
   (side-condition
    (lambda (name X1 variable) ((name M1 M) (name X1 variable)))
    (not (is-in-set? X1 (free-vars M1))))
   M1))

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Abbreviations:

(define true '(lambda x (lambda y x)))
(define false '(lambda x (lambda y y)))

(define mkpair '(lambda x (lambda y (lambda s ((s x) y)))))
(define fst '(lambda p (p (lambda x (lambda y x)))))
(define snd '(lambda p (p (lambda x (lambda y y)))))

(define (mk-church n)
  `(lambda f (lambda x ,(letrec ([mk (lambda (n)
				       (if (zero? n)
					   'x
					   `(f ,(mk (sub1 n)))))])
			  (mk n)))))

(define zero (mk-church 0))
(define one (mk-church 1))
(define two (mk-church 2))
(define three (mk-church 3))
(define six (mk-church 6))

(define add1 '(lambda n (lambda f (lambda x (f ((n f) x))))))

(define add `(lambda n (lambda m ((m ,add1) n))))

(define iszero `(lambda n ((n (lambda f ,false)) ,true)))

(define wrap `(lambda f
                (lambda p
                  ((,mkpair ,false)
                   (((,fst p) (,snd p)) (f (,snd p)))))))
(define sub1 `(lambda n 
                (lambda f 
                  (lambda x 
                    (,snd ((n (,wrap f)) ((,mkpair ,true) x)))))))
  
(define mkmk `(lambda k (lambda t (t ((k k) t)))))
(define mk `(,mkmk ,mkmk))

(define mksum `(lambda s
                 (lambda x
                   (((,iszero x) ,zero) ((,add x) (s (,sub1 x)))))))
(define sum `(,mk ,mksum))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Evaluation:

;; eval_n finds a normal form for M by searching
(define (eval_n M)
  (explore->n (list M)))

;; explore->n takes a list of expressions and tries to find
;; one in normal form; if none are in normal form, it recurs
;; with a new list of expressions by taking every possible
;; ->n step from every given expression
(define (explore->n M-list)
  (printf "~a expressions~n" (length M-list))
  (let ([nexts-list (map (lambda (M) (reduce ->n M)) M-list)])
    (printf "~a~n" (map length nexts-list))
    (or (ormap (lambda (M nexts)
		 (and (null? nexts)
		      M))
	       M-list nexts-list)
        (explore->n (remove-dups (apply append nexts-list))))))

;; simplifies the search by removing duplicates; in principle,
;; we could remove alpha-equivalent expressions, but it matters
;; little in practice because our lc-subst avoids generating new
;; names
(define (remove-dups M-list)
  (cond
   [(null? M-list) NULL]
   [else (let ([first (car M-list)]
               [rest (remove-dups (cdr M-list))])
           (cond
            [(ormap (lambda (M) (equal? first M)) rest)
             rest]
            [else
             (cons first rest)]))]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Normal-order evaluation:

;; We implement ->n- directly in Scheme. Since we're writing a
;; function, we're assuming that ->n- is a function instead of
;; demonstrating it. So that's a weakness, but this exercise is
;; still useful. For example, it uncovered a bug in the lecture
;; notes.

;; ->n- returns either an M' such that M ->n- M',
;; or #f to indicate that M is in normal form.
(define (->n- M)
  (let ([immediates (reduce (list beta eta) M)])
    (if (pair? immediates)
        (car immediates) ;; assert: only one reduction from M
        (match M
          [(? symbol?) #f]
          [`(lambda ,X1 ,M1)
           (cond
             [(->n- M1)  ; this rule used to be missing in the notes
              => (lambda (Mprime)
                   `(lambda ,X1 ,Mprime))]
             [else #f])]
          [else
           (let ([M1 (car M)]
                 [M2 (cadr M)])
             (cond
               [(->n- M1)
                => (lambda (M1prime)
                     `(,M1prime ,M2))]
               [(->n- M2)
                => (lambda (M2prime)
                     `(,M1 ,M2prime))]
               [else #f]))]))))

(define (->>n-to-norm M)
  (let ([Mprime (->n- M)])
    (if Mprime
        (->>n-to-norm Mprime)
        M)))