Require Import String.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import Coq.Program.Equality.
Require Import SystemF.
Require Import Infrastructure.

Module MSubtyping
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module MInfrastructure := MInfrastructure(VarTyp)(set).
Export MInfrastructure.

(* Notes:

The syntax is encoded using Charguéraud's Locally nameless representation:

http://www.chargueraud.org/softs/ln/

 *)

Inductive Atomic : PTyp -> Prop :=
  | AInt : Atomic PInt
  | AFun : forall t1 t2, Atomic (Fun t1 t2)
  | AVar : forall v, Atomic (PFVarT v)
  | AForAll : forall d t, Atomic (ForAll d t)
  | ARec : forall l t, Atomic (Rec l t).
(*  | ATop : Atomic Top. *)

Hint Constructors Atomic.
Hint Constructors STType.

(* Subtyping relation *)

Inductive usub : PTyp -> PTyp -> Prop :=
  | USInt : usub PInt PInt
  | USFun : forall o1 o2 o3 o4, usub o3 o1 -> usub o2 o4 -> usub (Fun o1 o2) (Fun  o3 o4)
  | USAnd1 : forall t t1 t2, usub t t1 -> usub t t2 -> usub t (And  t1 t2)
  | USAnd2 : forall t t1 t2 , usub t1 t -> PType t2 -> usub (And t1 t2) t
  | USAnd3 : forall t t1 t2, usub t2 t -> PType t1 -> usub (And t1 t2) t
  | USVar   : forall v, usub (PFVarT v) (PFVarT v)
  | USForAll : forall L d1 d2 t1 t2,
                 (forall x, not (In x L) -> usub (open_typ_source t1 (PFVarT x))
                                           (open_typ_source t2 (PFVarT x))) ->
                 usub d2 d1 ->
                 usub (ForAll d1 t1) (ForAll d2 t2)
  | USTop : forall t, PType t -> usub t Top
  | USRec : forall l t1 t2, usub t1 t2 -> usub (Rec l t1) (Rec l t2).

Inductive and_coercion (e : SExp var) : PTyp -> sum (SExp var) (SExp var) -> Prop :=
  | ACInt : and_coercion e PInt (inr e)
  | ACFunL : forall A B e1, and_coercion e B (inl e1) ->
                       and_coercion e (Fun A B) (inl (STLam _ e1))
  | ACFunR : forall A B, and_coercion e B (inr e) ->
                    and_coercion e (Fun A B) (inr e)
  | ACAndL : forall A B e1 e2, and_coercion e A (inl e1) ->
                          and_coercion e B (inl e2) ->
                          and_coercion e (And A B) (inl (STPair _ e1 e2))
  | ACAndR1 : forall A B, and_coercion e A (inr e) ->
                     and_coercion e (And A B) (inr e)
  | ACAndR2 : forall A B, and_coercion e B (inr e) ->
                     and_coercion e (And A B) (inr e)
  | ACVar : forall x, and_coercion e (PFVarT x) (inr e)
  | ACForAllL : forall L A d e1,
                  (forall x, not (In x L) ->
                        and_coercion e (open_typ_source A (PFVarT x)) (inl e1)) ->
                  and_coercion e (ForAll d A) (inl (STTLam _ e1))
  | ACForAllR : forall L A d,
                  (forall x, not (In x L) ->
                        and_coercion e (open_typ_source A (PFVarT x)) (inr e)) ->
                  and_coercion e (ForAll d A) (inr e)
  | ACTop : and_coercion e Top (inl (STUnit _))
  | ACRec : forall l t r, and_coercion e t r ->
                     and_coercion e (Rec l t) r.

Hint Constructors and_coercion.

(* Some properties about and_coercion *)

Definition join_sum : forall {A}, A + A -> A.
  intros A H; destruct H as [a | a]; exact a.
Defined.

Lemma ac_inr_inv : forall t e e', and_coercion e t (inr e') -> and_coercion e t (inr e).
Proof.
  intros.
  dependent induction H; eauto.
Qed.

Hint Resolve ac_inr_inv.

Lemma ac_inr_inv_eq : forall t e e', and_coercion e t (inr e') -> e = e'.
Proof.
  intros.
  dependent induction H; eauto.
Qed.

Lemma ac_subst :
  forall t, PType t ->
       forall e c y x,
         x <> y ->
         and_coercion e t c ->
         and_coercion e (subst_typ_source y (PFVarT x) t) c.
Proof.
  intros t Ht.
  induction Ht; intros; eauto.
  - destruct c. inversion H0.
    simpl in *; apply ac_inr_inv_eq in H0; subst.
    destruct (eqb x y); auto.
  - simpl in *.
    destruct c.
    inversion H0; subst.
    apply ACFunL; auto.
    assert (Ha : and_coercion e (Fun t1 t2) (inr s)) by assumption.
    apply ac_inr_inv_eq in Ha; subst.
    inversion H0; subst; auto.
  - simpl in *; destruct c.
    inversion H0; subst.
    apply ACAndL; auto.
    assert (Ha : and_coercion e (And t1 t2) (inr s)) by assumption.
    apply ac_inr_inv_eq in Ha; subst.
    inversion H0; subst; eauto.
  - simpl in *.
    destruct c.
    inversion H2; subst.
    eapply ACForAllL with (L := union L0 (union L (singleton y))); intros z H3.
    rewrite subst_typ_source_open_source_var.
    apply H0.
    not_in_L z.
    assumption.
    apply H4.
    not_in_L z.
    not_in_L z.
    auto.
    assert (Ha : and_coercion e (ForAll d t0) (inr s)) by assumption.
    apply ac_inr_inv_eq in H2; subst.
    inversion Ha; subst.
    eapply ACForAllR with (L := union L0 (union L (singleton y))); intros z H4.
    rewrite subst_typ_source_open_source_var.
    apply H0.
    not_in_L z.
    assumption.
    apply H3.
    not_in_L z.
    not_in_L z.
    auto.
  - inversion H0; subst; simpl; auto.
Qed.

Lemma ac_rename :
  forall L t e c, forall y, PType (open_typ_source t (PFVarT y)) ->
    ~ In y (union L (fv_ptyp t)) -> and_coercion e (open_typ_source t (PFVarT y)) c ->
    (forall x : elt, ~ In x L -> and_coercion e (open_typ_source t (PFVarT x)) c).
Proof.
  intros.
  destruct (VarTyp.eq_dec x y).
  subst; auto.
  rewrite subst_typ_source_intro with (x := y); auto.
  apply ac_subst; auto.
  not_in_L y.
Qed.

Lemma ac_ex : forall L e t,
  (forall x, ~ In x L -> PType (open_typ_source t (PFVarT x))) ->
  (forall x, ~ In x L -> exists c, and_coercion e (open_typ_source t (PFVarT x)) c) ->
  exists c, forall x, ~ In x L -> and_coercion e (open_typ_source t (PFVarT x)) c.
Proof.
  intros L e t H0 H.
  pick_fresh x.
  assert (Ha : ~ In x L) by not_in_L x.
  apply H in Ha.
  destruct Ha as [c HAC].
  exists c.
  intros.
  apply ac_rename with (y := x) (L := L); auto.
  apply H0.
  not_in_L x.
  not_in_L x.
Qed.

Lemma ac_ptype : forall t e, PType t -> exists x, and_coercion e t x.
Proof.
  intros t e Ht.
  induction Ht; eauto.
  - destruct IHHt1, IHHt2.
    destruct x, x0; eauto; apply ac_inr_inv in H0; eauto.
  - destruct IHHt1, IHHt2.
    destruct x, x0; eauto.
  - apply (ac_ex _ _ _ H) in H0.
    destruct IHHt.
    destruct H0.
    destruct x0.
    eexists.
    eapply ACForAllL with (L := L).
    intros.
    apply H0.
    auto.
    eexists.
    eapply ACForAllR with (L := L).
    intros.
    apply H0 in H2.
    now apply ac_inr_inv in H2.
  - destruct IHHt; eauto.
Qed.

(* and_coercion lemmas *)

Lemma ac_inl_term : forall e t r, and_coercion e t (inl r) -> STTerm r.
Proof.
  intros.
  dependent induction H; auto.
  - apply_fresh STTerm_Lam as x.
    unfold open; rewrite <- open_rec_term; auto.
  - pick_fresh x.
    assert (Ha : ~ In x L) by not_in_L x.
    apply H0 in Ha.
    apply body_typ_term_to_term_abs.
    unfold body_typ_term.
    exists (fv e1).
    intros; unfold open_typ_term; rewrite <- open_rec_typ_term_term; auto.
Qed.

Lemma ac_inr_term : forall e t r, STTerm e -> and_coercion e t (inr r) -> STTerm r.
Proof. intros; apply ac_inr_inv_eq in H0; now subst. Qed.

