Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export AlgoTyping.
Require Export Coq.micromega.Lia.

Module Fsub.

(*********************************************************)
(*********************************************************)
(********************** Definitions **********************)
(*********************************************************)
(*********************************************************)

Inductive typ : Set :=
  | typ_nat : typ
  | typ_top : typ
  | typ_bvar : nat -> typ
  | typ_fvar : var -> typ
  | typ_arrow : typ -> typ -> typ
  | typ_all : typ -> typ -> typ
.

Inductive exp : Set :=
  | exp_bvar : nat -> exp
  | exp_fvar : atom -> exp
  | exp_abs : typ -> exp -> exp
  | exp_app : exp -> exp -> exp
  | exp_tabs : typ -> exp -> exp
  | exp_tapp : exp -> typ -> exp
  | exp_nat : exp
.

Coercion exp_bvar : nat >-> exp.
Coercion exp_fvar : atom >-> exp.

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_nat         => typ_nat
  | typ_top         => typ_top
  | typ_bvar J      => if K === J then U else (typ_bvar J)
  | typ_fvar X      => typ_fvar X
  | typ_arrow T1 T2 => typ_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_all T1 T2 => typ_all (open_tt_rec K U T1) (open_tt_rec (S K) U T2)
  end.

Definition open_tt T U := open_tt_rec 0 U T.

Inductive type : typ -> Prop :=
  | type_top :
      type typ_top
  | type_nat :
      type typ_nat
  | type_var : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2)
  | type_all : forall L T1 T2,
      type T1 ->
      (forall X, X `notin` L -> type (open_tt T2 (typ_fvar X))) ->
      type (typ_all T1 T2)
.

Fixpoint subst_tt (Z : atom) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top => typ_top
  | typ_nat => typ_nat
  | typ_bvar J => typ_bvar J
  | typ_fvar X => if X == Z then U else (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_all T1 T2 => typ_all (subst_tt Z U T1) (subst_tt Z U T2)
  end.

Fixpoint fv_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_top => {}
  | typ_nat => {}
  | typ_bvar J => {}
  | typ_fvar X => {{ X }}
  | typ_arrow T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | typ_all T1 T2 => (fv_tt T1) `union` (fv_tt T2)
end.

Inductive binding : Set :=
| bind_sub : typ -> binding
| bind_typ : typ -> binding.

Definition env := list (atom * binding).
Notation empty := (@nil (atom * binding)).

Coercion typ_bvar : nat >-> typ.
Coercion typ_fvar : atom >-> typ.

Inductive WF : env -> typ -> Prop :=
| WF_top : forall E, WF E typ_top
| WF_nat : forall E, WF E typ_nat
| WF_var: forall U E (X : atom),
      binds X (bind_sub U) E ->
      WF E (typ_fvar X)
| WF_arrow : forall E A B,
    WF E A ->
    WF E B ->
    WF E (typ_arrow A B)
| WF_all : forall L E T1 T2,
      WF E T1 ->
      (forall X : atom, X `notin` L ->
        WF (X ~ bind_sub T1 ++ E) (open_tt T2 X)) ->
      WF E (typ_all T1 T2)
.

Fixpoint fl_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_top => {}
  | typ_nat => {}
  | typ_bvar J => {}
  | typ_fvar X => {}
  | typ_arrow T1 T2 => (fl_tt T1) `union` (fl_tt T2)
  | typ_all T1 T2 => (fl_tt T1) \u (fl_tt T2)
  end.

Fixpoint fv_env (E:env) : atoms :=
  match E with
  | nil => {}
  | (x,bind_sub y)::E' => (fv_tt y) \u (fv_env E')
  | (x,bind_typ y)::E' => (fv_tt y) \u (fv_env E')
  end.

Fixpoint fl_env (E:env) : atoms :=
  match E with
  | nil => {}
  | (x,bind_sub y)::E' => (fl_tt y) \u (fl_env E')
  | (x,bind_typ y)::E' => (fl_tt y) \u (fl_env E')
  end.

Inductive wf_env : env -> Prop :=
  | wf_env_empty :
      wf_env empty
  | wf_env_sub : forall (E : env) (X : atom) (T : typ),
      wf_env E ->
      WF E T ->
      X `notin` dom E ->
      wf_env (X ~ bind_sub T ++ E)
  | wf_env_typ : forall (E : env) (x : atom) (T : typ),
      wf_env E ->
      WF E T ->
      x `notin` dom E ->
      wf_env (x ~ bind_typ T ++ E).

Inductive sub : env -> typ -> typ -> Prop :=
| sa_nat: forall E,
    wf_env E ->
    sub E typ_nat typ_nat
| sa_fvar: forall E X,
    wf_env E ->
    WF E (typ_fvar X) ->
    sub E (typ_fvar X) (typ_fvar X)
| sa_top : forall E A,
    wf_env E ->
    WF E A ->
    sub E A typ_top
| sa_trans_tvar : forall U E T X,
      binds X (bind_sub U) E ->
      sub E U T ->
      sub E (typ_fvar X) T
| sa_arrow: forall E A1 A2 B1 B2,
    sub E B1 A1 ->
    sub E A2 B2 ->
    sub E (typ_arrow A1 A2) (typ_arrow B1 B2)
| sa_all : forall L E S T1 T2,
    WF E S ->
      (forall X : atom, X `notin` L ->
          sub (X ~ bind_sub S ++ E) (open_tt T1 X) (open_tt T2 X)) ->
      sub E (typ_all S T1) (typ_all S T2)
.

Definition subst_tb (Z : atom) (P : typ) (b : binding) : binding :=
  match b with
  | bind_sub T => bind_sub (subst_tt Z P T)
  | bind_typ T => bind_typ (subst_tt Z P T)
  end.

Fixpoint open_te_rec (K : nat) (U : typ) (e : exp) {struct e} : exp :=
  match e with
  | exp_nat => exp_nat
  | exp_bvar i => exp_bvar i
  | exp_fvar x => exp_fvar x
  | exp_abs V e1 => exp_abs  (open_tt_rec K U V)  (open_te_rec K U e1)
  | exp_app e1 e2 => exp_app  (open_te_rec K U e1) (open_te_rec K U e2)
  | exp_tabs V e1 => exp_tabs (open_tt_rec K U V)  (open_te_rec (S K) U e1)
  | exp_tapp e1 V => exp_tapp (open_te_rec K U e1) (open_tt_rec K U V)
  end.

Fixpoint open_ee_rec (k : nat) (f : exp) (e : exp)  {struct e} : exp :=
  match e with
  | exp_nat => exp_nat
  | exp_bvar i => if k == i then f else (exp_bvar i)
  | exp_fvar x => exp_fvar x
  | exp_abs V e1 => exp_abs V (open_ee_rec (S k) f e1)
  | exp_app e1 e2 => exp_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  | exp_tabs V e1 => exp_tabs V (open_ee_rec k f e1)
  | exp_tapp e1 V => exp_tapp (open_ee_rec k f e1) V
  end.

Definition open_te e U := open_te_rec 0 U e.
Definition open_ee e1 e2 := open_ee_rec 0 e2 e1.

Inductive expr : exp -> Prop :=
  | expr_nat : expr exp_nat
  | expr_var : forall x,
      expr (exp_fvar x)
  | expr_abs : forall L T e1,
      type T ->
      (forall x : atom, x `notin` L -> expr (open_ee e1 x)) ->
      expr (exp_abs T e1)
  | expr_app : forall e1 e2,
      expr e1 ->
      expr e2 ->
      expr (exp_app e1 e2)
  | expr_tabs : forall L T e1,
      type T ->
      (forall X : atom, X `notin` L -> expr (open_te e1 X)) ->
      expr (exp_tabs T e1)
  | expr_tapp : forall e1 V,
      expr e1 ->
      type V ->
      expr (exp_tapp e1 V)
.

Definition body_e (e : exp) :=
  exists L, forall x : atom, x `notin` L -> expr (open_ee e x).

Inductive typing : env -> exp -> typ -> Prop :=
  | typing_nat: forall G,
    wf_env G ->
    typing G (exp_nat) (typ_nat)
  | typing_var : forall E x T,
      wf_env E ->
      binds x (bind_typ T) E ->
      typing E (exp_fvar x) T
  | typing_abs : forall L E V e1 T1,
      (forall x : atom, x `notin` L ->
        typing (x ~ bind_typ V ++ E) (open_ee e1 x) T1) ->
      typing E (exp_abs V e1) (typ_arrow V T1)
  | typing_app : forall T1 E e1 e2 T2,
      typing E e1 (typ_arrow T1 T2) ->
      typing E e2 T1 ->
      typing E (exp_app e1 e2) T2
  | typing_tabs : forall L E V e1 T1,
      (forall X : atom, X `notin` L ->
        typing (X ~ bind_sub V ++ E) (open_te e1 X) (open_tt T1 X)) ->
      typing E (exp_tabs V e1) (typ_all V T1)
  | typing_tapp : forall T1 E e1 T T2,
      typing E e1 (typ_all T1 T2) ->
      sub E T T1 ->
      typing E (exp_tapp e1 T) (open_tt T2 T)
  | typing_sub : forall S E e T,
      typing E e S ->
      sub E S T ->
      typing E e T
.

Inductive value : exp -> Prop :=
  | value_abs : forall t1 T,
      expr (exp_abs T t1) ->
      value (exp_abs T t1)
  | value_tabs : forall t1 T,
      expr (exp_tabs T t1) ->
      value (exp_tabs T t1)
  | value_nat:
      value exp_nat
.

