From AIM Require Export Coqlib.
From AIM Require Export Map.
Require Import Arith.
From AIM Require Export Machine.
Require Import Lia.

Set Implicit Arguments.
Unset Strict Implicit.

(** SCAP definitions (sec4.1) ****************************************************)
(** p, Pred    *)
Definition Pred := State -> Prop.

(** MPred: m, INV0, INV1 \in Heap -> Prop *)
Definition MPred := Mem -> Prop.

(** g, Guarantee    *)
Definition Grt := State -> State -> Prop.

Notation STag := nat    (only parsing).

(** SCAP Spec    *)
Inductive Spec : Type :=
  Ast : Pred -> Grt -> STag -> Spec.

(*** Figure 15, Definitions  *)
(** True <==> lambda M. True *)
Definition mTrue : MPred :=
  fun (M : Mem) => True.

(** emp <==> lambda M. M = {} (empty memory space) *)
Definition Aemp : MPred :=
  fun (M : Mem) => M = MemMod.emp.

Definition mEq (M : Mem) : MPred :=
  fun (M0 : Mem) => M = M0.

Definition bang (P : Prop) : MPred :=
  fun (M : Mem) => Aemp M /\ P.

(** l |-> n <==> lambda H. H = {l ~> n} *)
Definition pto (l : Label) (n : int) : MPred :=
  fun (M : Mem) => MemMod.sgltonM M l n.

Notation "A |-> B" := (pto A B) (left associativity, at level 65).

(** l |-> _ <==> lambda H. Ext w. (l |-> w) H *)
Definition ptox (l : Label) : MPred :=
  fun (M : Mem) => exists n : int, pto l n M.

Notation "A |->_" := (ptox A) (left associativity, at level 65).

(** m1*m2
    lambda H. Ext. H1,H2. (H1 .\/ H2 = H) /\ m1 H1 /\ m2 H2 *)
Definition mstar (m1 m2 : MPred) : MPred :=
  fun (M : Mem) =>
    exists M1 : Mem, exists M2 : Mem,
      MemMod.disjUnion M1 M2 M /\ m1 M1 /\ m2 M2.

Notation "A *^* B" := (mstar A B) (left associativity, at level 68).

(* l |-> n, l+1 |-> _ *)
Definition ptoW (l : Label) (n : int) : MPred :=
  mstar (pto l n) (ptox (l+1)).

Notation "l |->w n" := (ptoW l n) (left associativity, at level 65).

Definition ptoxW (l : Label) : MPred :=
  mstar (ptox l) (ptox (l+1)).

Notation "l |->w_" := (ptoxW l) (left associativity, at level 65).

(** l |-> _, ..., _ *)
Fixpoint ptoxBlk (l : Label) (n : nat) {struct n}: MPred :=
  match n with
    0 => Aemp
  | S n' => mstar (ptox l) (ptoxBlk (l+1) n')
  end.

Definition imprecM (m : MPred) : MPred := mstar m mTrue.

(* l ~> n , equivalent to (l -> n) * mTrue *)
Definition leadsTo (l : Label) (n : int) : MPred := imprecM (pto l n).

Notation "l |~> n" := (leadsTo l n) (left associativity, at level 65).

Definition leadsTox (l : Label) : MPred := imprecM (ptox l).

Notation "l |~>_ " := (leadsTox l) (left associativity, at level 65).

Definition leadsToW (l : Label) (n : int) : MPred := imprecM (ptoW l n).

Notation "l |~>w n" := (leadsToW l n) (left associativity, at level 65).

Definition leadsToxW (l : Label) : MPred := imprecM (ptoxW l).

Notation "l |~>w_ " := (leadsToxW l) (left associativity, at level 65).

(* ext. M,  *)
Definition leadsToBlk (l : Label) (n : nat) : MPred := imprecM (ptoxBlk l n).

(* (sp-n) |-> _, ..., ... /\ mTrue *)
Definition stkSpace (sp : int) (n : nat) : MPred :=
  fun (M : Mem) => (sp >= n) /\ (leadsToBlk (sp-n) n) M.

(* precise version of stkSpace *)
Definition stkSpacePrec (sp : int) (n : nat) : MPred :=
  fun (M : Mem) => (sp >= n) /\ (ptoxBlk (sp-n) n) M.