Lemma and_coercion_proj1_term :
  forall t0 (c : SExp var) c',
    PType t0 ->
    STTerm c ->
    and_coercion ((STApp _ c (STProj1 _ (STBVar _ 0)))) t0 c' ->
    STTerm (STLam _ (join_sum c')).
Proof.
  intros.
  apply_fresh STTerm_Lam as x; unfold open; simpl.
  destruct c'; simpl.
  apply ac_inl_term in H1.
  rewrite <- open_rec_term; auto.
  apply ac_inr_inv_eq in H1.
  rewrite <- H1.
  simpl.
  apply STTerm_App; auto.
  rewrite <- open_rec_term; auto.
Qed.

Lemma and_coercion_proj2_term :
  forall t0 (c : SExp var) c',
    PType t0 ->
    STTerm c ->
    and_coercion ((STApp _ c (STProj2 _ (STBVar _ 0)))) t0 c' ->
    STTerm (STLam _ (join_sum c')).
Proof.
  intros.
  apply_fresh STTerm_Lam as x; unfold open; simpl.
  destruct c'; simpl.
  apply ac_inl_term in H1.
  rewrite <- open_rec_term; auto.
  apply ac_inr_inv_eq in H1.
  rewrite <- H1.
  simpl.
  apply STTerm_App; auto.
  rewrite <- open_rec_term; auto.
Qed.

Lemma same_coercion :
  forall A, PType A ->
       forall e c1 c2, and_coercion e A c1 -> and_coercion e A c2 -> c1 = c2.
Proof.
  intros A HPT.
  induction HPT; intros.
  - now inversion H; inversion H0.
  - now inversion H; inversion H0.
  - inversion H; inversion H0; subst; eauto.
    + apply f_equal.
      now apply (IHHPT2 _ _ _ H4) in H8; inversion H8.
    + now apply (IHHPT2 _ _ _ H4) in H8; inversion H8.
    + now apply (IHHPT2 _ _ _ H4) in H8; inversion H8.
  - inversion H; inversion H0; subst; eauto.
    + apply f_equal.
      apply (IHHPT1 _ _ _ H3) in H8.
      apply (IHHPT2 _ _ _ H5) in H10.
      inversion H8; inversion H10; now subst.
    + apply (IHHPT1 _ _ _ H3) in H9; inversion H9.
    + apply (IHHPT2 _ _ _ H5) in H9; inversion H9.
    + apply (IHHPT1 _ _ _ H4) in H7; inversion H7.
    + apply (IHHPT2 _ _ _ H4) in H9; inversion H9.
  - inversion H1; inversion H2; subst; eauto.
    + pick_fresh x.
      assert (Ha : @inl _ (SExp var) e1 = inl e0).
      eapply H0 with (x := x).
      not_in_L x.
      apply H6; not_in_L x.
      apply H10; not_in_L x.
      inversion Ha; now subst.
    + pick_fresh x.
      assert (Ha : inl e1 = inr e).
      eapply H0 with (x := x).
      not_in_L x.
      apply H6; not_in_L x.
      apply H10; not_in_L x.
      inversion Ha.
    + pick_fresh x.
      assert (Ha : inl e1 = inr e).
      eapply H0 with (x := x).
      not_in_L x.
      apply H10; not_in_L x.
      apply H6; not_in_L x.
      inversion Ha.
  - inversion H; inversion H0; subst; auto;
    apply (IHHTL _ _ _ H4) in H8; now inversion H8.
  - inversion H; inversion H0; subst; eauto.
Qed.

Fixpoint and_coercion' (t : PTyp) (e : SExp var) {struct t} : sum (SExp var) (SExp var).
refine(
  match t with
    | PInt => inr e
    | Fun _ B => match (and_coercion' B e) with
                  | inl l => inl (STLam _ l)
                  | inr r => inr r
                 end
    | And A B => match (and_coercion' A e, and_coercion' B e) with
                  | (inl l1, inl l2) =>
                    inl (STPair _ l1 l2)
                  | _ => inr e
                end
    | PBVarT _  => inr e
    | PFVarT _ => inr e
    | ForAll d A => match and_coercion' A e with
                     | inl l => inl (STTLam _ l)
                     | inr e => inr e
                   end
    | Top    => inl (STUnit _)
    | Rec l t => and_coercion' t e
  end).
Defined.
(*
pick_fresh x.
destruct (and_coercion (open_typ_source A (PFVarT x)) e).
apply (inl (STTLam _ s)).
apply (inr s).
Admitted. *)

Inductive sub : PTyp -> PTyp -> (SExp var) -> Prop :=
  | SInt : sub PInt PInt (STLam _ (STBVar _ 0))
  | SFun : forall o1 o2 o3 o4 c1 c2,
             sub o3 o1 c1 ->
             sub o2 o4 c2 ->
             sub (Fun o1 o2) (Fun o3 o4) (STLam _ (STLam _ (STApp _ c2 (STApp _ (STBVar _ 1) (STApp _ c1 (STBVar _ 0))))))
  | SAnd1 : forall t t1 t2 c1 c2,
              sub t t1 c1 ->
              sub t t2 c2 ->
              sub t (And t1 t2) (STLam _ (STPair _ (STApp _ c1 (STBVar _ 0)) (STApp _ c2 (STBVar _ 0))))
  | SAnd2 : forall t t1 t2 c ac,
              sub t1 t c ->
              Atomic t ->
              PType t2 ->
              and_coercion ((STApp _ c (STProj1 _ (STBVar _ 0)))) t ac ->
              sub (And t1 t2) t (STLam _ (join_sum ac))
              (*
              sub (And t1 t2) t (STLam _ (join_sum (and_coercion' t ((STApp _ c (STProj1 _ (STBVar _ 0))))))) *)
  | SAnd3 : forall t t1 t2 c ac,
              sub t2 t c ->
              Atomic t ->
              PType t1 ->
              (* sub (And t1 t2) t (STLam _ (join_sum (and_coercion' t ((STApp _ c (STProj2 _ (STBVar _ 0))))))) *)
              and_coercion ((STApp _ c (STProj2 _ (STBVar _ 0)))) t ac ->
              sub (And t1 t2) t (STLam _ (join_sum ac))
  | SVar : forall v, sub (PFVarT v) (PFVarT v) (STLam _ (STBVar _ 0))
  | SForAll : forall L d1 d2 t1 t2 c c',
                (forall x, not (In x L) -> sub (open_typ_source t1 (PFVarT x))
                                         (open_typ_source t2 (PFVarT x))
                                         (open_typ_term c (STFVarT x))) ->
                sub d2 d1 c' ->
                sub (ForAll d1 t1) (ForAll d2 t2)
                    (STLam _ (STTLam _ (STApp _ c (STTApp _ (STBVar _ 0) (STBVarT 0)))))
  | STop : forall t, PType t -> sub t Top (STLam _ (STUnit _))
  | SRec : forall l t1 t2 c, sub t1 t2 c -> sub (Rec l t1) (Rec l t2) c.

Hint Constructors Atomic sub usub.

Definition Sub (t1 t2 : PTyp) : Prop := exists (e:SExp var), sub t1 t2 e.

Lemma sub_lc : forall t1 t2, Sub t1 t2 -> PType t1 /\ PType t2.
Proof.
  intros t1 t2 HSub.
  destruct HSub.
  induction H; eauto.
  - destruct IHsub1, IHsub2; auto.
  - destruct IHsub1, IHsub2; auto.
  - destruct IHsub; auto.
  - destruct IHsub; auto.
  - destruct IHsub; split.
    apply_fresh PType_ForAll as x; auto.
    assert (Ha : ~ In x L) by not_in_L x.
    apply H0 in Ha; now destruct Ha.
    apply_fresh PType_ForAll as x; auto.
    assert (Ha : ~ In x L) by not_in_L x.
    apply H0 in Ha; now destruct Ha.
  - destruct IHsub; auto.
Qed.

Hint Resolve sub_lc.

(* Smart constructors for Sub *)

Definition stop : forall t, PType t -> Sub t Top.
unfold Sub; eauto.
Defined.

Definition sint : Sub PInt PInt.
unfold Sub. exists (STLam _ (STBVar _ 0)).
exact SInt.
Defined.

Definition sfun : forall o1 o2 o3 o4, Sub o3 o1 -> Sub o2 o4 -> Sub (Fun o1 o2) (Fun  o3 o4).
unfold Sub; intros. destruct H. destruct H0.
exists (STLam _ (
       STLam _ (STApp _ x0 (STApp _ (STBVar _ 1) (STApp _ x (STBVar _ 0)))))).
apply SFun. auto. auto.
Defined.

Definition sand1 : forall t t1 t2, Sub t t1 -> Sub t t2 -> Sub t (And t1 t2).
unfold Sub. intros. destruct H. destruct H0.
exists (STLam _ (
       STPair _ (STApp _ x (STBVar _ 0)) (STApp _ x0 (STBVar _ 0)))).
apply SAnd1. auto. auto.
Defined.

Definition sand2_atomic :
  forall t t1 t2, Sub t1 t -> Atomic t -> PType t2 -> Sub (And t1 t2) t.
  unfold Sub; intros t t1 t2 H H1 H0.
  destruct H; destruct t; try (now inversion H1); eauto.
  - assert (Ha : Sub t1 (Fun t3 t4)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
  - assert (Ha : Sub t1 (ForAll t3 t4)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
  - assert (Ha : Sub t1 (Rec v t0)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
Defined.

Definition sand2 : forall t t1 t2, Sub t1 t -> PType t2 -> Sub (And t1 t2) t.
  intro t.
  induction t; intros.
  (* Case PInt *)
  - apply sand2_atomic; auto.
  (* Case Fun *)
  - apply sand2_atomic; auto.
  (* Case And *)
  - unfold Sub. unfold Sub in H. destruct H. inversion H.
    assert (Sub (And t0 t3) t1). apply IHt1.
    unfold Sub. exists c1; auto. auto.
    assert (Sub (And t0 t3) t2). apply IHt2.
    unfold Sub. exists c2. auto. auto.
    unfold Sub in H7. destruct H7.
    unfold Sub in H8. destruct H8.
    exists (STLam _ (STPair _ (STApp _ x0 (STBVar _ 0)) (STApp _ x1 (STBVar _ 0)))).
    apply SAnd1. auto. auto.
    inversion H2.
    inversion H2.
  (* Case BVar *)
  - inversion H. inversion H1; inversion H3.
  (* Case FVar *)
  - apply sand2_atomic; auto.
  (* Case ForAll *)
  - apply sand2_atomic; auto; apply AForAll.
  (* Case Top *)
  - apply stop; auto.
    apply PType_And; auto.
    apply sub_lc in H; now destruct H.
  (* Case Rec *)
  - apply sand2_atomic; auto.
Defined.

Definition sand3_atomic :
  forall t t1 t2, Sub t2 t -> Atomic t -> PType t1 -> Sub (And t1 t2) t.
  unfold Sub; intros t t1 t2 H H1 H0.
  destruct t; try (now inversion H1); destruct H; eauto.
  - assert (Ha : Sub t2 (Fun t3 t4)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
  - assert (Ha : Sub t2 (ForAll t3 t4)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
  - assert (Ha : Sub t2 (Rec v t0)) by (unfold Sub; eauto).
    apply sub_lc in Ha; destruct Ha.
    eapply ac_ptype in H3.
    destruct H3; eauto.
Defined.

Definition sand3 : forall t t1 t2, Sub t2 t -> PType t1 -> Sub (And t1 t2) t.
  intros t; induction t; intros.
  (* Case PInt *)
  - apply sand3_atomic; auto.
  (* Case Fun *)
  - apply sand3_atomic; auto.
  (* Case And *)
  - unfold Sub. unfold Sub in H. destruct H. inversion H.
    assert (Sub (And t0 t3) t1). apply IHt1.
    unfold Sub. exists c1. auto. auto.
    assert (Sub (And t0 t3) t2). apply IHt2.
    unfold Sub. exists c2. auto. auto.
    unfold Sub in H7. destruct H7.
    unfold Sub in H8. destruct H8.
    exists (STLam _ (STPair _ (STApp _ x0 (STBVar _ 0)) (STApp _ x1 (STBVar _ 0)))).
    apply SAnd1. auto. auto.
    inversion H2.
    inversion H2.
  (* Case BVar *)
  - inversion H; inversion H1; inversion H3.
  (* Case FVar *)
  - apply sand3_atomic; auto.
  (* Case ForAll *)
  - apply sand3_atomic; auto; apply AForAll.
  (* Case Top *)
  - apply stop; auto.
    apply PType_And; auto.
    apply sub_lc in H; now destruct H.
  (* Case Rec *)
  - apply sand3_atomic; auto.
Qed.

Definition svar : forall v, Sub (PFVarT v) (PFVarT v).
  intros.
  unfold Sub.
  exists (STLam _ (STBVar _ 0)).
  apply SVar.
Defined.

(*
Definition sforall : forall L t1 t2 c,
                (forall x, not (In x L) -> sub (open_ptyp t1 (PFVar x))
                                         (open_ptyp t2 (PFVar x))
                                         (open_typ_term c (STFVarT x))) ->
                Sub (ForAll t1) (ForAll t2).
  intros.
  unfold Sub.
  eexists.
  eapply SForAll.
  intros.

  pick_fresh.
 *)

Definition srec : forall l t1 t2, Sub t1 t2 -> Sub (Rec l t1) (Rec l t2).
  intros l t1 t2 HSub; unfold Sub in *; destruct HSub; eauto.
Qed.

Hint Constructors sub.
Hint Resolve stop sint sfun sand1 sand2 sand3 svar srec.

Lemma coercions_produce_terms :
  forall E A B, sub A B E -> STTerm E.
Proof.
  intros.
  induction H.
  (* Case SInt *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
  (* Case SFun *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply_fresh STTerm_Lam as y; cbn.
    apply STTerm_App.
    repeat rewrite <- open_rec_term; assumption.
    apply STTerm_App.
    apply STTerm_Var.
    apply STTerm_App; [ repeat rewrite <- open_rec_term; auto | apply STTerm_Var ].
  (* Case SAnd1 *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply STTerm_Pair.
    apply STTerm_App; repeat rewrite <- open_rec_term; auto.
    rewrite <- open_rec_term; auto.
  (* Case SAnd2 *)
  - apply and_coercion_proj1_term with (t0 := t0) (c := c); auto.
    assert (Ha : Sub t1 t0) by (unfold Sub; eauto).
    now apply sub_lc in Ha as [Ha1 Ha2].
  (* Case SAnd3 *)
  - apply and_coercion_proj2_term with (t0 := t0) (c := c); auto.
    assert (Ha : Sub t2 t0) by (unfold Sub; eauto).
    now apply sub_lc in Ha as [Ha1 Ha2].
  (* Case SVar *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
  (* Case SForAll *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply_fresh STTerm_TLam as y; cbn.
    apply STTerm_App; auto.
    assert (Ha : not (In y L)) by (not_in_L y).
    apply H0 in Ha.
    rewrite open_comm_open_typ_term.
    rewrite <- open_rec_term; auto.
  (* Case STop *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
  (* Case SRec *)
  - auto.
Qed.

Lemma sub_inv :
  forall t1 t2 e x n,
    sub (open_rec_typ_source n (PFVarT x) t1) (open_rec_typ_source n (PFVarT x) t2) e ->
    exists e', e = open_rec_typ_term n (STFVarT x) e'.
Proof.
  intros t1 t2 e x n H.
  unfold open.
  inversion H; intros.
  - exists (STLam var (STBVar var 0)); now simpl.
  - exists (STLam var
       (STLam var
          (STApp var c2
                 (STApp var (STBVar var 1) (STApp var c1 (STBVar var 0)))))).
    unfold open_typ_term; simpl.
    apply coercions_produce_terms in H2; apply coercions_produce_terms in H3.
    repeat rewrite <- open_rec_typ_term_term; auto.
  - exists (STLam var
       (STPair var (STApp var c1 (STBVar var 0))
               (STApp var c2 (STBVar var 0)))).
    simpl.
    unfold open_typ_term; simpl.
    apply coercions_produce_terms in H1; apply coercions_produce_terms in H3.
    repeat rewrite <- open_rec_typ_term_term; auto.
  - exists (STLam var (join_sum ac)).
    unfold open_typ_term; simpl.
    destruct ac; simpl.
    apply ac_inl_term in H4.
    rewrite <- open_rec_typ_term_term; auto.
    apply ac_inr_inv_eq in H4.
    subst; simpl.
    apply coercions_produce_terms in H1.
    rewrite <- open_rec_typ_term_term; auto.
  - exists (STLam var (join_sum ac)).
    unfold open_typ_term; simpl.
    destruct ac; simpl.
    apply ac_inl_term in H4.
    rewrite <- open_rec_typ_term_term; auto.
    apply ac_inr_inv_eq in H4.
    subst; simpl.
    apply coercions_produce_terms in H1.
    rewrite <- open_rec_typ_term_term; auto.
  - exists (STLam var (STBVar var 0)); now simpl.
  - exists (STLam var
             (STTLam var (STApp var c (STTApp var (STBVar var 0) (STBVarT 0))))).
    rewrite <- open_rec_typ_term_term.
    auto.
    rewrite <- H4 in H.
    apply coercions_produce_terms in H.
    apply H.
 - exists (STLam var (STUnit var)); now simpl.
 - exists e.
   subst.
   apply coercions_produce_terms in H2.
   rewrite <- open_rec_typ_term_term; auto.
Qed.

(** Interlude: substitution of types in term **)

Fixpoint subst_typ_term (z : var) (u : STyp) (t : SExp var) {struct t} : SExp var :=
  match t with
  | STBVar _ i     => STBVar _ i
  | STFVar _ x     => STFVar _ x
  | STUnit _       => STUnit _
  | STLit _ n      => STLit _ n
  | STLam _ t      => STLam _ (subst_typ_term z u t)
  | STApp _ t1 t2  => STApp _ (subst_typ_term z u t1) (subst_typ_term z u t2)
  | STPair _ t1 t2 => STPair _ (subst_typ_term z u t1) (subst_typ_term z u t2)
  | STProj1 _ t    => STProj1 _ (subst_typ_term z u t)
  | STProj2 _ t    => STProj2 _ (subst_typ_term z u t)
  | STTLam _ t     => STTLam _ (subst_typ_term z u t)
  | STTApp _ t ty  => STTApp _ (subst_typ_term z u t) (subst_typ z u ty)
  end.

Lemma subst_typ_term_fresh :
  forall x t u, not (In x (fv t)) ->  subst_typ_term x u t = t.
Proof.
  intros; induction t0; simpl in *; auto.
  - rewrite IHt0; auto.
  - rewrite IHt0_1; [ rewrite IHt0_2 | not_in_L x ]; [ reflexivity | not_in_L x ].
  - rewrite IHt0_1; [ rewrite IHt0_2 | not_in_L x ]; [ reflexivity | not_in_L x ].
  - rewrite IHt0; [ reflexivity | not_in_L x ].
  - rewrite IHt0; [ reflexivity | not_in_L x ].
  - rewrite IHt0; [ reflexivity | not_in_L x ].
  - rewrite IHt0; [ | not_in_L x ].
    rewrite subst_typ_fresh; auto; not_in_L x.
Qed.

Lemma subst_typ_open' : forall x u t1 t2, STType u -> forall n,
  subst_typ x u (open_rec_typ n t1 t2) = open_rec_typ n (subst_typ x u t1) (subst_typ x u t2).
Proof.
  intros x u t1 t2.
  induction t2; intros; simpl; auto; try (apply f_equal; auto).
  - rewrite IHt2_1; auto; rewrite IHt2_2; auto.
  - rewrite IHt2_1; auto; rewrite IHt2_2; auto.
  - case_eq (eqb v x); intros; [ rewrite <- open_rec_type | ]; auto.
  - case_eq (Nat.eqb n0 n); intros; auto.
Qed.

Lemma subst_typ_term_open : forall x u t1 t2, STType u ->
  subst_typ_term x u (open_typ_term t1 t2) = open_typ_term (subst_typ_term x u t1) (subst_typ x u t2).
Proof.
  intros. unfold open_typ_term. generalize 0.
  induction t1; intros; simpl; auto; try (apply f_equal; auto).
  - rewrite IHt1_1; rewrite IHt1_2; auto.
  - rewrite IHt1_1; rewrite IHt1_2; auto.
  - rewrite IHt1.
    rewrite <- subst_typ_open'; auto.
Qed.

Lemma subst_typ_open_var :
  forall x y u t,
    y <> x -> STType u ->
    open_typ_term (subst_typ_term x u t) (STFVarT y) =
    subst_typ_term x u (open_typ_term t (STFVarT y)).
Proof.
  intros Neq Wu. intros. rewrite subst_typ_term_open; auto. simpl.
  case_eq (VarTyp.eqb Wu Neq); intros; auto.
  exfalso; apply H.
  now apply eqb_eq in H1.
Qed.

Lemma subst_typ_term_intro : forall x t u,
  not (In x (fv t)) -> STType u ->
  open_typ_term t u = subst_typ_term x u (open_typ_term t (STFVarT x)).
Proof.
  intros Fr Wu.
  intros.
  rewrite subst_typ_term_open.
  rewrite subst_typ_term_fresh.
  simpl.
  case_eq (eqb Fr Fr); intros; auto.
  apply EqFacts.eqb_neq in H1; exfalso; apply H1; reflexivity.
  auto. auto.
Qed.

Lemma sub_ex : forall L t1 t2,
  (forall x, ~ In x L -> PType (open_typ_source t1 (PFVarT x))) ->
  (forall x, ~ In x L -> PType (open_typ_source t2 (PFVarT x))) ->
  (forall x, ~ In x L -> exists c, sub (open_typ_source t1 (PFVarT x))
                            (open_typ_source t2 (PFVarT x))
                            (open_typ_term c (STFVarT x))) ->
  exists c, forall x, ~ In x L -> sub (open_typ_source t1 (PFVarT x))
                           (open_typ_source t2 (PFVarT x))
                           (open_typ_term c (STFVarT x)).
Proof.
  intros L t1 t2 H1 H2 H.
  pick_fresh x.
  assert (Ha : ~ In x L) by not_in_L x.
  apply H in Ha.
  destruct Ha as [c HAC].
  exists c.
  intros.
  (* this should follow naturally from hypothesis HAC *)
  (* we could try using a renaming lemma, but then "x" would have to be fresh in "c" *)
  admit.
Admitted.

Lemma sound_sub : forall t1 t2, usub t1 t2 -> Sub t1 t2.
  intros; induction H; auto.
  - destruct IHusub as [c Hsub].
    unfold Sub in *.
    assert (Ha : forall x : elt,
       ~ In x L ->
       exists e : SExp var,
         sub (open_typ_source t1 (PFVarT x)) (open_typ_source t2 (PFVarT x))
             (open_typ_term e (STFVarT x))).
    intros.
    apply H0 in H2.
    destruct H2.
    assert (H3 : sub (open_typ_source t1 (PFVarT x)) (open_typ_source t2 (PFVarT x)) x0) by assumption.
    apply sub_inv in H2.
    destruct H2; subst.
    eauto.
    clear H0.
    apply sub_ex in Ha.
    destruct Ha.
    eexists.
    apply_fresh SForAll as x; auto.
    apply H0.
    not_in_L y.
    eauto.
    intros.
    apply Ha in H0; destruct H0.
    assert (HSub : Sub (open_typ_source t1 (PFVarT x)) (open_typ_source t2 (PFVarT x))).
    unfold Sub; eauto.
    apply sub_lc in HSub; now destruct HSub.
    intros.
    apply Ha in H0; destruct H0.
    assert (HSub : Sub (open_typ_source t1 (PFVarT x)) (open_typ_source t2 (PFVarT x))).
    unfold Sub; eauto.
    apply sub_lc in HSub; now destruct HSub.
Qed.

Lemma complete_sub : forall t1 t2, Sub t1 t2 -> usub t1 t2.
Proof.
  intros; destruct H; induction H; auto.
  - apply_fresh USForAll as x.
    apply H0.
    not_in_L x.
    auto.
Qed.

(* Properties about sub *)

Lemma usub_refl : forall t, PType t -> usub t t.
Proof.
  intros t HWFt; induction HWFt; auto.
  - apply_fresh USForAll as x.
    apply H0.
    not_in_L x.
    auto.
Qed.

Lemma usub_and_l : forall t1 t2 t3, usub t1 (And t2 t3) -> usub t1 t2.
Proof.
  intros t1 t2 t3 Husub.
  apply complete_sub.
  apply sound_sub in Husub as [c Hsub].
  inversion Hsub; subst.
  exists c1; auto. inversion H0. inversion H0.
Qed.

Lemma usub_and_r : forall t1 t2 t3, usub t1 (And t2 t3) -> usub t1 t3.
Proof.
  intros t1 t2 t3 Husub.
  apply complete_sub.
  apply sound_sub in Husub as [c Hsub].
  inversion Hsub; subst.
  exists c2; auto. inversion H0. inversion H0.
Qed.

Lemma usub_lc : forall t1 t2, usub t1 t2 -> PType t1 /\ PType t2.
Proof.
  intros.
  apply sound_sub in H.
  now apply sub_lc in H.
Qed.

Lemma usub_trans_mid :
  forall A B C D, usub A B -> usub B C -> usub C D -> usub A D.
Proof.
  intros A B C D HusubAB HusubBC HusubCD.
  generalize dependent A.
  generalize dependent D.
  induction HusubBC; intros; auto.
  - dependent induction HusubAB; subst; auto.
  - dependent induction HusubAB; subst; auto.
    dependent induction HusubCD; subst; auto.
    apply USAnd1.
    apply IHHusubCD1; auto.
    intros; auto.
    subst.
    apply usub_and_l with (t3 := t2); eauto.
    intros; auto.
    subst.
    apply usub_and_l with (t3 := t2); eauto.
    apply IHHusubCD2; auto.
    intros; auto.
    subst.
    apply usub_and_r with (t2 := t1); eauto.
    intros; auto.
    subst.
    apply usub_and_r with (t2 := t1); eauto.
    apply usub_lc in HusubAB1; apply usub_lc in HusubAB2.
    apply USTop; destruct HusubAB1; destruct HusubAB2; auto.
  - dependent induction HusubCD; subst; auto.
    apply usub_lc in HusubAB; apply USTop; destruct HusubAB; auto.
  - dependent induction HusubAB; subst; auto.
  - dependent induction HusubAB; subst; auto.
  - dependent induction HusubCD; subst; auto.
    apply usub_lc in HusubAB; apply USTop; destruct HusubAB; auto.
  - dependent induction HusubCD; subst; auto.
    dependent induction HusubAB; subst; auto.
    apply_fresh USForAll as x.
    apply H0 with (x := x).
    not_in_L x.
    apply H1.
    not_in_L x.
    apply H3.
    not_in_L x.
    auto.
    apply usub_lc in HusubAB; apply USTop; destruct HusubAB; auto.
  - dependent induction HusubCD; subst; auto.
    apply usub_lc in HusubAB; apply USTop; destruct HusubAB; auto.
  - dependent induction HusubCD; subst; auto.
    apply usub_lc in HusubAB; destruct HusubAB; auto.
    dependent induction HusubAB; subst; auto.
Qed.

Lemma usub_trans :
  forall B A C, PType C -> usub A B -> usub B C -> usub A C.
Proof.
  intros B A C HWFC HusubAB HusubBC.
  assert (HusubCC : usub C C).
  eapply usub_refl; apply HWFC.
  eapply usub_trans_mid.
  apply HusubAB.
  apply HusubBC.
  apply HusubCC.
Qed.

Lemma usub_subst :
  forall A B z u,
    usub A B ->
    PType u ->
    usub (subst_typ_source z u A) (subst_typ_source z u B).
Proof.
  intros A B z u HSub HWFu.
  induction HSub; intros; simpl; eauto.
  - apply USAnd2; auto; now apply subst_source_lc.
  - apply USAnd3; auto; now apply subst_source_lc.
  - destruct eqb; auto.
    eapply usub_refl; apply HWFu.
  - apply_fresh USForAll as x.
    repeat rewrite subst_typ_source_open_source_var; auto.
    apply H0; auto.
    not_in_L x.
    not_in_L x.
    not_in_L x.
    auto.
  - apply USTop.
    apply subst_source_lc; auto.
Qed.

Lemma usub_subst_not_in :
  forall A B u z,
    not (In z (fv_ptyp B)) ->
    usub A B ->
    PType u ->
    usub (subst_typ_source z u A) B.
Proof.
  intros A ty u z HNotIn HSub HWFu.
  erewrite <- subst_typ_source_fresh with (t := ty).
  eapply usub_subst; eauto.
  auto.
Qed.

End MSubtyping.


From iris.proofmode Require Import tactics.
From cap_machine Require Import region_macros.
From cap_machine Require Import addr_reg_sample.

(* This file contains definition and lemmas for contiguous address regions *)
(* It is used mainly in specs of programs where it is necessary to assume  *)
(* that some program lies in memory in a contiguous region                 *)

Section Contiguous.

  Definition contiguous (l: list Addr): Prop :=
    ∃ a b, l = region_addrs a b.

  Inductive contiguous_between : list Addr -> Addr -> Addr -> Prop :=
    | contiguous_between_nil : ∀ a,
        contiguous_between [] a a
    | contiguous_between_cons : ∀ a a' b l,
        (a + 1)%a = Some a' ->
        contiguous_between l a' b ->
        contiguous_between (a :: l) a b.

  Lemma contiguous_between_vacuous l a b :
    contiguous_between l a b →
    (b < a)%a →
    False.
  Proof. induction 1; intros; solve_addr. Qed.

  Lemma contiguous_between_bounds l a b :
    contiguous_between l a b →
    (a <= b)%a.
  Proof.
    intros HH. generalize (contiguous_between_vacuous _ _ _ HH).
    solve_addr.
  Qed.

  Lemma contiguous_between_nil_inv l a b :
    contiguous_between l a b →
    (b <= a)%a →
    l = [].
  Proof.
    induction 1; eauto.
    destruct (Z_eq_dec a b).
    { intros. exfalso.
      eapply (contiguous_between_vacuous l a' b). 2: solve_addr. eauto. }
    { intros. exfalso. eapply contiguous_between_vacuous; eauto. solve_addr. }
  Qed.

  Lemma contiguous_between_cons_inv a b e ai :
    contiguous_between (a :: ai) b e →
    a = b ∧ ∃ a', (a+1)%a = Some a' ∧ contiguous_between ai a' e.
  Proof. inversion 1; eauto. Qed.

  Lemma contiguous_between_cons_inv_first l a a' b :
    contiguous_between (a' :: l) a b →
    a' = a.
  Proof. inversion 1; eauto. Qed.

  Lemma contiguous_between_last (a : list Addr) a0 an ai :
    contiguous_between a a0 an →
    list.last a = Some ai →
    (ai + 1)%a = Some an.
  Proof.
    revert ai. induction 1 as [| * X Y].
    { inversion 1. }
    { destruct l.
      - cbn. inversion 1. inversion Y; subst. auto.
      - eauto. }
  Qed.

  Lemma contiguous_between_middle_to_end (a: list Addr) (a0 an: Addr) i ai k :
    contiguous_between a a0 an →
    a !! i = Some ai →
    i + k = length a →
    (ai + k)%a = Some an.
  Proof.
    intros * Ha. revert i k ai. induction Ha; [done |].
    intros [| i] k ai; cbn.
    { intros. simplify_eq. enough ((a' + length l)%a = Some b) by solve_addr.
      inversion Ha; subst; cbn. solve_addr.
      apply (IHHa 0); eauto. }
    { eauto. }
  Qed.

  Lemma contiguous_between_of_region_addrs_aux l a b n :
    l = region_addrs_aux a n →
    (a + n)%a = Some b →
    contiguous_between l a b.
  Proof.
    revert a b l. induction n.
    { intros. cbn in *. subst l. assert (a = b) as -> by solve_addr.
      constructor. }
    { intros * -> ?. cbn. eapply (contiguous_between_cons _ (^(a+1)%a)). solve_addr.
      apply IHn; auto. solve_addr. }
  Qed.

  Lemma region_addrs_aux_of_contiguous_between l a b (n:nat) :
    contiguous_between l a b →
    (a + n)%a = Some b →
    l = region_addrs_aux a n.
  Proof.
    revert a b l. induction n.
    { intros. cbn in *.
      apply (contiguous_between_nil_inv l a b); eauto; solve_addr. }
    { intros * Hl Hn. cbn.
      destruct l as [| a' l].
      { inversion Hl; subst. exfalso. solve_addr. }
      { inversion Hl; subst. f_equal. eapply (IHn _ b). 2: solve_addr.
        assert (^(a+1)%a = a'0) as -> by solve_addr. auto. } }
  Qed.

  Lemma contiguous_between_of_region_addrs l a b :
    (a <= b)%a →
    l = region_addrs a b →
    contiguous_between l a b.
  Proof.
    intros ? ->. eapply contiguous_between_of_region_addrs_aux; eauto.
    rewrite /region_size. solve_addr.
  Qed.

  Lemma contiguous_between_region_addrs a e :
    (a <= e) %a → contiguous_between (region_addrs a e) a e.
  Proof. intros; by apply contiguous_between_of_region_addrs. Qed.

  Lemma region_addrs_of_contiguous_between l a b :
    contiguous_between l a b →
    l = region_addrs a b.
  Proof.
    intros.
    destruct (Z_le_dec a b).
    { eapply region_addrs_aux_of_contiguous_between; eauto.
      rewrite /region_size. solve_addr. }
    { rewrite /region_addrs (_: region_size a b = 0) /=.
      2: unfold region_size; solve_addr.
      eapply contiguous_between_nil_inv; eauto. solve_addr. }
  Qed.

  Lemma contiguous_iff_contiguous_between l :
    contiguous l ↔
    ∃ a b, contiguous_between l a b.
  Proof.
    split.
    { intros (a & b & H).
      destruct (Z_le_dec a b).
      { apply contiguous_between_of_region_addrs in H; eauto. }
      { rewrite /region_addrs (_: region_size a b = 0) in H.
        2: unfold region_size; solve_addr. cbn in *. subst l.
        exists a, a. constructor. } }
    { intros (a & b & H).
      apply region_addrs_of_contiguous_between in H. unfold contiguous.
      eauto. }
  Qed.

  Lemma contiguous_of_contiguous_between l a b :
    contiguous_between l a b →
    contiguous l.
  Proof.
    intros. rewrite contiguous_iff_contiguous_between. eauto.
  Qed.

  Lemma contiguous_spec (l: list Addr) :
      contiguous l →
      (∀ i ai aj,
       l !! i = Some ai →
       l !! (i + 1) = Some aj →
       (ai + 1)%a = Some aj).
  Proof.
    intros Hl%contiguous_iff_contiguous_between.
    destruct Hl as (a & b & H).
    induction H as [| * Ha' Hl Hind].
    { intros *. inversion 1. }
    { intros * Hi Hi'. destruct i as [| i].
      { cbn in *. inversion Hi; subst ai; clear Hi.
        destruct Hl; inversion Hi'; [ subst aj; clear Hi' ]. auto. }
      { cbn in *. eauto. } }
  Qed.

  Lemma contiguous_nil : contiguous [].
  Proof.
    rewrite contiguous_iff_contiguous_between. exists top, top. constructor.
  Qed.

  Lemma contiguous_weak hd a :
    contiguous (hd :: a) → contiguous a.
  Proof.
    rewrite !contiguous_iff_contiguous_between.
    intros (?&?&H). inversion H; eauto.
  Qed.

  Lemma contiguous_drop (a : list Addr) :
    ∀ i, contiguous a -> contiguous (drop i a).
  Proof.
    induction a; intros i Ha.
    - rewrite drop_nil. apply contiguous_nil.
    - destruct i; auto. simpl.
      apply IHa. by apply contiguous_weak with a.
  Qed.

  Lemma contiguous_between_length a i j :
    contiguous_between a i j →
    (i + length a = Some j)%a.
  Proof. induction 1; cbn; solve_addr. Qed.

  Lemma contiguous_between_length_minus a i j :
    contiguous_between a i j →
    (j + - (length a) = Some i)%a.
  Proof. induction 1; cbn; solve_addr. Qed.

  (* The first element of the contiguous list is less than or equal to the last *)
   Lemma incr_list_le (a : list Addr) (a0 an : Addr) :
    contiguous a →
    a !! 0 = Some a0 → list.last a = Some an → (a0 ≤ an)%Z.
  Proof.
    generalize a0 an. induction a as [| a al IHa ]; intros a0' an' Hcond Hfirst Hlast;
     first inversion Hfirst.
    simpl in Hfirst. inversion Hfirst. subst.
    destruct al as [| hd tl ].
    - inversion Hlast. omega.
    - assert ((a0' :: hd :: tl) !! 0 = Some a0') as Ha0; auto.
      assert ((a0' :: hd :: tl) !! 1 = Some hd) as Ha; auto.
      apply (contiguous_spec _ Hcond) with 0 a0' hd in Ha0 as Hnext; auto.
      assert ((hd :: tl) !! 0 = Some hd) as Ha'; auto.
      assert (list.last (hd :: tl) = Some an').
      { simpl. destruct tl; auto. }
      apply IHa with hd an' in Ha'; auto.
      + assert (a0' ≤ hd)%Z.
        {  solve_addr. }
        apply Z.le_trans with hd; auto.
      + eauto using contiguous_weak.
  Qed.

  (* The last element of a list is the same as a list where we drop fewer elements than the list *)
  Lemma last_drop_lt {A : Type} (l : list A) (i : nat) (a : A) :
    i < (length l) → list.last l = Some a → list.last (drop i l) = Some a.
  Proof.
    generalize i. induction l.
    - intros i' Hlen Hlast. inversion Hlast.
    - intros i' Hlen Hlast. destruct i'.
      + simpl. apply Hlast.
      + simpl; simpl in Hlen. apply IHl; first omega.
        assert (0 < length l) as Hl; first lia.
        destruct l; simpl in Hl; first by apply Nat.lt_irrefl in Hl. auto.
  Qed.

  Lemma last_lookup {A : Type} (l : list A) :
    list.last l = l !! (length l - 1).
  Proof.
    induction l.
    - done.
    - simpl. destruct l; auto.
      rewrite IHl. simpl. rewrite PeanoNat.Nat.sub_0_r. done.
  Qed.

  Lemma last_app_iff {A : Type} (l1 l2 : list A) a :
    list.last l2 = Some a <-> length l2 > 0 ∧ list.last (l1 ++ l2) = Some a.
  Proof.
    split.
    - intros Hl2.
      induction l1.
      + destruct l2; inversion Hl2. simpl. split; auto. lia.
      + destruct IHl1 as [Hlt Hlast]. split; auto. simpl. rewrite Hlast.
        destruct (l1 ++ l2); auto.
        inversion Hlast.
    - generalize l1. induction l2; intros l1' [Hlen Hl].
      + inversion Hlen.
      + destruct l2;[rewrite last_snoc in Hl; inversion Hl; done|].
        rewrite -(IHl2 (l1' ++ [a0])); auto.
        simpl. split;[lia|]. rewrite -app_assoc -cons_middle. done.
  Qed.

  Lemma last_app_eq {A : Type} (l1 l2 : list A) :
    length l2 > 0 ->
    list.last l2 = list.last (l1 ++ l2).
  Proof.
    revert l1. induction l2;intros l1 Hlen.
    - inversion Hlen.
    - destruct l2.
      + rewrite last_snoc. done.
      + rewrite cons_middle app_assoc -(IHl2 (l1 ++ [a]));[auto|simpl;lia].
  Qed.

  Lemma contiguous_between_middle_bounds (a : list Addr) i (ai a0 an : Addr) :
    contiguous_between a a0 an →
    a !! i = Some ai →
    (a0 <= ai ∧ ai < an)%a.
  Proof.
    intro HH. revert ai i. induction HH as [| * Ha Hc Hi]; [ by inversion 1 |].
    intros * Hi'. destruct i as [| i].
    { cbn in Hi'. inversion Hi'; subst; clear Hi'. split; [ solve_addr |].
      destruct (decide (a' = b)).
      { subst a'. inversion Hc; subst; solve_addr. }
      { apply contiguous_between_length in Hc. solve_addr. } }
    { cbn in Hi'. split. enough (a' <= ai)%a by solve_addr.
      all: eapply Hi; eauto. }
  Qed.

  Lemma contiguous_between_middle_bounds' (a : list Addr) (ai a0 an : Addr) :
    contiguous_between a a0 an →
    ai ∈ a →
    (a0 <= ai ∧ ai < an)%a.
  Proof.
    intros Hc Hin.
    apply elem_of_list_lookup_1 in Hin as [? ?].
    eapply contiguous_between_middle_bounds; eauto.
  Qed.

  (* The i'th element of the contiguous list is less than or equal to the last *)
  Lemma incr_list_le_middle (a : list Addr) i (ai an : Addr) :
    contiguous a →
    a !! i = Some ai → list.last a = Some an → (ai ≤ an)%Z.
  Proof.
    generalize ai. destruct i;
                     intros ai' Hcond Hi' Hlast.
    - apply incr_list_le with a; auto.
    - rewrite -Nat.add_1_r in Hi'.
      assert ((drop (i + 1) a) !! 0 = Some ai') as Ha.
      { rewrite -(Nat.add_0_r (i + 1)) in Hi'.
        rewrite -Hi'. apply (lookup_drop a (i + 1) 0). }
      apply incr_list_le with _ _ an in Ha; auto.
      + apply contiguous_drop; auto.
      + assert (is_Some (a !! (i + 1))) as Hsome; eauto.
        apply lookup_lt_is_Some_1 in Hsome as Hlength.
        apply last_drop_lt; auto.
  Qed.

  (* If the i'th element is not the last, it is less than the last *)
  Lemma incr_list_lt_middle (a : list Addr) i (ai an : Addr) :
    contiguous a →
    a !! i = Some ai → list.last a = Some an → (ai ≠ an)%Z → (ai < an)%Z.
  Proof.
    intros Hreg Ha Hj Hne.
    assert (ai ≤ an)%Z as Hinc; first (apply incr_list_le_middle with a i; auto).
    apply Z.lt_eq_cases in Hinc as [Hlt | Heq]; auto.
    apply neq_z_of in Hne. congruence.
  Qed.

  (* The i'th element is less than the i+1'th element *)
  Lemma incr_list_lt_succ (a : list Addr) (a0 a1 : Addr) (i : nat) :
    contiguous a →
    a !! i = Some a0 → a !! (S i) = Some a1 → (a0 < a1)%Z.
  Proof.
    intros Hcond Hi Hsi.
    pose proof (contiguous_spec _ Hcond i a0 a1) as Hcond'; simpl in Hcond'.
    apply Hcond' in Hi; try rewrite Nat.add_1_r; auto.
    solve_addr.
  Qed.

  Lemma contiguous_between_incr_addr (a: list Addr) (i : nat) a0 ai an :
    contiguous_between a a0 an →
    a !! i = Some ai →
    (a0 + i)%a = Some ai.
  Proof.
    intros Hc. revert i ai. induction Hc.
    - inversion 1.
    - intros i ai. destruct i as [| i].
      { cbn. inversion 1; subst. solve_addr. }
      { cbn. intros Hi. specialize (IHHc _ _ Hi). solve_addr. }
  Qed.

  (* the i'th element is the same as adding i to the first element *)
  Lemma contiguous_incr_addr (a : list Addr) (i : nat) a0 ai :
    contiguous a ->
    a !! 0 = Some a0 → a !! i = Some ai -> (a0 + i)%a = Some ai.
  Proof.
    revert ai. induction i; intros ai Ha Ha0 Hai.
    - rewrite Ha0 in Hai. inversion Hai.
      apply addr_add_0.
    - assert (∃ aj, a !! i = Some aj) as [aj Haj].
      { apply lookup_lt_is_Some.
        apply Nat.lt_succ_l.
        apply lookup_lt_is_Some. eauto. }
      specialize (IHi aj Ha Ha0 Haj).
      rewrite -Nat.add_1_r in Hai. rewrite -Nat.add_1_r.
      pose proof (contiguous_spec _ Ha i _ _ Haj Hai).
      rewrite -(incr_addr_trans a0 aj ai i 1); auto.
      rewrite Nat.add_1_r Z.add_1_r Nat2Z.inj_succ.
      done.
  Qed.

  (* the i'th element is the same as adding i to the first element *)
  Lemma contiguous_between_link_last (a : list Addr) a_first a_last ai :
    contiguous_between a a_first a_last ->
    length a > 0 ->
    (ai + 1)%a = Some a_last -> list.last a = Some ai.
  Proof.
    revert a_first. induction a; intros a_first Ha Hlen Hlink.
    - inversion Hlen.
    - destruct a0.
      + inversion Ha. subst. inversion H4. subst.
        solve_addr.
      + simpl in *. apply IHa with a0;[|lia|auto].
        inversion Ha; subst.
        apply contiguous_between_cons_inv_first in H4 as Heq.
        congruence.
  Qed.

  (* the i'th element is greater or equal to the first *)
  Lemma incr_list_ge_middle (a : list Addr) i (a0 ai : Addr) :
    contiguous a ->
    a !! 0 = Some a0 -> a !! i = Some ai -> (a0 <= ai)%Z.
  Proof.
    intros Ha H0 Hi. generalize (contiguous_incr_addr _ _ _ _ Ha H0 Hi).
    solve_addr.
  Qed.

  (* the i + j element is the same as adding j to the ith element *)
  Lemma contiguous_incr_addr_middle (a : list Addr) (i j : nat) ai aj :
    contiguous a ->
    a !! i = Some ai -> a !! (i + j) = Some aj -> (ai + j)%a = Some aj.
  Proof.
    intros Ha Hai Haij.
    rewrite -(PeanoNat.Nat.add_0_r i) in Hai.
    rewrite -lookup_drop in Hai.
    rewrite -lookup_drop in Haij.
    apply contiguous_drop with _ i in Ha.
    apply contiguous_incr_addr with (drop i a); auto.
  Qed.

  Lemma contiguous_between_incr_addr_middle (a : list Addr) a0 an (i j : nat) ai aj :
    contiguous_between a a0 an ->
    a !! i = Some ai -> a !! (i + j) = Some aj -> (ai + j)%a = Some aj.
  Proof.
    intros HH%contiguous_of_contiguous_between.
    apply contiguous_incr_addr_middle; auto.
  Qed.

  (* an alternative version of proving that an element in the middle of the list is < than the last *)
  Lemma incr_list_lt_middle_alt (a : list Addr) i (ai an : Addr) :
    contiguous a ->
    a !! i = Some ai -> list.last a = Some an -> i < length a - 1 -> (ai < an)%Z.
  Proof.
    intros Hreg Ha Hj Hlt.
    assert (ai ≤ an)%Z as Hinc; first (apply incr_list_le_middle with a i; auto).
    rewrite last_lookup in Hj.
    apply Zle_lt_or_eq in Hinc as [Hlt' | Heq];[auto|].
    apply z_of_eq in Heq. subst.
    assert ((an + (length a - 1 - i))%a = Some an) as Hcontr.
    { apply (contiguous_incr_addr_middle a i (length a - 1 - i)%nat an an) in Ha;auto.
      - solve_addr.
      - rewrite -Hj. f_equiv. lia.
    }
    apply next_lt_i in Hcontr; [done|lia].
  Qed.

  Lemma contiguous_incr_addr_middle' (a : list Addr) (i : nat) (j: Z) ai aj :
    contiguous a →
    (0 <= i + j < length a)%Z →
    a !! i = Some ai -> a !! (Z.to_nat (i + j)%Z) = Some aj -> (ai + j)%a = Some aj.
  Proof.
    intros Ha Hij Hai Haj.
    destruct (decide (0 <= j)%Z).
    { assert (j = Z.to_nat j) as -> by lia.
      eapply contiguous_incr_addr_middle; eauto.
      assert (i + Z.to_nat j = Z.to_nat (i + j)) as -> by lia. auto. }
    { assert (i = Z.to_nat (i + j) + Z.to_nat (-j)) as Hi by lia.
      generalize (contiguous_incr_addr_middle a (Z.to_nat (i + j)) (Z.to_nat (-j)) aj ai Ha Haj).
      rewrite -Hi => /(_ Hai). solve_addr. }
  Qed.

  Lemma contiguous_between_incr_addr_middle' (a : list Addr) a0 an (i : nat) (j: Z) ai aj :
    contiguous_between a a0 an →
    (0 <= i + j < length a)%Z →
    a !! i = Some ai -> a !! (Z.to_nat (i + j)%Z) = Some aj -> (ai + j)%a = Some aj.
  Proof.
    intros HH%contiguous_of_contiguous_between.
    apply contiguous_incr_addr_middle'; auto.
  Qed.

  (* A region_addrs_aux is contiguous *)
  Lemma region_addrs_aux_contiguous (a : Addr) (n : nat) :
    is_Some (a + n)%a →
    contiguous (region_addrs_aux a n).
  Proof.
    intros [? ?]. rewrite /contiguous /region_addrs.
    exists a, (^(a + n)%a). f_equal. unfold region_size. solve_addr.
  Qed.

  Lemma region_addrs_contiguous (a b : Addr) :
    contiguous (region_addrs a b).
  Proof.
    rewrite /region_addrs. apply region_addrs_aux_contiguous.
    rewrite /region_size. zify_addr; try lia; eauto.
  Qed.

  Lemma contiguous_between_app a a1 a2 (i j k: Addr) :
    a = a1 ++ a2 →
    contiguous_between a i j →
    (i + length a1 = Some k)%a →
    contiguous_between a1 i k ∧ contiguous_between a2 k j.
  Proof.
    revert a a2 i j k. induction a1 as [| aa a1].
    { intros * ->.  simpl. intros. assert (i = k) by solve_addr. subst i. split; auto.
      apply contiguous_between_nil. }
    { intros * ->. cbn. inversion 1. subst. intros.
      unshelve epose proof (IHa1 (a1 ++ a2) a2 _ _ _ eq_refl _ _) as [IH1 IH2];
        [ shelve | shelve | shelve | ..]; eauto; cycle 1.
      split; [| eapply IH2]. 2: by solve_addr.
      eapply contiguous_between_cons; eauto. }
  Qed.

  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          {stsg : STSG Addr region_type Σ} {heapg : heapG Σ}
          `{MonRef: MonRefG (leibnizO _) CapR_rtc Σ}.

  (* Note that we are assuming that both prog1 and prog2 are nonempty *)
  Lemma contiguous_between_program_split prog1 prog2 (φ : Addr → Word → iProp Σ) a i j :
    contiguous_between a i j →
    (([∗ list] a_i;w_i ∈ a;prog1 ++ prog2, φ a_i w_i) -∗
    ∃ (a1 a2 : list Addr) (k: Addr),
      ([∗ list] a_i;w_i ∈ a1;prog1, φ a_i w_i)
        ∗ ([∗ list] a_i;w_i ∈ a2;prog2, φ a_i w_i)
        ∗ ⌜contiguous_between a1 i k
           ∧ contiguous_between a2 k j
           ∧ a = a1 ++ a2
           ∧ (i + length a1 = Some k)%a⌝)%I.
  Proof.
    iIntros (Ha) "Hprog".
    iDestruct (big_sepL2_length with "Hprog") as %Hlength.
    rewrite app_length in Hlength.
    set (n1 := length prog1) in *.
    set (n2 := length prog2) in *.
    rewrite -(take_drop n1 a). set (k := ^(i + n1)%a).
    iExists (take n1 a), (drop n1 a), k.
    iDestruct (big_sepL2_app' with "Hprog") as "[Hprog1 Hprog2]".
    { subst n1. rewrite take_length. lia. }
    iFrame. iPureIntro.
    pose proof (contiguous_between_length _ _ _ Ha).
    destruct (contiguous_between_app a (take n1 a) (drop n1 a) i j k); auto.
    by rewrite take_drop.
    { rewrite take_length Hlength. subst k. solve_addr. }
    rewrite take_length. repeat split; eauto. rewrite Nat.min_l; solve_addr.
  Qed.

  (* Helper lemma for contiguous lists of size 2: useful for the push macro *)
  Lemma contiguous_2 a :
    length a = 2 → contiguous a → ∃ a1 a2, a = [a1; a2] ∧ (a1 + 1)%a = Some a2.
  Proof.
    intros Hlength Ha.
    destruct a as [|a1 a]; inversion Hlength.
    destruct a as [|a2 a]; inversion Hlength.
    destruct a; inversion Hlength.
    exists a1,a2.
    pose proof (contiguous_spec _ Ha) as Ha'.
    split; [| apply Ha' with 0]; auto.
  Qed.

  (* Helper lemma for contiguous lists of size 3: useful for the pop macro *)
  Lemma contiguous_3 a :
    length a = 3 → contiguous a → ∃ a1 a2 a3, a = [a1; a2; a3] ∧ (a1 + 1)%a = Some a2 ∧ (a2 + 1)%a = Some a3.
  Proof.
    intros Hlength Ha.
    destruct a as [|a1 a]; inversion Hlength.
    destruct a as [|a2 a]; inversion Hlength.
    destruct a as [|a3 a]; inversion Hlength.
    destruct a; inversion Hlength.
    exists a1,a2,a3.
    pose proof (contiguous_spec _ Ha) as Ha'.
    split; [|split;[apply Ha' with 0|apply Ha' with 1] ];auto.
  Qed.

  Lemma contiguous_between_inj l:
    forall a1 b1 b2,
      contiguous_between l a1 b1 ->
      contiguous_between l a1 b2 ->
      b1 = b2.
  Proof.
    induction l; intros.
    - inv H; inv H0; auto.
    - inv H; inv H0. rewrite H2 in H3; inv H3.
      eapply IHl; eauto.
  Qed.

End Contiguous.

Opaque contiguous.

Definition isCorrectPC_range p g b e a0 an :=
  ∀ ai, (a0 <= ai)%a ∧ (ai < an)%a → isCorrectPC (inr (p, g, b, e, ai)).

Lemma isCorrectPC_inrange p g b (e a0 an a: Addr) :
  isCorrectPC_range p g b e a0 an →
  (a0 <= a < an)%Z →
  isCorrectPC (inr (p, g, b, e, a)).
Proof.
  unfold isCorrectPC_range. move=> /(_ a) HH ?. apply HH. eauto.
Qed.

Lemma isCorrectPC_contiguous_range p g b e a0 an a l :
  isCorrectPC_range p g b e a0 an →
  contiguous_between l a0 an →
  a ∈ l →
  isCorrectPC (inr (p, g, b, e, a)).
Proof.
  intros Hr Hc Hin.
  eapply isCorrectPC_inrange; eauto.
  eapply contiguous_between_middle_bounds'; eauto.
Qed.

Lemma isCorrectPC_range_perm p g b e a0 an :
  isCorrectPC_range p g b e a0 an →
  (a0 < an)%a →
  p = RX ∨ p = RWX ∨ p = RWLX.
Proof.
  intros Hr H0n.
  assert (isCorrectPC (inr (p, g, b, e, a0))) as HH by (apply Hr; solve_addr).
  inversion HH; auto.
Qed.

Lemma isCorrectPC_range_perm_non_E p g b e a0 an :
  isCorrectPC_range p g b e a0 an →
  (a0 < an)%a →
  p ≠ E.
Proof.
  intros HH1 HH2. pose proof (isCorrectPC_range_perm _ _ _ _ _ _ HH1 HH2).
  naive_solver.
Qed.

Lemma isCorrectPC_range_restrict p g b e a0 an a0' an' :
  isCorrectPC_range p g b e a0 an →
  (a0 <= a0')%a ∧ (an' <= an)%a →
  isCorrectPC_range p g b e a0' an'.
Proof.
  intros HR [? ?] a' [? ?]. apply HR. solve_addr.
Qed.


From trancert.lib Require Tac Decidability.

Import Tac.

Section Decidability.

  Import lib.Decidability.

  Variables A B: Type.
  Hypotheses (Hdec1: eq_dec A) (Hdec2: eq_dec B).

  Definition pair_eq_dec : eq_dec (A * B).
    decide_equality.
  Defined.

End Decidability.

Hint Resolve pair_eq_dec : decidable_prop.

Ltac pair_cases :=
  match goal with
  | [ H : (let (_,_) := ?p in _) = _ |- _] => destruct p
  end; repeat clean.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2011-01-18

Transitive closure of a finite graph.
*)

From Coq Require Import OrderedType.
From CoLoR Require Import RelUtil LogicUtil BoolUtil FGraph.
From CoLoR Require ListUtil.

Set Implicit Arguments.

Module Make (XSet : FSetInterface.S)
       (XMap : FMapInterface.S with Module E := XSet.E).

  Module Export G := FGraph.Make XSet XMap.

  Implicit Type g h : graph.

  Import X.

  Module R := RelUtil.

(***********************************************************************)
(** (a,b) in (pred x s g) if a is a predecessor of x in g and b in s *)

  Definition pred x s g a b := rel g a x /\ XSet.In b s.

  Global Instance pred_geq' :
    Proper (eq ==> XSet.Equal ==> geq ==> inclusion) pred.

  Proof.
    intros x x' xx' s s' e g g' gg' a b. unfold pred. rewrite xx', e, gg'.
    tauto.
  Qed.

  Global Instance pred_geq :
    Proper (eq ==> XSet.Equal ==> geq ==> same) pred.

  Proof. split; apply pred_geq'; hyp. Qed.

  Global Instance pred_geq_ext' :
    Proper (eq ==> XSet.Equal ==> geq ==> eq ==> eq ==> impl) pred.

  Proof.
    intros x x' xx' s s' e g g' gg' a a' aa' b b' bb'. unfold pred.
    rewrite xx', e, gg', aa', bb'. refl.
  Qed.

  Global Instance pred_geq_ext :
    Proper (eq ==> XSet.Equal ==> geq ==> eq ==> eq ==> iff) pred.

  Proof. split; apply pred_geq_ext'; hyp. Qed.

  Lemma pred_empty : forall x s, pred x s empty == empty_rel.

  Proof.
    split; intros a b; unfold pred, empty_rel; intros.
    destruct H. destruct H as [t [t1 t2]]. rewrite empty_o in t1. discr.
    contr.
  Qed.

  Lemma pred_succ_prod : forall x y g,
    let ysy := XSet.add y (succs y g) in
      let xpx := XSet.add x (preds x g) in
        pred x ysy g U succ x ysy == prod xpx ysy.

  Proof.
    intros x y g. cbv zeta. set (ysy := XSet.add y (succs y g)).
    set (xpx := XSet.add x (preds x g)). split.
    (* << *)
    rewrite union_incl_eq. split; intros a b [h1 h2]; split.
    (* pred *)
    unfold xpx. rewrite add_iff. right. rewrite In_preds_rel. hyp. hyp.
    (* succ *)
    unfold xpx. rewrite add_iff. left. hyp. hyp.
    (* >> *)
    intros a b [h1 h2]. unfold Relation_Operators.union, pred, succ.
    subst xpx ysy. rewrite add_iff in h1, h2. rewrite !add_iff.
    rewrite In_preds_rel in h1. rewrite In_succs_rel in h2.
    rewrite !In_succs_rel, (eq_com a x). tauto.
  Qed.

(***********************************************************************)
(** if x is in sw, then add a pair (w,z) for every z in s *)

  Definition add_pred x s w sw g :=
    if XSet.mem x sw then XSet.fold (add_edge w) s g else g.

  Global Instance add_pred_geq :
    Proper (eq ==> XSet.Equal ==> eq ==> XSet.Equal ==> geq ==> geq) add_pred.

  Proof.
    intros x x' xx' s s' ss' y y' yy' t t' tt' g g' gg'. unfold add_pred.
    rewrite <- xx', <- tt'. clear - ss' yy' gg'. destruct (XSet.mem x t).
    2: hyp. apply S.fold_m_ext; auto. class. apply add_edge_geq. refl.
    apply add_edge_transp_geq. apply add_edge_geq. hyp.
  Qed.

  Lemma rel_map_fold_add_pred : forall x s g g0,
    fold (add_pred x s) g g0 == pred x s g U g0.

  Proof.
    intros x s g g0. pattern g, (fold (add_pred x s) g g0).
    apply fold_rec_weak; clear g.
    (* Equal *)
    intros m n g mn h. apply Equal_geq in mn. (*SLOW:rewrite <- mn. hyp.*)
    rewrite h. apply union_same. apply pred_geq; (refl||hyp). refl.
    (* empty *)
    rewrite pred_empty, R.union_empty_l. refl.
    (* add *)
    intros z t g m n h. unfold add_pred. case_eq (XSet.mem x t); intros.
    (* x in t *)
    rewrite <- mem_iff in H.
    rewrite rel_set_fold_add_edge, h, <- R.union_assoc.
    apply R.union_same. 2: refl.
    rewrite rel_eq; intros a b. unfold succ, pred, Relation_Operators.union.
    split_all.
    rewrite H0. unfold rel. exists t. rewrite add_eq_o. tauto. refl.
    unfold rel. rewrite add_o. destruct (eq_dec z a).
    exists t. tauto.
    destruct H0 as [u [u1 u2]]. exists u. tauto.
    unfold rel in H0. rewrite add_o in H0. destruct (eq_dec z a).
    left. rewrite (eq_com a z). tauto.
    right. tauto.
    (* x notin t *)
    rewrite <- not_mem_iff in H. rewrite h. apply R.union_same. 2: refl.
    rewrite rel_eq; intros a b. unfold pred.
    rewrite not_find_in_iff in n. split_all.
    unfold rel. rewrite add_o. destruct (eq_dec z a). 2: hyp.
    (*SLOW*)rewrite e in n. destruct H0 as [u [u1 u2]]. rewrite n in u1. discr.
    unfold rel in H0. rewrite add_o in H0. destruct (eq_dec z a). 2: hyp.
    destruct H0 as [u [u1 u2]]. inversion u1. subst t. contr.
  Qed.

  (*COQ: can we remove this lemma? *)
  Lemma rel_map_fold_add_pred_ext : forall x s g g0 a b,
    rel (fold (add_pred x s) g g0) a b <-> pred x s g a b \/ rel g0 a b.

  Proof.
    split; intro h. apply rel_map_fold_add_pred in h. hyp.
    apply rel_map_fold_add_pred. hyp.
  Qed.

  Lemma add_pred_transp_geq : forall x s, transpose_neqkey geq (add_pred x s).

  Proof.
    unfold transpose_neqkey. intros x s w w' sw sw' g nww'.
    unfold geq, add_pred. destruct (XSet.mem x sw); destruct (XSet.mem x sw');
    repeat rewrite rel_set_fold_add_edge; try refl.
    rewrite <- !R.union_assoc. apply R.union_same.
    apply union_commut. refl.
  Qed.

(***********************************************************************)
(** given a transitive graph [g], [add x y g] adds edges to g to get
the transitive closure of [id x y U g] *)

  Definition trans_add_edge x y g :=
    (* if (x,y) is already in g, do nothing *)
    if XSet.mem y (succs x g) then g
    (* otherwise, for every pair (w,x) in g,
      add a pair (w,z) for every z in {y} U (succs y g) *)
      else let ysy := XSet.add y (succs y g) in
        fold (add_pred x ysy) g
        (* and, for every z in {y} U (succs y g), add a pair (x,z) *)
          (XSet.fold (add_edge x) ysy g).

  Global Instance trans_add_edge_geq :
    Proper (eq ==> eq ==> geq ==> geq) trans_add_edge.

  Proof.
    intros x x' xx' y y' yy' g g' gg'. unfold geq, trans_add_edge.
    (*SLOW*)rewrite xx', yy', gg'. destruct (XSet.mem y' (succs x' g')).
    hyp. repeat rewrite rel_map_fold_add_pred, rel_set_fold_add_edge.
    apply union_same. (*SLOW:rewrite xx', yy', gg'. refl.*)
    apply pred_geq. hyp. apply XSetFacts.add_m. hyp. apply succs_geq; hyp. hyp.
    apply union_same. rewrite xx', yy', gg'. refl. hyp.
  Qed.

  Lemma rel_trans_add_edge_pred_succ : forall x y g,
    trans_add_edge x y g == if XSet.mem y (succs x g) then g
      else let ysy := XSet.add y (succs y g) in pred x ysy g U (succ x ysy U g).

  Proof.
    intros x y g. unfold trans_add_edge.
    case_eq (XSet.mem y (succs x g)); intros. refl.
    rewrite rel_map_fold_add_pred. apply R.union_same. refl.
    rewrite rel_set_fold_add_edge. refl.
  Qed.

  Lemma rel_trans_add_edge_prod : forall x y g,
    trans_add_edge x y g == if XSet.mem y (succs x g) then g
      else prod (XSet.add x (preds x g)) (XSet.add y (succs y g)) U g.

  Proof.
    intros x y g. rewrite rel_trans_add_edge_pred_succ.
    destruct (XSet.mem y (succs x g)). refl.
    cbv zeta. set (ysy := XSet.add y (succs y g)).
    set (xpx := XSet.add x (preds x g)). rewrite <- R.union_assoc.
    apply R.union_same. apply pred_succ_prod. refl.
  Qed.

  Lemma add_edge_incl_trans : forall x y g,
    add_edge x y g << trans_add_edge x y g.

  Proof.
    intros x y g. rewrite rel_add_edge, rel_trans_add_edge_pred_succ.
    case_eq (XSet.mem y (succs x g)); intros.
    rewrite mem_succs_id. refl. hyp.
    cbv zeta; set (ysy:=XSet.add y (succs y g)).
    rewrite <- R.union_assoc, union_incl_eq. split.
    apply incl_union_r. refl. apply incl_union_l. apply incl_union_r.
    unfold ysy. rewrite succ_add. apply incl_union_l. refl.
  Qed.

  Lemma transitive_trans_add_edge : forall x y g,
    Transitive g -> Transitive (trans_add_edge x y g).

  Proof.
    intros x y g tg. rewrite rel_trans_add_edge_prod.
    destruct (XSet.mem y (succs x g)). hyp.
    intros a b c. unfold Relation_Operators.union, prod.
    rewrite !add_iff. repeat rewrite In_preds_rel, In_succs_rel. split_all.
    (* g a b /\ eq x b /\ eq y c *)
    (*SLOW*)rewrite H0, H1. intuition.
    (* g a b /\ g b x /\ eq y c *)
    left. split_all. right. apply tg with b; hyp.
    (* g a b /\ eq x b /\ g y c *)
    (*SLOW*)rewrite H0. tauto.
    (* g a b /\ g b x /\ g y c *)
    left. split_all. right. apply tg with b; hyp.
    (* g b c /\ eq x a /\ eq y b *)
    (*SLOW*)rewrite H, H1. intuition.
    (* g b c /\ g a x /\ eq y b *)
    (*SLOW*)rewrite H1. tauto.
    (* g b c /\ eq x a /\ g y b *)
    left. split_all. right. apply tg with b; hyp.
    (* g b c /\ g a x /\ g y b *)
    left. split_all. right. apply tg with b; hyp.
    (* g a b /\ g b c *)
    right. apply tg with b; hyp.
  Qed.

  Lemma rel_trans_add_edge : forall x y g,
    Transitive g -> trans_add_edge x y g == add_edge x y g!.

  Proof.
    intros x y g tg. cut (Transitive (trans_add_edge x y g)).
    2: apply transitive_trans_add_edge; hyp.
    rewrite rel_add_edge. rewrite !rel_trans_add_edge_prod.
    case_eq (XSet.mem y (succs x g)); intros.
    (* y in sx *)
    rewrite mem_succs_id. rewrite trans_tc. refl. hyp. hyp.
    (* y not in sx *)
    split.
    rewrite union_incl_eq. split. apply prod_add_incl_tc_id.
    trans (g U id x y). apply incl_union_l. refl. apply incl_tc. refl.
    apply tc_min. 2: hyp. rewrite union_commut. apply R.union_incl.
    2: refl. intros a b [xa yb]. split; rewrite add_iff; intuition.
  Qed.

  Lemma succs_trans_add_edge_id : forall x y g,
    succs x (trans_add_edge x y g)
    [=] if XSet.mem y (succs x g) then succs x g
      else XSet.union (XSet.add y (succs y g)) (succs x g).

  Proof.
    intros x y g. unfold trans_add_edge.
    case_eq (XSet.mem y (succs x g)); intros. refl.
    intro z. rewrite In_succs_rel, rel_map_fold_add_pred_ext,
    rel_set_fold_add_edge_ext. unfold pred, succ. rewrite union_iff.
    rewrite !add_iff, !In_succs_rel. split_all; auto with ordered_type.
  Qed.

  Lemma preds_trans_add_edge_id : forall x y g,
    preds x (trans_add_edge x y g)
    [=] if XSet.mem y (succs x g) then preds x g
      else if XSet.mem x (XSet.add y (succs y g)) then XSet.add x (preds x g)
        else preds x g.

  Proof.
    intros x y g. unfold trans_add_edge.
    case_eq (XSet.mem y (succs x g)); intros. refl.
    set (ysy := XSet.add y (succs y g)). intro z.
    rewrite In_preds_rel, rel_map_fold_add_pred_ext, rel_set_fold_add_edge_ext.
    case_eq (XSet.mem x ysy); intros.
    (* x in ysy *)
    rewrite add_iff, In_preds_rel. unfold ysy in H0.
    rewrite XSetFacts.add_b, orb_eq, eqb_ok, mem_succs_rel in H0.
    unfold ysy, pred, succ. rewrite add_iff, In_succs_rel. split_all; auto with ordered_type.
    (* x not in ysy *)
    unfold ysy, pred, succ. rewrite add_iff, In_succs_rel, In_preds_rel.
    rewrite false_not_true in H, H0. unfold ysy in H0.
    rewrite <- mem_iff, add_iff, In_succs_rel in H0. rewrite mem_succs_rel in H.
    split_all; contr.
  Qed.

(***********************************************************************)
(** building a transitive graph using list iteration *)

  Import ListUtil.

  Definition trans_add_edge' x g y := trans_add_edge x y g.

  Lemma transitive_list_fold_left_trans_add_edge : forall x l g,
    Transitive g -> Transitive (fold_left (trans_add_edge' x) l g).

  Proof.
    intro x. induction l; simpl. auto. intros g tg. apply IHl.
    apply transitive_trans_add_edge. hyp.
  Qed.

(***********************************************************************)
(** In the following, we assume given a type [A] (e.g. rule) and a
function [f] on [A] returning either [None] or some pair [x,l] where
[x] is an element of X.t (e.g. a symbol) and l is a list of elements
of X.t. *)

  Section list.

    Variable (A : Type) (f : A -> option (X.t * list X.t)).

(***********************************************************************)
(** graph obtained by extending [g] with the arcs provided by [f a] *)

    Definition add_edge_list g a :=
      match f a with
        | None => g
        | Some (x,l) => fold_left (add_edge' x) l g
      end.

    Lemma rel_add_edge_list : forall g a, add_edge_list g a ==
      match f a with
        | None => g
        | Some (x,l) => succ_list x l U g
      end.

    Proof.
      intros g a. unfold add_edge_list. destruct (f a) as [[x l]|].
      apply rel_list_fold_left_add_edge. refl.
    Qed.

    Global Instance add_edge_list_gle :
      Proper (gle ==> Logic.eq ==> gle) add_edge_list.

    Proof.
      intros g g' gg' a a' aa'. subst a'. unfold gle.
      do 2 rewrite rel_add_edge_list. destruct (f a) as [[x l]|].
      (*COQ:unfold needed before rewrite*)unfold gle in gg'.
      rewrite gg'. refl. hyp.
    Qed.

    Global Instance add_edge_list_geq :
      Proper (geq ==> Logic.eq ==> geq) add_edge_list.

    Proof.
      intros g g' gg' a a' aa'. subst a'. rewrite gle_antisym in gg'.
      destruct gg' as [gg' g'g]. split.
      (*COQ:unfold needed before rewrite*)unfold gle in gg'.
      (*COQ:rewrite gg' does not work*)apply add_edge_list_gle. hyp. refl.
      (*COQ:rewrite g'g does not work*)apply add_edge_list_gle. hyp. refl.
    Qed.

(***********************************************************************)
(** iteration of [add_edge_list] on a list of elements of [A] *)

    Lemma rel_list_fold_left_add_edge_list : forall l g,
      fold_left add_edge_list l g == fold_left add_edge_list l empty U g.

    Proof.
      induction l; simpl; intro g. rewrite rel_empty, R.union_empty_l. refl.
      rewrite IHl. rewrite (IHl (add_edge_list empty a)).
      do 2 rewrite rel_add_edge_list.
      destruct (f a) as [[x m]|]; rewrite rel_empty, R.union_empty_r.
      rewrite R.union_assoc. refl. refl.
    Qed.

(***********************************************************************)
(** graph obtained by extending [g] with the arcs provided by [f a]
using the function [trans_add_edge] now *)

    Definition trans_add_edge_list g a :=
      match f a with
        | None => g
        | Some (x,l) => fold_left (trans_add_edge' x) l g
      end.

    Lemma transitive_trans_add_edge_list : forall g a,
      Transitive g -> Transitive (trans_add_edge_list g a).

    Proof.
      intros. unfold trans_add_edge_list. destruct (f a).
      destruct p as [x l]. apply transitive_list_fold_left_trans_add_edge. hyp.
      hyp.
    Qed.

    Lemma rel_trans_add_edge_list : forall g a, Transitive g ->
      trans_add_edge_list g a == add_edge_list g a!.

    Proof.
      intros g a tg. unfold trans_add_edge_list, add_edge_list. destruct (f a).
      (* f a = None *)
      2: sym; apply trans_tc; hyp.
      (* f a = Some (x, l) *)
      destruct p as [x l]. revert g tg. induction l; simpl; intros g tg.
      (* nil *)
      sym. apply trans_tc. hyp.
      (* cons *)
      rename a0 into y. rewrite IHl. 2: apply transitive_trans_add_edge; hyp.
      unfold add_edge' at 3, trans_add_edge'.
      rewrite !rel_list_fold_left_add_edge,
        rel_add_edge, rel_trans_add_edge_prod.
      case_eq (XSet.mem y (succs x g)); intros.
      (* y in (succs x g) *)
      rewrite mem_succs_id. 2: hyp. refl.
      (* y not in (succs x g): R! == S! *)
      apply tc_eq.
      (* S << R *)
      apply R.union_incl. refl. rewrite union_commut.
      apply R.union_incl. 2: refl.
      intros u v [xu yv]. unfold prod. rewrite xu, yv, !add_iff. intuition.
      (* R << S! *)
      rewrite union_incl_eq. split. apply incl_tc. apply incl_union_l. refl.
      rewrite union_incl_eq. split. rewrite prod_add_incl_tc_id.
      apply tc_incl. apply incl_union_r. refl.
      apply incl_tc. apply incl_union_r. apply incl_union_l. refl.
    Qed.

    Lemma transitive_list_fold_left_trans_add_edge_list : forall l g,
      Transitive g -> Transitive (fold_left trans_add_edge_list l g).

    Proof.
      induction l; simpl. auto. intros g tg. apply IHl.
      apply transitive_trans_add_edge_list. hyp.
    Qed.

(***********************************************************************)
(** iteration of [trans_add_edge_list] on a list of elements of [A] *)

    Lemma rel_list_fold_left_trans_add_edge_list : forall l g, Transitive g ->
      fold_left trans_add_edge_list l g == fold_left add_edge_list l g!.

    Proof.
      induction l; simpl. intros. sym. apply trans_tc. hyp.
      intros g tg. rewrite IHl. 2: apply transitive_trans_add_edge_list; hyp.
      rewrite rel_list_fold_left_add_edge_list.
      rewrite rel_list_fold_left_add_edge_list with (g:=add_edge_list g a).
      set (g0 := fold_left add_edge_list l empty).
      rewrite rel_trans_add_edge_list. 2: hyp. apply tc_eq.
      (* S << R *)
      apply R.union_incl. refl. apply incl_tc. refl.
      (* R << S! *)
      rewrite union_incl_eq. split. apply incl_tc. apply incl_union_l. refl.
      apply tc_incl. apply incl_union_r. refl.
    Qed.

(***********************************************************************)
(** transitive closure of a graph defined by a list of elements of [A] *)

    Definition trans_clos_list l := fold_left trans_add_edge_list l empty.

    Lemma transitive_empty : Transitive (rel empty).

    Proof. intros x y z [s [s1 s2]]. rewrite find_empty in s1. discr. Qed.

    Lemma transitive_trans_clos_list : forall l, Transitive (trans_clos_list l).

    Proof.
      intro l. apply transitive_list_fold_left_trans_add_edge_list.
      apply transitive_empty.
    Qed.

    Lemma rel_trans_clos_list : forall l,
      trans_clos_list l == fold_left add_edge_list l empty!.

    Proof.
      intro l. unfold trans_clos_list.
      rewrite rel_list_fold_left_trans_add_edge_list. refl.
      apply transitive_empty.
    Qed.

  End list.

(***********************************************************************)
(** building a transitive graph using set iteration *)

  Lemma transitive_set_fold_trans_add_edge : forall x g,
    Transitive g -> forall s, Transitive (XSet.fold (trans_add_edge x) s g).

  Proof.
    intros x g gtrans s. pattern (XSet.fold (trans_add_edge x) s g).
    apply XSetProps.fold_rec_weak; split_all. apply transitive_trans_add_edge.
    hyp.
  Qed.

End Make.


(**************************************************************************)
(*  Copyright 2010 2011, Thomas Braibant                                  *)
(*                                                                        *)
(**************************************************************************)

Require Import Common Axioms Base Finite.

Section Lifting.

  Context {tech : Techno}.
  Context {Data : Type}.
  Context {tech_spec : Technology_spec tech Data}.
  Context {tech_spec' : Technology_spec tech (stream Data)}.

  (**  A wf_atom is one that can be lifted (does not depend on time) *)
  Definition wf_atom n m (c : techno n m) :=
    forall ins outs (H : spec c ins outs) (t : nat),
      spec c (time ins t) (time outs t).

  (** A wf circuit can be lifted to streams *)
  Inductive wf : forall n m (c : circuit n m), Prop :=
  | wf_Atom : forall n m t {Hn : Fin n} {Hn : Fin m} ,
      wf_atom n m t -> wf n m (Atom t)
  | wf_Ser : forall n m p x1 x2, wf n m x1 -> wf m p x2 -> wf n p (x1 |> x2)
  | wf_Par : forall n m p q x1 x2, wf n p x1 -> wf m q x2 -> wf (n + m) (p + q)
    (x1 & x2)
  | wf_Plug : forall n m f  {Hn : Fin n} {Hn : Fin m} , wf n m (Plug f).

  Lemma lifting n m (x : circuit n m) (Hwf : wf n m x): forall ins outs,
    Semantics x ins outs -> forall t, Semantics x (time ins t) (time outs t).
  Proof.
    induction x; intros; rinvert; inversionK Hwf.

    apply inversion_Atom in H;  constructor; auto.

    apply IHx1 with( t := t) in Hk; clear IHx1; auto.
    apply IHx2 with (t := t) in Hk0; clear IHx2;auto.
    econstructor; eauto.

    apply IHx1 with( t := t) in Hk; clear IHx1;auto.
    apply IHx2 with (t := t) in Hk0; clear IHx2;auto.

    rewrite Data.time_left in *.
    rewrite Data.time_right in *.
    constructor;    auto.

    apply inversion_Plug in H. rewrite H.
    rewrite Data.time_lift.
    simpl. constructor.

  Qed.
End Lifting.