Inductive step : exp -> exp -> Prop :=
 | step_beta : forall (e1 e2:exp) T,
     expr (exp_abs T e1) ->
     value e2 ->
     step (exp_app  (exp_abs T e1) e2)  (open_ee e1 e2)
 | step_app1 : forall (e1 e2 e1':exp),
     expr e2 ->
     step e1 e1' ->
     step (exp_app e1 e2) (exp_app e1' e2)
 | step_app2 : forall v1 e2 e2',
     value v1 ->
     step e2 e2' ->
     step (exp_app v1 e2) (exp_app v1 e2')
 | step_tapp : forall e1 e1' V,
      type V ->
      step e1 e1' ->
      step (exp_tapp e1 V) (exp_tapp e1' V)
 | step_tabs : forall T1 e1 T2,
      expr (exp_tabs T1 e1) ->
      type T2 ->
      step (exp_tapp (exp_tabs T1 e1) T2) (open_te e1 T2)
.

Hint Constructors type WF wf_env sub expr typing step value: core.

Fixpoint fv_te (e : exp) {struct e} : atoms :=
  match e with
  | exp_nat => {}
  | exp_bvar i => {}
  | exp_fvar x => {}
  | exp_abs V e1  => (fv_tt V) `union` (fv_te e1)
  | exp_app e1 e2 => (fv_te e1) `union` (fv_te e2)
  | exp_tabs V e1 => (fv_tt V) `union` (fv_te e1)
  | exp_tapp e1 V => (fv_tt V) `union` (fv_te e1)
  end.

Fixpoint fv_ee (e : exp) {struct e} : atoms :=
  match e with
  | exp_nat => {}
  | exp_bvar i => {}
  | exp_fvar x => {{ x }}
  | exp_abs V e1 => (fv_ee e1)
  | exp_app e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_tabs V e1 => (fv_ee e1)
  | exp_tapp e1 V => (fv_ee e1)
  end.

Fixpoint subst_te (Z : atom) (U : typ) (e : exp) {struct e} : exp :=
  match e with
  | exp_nat => exp_nat
  | exp_bvar i => exp_bvar i
  | exp_fvar x => exp_fvar x
  | exp_abs V e1 => exp_abs  (subst_tt Z U V)  (subst_te Z U e1)
  | exp_app e1 e2 => exp_app  (subst_te Z U e1) (subst_te Z U e2)
  | exp_tabs V e1 => exp_tabs (subst_tt Z U V)  (subst_te Z U e1)
  | exp_tapp e1 V => exp_tapp (subst_te Z U e1) (subst_tt Z U V)
  end.

Fixpoint subst_ee (z : atom) (u : exp) (e : exp) {struct e} : exp :=
  match e with
  | exp_nat => exp_nat
  | exp_bvar i => exp_bvar i
  | exp_fvar x => if x == z then u else e
  | exp_abs V e1 => exp_abs V (subst_ee z u e1)
  | exp_app e1 e2 => exp_app (subst_ee z u e1) (subst_ee z u e2)
  | exp_tabs V e1 => exp_tabs V (subst_ee z u e1)
  | exp_tapp e1 V => exp_tapp (subst_ee z u e1) V
  end.

Definition equiv E A B := sub E A B /\ sub E B A.

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : typ => fl_tt x) in
  let E := gather_atoms_with (fun x : typ => fv_tt x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  let G := gather_atoms_with (fun x : env => fv_env x) in
  let H := gather_atoms_with (fun x : env => fl_env x) in
  let A1 := gather_atoms_with (fun x : exp => fv_te x) in
  let A2 := gather_atoms_with (fun x : exp => fv_ee x) in
  let A3 := gather_atoms_with (fun x : list (var * nat) => dom x) in
  constr:(A \u B \u C \u D \u E \u F \u G \u H \u A1 \u A2 \u A3).

(*********************************************************)
(*********************************************************)
(******************** Infrastructures ********************)
(*********************************************************)
(*********************************************************)

Lemma uniq_from_wf_env : forall E,
  wf_env E ->
  uniq E.
Proof.
  intros E H; induction H; auto.
Qed.

Lemma open_ee_rec_expr_aux : forall e j v u i,
  i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof with congruence || eauto.
  induction e; intros j v u i Neq H; simpl in *; inversion H; f_equal...
  Case "exp_bvar".
    destruct (j===n)... destruct (i===n)...
Qed.

Lemma open_ee_rec_type_aux : forall e j V u i,
  open_te_rec j V e = open_ee_rec i u (open_te_rec j V e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; intros j V u i H; simpl; inversion H; f_equal; eauto.
Qed.

Lemma open_ee_rec_expr : forall u e k,
  expr e ->
  e = open_ee_rec k u e.
Proof with auto.
  intros u e k Hexpr. revert k.
  induction Hexpr; intro k; simpl; f_equal; auto*;
  try solve [
    unfold open_ee in *;
    pick fresh x;
    eapply open_ee_rec_expr_aux with (j := 0) (v := exp_fvar x);
    auto
  | unfold open_te in *;
    pick fresh X;
    eapply open_ee_rec_type_aux with (j := 0) (V := typ_fvar X);
    auto
  ].
Qed.

Lemma subst_ee_open_ee_rec : forall e1 e2 x u k,
  expr u ->
  subst_ee x u (open_ee_rec k e2 e1) =
    open_ee_rec k (subst_ee x u e2) (subst_ee x u e1).
Proof with auto.
  intros e1 e2 x u k WP. revert k.
  induction e1; intros k; simpl; f_equal...
  Case "exp_bvar".
    destruct (k === n); subst...
  Case "exp_fvar".
    destruct (a == x); subst... apply open_ee_rec_expr...
Qed.

Lemma subst_ee_open_ee : forall e1 e2 x u,
  expr u ->
  subst_ee x u (open_ee e1 e2) =
    open_ee (subst_ee x u e1) (subst_ee x u e2).
Proof with auto.
  intros.
  unfold open_ee.
  apply subst_ee_open_ee_rec...
Qed.

Lemma subst_ee_open_ee_var : forall (x y:atom) u e,
  y <> x ->
  expr u ->
  open_ee (subst_ee x u e) y = subst_ee x u (open_ee e y).
Proof with congruence || auto.
  intros x y u e Neq Wu.
  unfold open_ee.
  rewrite subst_ee_open_ee_rec...
  simpl.
  destruct (y == x)...
Qed.

Ltac add_nil_fsub :=
    match goal with
    | [ |- WF ?E _ ] => rewrite_alist (nil ++ E)
    | [ |- sub ?E _ _ ] => rewrite_alist (nil ++ E)
    end.

Lemma subst_ee_intro_rec : forall x e u k,
  x `notin` fv_ee e ->
  open_ee_rec k u e = subst_ee x u (open_ee_rec k (exp_fvar x) e).
Proof with congruence || auto.
  induction e; intros u k Fr; simpl in *; f_equal...
  Case "exp_bvar".
    destruct (k === n)... simpl. destruct (x == x)...
  Case "exp_fvar".
    destruct (a == x)... contradict Fr; fsetdec.
Qed.

Lemma subst_ee_intro : forall x e u,
  x `notin` fv_ee e ->
  open_ee e u = subst_ee x u (open_ee e x).
Proof with auto.
  intros.
  unfold open_ee.
  apply subst_ee_intro_rec...
Qed.

Fixpoint close_tt_rec (K : nat) (Z : atom) (T : typ) {struct T} : typ :=
  match T with
  | typ_nat         => typ_nat
  | typ_top         => typ_top
  | typ_bvar J      => typ_bvar J
  | typ_fvar X      => if X == Z then typ_bvar K else typ_fvar X
  | typ_arrow T1 T2 => typ_arrow (close_tt_rec K Z T1) (close_tt_rec K Z T2)
  | typ_all A B     => typ_all (close_tt_rec K Z A)
                                (close_tt_rec (S K) Z B)
  end.

Definition close_tt T X := close_tt_rec 0 X T.

Lemma close_open_reverse_rec: forall T X,
    (X \notin fv_tt T) -> forall k, T = close_tt_rec k X (open_tt_rec k (typ_fvar X) T).
Proof with auto.
  intros T.
  induction T;intros;simpl in *;try solve [f_equal;auto]...
  -
    destruct (k==n)...
    simpl...
    destruct (X==X)...
    destruct n0...
  -
    destruct (a==X)...
    apply notin_singleton_1 in H...
    destruct H...
Qed.

Lemma close_open_reverse: forall T X,
    (X \notin fv_tt T) ->  T = close_tt (open_tt T (typ_fvar X)) X.
Proof with auto.
  intros.
  apply close_open_reverse_rec...
Qed.

(* WFC typ n : type with < k binded variables *)
Inductive WFD :  typ -> nat -> Prop :=
| WD_nat: forall k,
    WFD typ_nat k
| WD_top: forall k,
    WFD typ_top k
| WD_fvar: forall X k,
    WFD (typ_fvar X) k
| WD_bvar: forall b k,
    b < k ->
    WFD (typ_bvar b) k
| WD_arrow: forall A B k,
    WFD A k ->
    WFD B k ->
    WFD (typ_arrow A B) k
| WD_all: forall A B n,
    WFD A n ->
    WFD B (S n) ->
    WFD (typ_all A B) n
.

Hint Constructors WFC WFD WFE: core.

Lemma close_wfd : forall A X,
    WFD A 0 ->
    WFD (close_tt A X) 1.
Proof with auto.
  intros A.
  unfold close_tt.
  generalize 0.
  induction A;intros;try solve [dependent destruction H;simpl in *;auto]...
  -
    simpl...
    destruct (a==X)...
Qed.

Lemma close_type_wfd: forall A,
    type A -> WFD A 0.
Proof with auto.
  intros.
  induction H;intros...
  - (* WFD_all *)
    constructor...
    pick_fresh X.
    specialize_x_and_L X L.
    apply close_wfd with (X:=X) in H1.
    rewrite <- close_open_reverse in H1...
Qed.

Lemma open_close_reverse_rec: forall T X X0,
  (* (X \notin fv_tt T \u {{X0}}) ->  *)
  (* (X0 \notin fv_tt T) -> *)
  forall k, WFD T k ->
  subst_tt X X0 T = open_tt_rec k X0 (close_tt_rec k X T).
   (* subst_tt X0 X T = close_tt_rec k X (open_tt_rec k (typ_fvar X0) T). *)
Proof with auto.
intros T.
induction T;intros;simpl in *;try solve [f_equal;auto]...
- inv H. destruct (k == n);try lia...
- destruct (a == X)... simpl. destruct (k == k); try lia...
- inv H. rewrite IHT1 with (k:=k)...
  rewrite IHT2 with (k:=k)...
- inv H. rewrite IHT1 with (k:=k)...
  rewrite IHT2 with (k:=S k)...
Qed.

Lemma open_close_reverse: forall T (X0 X:atom),
  type T ->
  (* (X \notin fv_tt T \u {{ X0 }}) ->  *)
   subst_tt X X0 T = open_tt (close_tt T X) X0.
Proof with auto.
intros. unfold open_tt, close_tt.
rewrite <- open_close_reverse_rec...
apply close_type_wfd...
Qed.

Lemma subst_tt_intro_rec : forall X T2 U k,
  X `notin` fv_tt T2 ->
  open_tt_rec k U T2 = subst_tt X U (open_tt_rec k (typ_fvar X) T2).
Proof with congruence || auto.
  induction T2; intros U k Fr; simpl in *; f_equal...
  Case "typ_bvar".
    destruct (k === n)... simpl. destruct (X == X)...
  Case "typ_fvar".
    destruct (a == X)... contradict Fr; fsetdec.
Qed.

Lemma subst_tt_intro : forall X T2 U,
  X `notin` fv_tt T2 ->
  open_tt T2 U = subst_tt X U (open_tt T2 X).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tt_intro_rec...
Qed.

Lemma subst_te_intro_rec : forall X e U k,
  X `notin` fv_te e ->
  open_te_rec k U e = subst_te X U (open_te_rec k (typ_fvar X) e).
Proof.
  induction e; intros U k Fr; simpl in *; f_equal;
    auto using subst_tt_intro_rec.
Qed.

Lemma subst_te_intro : forall X e U,
  X `notin` fv_te e ->
  open_te e U = subst_te X U (open_te e X).
Proof with auto.
  intros.
  unfold open_te.
  apply subst_te_intro_rec...
Qed.

Lemma open_tt_rec_type_aux : forall T j V i U,
  i <> j ->
  open_tt_rec j V T = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof with congruence || eauto.
  induction T; intros j V i U Neq H; simpl in *; inversion H; f_equal...
    destruct (j === n)... destruct (i === n)...
Qed.

Lemma open_tt_rec_type : forall T U k,
  type T ->
  T = open_tt_rec k U T.
Proof with auto.
  intros T U k Htyp. revert k.
  induction Htyp; intros k; simpl; f_equal...
  unfold open_tt in *.
  pick fresh X.
  apply open_tt_rec_type_aux with (j:=0) (V:=(typ_fvar X))...
Qed.

Lemma subst_tt_fresh : forall Z U T,
   Z `notin` fv_tt T ->
   T = subst_tt Z U T.
Proof with auto.
  induction T; simpl; intro H; f_equal...
  Case "typ_fvar".
    destruct (a == Z)...
    contradict H; fsetdec.
Qed.

Lemma subst_tt_open_tt_rec : forall T1 T2 X P k,
  type P ->
  subst_tt X P (open_tt_rec k T2 T1) =
    open_tt_rec k (subst_tt X P T2) (subst_tt X P T1).
Proof with auto.
  intros T1 T2 X P k WP. revert k.
  induction T1; intros k; simpl; f_equal...
  Case "typ_bvar".
    destruct (k === n); subst...
  Case "typ_fvar".
    destruct (a == X); subst... apply open_tt_rec_type...
Qed.

Lemma subst_tt_open_tt : forall T1 T2 (X:atom) P,
  type P ->
  subst_tt X P (open_tt T1 T2) = open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tt_open_tt_rec...
Qed.

Lemma subst_tt_open_tt_var : forall (X Y:atom) P T,
  Y <> X ->
  type P ->
  open_tt (subst_tt X P T) Y = subst_tt X P (open_tt T Y).
Proof with congruence || auto.
  intros X Y P T Neq Wu.
  unfold open_tt.
  rewrite subst_tt_open_tt_rec...
  simpl.
  destruct (Y == X)...
Qed.

Lemma subst_te_open_ee_rec : forall e1 e2 Z P k,
  subst_te Z P (open_ee_rec k e2 e1) =
    open_ee_rec k (subst_te Z P e2) (subst_te Z P e1).
Proof with auto.
  induction e1; intros e2 Z P k; simpl; f_equal...
  Case "exp_bvar".
    destruct (k === n)...
Qed.

Lemma subst_te_open_ee : forall e1 e2 Z P,
  subst_te Z P (open_ee e1 e2) = open_ee (subst_te Z P e1) (subst_te Z P e2).
Proof with auto.
  intros.
  unfold open_ee.
  apply subst_te_open_ee_rec...
Qed.

Lemma subst_te_open_ee_var : forall Z (x:atom) P e,
  open_ee (subst_te Z P e) x = subst_te Z P (open_ee e x).
Proof with auto.
  intros.
  rewrite subst_te_open_ee...
Qed.

Lemma open_te_rec_expr_aux : forall e j u i P ,
  open_ee_rec j u e = open_te_rec i P (open_ee_rec j u e) ->
  e = open_te_rec i P e.
Proof with congruence || eauto.
  induction e; intros j u i P H; simpl in *; inversion H; f_equal...
Qed.

Lemma open_te_rec_type_aux : forall e j Q i P,
  i <> j ->
  open_te_rec j Q e = open_te_rec i P (open_te_rec j Q e) ->
  e = open_te_rec i P e.
Proof.
  induction e; intros j Q i P Neq Heq; simpl in *; inversion Heq;
    f_equal; eauto using open_tt_rec_type_aux.
Qed.

Lemma open_te_rec_expr : forall e U k,
  expr e ->
  e = open_te_rec k U e.
Proof.
  intros e U k WF. revert k.
  induction WF; intros k; simpl; f_equal; auto using open_tt_rec_type;
  try solve [
    unfold open_ee in *;
    pick fresh x;
    eapply open_te_rec_expr_aux with (j := 0) (u := exp_fvar x);
    auto
  | unfold open_te in *;
    pick fresh X;
    eapply open_te_rec_type_aux with (j := 0) (Q := typ_fvar X);
    auto
  ].
Qed.

Lemma subst_ee_open_te_rec : forall e P z u k,
  expr u ->
  subst_ee z u (open_te_rec k P e) = open_te_rec k P (subst_ee z u e).
Proof with auto.
  induction e; intros P z u k H; simpl; f_equal...
  Case "exp_fvar".
    destruct (a == z)... apply open_te_rec_expr...
Qed.

Lemma subst_ee_open_te : forall e P z u,
  expr u ->
  subst_ee z u (open_te e P) = open_te (subst_ee z u e) P.
Proof with auto.
  intros.
  unfold open_te.
  apply subst_ee_open_te_rec...
Qed.

Lemma subst_ee_open_te_var : forall z (X:atom) u e,
  expr u ->
  open_te (subst_ee z u e) X = subst_ee z u (open_te e X).
Proof with auto.
  intros z X u e H.
  rewrite subst_ee_open_te...
Qed.

Lemma subst_tt_type : forall Z P T,
  type T ->
  type P ->
  type (subst_tt Z P T).
Proof with auto.
  intros Z P T HT HP.
  induction HT; simpl...
  destruct (X == Z)...
  pick fresh Y.
  apply type_all with (L:=L \u {{Z}})...
  intros.
  rewrite subst_tt_open_tt_var...
Qed.

Lemma subst_tt_twice: forall (X Y:atom) T,
  X \notin fv_tt T ->
  T = subst_tt X Y (subst_tt Y X T).
Proof with auto.
  induction T;intros;simpl in *;try f_equal...
  +
    destruct (a == Y);simpl...
    destruct (X == X);simpl;try f_equal...
    tauto.
    destruct (a == X);simpl;try f_equal...
    exfalso. simpl in H...
Qed.

Lemma subst_te_open_te_rec : forall e T X U k,
  type U ->
  subst_te X U (open_te_rec k T e) =
    open_te_rec k (subst_tt X U T) (subst_te X U e).
Proof.
  intros e T X U k WU. revert k.
  induction e; intros k; simpl; f_equal; auto using subst_tt_open_tt_rec.
Qed.

Lemma subst_te_open_te : forall e T X U,
  type U ->
  subst_te X U (open_te e T) = open_te (subst_te X U e) (subst_tt X U T).
Proof with auto.
  intros.
  unfold open_te.
  apply subst_te_open_te_rec...
Qed.

Lemma subst_te_open_te_var : forall (X Y:atom) U e,
  Y <> X ->
  type U ->
  open_te (subst_te X U e) Y = subst_te X U (open_te e Y).
Proof with congruence || auto.
  intros X Y U e Neq WU.
  unfold open_te.
  rewrite subst_te_open_te_rec...
  simpl.
  destruct (Y == X)...
Qed.

Lemma fv_open_tt_notin_inv: forall T S (X:atom),
    X \notin fv_tt T ->
    fv_tt (open_tt T X) [<=] add X S ->
    fv_tt T [<=] S.
Proof with auto.
  intro T.
  unfold open_tt in *.
  generalize 0.
  induction T;intros;simpl in *;try solve [apply KeySetProperties.subset_empty]...
  -
    unfold "[<=]" in *.
    intros...
    apply AtomSetNotin.D.F.singleton_iff in H1...
    subst.
    assert (a0 `in` singleton a0) by auto.
    specialize (H0 a0 H1)...
    apply AtomSetImpl.add_3 in H0...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=n)...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=(Datatypes.S n))...
Qed.

Lemma open_tt_var_rev: forall A B (X:atom),
    X \notin fv_tt A \u fv_tt B ->
    open_tt A X = open_tt B X ->
    A = B.
Proof with auto.
  unfold open_tt.
  generalize 0.
  intros n A B.
  generalize dependent n.
  generalize dependent B.
  induction A;induction B;intros;simpl in *;try solve [inversion H0|destruct (n0==n);subst;inversion H0]...
  -
    destruct (n1==n);destruct (n1==n0);subst...
    inversion H0.
    inversion H0.
  -
    destruct (n0==n);subst...
    inversion H0.
    rewrite <- H2 in H.
    solve_notin_self X.
  -
    destruct (n0==n);subst...
    inversion H0.
    rewrite  H2 in H.
    solve_notin_self X.
  -
    inversion H0.
    apply IHA1 in H2...
    apply IHA2 in H3...
    subst...
  -
    inversion H0.
    apply IHA1 in H2...
    apply IHA2 in H3...
    subst...
Qed.

(*********************************************************)
(*********************************************************)
(******************** Regularity *************************)
(*********************************************************)
(*********************************************************)

Lemma wf_typ_strengthening : forall E F x U T,
 WF (F ++ x ~ bind_typ U ++ E) T ->
 WF (F ++ E) T.
Proof with eauto.
  intros.
  dependent induction H...
  -
    analyze_binds H...
  -
    apply WF_all with (L:=L);intros...
    rewrite_env (((X~ bind_sub T1) ++ F) ++ E)...
    apply H1 with (x0:=x) (U0:=U)...
Qed.

Lemma WF_weakening: forall E1 E2 T E,
    WF (E1 ++ E2) T ->
    WF (E1 ++ E ++ E2) T.
Proof with eauto.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  -
    apply WF_all with (L:=L)...
    intros.
    rewrite_alist (([(X, bind_sub T1)] ++ E1) ++ E ++ E2).
    apply H1...
Qed.

Lemma wf_typ_from_binds_typ : forall x U E,
  wf_env E ->
  binds x (bind_typ U) E ->
  WF E U.
Proof with auto.
  induction 1; intros J; analyze_binds J...
  -
    apply IHwf_env in BindsTac...
    add_nil_fsub.
    apply WF_weakening...
  -
    inversion BindsTacVal;subst.
    add_nil_fsub.
    apply WF_weakening...
  -
    apply IHwf_env in BindsTac...
    add_nil_fsub.
    apply WF_weakening...
Qed.

Lemma WF_type: forall E T,
    WF E T -> type T.
Proof with auto.
  intros.
  induction H...
  apply type_all with (L:=L)...
Qed.

Lemma sub_regular : forall E A B,
    sub E A B -> wf_env E /\ WF E A /\ WF E B.
Proof with auto.
  intros.
  induction H;destruct_hypos...
  -
    repeat split...
    apply WF_var with (U:=U)...
  -
    pick fresh Z.
    assert ( wf_env (Z ~ bind_sub S ++ E)).
    specialize_x_and_L Z L.
    destruct_hypos.
    dependent destruction H1...
    dependent destruction H2.
    repeat split...
    apply WF_all with (L:=L);intros...
    eapply H1...
    apply WF_all with (L:=L);intros...
    eapply H1...
Qed.

Lemma binds_map_free: forall F X  Y U  P,
    In (X, bind_sub U) F ->
    X <> Y ->
    In (X, bind_sub (subst_tt Y P U)) (map (subst_tb Y P) F).
Proof with auto.
  induction F;intros...
  apply in_inv in H.
  destruct H...
  -
    destruct a.
    inversion H;subst.
    simpl...
  -
    simpl...
Qed.

Lemma subst_tb_wf : forall F Q E Z P T,
  WF (F ++ Z ~ Q ++ E) T ->
  WF E P ->
  WF (map (subst_tb Z P) F ++ E) (subst_tt Z P T).
Proof with eauto.
  intros.
  generalize dependent P.
  dependent induction H;intros;simpl in *...
  -
    destruct (X==Z);subst...
    add_nil_fsub.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var with (U:=(subst_tt Z P U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free...
  -
    apply WF_all with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub T1 ++ F) ++ E).
    apply H1 with (Q0:=Q)...
    apply WF_type in H2...
Qed.

Lemma typing_regular : forall E e T,
  typing E e T ->
  wf_env E /\ expr e /\ WF E T.
Proof with auto.
  intros.
  induction H;destruct_hypos...
  -
    repeat split...
    apply wf_typ_from_binds_typ with (x:=x)...
  -
    pick fresh Y.
    assert (wf_env (Y ~ bind_typ V ++ E)).
    specialize_x_and_L Y L...
    destruct_hypos...
    dependent destruction H1...
    repeat split...
    +
      apply expr_abs with (L:=L)...
      apply WF_type with (E:=E) ...
      intros.
      apply H0...
    +
      constructor...
      specialize_x_and_L Y L...
      destruct_hypos.
      add_nil_fsub.
      apply wf_typ_strengthening with (x:=Y) (U:=V)...
  -
    inv H6...
  -
    pick fresh Y.
    assert (wf_env (Y ~ bind_sub V ++ E)).
    specialize_x_and_L Y L...
    destruct_hypos...
    dependent destruction H1...
    repeat split...
    +
      apply expr_tabs with (L:=L)...
      apply WF_type with (E:=E) ...
      intros.
      apply H0...
    +
      apply WF_all with (L:=L)...
      intros.
      eapply H0...
  -
    inv H3...
    repeat split...
    + constructor... apply WF_type with (E:=E).
      apply sub_regular in H0. destruct_hypos...
    +
      pick fresh X.
      rewrite subst_tt_intro with (X:=X)...
      rewrite_env (map (subst_tb X  T) nil ++ E).
      apply subst_tb_wf with (Q:=bind_sub T1)...
      apply H8...
      apply sub_regular in H0. destruct_hypos...
  -
    repeat split...
    apply sub_regular in H0. destruct_hypos...
Qed.

(*********************************************************)
(*********************************************************)
(******************** Reflexivity ************************)
(*********************************************************)
(*********************************************************)

Lemma Reflexivity: forall E A,
    WF E A ->
    wf_env E ->
    sub E A A.
Proof with auto.
  intros.
  induction H...
  -
    constructor...
    apply WF_var with (U:=U)...
  -
    apply sa_all with (L:=L \u dom E \u fv_env E \u fl_env E)...
Qed.

(*********************************************************)
(*********************************************************)
(*********** Context Strengthen/weakening ****************)
(*********************************************************)
(*********************************************************)

Lemma wf_env_strengthening : forall x T E F,
  wf_env (F ++ x ~ bind_typ T ++ E) ->
  wf_env (F ++ E).
Proof with eauto using wf_typ_strengthening.
  induction F; intros Wf_env; inversion Wf_env; subst; simpl_env in *...
Qed.

Lemma Sub_typ_strengthening : forall E F x U A B,
 sub (F ++ x ~ bind_typ U ++ E) A B ->
 sub (F ++ E) A B.
Proof with eauto using wf_env_strengthening, wf_typ_strengthening.
  intros.
  dependent induction H...
  -
    apply sa_trans_tvar with (U:=U0)...
    analyze_binds H...
  -
    apply sa_all with (L:=L);intros...
    rewrite_env (((X~ bind_sub S) ++ F) ++ E)...
    apply H1 with (x0:=x) (U0:=U)...
Qed.

Lemma Sub_weakening: forall E1 E2 A B E,
    sub (E1 ++ E2) A B ->
    wf_env (E1 ++ E ++ E2) ->
    sub (E1 ++ E ++ E2) A B.
Proof with eauto using WF_weakening.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  -
    apply sa_all with (L:=L \u dom E1 \u dom E2 \u dom E \u fv_env (E1++E++E2) \u fl_env (E1++E++E2))...
    intros.
    rewrite_alist (([(X, bind_sub S)] ++ E1) ++ E ++ E2).
    apply H1...
    rewrite_alist ([(X, bind_sub S)] ++ E1 ++ E ++ E2)...
Qed.

Lemma binds_typ_replacing_subst_tb: forall E X Y T x,
  binds x (bind_typ T) E ->
  binds x (bind_typ (subst_tt X Y T)) ((map (subst_tb X Y) E)).
Proof.
  intros. induction E.
  - inv H.
  - destruct H.
    + subst. left. reflexivity.
    + right. apply IHE. auto.
Qed.

Lemma binds_sub_replacing_subst_tb: forall E X Y T x,
  binds x (bind_sub T) E ->
  binds x (bind_sub (subst_tt X Y T)) ((map (subst_tb X Y) E)).
Proof.
  intros. induction E.
  - inv H.
  - destruct H.
    + subst. left. reflexivity.
    + right. apply IHE. auto.
Qed.

Lemma wf_env_cons: forall E1 E2,
    wf_env (E1++E2) ->
    wf_env E2.
Proof with auto.
  induction E1;intros...
  destruct a...
  dependent destruction H...
Qed.

Lemma WF_from_binds_typ : forall x U E,
  wf_env E ->
  binds x (bind_sub U) E ->
  WF E U.
Proof with auto.
  induction 1; intros J; analyze_binds J...
  -
    inversion BindsTacVal;subst.
    add_nil_fsub.
    apply WF_weakening...
  -
    add_nil_fsub.
    apply WF_weakening...
 -
    add_nil_fsub.
    apply WF_weakening...
Qed.

Lemma in_binds: forall x a U x0,
    a `in` dom (x ++ (a, bind_sub U) :: x0).
Proof with auto.
  induction x;intros...
  simpl...
  simpl...
  destruct a...
Qed.

Lemma WF_imply_dom: forall E A,
    WF E A ->
    fv_tt A [<=] dom E.
Proof with auto.
  intros.
  induction H;simpl in *;try solve [apply KeySetProperties.subset_empty]...
  -
    unfold binds in H...
    unfold "[<=]".
    intros.
    apply KeySetFacts.singleton_iff in H0.
    subst.
    apply in_split in H.
    destruct_hypos.
    rewrite H...
    apply in_binds...
  -
    apply KeySetProperties.union_subset_3...
  -
    apply KeySetProperties.union_subset_3...
    pick fresh X.
    specialize_x_and_L X L.
    apply fv_open_tt_notin_inv in H1...
Qed.

(*********************************************************)
(*********************************************************)
(******************** Replacing **************************)
(*********************************************************)
(*********************************************************)

Lemma binds_sub_replacing: forall E1 E2 U X Y x T,
    binds  x (bind_sub T) (E1++ X ~ bind_sub U ++E2) ->
    X <> Y -> x <> X ->
    wf_env ( E1 ++ X ~ bind_sub U ++ E2) ->
    binds  x (bind_sub (subst_tt X Y T)) (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++E2).
Proof with auto.
  intros.
  apply binds_app_iff in H. apply binds_app_iff.
  destruct H.
  - left. apply binds_sub_replacing_subst_tb...
  - right. inv H. { inv H3... exfalso... }
    apply wf_env_cons in H2. inv H2.
    pose proof WF_from_binds_typ _ _ H7 H3.
    apply WF_imply_dom in H4.
    rewrite <- subst_tt_fresh...
Qed.

Lemma typing_replacing: forall E1 E2 e T U X Y,
  typing (E1++ X ~ bind_typ U ++E2) e T ->
  X <> Y ->
  wf_env ( E1 ++ Y ~ bind_typ U ++ E2) ->
  typing (E1 ++ Y ~ bind_typ U ++E2) (subst_ee X Y e) T.
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros.
  - constructor. auto.
  - simpl. destruct (x == X)...
    { subst. apply typing_var...
      assert (binds X (bind_typ U) (E1 ++ X ~ bind_typ U ++ E2))...
      pose proof binds_unique _ _ _ _ _ H0 H3.
      rewrite H4... apply uniq_from_wf_env... }
    { apply typing_var with (T:=T)... analyze_binds H0. }
  - apply typing_abs with (L:=L \u {{ X }}
      \u dom (E1 ++ Y ~ bind_typ U ++ E2) )...
    intros.
    specialize_x_and_L x L.
    rewrite subst_ee_open_ee_var...
    rewrite_env ((x~bind_typ V ++ E1) ++ Y ~ bind_typ U ++ E2).
    apply H0...
    rewrite_env (x~bind_typ V ++ (E1 ++ Y ~ bind_typ U ++ E2)).
    constructor...
    { apply typing_regular in H. destruct_hypos.
      inv H... rewrite_env (E1 ++ X ~ bind_typ U ++ E2) in H10.
      apply wf_typ_strengthening in H10.
      apply WF_weakening... }
  - apply typing_app with (T1:=T1)...
  - simpl. apply typing_tabs with (L:=L \u {{ X }}
  \u dom (E1 ++ Y ~ bind_typ U ++ E2) ).
    intros.
    specialize_x_and_L X0 L.
    rewrite subst_ee_open_te_var...
    rewrite_env ((X0~bind_sub V ++ E1) ++ Y ~ bind_typ U ++ E2).
    apply H0...
    rewrite_env (X0~bind_sub V ++ (E1 ++ Y ~ bind_typ U ++ E2)).
    constructor...
    { apply typing_regular in H. destruct_hypos.
      inv H... rewrite_env (E1 ++ X ~ bind_typ U ++ E2) in H10.
      apply wf_typ_strengthening in H10.
      apply WF_weakening... }
  - simpl. apply typing_tapp with (T1:=T1)...
    apply IHtyping...
    { apply Sub_typ_strengthening in H0.
      rewrite_env (E1 ++ Y  ~ bind_typ U ++ E2).
      apply Sub_weakening...
    }
  - apply typing_sub with (S:=S)...
    { apply Sub_typ_strengthening in H0.
      rewrite_env (E1 ++ Y  ~ bind_typ U ++ E2).
      apply Sub_weakening...
    }
Qed.

Lemma WF_replacing: forall E1 E2 T U (X Y:atom),
    WF ( E1 ++ X ~ bind_sub U ++E2) T ->
    Y <> X ->
    WF (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++E2) (subst_tt X Y T).
Proof with auto.
  intros.
  dependent induction H;intros;simpl;try solve [rewrite_alist (map (subst_tb X Y) E1  ++ Y ~ bind_sub U ++ E2);constructor;auto]...
  -
    destruct (X0==X)...
    { subst. apply WF_var with (U:=U)... }
    { apply binds_app_iff in H. destruct H.
      + apply WF_var with (U:=(subst_tt X Y U0))...
        apply binds_app_iff. left.
        apply binds_map_free...
      + apply WF_var with (U:=U0)...
        simpl. analyze_binds H. }
  - apply WF_all with (L:= L \u {{X}});intros...
    + apply IHWF...
    + rewrite_alist ((map (subst_tb X Y) ((X0 ~ bind_sub T1) ++ E1)) ++ Y ~ bind_sub U ++ E2).
      rewrite  subst_tt_open_tt_var...
Qed.

Lemma maps_subst_tb_free: forall E X U,
    X \notin fv_env E ->
    map (subst_tb X U) E = E.
Proof with auto.
  induction E;intros...
  destruct a.
  destruct b.
  -
    simpl in *.
    f_equal...
    f_equal...
    f_equal...
    rewrite <- subst_tt_fresh...
  -
    simpl in *.
    f_equal...
    f_equal...
    f_equal...
    rewrite <- subst_tt_fresh...
Qed.

Lemma fv_env_ls_dom: forall E,
    wf_env E ->
    fv_env E [<=] dom E.
Proof with auto.
  induction E;intros;simpl in *...
  -
    apply AtomSetProperties.subset_empty...
  -
    destruct a.
    destruct b.
    +
      dependent destruction H.
      apply KeySetProperties.subset_add_2...
      apply AtomSetProperties.union_subset_3...
      apply WF_imply_dom...
    +
      dependent destruction H.
      apply KeySetProperties.subset_add_2...
      apply AtomSetProperties.union_subset_3...
      apply WF_imply_dom...
Qed.

Lemma notin_from_wf_env: forall E1 X T E2,
    wf_env (E1 ++ (X, bind_sub T) :: E2) ->
    X \notin fv_tt T \u dom E2 \u dom E1 \u fv_env E2.
Proof with auto.
  induction E1;intros...
  -
    dependent destruction H...
    apply WF_imply_dom in H0...
    apply fv_env_ls_dom in H...
  -
    dependent destruction H...
    simpl in *...
    apply IHE1 in H...
    simpl in *...
    apply IHE1 in H...
Qed.

Lemma binds_map_free_sub: forall E1 E2 X Y U S Q,
    Y \notin {{X}}  ->
    wf_env (E1 ++ (Y, bind_sub Q) :: E2) ->
    binds X (bind_sub U) (E1 ++ (Y, bind_sub Q) :: E2) ->
    binds X (bind_sub (subst_tt Y S U)) (map (subst_tb Y S) E1 ++  E2).
Proof with auto.
  intros.
  analyze_binds H1...
  -
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free...
  -
    unfold binds in *.
    apply In_lemmaR.
    rewrite <- maps_subst_tb_free with (X:=Y) (U:=S)...
    apply binds_map_free...
    apply notin_from_wf_env in H0...
Qed.

Lemma sub_replacing: forall E1 E2 A B U X Y,
    sub (E1++ X ~ bind_sub U ++E2) A B ->
    X <> Y ->
    wf_env (map (subst_tb X Y)  E1 ++ Y ~ bind_sub U ++ E2) ->
    sub (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++E2) (subst_tt X Y A) (subst_tt X Y B).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros;simpl;try solve [rewrite_alist (map (subst_tb X Y) E1 ++ [(Y, bind_sub U)] ++ E2);constructor;auto;apply WF_replacing;auto]...
  -
    destruct (X0==X)...
    constructor... apply WF_var with (U:=U)...
    constructor...
    dependent destruction H0.
    apply binds_map_free_sub with (S:=Y) in H0...
    apply WF_var with (U:=(subst_tt X Y U0))...
    analyze_binds H0.
  -
    destruct (X0==X);subst...
    +
      apply sa_trans_tvar with (U:=subst_tt X Y U0)...
      analyze_binds_uniq H...
      apply uniq_from_wf_env...
      { apply sub_regular in H0. destruct_hypos... }
      inversion BindsTacVal;subst.
      apply sub_regular in H0. destruct_hypos...
      apply notin_from_wf_env in H0.
      rewrite <- subst_tt_fresh...
      apply IHsub...
    +
      apply sa_trans_tvar with (U:=subst_tt X Y U0)...
      analyze_binds H.
      *
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free...
      *
        assert (Ht:=BindsTac0).
        apply WF_from_binds_typ in Ht...
        apply WF_imply_dom in Ht.
        apply sub_regular in H0. destruct_hypos.
        get_well_form.
        apply notin_from_wf_env in H.
        rewrite <- subst_tt_fresh...
        apply notin_partial with (E2:=dom E2)...
        apply wf_env_cons in H2.
        apply wf_env_cons in H2...
      *
        apply IHsub...
  -
    apply sa_all with (L:=L \u {{X}} \u dom (map (subst_tb X Y) E1 ++ (Y, bind_sub U) :: E2));intros...
    apply WF_replacing...
    rewrite_env (map (subst_tb X Y) (X0~bind_sub S ++ E1) ++ (Y, bind_sub U) :: E2).
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    apply H1...
    simpl...
    constructor...
    apply WF_replacing...
Qed.

Lemma typing_replacing2: forall E1 E2 e T U X Y,
  typing (E1++ X ~ bind_sub U ++E2) e T ->
  X <> Y ->
  wf_env ( map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++ E2) ->
  typing (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++E2) (subst_te X Y e) (subst_tt X Y T).
Proof with auto.
  intros.
  generalize dependent Y.
  dependent induction H;intros.
  - constructor. auto.
  - destruct (x == X)...
    { subst. apply typing_var...
      assert (binds X (bind_sub U) (E1 ++ X ~ bind_sub U ++ E2))...
      pose proof binds_unique _ _ _ _ _ H0 H3.
      apply uniq_from_wf_env in H.
      specialize (H4 H). inv H4.
    }
    { apply typing_var... apply binds_app_iff in H0. apply binds_app_iff.
      destruct H0.
      - left. apply binds_typ_replacing_subst_tb...
      - right. destruct H0. { inv H0... }
        apply wf_env_cons in H. inv H.
        pose proof wf_typ_from_binds_typ _ _ H6 H0.
        apply WF_imply_dom in H3.
        rewrite <- subst_tt_fresh...
    }
  - simpl. apply typing_abs with (L:=L \u {{ X }} \u
      dom (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++ E2)
    )...
    intros.
    specialize_x_and_L x L.
    rewrite subst_te_open_ee_var...
    rewrite_env (map (subst_tb X Y) (x ~ bind_typ V ++ E1) ++ Y ~ bind_sub U ++ E2).
    apply H0...
    rewrite_env (x ~ bind_typ (subst_tt X Y V) ++ (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++ E2)).
    constructor...
    { apply typing_regular in H. destruct_hypos.
      inv H... rewrite_env (E1 ++ (X ~ bind_sub U) ++ E2) in H10.
      apply WF_replacing... }
  - simpl. apply typing_app with (T2:=subst_tt X Y T2) (T1:=subst_tt X Y T1)...
    + apply IHtyping1...
    + apply IHtyping2...
  - simpl. apply typing_tabs with (L:=L \u {{ X }}
  \u dom (E1 ++ Y ~ bind_typ U ++ E2) ).
    intros.
    specialize_x_and_L X0 L.
    rewrite subst_te_open_te_var...
    rewrite subst_tt_open_tt_var...
    rewrite_env ( map (subst_tb X Y) (X0~bind_sub V ++ E1) ++ Y ~ bind_sub U ++ E2).
    apply H0...
    rewrite_env (X0~bind_sub (subst_tt X Y V) ++ (map (subst_tb X Y) E1 ++ Y ~ bind_sub U ++ E2)).
    constructor...
    { apply typing_regular in H. destruct_hypos.
      inv H... rewrite_env(E1 ++ (X ~ bind_sub U) ++ E2) in H10.
      apply WF_replacing... }
  - simpl. rewrite subst_tt_open_tt...
    apply typing_tapp with  (T2:=subst_tt X Y T2) (T1:=subst_tt X Y  T1)...
    + apply IHtyping...
    + apply sub_replacing...
  - apply typing_sub with (S:= subst_tt X Y S)...
    apply sub_replacing...
Qed.

End Fsub.


Require Import VST.floyd.proofauto.
Require Import wand_demo.wand_frame.
Require Import wand_demo.wand_frame_tactic.
Require Import wand_demo.bst.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_struct_tree := Tstruct _tree noattr.

Section TREES.
Variable V : Type.
Variable default: V.

Definition key := Z.

Inductive tree : Type :=
 | E : tree
 | T: tree -> key -> V -> tree -> tree.

Definition empty_tree : tree := E.

Fixpoint insert (x: key) (v: V) (s: tree) : tree :=
 match s with
 | E => T E x v E
 | T a y v' b => if  x <? y then T (insert x v a) y v' b
                        else if y <? x then T a y v' (insert x v b)
                        else T a x v b
 end.

Fixpoint lookup (x: key) (t : tree) : V :=
  match t with
  | E => default
  | T tl k v tr => if x <? k then lookup x tl
                         else if k <? x then lookup x tr
                         else v
  end.

Fixpoint pushdown_left (a: tree) (bc: tree) : tree :=
 match bc with
 | E => a
 | T b y vy c => T (pushdown_left a b) y vy c
 end.

Fixpoint delete (x: key) (s: tree) : tree :=
 match s with
 | E => E
 | T a y v' b => if  x <? y then T (delete x a) y v' b
                        else if y <? x then T a y v' (delete x b)
                        else pushdown_left a b
 end.

End TREES.
Arguments E {V}.
Arguments T {V} _ _ _ _.
Arguments insert {V} x v s.
Arguments lookup {V} default x t.
Arguments pushdown_left {V} a bc.
Arguments delete {V} x s.

Fixpoint treebox_rep (t: tree val) (p: val) :=
  EX q: val,
  data_at Tsh (tptr t_struct_tree) q p *
  match t with
  | E => !!(q=nullval) && emp
  | T l x v r => !! (Int.min_signed <= x <= Int.max_signed /\ tc_val (tptr Tvoid) v) &&
      field_at Tsh t_struct_tree [StructField _key] (Vint (Int.repr x)) q *
      field_at Tsh t_struct_tree [StructField _value] v q *
      treebox_rep l (field_address t_struct_tree [StructField _left] q) *
      treebox_rep r (field_address t_struct_tree [StructField _right] q)
  end.

Definition tree_rep (t: tree val) (q: val) :=
  match t with
  | E => !!(q=nullval) && emp
  | T l x v r => !! (Int.min_signed <= x <= Int.max_signed /\ tc_val (tptr Tvoid) v) &&
      field_at Tsh t_struct_tree [StructField _key] (Vint (Int.repr x)) q *
      field_at Tsh t_struct_tree [StructField _value] v q *
      treebox_rep l (field_address t_struct_tree [StructField _left] q) *
      treebox_rep r (field_address t_struct_tree [StructField _right] q)
  end.

Lemma treebox_rep_spec: forall t p,
  treebox_rep t p = EX q: val, data_at Tsh (tptr t_struct_tree) q p * tree_rep t q.
Proof.
  intros.
  unfold tree_rep, treebox_rep.
  destruct t; auto.
Qed.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH n: Z
  PRE [ 1%positive OF tint]
     PROP (4 <= n <= Int.max_unsigned)
     LOCAL (temp 1%positive (Vint (Int.repr n)))
     SEP ()
  POST [ tptr tvoid ]
     EX v: val,
     PROP (malloc_compatible n v)
     LOCAL (temp ret_temp v)
     SEP (memory_block Tsh n v).

Definition freeN_spec :=
 DECLARE _freeN
  WITH p : val , n : Z
  PRE [ 1%positive OF tptr tvoid , 2%positive OF tint]
     (* we should also require natural_align_compatible (eval_id 1) *)
      PROP() LOCAL (temp 1%positive p; temp 2%positive (Vint (Int.repr n)))
      SEP (memory_block Tsh n p)
  POST [ tvoid ]
    PROP () LOCAL () SEP ().

Definition insert_spec :=
 DECLARE _insert
  WITH p0: val, x: Z, v: val, t0: tree val
  PRE  [ _p OF (tptr (tptr t_struct_tree)), _x OF tint,
        _value OF (tptr Tvoid)   ]
    PROP( Int.min_signed <= x <= Int.max_signed; is_pointer_or_null v)
    LOCAL(temp _p p0; temp _x (Vint (Int.repr x)); temp _value v)
    SEP (treebox_rep t0 p0)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (insert x v t0) p0).

Definition lookup_spec :=
 DECLARE _lookup
  WITH b: val, x: Z, v: val, t: tree val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint  ]
    PROP( Int.min_signed <= x <= Int.max_signed)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)))
    SEP (treebox_rep t b)
  POST [ tptr Tvoid ]
    PROP()
    LOCAL(temp ret_temp (lookup nullval x t))
    SEP (treebox_rep t b).