Definition MemUpd16 (M : Mem) (l : int) (n : int) (M' : Mem) : Prop :=
  exists x, M' = MemMod.put (MemMod.put M l n) (l+1) x.

Definition MemUpdW (M : Mem) (l : Label) (w w': nat) : Mem :=
  MemMod.put (MemMod.put M l w) (l+1) w'.

Lemma MemUpd16_MemUpdW : forall M M' l w,
  MemUpd16 M l w M'
  -> exists w', M' = MemUpdW M l w w'.
Admitted.
Arguments MemUpd16_MemUpdW [M M' l w].

Lemma MemUpdW_MemUpd16 : forall M M' l w w',
  M' = MemUpdW M l w w'
    -> MemUpd16 M l w M'.
Admitted.
Arguments MemUpdW_MemUpd16 [M M' l w w'].

(** precise(m) <==>
    forall H,H1,H2.
      (H1 \in H) /\ (H2 \in H) /\ m H1 /\ m H2 -> H1 = H2 *)
Definition precise : MPred -> Prop :=
  fun (m : MPred) =>
    forall (M1 M2 M : Mem),
      MemMod.subseteq M1 M -> MemMod.subseteq M2 M -> m M1 -> m M2 -> M1 = M2.

(** (p*m) <==>
       lambda K,S. Ext H1,H2. (H1 .\/ H2 = S.H) /\ p K S|H1 /\ m H2
*)
Definition pmstar (p : Pred) (m : MPred) : Pred :=
  fun (S : State) =>
    exists M1, exists M2, MemMod.disjUnion M1 M2 (S_Mem S) /\ p (S_Mem_Upd S M1) /\ m M2.

Notation "p *<* m" := (pmstar p m) (left associativity, at level 68).

(** m -* p <==>
    lambda K,S. forall H,H'. (H .\/ S.H = H') /\ m H -> p K S|H' *)
Definition pm_mwand (m : MPred) (p : Pred) : Pred :=
  fun (S : State) =>
    forall (M M' : Mem), MemMod.disjUnion M (S_Mem S) M' -> m M -> p (S_Mem_Upd S M').

Notation "m -* p" := (pm_mwand m p) (right associativity, at level 70).

(** p*True imprec *)
Definition imprec (p : Pred) : Pred := pmstar p mTrue.

Definition pTrue : Pred :=
  fun (S : State) => True.

Definition prepost (m m' : MPred) : Grt :=
  fun (S S' : State) =>
    exists M1, exists M2, exists M1',
      m M1 /\ m' M1' /\ MemMod.disjUnion M1 M2 (S_Mem S) /\ MemMod.disjUnion M1' M2 (S_Mem S').

(*** Figure 16, Connectors for p&g *)
(** Implication of Predicate:
    p => p' <==> forall K,S. p K S -> p' K S *)
Definition pimp (p p' : Pred) : Prop :=
  forall (S : State), p S -> p' S.

(** Implication of Guarantee:
    g => g' <==> forall S,S'. g S S' -> g' S S' *)
Definition gimp (g g' : Grt) : Prop :=
  forall (S S' : State), g S S' -> g' S S'.

(** Strongest Predicate **)
Definition strongPred (gc: Grt) (p : Pred) : Pred :=
  fun (S : State) =>
  (exists S0, (imprec p) S0 /\ gc S0 S).

(** Weakest Guarantee **)
Definition weakGrt (gc : Grt) (p : Pred) (g : Grt) : Grt :=
  fun (S S' : State) =>
  forall S0, (imprec p) S0 -> gc S0 S -> g S0 S'.

(* enable(p,g) <==> ∀K,S. p K S -> ∃S', g S S0 *)
Definition enable (p : Pred) (g : Grt) : Prop :=
  forall S, p S -> exists S', g S S'.

(* g ◦ g' , lambda S,S''. ∃S'. g S S' ∧ g' S' S'' *)
Definition conjG (g g' : Grt) : Grt :=
  fun (S S' : State) =>
    exists S'', g S S'' /\ g' S'' S'.

Infix "oo" := conjG (left associativity, at level 69).

(* p ◦ g' , lambda S,S'. ∃S'. p K S ∧ g S S' *)
Definition linkPG (p : Pred) (g: Grt) : Pred :=
  fun (S' : State) =>
    exists S, p S /\ g S S'.

Infix "|>" := linkPG (left associativity, at level 69).

Definition conjPG (p : Pred) (g : Grt) : Grt :=
  fun (S S' : State) => p S /\ g S S'.

Infix ">o" := conjPG (left associativity, at level 69).

(** pattern used to define g based on pre and post *)
Definition leadstoPQ (p q : Pred) : Grt :=
  fun (S S' : State) =>
  match S with
    (M, R, fl, isr) =>
      match S' with
        (M', R', fl', isr') =>
            forall M1 M2,
              MemMod.disjUnion M1 M2 M
              -> p (M1, R, fl, isr)
              -> exists M1', MemMod.disjUnion M1' M2 M'
                             /\ q (M1', R', fl', isr')
      end
  end.

(** p8: Function calls and memory polymorphism. *)
(** there is an S' s.t. g S S' *)
Definition enableS (S : State) (g : Grt) : Prop :=
  exists S', g S S'.

(** frame property of g
    frame(g) <==> forall S,S',H0,H.
                  (H0 .\/ H = S.H) /\ (g S S') /\ (Ext. S''. g S|_H S'')
                  -> Ext H'. (H0 .\/ H' = S'.H) /\ g S|_H S'|_H'
 *)
Definition frame (g : Grt) : Prop :=
  forall S S',
    g S S'
    -> forall M1 M2, MemMod.disjUnion M1 M2 (S_Mem S)
                    (* ∃S''. g S|_H S'' *)
                     -> enableS (S_Mem_Upd S M1) g
                     -> exists M1', MemMod.disjUnion M1' M2 (S_Mem S')
                                    /\ g (S_Mem_Upd S M1) (S_Mem_Upd S' M1').

(** monotonicigy of g *)
Definition safe_mono (g : Grt) : Prop :=
  forall p, enable p g -> enable (fun S => imprec p S) g.

Lemma frame_rule_1:
  forall p g p',
    pimp (p |> g) p' -> frame g -> enable p g -> pimp ((fun S=> imprec p S) |> g) (fun S => imprec p' S).
Admitted.

Lemma leadstoPQ_sameQ_reverseP:
  forall p p' q g,
    frame g -> enable p g -> pimp (p |> g) p'
    -> gimp (g oo (leadstoPQ p' q)) (leadstoPQ p q).
Admitted.

Lemma imprec_weaker:
  forall (S : State) (p : Pred),
    p S -> imprec p S.
Admitted.
Hint Resolve imprec_weaker.

(* ********** *)
Lemma imprecPimp:
  forall (S : State) (p p0: Pred),
    pimp p p0 -> imprec p S -> imprec p0 S.
Admitted.

Hint Resolve imprecPimp.

(*** SIMP/PIMP/GIMP Related  Lemmas ***)
Lemma equ_pimp:
  forall (p : Pred), pimp p p.
Admitted.

Hint Resolve equ_pimp.

Lemma equ_gimp:
  forall (g : Grt), gimp g g.
Admitted.

Hint Resolve equ_gimp.

Lemma pimp_transt:
  forall (p p' p'' : Pred),   pimp p p' -> pimp p' p'' -> pimp p p''.
Admitted.
Hint Resolve pimp_transt.

Lemma gimp_transt:
  forall (g g' g'' : Grt),   gimp g g' -> gimp g' g'' -> gimp g g''.
Admitted.

Hint Resolve gimp_transt.

Lemma mstar_presv_prec:
  forall (m m' : MPred), precise m -> precise m' -> precise (mstar m m').
Admitted.
Arguments mstar_presv_prec [m m'].

Hint Resolve mstar_presv_prec.

Lemma precise_emp : precise Aemp.
Admitted.

Hint Resolve precise_emp.

Lemma mstar_Aemp_unit:
  forall (m: MPred) (M: Mem), mstar m Aemp M -> m M.
Admitted.

Lemma mstar_Aemp_unit_right:
  forall (m: MPred) (M: Mem), m M -> mstar m Aemp M.
Admitted.
Hint Resolve mstar_Aemp_unit_right.

Lemma pmstar_Aemp_unit:
  forall p S, pmstar p Aemp S -> p S.
Admitted.

Lemma pmstar_Aemp_unit_right:
  forall (p: Pred) (S: State), p S -> (pmstar p Aemp) S.
Admitted.
Hint Resolve pmstar_Aemp_unit_right.

Lemma imprec_monotone:
  forall (p : Pred) (M M': Mem) (R : RFile) (fl : FlagR) (is : ISR),
    imprec p (M, R, fl, is) -> MemMod.subseteq M M' -> imprec p (M', R, fl, is).
Admitted.
Hint Resolve imprec_monotone.

Lemma mstar_mwand_equ_left:
  forall m m' p S, pm_mwand (mstar m m') p S -> pm_mwand m (pm_mwand m' p) S.
Admitted.
Hint Resolve mstar_mwand_equ_left.

Lemma mstar_mwand_equ_right:
  forall m m' p S, pm_mwand m (pm_mwand m' p) S -> pm_mwand (mstar m m') p S.
Admitted.
Hint Resolve mstar_mwand_equ_right.

Lemma mstar_commut:
  forall m m' M, mstar m m' M -> mstar m' m M.
Admitted.
Hint Resolve mstar_commut.

Lemma mstar_sym : forall M A B,
  (A *^* B) M -> (B *^* A) M.
Admitted.

Lemma mstar_assoc_left_right:
  forall M A B C,
    (A *^* B *^* C) M
    -> (A *^* (B *^* C)) M.
Admitted.
Arguments mstar_assoc_left_right [M A B C].

Lemma mstar_assoc_right_left:
  forall M A B C,
    (A *^* (B *^* C)) M
    -> (A *^* B *^* C) M.
Admitted.
Arguments mstar_assoc_left_right [M A B C].

Lemma leadsToInterK:
  forall sp h, leadsToBlk sp 6 h
    -> exists pc, leadsToW sp pc h.
Admitted.

Lemma ptoW_indom:
  forall l m h,
  ptoW l m h
  -> MemMod.in_dom l h /\ MemMod.in_dom (l+1) h.
Admitted.

Lemma ptoxBlk_notindom: forall l s addr h,
  ptoxBlk l s h
  -> addr < l \/ addr >= l + s
  -> h addr = None.
Admitted.

Lemma ptoxBlk_split : forall s1 s2 M l,
  ptoxBlk l (s1 + s2) M
  -> mstar (ptoxBlk l s1) (ptoxBlk (l+s1) s2) M.
Admitted.

Lemma ptoxBlk_merge : forall s1 s2 M l,
  mstar (ptoxBlk l s1) (ptoxBlk (l+s1) s2) M
  -> ptoxBlk l (s1 + s2) M.
Admitted.

Lemma stkSpacePrec_split : forall sp s1 s2 M,
  stkSpacePrec sp (s1 + s2) M
  -> mstar (stkSpacePrec sp s2) (stkSpacePrec (sp-s2) s1) M.
Admitted.
Arguments stkSpacePrec_split [sp s1 s2 M].

Lemma stkSpacePrec_merge : forall sp s1 s2 M1 M2,
  stkSpacePrec sp s2 M1
  -> stkSpacePrec (sp-s2) s1 M2
  -> stkSpacePrec sp (s1 + s2) (MemMod.merge M1 M2).
Admitted.
Arguments stkSpacePrec_merge [sp s1 s2 M1 M2].

Definition uniqueM (m: MPred) : Prop :=
forall M M', m M -> m M' -> M = M'.


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
  | typ_rcd_nil : typ
  | typ_rcd_cons : var -> 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
  | exp_rcd_nil : exp
  | exp_rcd_cons : var -> exp -> exp -> exp
  | exp_rcd_proj : exp -> var -> 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)
  | typ_rcd_nil     => typ_rcd_nil
  | typ_rcd_cons i T1 T2  => typ_rcd_cons i (open_tt_rec K U T1) (open_tt_rec K U T2)
  end.

Definition open_tt T U := open_tt_rec 0 U T.

Inductive rt_type : typ -> Prop :=
  | rt_type_rcd_nil :
      rt_type typ_rcd_nil
  | rt_type_rcd_cons : forall i T1 T2,
      rt_type (typ_rcd_cons i T1 T2)
.

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)
  | type_rcd_nil :
      type typ_rcd_nil
  | type_rcd_cons : forall i T1 T2,
      type T1 ->
      type T2 ->
      rt_type T2 ->
      type (typ_rcd_cons i 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)
  | typ_rcd_nil     => typ_rcd_nil
  | typ_rcd_cons i T1 T2  => typ_rcd_cons i (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)
  | typ_rcd_nil     => {}
  | typ_rcd_cons i T1 T2  => fv_tt T1 \u 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)).

Fixpoint Tlookup (i':var) (Tr:typ) : option typ :=
  match Tr with
  | (typ_rcd_cons i T1 T2) =>
      if i == i' then Some T1 else Tlookup i' T2
  | _ => None
  end.

Fixpoint collectLabel (T : typ) : atoms :=
  match T with
  | (typ_rcd_cons i T1 T2) => {{i}} \u collectLabel T2
  | _ => {}
  end.

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)
| WF_rcd_nil : forall E,
      WF E typ_rcd_nil
| WF_rcd_cons : forall E i T1 T2,
      WF E T1 ->
      WF E T2 ->
      rt_type T2 ->
      i \notin (collectLabel T2) ->
      WF E (typ_rcd_cons i 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)
  | typ_rcd_nil     => {}
  | typ_rcd_cons i T1 T2  => {{i}} \u 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 S1 S2 T1 T2,
    sub E S1 S2 ->
    sub E S2 S1 ->
      (forall X : atom, X `notin` L ->
          sub (X ~ bind_sub S2 ++ E) (open_tt T1 X) (open_tt T2 X)) ->
      sub E (typ_all S1 T1) (typ_all S2 T2)
| sa_rcd: forall A1 A2 E,
    wf_env E ->
    rt_type A1 ->
    rt_type A2 ->
    collectLabel A2 [<=] collectLabel A1 ->
    WF E A1 -> WF E A2 ->
    (forall i t1 t2, Tlookup i A1 = Some t1 ->  Tlookup i A2 = Some t2 -> sub E t1 t2) ->
    sub E A1 A2
.

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)
  | exp_rcd_nil => exp_rcd_nil
  | exp_rcd_cons i e1 e2 => exp_rcd_cons i (open_te_rec K U e1) (open_te_rec K U e2)
  | exp_rcd_proj e1 i => exp_rcd_proj (open_te_rec K U e1) i
  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
  | exp_rcd_nil => exp_rcd_nil
  | exp_rcd_cons i e1 e2 => exp_rcd_cons i (open_ee_rec k f e1) (open_ee_rec k f e2)
  | exp_rcd_proj e1 i => exp_rcd_proj (open_ee_rec k f e1) i
  end.

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

Inductive rt_expr : exp -> Prop :=
  | rt_expr_rcd_nil :
      rt_expr exp_rcd_nil
  | rt_expr_rcd_cons : forall i e1 e2,
      rt_expr (exp_rcd_cons i e1 e2)
.

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)
  | expr_rcd_nil :
     expr exp_rcd_nil
  | expr_rcd_cons : forall i e1 e2,
     expr e1 ->
     expr e2 ->
     rt_expr e2 ->
     expr (exp_rcd_cons i e1 e2)
  | expr_rcd_proj : forall i e,
     expr e ->
     expr (exp_rcd_proj e i)
.

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

Fixpoint tlookup (i':var) (Er:exp) : option exp :=
  match Er with
  | (exp_rcd_cons i e1 e2) =>
      if i == i' then Some e1 else tlookup i' e2
  | _ => None
  end.

Fixpoint collectLabele (e: exp) : atoms :=
  match e with
  | (exp_rcd_cons i e1 e2) => {{i}} \u collectLabele e2
  | _ => {}
  end.

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
  | typing_proj : forall G e T i Ti,
      typing G e T ->
      Tlookup i T = Some Ti ->
      typing G (exp_rcd_proj e i) Ti
  | typing_rcd_nil : forall G,
      wf_env G ->
      typing G exp_rcd_nil typ_rcd_nil
  | typing_rcd_cons: forall G e1 e2 T1 T2 i,
      typing G e1 T1 ->
      typing G e2 T2 ->
      rt_type T2 ->
      rt_expr e2 ->
      i \notin (collectLabele e2) ->
      typing G (exp_rcd_cons i e1 e2) (typ_rcd_cons i T1 T2)
.

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
  | value_rcd_nil:
      value exp_rcd_nil
 | value_rcd_cons : forall i e1 e2,
      value e1 ->
      value e2 ->
      rt_expr e2 ->
      value (exp_rcd_cons i e1 e2)
.

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)
 | step_projrcd: forall e i vi ,
     value e ->
     tlookup i e = Some vi->
     step (exp_rcd_proj e i) vi
 | step_proj: forall e1 e2 i,
     step e1 e2 ->
     step (exp_rcd_proj e1 i) (exp_rcd_proj e2 i)
 | step_rcd_head: forall e1 e2 e i,
     step e1 e2 ->
     step (exp_rcd_cons i e1 e) (exp_rcd_cons i e2 e)
 | step_rcd_cons: forall v1 e1 e2 i,
     value v1 ->
     step e1 e2 ->
     step (exp_rcd_cons i v1 e1) (exp_rcd_cons i v1 e2)
.

Hint Constructors rt_type rt_expr 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)
  | exp_rcd_nil => {}
  | exp_rcd_cons i e1 e2 => (fv_te e1) `union` (fv_te e2)
  | exp_rcd_proj e1 i => (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)
  | exp_rcd_nil => {}
  | exp_rcd_cons i e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_rcd_proj e1 i => (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)
  | exp_rcd_nil => exp_rcd_nil
  | exp_rcd_cons i e1 e2 => exp_rcd_cons i (subst_te Z U e1) (subst_te Z U e2)
  | exp_rcd_proj e1 i => exp_rcd_proj (subst_te Z U e1) i
  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
  | exp_rcd_nil => exp_rcd_nil
  | exp_rcd_cons i e1 e2 => exp_rcd_cons i (subst_ee z u e1) (subst_ee z u e2)
  | exp_rcd_proj e1 i => exp_rcd_proj (subst_ee z u e1) i
  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 sub_tvar_inv:forall E U (X:atom),
    sub E U X ->
    exists Y, U = typ_fvar Y.
Proof with auto.
  intros.
  dependent induction H...
  exists X...
  exists X0...
  inversion H1.
Qed.

Lemma typing_rt_expr_novar : forall E e (X:atom),
  typing E e X -> rt_expr e -> False.
Proof with auto.
  intros.
  dependent induction H;
  try match goal with
  | [H : rt_expr _ |- _] => inversion H
  end.
  - apply sub_tvar_inv in H0. destruct H0. subst.
    apply IHtyping with (X:=x)...
  - subst. apply sub_tvar_inv in H0. destruct H0. subst.
    apply IHtyping with (X:=x)...
Qed.

Lemma typing_collectLabel_inclusion : forall E e T,
  typing E e T -> rt_type T -> rt_expr e ->
  collectLabel T [<=]
  collectLabele e.
Proof with auto.
  intros. induction H;inv_rt;try solve [inversion H1].
  - (* subsumption *)
    destruct H0.
    + simpl. apply AtomSetProperties.subset_empty.
    + dependent destruction H2;inv_rt.
      { apply typing_rt_expr_novar in H... destruct H. }
      rewrite <- IHtyping...
  - (* nil *)
    reflexivity.
  - (* cons *)
    simpl. rewrite IHtyping2... reflexivity.
Qed.

Lemma label_choose_reserve_e:
  forall (X : atom) (u : exp) [e : exp],
  expr e -> rt_expr e -> collectLabele e [=] collectLabele (subst_ee X u e).
Proof with auto.
  intros.
  induction H;simpl;try reflexivity...
  + inversion H0.
  + rewrite IHexpr2... reflexivity.
Qed.

Lemma subst_te_collect: forall i X A e,
    i `notin` collectLabele e ->
    rt_expr e ->
    expr e ->
    i `notin` collectLabele (subst_te X A e).
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply notin_union in H.
  destruct H.
  apply notin_union.
  split...
Qed.

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)
  | typ_rcd_nil => typ_rcd_nil
  | typ_rcd_cons i A B => typ_rcd_cons i (close_tt_rec K Z A) (close_tt_rec 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
| WD_nil: forall k,
    WFD typ_rcd_nil k
| WD_cons: forall i A B k,
    WFD A k ->
    WFD B k ->
    WFD (typ_rcd_cons i A B) k
.

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)...
- inv H. rewrite IHT1 with (k:=k)...
  rewrite IHT2 with (k:=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_rt_type : forall Z P T,
  rt_type T ->
  type P ->
  rt_type (subst_tt Z P T).
Proof with auto.
  intros.
  induction H...
  constructor...
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...
  {
    (* typ_rcd_cons *)
    constructor... apply subst_tt_rt_type...
  }
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)...
  -
    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))...
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 WF_narrowing : forall V U T E F X,
  WF (F ++ X ~ bind_sub V ++ E) T ->
  WF (F ++ X ~ bind_sub U ++ E) T.
Proof with eauto.
  intros.
  dependent induction H;try solve [analyze_binds H;eauto]...
  -
    apply WF_all with (L:=L)...
    intros.
    rewrite_alist (([(X0, bind_sub T1)] ++ F) ++ [(X, bind_sub U)] ++ E)...
    eapply H1 with (V0:=V)...
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)...
  -
    repeat split...
    + apply WF_all with (L:=L);intros...
      rewrite_env (nil ++ X ~ bind_sub S1 ++ E).
      eapply WF_narrowing with (V:=S2)...
      eapply H2...
    + apply WF_all with (L:=L);intros...
      eapply H2...
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_tt_collect: forall T E i X A,
    i `notin` collectLabel T ->
    rt_type T ->
    WF E T ->
    i `notin` collectLabel (subst_tt X A T).
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply notin_union in H.
  destruct H.
  apply notin_union.
  split...
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...
  -
    constructor...
    { apply subst_tt_rt_type... apply WF_type in H3... }
    { eapply subst_tt_collect... }
Qed.

Lemma wf_rcd_lookup : forall E i T Ti,
  WF E T ->
  Tlookup i T = Some Ti ->
  WF E Ti.
Proof with eauto.
  intros E i T.
  dependent induction T; intros; try solve [inversion H0]...
  - (* RCons *)
    dependent destruction H.
    simpl in *.
    destruct (a==i)...
    inversion H3; subst...
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...
  -
    repeat split...
    apply wf_rcd_lookup with (i:=i) (T:=T)...
  -
    repeat split...
    constructor...
    rewrite typing_collectLabel_inclusion...
    apply H0.
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)...
  -
    constructor...
    { simpl...
      apply KeySetProperties.FM.Subset_refl... }
    { intros.
      simpl in *.
      inversion H. }
  -
    dependent induction H2...
    +
      constructor...
      { apply KeySetProperties.FM.Subset_refl... }
      intros.
      simpl in *...
      destruct (i==i0)...
      { inversion H2.
        inversion H4...
        subst... }
      { inversion H2... }
    +
      constructor...
      { apply KeySetProperties.FM.Subset_refl... }
      apply IHWF2 in H0.
      dependent destruction H0.
      intros.
      simpl in *.
      destruct (i==i1)...
      { inversion H9.
        inversion H10.
        subst... }
      { apply H8 with (i:=i1)... }
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 S2) ++ F) ++ E)...
    apply H2 with (x0:=x) (U0:=U)...
  -
    apply sa_rcd...
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 S2)] ++ E1) ++ E ++ E2).
    apply H2...
    get_well_form.
    rewrite_alist ([(X, bind_sub S2)] ++ E1 ++ E ++ E2)...
    constructor...
    apply WF_weakening... apply sub_regular in H. destruct_hypos...
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...
  -
    apply KeySetProperties.union_subset_3...
Qed.

Lemma  subst_tt_rt_expr : forall   A B X,
    rt_expr  B ->
    expr A  ->
    expr B ->
    rt_expr  (subst_ee X A B).
Proof with auto.
  intros.
  induction H...
  dependent destruction H1...
  simpl...
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...
    }
  - apply typing_proj with (T:=T)...
  - apply typing_rcd_nil...
  - simpl. apply typing_rcd_cons...
    + apply IHtyping1...
    + apply IHtyping2...
    + apply subst_tt_rt_expr... apply typing_regular in H0. destruct_hypos...
    + rewrite <- label_choose_reserve_e...
      apply typing_regular in H0. destruct_hypos...
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...
  -
    rewrite_alist (map (subst_tb X Y) E1  ++ Y ~ bind_sub U ++ E2).
    apply WF_rcd_cons...
    { apply subst_tt_rt_type... }
    { apply subst_tt_collect with (E:= E1 ++ X ~ bind_sub U ++ E2)... }
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 subst_tt_collect2: forall T E i X A,
    i `in` collectLabel T ->
    rt_type T ->
    WF E T ->
    i `in` collectLabel (subst_tt X A T).
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply union_iff in H. apply union_iff.
  destruct H...
Qed.

Lemma subst_tt_collect3: forall T E i X A,
    i `in` collectLabel (subst_tt X A T) ->
    rt_type T ->
    WF E T ->
    i `in` collectLabel T.
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply union_iff in H. apply union_iff.
  destruct H...
Qed.

Lemma Tlookup_subst: forall E A i X C T,
    WF E A ->
    rt_type A ->
    Tlookup i (subst_tt X C A) = Some T ->
    exists S,
      Tlookup i (subst_tt X C A) = Some (subst_tt X C S) /\ (subst_tt X C S) = T
/\ Tlookup i A = Some S.
Proof with auto.
  intros.
  induction H;try solve [inversion H0]...
  -
    simpl in H1.
    inversion H1.
  -
    simpl in *.
    destruct (i0==i)...
    subst.
    inversion H1...
    exists T1...
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 IHsub1...
    apply IHsub2...
    rewrite_env (map (subst_tb X Y) (X0~bind_sub S2 ++ E1) ++ (Y, bind_sub U) :: E2).
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    apply H2...
    simpl...
    constructor...
    apply WF_replacing...
    apply sub_regular in H. destruct_hypos...
  - apply sa_rcd...
    + apply subst_tt_rt_type...
    + apply subst_tt_rt_type...
    + intro x. intros. specialize (H2 x).
      apply subst_tt_collect2 with (E:= E1 ++ X ~ bind_sub U ++ E2)...
      apply H2.
      apply subst_tt_collect3 with (E:= E1 ++ X ~ bind_sub U ++ E2) in H9...
    + rewrite_alist (map (subst_tb X Y) E1 ++ [(Y, bind_sub U)] ++ E2).
      apply WF_replacing...
    + rewrite_alist (map (subst_tb X Y) E1 ++ [(Y, bind_sub U)] ++ E2).
      apply WF_replacing...
    + intros.
      apply Tlookup_subst with (E:=(E1 ++ X ~ bind_sub U ++ E2)) in H9...
      apply Tlookup_subst with (E:=(E1 ++ X ~ bind_sub U ++ E2)) in H10...
      destruct H9 as [t1'], H10 as [t2']. destruct_hypos. subst.
      apply H6 with (i:=i)...
Qed.

Lemma lookup_some_subst: forall i A T E X B,
    WF E A -> rt_type A ->
    Tlookup i A = Some T->
    Tlookup i (subst_tt X B A) = Some (subst_tt X B T).
Proof with auto.
  intros.
  induction H;try solve [inversion H0]...
  inversion H1...
  simpl in *.
  destruct (i0==i);subst...
  inversion H1...
Qed.

Lemma subst_te_rt_expr:
  forall A B X,
  rt_expr B -> type A -> expr B -> rt_expr (subst_te X A B).
Proof.
  intros. induction H;simpl...
  + constructor.
  + constructor.
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...
  - simpl. apply typing_proj with (T:=subst_tt X Y T)...
    + apply IHtyping...
    + apply lookup_some_subst with (E:=(E1 ++ X ~ bind_sub U ++ E2))...
      { apply typing_regular in H. destruct_hypos... }
      { destruct T;inversion H0... }
  - simpl. apply typing_rcd_nil...
  - simpl. apply typing_rcd_cons...
    + apply IHtyping1...
    + apply IHtyping2...
    + apply subst_tt_rt_type...
    + apply subst_te_rt_expr... apply typing_regular in H0.
      destruct_hypos...
    + apply subst_te_collect...
      apply typing_regular in H0. destruct_hypos...
Qed.

End Fsub.


(** * Isomorphisms *)

(** ** Contents

  - isomorphisms: [iso], [isiso f := isweq (precomp_with f)]
  - Equivalence relation identifying isomorphic objects
  - Isomorphisms in a category [z_iso]
    - Definition: [is_z_iso f := ∑ g, ...]
    - Relationship between [z_iso] and [iso]
  - Properties of 0-isomorphisms
    - uniqueness of inverse, composition etc.
    - stability under composition
    - Analogue to [isweq_iso]: [is_iso_qinv]
 *)

Require Import UniMath.Foundations.PartA.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.

Local Open Scope cat.

(** A morphism [f: a --> b] in a precategory is an isomorphism [is_iso(f)],
    if for any [c: C], precomposition with [f] yields an equivalence
    (b --> c -> a --> c].
    Definition suggested by V. Voevodsky
*)

Definition precomp_with {C : precategory_data} {a b : C} (f : a --> b) {c : C} (g : b --> c): a --> c :=
   f · g.

Definition is_iso {C : precategory_data} {a b : C} (f : a --> b) :=
  ∏ c, isweq (precomp_with f (c:=c)).

Lemma isaprop_is_iso {C : precategory_data} (a b : C) (f : a --> b) : isaprop (is_iso f).
Proof.
  apply impred; intro.
  apply isapropisweq.
Qed.

Definition iso {C: precategory_data} (a b : C) := ∑ f : a --> b, is_iso f.
Definition morphism_from_iso {C : precategory_data} {a b : C} (f : iso a b) : a --> b := pr1 f.
Coercion morphism_from_iso : iso >-> precategory_morphisms.

Definition iso_is_iso {C : precategory_data} {a b : C} (f : iso a b) : is_iso f := pr2 f.

Definition make_iso {C : precategory_data} {a b : C} (f : a --> b) (fiso: is_iso f) : iso a b := (f,,fiso).

Definition inv_from_iso {C : precategory_data} {a b : C} (f : iso a b) : b --> a :=
   invmap (make_weq (precomp_with f) (pr2 f a)) (identity _ ).

Definition iso_inv_after_iso {C : precategory_data} {a b : C} (f: iso a b) :
   f · inv_from_iso f = identity _ .
Proof.
  set (T := homotweqinvweq (make_weq (precomp_with f) (pr2 f a ))).
  simpl in *.
  apply T.
Defined.

Definition iso_after_iso_inv {C : precategory} {a b : C} (f : iso a b) :
  inv_from_iso f · f = identity _ .
Proof.
  set (T := invmaponpathsweq (make_weq (precomp_with f) (pr2 f b))).
  apply T; clear T; simpl.
  unfold precomp_with.
  intermediate_path ((f · inv_from_iso f) · f).
  - apply assoc.
  - apply remove_id_left.
    + apply iso_inv_after_iso.
    + apply (!(id_right _ )).
Defined.

Definition is_iso_inv_from_iso {C : precategory} {a b : C} (f : iso a b) : is_iso (inv_from_iso f).
Proof.
  intro c.
  apply (isweq_iso _ (precomp_with f)).
  - intro g.
    unfold precomp_with.
    intermediate_path ((f · inv_from_iso f) · g).
    + apply assoc.
    + apply remove_id_left. apply iso_inv_after_iso. apply idpath.
  - intro g.
    unfold precomp_with.
    intermediate_path ((inv_from_iso f · f) · g).
    + apply assoc.
    + apply remove_id_left. apply iso_after_iso_inv. apply idpath.
Defined.

Definition iso_inv_from_iso {C : precategory} {a b : C} (f : iso a b) : iso b a :=
  tpair _ _ (is_iso_inv_from_iso f).

Lemma eq_iso {C: precategory_data} {a b : C} (f g : iso a b) : pr1 f = pr1 g -> f = g.
Proof.
  intro H.
  apply subtypePath.
  - intros t. apply isaprop_is_iso.
  - apply H.
Defined.

Lemma isaset_iso {C : precategory_data} (hs : has_homsets C) (a b : ob C) :
  isaset (iso a b).
Proof.
  change isaset with (isofhlevel 2).
  apply isofhleveltotal2.
  - apply hs.
  - intro f.
    apply isasetaprop.
    apply isaprop_is_iso.
Qed.

Lemma identity_is_iso (C : precategory) (a : ob C) : is_iso (identity a).
Proof.
  intros c.
  set (T := @isweqhomot (a --> c) (a --> c) (λ t, t) (precomp_with (identity a))).
  apply T.
  - intro g. apply pathsinv0. apply id_left.
  - apply idisweq.
Defined.

Definition identity_iso {C : precategory} (a : ob C) :
   iso a a := tpair _ _ (identity_is_iso C a).

Definition iso_inv_from_is_iso {C : precategory} {a b : ob C}
  (f : a --> b) (H : is_iso f) : iso b a :=
  iso_inv_from_iso (f,,H).

Lemma iso_inv_on_right {C : precategory} (a b c : ob C)
  (f : iso a  b) (g : b --> c) (h : a --> c) (H : h = f · g) :
     inv_from_iso f · h = g.
Proof.
  apply (invmaponpathsweq (make_weq (precomp_with f) (pr2 f c))).
  unfold precomp_with; simpl.
  intermediate_path ((f · inv_from_iso f) · h).
  - apply assoc.
  - apply remove_id_left.
    + apply iso_inv_after_iso.
    + assumption.
Defined.

Lemma iso_inv_on_left {C : precategory} (a b c : ob C)
  (f : a --> b) (g : iso b c) (h : a --> c) (H : h = f · g) :
     f = h · inv_from_iso g.
Proof.
  assert (H2 : h · inv_from_iso g =
                         (f · g) · inv_from_iso g).
    rewrite H. apply idpath.
  rewrite <- assoc in H2.
  rewrite iso_inv_after_iso in H2.
  rewrite id_right in H2.
  apply pathsinv0.
  assumption.
Qed.

Lemma iso_inv_to_left {C : precategory} (a b c : ob C)
  (f : iso a  b) (g : b --> c) (h : a --> c) :
    inv_from_iso f · h = g -> h = f · g.
Proof.
  intro H.
  intermediate_path (f · inv_from_iso f · h).
  - rewrite iso_inv_after_iso, id_left; apply idpath.
  - rewrite <- assoc. rewrite H. apply idpath.
Qed.

Lemma iso_inv_to_right {C : precategory} (a b c : ob C)
  (f : a --> b) (g : iso b c) (h : a --> c) :
     f = h · inv_from_iso g -> f · g = h.
Proof.
  intro H.
  intermediate_path (h · inv_from_iso g · g).
  - rewrite H. apply idpath.
  - rewrite <- assoc, iso_after_iso_inv, id_right. apply idpath.
Qed.

(** ** Properties of isomorphisms *)
(** Stability under composition, inverses etc *)

Definition isweqhomot' {X Y} (f g : X -> Y) (H : isweq f)
      (homot : ∏ x, f x = g x) : isweq g.
Proof.
  apply (isweqhomot f g homot H).
Defined.

Lemma is_iso_comp_of_isos {C : precategory} {a b c : ob C}
  (f : iso a b) (g : iso b c) : is_iso (f · g).
Proof.
  simpl.
  intro d.
  set (T := twooutof3c (precomp_with g) (precomp_with f (c:=d)) (pr2 g d) (pr2 f _)).
  apply (isweqhomot' _ _ T).
  intro h. apply assoc.
Defined.

Lemma is_iso_comp_of_is_isos {C : precategory} {a b c : ob C}
      (f : a --> b) (g : b --> c) (H1 : is_iso f) (H2 : is_iso g) : is_iso (f · g).
Proof.
  set (i1 := make_iso f H1).
  set (i2 := make_iso g H2).
  exact (is_iso_comp_of_isos i1 i2).
Qed.

Definition iso_comp {C : precategory} {a b c : ob C}
  (f : iso a b) (g : iso b c) : iso a c.
Proof.
  exists (f · g).
  apply is_iso_comp_of_isos.
Defined.

Lemma inv_iso_unique (C : precategory) (a b : C) (f : iso a b) (g : iso b a) :
  precomp_with f g = identity _ -> g = iso_inv_from_iso f.
Proof.
  intro H.
  apply eq_iso. simpl.
  set (T := invmaponpathsweq (make_weq (precomp_with f) (pr2 f a ))).
  apply T; simpl.
  intermediate_path (identity a).
  + assumption.
  + apply pathsinv0. apply iso_inv_after_iso.
Defined.

Lemma inv_iso_unique' (C : precategory) (a b : C) (f : iso a b) (g : b --> a) :
  precomp_with f g = identity _ -> g = inv_from_iso f.
Proof.
  intro H.
  set (T := invmaponpathsweq (make_weq (precomp_with f) (pr2 f a ))).
  apply T; simpl.
  intermediate_path (identity a).
  + assumption.
  + apply pathsinv0. apply iso_inv_after_iso.
Defined.

Lemma iso_inv_of_iso_comp (C : precategory) (a b c : ob C)
   (f : iso a b) (g : iso b c) :
   iso_inv_from_iso (iso_comp f g) = iso_comp (iso_inv_from_iso g) (iso_inv_from_iso f).
Proof.
  apply pathsinv0.
  apply inv_iso_unique. simpl. unfold precomp_with.
  intermediate_path (f · (g · inv_from_iso g) · inv_from_iso f).
  - repeat rewrite assoc.  apply idpath.
  - rewrite iso_inv_after_iso. rewrite id_right.
    apply iso_inv_after_iso.
Qed.

Lemma iso_inv_of_iso_id {C : precategory} (a : ob C) :
   iso_inv_from_iso (identity_iso a) = identity_iso a.
Proof.
  apply eq_iso.
  apply idpath.
Qed.

Lemma iso_inv_iso_inv {C : precategory} (a b : ob C) (f : iso a b) :
     iso_inv_from_iso (iso_inv_from_iso f) = f.
Proof.
  apply eq_iso. simpl.
  apply pathsinv0.
  apply inv_iso_unique'.
  apply iso_after_iso_inv.
Defined.

Lemma pre_comp_with_iso_is_inj {C : precategory_data} (a b c : ob C)
    (f : a --> b) (H : is_iso f) (g h : b --> c) : f · g = f · h -> g = h.
Proof.
  intro X.
  apply (invmaponpathsweq (make_weq (precomp_with f) (H _ ))).
  apply X.
Qed.

Lemma cancel_precomposition_iso {C : precategory_data} {a b c : C}
    (f : iso a b) (g h : b --> c) : f · g = f · h -> g = h.
Proof.
  apply (pre_comp_with_iso_is_inj _ _ _ (pr1 f) (pr2 f)).
Qed.

Lemma post_comp_with_iso_is_inj {C : precategory} (b c : ob C)
     (h : b --> c) (H : is_iso h)
   (a : ob C) (f g : a --> b) : f · h = g · h -> f = g.
Proof.
  intro HH.
  set (T := iso_inv_after_iso (h,,H)). simpl in T.
  intermediate_path (f · (h · inv_from_iso (h,,H))).
  - rewrite T. clear T.
    apply pathsinv0, id_right.
  - rewrite assoc. rewrite HH.
    rewrite <- assoc. rewrite T.
    apply id_right.
Qed.

Lemma cancel_postcomposition_iso {C : precategory} {a b c : C}
    (h : iso b c) (f g : a --> b) : f · h = g · h -> f = g.
Proof.
  apply (post_comp_with_iso_is_inj _ _ (pr1 h) (pr2 h)).
Qed.

Lemma iso_comp_right_isweq {C : precategory_data} {a b : ob C} (h : iso a b) (c : C) :
  isweq (fun f : b --> c => h · f).
Proof.
  apply (pr2 h _ ).
Defined.

Definition iso_comp_right_weq {C : precategory_data} {a b : C} (h : iso a b) (c : C) :
 (b --> c) ≃ (a --> c) := make_weq _ (iso_comp_right_isweq h c).

Lemma iso_comp_left_isweq {C : precategory} {a b : ob C} (h : iso a b) (c : C) :
  isweq (fun f : c --> a => f · h).
Proof.
  intros. apply (isweq_iso _ (λ g, g · inv_from_iso h)).
  - intro x. rewrite <- assoc. apply remove_id_right.
    apply iso_inv_after_iso. apply idpath.
  - intro y. rewrite <- assoc. apply remove_id_right.
    apply iso_after_iso_inv. apply idpath.
Defined.

Definition postcomp_with {C : precategory_data} {b c : C} (h : b --> c) {a : C}
  (f : a --> b) : a --> c := f · h.

Definition is_iso' {C : precategory} {b c : C} (f : b --> c) :=
  ∏ a, isweq (postcomp_with f (a:=a)).

Definition is_inverse_in_precat {C : precategory_data} {a b : C}
  (f : a --> b) (g : b --> a) :=
          (f · g = identity a) ×
          (g · f = identity b).

Definition make_is_inverse_in_precat {C : precategory_data} {a b : C} {f : a --> b} {g : b --> a}
           (H1 : f · g = identity a) (H2 : g · f = identity b) :
  is_inverse_in_precat f g := (H1,,H2).

Definition is_inverse_in_precat1 {C : precategory_data} {a b : C} {f : a --> b} {g : b --> a}
           (H : is_inverse_in_precat f g) :
  f · g = identity a := dirprod_pr1 H.

Definition is_inverse_in_precat2 {C : precategory_data} {a b : C} {f : a --> b} {g : b --> a}
           (H : is_inverse_in_precat f g) :
  g · f = identity b := dirprod_pr2 H.

Definition is_inverse_in_precat_inv {C : precategory_data} {a b : C} {f : a --> b} {g : b --> a}
           (H : is_inverse_in_precat f g) : is_inverse_in_precat g f :=
  make_dirprod (is_inverse_in_precat2 H) (is_inverse_in_precat1 H).

Definition is_inverse_in_precat_comp {C : precategory} {a b c : C} {f1 : a --> b} {f2 : b --> c}
           {g1 : b --> a} {g2 : c --> b} (H1 : is_inverse_in_precat f1 g1)
           (H2 : is_inverse_in_precat f2 g2) : is_inverse_in_precat (f1 · f2) (g2 · g1).
Proof.
  use make_is_inverse_in_precat.
  - rewrite assoc. rewrite <- (assoc _ f2). rewrite (is_inverse_in_precat1 H2). rewrite id_right.
    rewrite (is_inverse_in_precat1 H1). apply idpath.
  - rewrite assoc. rewrite <- (assoc _ g1). rewrite (is_inverse_in_precat2 H1). rewrite id_right.
    rewrite (is_inverse_in_precat2 H2). apply idpath.
Qed.

Definition is_inverse_in_precat_identity {C : precategory} (c : C) :
  is_inverse_in_precat (identity c) (identity c).
Proof.
  use make_is_inverse_in_precat.
  - apply id_left.
  - apply id_left.
Qed.

Definition is_iso_qinv {C:precategory} {a b : C} (f : a --> b) (g : b --> a) :
  is_inverse_in_precat f g -> is_iso f.
Proof.
  intros H c.
  apply (isweq_iso _ (precomp_with g)).
  - intro h. unfold precomp_with.
    rewrite assoc.
    apply remove_id_left.
    apply (pr2 H). apply idpath.
  - intro h. unfold precomp_with. rewrite assoc.
    apply remove_id_left.
    apply (pr1 H). apply idpath.
Defined.

Definition iso_comp_left_weq {C : precategory} {a b : C} (h : iso a b) (c : C) :
 (c --> a) ≃ (c --> b) := make_weq _ (iso_comp_left_isweq h c).

Definition iso_conjug_weq {C : precategory} {a b : C} (h : iso a b) :
 (a --> a) ≃ (b --> b) := weqcomp (iso_comp_left_weq h _ ) (iso_comp_right_weq (iso_inv_from_iso h) _ ).

(** ** Equivalence relation identifying isomorphic objects *)

Section are_isomorphic.

  Context {C : precategory}.

  (** a and b are related if there merely exists an iso between them *)
  Definition are_isomorphic : hrel C := λ a b, ∥iso a b∥.

  Lemma iseqrel_are_isomorphic : iseqrel are_isomorphic.
  Proof.
  repeat split.
  - intros x y z h1.
    apply hinhuniv; intros h2; generalize h1; clear h1.
    now apply hinhuniv; intros h1; apply hinhpr, (iso_comp h1 h2).
  - now intros x; apply hinhpr, identity_iso.
  - now intros x y; apply hinhuniv; intro h1; apply hinhpr, iso_inv_from_iso.
  Qed.

  Definition iso_eqrel : eqrel C := (are_isomorphic,,iseqrel_are_isomorphic).

End are_isomorphic.

(** ** Isomorphisms in a category [z_iso] *)

(** In a precategory with hom-sets, we can give the usual definition of
    isomorphism, called [z_iso] in the following.
*)

Lemma isaprop_is_inverse_in_precat {C : category} (a b : ob C)
   (f : a --> b) (g : b --> a) : isaprop (is_inverse_in_precat f g).
Proof.
  apply isapropdirprod; apply homset_property.
Qed.

Lemma inverse_unique_precat {C : precategory} (a b : ob C)
   (f : a --> b) (g g': b --> a) (H : is_inverse_in_precat f g)
    (H' : is_inverse_in_precat f g') : g = g'.
Proof.
  destruct H as [eta eps].
  destruct H' as [eta' eps'].
  assert (H : g = identity b · g).
    rewrite id_left; apply idpath.
  apply (pathscomp0 H).
  rewrite <- eps'.
  rewrite <- assoc.
  rewrite eta.
  apply id_right.
Qed.

Definition is_z_isomorphism {C : precategory_data} {a b : ob C}
           (f : a --> b) := ∑ g, is_inverse_in_precat f g.

Definition make_is_z_isomorphism {C : precategory_data} {a b : C} (f : a --> b)
           (g : b --> a) (H : is_inverse_in_precat f g) : is_z_isomorphism f := (g,,H).

Definition is_z_isomorphism_mor {C : precategory_data} {a b : C} {f : a --> b}
           (I : is_z_isomorphism f) : b --> a := pr1 I.

Definition is_z_isomorphism_is_inverse_in_precat {C : precategory_data} {a b : C}
           {f : a --> b} (I : is_z_isomorphism f) :
  is_inverse_in_precat f (is_z_isomorphism_mor I) := pr2 I.
Coercion is_z_isomorphism_is_inverse_in_precat : is_z_isomorphism >-> is_inverse_in_precat.

Definition is_z_isomorphism_inv {C : precategory_data} {a b : C} {f : a --> b}
           (I : is_z_isomorphism f) : is_z_isomorphism (is_z_isomorphism_mor I).
Proof.
  use make_is_z_isomorphism.
  - exact f.
  - exact (is_inverse_in_precat_inv I).
Defined.

Definition is_z_isomorphism_comp {C : precategory} {a b c : C} {f1 : a --> b} {f2 : b --> c}
           (H1 : is_z_isomorphism f1) (H2 : is_z_isomorphism f2) :
  is_z_isomorphism (f1 · f2).
Proof.
  use make_is_z_isomorphism.
  - exact (is_z_isomorphism_mor H2 · is_z_isomorphism_mor H1).
  - exact (is_inverse_in_precat_comp H1 H2).
Defined.

Definition is_z_isomorphism_identity {C : precategory} (c : C) : is_z_isomorphism (identity c).
Proof.
  use make_is_z_isomorphism.
  - exact (identity c).
  - exact (is_inverse_in_precat_identity c).
Defined.

Lemma isaprop_is_z_isomorphism {C : category} {a b : ob C}
     (f : a --> b) : isaprop (is_z_isomorphism f).
Proof.
  apply invproofirrelevance.
  intros g g'.
  set (Hpr1 := inverse_unique_precat _ _ _ _ _ (pr2 g) (pr2 g')).
  apply (total2_paths_f Hpr1).
  destruct g as [g [eta eps]].
  destruct g' as [g' [eta' eps']].
  simpl in *.
  apply isapropdirprod; apply homset_property.
Qed.

Lemma is_z_isomorphism_mor_eq {C : precategory} {a b : C} {f g : a --> b}
      (e : f = g) (I1 : is_z_isomorphism f) (I2 : is_z_isomorphism g) :
  is_z_isomorphism_mor I1 = is_z_isomorphism_mor I2.
Proof.
  use inverse_unique_precat.
  - exact f.
  - exact I1.
  - rewrite e. exact I2.
Qed.

Definition z_iso {C : precategory_data} (a b : ob C) := ∑ f : a --> b, is_z_isomorphism f.

Definition make_z_iso {C : precategory_data} {a b : C} (f : a --> b) (g : b --> a)
  (H : is_inverse_in_precat f g) : z_iso a b := (f,,make_is_z_isomorphism f g H).

Definition make_z_iso' {C : precategory_data} {a b : C} (f : a --> b) (H : is_z_isomorphism f) :
  z_iso a b := (f,,H).

Definition z_iso_mor {C : precategory_data} {a b : ob C} (f : z_iso a b) : a --> b := pr1 f.
Coercion z_iso_mor : z_iso >-> precategory_morphisms.

Definition inv_from_z_iso {C : precategory_data} {a b : C} (i : z_iso a b) : b --> a :=
  is_z_isomorphism_mor (pr2 i).

Definition z_iso_is_inverse_in_precat {C : precategory_data} {a b : C} (i : z_iso a b) :
  is_inverse_in_precat i (inv_from_z_iso i) := pr2 i.
Coercion z_iso_is_inverse_in_precat : z_iso >-> is_inverse_in_precat.

Definition z_iso_inv {C : precategory_data} {a b : C} (I : z_iso a b) : z_iso b a.
Proof.
  use make_z_iso.
  - exact (inv_from_z_iso I).
  - exact I.
  - exact (is_inverse_in_precat_inv I).
Defined.

Definition z_iso_comp {C : precategory} {a b c : C} (I1 : z_iso a b) (I2 : z_iso b c) :
  z_iso a c.
Proof.
  use make_z_iso.
  - exact (I1 · I2).
  - exact ((inv_from_z_iso I2) · (inv_from_z_iso I1)).
  - exact (is_inverse_in_precat_comp I1 I2).
Defined.

Lemma is_z_iso_comp_of_is_z_isos {C : precategory} {a b c : ob C}
      (f : a --> b) (g : b --> c) (H1 : is_z_isomorphism f) (H2 : is_z_isomorphism g) : is_z_isomorphism (f · g).
Proof.
  set (i1 := make_z_iso f _ H1).
  set (i2 := make_z_iso g _ H2).
  exact (pr2 (z_iso_comp i1 i2)).
Defined.

(* see below [identity_z_iso]
Definition z_iso_identity {C : precategory} (c : C) : z_iso c c.
Proof.
  use make_z_iso.
  - exact (identity c).
  - exact (identity c).
  - exact (is_inverse_in_precat_identity c).
Defined.
 *)

Definition z_iso_is_z_isomorphism {C : precategory_data} {a b : C} (I : z_iso a b) :
  is_z_isomorphism I.
Proof.
  use make_is_z_isomorphism.
  - exact (inv_from_z_iso I).
  - exact I.
Defined.

Definition is_z_iso_inv_from_z_iso {C : precategory_data} {a b : C} (I : z_iso a b) :
  is_z_isomorphism (inv_from_z_iso I).
Proof.
  use make_is_z_isomorphism.
  - exact I.
  - exact (is_inverse_in_precat_inv I).
Defined.

Lemma post_comp_with_z_iso_is_inj {C : precategory} {a' a b : C} {f : a --> b} {g : b --> a}
      (i : is_inverse_in_precat f g) : ∏ (f' g' : a' --> a), f' · f = g' · f -> f' = g'.
Proof.
  intros f' g' H.
  apply (maponpaths (postcompose g)) in H. unfold postcompose in H.
  do 2 rewrite <- assoc in H.
  rewrite (is_inverse_in_precat1 i) in H. do 2 rewrite id_right in H.
  exact H.
Qed.

Lemma post_comp_with_z_iso_inv_is_inj {C : precategory} {a b b' : C} {f : a --> b} {g : b --> a}
      (i : is_inverse_in_precat f g) : ∏ (f' g' : b' --> b), f' · g = g' · g -> f' = g'.
Proof.
  intros f' g' H.
  apply (maponpaths (postcompose f)) in H. unfold postcompose in H.
  do 2 rewrite <- assoc in H.
  rewrite (is_inverse_in_precat2 i) in H. do 2 rewrite id_right in H.
  exact H.
Qed.

Lemma pre_comp_with_z_iso_is_inj {C : precategory} {a b b' : C} {f : a --> b} {g : b --> a}
      (i : is_inverse_in_precat f g) : ∏ (f' g' : b --> b'), f · f' = f · g' -> f' = g'.
Proof.
  intros f' g' H.
  apply (maponpaths (compose g)) in H.
  do 2 rewrite assoc in H.
  rewrite (is_inverse_in_precat2 i) in H. do 2 rewrite id_left in H.
  exact H.
Qed.

Lemma cancel_precomposition_z_iso {C : precategory} {a b c : C}
    (f : z_iso a b) (g h : b --> c) : f · g = f · h -> g = h.
Proof.
  use pre_comp_with_z_iso_is_inj.
  - exact (pr1 (pr2 f)).
  - exact (pr2 (pr2 f)).
Qed.

Lemma pre_comp_with_z_iso_is_inj' {C : precategory} {a b b' : C} {f : a --> b}
      (i : is_z_isomorphism f) : ∏ (f' g' : b --> b'), f · f' = f · g' -> f' = g'.
Proof.
  intros f' g' H.
  apply (pre_comp_with_z_iso_is_inj (pr2 i)).
  exact H.
Qed.

Lemma pre_comp_with_z_iso_inv_is_inj {C : precategory} {a' a b : C} {f : a --> b} {g : b --> a}
      (i : is_inverse_in_precat f g) : ∏ (f' g' : a --> a'), g · f' = g · g' -> f' = g'.
Proof.
  intros f' g' H.
  apply (maponpaths (compose f)) in H.
  do 2 rewrite assoc in H.
  rewrite (is_inverse_in_precat1 i) in H. do 2 rewrite id_left in H.
  exact H.
Qed.

Lemma z_iso_eq {C : category} {a b : C} (i i' : z_iso a b) (e : z_iso_mor i = z_iso_mor i') :
  i = i'.
Proof.
  use total2_paths_f.
  - exact e.
  - use proofirrelevance. apply isaprop_is_z_isomorphism.
Qed.

Lemma z_iso_eq_inv {C : category} {a b : C} (i i' : z_iso a b)
      (e2 : inv_from_z_iso i = inv_from_z_iso i') : i = i'.
Proof.
  use z_iso_eq.
  assert (H : is_inverse_in_precat (inv_from_z_iso i) i').
  {
    use make_is_inverse_in_precat.
    - rewrite e2. exact (is_inverse_in_precat2 i').
    - rewrite e2. exact (is_inverse_in_precat1 i').
  }
  exact (inverse_unique_precat _ _ _ _ _ (z_iso_inv i) H).
Qed.

Definition morphism_from_z_iso {C : precategory_data} (a b : ob C)
   (f : z_iso a b) : a --> b := pr1 f.
Coercion morphism_from_z_iso : z_iso >-> precategory_morphisms.

Lemma isaset_z_iso {C : category} (a b : ob C) : isaset (z_iso a b).
Proof.
  change isaset with (isofhlevel 2).
  apply isofhleveltotal2.
  - apply homset_property.
  - intro f.
    apply isasetaprop.
    apply isaprop_is_z_isomorphism.
Qed.

Lemma identity_is_z_iso {C : precategory} (a : ob C) :
    is_z_isomorphism (identity a).
Proof.
  exists (identity a).
  simpl; split;
  apply id_left.
Defined.

Definition identity_z_iso {C : precategory} (a : ob C) :
   z_iso a a := tpair _ _ (identity_is_z_iso a).

Definition z_iso_inv_from_z_iso {C : precategory_data} {a b : ob C}
  (f : z_iso a b) : z_iso b a.
Proof.
  exists (inv_from_z_iso f).
  apply is_z_iso_inv_from_z_iso.
Defined.

Definition z_iso_inv_from_is_z_iso {C : precategory_data} {a b : ob C}
  (f : a --> b) (H : is_z_isomorphism f) : z_iso b a :=
  z_iso_inv_from_z_iso (f,,H).

Definition z_iso_inv_after_z_iso {C : precategory_data} {a b : ob C}
   (f : z_iso a b) : f · inv_from_z_iso f = identity _ :=
      pr1 (pr2 (pr2 f)).

Definition z_iso_after_z_iso_inv {C : precategory_data} {a b : ob C}
   (f : z_iso a b) : inv_from_z_iso f · f = identity _ :=
      pr2 (pr2 (pr2 f)).

Lemma z_iso_inv_on_right {C : precategory} (a b c : ob C)
  (f : z_iso a  b) (g : b --> c) (h : a --> c) (H : h = f · g) :
     inv_from_z_iso f · h = g.
Proof.
  assert (H2 : inv_from_z_iso f · h =
                  inv_from_z_iso f · (f · g)).
    apply maponpaths; assumption.
  rewrite assoc in H2.
  rewrite H2.
  rewrite z_iso_after_z_iso_inv.
  apply id_left.
Qed.

Lemma z_iso_inv_on_left {C : precategory} (a b c : ob C)
  (f : a --> b) (g : z_iso b c) (h : a --> c) (H : h = f · g) :
     f = h · inv_from_z_iso g.
Proof.
  assert (H2 : h · inv_from_z_iso g =
                         (f · g) · inv_from_z_iso g).
    rewrite H. apply idpath.
  rewrite <- assoc in H2.
  rewrite z_iso_inv_after_z_iso in H2.
  rewrite id_right in H2.
  apply pathsinv0.
  assumption.
Qed.

Lemma z_iso_inv_to_left {C : precategory} (a b c : ob C)
  (f : z_iso a  b) (g : b --> c) (h : a --> c) :
    inv_from_z_iso f · h = g -> h = f · g.
Proof.
  intro H.
  intermediate_path (f · inv_from_z_iso f · h).
  - rewrite z_iso_inv_after_z_iso, id_left; apply idpath.
  - rewrite <- assoc. apply maponpaths. assumption.
Qed.

Lemma z_iso_inv_to_right {C : precategory} (a b c : ob C)
  (f : a --> b) (g : z_iso b c) (h : a --> c) :
     f = h · inv_from_z_iso g -> f · g = h.
Proof.
  intro H.
  intermediate_path (h · inv_from_z_iso g · g).
  - rewrite H. apply idpath.
  - rewrite <- assoc, z_iso_after_z_iso_inv, id_right. apply idpath.
Qed.

Lemma wrap_inverse {M : precategory} {x y : M} (g : x --> x) (f : z_iso x y) :
  g = identity x -> z_iso_inv f · g · f = identity y.
Proof.
  intros e. rewrite e. rewrite id_right. apply z_iso_after_z_iso_inv.
Defined.

Lemma wrap_inverse' {M : precategory} {x y : M} (g : x --> x) (f : z_iso y x) :
  g = identity x -> f · g · z_iso_inv f = identity y.
Proof.
  intros e. rewrite e. rewrite id_right. apply z_iso_inv_after_z_iso.
Defined.

Lemma cancel_z_iso {M : precategory} {x y z : M} (f f' : x --> y) (g : z_iso y z) :
  f · g = f' · g -> f = f'.
Proof.
  intro e.
  destruct g as [g [g' H]].
  apply (post_comp_with_z_iso_is_inj H).
  assumption.
Qed.

Lemma cancel_z_iso' {M : precategory} {w x y : M} (g : z_iso w x) (f f' : x --> y) :
  g · f = g · f' -> f = f'.
Proof.
  intro e.
  destruct g as [g [g' H]].
  apply (pre_comp_with_z_iso_is_inj H).
  assumption.
Qed.

Definition are_z_isomorphic {C : precategory_data} : hrel C := λ a b, ∥z_iso a b∥.

Lemma iseqrel_are_z_isomorphic {C : precategory} : iseqrel (are_z_isomorphic(C:=C)).
  Proof.
  repeat split.
  - intros x y z h1.
    apply hinhuniv; intros h2; generalize h1; clear h1.
    now apply hinhuniv; intros h1; apply hinhpr, (z_iso_comp h1 h2).
  - now intros x; apply hinhpr, identity_z_iso.
  - now intros x y; apply hinhuniv; intro h1; apply hinhpr, z_iso_inv_from_z_iso.
  Qed.

Definition z_iso_eqrel {C : precategory} : eqrel C := (are_z_isomorphic,,iseqrel_are_z_isomorphic).

(** ** Properties of 0-isomorphisms *)

(** Stability under composition, inverses etc *)

Lemma are_inverse_comp_of_inverses {C : precategory} (a b c : C)
     (f : z_iso a b) (g : z_iso b c) :
  is_inverse_in_precat (f · g) (inv_from_z_iso g · inv_from_z_iso f).
Proof.
  apply is_inverse_in_precat_comp.
  - apply (pr2 f).
  - apply (pr2 g).
Qed.

Lemma inv_z_iso_unique {C : category} (a b : ob C)
  (f : z_iso a b) (g : z_iso b a) :
  is_inverse_in_precat f g -> g = z_iso_inv_from_z_iso f.
Proof.
  intro H.
  apply z_iso_eq.
  apply (inverse_unique_precat _ _ f).
    - assumption.
    - split.
      + apply z_iso_inv_after_z_iso.
      + set (h := z_iso_after_z_iso_inv f).
        apply h.
Qed.

Lemma inv_z_iso_unique' (C : precategory) (a b : C) (f : z_iso a b) (g : b --> a) :
  precomp_with f g = identity _ -> g = inv_from_z_iso f.
Proof.
  intro H.
  apply (cancel_z_iso' f).
  unfold precomp_with in H.
  rewrite H.
  apply pathsinv0.
  apply z_iso_inv_after_z_iso.
Defined.

Lemma z_iso_inv_of_z_iso_comp {C : category} (a b c : ob C)
   (f : z_iso a b) (g : z_iso b c) :
   z_iso_inv_from_z_iso (z_iso_comp f g) =
       z_iso_comp (z_iso_inv_from_z_iso g) (z_iso_inv_from_z_iso f).
Proof.
  apply z_iso_eq.
  apply idpath.
Defined.

Lemma z_iso_inv_of_z_iso_id {C : category} (a : ob C) :
   z_iso_inv_from_z_iso (identity_z_iso a) = identity_z_iso a.
Proof.
  apply z_iso_eq.
  apply idpath.
Qed.

Lemma z_iso_inv_z_iso_inv {C : category} (a b : ob C) (f : z_iso a b) :
     z_iso_inv_from_z_iso (z_iso_inv_from_z_iso f) = f.
Proof.
  apply z_iso_eq.
  apply idpath.
Defined.

Lemma z_iso_comp_right_isweq {C : precategory} {a b : ob C} (h : z_iso a b) (c : C) :
  isweq (fun f : b --> c => h · f).
Proof.
  intros. apply (isweq_iso _ (λ g, inv_from_z_iso h · g)).
       { intros f. use (_ @ maponpaths (λ m, m · f) (pr2 (pr2 (pr2 h))) @ _).
         { apply assoc. } { apply id_left. } }
       { intros g. use (_ @ maponpaths (λ m, m · g) (pr1 (pr2 (pr2 h))) @ _).
         { apply assoc. } { apply id_left. } }
Defined.

Definition z_iso_comp_right_weq {C : precategory} {a b : C} (h : z_iso a b) (c : C) :
 (b --> c) ≃ (a --> c) := make_weq _ (z_iso_comp_right_isweq h c).

Lemma z_iso_comp_left_isweq {C : precategory} {a b : ob C} (h : z_iso a b) (c : C) :
  isweq (fun f : c --> a => f · h).
Proof.
  intros. apply (isweq_iso _ (λ g, g · inv_from_z_iso h)).
  { intros f. use (_ @ maponpaths (λ m, f · m) (pr1 (pr2 (pr2 h))) @ _).
         { apply pathsinv0. apply assoc. }  { apply id_right. } }
       { intros g. use (_ @ maponpaths (λ m, g · m) (pr2 (pr2 (pr2 h))) @ _).
         { apply pathsinv0, assoc. } { apply id_right. } }
Defined.

Definition z_iso_comp_left_weq {C : precategory} {a b : C} (h : z_iso a b) (c : C) :
 (c --> a) ≃ (c --> b) := make_weq _ (z_iso_comp_left_isweq h c).

Definition z_iso_conjug_weq {C : precategory} {a b : C} (h : z_iso a b) :
 (a --> a) ≃ (b --> b) := weqcomp (z_iso_comp_left_weq h _ )
         (z_iso_comp_right_weq (z_iso_inv_from_z_iso h) _ ).

Lemma is_iso_from_is_z_iso {C : precategory} {a b : C} (f: a --> b) :
     is_z_isomorphism f -> is_iso f.
Proof.
  intro H.
  apply (is_iso_qinv _ (pr1 H)).
  apply (pr2 H).
Defined.

Definition z_iso_to_iso {C : precategory} {b c : C} (f : z_iso b c) : iso b c
  := pr1 f ,, is_iso_from_is_z_iso (pr1 f) (pr2 f).

Lemma is_z_iso_from_is_iso {C : precategory} {a b : C} (f : a --> b):
     is_iso f -> is_z_isomorphism f.
Proof.
  intro H.
  set (fiso := make_iso f H).
  exists (inv_from_iso fiso).
  split.
  - set (H2 := iso_inv_after_iso fiso).
    simpl in H2. apply H2.
  - set (H2 := iso_after_iso_inv fiso).
    simpl in H2. apply H2.
Defined.

Lemma is_z_iso_from_is_iso' (C : precategory) {b c : C} (f : b --> c) :
  is_iso' f -> is_z_isomorphism f.
Proof.
  intros i.
  assert (Q := i c (identity c)). induction Q as [[g E] _]. unfold postcomp_with in E.
  exists g. split.
  2 : { exact E. }
  assert (X := id_left _ : postcomp_with f (identity _) = f).
  assert (Y := ! assoc _ _ _ @ maponpaths (precomp_with f) E @ id_right _
               : postcomp_with f (f · g) = f).
  clear E.
  set (x := (_,,X) : hfiber (postcomp_with f) f).
  set (y := (_,,Y) : hfiber (postcomp_with f) f).
  exact (maponpaths pr1 (proofirrelevancecontr (i b f) y x)).
Defined.

Definition iso_to_z_iso {C : precategory} {b c : C} : iso b c -> z_iso b c
  := λ f, pr1 f ,, is_z_iso_from_is_iso (pr1 f) (pr2 f).

Lemma roundtrip1_iso_z_iso {C : precategory} {b c : C} (f: iso b c) :
  z_iso_to_iso (iso_to_z_iso f) = f.
Proof.
  destruct f as [f H].
  use total2_paths_f.
  - apply idpath.
  - apply isaprop_is_iso.
Qed.

Lemma roundtrip2_iso_z_iso {C : category} {b c : C} (f: z_iso b c) :
  iso_to_z_iso (z_iso_to_iso f) = f.
Proof.
  destruct f as [f H].
  use total2_paths_f.
  - apply idpath.
  - apply isaprop_is_z_isomorphism.
Qed.

Definition weq_iso_z_iso {C : category} {b c : C} : iso b c ≃ z_iso b c.
Proof.
  exists iso_to_z_iso.
  use isweq_iso.
  - apply z_iso_to_iso.
  - apply roundtrip1_iso_z_iso.
  - apply roundtrip2_iso_z_iso.
Defined.

(** The right inverse of an invertible morphism must be equal to the known (two-sided) inverse. *)
(** TODO: Did I switch up right and left here vis a vis the conventional use? *)
Lemma right_inverse_of_iso_is_inverse {C : precategory} {c c' : C}
      (f : c --> c')
      (g : c' --> c) (H  : is_inverse_in_precat f g)
      (h : c' --> c) (HH : f · h = identity _) :
  h = g.
Proof.
  refine (!id_left _ @ _).
  refine (maponpaths (fun z => z · h) (!is_inverse_in_precat2 H) @ _).
  refine (!assoc _ _ _ @ _).
  refine (maponpaths (fun z => g · z) HH @ _).
  apply id_right.
Qed.

Lemma left_inverse_of_iso_is_inverse {C : precategory} {c c' : C}
      (f : c --> c')
      (g : c' --> c) (H  : is_inverse_in_precat f g)
      (h : c' --> c) (HH : h · f = identity _) :
  h = g.
Proof.
  refine (!id_right _ @ _).
  refine (maponpaths (fun z => h · z) (!is_inverse_in_precat1 H) @ _).
  refine (assoc _ _ _ @ _).
  refine (maponpaths (fun z => z · g) HH @ _).
  apply id_left.
Qed.

Definition is_z_isomorphism_path
           {C : category}
           {x y : C}
           {f f' : x --> y}
           (p : f = f')
           (Hf : is_z_isomorphism f)
  : is_z_isomorphism f'.
Proof.
  use make_is_z_isomorphism.
  - exact (inv_from_z_iso (_ ,, Hf)).
  - split.
    + abstract
        (rewrite <- p ;
         apply (z_iso_inv_after_z_iso (_ ,, Hf))).
    + abstract
        (rewrite <- p ;
         apply (z_iso_after_z_iso_inv (_ ,, Hf))).
Defined.