#lang racket

(require redex/reduction-semantics
         "grammar.rkt")

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

(define-metafunction grammar
  [(subst x e_1 e_2) (subst* ((x e_1)) e_2)])

(define-metafunction grammar
  [(subst* () e) e] ;; shortcut
  [(subst* ((x_0 e_0) ... (x_1 e_1) (x_4 e_4) ...) (λ (x_2 ... x_1 x_3 ...) e_2))
   (subst* ((x_0 e_0) ... (x_4 e_4) ...) (λ (x_2 ... x_1 x_3 ...) e_2))]
  [(subst* ((x_1 e_1) ...) (λ (x_2 ...) e_2)) ; x_1 != any x_2
   ,(term-let ([(x_new ...) (variables-not-in (term (((x_1 e_1) ...) e_2)) (term (x_2 ...)))])
              (term (λ (x_new ...)
                      (subst* ((x_1 e_1) ...) (replace* ((x_2 x_new) ...) e_2)))))]
  [(subst* ((x_0 e_0) ... (x_1 e_1) (x_2 e_2) ...) x_1) e_1]
  [(subst* ((x_1 e) ...) x_2) x_2] ; x_1 != x_2, since previous didn't match
  [(subst* ((x_1 e_1) ...) (list v_1 ...)) (list (subst* ((x_1 e_1) ...) v_1) ...)]
  [(subst* ((x_1 e_1) ...) (cont v E)) (cont (subst* ((x_1 e_1) ...) v) E)]
  [(subst* ((x_1 e_1) ...) v_1) v_1] ; all other values are atomic
  [(subst* ((x_1 e_1) ...) (e_2 ...))
   ((subst* ((x_1 e_1) ...) e_2) ...)]
  [(subst* ((x_1 e_1) ...) (if e_2 e_3 e_4))
   (if (subst* ((x_1 e_1) ...) e_2)
       (subst* ((x_1 e_1) ...) e_3)
       (subst* ((x_1 e_1) ...) e_4))]
  [(subst* ((x_1 e_1) ...) (begin e_2 e_3))
   (begin (subst* ((x_1 e_1) ...) e_2)
          (subst* ((x_1 e_1) ...) e_3))]
  [(subst* ((x_1 e_1) ...) (set! x_2 e_2))
   (set! x_2 (subst* ((x_1 e_1) ...) e_2))]
  [(subst* ((x_1 e_1) ...) (% e_2 e_3 e_4))
   (% (subst* ((x_1 e_1) ...) e_2)
      (subst* ((x_1 e_1) ...) e_3)
      (subst* ((x_1 e_1) ...) e_4))]
  [(subst* ((x_1 e_1) ...) (wcm ((v_1 v_2) ...) e_2))
   (wcm (((subst* ((x_1 e_1) ...) v_1)
          (subst* ((x_1 e_1) ...) v_2)) ...)
        (subst* ((x_1 e_1) ...) e_2))]
  [(subst* ((x_1 e_1) ...) (dw x_2 e_2 e_3 e_4))
   (dw x_2
       (subst* ((x_1 e_1) ...) e_2)
       (subst* ((x_1 e_1) ...) e_3)
       (subst* ((x_1 e_1) ...) e_4))])

(define-metafunction grammar
  [(replace* ((x_1 x_2) ... (x_3 x_4) (x_5 x_6) ...) x_3) x_4]
  [(replace* ((x_1 x_2) ...) (any ...)) ((replace* ((x_1 x_2) ...) any) ...)]
  [(replace* ((x_1 x_2) ...) any) any])

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Other meta-functions:

(define-metafunction grammar
  [(noPrompt v_1 (% v_1 E v)) #f]
  [(noPrompt v_1 (% v_2 E_1 v)) (noPrompt v_1 E_1)]
  [(noPrompt v hole) #t]
  [(noPrompt v_1 (v ... E_1 e ...)) (noPrompt v_1 E_1)]
  [(noPrompt v_1 (if E_1 e_2 e_3)) (noPrompt v_1 E_1)]
  [(noPrompt v_1 (begin E_1 e_2)) (noPrompt v_1 E_1)]
  [(noPrompt v_1 (set! x E_1)) (noPrompt v_1 E_1)]
  [(noPrompt v_1 (wcm w E_1)) (noPrompt v_1 E_1)]
  [(noPrompt v_1 (dw x e_0 E_1 e_1)) (noPrompt v_1 E_1)]
  [(noPrompt v_1 (% v_2 e E_1)) (noPrompt v_1 E_1)]
  [(noPrompt v_1 (% E_1 e_1 e_2)) (noPrompt v_1 E_1)])

(define-metafunction grammar
  [(get-marks-core (in-hole hole hole) v e_2) e_2]
  [(get-marks-core (wcm (name w_1 ((v_4 v_5) ... (v_1 v_3) (v_6 v_7) ...)) E_1) v_1 e_2) (get-marks E_1 v_1 (cons v_3 e_2))]
  [(get-marks-core (wcm w_1 E_1) v_1 e_2) (get-marks E_1 v_1 e_2) (side-condition (term (notInDom v_1 w_1)))]
  [(get-marks-core (v ... E_1 e ...) v_1 e_2) (get-marks E_1 v_1 e_2)]
  [(get-marks-core (begin E_1 e) v_1 e_2) (get-marks E_1 v_1 e_2)]
  [(get-marks-core (% v_2 E_1 v_3) v_1 e_2) (get-marks E_1 v_1 e_2)]
  [(get-marks-core (% v_2 e_1 E_1) v_1 e_2) (get-marks E_1 v_1 e_2)]
  [(get-marks-core (% E_1 e_1 e_3) v_1 e_2) (get-marks E_1 v_1 e_2)]
  [(get-marks-core (dw x e_1 E_1 e_3) v_1 e_2) (get-marks E_1 v_1 e_2)])

(define-metafunction grammar
  [(get-marks (if E_1 e_1 e_3) v_1 e_2) (get-marks E_1 v_1 e_2)]
  [(get-marks (set! x E_1) v_1 e_2) (get-marks E_1 v_1 e_2)]
  [(get-marks E_1 v_1 e_2) (get-marks-core E_1 v_1 e_2)])

(define-metafunction grammar
  [(expose-wcm e_1) e_1 (side-condition (term (noMatchWCM e_1 (wcm w e))))]
  [(expose-wcm (wcm () e_1)) e_1]
  [(expose-wcm (wcm ((v_1 v_2) (v_3 v_4) ...) e_1))
   (call/cm v_1 v_2 (λ () (expose-wcm (wcm ((v_3 v_4) ...) e_1))))])

(define-metafunction grammar
  [(sameDWs W_1 W_2) (True)]
  [(sameDWs (in-hole W_1 (dw x_1 e_1 E_1 e_2)) 
            (in-hole W_2 (dw x_1 e_1 E_2 e_2)))
   (sameDWs E_1 E_2)]
  [(sameDWs any_1 any_2) (False)])

(define-metafunction grammar
  [(noShared (in-hole W_1 (dw x_1 e_1 E_1 e_2))
             (in-hole W_2 (dw x_1 e_1 E_2 e_2)))
   (False)]
  [(noShared any_1 any_2) (True)])

(define-metafunction grammar
  [(nonWCM (in-hole E (wcm w hole))) #f]
  [(nonWCM any) #t])

;; The rest are helpers that are typeset specially in the paper

(define-metafunction grammar
  [(noMatch E_1 any (% v_1 any_1 any_2)) (noPrompt v_1 E_1)]
  [(noMatch E_1 any (wcm any_1 any_2)) (nonWCM E_1)])

(define-metafunction grammar
  [(noMatchWCM (wcm w e_1) any) #f]
  [(noMatchWCM any_1 any_2) #t])

(define-metafunction grammar
  [(notIn v_1 (v_2 ...)) ,(not (member (term v_1) (term (v_2 ...))))])

(define-metafunction grammar
  [(notInDom v_1 ((v_2  v_3) ...)) (notIn v_1 (v_2 ...))])

(define-metafunction grammar [(True) #t])
(define-metafunction grammar [(False) #f])

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(provide subst subst*
         noPrompt
         get-marks get-marks-core
         expose-wcm
         sameDWs
         noShared
         nonWCM
         noMatch
         noMatchWCM
         notIn
         notInDom)