(*
Definition turn_left_spec :=
 DECLARE _turn_left
  WITH ta: tree val, x: Z, vx: val, tb: tree val, y: Z, vy: val, tc: tree val, b: val, l: val, pa: val, r: val
  PRE  [ __l OF (tptr (tptr (Tstruct _tree noattr))),
        _l OF (tptr (Tstruct _tree noattr)),
        _r OF (tptr (Tstruct _tree noattr))]
    PROP(Int.min_signed <= x <= Int.max_signed; is_pointer_or_null vx)
    LOCAL(temp __l b; temp _l l; temp _r r)
    SEP (data_at Tsh (tptr t_struct_tree) l b;
         data_at Tsh t_struct_tree (Vint (Int.repr x), (vx, (pa, r))) l;
         tree_rep ta pa;
         tree_rep (T tb y vy tc) r)
  POST [ Tvoid ]
    EX pc: val,
    PROP(Int.min_signed <= y <= Int.max_signed; is_pointer_or_null vy)
    LOCAL()
    SEP (data_at Tsh (tptr t_struct_tree) r b;
         data_at Tsh t_struct_tree (Vint (Int.repr y), (vy, (l, pc))) r;
         tree_rep (T ta x vx tb) l;
         tree_rep tc pc).

Definition pushdown_left_spec :=
 DECLARE _pushdown_left
  WITH ta: tree val, x: Z, v: val, tb: tree val, b: val, p: val
  PRE  [ _t OF (tptr (tptr (Tstruct _tree noattr)))]
    PROP(Int.min_signed <= x <= Int.max_signed; tc_val (tptr Tvoid) v)
    LOCAL(temp _t b)
    SEP (data_at Tsh (tptr t_struct_tree) p b;
         field_at Tsh t_struct_tree [StructField _key] (Vint (Int.repr x)) p;
         field_at Tsh t_struct_tree [StructField _value] v p;
         treebox_rep ta (field_address t_struct_tree [StructField _left] p);
         treebox_rep tb (field_address t_struct_tree [StructField _right] p))
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (pushdown_left ta tb) b).

