(require (lib "reduction-semantics.ss" "reduction-semantics")
         (lib "subst.ss" "reduction-semantics")
	 (lib "match.ss")
         (lib "list.ss"))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Expression grammar:

(define grammar
  (language (M (M M)
               (o1 M)
               (o2 M M)
               V)
            (V variable
	       (lambda variable M)
               b)
            (b number)
            (o1 "add1" "sub1" "iszero")
            (o2 "+" "-" "*" "^")))

(define is-in-V?
  ;; to check whether an expression is in V, apply a reduction that
  ;; matches only Vs, and see whether it generates any results
  (let ([v-to-7 (list (reduction grammar V 7))])
    (lambda (M)
      (pair? (reduce v-to-7 M)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Substitution:

;; 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
   [(? symbol?) (variable)]
   [(? number?) (constant)]
   [`(lambda ,X ,M)
    (all-vars (list X))
    (build (lambda (X-list M) `(lambda ,(car X-list) ,M)))
    (subterm (list X) M)]
   [`(,(and o (or "add1" "sub1" "iszero")) ,M1)
    (all-vars '())
    (build (lambda (vars M1) `(,o ,M1)))
    (subterm '() M1)]
   [`(,(and o (or "+" "-" "*" "^")) ,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))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Alpha equivalence:

(define (=alpha Ma Mb)
  (match Ma
    [`(lambda ,Xa ,M1a)
     (match Mb
       [`(lambda ,Xb ,M1b)
        (if (eq? Xa Xb)
            (=alpha M1a M1b)
            (=alpha M1a (iswim-subst M1b Xb Xa)))]
       [else #f])]
    [`(,(or "add1" "sub1" "iszero") ,M1a)
     (match Mb
       [`(,(or "add1" "sub1" "iszero") ,M1b) (=alpha M1a M1b)]
       [else #f])]
    [`(,(or "+" "-" "*" "^") ,M1a ,M2a)
     (match Mb
       [`(,(or "+" "-" "*" "^") ,M1b ,M2b) 
        (and (=alpha M1a M1b) (=alpha M2a M2b))]
       [else #f])]
    [`(,M1a ,M2a)
     (match Mb
       [`(,M1b ,M2b) (and (=alpha M1a M1b) (=alpha M2a M2b))]
       [else #f])]
    [(? number?)
     (match Mb
       [(? number?) (= Ma Mb)]
       [else #f])]
    [Xa (eq? Xa Mb)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reductions:

;; beta_v reduction
(define beta_v
  (reduction grammar
             ((lambda (name X1 variable) (name M1 M)) (name V1 V))
             (iswim-subst M1 X1 V1)))


(define delta
  (list
   (reduction grammar ("add1" (name b1 b)) (add1 b1))
   (reduction grammar ("sub1" (name b1 b)) (sub1 b1))
   (reduction grammar ("iszero" (name b1 b))
              (if (zero? b1) 
                  '(lambda x (lambda y x))
                  '(lambda x (lambda y y))))
   (reduction grammar ("+" (name b1 b) (name b2 b)) (+ b1 b2))
   (reduction grammar ("-" (name b1 b) (name b2 b)) (- b1 b2))
   (reduction grammar ("*" (name b1 b) (name b2 b)) (* b1 b2))
   (reduction grammar ("^" (name b1 b) (name b2 b)) (expt b1 b2))))

;; ->v
(define ->v (map (lambda (red)
		   (compatible-closure red grammar 'M))
		 (cons beta_v delta)))

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

(define (if0 test then else)
  (let ([X (variable-not-in `(,then ,else) 'X)])
    `(((("iszero" ,test) (lambda ,X ,then)) (lambda ,X ,else)) 77)))

(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 Y_v '(lambda f (lambda x
                         (((lambda g (f (lambda x ((g g) x))))
			   (lambda g (f (lambda x ((g g) x)))))
			  x))))
 
(define mksum `(lambda s
                 (lambda x 
                   ,(if0 'x 0 '("+" x (s ("sub1" x)))))))
(define sum `(,Y_v ,mksum))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reduction to a value:

;; ->>v-to-val finds a value for M or a stuck state by searching;
;; the eval-limit argument is a positive number to indicate how
;; far to search
(define (->>v-to-val M eval-limit)
  (explore->v (list M) null eval-limit))

;; explore->v takes a list of expressions and tries to find
;; one that is in V or stuck; it searches the evaluation
;; paths heurstically, trying the smallest expression in the
;; current frontier.
(define (explore->v M-list M-seen-list eval-limit)
  (when (negative? eval-limit)
    (raise (make-exn:give-up)))
  (printf "~a seen, ~a to explore~n"
          (length M-seen-list) (length M-list))
  (or 
   ;; Any values in M-list ?
   (ormap (lambda (M) (and (is-in-V? M) M)) M-list)
   ;; No values. Try the smallest (first) in the list:
   (let* ([M-try (car M-list)]
	  [next-list (reduce ->v M-try)])
     ;; No next states?
     (if (null? next-list)
	 ;; Then M-try s stuck
	 M-try
	 ;; Otherwise, recur. Put M-try into the M-seen-list,
	 ;;  and add unique (modulo alpha) new state into
	 ;;  the list of explore. The re-sort the explore list.
	 (let ([M-seen-list (cons M-try M-seen-list)]
	       [M-list (cdr M-list)])
	   (explore->v
	    (quicksort
	     (add-new next-list M-seen-list M-list)
	     (lambda (a b) (< (size-of a) (size-of b))))
	    M-seen-list
            (- eval-limit (apply + (map size-of next-list)))))))))

;; size-of computes an expression's size for our heuristic
(define (size-of M)
  (match M
    [`(lambda ,X ,M1)
     (add1 (size-of M1))]
    [`(,(or "add1" "sub1" "iszero") ,M1)
     (add1 (size-of M1))]
    [`(,(or "+" "-" "*" "^") ,M1 ,M2)
     (+ 1 (size-of M1) (size-of M2))]
    [`(,M1 ,M2)
     (+ (size-of M1) (size-of M2))]
    [else 1]))

;; add-new adds elements of new-list to M-list
;; if they're not already in M-list or M-seen-list
(define (add-new new-list M-seen-list M-list)
  (cond
   [(null? new-list) M-list]
   [else (let ([first (car new-list)])
	   (cond
	    [(or (ormap (lambda (M) (=alpha first M)) M-list)
		 (ormap (lambda (M) (=alpha first M)) M-seen-list))
	     (add-new (cdr new-list) M-seen-list M-list)]
	    [else
	     (add-new (cdr new-list) M-seen-list
                      (cons first M-list))]))]))

;; eval_v/search uses ->>-to-val to search for a value or stuck
;; state; a #f result means that the eval result not defined -- 
;; as does non-termination; if eval-limit is reached the exn:give-up
;; exception is raised
(define (eval_v/search M eval-limit)
  (let ([N (->>v-to-val M eval-limit)])
    (match N
      [(? number?) N]
      [`(lambda ,X ,K) 'function]
      [else #f])))

(define-struct exn:give-up ())

;; eval_v performs an unlimited search
(define (eval_v M)
  (eval_v/search M +inf.0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Observational Equivalence

;; show-not-obs-eq searches for a counter-example context
;; to show that two expressions are not observationally
;; equivalent; the limit positive number limits the depth
;; of the search in context generations, and the eval-limit
;; positive number limits eval_v searching for a value for
;; each in-context evaluation (so it's possible that the
;; search actually finds a counter-example context, but doesn't
;; try hard enough at evaluation to show the different results);
;; this implementation assumes that x and y are the only
;; potentially free variables in M and N
(define (show-not-obs-eq M N limit eval-limit)
  (show-not-obs-eq-in M N 
                      (list '||) (list 'x 'y) 
                      limit eval-limit #t))

;; show-not-obs-eq-in is the main search engine; it takes two
;; extra parameters, which are a list of contexts generated that
;; need to be checked, and a list of generated expressions that
;; need to be tried as an argument to a hole; on every iteration,
;; new contexts are built out of the first one in the list, and
;; the first context is in the list is tried; meanwhile, new contexts
;; are also built out of the first expression, and new expressions
;; are generated from it; the expr-mode? boolean controls how early
;; in the list the new expression-based contexts are inserted
(define (show-not-obs-eq-in M N contexts arg-expressions 
                            limit eval-limit expr-mode?)
  (if (zero? limit)
      (error "giving up")
      (let ([context-to-try (car contexts)]
            [old-contexts (cdr contexts)]
            [generator-arg-expression (car arg-expressions)])
        (let ([arg-expressions
                (append
                 (cdr arg-expressions)
                 (map (lambda (template)
                        (replace-hole template
                                      generator-arg-expression))
                      '((lambda x ||)
                        (lambda y ||)
                        (|| x)
                        (x ||))))]
              [contexts (append
                         (if expr-mode? null old-contexts)
                         (list `(|| ,generator-arg-expression))
                         (if expr-mode? old-contexts null)
                         (map
                          (lambda (ctx)
                            (replace-hole ctx context-to-try))
                          '((lambda x ||)
                            (lambda y ||)
                            (|| 1)
                            (|| 2)
                            ("+" 3 ||)
                            ("*" 3 ||))))])
          (with-handlers ([exn:give-up? void])
            (printf "trying in ~s~n" context-to-try)
            (unless (equal? 
                     (eval_v/search (replace-hole context-to-try M)
                                    eval-limit)
                     (eval_v/search (replace-hole context-to-try N)
                                    eval-limit))
              (error 'obseq
                     "~s differs from ~s in ~s"
                     M N context-to-try)))
          (show-not-obs-eq-in M N contexts arg-expressions
                              (sub1 limit) eval-limit
                              (not expr-mode?))))))

;; replace is like subst, except that it captures;
(define iswim-replace/backwards
  (subst
   [(? symbol?) (variable)]
   [(? number?) (constant)]
   [`(lambda ,X ,M)
    (all-vars '())
    (build (lambda (X-list M) `(lambda X ,M)))
    (subterm (list X) M)]
   [`(,(and o (or "add1" "sub1" "iszero")) ,M1)
    (all-vars '())
    (build (lambda (vars M1) `(,o ,M1)))
    (subterm '() M1)]
   [`(,(and o (or "+" "-" "*" "^")) ,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)]))

(define (replace-hole M Mr)
  (iswim-replace/backwards '|| Mr M))