Require Export PredMonad.TypeReflection.OrderedType.
Require Export PredMonad.TypeReflection.OTypeExpr.

Import EqNotations.

(***
 *** Helper Tactics
 ***)

(* FIXME: move these somewhere sensible! *)
Ltac destruct_ands :=
  repeat (lazymatch goal with | H:_ /\ _ |- _ => destruct H | _ => idtac end).
Ltac split_ands :=
  repeat (lazymatch goal with | |- _ /\ _ => split | _ => idtac end).

(***
 *** Ordered Expressions
 ***)

Inductive OVar {A RA} (tpA:@OTypeExpr A RA) : Ctx -> Type :=
| OVar_0 {ctx} : OVar tpA (@CtxCons A RA tpA ctx)
| OVar_S {B RB tpB ctx} : OVar tpA ctx -> OVar tpA (@CtxCons B RB tpB ctx)
.

Arguments OVar_0 {A RA tpA ctx}.
Arguments OVar_S {A RA tpA B RB tpB ctx} v.

(* Expressions to represent proper functions *)
Inductive OExpr ctx : forall {A RA}, @OTypeExpr A RA -> Type :=
| Var {A RA tp} (v:OVar tp ctx) : @OExpr ctx A RA tp
| Embed {A RA tp} (a:A) : @OExpr ctx A RA tp
| App {A RA} {tpA:@OTypeExpr A RA} {B RB} {tpB:@OTypeExpr B RB}
      (e1 : OExpr ctx (OTpArrow tpA tpB)) (e2 : OExpr ctx tpA) :
    OExpr ctx tpB
| Lam {A RA} {tpA:@OTypeExpr A RA} {B RB} {tpB:@OTypeExpr B RB}
      (e: OExpr (CtxCons tpA ctx) tpB) :
    OExpr ctx (OTpArrow tpA tpB)
.

Arguments Var {ctx A RA tp} v.
Arguments Embed {ctx A RA tp} a.
Arguments App {ctx A RA tpA B RB tpB} e1 e2.
Arguments Lam {ctx A RA tpA B RB tpB} e.

(***
 *** Semantics of Ordered Expressions
 ***)

(* The semantics of a variable *)
Fixpoint varSemantics {A RA tp ctx} (v:@OVar A RA tp ctx) :
  CtxElem ctx -o> A :=
  match v in OVar _ ctx return CtxElem ctx -o> A with
  | OVar_0 => ctx_head_pfun
  | OVar_S v' => compose_pfun ctx_tail_pfun (varSemantics v')
  end.
Arguments varSemantics {A RA tp ctx} !v.

(* The semantics of an ordered expression *)
Fixpoint exprSemantics {ctx A RA tp} (e:@OExpr ctx A RA tp) : CtxElem ctx -o> A :=
  match e in @OExpr _ A RA tp return CtxElem ctx -o> A with
  | Var v => varSemantics v
  | Embed a => const_pfun a
  | App e1 e2 => pfun_apply (exprSemantics e1) (exprSemantics e2)
  | Lam e => pfun_curry (exprSemantics e)
  end.
Arguments exprSemantics {ctx A RA tp} !e.

(***
 *** Relating Ordered Expressions
 ***)

(* Two expressions are related iff their semantics are *)
Definition oexpr_R {ctx A RA tp} (e1 e2:@OExpr ctx A RA tp) : Prop :=
  exprSemantics e1 <o= exprSemantics e2.
Arguments oexpr_R {ctx A RA tp} e1 e2 : simpl never.

(* oexpr_R is a PreOrder *)
Instance PreOrder_oexpr_R ctx A RA tp : PreOrder (@oexpr_R ctx A RA tp).
Proof.
  unfold oexpr_R; split; intro; intros.
  - reflexivity.
  - etransitivity; [ apply H | apply H0 ].
Qed.

(* Two expressions are equivalenct iff their semantics are *)
Definition oexpr_eq {ctx A RA tp} (e1 e2:@OExpr ctx A RA tp) : Prop :=
  exprSemantics e1 =o= exprSemantics e2.
Arguments oexpr_eq {ctx A RA tp} e1 e2 : simpl never.

(* oexpr_eq is a Equivalence *)
Instance Equivalence_oexpr_eq ctx A RA tp : Equivalence (@oexpr_eq ctx A RA tp).
Proof.
  unfold oexpr_eq; split; intro; intros.
  - reflexivity.
  - symmetry; assumption.
  - etransitivity; [ apply H | apply H0 ].
Qed.

Notation "x <e= y" :=
  (oexpr_R x y) (no associativity, at level 70).
Notation "x =e= y" :=
  (oexpr_eq x y) (no associativity, at level 70).

(* The Embed constructor is Proper w.r.t. ot_R and oexpr_R *)
Instance Proper_Embed ctx A RA tp :
  Proper (ot_R ==> oexpr_R) (@Embed ctx A RA tp).
Proof.
  intros a1 a2 Ra; unfold oexpr_R; simpl.
  apply Proper_const_pfun. assumption.
Qed.

(* The Embed constructor is Proper w.r.t. ot_equiv and oexpr_eq *)
Instance Proper_Embed_equiv ctx A RA tp :
  Proper (ot_equiv ==> oexpr_eq) (@Embed ctx A RA tp).
Proof.
  intros a1 a2 Ra. destruct Ra; split; apply Proper_Embed; assumption.
Qed.

(* The App constructor is Proper *)
Instance Proper_App ctx A RA tpA B RB tpB :
  Proper (oexpr_R ==> oexpr_R ==> oexpr_R) (@App ctx A RA tpA B RB tpB).
Proof.
  intros f1 f2 Rf a1 a2 Ra. unfold oexpr_R; simpl.
  apply Proper_pfun_apply; assumption.
Qed.

(* The App constructor is Proper for equivalence *)
Instance Proper_App_equiv ctx A RA tpA B RB tpB :
  Proper (oexpr_eq ==> oexpr_eq ==> oexpr_eq) (@App ctx A RA tpA B RB tpB).
Proof.
  intros f1 f2 Rf a1 a2 Ra. unfold oexpr_eq; simpl.
  apply Proper_pfun_apply_equiv; assumption.
Qed.

(* The Lam constructor is Proper *)
Instance Proper_Lam ctx A RA tpA B RB tpB :
  Proper (oexpr_R ==> oexpr_R) (@Lam ctx A RA tpA B RB tpB).
Proof.
  intros e1 e2 Re. unfold oexpr_R; simpl.
  apply Proper_pfun_curry. assumption.
Qed.

(* The Lam constructor is Proper for equivalence *)
Instance Proper_Lam_equiv ctx A RA tpA B RB tpB :
  Proper (oexpr_eq ==> oexpr_eq) (@Lam ctx A RA tpA B RB tpB).
Proof.
  intros e1 e2 Re. unfold oexpr_eq; simpl.
  apply Proper_pfun_curry_equiv. assumption.
Qed.

(***
 *** Weakening for Ordered Expressions
 ***)