Definition delete_spec :=
 DECLARE _delete
  WITH b: val, x: Z, t: tree val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint]
    PROP( Int.min_signed <= x <= Int.max_signed)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)))
    SEP (treebox_rep t b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (delete x t) b).
*)
Definition Gprog : funspecs :=
    ltac:(with_library prog [
    mallocN_spec; freeN_spec;
    insert_spec; lookup_spec(*;
    turn_left_spec; pushdown_left_spec; delete_spec*)
  ]).

Lemma tree_rep_saturate_local:
   forall t p, tree_rep t p |-- !! is_pointer_or_null p.
Proof.
destruct t; simpl; intros.
entailer!.
entailer!.
Qed.

Hint Resolve tree_rep_saturate_local: saturate_local.

Lemma tree_rep_valid_pointer:
  forall t p, tree_rep t p |-- valid_pointer p.
Proof.
intros.
destruct t; simpl; normalize; auto with valid_pointer.
rewrite !sepcon_assoc.
apply sepcon_valid_pointer1.
apply field_at_valid_ptr0; auto. simpl;  computable.
Qed.
Hint Resolve tree_rep_valid_pointer: valid_pointer.

Lemma treebox_rep_saturate_local:
   forall t b, treebox_rep t b |-- !! field_compatible (tptr t_struct_tree) [] b.
Proof.
intros.
unfold treebox_rep.
destruct t;
Intros p.
entailer!.
entailer!.
Qed.
Hint Resolve treebox_rep_saturate_local: saturate_local.

Definition insert_inv (p0: val) (t0: tree val) (x: Z) (v: val): environ -> mpred :=
  EX p: val, EX t: tree val,
  PROP()
  LOCAL(temp _p p; temp _x (Vint (Int.repr x));   temp _value v)
  SEP(treebox_rep t p;  (treebox_rep (insert x v t) p -* treebox_rep (insert x v t0) p0)).
(*
Lemma ramify_PPQQ {A: Type} {NA: NatDed A} {SA: SepLog A} {CA: ClassicalSep A}: forall P Q,
  P |-- P * (Q -* Q).
Proof.
  intros.
  apply RAMIF_PLAIN.solve with emp.
  + rewrite sepcon_emp; auto.
  + rewrite emp_sepcon; auto.
Qed.
*)
Lemma tree_rep_nullval: forall t,
  tree_rep t nullval |-- !! (t = E).
Proof.
  intros.
  destruct t; [entailer! |].
  simpl tree_rep.
  entailer!.
Qed.
Hint Resolve tree_rep_nullval: saturate_local.

Lemma is_pointer_or_null_force_val_sem_cast_neutral: forall p,
  is_pointer_or_null p -> force_val (sem_cast_neutral p) = p.
Proof.
  intros.
  destruct p; try contradiction; reflexivity.
Qed.

Lemma treebox_rep_leaf: forall x p b (v: val),
  is_pointer_or_null v ->
  Int.min_signed <= x <= Int.max_signed ->
  field_at Tsh t_struct_tree [] (Vint (Int.repr x), (v, (nullval, nullval))) p *
  field_at Tsh (tptr t_struct_tree) [] p b |-- treebox_rep (T E x v E) b.
Proof.
  intros.
  unfold treebox_rep, tree_rep. Exists p nullval nullval.
  unfold_field_at 1%nat.
  entailer!.
  rewrite !field_at_data_at.
  entailer!.