(* Weakening / lifting of ordered expression variables *)
Fixpoint weakenOVar w {W RW} (tpW:@OTypeExpr W RW) :
  forall {ctx A RA tpA}, @OVar A RA tpA ctx -> OVar tpA (ctxInsert w tpW ctx) :=
  match w return forall ctx A RA tpA,
      OVar tpA ctx -> OVar tpA (ctxInsert w tpW ctx) with
  | 0 => fun _ _ _ _ v => OVar_S v
  | S w' =>
    fun ctx A RA tpA v =>
      match v in OVar _ ctx return OVar tpA (ctxInsert (S w') tpW ctx) with
      | OVar_0 => OVar_0
      | OVar_S v' => OVar_S (weakenOVar w' tpW v')
      end
  end.
Arguments weakenOVar w {W RW} tpW {ctx A RA tpA} v : simpl nomatch.

(* Correctness of weakenOVar: it is equivalent to weaken_pfun *)
Lemma weakenOVar_correct w {W RW} tpW {ctx A RA tpA} (v:@OVar A RA tpA ctx) :
  varSemantics (@weakenOVar w W RW tpW ctx A RA tpA v) =o=
  compose_pfun (weaken_pfun w tpW ctx) (varSemantics v).
Proof.
  revert ctx v; induction w; intros; [ | destruct v ]; simpl.
  - reflexivity.
  - rewrite compose_pair_snd. reflexivity.
  - rewrite compose_compose_pfun. rewrite compose_pair_fst.
    rewrite <- compose_compose_pfun. f_equiv. apply IHw.
Qed.

(* Weakening / lifting of ordered expressions *)
Fixpoint weakenOExpr w {W RW} (tpW:@OTypeExpr W RW) {ctx A RA tpA}
         (e:@OExpr ctx A RA tpA) : OExpr (ctxInsert w tpW ctx) tpA :=
  match e in OExpr _ A return OExpr (ctxInsert w tpW ctx) A with
  | Var v => Var (weakenOVar w tpW v)
  | Embed a => Embed a
  | App e1 e2 => App (weakenOExpr w tpW e1) (weakenOExpr w tpW e2)
  | Lam e => Lam (weakenOExpr (S w) tpW e)
  end.

(* Correctness of weakenOExpr: it is equivalent to weaken_pfun *)
Lemma weakenOExpr_correct w {W RW} tpW {ctx A RA tpA} (e:@OExpr ctx A RA tpA) :
  exprSemantics (@weakenOExpr w W RW tpW ctx A RA tpA e) =o=
  compose_pfun (weaken_pfun w tpW ctx) (exprSemantics e).
  revert w; induction e; intros; simpl.
  - apply weakenOVar_correct.
  - rewrite compose_f_const_pfun; try typeclasses eauto. reflexivity.
  - rewrite compose_pfun_apply; try typeclasses eauto.
    rewrite IHe1. rewrite IHe2. reflexivity.
  - rewrite compose_pfun_curry; try typeclasses eauto.
    f_equiv. apply (IHe (S w)).
    Unshelve. typeclasses eauto.
Qed.

(* Proper-ness of weakenOExpr *)
Instance Proper_weakenOExpr w W RW tpW ctx A RA tpA :
  Proper (oexpr_R ==> oexpr_R) (@weakenOExpr w W RW tpW ctx A RA tpA).
Proof.
  intros e1 e2 Re. unfold oexpr_R.
  etransitivity; [ apply weakenOExpr_correct | ].
  etransitivity; [ | apply weakenOExpr_correct ].
  f_equiv. assumption.
Qed.

(* Proper-ness of weakenOExpr *)
Instance Proper_weakenOExpr_equiv w W RW tpW ctx A RA tpA :
  Proper (oexpr_eq ==> oexpr_eq) (@weakenOExpr w W RW tpW ctx A RA tpA).
Proof.
  intros e1 e2 Re. unfold oexpr_eq.
  etransitivity; [ apply weakenOExpr_correct | ].
  etransitivity; [ | symmetry; apply weakenOExpr_correct ].
  f_equiv. assumption.
Qed.

(***
 *** Substitution for Ordered Variables
 ***)

(* Substitution for ordered expression variables *)
Fixpoint substOVar n {ctx A RA tp} :
  @OVar A RA tp ctx -> OExpr (ctxSuffix n ctx) (ctxNthExpr n ctx) ->
  OExpr (ctxDelete n ctx) tp :=
  match n return
        OVar tp ctx -> OExpr (ctxSuffix n ctx) (ctxNthExpr n ctx) ->
        OExpr (ctxDelete n ctx) tp
  with
  | 0 =>
    fun v =>
      match v in OVar _ ctx return
            OExpr (ctxSuffix 0 ctx) (ctxNthExpr 0 ctx) ->
            OExpr (ctxDelete 0 ctx) tp
      with
      | OVar_0 => fun s => s
      | OVar_S v' => fun _ => Var v'
    end
  | S n' =>
    fun v =>
      match v in OVar _ ctx return
            OExpr (ctxSuffix (S n') ctx) (ctxNthExpr (S n') ctx) ->
            OExpr (ctxDelete (S n') ctx) tp
      with
      | OVar_0 => fun _ => Var OVar_0
      | @OVar_S _ _ _ B RB tpB ctx' v' =>
        fun s => weakenOExpr 0 tpB (substOVar n' v' s)
      end
  end.
Arguments substOVar !n {ctx A RA tp} !v s.

(* Correctness of substOVar: it is equivalent to subst_pfun *)
Lemma substOVar_correct n {ctx A RA tp} (v:@OVar A RA tp ctx) s :
  exprSemantics (substOVar n v s) =o=
  compose_pfun (subst_pfun ctx n (exprSemantics s)) (varSemantics v).
Proof.
  revert n s; induction v; intros; destruct n; simpl.
  - symmetry; apply compose_pair_snd.
  - symmetry; apply compose_pair_snd.
  - rewrite compose_compose_pfun. rewrite compose_pair_fst.
    rewrite id_compose_pfun. reflexivity.
  - etransitivity; [ apply (weakenOExpr_correct 0) | ].
    rewrite compose_compose_pfun. rewrite compose_pair_fst.
    rewrite <- compose_compose_pfun. f_equiv. apply IHv.
Qed.

(* substOVar is Proper in its s argument *)
Instance Proper_substOVar n {ctx A RA tp} v :
  Proper (oexpr_R ==> oexpr_R) (@substOVar n ctx A RA tp v).
Proof.
  revert ctx v; induction n; intros; destruct v; intros e1 e2 Re; simpl.
  - assumption.
  - reflexivity.
  - reflexivity.
  - apply (Proper_weakenOExpr 0). apply IHn. assumption.
Qed.

(* substOVar is Proper in its s argument *)
Instance Proper_substOVar_equiv n {ctx A RA tp} v :
  Proper (oexpr_eq ==> oexpr_eq) (@substOVar n ctx A RA tp v).
Proof.
  intros e1 e2 Re; destruct Re; split; apply Proper_substOVar; assumption.
Qed.

(***
 *** Substitution for Ordered Expressions
 ***)

(* Substitution for ordered expressions *)
Fixpoint substOExpr n {ctx A RA tp} (e:@OExpr ctx A RA tp) :
  OExpr (ctxSuffix n ctx) (ctxNthExpr n ctx) -> OExpr (ctxDelete n ctx) tp :=
  match e with
  | Var v => fun s => substOVar n v s
  | Embed a => fun _ => Embed a
  | App e1 e2 => fun s => App (substOExpr n e1 s) (substOExpr n e2 s)
  | Lam e => fun s => Lam (substOExpr (S n) e s)
  end.
Arguments substOExpr n {ctx A RA tp} !e.

(* Correctness of substOExpr: it is equivalent to subst_pfun *)
Lemma substOExpr_correct n {ctx A RA tp} (e:@OExpr ctx A RA tp) s :
  exprSemantics (substOExpr n e s) =o=
  compose_pfun (subst_pfun ctx n (exprSemantics s)) (exprSemantics e).
Proof.
  revert n s; induction e; intros; simpl.
  - apply substOVar_correct.
  - symmetry. apply compose_f_const_pfun. typeclasses eauto.
  - etransitivity; [ | symmetry; apply compose_pfun_apply ];
      try typeclasses eauto.
    apply Proper_pfun_apply_equiv; [ apply IHe1 | apply IHe2 ].
  - etransitivity; [ | symmetry; apply compose_pfun_curry ];
      try typeclasses eauto.
    f_equiv.
    apply (IHe (S n)).
Qed.

(***
 *** OExpr Rewrite Rules
 ***)

(* The Beta rule for ordered expressions *)
Lemma OExpr_Beta ctx A RA tpA B RB tpB
      (e1: @OExpr (@CtxCons A RA tpA ctx) B RB tpB) (e2: @OExpr ctx A RA tpA) :
  App (Lam e1) e2 =e= substOExpr 0 e1 e2.
Proof.
  unfold oexpr_eq; simpl.
  rewrite (substOExpr_correct 0 e1 e2).
  rewrite pfun_apply_pfun_curry; try typeclasses eauto.
  f_equiv.
Qed.

(*
(* The OExpr for the fst function *)
Definition OFst {ctx A RA B} {RB:OTRelation B} {tp} : @OExpr ctx (A*B -o> A) _ tp :=
  Embed (tp:=tp) (@ofst A B RA RB).

(* The OExpr for the snd function *)
Definition OSnd {ctx A B} : OExpr ctx (OTpArrow (OTpPair A B) B) :=
  Embed (A:=OTpArrow (OTpPair A B) B) osnd.

(* The OExpr for the pair function *)
Definition OPair {ctx A B} : OExpr ctx (OTpArrow A (OTpArrow B (OTpPair A B))) :=
  Embed (A:=OTpArrow A (OTpArrow B (OTpPair A B))) opair.

(* Mark the above OExpr constructs as opaque *)
Typeclasses Opaque OFst OSnd OPair.
*)

Lemma OExpr_fst_pair ctx A RA tpA B RB tpB
      (e1: @OExpr ctx A RA tpA) (e2: @OExpr ctx B RB tpB) :
  App (Embed ofst) (App (App (Embed opair) e1) e2) =e= e1.
Proof.
  split; intros a1 a2 Ra; simpl; f_equiv; assumption.
Qed.

Lemma OExpr_snd_pair ctx A RA tpA B RB tpB
      (e1: @OExpr ctx A RA tpA) (e2: @OExpr ctx B RB tpB) :
  App (Embed osnd) (App (App (Embed opair) e1) e2) =e= e2.
Proof.
  split; intros a1 a2 Ra; simpl; f_equiv; assumption.
Qed.

Lemma OExpr_pair_eta ctx A RA (tpA:@OTypeExpr A RA) B RB (tpB:@OTypeExpr B RB)
      (e: OExpr ctx (OTpPair tpA tpB)) :
  (App (App (Embed opair) (App (Embed ofst) e)) (App (Embed osnd) e)) =e= e.
Proof.
  split; intros a1 a2 Ra; split; simpl; f_equiv; f_equiv; assumption.
Qed.

Hint Rewrite OExpr_fst_pair OExpr_snd_pair OExpr_pair_eta : osimpl.

(***
 *** Quoting Tactic for Ordered Expressions
 ***)

(* Specially-marked versions of fst and snd just used for quoting OExprs *)
Definition celem_head {ctx A RA tpA}
           (celem: CtxElem (@CtxCons A RA tpA ctx)) : A :=
  let (_,head) := celem in head.
Definition celem_rest {ctx A RA tpA}
           (celem: CtxElem (@CtxCons A RA tpA ctx)) : CtxElem ctx :=
  let (rest,_) := celem in rest.

(* Typeclass for incrementally quoting functions into OExpr variables, by
peeling off the celem_rest projections one at a time and adding them as OVar_S
constructors to the input variable to build the output variable *)
Class QuotesToVar {ctx1 ctx2 A RA} {tpA:@OTypeExprInd A RA}
      (f: CtxElem ctx1 -> CtxElem ctx2)
      (vin: OVar tpA ctx2) (vout: OVar tpA ctx1) : Prop :=
  quotesToVar :
    forall c, varSemantics vin @o@ (f c) = varSemantics vout @o@ c.

Instance QuotesToVar_Base {ctx A RA} {tpA:@OTypeExprInd A RA}
         (v:@OVar A RA tpA ctx) : QuotesToVar (fun c => c) v v.
Proof.
  intro; reflexivity.
Qed.

Instance QuotesToVar_Step {ctx1 ctx2 A RA} {tpA:@OTypeExprInd A RA}
         {B RB} {tpB:@OTypeExprInd B RB}
         (f: CtxElem ctx1 -> CtxElem (@CtxCons B RB tpB ctx2)) vin vout
         (q: @QuotesToVar _ _ A RA tpA f (OVar_S vin) vout) :
  QuotesToVar (fun c => celem_rest (f c)) vin vout.
Proof.
  intro. apply q.
Qed.

(* Class for quoting functions to OExprs *)
Class QuotesTo {ctx A RA} {tpA:@OTypeExprInd A RA} (f: CtxElem ctx -> A)
      (e: @OExpr ctx A RA tpA) : Prop :=
  quotesTo : forall c, f c =o= exprSemantics e @o@ c.

(* Logically the same as QuotesTo, but we never build lambdas in this one, i.e.,
this only builds "atomic" OExprs *)
Class QuotesToAtomic {ctx A RA} {tpA:@OTypeExprInd A RA}
      (f: CtxElem ctx -> A) (e: @OExpr ctx A RA tpA) :=
  quotesToAtomic : QuotesTo f e.

(* Quote any term of functional type to a lambda *)
Instance QuotesTo_Lam {ctx A RA} {tpA:@OTypeExprInd A RA}
         {B RB} {tpB:@OTypeExprInd B RB} (f: CtxElem ctx -> A -o> B)
         (e: OExpr (CtxCons tpA ctx) tpB)
         (q: QuotesTo (fun c => f (celem_rest c) @o@ (celem_head c)) e) :
  QuotesTo f (Lam e) | 2.
Proof.
  intros; split; intro; intros; simpl; rewrite H;
    rewrite <- (q (c,a2)); reflexivity.
Qed.

(* Special case: quote ofuns as lambdas, destructuring the ofun *)
Instance QuotesTo_Lam_ofun {ctx A RA} {tpA:@OTypeExprInd A RA}
         {B RB} {tpB:@OTypeExprInd B RB} (f: CtxElem ctx -> A -> B) prp
         (e: OExpr (CtxCons tpA ctx) tpB)
         (q: QuotesTo (fun c => f (celem_rest c) (celem_head c)) e) :
  QuotesTo (fun c => ofun (f c) (prp:=prp c)) (Lam e) | 1.
Proof.
  apply QuotesTo_Lam. assumption.
Qed.

(* Quote any non-function term as an atomic OExpr *)
Instance QuotesTo_Atomic {ctx A RA} {tpA:@OTypeExprInd A RA}
         (f: CtxElem ctx -> A) e (q: QuotesToAtomic f e) :
  QuotesTo (tpA:=tpA) f e | 3 := q.

(* Quote any use of celem_head as a var *)
Instance QuotesTo_Var {ctx1 ctx2 A RA} {tpA:@OTypeExprInd A RA}
         (f: CtxElem ctx1 -> CtxElem (CtxCons tpA ctx2)) v
         (q: QuotesToVar f OVar_0 v) :
  QuotesToAtomic (fun c => celem_head (f c)) (Var v) | 1.
Proof.
  intro. rewrite <- (quotesToVar (QuotesToVar:=q)). destruct (f c).
  reflexivity.
Qed.

(* Special case for an eta-reduced celem_head application *)
Instance QuotesTo_Var0 {ctx A RA} {tpA:@OTypeExprInd A RA} :
  QuotesToAtomic (@celem_head ctx A RA tpA) (Var OVar_0) | 1.
Proof.
  intro; reflexivity.
Qed.

(* Quote applications as OExpr applications, where the function must still be
atomic but the argument need not be *)
Instance QuotesTo_App {ctx A RA} {tpA:@OTypeExprInd A RA} {B RB}
         {tpB:@OTypeExprInd B RB}
         (f1: CtxElem ctx -> A -o> B) (f2: CtxElem ctx -> A)
         (e1: OExpr ctx (OTpArrow tpA tpB)) (e2: OExpr ctx tpA)
         (q1: QuotesToAtomic f1 e1) (q2: QuotesTo f2 e2) :
  QuotesToAtomic (fun c => (f1 c) @o@ (f2 c)) (App e1 e2) | 1.
Proof.
  intro. simpl. f_equiv.
  - apply (quotesTo (QuotesTo:=q1)).
  - apply (quotesTo (QuotesTo:=q2)).
Qed.

(* Quote ofuns in atomic position as lambdas *)
Instance QuotesToAtomic_ofun {ctx A RA} {tpA:@OTypeExprInd A RA} {B RB}
         {tpB:@OTypeExprInd B RB} (f: CtxElem ctx -> A -> B) prp
         (e: OExpr (CtxCons tpA ctx) tpB)
         (q: QuotesTo (fun c => f (celem_rest c) (celem_head c)) e) :
  QuotesToAtomic (fun c => ofun (f c) (prp:=prp c)) (Lam e) | 1.
Proof.
  apply QuotesTo_Lam. assumption.
Qed.

(* Quote objects that are independent of the context as embedded objects, but at
low priority *)
Instance QuotesTo_Embed {ctx A RA} {tpA:@OTypeExprInd A RA} (a:A) :
  QuotesToAtomic (fun _ => a) (@Embed ctx A RA tpA a) | 2.
Proof.
  intro. reflexivity.
Qed.

(* Quote pairs as applications of opair *)
Instance QuotesTo_pair {ctx A RA} {tpA:@OTypeExprInd A RA} {B RB}
         {tpB:@OTypeExprInd B RB} (a: CtxElem ctx -> A) (b: CtxElem ctx -> B)
         (e1: OExpr ctx tpA) (e2: OExpr ctx tpB)
         (q1: QuotesTo a e1) (q2: QuotesTo b e2) :
  QuotesToAtomic (tpA:=OTpPair tpA tpB) (fun c => (a c, b c))
                 (App (App (Embed opair) e1) e2) | 1.
Proof.
  intro. simpl. rewrite (q1 c). rewrite (q2 c). reflexivity.
Qed.

(* Quote applications of fst as applications of ofst *)
Instance QuotesTo_fst {ctx A RA} {tpA:@OTypeExprInd A RA} {B RB}
         {tpB:@OTypeExprInd B RB} (f: CtxElem ctx -> A * B)
         (e: OExpr ctx (OTpPair tpA tpB)) (q: QuotesTo f e) :
  QuotesToAtomic (tpA:=tpA) (fun c => fst (f c)) (App (Embed ofst) e) | 1.
Proof.
  intro. simpl. rewrite (q c). reflexivity.
Qed.

(* Quote applications of snd as applications of osnd *)
Instance QuotesTo_snd {ctx A RA} {tpA:@OTypeExprInd A RA} {B RB}
         {tpB:@OTypeExprInd B RB} (f: CtxElem ctx -> A * B)
         (e: OExpr ctx (OTpPair tpA tpB)) (q: QuotesTo f e) :
  QuotesToAtomic (tpA:=tpB) (fun c => snd (f c)) (App (Embed osnd) e) | 1.
Proof.
  intro. simpl. rewrite (q c). reflexivity.
Qed.

(* Use QuotesTo to prove a relation *)
Lemma oquote_R {A RA} {tpA:@OTypeExprInd A RA} {f1 f2 : A}
      {e1 e2: OExpr CtxNil tpA}
      {q1: QuotesTo (fun _ => f1) e1} {q2: QuotesTo (fun _ => f2) e2} :
  e1 <e= e2 -> f1 <o= f2.
Proof.
  intro R12.
  etransitivity; [ apply (q1 tt) | ].
  etransitivity; [ | apply (q2 tt) ].
  apply R12. reflexivity.
Qed.

(* Use QuotesTo to prove an equivalence *)
Lemma oquote_eq {A RA} {tpA:@OTypeExpr A RA} {f1 f2 : A}
      {e1 e2: OExpr CtxNil tpA}
      {q1: QuotesTo (tpA:=tpA) (fun _ => f1) e1} {q2: QuotesTo (fun _ => f2) e2} :
  e1 =e= e2 -> f1 =o= f2.
Proof.
  intro R12.
  etransitivity; [ apply (q1 tt) | ].
  etransitivity; [ | symmetry; apply (q2 tt) ].
  f_equiv. apply R12.
Qed.

(* Translate a problem about proper functions into one about OExprs, by
"quoting" both sides *)
Ltac oquote :=
  lazymatch goal with
  | |- ?e1 =o= ?e2 =>
    apply oquote_eq
  | |- ?e1 <o= ?e2 =>
    apply oquote_R
  end.

Ltac oexpr_simpl :=
  rewrite_strat (bottomup (choice (OExpr_Beta ; eval simpl) (hints osimpl))).

(* Translate a problem about proper functions into one about OExprs by calling
oquote, simplify both sides using the osimpl rewrite database, and then try to
use reflexivity, going back to proper functions if that does not work *)
Ltac osimpl :=
  simpl; oquote; try oexpr_simpl; try reflexivity; try typeclasses eauto; simpl.

(***
 *** Testing the Quote Mechanism
 ***)

Module OQuoteTest.

(* Set Printing All. *)
(* Hint Extern 4 (QuotesTo ) : typeclass_instances. *)

(*
Goal (forall A (RA:OTRelation A) (a:A),
         exists (tpA:OTypeExprInd A) (e:OExpr CtxNil tpA),
           QuotesTo (fun _ => a) e).
  intros. eexists. eexists.
  typeclasses eauto.
  simple apply @QuotesTo_Atomic.
 *)
(* Hint Extern 1 (OTypeExprInd _) => prove_OTypeExpr : typeclass_instances. *)
(* Typeclasses Opaque OTypeExprInd.
Print HintDb typeclass_instances. *)

Instance Equivalence_oexpr_eq' ctx A RA (tp:@OTypeExprInd A RA)
  : Equivalence (@oexpr_eq ctx A RA tp) := Equivalence_oexpr_eq _ _ _ _.

(* A simple test case for constant terms *)
Lemma simple_quote_test A `{OType A} a : a =o= a.
  osimpl.
Qed.

(* A simple test case with all 4 OExpr constructs, that does beta-reduction *)
Lemma beta_test A `{OType A} a : (ofun (A:=A) (fun x => x)) @o@ a =o= a.
  osimpl.
Qed.

(* A test case with the first projection of a product *)
Lemma product_proj1_test A `{OType A} B `{OType B} (a:A) (b:B) :
  ofst @o@ (a ,o, b) =o= a.
  osimpl.
Qed.

(* A test case with with beta-reduction and projections + eta for products *)
Lemma beta_product_test A `{OType A} B `{OType B} (p:A*B) :
  ofun (fun p => (osnd @o@ p ,o, ofst @o@ p)) @o@ (osnd @o@ p ,o, ofst @o@ p)
  =o= p.
  (* osimpl *)
  (* NOTE: we write this out to see how long each step takes... *)
  oquote.

  FIXME HERE NOW: quoting for ofuns is not working!

  oexpr_simpl. reflexivity. typeclasses eauto.
Qed.

Lemma double_lambda_test A `{OType A} :
  (ofun (fun (f : A -o> A) => ofun (fun x => f @o@ x))) @o@ (ofun (fun y => y))
  =o= ofun (fun x => x).
  osimpl.
Qed.

(* A test case with with beta-reduction and projections for products *)
Lemma beta_product_test2 A `{OType A} B `{OType B} :
  ofun (fun a =>
          ofun (fun b =>
                  ofun (fun p => (osnd @o@ p ,o, ofst @o@ p)) @o@ (b ,o, a)))
  =o= opair.
  (* osimpl *)
  (* NOTE: we write this out to see how long each step takes... *)
  oquote. oexpr_simpl.
  reflexivity. typeclasses eauto. typeclasses eauto.
Qed.

End OQuoteTest.

FIXME HERE NOW: continue porting OExpr_typed.v!


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.String.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.syms.SymEnv.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.ExprVariables.
Require Import MirrorCore.SymI.
Require Import MirrorCore.syms.SymSum.

Require Import Charge.Open.Stack.
Require Import Charge.Open.Subst.
Require Import Charge.Rel.

Require Import Coq.Strings.String.
Require Import Coq.Bool.Bool.
Require Import FunctionalExtensionality.

Require Import MirrorCharge.ModularFunc.BaseType.
Require Import MirrorCharge.ModularFunc.ListType.
Require Import MirrorCharge.ModularFunc.SubstType.
Require Import MirrorCharge.ModularFunc.ListFunc.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.

  Inductive open_func typ {RType_typ : RType typ} {HST : SubstType typ} :=
    | of_const (_ : typ)
    | of_ap (_ _ : typ)
    | of_null
    | of_stack_get
    | of_stack_set
    | of_apply_subst (_ : typ)
    | of_single_subst
    | of_subst
    | of_trunc_subst.

Implicit Arguments open_func [[RType_typ] [HST]].

Class OpenFunc (typ func : Type) {RType_typ : RType typ} {HST : SubstType typ} := {
  fConst : typ -> func;
  fAp : typ -> typ -> func;

  fNull : func;

  fStackGet : func;
  fStackSet : func;

  fApplySubst : typ -> func;
  fSingleSubst : func;
  fSubst : func;
  fTruncSubst : func;

  open_funcS : func -> option (open_func typ)
}.

Implicit Arguments OpenFunc [[RType_typ] [HST]].

Section OpenFuncSum.
	Context {typ func : Type} `{H : OpenFunc typ func}.

	Global Instance OpenFuncSumL (A : Type) :
	   OpenFunc typ (func + A) := {
		  fConst t := inl (fConst t);
		  fAp t u := inl (fAp t u);

		  fNull := inl fNull;

		  fStackGet := inl fStackGet;
		  fStackSet := inl fStackSet;

		  fApplySubst t := inl (fApplySubst t);
		  fSingleSubst := inl fSingleSubst;
		  fSubst := inl fSubst;
		  fTruncSubst := inl fTruncSubst;

		  open_funcS f := match f with
		  				    | inl f => open_funcS f
		  				    | inr _ => None
		  				  end
       }.

	Global Instance OpenFuncSumR (A : Type) :
	   OpenFunc typ (A + func) := {
		  fConst t := inr (fConst t);
		  fAp t u := inr (fAp t u);

		  fNull := inr fNull;

		  fStackGet := inr fStackGet;
		  fStackSet := inr fStackSet;

		  fApplySubst t := inr (fApplySubst t);
		  fSingleSubst := inr fSingleSubst;
		  fSubst := inr fSubst;
		  fTruncSubst := inr fTruncSubst;

		  open_funcS f := match f with
		  				    | inr f => open_funcS f
		  				    | inl _ => None
		  				  end

       }.

	Global Instance OpenFuncExpr :
	   OpenFunc typ (expr typ func) := {
		  fConst t := Inj (fConst t);
		  fAp t u := Inj (fAp t u);

		  fNull := Inj fNull;

		  fStackGet := Inj fStackGet;
		  fStackSet := Inj fStackSet;

		  fApplySubst t := Inj (fApplySubst t);
		  fSingleSubst := Inj fSingleSubst;
		  fSubst := Inj fSubst;
		  fTruncSubst := Inj fTruncSubst;

		  open_funcS f := match f with
		  				    | Inj f => open_funcS f
		  				    | _ => None
		  				  end

       }.

End OpenFuncSum.

Section OpenFuncInst.

	Context {typ func : Type} {HBT : BaseType typ} {HLT : ListType typ}.
	Context {HR : RType typ} {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.

    Variable Typ2_tyArr : Typ2 _ Fun.
    Variable Typ0_tyProp : Typ0 _ Prop.

    Context {HST : SubstType typ} {HV : ValNull (typD tyVal)}.
    Context {HSTD : SubstTypeD}.
    Context {HBTD : BaseTypeD} {HLTD : ListTypeD}.

	Context {RelDec_string : RelDec (@eq (typD tyString))}.
	Context {RelDec_string_Correct : RelDec_Correct RelDec_string}.

    Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
    Let tyProp : typ := @typ0 _ _ _ _.

	Local Notation "'tyStack'" := (tyArr tyString tyVal).
	Local Notation "'tyExpr'" := (tyArr tyStack tyVal).
	Local Notation "'tySubstList'" := (tyList (tyPair tyString (tyArr tyStack tyVal))).

	Definition stack := @stack (typD tyString) (typD tyVal).

	Global Instance OpenFuncInst : OpenFunc typ (open_func typ) := {
	  fConst := of_const;
	  fAp := of_ap;
	  fNull := of_null;
	  fStackGet := of_stack_get;
	  fStackSet := of_stack_set;
	  fApplySubst := of_apply_subst;
	  fSingleSubst := of_single_subst;
	  fSubst := of_subst;
	  fTruncSubst := of_trunc_subst;

	  open_funcS f := Some f
	}.

  Definition typeof_open_func (f : open_func typ) : option typ :=
    match f with
    | of_const t => Some (tyArr t (tyArr tyStack t))
    | of_ap t u => Some (tyArr (tyArr tyStack (tyArr t u)) (tyArr (tyArr tyStack t) (tyArr tyStack u)))
    | of_apply_subst t => Some (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t)))
	| of_null => Some tyVal
    | of_stack_get => Some (tyArr tyString tyExpr)
    | of_stack_set => Some (tyArr tyString (tyArr tyVal (tyArr tyStack tyStack)))
    | of_single_subst => Some (tyArr tyExpr (tyArr tyString tySubst))
    | of_subst => Some (tyArr tySubstList tySubst)
    | of_trunc_subst => Some (tyArr tySubstList tySubst)
	end.

  Global Instance RelDec_open_func : RelDec (@eq (open_func typ)) :=
  { rel_dec := fun a b =>
	         match a, b with
	  	       | of_const t, of_const t'
	  	       | of_apply_subst t, of_apply_subst t' => t ?[eq] t'
	  	       | of_ap t u, of_ap t' u' => (t ?[eq] t' && u ?[eq] u')%bool
	  	       | of_null, of_null
	  	       | of_stack_get, of_stack_get
	  	       | of_stack_set, of_stack_set
	  	       | of_single_subst, of_single_subst
	  	       | of_subst, of_subst
	  	       | of_trunc_subst, of_trunc_subst => true
	  	       | _, _ => false
	         end
  }.

  Global Instance RelDec_Correct_open_func : RelDec_Correct RelDec_open_func.
  Proof.
    constructor.
    destruct x; destruct y; simpl; try rewrite andb_true_iff;
    repeat rewrite rel_dec_correct; try intuition congruence.
  Qed.

	Local Instance Applicative_Fun A : Applicative (Fun A) :=
	{ pure := fun _ x _ => x
	; ap := fun _ _ f x y => (f y) (x y)
	}.

  Definition fun_to_typ {a b : typ} (f : typD a -> typD b) : typD (tyArr a b) :=
    eq_rect_r id f (typ2_cast a b).

  Definition typ_to_fun {a b : typ} (f : typD (tyArr a b)) : typD a -> typD b :=
  fun x => (fun g : typD a -> typD b => g x)
    (eq_rect (typD (typ2 a b)) id f (typD a -> typD b)
       (typ2_cast a b)).

Definition fun_to_typ2 {a b c : typ} (f : typD a -> typD b -> typD c) :=
   fun_to_typ (fun x => fun_to_typ (f x)).

Definition fun_to_typ3 {a b c d : typ} (f : typD a -> typD b -> typD c -> typD d) :=
  fun_to_typ (fun x => fun_to_typ (fun y => fun_to_typ (f x y))).

Definition typ_to_fun2 {a b c : typ} (f : typD (tyArr a (tyArr b c))) : typD a -> typD b -> typD c :=
  fun x => typ_to_fun (typ_to_fun f x).

Definition typ_to_fun3 {a b c d : typ} (f : typD (tyArr a (tyArr b (tyArr c d)))) :
	typD a -> typD b -> typD c -> typD d :=
  fun x y => typ_to_fun (typ_to_fun (typ_to_fun f x) y).

  Definition fun1_wrap {a b : typ} (f : typD a -> typD b) :=
      eq_rect_r id f (typ2_cast a b).

  Definition fun1D {a b : typ} (f : typD (tyArr a b)) (x : typD a) : typD b :=
  (fun g : typD a -> typD b => g x)
    (eq_rect (typD (typ2 a b)) id f (typD a -> typD b)
       (typ2_cast a b)).

  Definition fun2_wrap {a b c : typ} (f : typD a -> typD b -> typD c) : typD (tyArr a (tyArr b c)) :=
    fun1_wrap (fun x => fun1_wrap (fun y : typD b => f x y)).

  Definition fun2D {a b c : typ} (f : typD (tyArr a (tyArr b c))) (x : typD a) (y : typD b) : typD c :=
    (fun g : typD a -> typD (typ2 b c) =>
      (fun h : typD a -> typD b -> typD c => h x y)
        (eq_rect (typD (typ2 b c)) (fun T : Type => typD a -> T) g
          (typD b -> typD c) (typ2_cast b c)))
      (eq_rect (typD (typ2 a (typ2 b c))) id f
         (typD a -> typD (typ2 b c)) (typ2_cast a (typ2 b c))).

  Definition fun3_wrap {a b c d : typ} (f : typD a -> typD b -> typD c -> typD d) :
   typD (tyArr a (tyArr b (tyArr c d))) :=
     fun1_wrap (fun x => fun2_wrap (fun y z => f x y z)).

  Definition fun4_wrap {a b c d e : typ} (f : typD a -> typD b -> typD c -> typD d -> typD e) :
   typD (tyArr a (tyArr b (tyArr c (tyArr d e)))) :=
     fun1_wrap (fun x => fun3_wrap (fun y z z' => f x y z z')).

(*
	 Program Definition open_func_symD bf :=
		match bf as bf return match typeof_open_func bf with
								| Some t => typD t
								| None => unit
							  end with
	    | of_cons t => typ2_cast_bin t tyStack t
	    	(eq_rect_r (fun T : Type => typD t -> T -> typD t)
	    		(@pure (Fun stack) (Applicative_Fun _) (typD t)) (typ2_cast d r))

	    | of_ap t u => _
	    | of_stack_set => _
	    | of_stack_get => _
	    | of_apply_subst t => _
	    | of_subst => _
	    | of_trunc_subst => _
	 end.
	 Next Obligation.
		apply typ3_cast_bin.
		unfold tyArr. repeat rewrite typ2_cast. unfold Fun.
		apply (@Applicative.ap (Fun stack) (Applicative_Fun _) (typD t) (typD u)).
	 Defined.
	 Next Obligation.
	    apply typ2_cast_bin.
	    unfold tyArr. rewrite typ2_cast.
	    apply (fun (x : typD d) (s : stack) => s x).
	 Defined.
	 Next Obligation.
	 	unfold tyArr; repeat rewrite typ2_cast; unfold Fun.
	 	pose (@stack_add (typD d) _ (@VN typ _ r null)). apply s.
	 Defined.
	 Next Obligation.
		unfold tyArr; repeat rewrite typ2_cast; unfold Fun.
		rewrite stSubst.
		apply (@apply_subst (typD d) (@VN typ _ r null) (typD t)).
	 Defined.
	 Next Obligation.
	    unfold tyArr; rewrite typ2_cast; unfold Fun.
	    rewrite btList, btPair, stSubst; repeat rewrite typ2_cast.
	    apply (@substl_aux (typD d) _ (@VN typ _ r null)).
	 Defined.
	 Next Obligation.
		unfold tyArr; rewrite typ2_cast; unfold Fun.
		rewrite btList, btPair, stSubst. repeat rewrite typ2_cast.
		apply (@substl_trunc_aux (typD d) _ (@VN typ _ r null)).
	 Defined.
*)

	    Definition substListD (lst : typD tySubstList) : substlist (A := typD tyString) (val := (typD tyVal)).
	    Proof.
	      rewrite btList, btPair, btString in lst.
	      unfold tyArr in lst.
	      repeat rewrite typ2_cast in lst.
	      rewrite btString in lst.
	      rewrite btString.
	      apply lst.
	   Defined.

	 Definition open_func_symD f : match typeof_open_func f with
	                                 | Some t => typD t
	                                 | None => unit
	                               end :=
		match f as f return match typeof_open_func f with
								| Some t => typD t
								| None => unit
							  end with
	      | of_const t =>
	        fun2_wrap
		      (eq_rect_r (fun T : Type => typD t -> T -> typD t) pure
		         (typ2_cast tyString tyVal))
	      | of_ap t1 t2 =>
	        fun3_wrap
	          (fun a b c => @ap (Fun (typD tyStack)) (Applicative_Fun _) (typD t1) (typD t2)
	            (fun2D a)
	            (fun1D b)
	            c)
	      | of_null => null
	      | of_stack_get => fun2_wrap (fun x s => (fun1D s) x)
	      | of_stack_set =>
	        (fun4_wrap
	          (fun a b c d => stack_add a b (fun1D c) d))
	      | of_apply_subst t => fun_to_typ3
	         (fun a b c => apply_subst
	           (fun x => typ_to_fun a (fun_to_typ x))
	           (eq_rect (typD tySubst) id b subst stSubst)
	           (typ_to_fun c))
	      | of_single_subst =>
	        fun2_wrap (fun a b => eq_rect_r id (subst1 (fun x => fun1D a (fun1_wrap x)) b) stSubst)
	      | of_subst =>
	        fun1_wrap
	          (fun a => eq_rect_r id
	            (substl_aux (substListD a)) stSubst)
	      | of_trunc_subst =>
	        fun1_wrap
	          (fun a => eq_rect_r id
	            (substl_trunc_aux (substListD a)) stSubst)
	    end.

	Global Program Instance RSym_OpenFunc : SymI.RSym (open_func typ) := {
	  typeof_sym := typeof_open_func;
	  symD := open_func_symD;
	  sym_eqb := (fun a b => Some (rel_dec a b))
	}.

  Global Instance RSymOk_lopen_func : SymI.RSymOk RSym_OpenFunc.
  Proof.
    constructor.
    intros. unfold sym_eqb; simpl.
    consider (a ?[ eq ] b); auto.
  Qed.

End OpenFuncInst.

Section OpenFuncOk.
  Context {typ func : Type} {HBT : BaseType typ} {HLT : ListType typ} {HST : SubstType typ}.
  Context {HR : RType typ} {HO: OpenFunc typ func} {Heq' : RelDec (@eq typ)}.
  Context {HS : RSym func} {Heq : RelDec (@eq (typD tyString))}.
  Context {HV : ValNull (typD tyVal)}.

  Context {HSTD : SubstTypeD}.
  Context {HBTD : BaseTypeD} {HLTD : ListTypeD}.

  Context  {Typ2_tyArr : Typ2 _ Fun}.
  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Class OpenFuncOk := {
    of_funcAsOk f e : open_funcS f = Some e -> forall t, funcAs f t = funcAs e t;
    of_fConstOk t : open_funcS (fConst t) = Some (of_const t);
    of_fApOk t u : open_funcS (fAp t u) = Some (of_ap t u);
    of_fNullOk : open_funcS fNull = Some of_null;
    of_fStackGetOk : open_funcS fStackGet = Some of_stack_get;
    of_fStackSetOk : open_funcS fStackSet = Some of_stack_set;
    of_fApplySubstOk t : open_funcS (fApplySubst t) = Some (of_apply_subst t);
    of_fSingleSubstOk : open_funcS fSingleSubst = Some of_single_subst;
    of_fSubstOk : open_funcS fSubst = Some of_subst;
    of_fTruncSubstOk : open_funcS fTruncSubst = Some of_trunc_subst
  }.

End OpenFuncOk.

Implicit Arguments OpenFuncOk [[HBT] [HLT] [HST] [HR] [HO] [Heq'] [HS] [Heq] [HV] [HSTD] [HBTD] [HLTD] [Typ2_tyArr]].

Section OpenFuncBaseOk.
  Context {typ func : Type} {HBT : BaseType typ} {HLT : ListType typ} {HST : SubstType typ}.
  Context {HR : RType typ} {HO: OpenFunc typ func} {Heq' : RelDec (@eq typ)}.
  Context {HS : RSym func} {Heq : RelDec (@eq (typD tyString))}.
  Context {HV : ValNull (typD tyVal)}.

  Context {HSTD : SubstTypeD}.
  Context {HBTD : BaseTypeD} {HLTD : ListTypeD}.

  Context  {Typ2_tyArr : Typ2 _ Fun}.
  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Program Instance open_funcOk : OpenFuncOk typ (open_func typ) := {
    of_funcAsOk := fun _ _ _ _ => eq_refl;
    of_fConstOk t := eq_refl;
    of_fApOk t u := eq_refl;
    of_fNullOk := eq_refl;
    of_fStackGetOk := eq_refl;
    of_fStackSetOk := eq_refl;
    of_fApplySubstOk t := eq_refl;
    of_fSingleSubstOk := eq_refl;
    of_fSubstOk := eq_refl;
    of_fTruncSubstOk := eq_refl
  }.

End OpenFuncBaseOk.

Section OpenFuncExprOk.
  Context {typ func : Type} `{HOK : OpenFuncOk typ func}.
  Context {HROk : RTypeOk}.

  Lemma open_funcSome (f : func) (e : open_func typ) (t : typ)
    (H : open_funcS f = Some e) :
      match typeof_open_func _ e with
        | Some t => funcAs f t <> None
        | None => False
      end.
  Proof.
    destruct HOK as [H1].
    specialize (H1 _ _ H).
    destruct e; simpl in *; intros H2;
    match goal with
      | H : funcAs _ ?t = None |- _ =>
        specialize (H1 t); rewrite H in H1; clear H;
              unfold funcAs in H1; simpl in H1;
              rewrite type_cast_refl in H1; [|apply _]; inversion H1
    end.
  Qed.

  Lemma OpenFunc_typeOk (f : func) (e : open_func typ) (H : open_funcS f = Some e) :
    typeof_sym f = typeof_open_func _ e.
  Proof.
    destruct HOK as [H1].
    specialize (H1 _ _ H).
 	destruct e; simpl in *;
    match goal with
      | |- typeof_sym ?f = Some ?t =>
	 	specialize (H1 t);
	 	simpl in H1;
 	 	unfold funcAs in H1; simpl in H1; rewrite type_cast_refl in H1; [|apply _];
 		generalize dependent (symD f);
 		destruct (typeof_sym f); simpl; intros; [forward|]; inversion H1
    end.
  Qed.

  Existing Instance RSym_sum.
  Existing Instance RSymOk_sum.

  Context {A : Type} {RSymA : RSym A}.

  Global Program Instance OpenFuncOkSumR : OpenFuncOk typ (A + func) := {
    of_funcAsOk :=
      fun a f H t =>
        match a with
          | inl b => _
          | inr b => _
        end;
    of_fConstOk t := of_fConstOk t (func := func);
    of_fApOk t u := of_fApOk t u (func := func);
    of_fNullOk := of_fNullOk (func := func);
    of_fStackGetOk := of_fStackGetOk (func := func);
    of_fStackSetOk := of_fStackSetOk (func := func);
    of_fApplySubstOk t := of_fApplySubstOk t (func := func);
    of_fSingleSubstOk := of_fSingleSubstOk (func := func);
    of_fSubstOk := of_fSubstOk (func := func);
    of_fTruncSubstOk := of_fTruncSubstOk (func := func)
  }.
  Next Obligation.
    apply (of_funcAsOk _ H).
  Qed.

  Global Program Instance OpenFuncOkSumL : OpenFuncOk typ (func + A) := {
    of_funcAsOk :=
      fun a f H t =>
        match a with
          | inl b => _
          | inr b => _
        end;
    of_fConstOk t := of_fConstOk t (func := func);
    of_fApOk t u := of_fApOk t u (func := func);
    of_fNullOk := of_fNullOk (func := func);
    of_fStackGetOk := of_fStackGetOk (func := func);
    of_fStackSetOk := of_fStackSetOk (func := func);
    of_fApplySubstOk t := of_fApplySubstOk t (func := func);
    of_fSingleSubstOk := of_fSingleSubstOk (func := func);
    of_fSubstOk := of_fSubstOk (func := func);
    of_fTruncSubstOk := of_fTruncSubstOk (func := func)
  }.
  Next Obligation.
    apply (of_funcAsOk _ H).
  Qed.

End OpenFuncExprOk.

Section MakeOpen.
	Context {typ func : Type} {HR : RType typ} {HS : SubstType typ}.
	Context {H : OpenFunc typ func} {H1 : ListFunc typ func}
	        {HBT : BaseType typ}.

    Context  {Typ2_tyArr : Typ2 _ Fun}.
    Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

	Local Notation "'tyStack'" := (tyArr tyString tyVal).

    Definition mkNull : expr typ func := Inj fNull.
	Definition mkConst (t : typ) (e : expr typ func) := App (fConst t) e.
	Definition mkAp (t u : typ) (f e : expr typ func) := App (App (fAp t u) f) e.
	Definition mkStackGet (x s : expr typ func) := App (App fStackGet x) s.
	Definition mkStackSet (x v s : expr typ func) := App (App (App fStackSet x) v) s.
	Definition mkApplySubst (t : typ) (P s : expr typ func) := App (App (fApplySubst t) P) s.
	Definition mkSingleSubst (e x : expr typ func) := App (App fSingleSubst e) x.
	Definition mkApplySingleSubst t P x e := mkApplySubst t P (mkSingleSubst x e).
	Definition mkSubst (s : expr typ func) := App fSubst s.
	Definition mkTruncSubst (s : expr typ func) := App fTruncSubst s.
	Definition mkApplyTruncSubst t P s := mkApplySubst t P (mkTruncSubst s).

	Fixpoint mkAps f es t :=
		match es with
			| nil => mkConst t f
			| (e, t')::es => mkAp t' t (mkAps f es (tyArr t' t)) e
		end.

	Context {HSf : RSym func}.
(*
	Fixpoint ap_lift_aux tus tvs (e : expr typ func) (t : typ) : option (expr typ func) :=
	  match e with
		| App f a =>
		  match typeof_expr tus tvs a with
		    | Some u =>
		        match ap_lift_aux tus tvs f (tyArr u t), ap_lift_aux tus tvs a u with
		    	  | Some f', Some a' => Some (mkAp u t f' a')
		    	  | _, _ => None
		    	end
		    | None => None
		  end
		| Inj f => Some (mkConst t (Inj f))
		| Abs u f => match (ap_lift_aux tus (u::tvs) f (tyArr u t)) with
					   | Some f' => Some (Abs (tyArr tyStack u) f')
					   | None => None
					 end

		| _ => Some e
	  end.

	Definition ap_lift2 tus tvs (e : expr typ func) :=
		match typeof_expr tus tvs e with
		  | Some t => ap_lift_aux tus tvs e t
		  | None => None
		end.
*)
	Require Import MirrorCharge.ModularFunc.ILogicFunc.
	Require Import MirrorCharge.ModularFunc.BILogicFunc.

	Context {HIL : ILogicFunc typ func}.
	Context {HBIL : BILogicFunc typ func}.

	Fixpoint il_lift tus tvs (e : expr typ func) :=
	  match e with
	    | App (App f a) b =>
	      match ilogicS f with
	        | Some (ilf_entails t) =>
	          match il_lift tus tvs a, il_lift tus tvs b with
	            | Some a', Some b' => Some (mkEntails (tyArr tyStack t) a' b')
	            | _, _ => None
	          end
	        | Some (ilf_and t) =>
	          match il_lift tus tvs a, il_lift tus tvs b with
	            | Some a', Some b' => Some (mkAnd (tyArr tyStack t) a' b')
	            | _, _ => None
	          end
	        | Some (ilf_or t) =>
	          match il_lift tus tvs a, il_lift tus tvs b with
	            | Some a', Some b' => Some (mkOr (tyArr tyStack t) a' b')
	            | _, _ => None
	          end
	        | Some (ilf_impl t) =>
	          match il_lift tus tvs a, il_lift tus tvs b with
	            | Some a', Some b' => Some (mkImpl (tyArr tyStack t) a' b')
	            | _, _ => None
	          end
	        | _ =>
	          match bilogicS f with
	            | Some (bilf_star t) =>
		          match il_lift tus tvs a, il_lift tus tvs b with
		            | Some a', Some b' => Some (mkStar (tyArr tyStack t) a' b')
		            | _, _ => None
		          end
	            | Some (bilf_wand t) =>
		          match il_lift tus tvs a, il_lift tus tvs b with
		            | Some a', Some b' => Some (mkWand (tyArr tyStack t) a' b')
		            | _, _ => None
		          end
	            | _ =>
	              match typeof_expr tus tvs e, typeof_expr tus tvs a, typeof_expr tus tvs b with
	                | Some t, Some u, Some v =>
	            	  match il_lift tus tvs f, il_lift tus tvs a, il_lift tus tvs b with
	            	    | Some f', Some a', Some b' =>
	            	      Some (mkAp v t (mkAp u (tyArr v t) f' a') b')
	            	    | _, _, _ => None
	            	  end
	            	| _, _, _ => None
	              end
	          end
	      end
	    | App f a =>
	      match ilogicS f with
	        | Some (ilf_exists u v) =>
	          match il_lift tus tvs a with
	            | Some a' => Some (App (fExists (tyArr tyStack u) (tyArr tyStack v)) a')
	            | None => None
	          end
	        | Some (ilf_forall u v) =>
	          match il_lift tus tvs a with
	            | Some a' => Some (App (fForall (tyArr tyStack u) (tyArr tyStack v)) a')
	            | None => None
	          end
	        | _ =>
	          match typeof_expr tus tvs e, typeof_expr tus tvs a with
	            | Some t, Some u =>
	              match il_lift tus tvs f, il_lift tus tvs a with
	                | Some f', Some a' => Some (mkAp u t f' a')
	                | _, _ => None
	              end
	            | _, _ => None
	          end
	      end
	    | Inj f =>
	      match ilogicS f with
	        | Some (ilf_true t) => Some (mkTrue (tyArr tyStack t))
	        | Some (ilf_false t) => Some (mkFalse (tyArr tyStack t))
	        | _ =>
	          match bilogicS f with
	            | Some (bilf_emp t) => Some (mkEmp (tyArr tyStack t))
	            | _ =>
	              match typeof_expr tus tvs e with
	                | Some t => Some (mkConst t e)
	                | None => None
	              end
	          end
	      end
		| Abs t f =>
		  match il_lift tus (t::tvs) f with
		    | Some f' => Some (Abs (tyArr tyStack t) f')
		    | None => None
		  end
	    | _ => Some e
	  end.
(*
	with ap_lift tus tvs (e : expr typ func) {struct e} :=
		match e with
		  | Abs t f =>
		    match il_lift tus (t::tvs) f with
		      | Some f' => Some (Abs (tyArr tyStack t) f')
		      | None => None
		    end
		  | Inj f =>
		    match typeof_expr tus tvs e with
		      | Some t => Some (mkConst t (Inj f))
		      | None => None
		    end
		  | App f a =>
		    match typeof_expr tus tvs e, typeof_expr tus tvs a with
		      | Some t, Some u =>
		        match il_lift tus tvs f, il_lift tus tvs a with
		          | Some f', Some a' => Some (mkAp u t f' a')
		          | _, _ => None
		        end
		      | _, _ => None
		    end
		  | _ => Some e
		end.
*)
End MakeOpen.

Require Import MirrorCharge.ModularFunc.BaseFunc.
Require Import MirrorCharge.ModularFunc.EmbedFunc.

Require Import MirrorCore.Lambda.ExprTac.

Section TypeOfFunc.
  Context {typ func : Type}.
  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {RSym_func : RSym func}.
    Lemma typeof_funcAs f t e (H : funcAs f t = Some e) : typeof_sym f = Some t.
    Proof.
      unfold funcAs in H.
      generalize dependent (symD f).
      destruct (typeof_sym f); intros; [|congruence].
      destruct (type_cast t0 t); [|congruence].
      destruct r; reflexivity.
    Qed.

      Lemma funcAs_Some f t (pf : typeof_sym f = Some t) :
        funcAs f t =
        Some (match pf in (_ = z)
          return match z with
                   | Some z' => typD z'
                   | None => unit
                 end
          with
          | eq_refl => symD f
          end).
      Proof.
        unfold funcAs.
        generalize (symD f).
        rewrite pf. intros.
        rewrite type_cast_refl. reflexivity. apply _.
      Qed.

End TypeOfFunc.

Section MakeOpenSound.
  Context {typ func subst : Type} {ST : SubstType typ} {BT : BaseType typ} {RType_typ : RType typ}.
  Context {OF : OpenFunc typ func} {ILF : ILogicFunc typ func} {BILF : BILogicFunc typ func} {BF : BaseFunc typ func}.
  Context {LT : ListType typ}.
  Context {EF : EmbedFunc typ func}.
  Context {RelDec_string : RelDec (@eq (typD tyString))}.
  Context {RelDec_typ : RelDec (@eq typ)}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {RSym_func : RSym func}.
  Context {RSym_funcOk : RSymOk RSym_func}.
  Context {Typ2_tyArr : Typ2 _ Fun}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {Typ2_tyArrOk : Typ2Ok Typ2_tyArr}.
  Context {HV : ValNull (typD tyVal)}.
  Context {HSTD : SubstTypeD}.
  Context {HBTD : BaseTypeD} {HLTD : ListTypeD}.
  Context {OFOK : OpenFuncOk typ func}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Let Expr_expr := Expr_expr (typ := typ) (func := func).
  Let ExprOk_expr := ExprOk_expr (typ := typ) (func := func).
  Let ExprUVar_expr := ExprUVar_expr (typ := typ) (func := func).

  Local Existing Instance Expr_expr.
  Local Existing Instance ExprOk_expr.
  Local Existing Instance ExprUVar_expr.

  Local Notation "'tyStack'" := (tyArr tyString tyVal).

  Lemma mkNull_sound (tus tvs : tenv typ) (f : func)
    (df : typD tyVal)
    (Ho : open_funcS f = Some of_null)
    (Hf : funcAs f tyVal = Some df) :
    exprD' tus tvs tyVal mkNull = Some (fun _ _ => df).
  Proof.
    unfold mkNull; simpl.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (of_funcAsOk _ Ho) as H; rewrite H in Hf.
    pose proof (of_fNullOk) as H1.
    pose proof (of_funcAsOk _ H1) as H2. rewrite <- H2 in Hf.
    pose proof (OpenFunc_typeOk _ H1) as H3. simpl in H3.
    rewrite (funcAs_Some _ H3).
    rewrite (funcAs_Some _ H3) in Hf.
    inv_all; subst. reflexivity.
  Qed.

  Lemma mkApplySubst_sound (tus tvs : tenv typ) (t : typ) (f : func) (e s : expr typ func)
    (df : typD (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t))))
    (de : ExprI.exprT tus tvs (typD (tyArr tyStack t)))
    (ds : ExprI.exprT tus tvs (typD tySubst))
    (Ho : open_funcS f = Some (of_apply_subst t))
    (Hf : funcAs f
            (tyArr (tyArr tyStack t)
              (tyArr tySubst (tyArr tyStack t))) = Some df)
    (Hs : exprD' tus tvs tySubst s = Some ds)
    (He : exprD' tus tvs (tyArr tyStack t) e = Some de) :
    exprD' tus tvs (tyArr tyStack t) (mkApplySubst t e s) =
      Some (exprT_App (exprT_App (fun _ _ => df) de) ds).
  Proof.
    unfold mkApplySubst; simpl.
    pose proof (exprD_typeof_Some _ _ _ _ _ Hs) as Hts.
    pose proof (exprD_typeof_Some _ _ _ _ _ He) as Hte.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (of_funcAsOk _ Ho) as H3; rewrite H3 in Hf.
    pose proof (of_fApplySubstOk t) as H5.
    pose proof (of_funcAsOk _ H5) as H6. rewrite <- H6 in Hf.
    pose proof (OpenFunc_typeOk _ H5) as H7. simpl in H7.
    unfold tyArr in *.
    rewrite (funcAs_Some _ H7).
    rewrite (funcAs_Some _ H7) in Hf.
    inv_all; subst. reflexivity.
  Qed.

End MakeOpenSound.


Require Export TM.TM.
Require Import Shared.FiniteTypes.DepPairs EqdepFacts.

Section While.

  Variable n : nat.
  Variable sig : finType.

  Variable F : finType.
  (** Label [None] indicates continueing, [Some f] means breaking out of the loop and terminating in the label [f]. *)
  Variable pM : pTM sig (option F) n.

  Definition While_trans :
    (TM.states (projT1 pM)) * Vector.t (option sig) n ->
    (TM.states (projT1 pM)) * Vector.t (option sig * move) n :=
    fun '(q,s) =>
      if halt q
      then (start (projT1 pM), nop_action)
      else trans (q,s).

  Definition WhileTM : mTM sig n :=
    Build_mTM While_trans (start (projT1 pM))
              (fun q => halt q && match projT2 pM q with
                               | Some _ => true
                               | None => false
                               end).

  Hypothesis (defF : inhabitedC F).

  Definition While_part : states (projT1 pM) -> F :=
    fun q =>
      match projT2 pM q with
      | Some y => y
      | None => default
      end.

  Definition While : pTM sig F n :=
    (WhileTM; While_part).

  Local Arguments loopM {_ _} _ _ _.
  Local Arguments halt {_ _} _ _.
  Local Arguments step {_ _} _ _.

  Lemma step_comp (c : mconfig sig (states (projT1 pM)) n) :
    haltConf c = false ->
    step (projT1 pM) c = step WhileTM c.
  Proof.
    intros HHalt. unfold haltConf in HHalt.
    destruct c as [q t]. cbn in *.
    cbv [step]. cbn. rewrite HHalt. reflexivity.
  Qed.

  Lemma halt_comp (c : mconfig sig (states (projT1 pM)) n) :
    haltConf (M := projT1 pM) c = false ->
    haltConf (M := WhileTM)     c = false.
  Proof.
    intros HHalt. cbn in *.
    destruct c as [q t]. cbn in *.
    apply andb_false_iff. now left.
  Qed.

  Lemma While_trans_repeat (c : mconfig sig (states WhileTM) n) :
    haltConf (M := projT1 pM) c = true ->
    projT2 pM (cstate c) = None ->
    step WhileTM c = initc (WhileTM) (ctapes c).
  Proof.
    intros HHalt HRepeat. unfold haltConf in HHalt.
    destruct c as [q t]; cbn in *.
    unfold step. cbn -[doAct_multi] in *. rewrite HHalt. unfold initc. f_equal. apply doAct_nop.
  Qed.

  Lemma While_split k (c1 c3 : mconfig sig (states (projT1 pM)) n) :
    loopM WhileTM c1 k = Some c3 ->
    exists k1 k2 c2,
      loopM (projT1 pM) c1 k1 = Some c2 /\
      loopM WhileTM c2 k2 = Some c3 /\
      k1 + k2 <= k.
  Proof.
    unfold loopM. intros HLoop.
    apply loop_split with (h := haltConf (M := projT1 pM)) in HLoop as (k1&c2&k2&HLoop&HLoop'&Hk).
    - exists k1, k2, c2. repeat split; eauto.
      apply loop_lift with (lift := id) (f' := step (projT1 pM)) (h' := haltConf (M := projT1 pM)) in HLoop.
      + apply HLoop.
      + auto.
      + apply step_comp.
    - apply halt_comp.
  Qed.

  Lemma While_split_repeat k (c1 c2 : mconfig sig (states WhileTM) n) :
    loopM WhileTM c1 k = Some c2 ->
    haltConf (M := projT1 pM) c1 = true ->
    projT2 pM (cstate c1) = None ->
    exists k' : nat,
      k = S k' /\
      loopM WhileTM (initc WhileTM (ctapes c1)) k' = Some c2.
  Proof.
    intros HLoop HHalt HRepeat. unfold haltConf in HHalt.
    destruct k as [ | k']; cbn in *.
    - rewrite HHalt, HRepeat in HLoop. cbn in HLoop. inv HLoop.
    - rewrite HHalt, HRepeat in HLoop. cbn in HLoop. exists k'. split. reflexivity.
      now rewrite While_trans_repeat in HLoop by auto.
  Qed.

  Lemma While_split_term k (c1 c2 : mconfig sig (states WhileTM) n) (f : F) :
    loopM WhileTM c1 k = Some c2 ->
    haltConf (M := projT1 pM) c1 = true ->
    projT2 pM (cstate c1) = Some f ->
    c2 = c1.
  Proof.
    intros HLoop HHalt HTerm. unfold loopM in *.
    eapply loop_eq_0. 2: apply HLoop. unfold haltConf in *. cbn in *. now rewrite HHalt, HTerm.
  Qed.

  Lemma While_merge_repeat k1 k2 (c1 c2 c3 : mconfig sig (states WhileTM) n) :
    loopM (projT1 pM) c1 k1 = Some c2 ->
    (projT2 pM) (cstate c2) = None ->
    loopM WhileTM (initc WhileTM (ctapes c2)) k2 = Some c3 ->
    loopM WhileTM c1 (k1+(1+k2)) = Some c3.
  Proof.
    intros HLoop1 HRepeat HLoop2. unfold loopM in *.
    eapply loop_lift with (lift := id) (f' := step (WhileTM)) (h' := haltConf (M := projT1 pM)) in HLoop1; cbv [id] in *; cbn; auto; cycle 1.
    { intros. symmetry. now apply step_comp. }
    apply loop_merge with (h := haltConf (M := projT1 pM)) (a2 := c2).
    - apply halt_comp.
    - apply HLoop1.
    - cbn [loop plus]. rewrite While_trans_repeat; auto. 2: apply (loop_fulfills HLoop1).
      cbn in *. setoid_rewrite (loop_fulfills HLoop1). now rewrite HRepeat.
  Qed.

  Lemma While_merge_term k1 (c1 c2 : mconfig sig (states WhileTM) n) (f : F) :
    loopM (projT1 pM) c1 k1 = Some c2 ->
    (projT2 pM) (cstate c2) = Some f ->
    loopM WhileTM c1 k1 = Some c2.
  Proof.
    intros HLoop HTerm. unfold loopM in *.
    eapply loop_lift with (lift := id) (f' := step (WhileTM)) (h' := haltConf (M := projT1 pM)) in HLoop; cbv [id] in *; cbn; auto; cycle 1.
    { intros. symmetry. now apply step_comp. }
    unfold loopM.
    replace k1 with (k1 + 0) by omega.
    apply loop_merge with (h := haltConf (M := projT1 pM)) (a2 := c2).
    - apply halt_comp.
    - apply HLoop.
    - cbn in *. setoid_rewrite (loop_fulfills HLoop). rewrite HTerm. cbn. reflexivity.
  Qed.

  (** ** Correctness of [While] *)

  Variable R : pRel sig (option F) n.

  Inductive While_Rel : pRel sig F n :=
  | While_Rel''_one :
      forall tin yout tout, R tin (Some yout, tout) -> While_Rel tin (yout, tout)
  | While_Rel''_loop :
      forall tin tmid yout tout,
        R tin (None, tmid) ->
        While_Rel tmid (yout, tout) ->
        While_Rel tin (yout, tout).

  Lemma While_Realise :
    pM ⊨ R -> While ⊨ While_Rel.
  Proof.
    intros HRel. hnf in HRel; hnf. intros t k; revert t. apply complete_induction with (x := k); clear k; intros k IH. intros tin c3 HLoop.
    apply While_split in HLoop as (k1&k2&c2&HLoop1&HLoop2&Hk).
    destruct (projT2 pM (cstate c2)) as [ f | ] eqn:E; cbn in *; [ clear IH | ].
    - apply While_split_term with (f := f) in HLoop2 as ->; auto. 2: apply (loop_fulfills HLoop1). unfold While_part. rewrite E.
      constructor 1. specialize HRel with (1 := HLoop1). now rewrite E in HRel.
    - apply While_split_repeat in HLoop2 as (k2'&->&HLoop2); auto. 2: apply (loop_fulfills HLoop1).
      specialize IH with (2 := HLoop2); spec_assert IH by omega.
      econstructor 2.
      + specialize HRel with (1 := HLoop1). rewrite E in HRel. eassumption.
      + apply IH.
  Qed.

  (** ** Termination of [While] *)
  Section While_TerminatesIn.
    Variable (T T' : Rel (tapes sig n) nat).

    Lemma While_TerminatesIn_ind :
      pM ⊨ R ->
      projT1 pM ↓ T' ->
      (forall (tin : tapes sig n) (k : nat),
          T tin k ->
          exists k1,
            T' tin k1 /\
            (forall ymid tmid, R tin (Some ymid, tmid) -> k1 <= k) /\
            (forall tmid, R tin (None, tmid) -> exists k2, T tmid k2 /\ 1 + k1 + k2 <= k)) ->
      WhileTM ↓T.
    Proof.
      intros Realise_M Term_M Hyp tin i. revert tin. apply complete_induction with (x:=i); clear i; intros i IH tin.
      intros (i1&HT1&HT2&HT3) % Hyp. (* todo: i *)
      pose proof (Term_M _ _ HT1) as (oconf&Hloop).
      specialize (Realise_M _ _ _ Hloop).
      destruct (projT2 pM (cstate oconf)) as [ ymid | ] eqn:E1.
      - specialize HT2 with (1 := Realise_M).
        exists oconf. eapply loop_monotone; eauto. eapply While_merge_term; eauto.
      - specialize HT3 with (1 := Realise_M) as (i2&HT3&Hi).
        specialize (IH i2 ltac:(omega) _ HT3) as (oconf2&Hloop2).
        exists oconf2. apply loop_monotone with (k1 := i1 + (1 + i2)). 2: omega.
        eapply While_merge_repeat; eauto.
    Qed.

  End While_TerminatesIn.

  (** Alternative for [While_TerminatesIn] using co-induction *)
  Section While_TerminatesIn_coind.
    Variable (T : Rel (tapes sig n) nat).

    CoInductive While_T : tRel sig n :=
    | While_T_intro tin k k1 :
        T tin k1 ->
        (forall tmid ymid,
            R tin (Some ymid, tmid) -> k1 <= k) ->
        (forall tmid,
            R tin (None, tmid) ->
            exists k2, While_T tmid k2 /\ 1 + k1 + k2 <= k) ->
        While_T tin k.

    Lemma While_TerminatesIn :
      pM ⊨ R ->
      projT1 pM ↓ T ->
      WhileTM ↓ While_T.
    Proof.
      intros HRel HTerm. eapply While_TerminatesIn_ind; eauto.
      intros tin k' HCoInd. destruct HCoInd as [ t k k1 H1 H2 H3 ]. eauto.
    Qed.

  End While_TerminatesIn_coind.

End While.

Arguments While : simpl never.
Arguments While {n sig F} pM {defF}.

(* Deprecated name *)
Notation WHILE := While.

(** ** (Co-) Induction Principle for Correctness (Running Time) of [While] *)

Section WhileInduction.
  Variable (sig : finType) (n : nat) (F : finType).

  Variable R1 : pRel sig (option F) n.
  Variable R2 : pRel sig F n.

  Lemma WhileInduction :
    (forall tin yout tout (HLastStep: R1 tin (Some yout, tout)), R2 tin (yout, tout)) ->
    (forall tin tmid tout yout
       (HStar : R1 tin (None, tmid)) (HLastStep : R2 tmid (yout, tout)), R2 tin (yout, tout)) ->
    While_Rel R1 <<=2 R2.
  Proof. intros H1 H2. intros tin tout. induction 1; eauto. Qed.

End WhileInduction.

Section WhileCoInduction.
  Variable (sig : finType) (n : nat) (F : finType).

  Variable R : pRel sig (option F) n.
  Variable T T' : tRel sig n.

  Lemma WhileCoInduction :
    (forall (tin : tapes sig n) (k : nat) (HT : T tin k),
        exists k1,
          T' tin k1 /\
          forall (ymid : option F) tmid,
            R tin (ymid, tmid) ->
            match ymid with
            | Some _ => k1 <= k
            | None => exists k2, T tmid k2 /\ 1 + k1 + k2 <= k
            end) ->
    T <<=2 While_T R T'.
  Proof.
    intros. cofix IH. intros tin k HT. specialize H with (1 := HT) as (k1&H1&H2). econstructor; eauto.
    - intros tmid ymid HR. specialize (H2 (Some ymid) tmid); cbn in *. auto.
    - intros tmid HR. specialize (H2 None tmid) as (k2&H3&H4); eauto.
  Qed.

End WhileCoInduction.

(** Alternative definition of [While_Rel] *)
Section OtherWhileRel.

  Variable (sig : finType) (n : nat) (F : finType).

  Variable R : Rel (tapes sig n) (option F * tapes sig n).

  Definition While_Rel' : pRel sig F n :=
    (star (R |_ None)) ∘ ⋃_y (R |_(Some y)) ||_y.

  Goal While_Rel R =2 While_Rel'.
  Proof.
    unfold While_Rel'. split.
    {
      apply WhileInduction; intros; cbn in *.
      - eexists. split. constructor. exists yout. auto.
      - destruct HLastStep as (y&IH1&?&<-&IH2); cbn in *.
        eexists. split; eauto. econstructor; eauto.
    }
    {
      intros tin (yout, tout) H.  cbn in H. destruct H as (tmid&HStar&HLastStep).
      induction HStar as [ tin | tin tmid tmid2 HS1 HS2 IH].
      - destruct HLastStep as (?&<-&H). now constructor.
      - spec_assert IH by assumption.
        destruct HLastStep as (?&<-&H).
        econstructor 2.
        + apply HS1.
        + apply IH.
    }
  Qed.

End OtherWhileRel.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Bool.Bool.
From Coq Require Import Strings.String.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Strings.String.
From Coq Require Import Logic.Eqdep_dec.
From Coq Require Import Logic.FunctionalExtensionality.

(** Based on https://softwarefoundations.cis.upenn.edu/ *)

(* Partial Map *)

Definition partial_map (A : Type) := nat -> (option A).

Definition empty {A : Type} : partial_map A := (fun _ => None).

Definition update {A : Type} (m : partial_map A) (x : nat) (v : A) : partial_map A :=
  fun (x' : nat) => if x =? x' then Some(v) else m x'.

Notation "x '|->' v ';' m" := (update m x v) (at level 100, v at next level, right associativity).

Lemma update_neq : forall A (m : partial_map A) x1 x2 v,
  x2 <> x1 ->
  (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. apply Nat.eqb_neq in H. rewrite H. reflexivity.
Qed.

Lemma update_permute : forall A (m : partial_map A) v1 v2 x1 x2,
  x2 <> x1 -> (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m v1 v2 x1 x2 H.
  apply functional_extensionality. intros. unfold update.
  case_eq (x1 =? x); case_eq (x2 =? x); intros.
  - apply Nat.eqb_eq in H0. apply Nat.eqb_eq in H1. subst. unfold not in H.
    assert (Trivial : x = x). { reflexivity. }
    apply H in Trivial. contradiction.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
  (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. apply functional_extensionality. intros. unfold update.
  case_eq (x =? x0); intros.
  - reflexivity.
  - reflexivity.
Qed.

(* Set *)

Definition set := nat -> bool.
Definition emptySet : set := (fun _ => false).
Definition singletonSet (v : nat) : set := fun (v' : nat) => if v =? v' then true else false.
Definition updateSet (s : set) (v : nat) : set := fun (v' : nat) => if v =? v' then true else s v'.
Definition removeFromSet (s : set) (v : nat) : set := fun (v' : nat) => if v =? v' then false else s v'.
Definition unionSet (s1 s2 : set) : set := fun (v : nat) => s1 v || s2 v.
Definition intersectionSet (s1 s2 : set) : set := fun (v : nat) => s1 v && s2 v.

Lemma update_set_permute : forall s a b,
  updateSet (updateSet s a) b = updateSet (updateSet s b) a.
Proof.
  intros.
  unfold updateSet.
  apply functional_extensionality. intros.
  destruct (a =? x); destruct (b =? x).
  all: reflexivity.
Qed.

Lemma remove_from_set_permute : forall s a b,
  removeFromSet (removeFromSet s a) b = removeFromSet (removeFromSet s b) a.
Proof.
  intros.
  unfold removeFromSet.
  apply functional_extensionality. intros.
  destruct (a =? x); destruct (b =? x).
  all: reflexivity.
Qed.

Lemma singleton_set_equals_update_empty : forall x,
  singletonSet x = updateSet emptySet x.
Proof.
  intros.
  unfold updateSet. unfold singletonSet.
  apply functional_extensionality. intros.
  unfold emptySet. reflexivity.
Qed.

Lemma update_set_permute_singleton : forall a b,
  updateSet (singletonSet a) b = updateSet (singletonSet b) a.
Proof.
  intros.
  unfold updateSet.
  apply functional_extensionality. intros.
  case_eq (a =? x); case_eq (b =? x); intros.
  all: try unfold singletonSet.
  all: try rewrite H.
  all: try rewrite H0.
  all: try reflexivity.
Qed.

Lemma update_set_permute_remove : forall s a b,
  (a =? b) = false ->
  updateSet (removeFromSet s a) b = removeFromSet (updateSet s b) a.
Proof.
  intros.
  apply functional_extensionality. intros.
  unfold updateSet. unfold removeFromSet.
  case_eq (a =? x); case_eq (b =? x); intros.
  apply Nat.eqb_eq in H0. apply Nat.eqb_eq in H1. subst.
  rewrite Nat.eqb_refl in H. discriminate.
  all: reflexivity.
Qed.

Lemma update_set_shadow : forall s a,
  s a = true -> s = updateSet s a.
Proof.
  intros.
  unfold updateSet.
  apply functional_extensionality. intros.
  case_eq (a =? x); intros.
  apply Nat.eqb_eq in H0. subst. assumption.
  reflexivity.
Qed.

Lemma update_set_twice : forall s x,
  (updateSet (updateSet s x) x) = (updateSet s x).
Proof.
  intros.
  apply functional_extensionality. intros.
  unfold updateSet.
  destruct (x =? x0).
  reflexivity.
  reflexivity.
Qed.

Lemma remove_from_set_twice : forall s x,
  (removeFromSet (removeFromSet s x) x) = (removeFromSet s x).
Proof.
  intros.
  apply functional_extensionality. intros.
  unfold removeFromSet.
  destruct (x =? x0).
  reflexivity.
  reflexivity.
Qed.

Lemma remove_after_update_set_1 : forall s x,
  s x = false ->
  (removeFromSet (updateSet s x) x) = s.
Proof.
  intros.
  apply functional_extensionality. intros.
  unfold removeFromSet.
  case_eq (x =? x0); intro.
  apply Nat.eqb_eq in H0. subst. symmetry. assumption.
  unfold updateSet. rewrite H0. reflexivity.
Qed.

Lemma remove_after_update_set_2 : forall s x,
  (removeFromSet (updateSet s x) x) = removeFromSet s x.
Proof.
  intros.
  apply functional_extensionality. intros.
  unfold removeFromSet.
  unfold updateSet.
  destruct (x =? x0).
  all: reflexivity.
Qed.

Lemma remove_from_empty : forall x,
  removeFromSet emptySet x = emptySet.
Proof.
  intros.
  apply functional_extensionality. intros.
  unfold removeFromSet. unfold emptySet.
  destruct (x =? x0). all: reflexivity.
Qed.

Lemma remove_from_singleton : forall x,
  removeFromSet (singletonSet x) x = emptySet.
Proof.
  intros.
  apply functional_extensionality. intros.
  unfold removeFromSet. unfold singletonSet.
  destruct (x =? x0). all: reflexivity.
Qed.

Lemma remove_not_existant_from_singleton : forall x x',
  (x =? x') = false ->
  removeFromSet (singletonSet x) x' = singletonSet x.
Proof.
  intros.
  apply functional_extensionality. intros.
  unfold removeFromSet. unfold singletonSet.
  case_eq (x =? x0); case_eq (x' =? x0); intros.
  all: try reflexivity.
  apply Nat.eqb_eq in H1. subst.
  apply Nat.eqb_eq in H0. subst.
  rewrite Nat.eqb_refl in H. discriminate.
Qed.


From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.
From iris.algebra Require Import gset gmap excl agree frac.
From iris.heap_lang.lib Require Export lock.
From iris.bi.lib Require Import fractional.

Set Default Proof Using "Type".
Import uPred.

(** Implementation of CLH lock in Heaplang. *)
Definition init_lock : val :=
  λ: "" ,
     let: "L" := ref #0 in
     "L" <- ref #false;;
     "L". (* GRANTED, lock is free*)

Definition init_proc :val :=
  λ: "",
  let: "t" := ref #0 in
  let: "R" := ref "t" in
  let: "W" := ref "t" in
  let: "P" := ("R","W") in
  (Fst "P") <- ref #false;;
  "P".

Definition grant : val :=
  λ:  "P", !(Fst "P") <- #false;;
          (Fst "P")<- !(Snd "P").

Definition spin : val :=
  rec: "spin" "watch" :=
    if: !"watch" = #false then #() (* loop until (P.watch->state = GRANTED)*)
                      else "spin" "watch".

Definition FAS : val :=
  rec: "FAS" "x" "newv" :=
    let: "oldv" := !"x" in
    let: "p" :=  CmpXchg "x" "oldv" "newv" in
    if: (Snd "p") then (Fst "p")
    else "FAS" "x" "newv".

Definition request : val :=
  λ: "L" "P" ,
    !(Fst "P") <- #true;; (* *P.myreq.state= PENDING *)
    (Snd "P") <- FAS "L" !(Fst "P");;
    spin !(Snd "P").

(** The CMRAs we need. *)
Class issuedG Σ :=
  issue_G :> inG Σ (exclR unitO).
Definition issuedΣ : gFunctors :=
  #[ GFunctor (exclR unitO)].

Instance subG_issuedΣ {Σ} : subG issuedΣ Σ → issuedG Σ.
Proof. solve_inG. Qed.

Class lockedG Σ :=
  locked_G :> inG Σ (exclR unitO).
Definition lockedΣ : gFunctors :=
  #[ GFunctor (exclR unitO)].

Instance subG_lockedΣ {Σ} : subG lockedΣ Σ → lockedG Σ.
Proof. solve_inG. Qed.

Definition stateUR  : cmraT :=
  (prodR fracR (agreeR (leibnizO bool))).

Class stateG Σ :=
  state_G :> inG Σ stateUR.
Definition stateΣ : gFunctors :=
  #[ GFunctor stateUR].

Instance subG_stateΣ {Σ} : subG stateΣ Σ → stateG Σ.
Proof. solve_inG. Qed.

Section proof.

  Context `{!heapG Σ, !issuedG Σ, !lockedG Σ, !stateG Σ} (N : namespace).

(* ISSUED is not duplicable. Only the thread that has ISSUED can spin on the corresponding node. It is allocated when init isProc.*)
Definition ISSUED γ : iProp Σ := (own γ (Excl ()))%I.
Lemma issued_exclusive (γ : gname) : ISSUED γ  -∗ ISSUED γ  -∗ False.
Proof.
  iDestruct 1 as  "H1". iDestruct 1 as  "H2".
  iDestruct (own_valid_2 with "H1 H2") as %[].
Qed.

(* LOCKED is not duplicable. Thread get it after acquairing the lock and give it back when releasing. It is allocated when init isLock*)
Definition LOCKED γ : iProp Σ := (own γ (Excl ()))%I.
Lemma locked_exclusive (γ : gname) : LOCKED γ -∗ LOCKED γ -∗ False.
Proof.
  iDestruct 1 as  "H1". iDestruct 1 as  "H2".
  iDestruct (own_valid_2 with "H1 H2") as %[].
Qed.

(* Abstract state. The value of b indicates the real value of the node. The definition is same as the one used for modular counter(with minor modification). *)
Definition newstate (q:Qp) (b:bool):stateUR := (q, to_agree (b : leibnizO bool)).

Notation "γ ⤇[ q ] b" := (own γ ( newstate q  b))
                             (at level 20, q at level 50, format "γ ⤇[ q ] b") : bi_scope.
Notation "γ ⤇½ b" := (own γ (newstate (1/2) b))
                         (at level 20, format "γ ⤇½  b") : bi_scope.

Definition Locked γ1 γ3: iProp Σ := (LOCKED γ3 ∗ γ1 ⤇[1/2] false)%I.

Global Instance makeElem_fractional γ m:  Fractional(λ q, γ ⤇[ q ] m)%I.
Proof.
  intros p q. rewrite /newstate.
  rewrite -own_op; f_equiv.
  split; first done.
    by rewrite /= agree_idemp.
Qed.

Global Instance makeElem_as_fractional γ m q:
  AsFractional (own γ (newstate q m)) (λ q, γ ⤇[q] m)%I q.
Proof.
  split. done. apply _.
Qed.

Global Instance makeElem_Exclusive m: Exclusive (newstate 1 m).
Proof.
  intros [y ?] [H _]. apply (exclusive_l _ _ H).
Qed.

Lemma makeElem_op p q n: newstate p n ⋅ newstate q n ≡ newstate (p + q) n.
Proof.
  rewrite /newstate; split; first done.
    by rewrite /= agree_idemp.
Qed.

Lemma makeElem_eq γ p q (n m : bool): γ ⤇[p] n -∗ γ ⤇[q] m -∗ ⌜n = m⌝.
Proof.
  iIntros "H1 H2".
  iDestruct (own_valid_2 with "H1 H2") as %HValid.
  destruct HValid as [_ H2].
  iIntros "!%"; by apply agree_op_invL'.
Qed.

Lemma makeElem_entail γ p q (n m : bool): γ ⤇[p] n -∗ γ ⤇[q] m -∗ γ ⤇[p + q] n.
Proof.
  iIntros "H1 H2".
  iDestruct (makeElem_eq with "H1 H2") as %->.
  rewrite <- makeElem_op.
  iSplitL "H1";done.
Qed.

Lemma makeElem_update γ (n m k : bool): γ ⤇½ n -∗ γ ⤇½ m ==∗ γ ⤇[1] k.
Proof.
  iIntros "H1 H2".
  iDestruct (makeElem_entail with "H1 H2") as "H".
  rewrite Qp_div_2.
  iApply (own_update with "H"); by apply cmra_update_exclusive.
Qed.

Lemma dummy: (1/2 + 1/2 + 1/2 = 3/2)%Qp.
Proof.
  apply (bool_decide_unpack _).
  by compute.
Qed.

Lemma invalidST γ:  γ⤇[3 / 2]false -∗ False.
Proof.
  iIntros "H".
  iDestruct (own_valid with "H") as %[[] _].
  eauto.
Qed.

(** Specifications for CLH lock *)
Definition nodeInv l R γ1 γ2 γ3: iProp Σ:=
  ∃ (m :bool), l ↦ #m ∗ γ1 ⤇[1/2] m ∗( ⌜m= true⌝
                                ∨ ⌜ m= false ⌝ ∗ ISSUED γ2
                                ∨ ⌜ m= false ⌝ ∗ Locked γ1 γ3 ∗ R ).

Definition isProc p (n:bool) R γ1 γ2 γ3 γ1' γ2' : iProp Σ:=
  ∃(req watch l1 l2 :loc)  , ⌜p = (#req, #watch)%V ⌝ ∗ req ↦ #l1 ∗ watch ↦ #l2  ∗ γ1 ⤇[1/2] n ∗ inv (N.@ "node") (nodeInv l1 R γ1 γ2 γ3) ∗
      (⌜n= false ⌝  ∨ ⌜n=true⌝  ∗ inv (N.@"node") (nodeInv l2 R γ1' γ2' γ3) ).

Definition lockInv l R γ3: iProp Σ:=
  ∃(k:loc) γ1 γ2, l ↦ #k ∗ ISSUED γ2  ∗ inv (N.@ "node") (nodeInv k R γ1 γ2 γ3).

Definition isLock l R γ3 : iProp Σ:=
   inv (N .@ "lock") (lockInv l R γ3 ).

Lemma init_lock_spec (R: iProp Σ) :
  {{{R}}}init_lock #() {{{l, RET #l; ∃ γ3, isLock l R γ3 }}}.
Proof.
  iIntros (ϕ) "HR Hcont".
  rewrite -wp_fupd.
  wp_lam.
  wp_alloc l as "Hlpt".
  wp_pures.
  wp_alloc k as "Hkpt".
(**  iDestruct "Hpt" as (t) "Hlpt". *)
  wp_store.
  iMod (own_alloc (Excl ())) as (γ3) "HL".
  {done. }
  iMod (own_alloc (Excl ())) as (γ2) "HIS".
  {done. }
  iMod (own_alloc (newstate 1 false)) as (γ1) "[HST1 HST2]".
  {done. }
  iMod (inv_alloc (N .@ "node") _ (nodeInv k R γ1 γ2 γ3 ) with "[-Hcont Hlpt HIS]") as "Hinv".
  {iNext. iExists false.  eauto with iFrame. }
  iApply "Hcont".
  rewrite /isLock.
  iExists γ3.
  iMod (inv_alloc (N .@ "lock") _ (lockInv l R γ3) with "[Hlpt Hinv HIS]").
  {iNext. iExists k,γ1, γ2. iFrame. }
  iModIntro.
  iFrame.
Qed.

Lemma init_proc_spec R γ3 :
  {{{True }}}
    init_proc #()
    {{{p, RET p; ∃ γ1 γ2 γ1' γ2', isProc p false R γ1 γ2 γ3 γ1' γ2'}}}.
Proof.
  iIntros (ϕ) "_ Hcont".
  rewrite -wp_fupd.
  wp_lam.
  wp_alloc k.
  wp_alloc req as "Hreq".
  wp_let.
  wp_alloc watch as "Hwatch".
  wp_let.
  wp_pures.
  wp_alloc l1 as "Hl1pt".
  wp_proj;wp_store.
  iMod (own_alloc (Excl ())) as (γ2) "HIS".
  {done. }
  iMod (own_alloc (newstate 1 false)) as (γ1) "[HST1 HST2]".
  {done. }
  iMod (inv_alloc (N .@ "node") _ (nodeInv l1 R γ1 γ2 γ3) with "[-Hcont HST1 Hreq Hwatch]") as "Hinv".
  {iNext. iExists false.  eauto with iFrame. }
  iApply "Hcont".
  iExists γ1, γ2, γ3, γ1.
  iModIntro.
  iFrame.
  iExists req, watch, l1, k.
  eauto with iFrame.
Qed.

Lemma spin_spec (k:loc) R γ1 γ2 γ3 :
  {{{ inv (N.@"node") (nodeInv k R γ1 γ2 γ3) ∗ ISSUED γ2}}}
    spin #k
    {{{RET #(); inv (N.@"node") (nodeInv k R γ1 γ2 γ3) ∗  Locked γ1 γ3∗ R}}}.
Proof.
  iIntros (ϕ) "[#Hnode HIS] Hcont".
  iLöb as "IH".
  wp_lam.
  wp_bind (! _)%E.
  iInv (N .@ "node") as (b) "(>Hkpt & >HST1 & [>% |[[>% >HISS] | [>% [>HL HR]]]])" "Hclose".
  - destruct b.
    * wp_load. (* false case *)
      iMod ("Hclose" with "[Hkpt HST1]") as "_".
      {iNext. iExists true.  eauto with iFrame. }
      iModIntro.
      wp_op;wp_if_false.
      iApply ("IH" with "HIS Hcont").
    * discriminate H.
  - iDestruct (issued_exclusive with "HIS HISS") as %[].
  - destruct b.
    * discriminate H.
    * wp_load.
      iMod ("Hclose" with "[Hkpt HIS HST1]") as "_".
      {iNext. iExists false.  eauto with iFrame. }
      iModIntro.
      wp_op;wp_if_true.
      iApply "Hcont".
      eauto with iFrame.
Qed.

(* Fetch-and-store operation(atomic) *)
Lemma FAS_spec l l1 R γ1 γ2 γ3:
  {{{isLock l R γ3 ∗ ISSUED γ2 ∗ inv (N.@"node") (nodeInv l1 R γ1 γ2 γ3) }}}
    FAS #l #l1
    {{{k, RET #k; ∃ γ1' γ2', ISSUED γ2' ∗ inv (N.@"node") (nodeInv k R γ1' γ2' γ3)}}}.
Proof.
  iIntros (ϕ) "[#Hlkinv [Hl1IS #Hnodeinv]] Hcont".
  iLöb as "IH".
  rewrite /isLock.
  wp_lam.
  wp_let.
  wp_bind (! _)%E.
  iInv (N .@ "lock") as (k γ1' γ2') "(>Hlpt & >HkIS & #Hknode)" "Hclose".
  wp_load.
  iMod ("Hclose" with "[Hlpt HkIS Hknode]") as "_".
  {iNext. iExists k ,γ1', γ2'. iFrame. iFrame "#". }
  iModIntro.
  wp_let.
  wp_bind (CmpXchg _ _ _)%E.
  iInv (N .@ "lock") as (k' γ1'' γ2'') "(>Hlpt & Hk'IS & #Hk'node)" "Hclose".
  destruct (decide (k = k')) as [->|Hneq].
  + (* FAS succ case*)
    wp_cmpxchg_suc.
    iMod("Hclose" with "[Hlpt Hl1IS Hnodeinv]") as "_".
    { iNext. iExists l1, γ1, γ2. iFrame. iFrame "#". }
    iModIntro.
    wp_let;wp_proj;wp_if_true;wp_proj.
    iApply "Hcont".
    eauto with iFrame.
  + wp_cmpxchg_fail.
    iMod("Hclose" with "[Hlpt Hk'IS Hknode]") as "_".
    { iNext. iExists k', γ1'', γ2''. iFrame. iFrame "#". }
    iModIntro.
    wp_let;wp_proj;wp_if_false.
    iApply ("IH" with "Hl1IS Hcont").
Qed.

Lemma request_spec l p R γ1 γ2 γ3 γ1' γ2':
  {{{isProc p false R γ1 γ2 γ3 γ1' γ2'∗ isLock l R γ3}}}
    request #l p
    {{{RET #(); ∃ γ1'' γ2'', isProc p true R γ1 γ2 γ3 γ1'' γ2'' ∗ Locked γ1'' γ3 ∗ R}}}.
Proof.
   iIntros (ϕ) "(Hpc & #Hlkinv) Hcont".
   iDestruct "Hpc" as (req watch l1 l2) "(-> & Hreq & Hwatch & HST1 & #Hpcinv & [Hdisj1| Hdisj2] )".
   - rewrite /isLock.
     rewrite /lockInv.
     wp_lam; wp_let;wp_proj;wp_load.
     wp_bind (_ <- _)%E.
     iInv (N .@ "node") as (b) "(>Hl1pt & >HST2 & [>% |[[>% >HIS] | [>% [>[HL HST3] HR]]]])" "Hclose".
     + destruct b.
       * iDestruct (makeElem_eq with "HST1 HST2") as %H'.
         discriminate H'.
       * discriminate H.
     + destruct b.
        * iDestruct (makeElem_eq with "HST1 HST2") as %H'.
         discriminate H'.
        * wp_store.
          iMod (makeElem_update _ _ _ true with "HST1 HST2") as "[HST1 HST2]".
          iMod ("Hclose" with "[Hl1pt HST2]") as "_".
          {iNext. iExists true. eauto with iFrame. }
          iModIntro.
          wp_seq;wp_proj;wp_load.
          wp_bind (FAS _ _)%E.
          (*FAS*)
          iApply (FAS_spec l l1 R γ1 γ2 γ3  with "[Hlkinv HIS Hpcinv]").
          {iFrame. rewrite /isLock. iFrame "#". }
          iNext.
          iIntros (k') "HPostFAS".
          iDestruct "HPostFAS" as (γ1'' γ2'') "[Hk'IS #Hk'node]".
          (* Spin *)
          wp_proj;wp_store;wp_proj;wp_load.
          iApply (spin_spec k' R γ1'' γ2'' γ3 with "[Hk'node Hk'IS]").
          { iFrame. iFrame "#". }
          iNext. iIntros "[_ [HL HSTk']]".
          iApply "Hcont".
          iFrame.
          rewrite /isProc.
          iExists γ1'', γ2''.
          iFrame.
          iExists req, watch, l1, k'.
          iFrame "#".
          eauto with iFrame.
     + iDestruct (makeElem_entail with "HST1 HST2") as "HSTT".
       iDestruct (makeElem_entail with "HSTT HST3") as "H".
       rewrite dummy.
       iDestruct (invalidST with "H") as %[].
   - iDestruct "Hdisj2" as "[% _]".
     discriminate H.
Qed.

Lemma grant_spec p R γ1 γ2 γ3 γ1' γ2':
  {{{isProc p true R γ1 γ2 γ3 γ1' γ2' ∗ Locked γ1' γ3 ∗ R}}}
    grant p
    {{{RET #(); isProc p false R γ1' γ2' γ3 γ1' γ2'}}}.
Proof.
  iIntros (ϕ) "(Hpc & [[HL HST] HR]) Hcont".
  iDestruct "Hpc" as (req watch l1 l2) "(-> & Hreq & Hwatch & HST1 & #Hpcinv & [%| Hdisj2] )".
  - discriminate H.
  - wp_lam;wp_proj;wp_load.
    wp_bind (_ <- _)%E.
    iInv (N .@ "node") as (b) "(>Hl1pt & >HST2 & [>% |[[>% >HIS] | [>% [[>HLL >HST3] _]]]])" "Hclose".
    + destruct b.
      * wp_store.
        iMod (makeElem_update _ _ _ false with "HST1 HST2") as "[HST1 HST2]".
        iMod("Hclose" with "[Hl1pt HST1 HST2 HL HR]") as "_".
        { iNext. iExists false. eauto with iFrame. }
        iModIntro.
        wp_seq.
        wp_proj;wp_load;wp_proj.
        wp_store.
        iApply ("Hcont").
        iExists req, watch, l2, l2.
        iDestruct "Hdisj2" as "(_ & #Hl2node)".
        eauto with iFrame.
      * discriminate H.
    + destruct b.
      * discriminate H.
      * iDestruct (makeElem_eq with "HST1 HST2") as %H'.
        discriminate H'.
    + iDestruct (locked_exclusive with "HL HLL") as%[].
Qed.

End proof.