Qed.
(*
Lemma bst_left_entail: forall (t1 t1' t2: tree val) k (v p1 p2 p b: val),
  Int.min_signed <= k <= Int.max_signed ->
  is_pointer_or_null v ->
  data_at Tsh (tptr t_struct_tree) p b *
  data_at Tsh t_struct_tree (Vint (Int.repr k), (v, (p1, p2))) p *
  tree_rep t1 p1 * tree_rep t2 p2
  |-- treebox_rep t1 (field_address t_struct_tree [StructField _left] p) *
       (treebox_rep t1'
         (field_address t_struct_tree [StructField _left] p) -*
        treebox_rep (T t1' k v t2) b).
Proof.
  intros.
  unfold_data_at 2%nat.
  rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
  unfold treebox_rep at 1. Exists p1. cancel.

  rewrite <- wand_sepcon_adjoint.
  clear p1.
  unfold treebox_rep.
  Exists p.
  simpl.
  Intros p1.
  Exists p1 p2.
  entailer!.
  unfold_data_at 2%nat.
  rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
  cancel.
Qed.

Lemma bst_right_entail: forall (t1 t2 t2': tree val) k (v p1 p2 p b: val),
  Int.min_signed <= k <= Int.max_signed ->
  is_pointer_or_null v ->
  data_at Tsh (tptr t_struct_tree) p b *
  data_at Tsh t_struct_tree (Vint (Int.repr k), (v, (p1, p2))) p *
  tree_rep t1 p1 * tree_rep t2 p2
  |-- treebox_rep t2 (field_address t_struct_tree [StructField _right] p) *
       (treebox_rep t2'
         (field_address t_struct_tree [StructField _right] p) -*
        treebox_rep (T t1 k v t2') b).
Proof.
  intros.
  unfold_data_at 2%nat.
  rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
  unfold treebox_rep at 1. Exists p2. cancel.

  rewrite <- wand_sepcon_adjoint.
  clear p2.
  unfold treebox_rep.
  Exists p.
  simpl.
  Intros p2.
  Exists p1 p2.
  entailer!.
  unfold_data_at 2%nat.
  rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
  cancel.
Qed.

Lemma modus_ponens_wand' {A}{ND: NatDed A}{SL: SepLog A}:
  forall P Q R: A, P |-- Q -> P * (Q -* R) |-- R.
Proof.
  intros.
  eapply derives_trans; [| apply modus_ponens_wand].
  apply sepcon_derives; [| apply derives_refl].
  auto.
Qed.
*)
Lemma if_trueb: forall {A: Type} b (a1 a2: A), b = true -> (if b then a1 else a2) = a1.
Proof. intros; subst; auto. Qed.

Lemma if_falseb: forall {A: Type} b (a1 a2: A), b = false -> (if b then a1 else a2) = a2.
Proof. intros; subst; auto. Qed.

Ltac simpl_compb := first [ rewrite if_trueb by (apply Z.ltb_lt; omega)
                          | rewrite if_falseb by (apply Z.ltb_ge; omega)].
Opaque treebox_rep.

Lemma body_insert: semax_body Vprog Gprog f_insert insert_spec.
Proof.
  start_function.
  eapply semax_pre; [
    | apply (semax_loop _ (insert_inv p0 t0 x v) (insert_inv p0 t0 x v) )].
  * (* Precondition *)
    unfold insert_inv.
    Exists p0 t0.
    entailer!.
    cancel_wand.
  * (* Loop body *)
    unfold insert_inv.
    Intros p t.
    forward. (* Sskip *)
    rewrite treebox_rep_spec at 1.
    Intros q.
    forward. (* q = * p; *)
    forward_if.
    + (* then clause *)
      subst q.
      forward_call (sizeof t_struct_tree).
        1: simpl; rep_omega.
      Intros q.
      rewrite memory_block_data_at_ by auto.
      forward. (* q->key=x; *)
      simpl.
      forward. (* q->value=value; *)
      forward. (* q->left=NULL; *)
      forward. (* q->right=NULL; *)
      assert_PROP (t = (@E _)).
        1: entailer!.
      subst t. simpl tree_rep. rewrite !prop_true_andp by auto.
      rewrite is_pointer_or_null_force_val_sem_cast_neutral by auto.
      forward. (* * p = q; *)
      forward. (* return; *)
      fold (data_at Tsh t_struct_tree).
      sep_apply (treebox_rep_leaf x q p v); auto.
      apply_wand_frame_elim; cancel.
    + (* else clause *)
      destruct t.
        { simpl tree_rep. normalize. }
      simpl tree_rep.
      Intros.
      forward. (* y=q->key; *)
      forward_if; [ | forward_if ].
      - (* Inner if, then clause: x<k *)
        forward. (* t=&q->left *)
        unfold insert_inv.
        Exists (offset_val 8 q) t1.
        entailer!.
        simpl_compb.
        replace (offset_val 8 q)
          with (field_address t_struct_tree [StructField _left] q)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        apply_wand_frame_elim. cancel.
        apply RAMIF_PLAIN.trans'.
        apply bst_left_entail; auto.
      - (* Inner if, second branch:  k<x *)
        forward. (* t=&p->right *)
        unfold insert_inv.
        Exists (offset_val 12 p1) t1_2.
        entailer!.
        simpl_compb; simpl_compb.
        (* TODO: SIMPLY THIS LINE *)
        replace (offset_val 12 p1)
          with (field_address t_struct_tree [StructField _right] p1)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        apply RAMIF_PLAIN.trans'.
        apply bst_right_entail; auto.
      - (* Inner if, third branch: x=k *)
        assert (x=k) by omega.
        subst x. clear H H1 H4.
        forward. (* p->value=value *)
        forward. (* return *)
        (* TODO: SIMPLY THIS LINE *)
        simpl_compb.
        simpl_compb.
        apply modus_ponens_wand'.
        unfold treebox_rep. Exists p1.
        simpl tree_rep. Exists pa pb. entailer!.
  * (* After the loop *)
    forward.
    unfold loop2_ret_assert. apply andp_left2. normalize.
Qed.

Definition lookup_inv (b0 p0: val) (t0: tree val) (x: Z): environ -> mpred :=
  EX p: val, EX t: tree val,
  PROP(lookup nullval x t = lookup nullval x t0)
  LOCAL(temp _p p; temp _x (Vint (Int.repr x)))
  SEP(tree_rep t p;  (tree_rep t p -* tree_rep t0 p0)).

Lemma body_lookup: semax_body Vprog Gprog f_lookup lookup_spec.
Proof.
  start_function.
  unfold treebox_rep. Intros p.
  forward. (* p=*t; *)
  apply (semax_post_ret1 nil
          (data_at Tsh (tptr t_struct_tree) p b :: tree_rep t p :: nil)).
  1: intro HH; inversion HH.
  1: unfold treebox_rep; Exists p; entailer!.
  apply semax_frame''.
  forward_while (lookup_inv b p t x).
  * (* precondition implies loop invariant *)
    Exists p t. entailer!.
    apply -> wand_sepcon_adjoint. cancel.
  * (* type-check loop condition *)
    entailer!.
  * (* loop body preserves invariant *)
    destruct t0; unfold tree_rep at 1; fold tree_rep. normalize.
    Intros pa pb.
    forward.
    forward_if; [ | forward_if ].
    + (* then clause: x<y *)
      forward. (* p=p<-left *)
      Exists (pa,t0_1). unfold fst,snd.
      entailer!.
      - rewrite <- H0; simpl.
        simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply RAMIF_PLAIN.trans''.
        apply -> wand_sepcon_adjoint.
        Exists pa pb; entailer!.
    + (* else-then clause: y<x *)
      forward. (* p=p<-right *)
      Exists (pb,t0_2). unfold fst,snd.
      entailer!.
      - rewrite <- H0; simpl.
        simpl_compb; simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply RAMIF_PLAIN.trans''.
        apply -> wand_sepcon_adjoint.
        Exists pa pb; entailer!.
    + (* else-else clause: x=y *)
      assert (x=k) by omega. subst x. clear H H4 H5.
      forward. (* v=p->value *)
      forward. (* return v; *)
      unfold treebox_rep. unfold normal_ret_assert.
      entailer!.
      - rewrite <- H0. simpl.
        simpl_compb; simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply modus_ponens_wand'.
        Exists pa pb; entailer!.
  * (* after the loop *)
    forward. (* return NULL; *)
    entailer!.
    apply modus_ponens_wand.
Qed.

Lemma body_turn_left: semax_body Vprog Gprog f_turn_left turn_left_spec.
Proof.
  start_function.
  simpl.
  Intros pb pc.
  forward. (* mid=r->left *)
  forward. (* l->right=mid *)
  assert_PROP (is_pointer_or_null pb) by entailer!.
  rewrite is_pointer_or_null_force_val_sem_cast_neutral by auto.
  forward. (* r->left=l *)
  assert_PROP (is_pointer_or_null l) by entailer!.
  rewrite is_pointer_or_null_force_val_sem_cast_neutral by auto.
  forward. (* _l = r *)
  assert_PROP (is_pointer_or_null r) by entailer!.
  rewrite is_pointer_or_null_force_val_sem_cast_neutral by auto.
  Opaque tree_rep. forward. Transparent tree_rep. (* return *)
  (* TODO: simplify the following proof *)
  Exists pc.
  entailer!.
  simpl.
  Exists pa pb.
  entailer!.
Qed.

Definition pushdown_left_inv (b_res: val) (t_res: tree val): environ -> mpred :=
  EX b: val, EX ta: tree val, EX x: Z, EX v: val, EX tb: tree val,
  PROP  ()
  LOCAL (temp _t b)
  SEP   (treebox_rep (T ta x v tb) b;
         (treebox_rep (pushdown_left ta tb) b -* treebox_rep t_res b_res)).

Lemma body_pushdown_left: semax_body Vprog Gprog f_pushdown_left pushdown_left_spec.
Proof.
  start_function.
  eapply semax_pre; [
    | apply (semax_loop _ (pushdown_left_inv b (pushdown_left ta tb))
                         (pushdown_left_inv b (pushdown_left ta tb)))].
  + (* Precondition *)
    unfold pushdown_left_inv.
    Exists b ta x v tb.
    entailer!.
    eapply derives_trans; [| apply ramify_PPQQ].
    rewrite (treebox_rep_spec (T ta x v tb)).
    Exists p.
    entailer!.
  + (* Loop body *)
    unfold pushdown_left_inv.
    clear x v H H0.
    Intros b0 ta0 x vx tbc0.
    unfold treebox_rep at 1.
    Intros p0.
    forward. (* skip *)
    forward. (* p = *t; *)
      (* TODO entailer: The following should be solve automatically. satuate local does not work *)
      1: rewrite (add_andp _ _ (tree_rep_saturate_local _ _)); entailer!.
    simpl tree_rep.
    Intros pa pbc.
    forward. (* q = p->right *)
    forward_if.
    - subst.
      assert_PROP (tbc0 = (@E _)).
        1: entailer!.
      subst.
      forward. (* q=p->left *)
      forward. (* *t=q *)
      forward_call (p0, sizeof t_struct_tree). (* freeN(p, sizeof ( *p )); *)
      {
        entailer!.
        rewrite memory_block_data_at_ by auto.
        cancel.
      }
      forward. (* return *)
      apply modus_ponens_wand'.
      Exists pa.
      cancel.
    - destruct tbc0 as [| tb0 y vy tc0].
        { simpl tree_rep. normalize. }
      forward_call (ta0, x, vx, tb0, y, vy, tc0, b0, p0, pa, pbc). (* turn_left(t, p, q); *)
      Intros pc.
      forward. (* t = &q->left; *)
      Exists (field_address t_struct_tree [StructField _left] pbc) ta0 x vx tb0.
      (* TODO entailer: not to simply too much in entailer? *)
      Opaque tree_rep. entailer!. Transparent tree_rep.
        (* TODO: simplify this line *)
      apply RAMIF_PLAIN.trans'.
      apply bst_left_entail; auto.
  + forward. (* Sskip *)
    apply andp_left2.
    unfold loop2_ret_assert. rewrite prop_true_andp by auto.
    auto.
Qed.


(*******************************************************************************

Title: Auxiliary.v
Authors: Jeremy Avigad, Chris Kapulkin, Peter LeFanu Lumsdaine
Date: 1 March 2013

This file contains lemmas that are required as background in the
Fibration Categories project, but are not supplied by the HoTT
library.

*******************************************************************************)

Require Import HoTT.

Require Export FunextAxiom.

Open Scope path.

Monomorphic Definition UU := Type.

Notation pr1 := projT1.
Notation pr2 := projT2.

Arguments pr1 {_ _} _.
Arguments pr2 {_ _} _.

(* TODO (mid): possible improvements now that we’re over the new library.

- increase usage of the [moveL_Pm] family;

- use [apply (concat H)] and [apply (concatR H)], rather than e.g. [path_via' p. apply H.]

- use [whiskerL], [whiskerR] rather than [apply (ap (concat p))] and [apply (ap (fun q => q @ p))].

*)

(*******************************************************************************

Paths.

*******************************************************************************)

Section Paths.

(* Convenient for the frequent idiom [apply (concat (concat_pp_p))] and variants. *)
Global Arguments concat_pp_p {_ _ _ _ _ _ _ _}.
Global Arguments concat_p_pp {_ _ _ _ _ _ _ _}.

(* The Paulin-Mohring elimination principle for equalities is
very useful, but asymmetric. This is its left-handed counterpart. *)
Definition id_opp_elim {X:Type} (x:X)
  {P:forall (y:X) (p:y=x), Type}
: (P x 1)
  -> forall (y:X) (p:y=x), P y p.
Proof.
  intros P1 y p. destruct p. assumption.
Defined.
(* Note: this proof, while clean, is proof-theoretically overkill — it requires a universe, since inspecting it carefully, it Id-eliminates into a Pi-type with large domain (since P has to be generalized).  With a little more work, it can be proved more economically, using just pure M-L TT. *)

Definition path_space (A : Type) := { x:A & { y:A & x = y }}.

(* Useful mainly for the idiom [apply (concatR (expression))]. *)
Definition concatR {A : Type} {x y z : A}  (q : y = z) (p : x = y)
  := concat p q.

End Paths.

(* A variant of [path_via] that does not attempt to do anything clever. *)
Ltac path_via' mid :=
  apply @concat with (y := mid).

(*******************************************************************************

Lemmas about paths in types of the form [{a : A & {b : B & C a b}}].

*******************************************************************************)

Section TriplePaths.

Lemma triple_path  {A : Type} {B : Type} (C : A -> B -> Type)
  (u v : {a : A & {b : B & C a b}})
  (p : (pr1 u) = (pr1 v))
  (q : (pr1 (pr2 u)) = (pr1 (pr2 v)))
  (r : (transport (fun x => C x (pr1 (pr2 v))) p
         (transport (C (pr1 u)) q (pr2 (pr2 u))))
       = (pr2 (pr2 v)))
: u = v.
Proof.
  destruct u as [u1 [u2 u3]], v as [v1 [v2 v3]]. simpl in * |- *.
  destruct p; destruct q; destruct r. simpl. exact 1.
Defined.

Lemma pr1_triple_path  {A : Type} {B : Type} (C : A -> B -> Type)
  (u v : {a : A & {b : B & C a b}})
  (p : (pr1 u) = (pr1 v))
  (q : (pr1 (pr2 u)) = (pr1 (pr2 v)))
  (r : (transport (fun x => C x (pr1 (pr2 v))) p
         (transport (C (pr1 u)) q (pr2 (pr2 u))))
       = (pr2 (pr2 v)))
: ap pr1 (triple_path C u v p q r) = p.
Proof.
  destruct u as [u1 [u2 u3]], v as [v1 [v2 v3]]. simpl in * |- *.
  destruct p. destruct q. destruct r. simpl. exact 1.
Defined.

Lemma pr2_triple_path  {A : Type} {B : Type} (C : A -> B -> Type)
  (u v : {a : A & {b : B & C a b}})
  (p : (pr1 u) = (pr1 v))
  (q : (pr1 (pr2 u)) = (pr1 (pr2 v)))
  (r : (transport (fun x => C x (pr1 (pr2 v))) p
         (transport (C (pr1 u)) q (pr2 (pr2 u))))
       = (pr2 (pr2 v)))
: ap (fun xyz => pr1 (pr2 xyz)) (triple_path C u v p q r) = q.
Proof.
  destruct u as [u1 [u2 u3]], v as [v1 [v2 v3]]. simpl in * |- *.
  destruct p. destruct q. destruct r. simpl. exact 1.
Defined.

(* TODO (low): triple_path_pr3.  (The tricky bit is typing the statement.) *)

End TriplePaths.

(*******************************************************************************

Equivalences.

*******************************************************************************)

(* TODO (low): move this declarations into the section itself, once weird bug is sorted out. *)
Arguments BuildEquiv [A B f] _ : rename.

Section Equivs.

(* TODO (high): move to library. *)
Global Arguments equiv_inv [A B] f {_} x.

(* TODO (low): consider; possibly move to library. *)
Global Arguments equiv_fun [A B] _ _.
Global Arguments equiv_isequiv [A B] e.
Global Arguments isequiv_adjointify [A B f] _ _ _.

(* TODO (med): Unnecessary here; but probably move to library. *)
Global Arguments isequiv_ap [A B] f {_} x y.

(* TODO (high): move to library. *)
Global Arguments isequiv_postcompose {_} A [B C] f {_}.
Global Arguments isequiv_precompose {_} [A B] C f {_}.

(*
TODO (low): also consider/try changing arguments as follows:
Arguments cancelL_isequiv [B C] g {ge} [A] f {fge} : rename.
Arguments cancelR_isequiv [A B] f {fe} [C] g {gfe}.

Also: consider changing the order of their arguments; and *definitely* try making them not instances.
*)

(* Compare to [map_equiv_o_inverse] in old library *)
(* TODO (low): actually, this is an instance of homotopy-naturality, [concat_Ap].  Can it be replaced by that? *)
Lemma ap_inverse_o_equiv {A B : Type} (e : A <~> B)
  {x y : B} (p : x = y)
: ap e (ap (e ^-1) p)
  = (eisretr e x @ p) @ (eisretr e y)^.
Proof.
  destruct p. simpl.
  path_via (eisretr e x @ (eisretr e x)^).
    symmetry. apply concat_pV.
  apply whiskerR, inverse, concat_p1.
Defined.

(* Every type [P] is equivalent to the function type [1 -> P]. *)
Lemma well_pointedness (P : Type) : P <~> (Unit -> P).
Proof.
  exists (fun x _ => x).
  apply (isequiv_adjointify (fun f => f tt)).
  intros f. apply path_forall. intros []. exact 1.
  intros x. exact 1.
Defined.

End Equivs.

(*******************************************************************************

HLevels.

*******************************************************************************)

Section HLevels.

(* TODO (low): move to HoTT? *)
Record HSet := {
  hset_carrier :> Type;
  ishset_hset : IsHSet hset_carrier }.

End HLevels.

(*******************************************************************************

Functional Extensionality.

*******************************************************************************)

Section Funext.

Global Arguments path_forall {_} [_ _ _ _] _.

(** [path_forall] commutes with [inverse].  (This follows purely formally from the fact that its inverse [apD10] does.) *)
Definition path_forall_V {X : Type} {P : X -> Type} {f g : forall x, P x}
  (H : forall x, f x = g x)
: path_forall (fun x => (H x)^) = (path_forall H)^.
Proof.
  path_via' (path_forall (fun x => (apD10 (path_forall H) x)^)).
    apply ap, (@ap _ _ (fun h x => (h x)^)). apply inverse, eisretr.
  path_via' (path_forall (apD10 (path_forall H)^)).
    apply ap, inverse. apply path_forall; intros x. apply apD10_V.
  apply eissect.
Defined.

(** Note: this differs from the library function [apD10_path_forall] essentially only in having [pointwise_paths] unfolded in its type.  However, that is enough to make working with it more convenient — in particular, [rewrite] often works with this where it fails with [apD10_path_forall]. *)
Definition apD10_path_forall' {A : Type} {P : A -> Type}
  {f g : forall x, P x} (h : f == g) (x:A)
  : apD10 (path_forall h) x = h x
:= (apD10_path_forall _ _ h x).
(*TODO (high): consistentize the various ways of using [eisretr], [apD10_path_forall], etc. *)

End Funext.

(*******************************************************************************

Various things that don’t have a clear home.

*******************************************************************************)

Section Varia.

(* TODO (low): move to live with hfibers?  Where do they live? *)
Definition hfiber_incl {X Y:Type} (f:X -> Y) (y:Y) : hfiber f y -> X
:= pr1.

Fixpoint iterate {A:Type} (f:A->A) (n:nat)
:= fun x => match n with O => x | S n' => f (iterate f  n' x) end.

Fixpoint iterate_dep {A:Type} (f:A->A) (B:A->Type)
  (g : forall a:A, B a -> B (f a))
  (n:nat)
:= fun (x:A) (y:B x) => match n return (B (iterate f n x)) with
     | O => y
     | S n' => g _ (iterate_dep _ _ g n' x y) end.

Lemma moveR_I {AA BB : Type} (ff : AA -> BB) {H : IsEquiv ff} (x : AA) (y : BB)
  : y = ff x -> ff ^-1 y = x.
Proof.
  intros H_eq.  path_via (ff ^-1 (ff x)).
  apply ap, H_eq.  apply eissect.
Defined.

(* Compare [equiv_sigma_contr] in library. *)
Lemma isequiv_sigma_contr {X:Type} {Y:X->Type}
: (forall x:X, Contr (Y x)) -> IsEquiv (@projT1 X Y).
Proof.
  intros H. exact (equiv_isequiv (equiv_sigma_contr _)).
Defined.

Lemma isequiv_hfiber_incl_over_hprop {Y X : Type} (X_hprop : IsHProp X)
  (f : Y -> X) (x:X)
: IsEquiv (hfiber_incl f x).
Proof.
  refine (isequiv_sigma_contr _).
Defined.

End Varia.

Notation "A /\ B" := (A * B).
Notation "A <-> B" := ((A -> B) /\ (B -> A)).

(*
Local Variables:
coq-prog-name: "hoqtop"
End:
*)


Require Import trees.

Set Implicit Arguments.

Definition find_code :=
  FunDef "find" ["v"; "t"]
  (SIf ("t"=0)
    (SReturn false)
    (SReturn (("v"="t"->>"val")
             || ECall "find" [EVar "v"; "t"->>"left"]
             || ECall "find" [EVar "v"; "t"->>"right"])))%code.

Fixpoint contains_bool v t :=
  match t with
    | Leaf => false
    | Node v' l r =>
         orb (Z.eqb v v') (orb (contains_bool v l) (contains_bool v r))
  end.
Inductive find_spec : Spec kcfg  :=
  find_claim : forall v H t p, heap_gen_fun find_spec
  find_code [Int v;Int p] (asP H (rep_tree t p))
  (fun r => constraint (r = KBool (contains_bool v t)) :* litP H)%pattern.

Lemma find_proof : sound kstep find_spec.
Proof. tree_solver;destruct (contains_bool v t1) eqn: ?;tree_run. Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq paths fintype.

(*****************************************************************************)
(* This file develops the theory of transitive closure in a finType T.       *)
(* For e : rel T and f : T -> T we define:                                   *)
(*                                                                           *)
(* dfs e n a x    == the list of points traversed by a depth-first search of *)
(*                   the graph of e, at depth n, starting from x, and        *)
(*                   prepended to a                                          *)
(* connect e      == the transitive closure of e (computed by dfs)           *)
(* connect_sym e  <=> connect e is symmetric, hence an equivalence relation  *)
(* root e x       == pick a representative of connect e x, the component of  *)
(*                   x in the transitive closure of e                        *)
(* roots e        == the codomain predicate of root e                        *)
(* n_comp e       == number of components of connect e, i.e., the number of  *)
(*                   equivalence classes of connect e if connect_sym e holds *)
(* closed e a     == the predicate a is e-invariant                          *)
(* closure e a    == closure under e of a (the image of a under connect e)   *)
(* rel_adjunction h e e' a                                                   *)
(*                <=> in the e-closed domain a, h is the left part of an     *)
(*                    adjunction from e to another relation e'               *)
(* fconnect f     == connect (frel f) == connected under f iteration         *)
(* froot f x      == root (frel f) x == root of the orbit of x under f       *)
(* froots f       == roots (frel f) == orbit representatives for f           *)
(* orbit f x      == lists the f orbit of x                                  *)
(* findex f x y   == index of y in the f-orbit of x                          *)
(* order f x      == size (cardinal) of the orbit of x under f               *)
(* order_set f n  == elements of f-order n                                   *)
(* finv f         == the inverse of f, if f is a permutation; specifically,  *)
(*                   finv f x == iter (order x).-1 f x                       *)
(* fcard f        == number of orbits of f                                   *)
(* fclosed f a    == closed under iteration of f                             *)
(* fclosure f a   == closure under f iteration                               *)
(* fun_adjunction == rel_adjunction (frel f)                                 *)
(*****************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* Decidable connectivity in finite types.                                  *)

Section Connect.

Variables (T : finType) (e : rel T).

Fixpoint dfs (n : nat) (a : seq T) (x : T) {struct n} :=
  if n is n'.+1 then
    if x \in a then a else foldl (dfs n') (x :: a) (enum (e x))
  else a.

Definition connect : rel T := fun x y => y \in dfs #|T| [::] x.

Lemma subset_dfs : forall n (a b : seq T), a \subset foldl (dfs n) a b.
Proof.
elim=> [|n IHn] a b; first by elim: b => /=.
elim: b a => [|x b IHb] a //=; apply: subset_trans (IHb _) => /=.
case: (x \in a) => //=; apply: subset_trans (IHn _ _).
apply/subsetP=> y ay; exact: mem_behead.
Qed.

Inductive dfs_path x y (a : seq T) : Prop :=
  DfsPath p of path e x p & y = last x p & [disjoint x :: p & a].

Lemma dfsP : forall n x y (a : seq T),
  #|T| <= #|a| + n -> y \notin a -> reflect (dfs_path x y a) (y \in dfs n a x).
Proof.
elim=> [|n IHn] x y a Hn Hy /=.
  case/idPn: (max_card (predU1 y (mem a))) => /=.
  by rewrite -ltnNge cardU1 /= (negPf Hy) /= addSn addnC.
case Hx: (x \in a).
  rewrite (negPf Hy); right=> [] [p Hp Ep Hpa].
  by rewrite disjoint_has /= Hx in Hpa.
move Da': (x :: a) => a'; case Hya': (y \in a').
  rewrite (subsetP (subset_dfs n _ _) _ Hya'); left.
  exists (Nil T); repeat split; last by rewrite disjoint_has /= Hx.
  by rewrite -Da' in_cons in Hya'; case/predU1P: Hya' Hy => //= ->.
have Hna': #|T| <= #|a'| + n by rewrite -Da' /= cardU1 Hx /= add1n addSnnS.
move Db: (enum _) => b.
suffices IHb:  reflect (exists2 x', x' \in b & dfs_path x' y a')
                       (y \in foldl (dfs n) a' b).
- apply: {IHn IHb}(iffP IHb) => [[x' Hx' [p Hp Ep Hpa]] | [p Hp Ep Hpa]].
    rewrite -Da' /= disjoint_sym disjointU1 in Hpa.
    move/andP: Hpa => [Hpx Hpa].
    exists (x' :: p); try by rewrite //= disjointU1 Hx disjoint_sym.
    by rewrite -Db mem_enum in Hx'; rewrite /= [_ x']Hx'.
  move/shortenP: Hp Ep => /= [[|y' p']] /= Hp' Up' Hp'p Dy.
    by rewrite -Da' Dy /= mem_head in Hya'.
  move/andP: Hp' => [Hxy' Hp']; move/andP: Up' => [Hp'x' _].
  exists y'; [ by rewrite -Db mem_enum | exists p'; auto ].
  rewrite disjoint_sym -Da' /= disjoint_cons Hp'x' /= disjoint_sym.
  apply: disjoint_trans Hpa; apply/subsetP=> z ?; apply: predU1r; exact: Hp'p.
elim: b a' Hya' Hna' {a x Da' Db Hy Hn Hx} => [|x b IHb] a Hy Hn /=.
  by rewrite Hy; right; case.
have Ha := subset_dfs n a [ :: x ]; simpl in Ha.
case Hdfs_y: (y \in dfs n a x).
  rewrite (subsetP (subset_dfs n _ b) _ Hdfs_y); left.
  exists x; [ exact: mem_head | apply: (IHn _); auto; exact (negbT Hy) ].
have Hca := subset_leq_card Ha; rewrite -(leq_add2r n) in Hca.
apply: {IHb Hca}(iffP (IHb _ Hdfs_y (leq_trans Hn Hca))).
  move=> [x' Hx' [p Hp Ep Hpa]]; rewrite disjoint_sym in Hpa.
  exists x'; [ exact: predU1r | exists p => // ].
  rewrite disjoint_sym; exact (disjoint_trans Ha Hpa).
move=> [x' Hx' [p Hp Ep Hpa]].
case Hpa': [disjoint x' :: p & dfs n a x].
  case/orP: Hx' => [Dx'|Hx']; last by exists x'; auto; exists p.
  move: (pred0P Hpa x'); rewrite /= mem_head /= => Hax'.
  case/idP: (pred0P Hpa' x'); rewrite /= mem_head //=.
  apply/(IHn _ _ _ Hn (negbT Hax')).
  exists (Nil T)=> //; first by move/eqP: Dx'.
  by rewrite disjoint_has /= -(eqP Dx') Hax'.
case/(IHn _ _ _ Hn (negbT Hy)): Hdfs_y.
case/pred0Pn: Hpa' => [x'' H]; case/andP: H => [ /= Hpx'' Hdfs_x''].
have Hax'' := pred0P Hpa x''; rewrite /= Hpx'' in Hax''.
case/(IHn _ _ _ Hn (negbT Hax'')): Hdfs_x'' => [q Hq Eq Hqa].
case/splitPl: {p}Hpx'' Hp Ep Hpa => [p1 p2 Ep1].
rewrite path_cat -cat_cons disjoint_cat last_cat Ep1.
move/andP=> [Hp1 Hp2] Ep2; case/andP=> [Hp1a Hp2a]; exists (cat q p2).
- by rewrite path_cat Hq -Eq.
- by rewrite last_cat -Eq.
by rewrite -cat_cons disjoint_cat Hqa.
Qed.

Lemma connectP : forall x y,
  reflect (exists2 p, path e x p & y = last x p) (connect x y).
Proof.
move=> x y; apply: (iffP (@dfsP _ x _ nil _ _)) => // [|[p]|[p]].
- by rewrite card0 leqnn.
- by exists p.
by exists p; rewrite // disjoint_sym disjoint_has.
Qed.

Lemma connect_trans : forall x1 x2 x3,
  connect x1 x2 -> connect x2 x3 -> connect x1 x3.
Proof.
move=> x1 x2 x3; move/connectP=> [p1 Hp1 ->]; move/connectP=> [p2 Hp2 ->].
by apply/connectP; exists (p1 ++ p2); rewrite ?path_cat ?Hp1 ?last_cat.
Qed.

Lemma connect0 : forall x, connect x x.
Proof. by move=> x; apply/connectP; exists (Nil T). Qed.

Lemma eq_connect0 : forall x y : T, x = y -> connect x y.
Proof. move=> x y ->; exact: connect0. Qed.

Lemma connect1 : forall x y, e x y -> connect x y.
Proof. by move=> x y Hxy; apply/connectP; exists [:: y]; rewrite /= ?Hxy. Qed.

Lemma path_connect : forall x p, path e x p ->
  subpred (mem (x :: p)) (connect x).
Proof.
move=> x p Hp x' Hx'; apply/connectP; case/splitPl: p / Hx' Hp => [p p' Ep].
by rewrite path_cat; case/andP; exists p.
Qed.

Definition root x := if pick (connect x) is Some y then y else x.

Definition roots : pred T := fun x => root x == x.

Definition n_comp a := #|predI roots a|.

Lemma connect_root : forall x, connect x (root x).
Proof.
by move=> x; rewrite /root; case: (pickP (connect x)); rewrite // connect0.
Qed.

Definition connect_sym := forall x y, connect x y = connect y x.

Lemma same_connect : connect_sym -> forall x y,
  connect x y -> connect x =1 connect y.
Proof.
by move=> He x y Hxy z; apply/idP/idP; apply: connect_trans; rewrite // He.
Qed.

Lemma same_connect_r : connect_sym -> forall x y,
  connect x y -> forall z, connect z x = connect z y.
Proof. move=> He x y Hxy z; rewrite !(He z); exact: same_connect. Qed.

Lemma rootP : forall x y,
  connect_sym -> reflect (root x = root y) (connect x y).
Proof.
move=> x y He; apply introP=> [Hxy|Hxy Hr].
  rewrite /root -(eq_pick (same_connect He Hxy)).
  by case: (pickP (connect x)) => [H|Hx] //; case/idP: (Hx y).
case/negP: Hxy; apply: (connect_trans (connect_root x)).
rewrite Hr He; apply connect_root.
Qed.

Lemma root_root : connect_sym -> forall x, root (root x) = root x.
Proof. move=> He x; symmetry; apply/(rootP _ _ He); exact: connect_root. Qed.

Lemma roots_root : connect_sym -> forall x, roots (root x).
Proof. move=> *; apply/eqP; exact: root_root. Qed.

Lemma root_connect :
  connect_sym -> forall x y, (root x == root y) = connect x y.
Proof. move=> He *; exact: sameP eqP (rootP _ _ He). Qed.

End Connect.

Prenex Implicits connect root roots n_comp.

Implicit Arguments connectP [T e x y].
Implicit Arguments rootP [T e x y].
Prenex Implicits connectP rootP.

Notation fconnect f := (connect (frel f)).
Notation froot f := (root (frel f)).
Notation froots f := (roots (frel f)).
Notation fcard f := (n_comp (frel f)).

Section EqConnect.

Variable T : finType.

Lemma connect_sub : forall e e' : rel T,
  subrel e (connect e') -> subrel (connect e) (connect e').
Proof.
move=> e e' He x y; move/connectP=> [p Hp ->] {y}.
elim: p x Hp => [|y p Hrec] x => [_|/=]; first exact: connect0.
move/andP=> [Hx Hp]; exact (connect_trans (He _ _ Hx) (Hrec _ Hp)).
Qed.

Lemma relU_sym : forall e e' : rel T,
  connect_sym e -> connect_sym e' -> connect_sym (relU e e').
Proof.
move=> e e' He He'.
suff Hsub: forall x y, connect (relU e e') x y -> connect (relU e e') y x.
  move=> x y; apply/idP/idP; auto.
move=> x y; move/connectP=> [p Hp ->] {y}.
elim: p x Hp => [|y p Hrec] x /=; first by rewrite connect0.
case/andP=> [Hxp Hp]; apply: {Hrec Hp}(connect_trans (Hrec _ Hp)).
case/orP: Hxp; move/(@connect1 T); rewrite 1?He 1?He';
 apply: connect_sub y x => [x y Hy]; apply connect1; apply/orP; auto.
Qed.

Lemma eq_connect : forall e e' : rel T, e =2 e' -> connect e =2 connect e'.
Proof.
by move=> e e' Ee x y; apply/connectP/connectP=> [] [p Hp Ep]; exists p;
  move: Hp; rewrite // (eq_path Ee).
Qed.

Lemma eq_n_comp : forall e e' : rel T,
  connect e =2 connect e' -> n_comp e =1 n_comp e'.
Proof.
move=> e e' Hee' a; apply: eq_card => x.
by rewrite !inE /= /roots /root /= (eq_pick (Hee' x)).
Qed.

Lemma eq_n_comp_r : forall a a' : pred T, a =1 a' ->
  forall e, n_comp e a = n_comp e a'.
Proof. by move=> a a' Ha e; apply: eq_card => x; rewrite inE /= Ha. Qed.

Lemma n_compC : forall a e, n_comp e T = n_comp e a + n_comp e (predC a).
Proof.
move=> a e; rewrite /n_comp; rewrite -(cardID a).
by congr (_ + _); apply: eq_card => x; rewrite !inE !andbT andbC.
Qed.

Lemma eq_root : forall e1 e2 : rel T, e1 =2 e2 -> root e1 =1 root e2.
Proof. by move=> e1 e2 He x; rewrite /root (eq_pick (eq_connect He x)). Qed.

Lemma eq_roots : forall e1 e2 : rel T, e1 =2 e2 -> roots e1 =1 roots e2.
Proof. by move=> e1 e2 He x; rewrite /roots (eq_root He). Qed.

End EqConnect.

Section Closure.

Variables (T : finType) (e : rel T).
Hypothesis He : connect_sym e.

Lemma same_connect_rev : connect e =2 connect (fun x y => e y x).
Proof.
suff Hrev: forall e',
    subrel (connect (fun x y : T => e' y x)) (fun x y => connect e' y x).
  move=> x y; rewrite He; apply/idP/idP => [Hyx|Hxy]; apply: Hrev; auto.
move=> e' x y; move/connectP=> [p Hp ->] {y}.
elim: p x Hp => [|y p Hrec] x /=; first by rewrite connect0.
move/andP=> [Hyx Hp]; exact (connect_trans (Hrec _ Hp) (connect1 Hyx)).
Qed.

Definition closed (a : pred T) := forall x y, e x y -> a x = a y.

Lemma intro_closed : forall a : pred T,
  (forall x y, e x y -> a x -> a y) -> closed a.
Proof.
move=> a Ha x y Hxy; apply/idP/idP; first by apply: Ha.
move/connectP: {Hxy}(etrans (He _ _) (connect1 Hxy)) => [p Hp ->].
by elim: p y Hp => [|z p Hrec] y //=; move/andP=> [Hxp Hp]; eauto.
Qed.

Lemma closed_connect : forall a, closed a ->
  forall x y, connect e x y -> a x = a y.
Proof.
move=> a Ha x y; move/connectP=> [p Hp ->] {y}.
elim: p x Hp => [|y p Hrec] x //=; move/andP=> [Hxp Hp].
rewrite (Ha _ _ Hxp); auto.
Qed.

Lemma connect_closed : forall x, closed (connect e x).
Proof. by move=> x y z Hyz; apply (same_connect_r He); apply connect1. Qed.

Lemma predC_closed : forall a, closed a -> closed (predC a).
Proof. by move=> a Ha x y Hxy; rewrite /= (Ha x y Hxy). Qed.

Definition closure (a : pred T) : pred T :=
  fun x => ~~ [disjoint connect e x & a].

Lemma closure_closed : forall a, closed (closure a).
Proof.
move=> a; apply intro_closed; move=> x y Hxy.
by rewrite /closure (eq_disjoint (same_connect He (connect1 Hxy))).
Qed.

Lemma subset_closure : forall a : pred T, a \subset (closure a).
Proof.
move=> a; apply/subsetP => x Hx; apply/pred0Pn.
by exists x; rewrite /= -topredE /= connect0.
Qed.

Lemma n_comp_closure2 : forall x y,
  n_comp e (closure (pred2 x y)) = (~~ connect e x y).+1.
Proof.
move=> x y; rewrite -(root_connect He) -card2.
apply: eq_card => z; apply/idP/idP.
  case/andP=> Hrz; case/pred0Pn=> z'; case/andP=> Hzz' Hxyz'.
  rewrite -(eqP Hrz) (rootP He Hzz').
  by case: (orP Hxyz'); move/eqP=> Dz'; rewrite !inE /= Dz' /= eqxx ?orbT.
case/orP; move/eqP=> ->; rewrite /= -topredE /= (roots_root He);
  apply/existsP; [exists x | exists y];
  by rewrite /= -!topredE /= eqxx ?orbT He connect_root.
Qed.

Lemma n_comp_connect : forall x, n_comp e (connect e x) = 1.
Proof.
move=> x; rewrite -(card1 (root e x)); apply: eq_card => [y].
apply/andP/eqP => [[Hy Hxy]|->]; first by rewrite (rootP He Hxy) (eqP Hy).
by rewrite (roots_root He) connect_root.
Qed.

End Closure.

Notation fclosed f := (closed (frel f)).
Notation fclosure f := (closure (frel f)).

Prenex Implicits closed closure.

Section Orbit.

Variables (T : finType) (f : T -> T).

Definition order x := #|fconnect f x|.

Definition orbit x := traject f x (order x).

Definition findex x y := index y (orbit x).

Definition finv x := iter (order x).-1 f x.

Lemma fconnect_iter : forall n x, fconnect f x (iter n f x).
Proof.
move=> n x; apply/connectP.
by exists (traject f (f x) n); [ exact: fpath_traject | rewrite last_traject ].
Qed.

Lemma fconnect1 : forall x, fconnect f x (f x).
Proof. exact (fconnect_iter 1). Qed.

Lemma fconnect_finv : forall x, fconnect f x (finv x).
Proof. move=> x; apply: fconnect_iter. Qed.

Lemma orderSpred : forall x, (order x).-1.+1 = order x.
Proof. by move=> x; rewrite /order (cardD1 x) [_ x _]connect0. Qed.

Lemma size_orbit : forall x : T, size (orbit x) = order x.
Proof. move=> x; apply: size_traject. Qed.

Lemma looping_order : forall x, looping f x (order x).
Proof.
move=> x; apply/idPn => [Ux]; rewrite -looping_uniq in Ux.
case/idP: (ltnn (order x)).
have:= card_uniqP Ux; rewrite size_traject => <-.
apply: subset_leq_card; apply/subsetP=> z.
move/trajectP=> [i _ ->]; apply: fconnect_iter.
Qed.

Lemma fconnect_orbit : forall x, fconnect f x =i orbit x.
Proof.
move=> x y; symmetry; apply/idP/idP.
  move/trajectP=> [i _ ->]; apply: fconnect_iter.
move/connectP=> [q' Hq' ->]; move/fpathP: Hq' => [m ->] {q'}.
rewrite last_traject; apply: loopingP; apply looping_order.
Qed.

Lemma orbit_uniq : forall x, uniq (orbit x).
Proof.
move=> x; rewrite /orbit -orderSpred looping_uniq.
apply/trajectP => [[i Hi Ei]]; set n := (order x).-1; case/idP: (ltnn n).
rewrite {1}/n orderSpred /order -(size_traject f x n).
apply: (leq_trans (subset_leq_card _) (card_size _)); apply/subsetP=> z.
rewrite fconnect_orbit; case/trajectP=> j Hj ->{z}; apply/trajectP.
rewrite -orderSpred -/n ltnS leq_eqVlt in Hj.
by case/predU1P: Hj => [->|Hj]; [ exists i | exists j ].
Qed.

Lemma findex_max : forall x y, fconnect f x y -> findex x y < order x.
Proof. by move=> x y; rewrite [_ y]fconnect_orbit -index_mem size_orbit. Qed.

Lemma findex_iter : forall x i, i < order x -> findex x (iter i f x) = i.
Proof.
move=> x i Hi; rewrite -(nth_traject f Hi); rewrite -size_orbit in Hi.
exact (index_uniq x Hi (orbit_uniq x)).
Qed.

Lemma iter_findex : forall x y, fconnect f x y -> iter (findex x y) f x = y.
Proof.
move=> x y; rewrite [_ y]fconnect_orbit; move=> Hy.
have Hi := Hy; rewrite -index_mem size_orbit in Hi.
by rewrite -(nth_traject f Hi) -/(orbit x) nth_index.
Qed.

Lemma findex0 : forall x, findex x x = 0.
Proof. by move=> x; rewrite /findex /orbit -orderSpred /= eq_refl. Qed.

Lemma fconnect_invariant : forall (T' : eqType) (k : T -> T'),
  invariant f k =1 xpredT -> forall x y : T, fconnect f x y -> k x = k y.
Proof.
move=> T' k Hk x y; move/iter_findex=> <-; elim: {y}(findex x y) => //= n ->.
exact (esym (eqP (Hk _))).
Qed.

Section Loop.

Variable p : seq T.
Hypotheses (Hp : fcycle f p) (Up : uniq p).
Variable x : T.
Hypothesis Hx : x \in p.

(* The first lemma does not depend on Up : (uniq p) *)
Lemma fconnect_cycle : fconnect f x =i p.
Proof.
case/rot_to: Hx => [i q Dp] y; rewrite -(mem_rot i p) Dp.
have Hp' := Hp; rewrite -(cycle_rot i) {i}Dp (cycle_path x) /=  in Hp'.
case/andP: Hp'; move/eqP=> Eq Hq; apply/idP/idP; last exact: path_connect.
move/connectP=> [q' Hq' ->] {y}; case/fpathP: Hq' => [m ->] {q'}.
case/fpathP: Hq Eq => [n ->]; rewrite !last_traject -iterS; move=> Dx.
by apply: (@loopingP _ f x (n.+1) _ m); rewrite /looping Dx /= mem_head.
Qed.

Lemma order_cycle : order x = size p.
Proof. rewrite -(card_uniqP Up); exact (eq_card fconnect_cycle). Qed.

Lemma orbit_rot_cycle : {i : nat | orbit x = rot i p}.
Proof.
case/rot_to: Hx => [i q Dp]; exists i; rewrite (Dp).
have Hp' := Hp; rewrite -(cycle_rot i) (Dp) (cycle_path x) /= in Hp'.
case/andP: Hp' => _; move/fpathP=> [m Dq].
by rewrite /orbit order_cycle -(size_rot i) Dp /= Dq size_traject.
Qed.

End Loop.

Hypothesis Hf : injective f.

Lemma f_finv : cancel finv f.
Proof.
move=> x; move: (looping_order x) (orbit_uniq x).
rewrite /looping /orbit -orderSpred looping_uniq /= /looping.
set n := (order x).-1; case/predU1P; first by [].
move/trajectP=> [i Hi Dnx]; rewrite -iterSr iterS in Dnx.
by case/trajectP; exists i; last exact: Hf.
Qed.

Lemma finv_f : cancel f finv.
Proof. exact (inj_can_sym f_finv Hf). Qed.

Lemma fin_inj_bij : bijective f.
Proof. exists finv; [ exact finv_f | exact f_finv ]. Qed.

Lemma finv_bij : bijective finv.
Proof. exists f; [ exact f_finv | exact finv_f ]. Qed.

Lemma finv_inj : injective finv.
Proof. exact (can_inj f_finv). Qed.

Lemma fconnect_sym : forall x y, fconnect f x y = fconnect f y x.
Proof.
suff: forall x y, fconnect f x y -> fconnect f y x.
  move=> *; apply/idP/idP; auto.
move=> x y; move/connectP=> [p Hp ->] {y}.
elim: p x Hp => [|y p Hrec] x /=; first by rewrite connect0.
move/andP=> [Hx Hp]; rewrite -(finv_f x) (eqP Hx).
apply: (connect_trans _ (fconnect_finv _)); auto.
Qed.

Lemma iter_order : forall x, iter (order x) f x = x.
Proof. move=> x; rewrite -orderSpred iterS; exact (f_finv x). Qed.

Lemma iter_finv : forall n x, n <= order x ->
  iter n finv x = iter (order x - n) f x.
Proof.
move=> n x Hn; set m := order x - n.
rewrite -{1}[x]iter_order -(subnKC Hn) -/m iter_add.
move: {m x Hn}(iter m f x) => x.
by elim: n => // [n Hrec]; rewrite iterSr /= finv_f.
Qed.

Lemma cycle_orbit : forall x, fcycle f (orbit x).
Proof.
move=> x; rewrite /orbit -orderSpred (cycle_path x) /= last_traject -/(finv x).
by rewrite fpath_traject f_finv andbT /=.
Qed.

Lemma fpath_finv : forall x p,
  fpath finv x p = fpath f (last x p) (rev (belast x p)).
Proof.
move=> x p; elim: p x => [|y p Hrec] x //=.
rewrite rev_cons -cats1 path_cat -{}Hrec andbC /= eq_sym andbT.
bool_congr; rewrite -(inj_eq Hf) f_finv.
by case: p => [|z p] //=; rewrite rev_cons last_rcons.
Qed.

Lemma same_fconnect_finv : fconnect finv =2 fconnect f.
Proof.
move=> x y; rewrite (same_connect_rev fconnect_sym).
apply: {x y}eq_connect => x y.
by rewrite /= -(inj_eq Hf) f_finv eq_sym.
Qed.

Lemma fcard_finv : fcard finv =1 fcard f.
Proof. exact (eq_n_comp same_fconnect_finv). Qed.

Definition order_set n : pred T := fun x => order x == n.

Lemma order_div_card : forall n a,
    subpred a (order_set n) -> fclosed f a -> 0 < n ->
  forall m, (#|a| == n * m) = (fcard f a == m).
Proof.
move=> n a Han Ha Hn; rewrite /n_comp; set b : pred T := xpredI (froots f) a.
have Hb: forall x, b x -> froot f x = x /\ order x = n.
  move=> x; move/andP=> [Hrx Hax]; split; apply: eqP; rewrite //=.
  exact: (Han _ Hax).
have <-: #|preim (froot f) b| = #|a|.
  apply: eq_card => x; rewrite /b inE /= (roots_root fconnect_sym).
  by rewrite -(closed_connect Ha (connect_root _ x)).
elim: {a b}#|b| {1 3 4}b (eqxx #|b|) Hb {Ha Han} => [|m Hrec] b Em Hb.
  rewrite -(@eq_card _ pred0) => [m|x].
    by rewrite card0 !(eq_sym 0) muln_eq0 eqn0Ngt Hn.
  by rewrite !inE /= (pred0P Em).
case: (pickP b) => [x //= Hx|Hb0]; last by rewrite (eq_card Hb0) card0 in Em.
case: (Hb _ Hx) => [Dx Hex].
case=> [|m']; rewrite mulnC /=; first by rewrite (cardD1 x) inE /= Dx Hx.
rewrite (cardD1 x) [x \in b]Hx in Em; rewrite mulSn mulnC eqSS.
rewrite -{Hrec}(Hrec _ Em) => [|y]; last by case/andP; auto.
apply: etrans (congr1 (fun p => p == _) _) (eqn_addl _ _ _).
rewrite -(cardID (fconnect f x)); congr (_ + _).
  apply: etrans Hex; apply: eq_card => y; rewrite inE /= -!topredE /= andbC.
  case Hy: (fconnect f x y) => //=.
  by rewrite -(rootP fconnect_sym Hy) Dx.
apply: eq_card => y; rewrite !inE andbC.
by rewrite -{2}Dx (root_connect fconnect_sym) fconnect_sym andbC.
Qed.

Lemma fclosed1 : forall a, fclosed f a -> forall x, a x = a (f x).
Proof. move=> a Ha x; exact (Ha x _ (eq_refl _)). Qed.

Lemma same_fconnect1 : forall x, fconnect f x =1 fconnect f (f x).
Proof. move=> x; exact (same_connect fconnect_sym (fconnect1 x)). Qed.

Lemma same_fconnect1_r : forall x y, fconnect f x y = fconnect f x (f y).
Proof. by move=> x y; rewrite /= !(fconnect_sym x) -same_fconnect1. Qed.

End Orbit.

Prenex Implicits order orbit findex finv order_set.

Section FinCancel.

Variables (T : finType) (f f' : T -> T).
Hypothesis Ef : cancel f f'.

Let Hf := can_inj Ef.

Lemma finv_eq_can : finv f =1 f'.
Proof. exact (bij_can_eq (fin_inj_bij Hf) (finv_f Hf) Ef). Qed.

End FinCancel.

Section FconnectEq.

Variables (T : finType) (f f' : T -> T).
Hypothesis Eff' : f =1 f'.

Lemma eq_pred1 : frel f =2 frel f'.
Proof. move=> x y; rewrite /= Eff'; done. Qed.

Lemma eq_fpath : fpath f =2 fpath f'.
Proof. exact: eq_path eq_pred1. Qed.

Lemma eq_fconnect : fconnect f =2 fconnect f'.
Proof. exact: eq_connect eq_pred1. Qed.

Lemma eq_fcard : fcard f =1 fcard f'.
Proof. exact: eq_n_comp eq_fconnect. Qed.

Lemma eq_finv : finv f =1 finv f'.
Proof.
move=> x; rewrite /finv /order (eq_card (eq_fconnect x)).
exact: (eq_iter Eff').
Qed.

Lemma eq_froot : froot f =1 froot f'.
Proof. exact: eq_root eq_pred1. Qed.

Lemma eq_froots : froots f =1 froots f'.
Proof. exact: eq_roots eq_pred1. Qed.

Hypothesis Hf : injective f.

Lemma finv_inv : finv (finv f) =1 f.
Proof. exact (finv_eq_can (f_finv Hf)). Qed.

Lemma order_finv : order (finv f) =1 order f.
Proof. move=> x; exact (eq_card (same_fconnect_finv Hf x)). Qed.

Lemma order_set_finv : order_set (finv f) =2 order_set f.
Proof. by move=> n x; rewrite /order_set order_finv. Qed.

End FconnectEq.

Section RelAdjunction.

Variables (T T' : finType) (h : T' -> T) (e : rel T) (e' : rel T').
Hypotheses (He : connect_sym e) (He' : connect_sym e').

Variable a : pred T.
Hypothesis Ha : closed e a.

Record rel_adjunction : Type := RelAdjunction {
  rel_unit : forall x, a x -> {x' : T' | connect e x (h x')};
  rel_functor : forall x' y',
    a (h x') -> connect e' x' y' = connect e (h x') (h y')
}.

Lemma intro_adjunction : forall h' : (forall x, a x -> T'),
   (forall x Hx, connect e x (h (h' x Hx))
             /\ (forall y Hy, e x y -> connect e' (h' x Hx) (h' y Hy))) ->
   (forall x' Hx, connect e' x' (h' (h x') Hx)
             /\ (forall y', e' x' y' -> connect e (h x') (h y'))) ->
  rel_adjunction.
Proof.
move=> h' Hee' He'e; split.
  by move=> y Hy; exists (h' y Hy); case (Hee' _ Hy).
move=> x' z' Hx'; apply/idP/idP.
  move/connectP=> [p Hp ->] {z'}.
  elim: p x' Hp Hx' => [|y' p Hrec] x' /=; first by rewrite connect0.
  move/andP=> [Hx' Hp] Hx.
  move: (He'e _ Hx) => [_ H]; move/H: {H}Hx' => Hxp.
  apply: (connect_trans Hxp (Hrec _ Hp _)).
  by rewrite -(closed_connect Ha Hxp).
case: (He'e _ Hx') => [Hx'x'' _] Hxz; apply: (connect_trans Hx'x'').
move/connectP: Hxz Hx' {Hx'x''} => [p Hp Hpz].
elim: p {x'}(h x') Hp Hpz => [|y' p Hrec] x /=.
  by move=> _ <- Hz'; rewrite He'; case (He'e _ Hz').
move/andP=> [Hx' Hp] Dz' Hy.
move: (Hy) (Hee' _ Hy) => Hx [_ Hhxy]; rewrite (Ha Hx') in Hy.
apply: connect_trans (Hrec _ Hp Dz' Hy); auto.
Qed.

Lemma strict_adjunction :
    injective h -> a \subset codom h -> rel_base h e e' (predC a) ->
  rel_adjunction.
Proof.
move=> /= Hh Hha He'e.
apply intro_adjunction with (fun x Hx => iinv (subsetP Hha x Hx)).
  move=> x Hx; split; first by rewrite f_iinv; apply connect0.
  by move=> y Hy //= Hxy; apply connect1; rewrite -He'e !f_iinv ?Hx //= negbK.
move=> x' Hx'; split; first by rewrite (iinv_f _ Hh); apply connect0.
by move=> y' //= Hx'y'; apply connect1; rewrite He'e ?Hx' //= negbK.
Qed.

Lemma adjunction_closed : rel_adjunction -> closed e' (preim h a).
Proof.
move=> [Hu He'e]; apply (intro_closed He').
move=> x' y'; move/(@connect1 T')=> Hx'y' Hx'.
by rewrite He'e // in Hx'y'; rewrite /preim /= -(closed_connect Ha Hx'y').
Qed.

Lemma adjunction_n_comp : rel_adjunction -> n_comp e a = n_comp e' (preim h a).
Proof.
move=> [Hu He'e]; have Hac := closed_connect Ha.
have inj_h: {in predI (roots e') (preim h a) &, injective (root e \o h)}.
  move=> x' y'; case/andP; move/eqP=> rx' /= ax'; case/andP; move/eqP=> ry' _.
  by move/(rootP He); rewrite -He'e //; move/(rootP He'); rewrite rx' ry'.
rewrite /n_comp -(card_in_image inj_h); apply: eq_card => x.
apply/andP/imageP=> [[] | [x']]; last first.
  case/andP; move/eqP=> rx' /= ax' ->.
  by rewrite -(Hac _ _ (connect_root _ _)) roots_root.
move/eqP=> rx ax; have [y' x_y']:= Hu x ax; pose x' := root e' y'.
have ay': a (h y') by rewrite -(Hac _ _ x_y').
have x'_y': connect e (h y') (h x') by rewrite -He'e ?connect_root.
exists x'; first by rewrite /= !inE -(Hac _ _ x'_y') ?roots_root.
rewrite -rx; apply/(rootP He); exact: connect_trans x'_y'.
Qed.

End RelAdjunction.

Definition fun_adjunction T T' h f f' :=
  @rel_adjunction T T' h (frel f) (frel f').

Implicit Arguments intro_adjunction [T T' h e e' a].
Implicit Arguments adjunction_n_comp [T T' e e' a].

Unset Implicit Arguments.