Add LoadPath "../metatheory".
Require Import FzipCore_init.
Require Import FzipCore_weakenU.

(** Lemmas about [lc] *)
Lemma zip_lc1 : forall Γ₁ Γ₂ Γ₃,
  zip Γ₁ Γ₂ Γ₃ → lc_env Γ₁.
Proof.
intros Γ₁ Γ₂ Γ₃ H. induction H; auto with lngen.
Qed.

Lemma zip_lc2 : forall Γ₁ Γ₂ Γ₃,
  zip Γ₁ Γ₂ Γ₃ → lc_env Γ₂.
Proof.
intros Γ₁ Γ₂ Γ₃ H. induction H; auto with lngen.
Qed.

Lemma zip_lc3 : forall Γ₁ Γ₂ Γ₃,
  zip Γ₁ Γ₂ Γ₃ → lc_env Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ H. induction H; auto with lngen.
Qed.
Hint Resolve zip_lc1 zip_lc2 zip_lc3: lngen.

(** Lemmas about [dom] *)
Lemma zip_dom1 :
  forall Γ₁ Γ₂ Γ₃, zip Γ₁ Γ₂ Γ₃ →
  dom Γ₁ [<=] dom Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ H. induction H; simpl in *; fsetdec.
Qed.

Lemma zip_dom2 :
  forall Γ₁ Γ₂ Γ₃, zip Γ₁ Γ₂ Γ₃ →
  dom Γ₂ [=] dom Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ H. induction H; simpl in *; fsetdec.
Qed.

Lemma zip_dom3 :
  forall Γ₁ Γ₂ Γ₃, zip Γ₁ Γ₂ Γ₃ →
  dom Γ₁ [<=] dom Γ₂.
Proof.
intros Γ₁ Γ₂ Γ₃ H. rewrite (zip_dom2 Γ₁ Γ₂ Γ₃); auto. eapply zip_dom1; eauto.
Qed.
Hint Resolve zip_dom1 zip_dom2 zip_dom3: fzip.

(** Lemmas about [uniq] *)
Lemma zip_uniq1 : forall Γ₁ Γ₂ Γ₃,
  zip Γ₁ Γ₂ Γ₃ → uniq Γ₁.
Proof.
intros Γ₁ Γ₂ Γ₃ H. induction H; auto.
Qed.

Lemma zip_uniq2 : forall Γ₁ Γ₂ Γ₃,
  zip Γ₁ Γ₂ Γ₃ → uniq Γ₂.
Proof.
intros Γ₁ Γ₂ Γ₃ H. induction H; auto.
Qed.

Lemma zip_uniq3 : forall Γ₁ Γ₂ Γ₃,
  zip Γ₁ Γ₂ Γ₃ → uniq Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ H. induction H; auto.
assert (x ∉ dom G). erewrite <- zip_dom2; eauto. auto.
assert (a ∉ dom G). erewrite <- zip_dom2; eauto. auto.
assert (a ∉ dom G). erewrite <- zip_dom2; eauto. auto.
assert (a ∉ dom G). erewrite <- zip_dom2; eauto. auto.
assert (a ∉ dom G). erewrite <- zip_dom2; eauto. auto.
Qed.
Hint Resolve zip_uniq1 zip_uniq2 zip_uniq3: lngen.

(** Lemmas about [binds] *)
Lemma zip_binds_T12 :
  forall Γ₁ Γ₂ Γ₃ x τ, zip Γ₁ Γ₂ Γ₃ →
    binds x (T τ) Γ₁ → binds x (T τ) Γ₂.
Proof.
intros Γ₁ Γ₂ Γ₃ x τ H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.

Lemma zip_binds_T13 :
  forall Γ₁ Γ₂ Γ₃ x τ, zip Γ₁ Γ₂ Γ₃ →
    binds x (T τ) Γ₁ → binds x (T τ) Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ x τ H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.

Lemma zip_binds_T23 :
  forall Γ₁ Γ₂ Γ₃ x τ, zip Γ₁ Γ₂ Γ₃ →
    binds x (T τ) Γ₂ → binds x (T τ) Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ x τ H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.

Lemma zip_binds_T31 :
  forall Γ₁ Γ₂ Γ₃ x τ, zip Γ₁ Γ₂ Γ₃ →
    binds x (T τ) Γ₃ → binds x (T τ) Γ₁.
Proof.
intros Γ₁ Γ₂ Γ₃ x τ H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.
Hint Resolve zip_binds_T12 zip_binds_T13 zip_binds_T23 zip_binds_T31: fzip.

Lemma zip_binds_Eq12 :
  forall Γ₁ Γ₂ Γ₃ a τ, zip Γ₁ Γ₂ Γ₃ →
    binds a (Eq τ) Γ₁ → binds a (Eq τ) Γ₂.
Proof.
intros Γ₁ Γ₂ Γ₃ a τ H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.

Lemma zip_binds_Eq13 :
  forall Γ₁ Γ₂ Γ₃ a τ, zip Γ₁ Γ₂ Γ₃ →
    binds a (Eq τ) Γ₁ → binds a (Eq τ) Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ a τ H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.

Lemma zip_binds_Eq23 :
  forall Γ₁ Γ₂ Γ₃ a τ, zip Γ₁ Γ₂ Γ₃ →
    binds a (Eq τ) Γ₂ → binds a (Eq τ) Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ a τ H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.

Lemma zip_binds_Eq31 :
  forall Γ₁ Γ₂ Γ₃ a τ, zip Γ₁ Γ₂ Γ₃ →
    binds a (Eq τ) Γ₃ → binds a (Eq τ) Γ₁.
Proof.
intros Γ₁ Γ₂ Γ₃ a τ H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.

Lemma zip_binds_Eq32 :
  forall Γ₁ Γ₂ Γ₃ a τ, zip Γ₁ Γ₂ Γ₃ →
    binds a (Eq τ) Γ₃ → binds a (Eq τ) Γ₂.
Proof.
intros Γ₁ Γ₂ Γ₃ a τ H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.
Hint Resolve zip_binds_Eq12 zip_binds_Eq13 zip_binds_Eq23 zip_binds_Eq31 zip_binds_Eq32: fzip.

Lemma zip_binds_E12 :
  forall Γ₁ Γ₂ Γ₃ a, zip Γ₁ Γ₂ Γ₃ →
    binds a E Γ₁ → binds a U Γ₂.
Proof.
intros Γ₁ Γ₂ Γ₃ a H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.

Lemma zip_binds_E13 :
  forall Γ₁ Γ₂ Γ₃ a, zip Γ₁ Γ₂ Γ₃ →
    binds a E Γ₁ → binds a E Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ a H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.

Lemma zip_binds_E23 :
  forall Γ₁ Γ₂ Γ₃ a, zip Γ₁ Γ₂ Γ₃ →
    binds a E Γ₂ → binds a E Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ a H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.

Lemma zip_binds_E3_inv :
  forall Γ₁ Γ₂ Γ₃ a, zip Γ₁ Γ₂ Γ₃ →
    binds a E Γ₃ →
    (binds a E Γ₁ ∧ binds a U Γ₂) ∨ (a ∉ dom Γ₁ ∧ binds a E Γ₂).
Proof.
intros Γ₁ Γ₂ Γ₃ a H H1. dependent induction H; auto.
Case "TT".
assert (uniq (x ~ T t ++ G)). erewrite zip_dom2 in H2; eauto. eauto with lngen.
destruct IHzip.
analyze_binds_uniq H1.
destruct H5; auto.
analyze_binds_uniq H1. destruct H5; auto.
Case "UU".
assert (uniq (a0 ~ U ++ G)). erewrite zip_dom2 in H0; eauto. eauto with lngen.
destruct IHzip.
analyze_binds_uniq H1.
destruct H4; auto.
analyze_binds_uniq H1. destruct H4; auto.
Case "EU".
assert (uniq (a0 ~ E ++ G)). erewrite zip_dom2 in H0; eauto. eauto with lngen.
destruct (a == a0); subst; auto.
destruct IHzip.
analyze_binds_uniq H1.
destruct H4; auto.
analyze_binds_uniq H1. destruct H4; auto.
Case "E".
assert (uniq (a0 ~ E ++ G)). erewrite zip_dom2 in H0; eauto. eauto with lngen.
destruct (a == a0); subst; auto.
destruct IHzip.
analyze_binds_uniq H1.
destruct H4; auto.
analyze_binds_uniq H1. destruct H4; auto.
Case "Eq".
assert (uniq (a0 ~ Eq t ++ G)). erewrite zip_dom2 in H2; eauto. eauto with lngen.
destruct IHzip.
analyze_binds_uniq H1.
destruct H5; auto.
analyze_binds_uniq H1. destruct H5; auto.
Qed.
Hint Resolve zip_binds_E12 zip_binds_E13 zip_binds_E23 zip_binds_E3_inv: fzip.

Lemma zip_binds_U12 :
  forall Γ₁ Γ₂ Γ₃ a, zip Γ₁ Γ₂ Γ₃ →
    binds a U Γ₁ → binds a U Γ₂.
Proof.
intros Γ₁ Γ₂ Γ₃ a H H0. dependent induction H; auto; try solve [analyze_binds H0; intuition].
Qed.

Lemma zip_binds_U13 :
  forall Γ₁ Γ₂ Γ₃ a, zip Γ₁ Γ₂ Γ₃ →
    binds a U Γ₁ → binds a U Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ a H H0. dependent induction H; auto; try solve [analyze_binds H0].
Qed.

Lemma zip_binds_U23 :
  forall Γ₁ Γ₂ Γ₃ a, zip Γ₁ Γ₂ Γ₃ →
    binds a U Γ₂ → binds a U Γ₃ ∨ binds a E Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ a H H0. dependent induction H; auto; try solve [analyze_binds H0; intuition].
Qed.

Lemma zip_binds_U31 :
  forall Γ₁ Γ₂ Γ₃ a, zip Γ₁ Γ₂ Γ₃ →
    binds a U Γ₃ → binds a U Γ₁.
Proof.
intros Γ₁ Γ₂ Γ₃ a H H0. dependent induction H; auto; try solve [analyze_binds H0; intuition].
Qed.

Lemma zip_binds_U32 :
  forall Γ₁ Γ₂ Γ₃ a, zip Γ₁ Γ₂ Γ₃ →
    binds a U Γ₃ → binds a U Γ₂.
Proof.
intros Γ₁ Γ₂ Γ₃ a H H0. dependent induction H; auto; try solve [analyze_binds H0; intuition].
Qed.
Hint Resolve zip_binds_U12 zip_binds_U13 zip_binds_U23 zip_binds_U31 zip_binds_U32: fzip.

Ltac my_auto := try solve [ auto | auto with fzip | auto with lngen | solve_uniq].

Lemma zip_app : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃',
  disjoint Γ₁ Γ₁' → disjoint Γ₂ Γ₂' → disjoint Γ₃ Γ₃' →
  zip Γ₁ Γ₂ Γ₃ → zip Γ₁' Γ₂' Γ₃' →
  zip (Γ₁ ++ Γ₁') (Γ₂ ++ Γ₂') (Γ₃ ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' H H0 H1 H2 H3.
generalize dependent Γ₃'.
generalize dependent Γ₂'.
generalize dependent Γ₁'.
induction H2; intros; simpl_env in *; auto; constructor; my_auto.
Case "E". simpl_env. assert (dom Γ₁' [<=] dom Γ₃') by eauto with fzip. my_auto.
Qed.

Lemma zip_unique : forall Γ₁ Γ₂ Γ₃ Γ₄,
  zip Γ₁ Γ₂ Γ₃ → zip Γ₁ Γ₂ Γ₄ → Γ₃ = Γ₄.
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₄ H H0.
generalize dependent Γ₄. induction H; intros Γ₄ H3; inversion H3; subst;
f_equal; auto.
Qed.

(** Basic lemmas about [zip] *)
Lemma zip_nil : forall Γ Γ',
  zip nil Γ Γ' → Γ = Γ'.
Proof.
intros Γ Γ' H. dependent induction H; auto.
rewrite IHzip; auto.
Qed.

Lemma zip_T : forall x τ, lc_typ τ → zip (x ~ T τ) (x ~ T τ) (x ~ T τ).
Proof.
intros x τ. rewrite_env (x ~ T τ ++ nil). auto.
Qed.

Lemma zip_Eq : forall a τ, lc_typ τ → zip (a ~ Eq τ) (a ~ Eq τ) (a ~ Eq τ).
Proof.
intros a τ. rewrite_env (a ~ Eq τ ++ nil). auto.
Qed.

Lemma zip_U : forall a, zip (a ~ U) (a ~ U) (a ~ U).
Proof.
intros a. rewrite_env (a ~ (@U typ) ++ nil). auto.
Qed.

Lemma zip_EU : forall a, zip (a ~ E) (a ~ U) (a ~ E).
Proof.
intros a. rewrite_env (a ~ (@U typ) ++ nil). rewrite_env (a ~ (@E typ) ++ nil).  auto.
Qed.

Lemma zip_E : forall a, zip nil (a ~ E) (a ~ E).
Proof.
intros a. rewrite_env (a ~ (@E typ) ++ nil).  auto.
Qed.
Hint Resolve zip_T zip_Eq zip_U zip_EU zip_E: fzip.

(** Lemmas about [ftv_env] *)
Lemma zip_ftv_env1 : forall Γ₁ Γ₂ Γ₃,
  zip Γ₁ Γ₂ Γ₃ → ftv_env Γ₁ [=] ftv_env Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ H. induction H.
rewrite ftv_env_nil. fsetdec.
repeat rewrite ftv_env_app. fsetdec.
repeat rewrite ftv_env_app. fsetdec.
repeat rewrite ftv_env_app. fsetdec.
repeat rewrite ftv_env_app. fsetdec.
repeat rewrite ftv_env_app. fsetdec.
Qed.

Lemma zip_ftv_env2 : forall Γ₁ Γ₂ Γ₃,
  zip Γ₁ Γ₂ Γ₃ → ftv_env Γ₂ [=] ftv_env Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ H. induction H.
rewrite ftv_env_nil. fsetdec.
repeat rewrite ftv_env_app. fsetdec.
repeat rewrite ftv_env_app. fsetdec.
repeat rewrite ftv_env_app. fsetdec.
repeat rewrite ftv_env_app. fsetdec.
repeat rewrite ftv_env_app. fsetdec.
Qed.

(** Lemmas about concatenation of environments *)
Lemma zip_app_inv : forall Γ₁ Γ₂ Γ₃' Γ₃'',
  zip Γ₁ Γ₂ (Γ₃' ++ Γ₃'') →
  exists Γ₁', exists Γ₁'', exists Γ₂', exists Γ₂'',
    Γ₁ = Γ₁' ++ Γ₁'' ∧ Γ₂ = Γ₂' ++ Γ₂'' ∧
    zip Γ₁' Γ₂' Γ₃' ∧ zip Γ₁'' Γ₂'' Γ₃''.
Proof.
intros Γ₁ Γ₂ Γ₃' Γ₃'' H.
dependent induction H; intros.
Case "nil".
exists nil; exists nil; exists nil; exists nil.
destruct Γ₃'; auto; try solve [inversion H].
simpl in H; subst.
intuition auto.
Case "TT".
destruct Γ₃'; simpl_env in *.
exists nil; exists (x ~ T t ++ G1); exists nil; exists (x ~ T t ++ G2).
subst. intuition auto.
inversion H3; subst.
destruct (IHzip Γ₃' Γ₃'') as [? [? [? [? [? [? [? ?]]]]]]]; auto; subst.
exists (x ~ T t ++ x0); exists x1; exists (x ~ T t ++ x2); exists x3.
intuition auto.
Case "UU".
destruct Γ₃'; simpl_env in *.
exists nil; exists (a ~ U ++ G1); exists nil; exists (a ~ U ++ G2).
subst. intuition auto.
inversion H2; subst.
destruct (IHzip Γ₃' Γ₃'') as [? [? [? [? [? [? [? ?]]]]]]]; auto; subst.
exists (a ~ U ++ x); exists x0; exists (a ~ U ++ x1); exists x2.
intuition auto.
Case "EU".
destruct Γ₃'; simpl_env in *.
exists nil; exists (a ~ E ++ G1); exists nil; exists (a ~ U ++ G2).
subst. intuition auto.
inversion H2; subst.
destruct (IHzip Γ₃' Γ₃'') as [? [? [? [? [? [? [? ?]]]]]]]; auto; subst.
exists (a ~ E ++ x); exists x0; exists (a ~ U ++ x1); exists x2.
intuition auto.
Case "E".
destruct Γ₃'; simpl_env in *.
exists nil; exists G1; exists nil; exists (a ~ E ++ G2).
subst. intuition auto.
inversion H2; subst.
destruct (IHzip Γ₃' Γ₃'') as [? [? [? [? [? [? [? ?]]]]]]]; auto; subst.
exists x; exists x0; exists (a ~ E ++ x1) ; exists x2.
intuition auto.
Case "EqEq".
destruct Γ₃'; simpl_env in *.
exists nil; exists (a ~ Eq t ++ G1); exists nil; exists (a ~ Eq t ++ G2).
subst. intuition auto.
inversion H3; subst.
destruct (IHzip Γ₃' Γ₃'') as [? [? [? [? [? [? [? ?]]]]]]]; auto; subst.
exists (a ~ Eq t ++ x); exists x0; exists (a ~ Eq t ++ x1); exists x2.
intuition auto.
Qed.

(** Weakening *)
Lemma zip_app_weakening_strong : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'',
  zip (Γ₁ ++ Γ₁') (Γ₂ ++ Γ₂') (Γ₃ ++ Γ₃') →
  zip Γ₁ Γ₂ Γ₃ →
  zip Γ₁' Γ₂' Γ₃' →
  zip Γ₁'' Γ₂'' Γ₃'' →
  disjoint Γ₁'' (Γ₁ ++ Γ₁') →
  disjoint Γ₂'' (Γ₂ ++ Γ₂') →
  disjoint Γ₃'' (Γ₃ ++ Γ₃') →
  zip (Γ₁ ++ Γ₁'' ++ Γ₁') (Γ₂ ++ Γ₂'' ++ Γ₂') (Γ₃ ++ Γ₃'' ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' H H0 H1 H2 H3 H4 H5.
assert (uniq (Γ₁ ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ Γ₃')) by eauto with lngen.
generalize dependent Γ₃''.
generalize dependent Γ₂''.
generalize dependent Γ₁''.
generalize dependent Γ₃'.
generalize dependent Γ₂'.
generalize dependent Γ₁'.
induction H0; intros; simpl_env in *.
Case "nil". apply zip_app; auto.
Case "TT". constructor; simpl_env; my_auto.
apply IHzip; my_auto. apply zip_app; my_auto.
Case "UU". constructor; simpl_env; my_auto.
apply IHzip; my_auto. apply zip_app; my_auto.
Case "EU". constructor; simpl_env; my_auto.
apply IHzip; my_auto. apply zip_app; my_auto.
Case "E".
assert (dom G1 [<=] dom G) by eauto with fzip.
assert (dom Γ₁' [<=] dom Γ₃') by eauto with fzip.
assert (dom Γ₁'' [<=] dom Γ₃'') by eauto with fzip.
constructor; simpl_env; my_auto.
apply IHzip; my_auto. apply zip_app; my_auto.
Case "Eq". constructor; simpl_env; my_auto.
apply IHzip; my_auto. apply zip_app; my_auto.
Qed.

(** Removing elements *)
Lemma zip_remove_U : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a,
  zip (Γ₁ ++ a ~ U ++ Γ₁') (Γ₂ ++ a ~ U ++ Γ₂') (Γ₃ ++ a ~ U ++ Γ₃') →
  zip (Γ₁ ++ Γ₁') (Γ₂ ++ Γ₂') (Γ₃ ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a H.
assert (uniq (Γ₁ ++ a ~ U ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ a ~ U ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ a ~ U ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
apply zip_app; my_auto.
Qed.

Lemma zip_remove_EU : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a,
  zip (Γ₁ ++ a ~ E ++ Γ₁') (Γ₂ ++ a ~ U ++ Γ₂') (Γ₃ ++ a ~ E ++ Γ₃') →
  zip (Γ₁ ++ Γ₁') (Γ₂ ++ Γ₂') (Γ₃ ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a H.
assert (uniq (Γ₁ ++ a ~ E ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ a ~ U ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ a ~ E ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
Case "EU".
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
apply zip_app; my_auto.
Case "E".
assert (@U typ = E).
apply binds_unique with (x := a) (E := Γ₂ ++ [(a, U)] ++ Γ₂'); auto.
rewrite H4; auto.
congruence.
Qed.

Lemma zip_remove_E : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a,
  zip (Γ₁ ++ Γ₁') (Γ₂ ++ a ~ E ++ Γ₂') (Γ₃ ++ a ~ E ++ Γ₃') →
  zip (Γ₁ ++ Γ₁') (Γ₂ ++ Γ₂') (Γ₃ ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a H.
assert (uniq (Γ₁ ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ a ~ E ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ a ~ E ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
Case "EU".
assert (@E typ = U).
apply binds_unique with (x := a) (E := Γ₂ ++ [(a, E)] ++ Γ₂'); auto.
rewrite H4; auto.
congruence.
Case "E".
apply uniq_app_inv in H4; my_auto.
destruct H4; subst. rewrite H3 in *.
apply zip_app; my_auto.
Qed.

Lemma zip_remove_Eq : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ,
  zip (Γ₁ ++ a ~ Eq τ ++ Γ₁') (Γ₂ ++ a ~ Eq τ ++ Γ₂') (Γ₃ ++ a ~ Eq τ ++ Γ₃') →
  zip (Γ₁ ++ Γ₁') (Γ₂ ++ Γ₂') (Γ₃ ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ H.
assert (uniq (Γ₁ ++ a ~ Eq τ ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ a ~ Eq τ ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ a ~ Eq τ ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
apply zip_app; my_auto.
Qed.

Lemma zip_subst : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' x τ,
  zip (Γ₁ ++ x ~ T τ ++ Γ₁') (Γ₂ ++ x ~ T τ ++ Γ₂') (Γ₃ ++ x ~ T τ ++ Γ₃') →
  zip (Γ₁ ++ Γ₁') (Γ₂ ++ Γ₂') (Γ₃ ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' x τ H.
assert (uniq (Γ₁ ++ [(x, T τ)] ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ [(x, T τ)] ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ [(x, T τ)] ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
apply zip_app; my_auto.
Qed.

(** Stability under substitution *)
Lemma zip_stable_tsubst : forall Γ₁ Γ₂ Γ₃ a τ,
  lc_typ τ →
   zip Γ₁ Γ₂ Γ₃ →
   zip (env_map (tsubst_typ τ a) Γ₁)
       (env_map (tsubst_typ τ a) Γ₂)
       (env_map (tsubst_typ τ a) Γ₃).
Proof.
intros Γ₁ Γ₂ Γ₃ a τ Hlc H. induction H; simpl; simpl_env; auto;
constructor; solve [auto with lngen | unfold env_map; auto with lngen].
Qed.

(** Instantiation with an equation *)
Lemma zip_instantiate : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ,
  lc_typ τ →
  zip (Γ₁ ++ a ~ U ++ Γ₁') (Γ₂ ++ a ~ U ++ Γ₂') (Γ₃ ++ a ~ U ++ Γ₃') →
  zip (Γ₁ ++ a ~ Eq τ ++ Γ₁') (Γ₂ ++ a ~ Eq τ ++ Γ₂') (Γ₃ ++ a ~ Eq τ ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ Hlc H.
assert (uniq (Γ₁ ++ a ~ U ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ a ~ U ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ a ~ U ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
apply zip_app; my_auto.
Qed.

(** Unfolding an equation *)
Lemma zip_subst_eq : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ,
  zip (Γ₁ ++ a ~ Eq τ ++ Γ₁') (Γ₂ ++ a ~ Eq τ ++ Γ₂') (Γ₃ ++ a ~ Eq τ ++ Γ₃') →
  zip (env_map (tsubst_typ τ a) Γ₁ ++ Γ₁')
      (env_map (tsubst_typ τ a) Γ₂ ++ Γ₂')
      (env_map (tsubst_typ τ a) Γ₃ ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ H.
assert (uniq (Γ₁ ++ a ~ Eq τ ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ a ~ Eq τ ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ a ~ Eq τ ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
apply zip_app; auto using zip_stable_tsubst;
  unfold env_map; solve_uniq.
Qed.

Lemma zip_tsubst : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ,
  lc_typ τ →
  zip (Γ₁ ++ a ~ U ++ Γ₁') (Γ₂ ++ a ~ U ++ Γ₂') (Γ₃ ++ a ~ U ++ Γ₃') →
  zip (env_map (tsubst_typ τ a) Γ₁ ++ Γ₁')
      (env_map (tsubst_typ τ a) Γ₂ ++ Γ₂')
      (env_map (tsubst_typ τ a) Γ₃ ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ Hlc H.
auto using zip_subst_eq, zip_instantiate.
Qed.

(** Inversion lemmas wrt concatenation *)
Lemma zip_app_T_inv : forall Γ₁ Γ₂ Γ₃' x τ Γ₃'',
  zip Γ₁ Γ₂ (Γ₃' ++ x ~ T τ ++ Γ₃'') →
  exists Γ₁', exists Γ₁'', exists Γ₂', exists Γ₂'',
    Γ₁ = Γ₁' ++ x ~ T τ ++ Γ₁'' ∧ Γ₂ = Γ₂' ++ x ~ T τ ++ Γ₂''.
Proof.
intros Γ₁ Γ₂ Γ₃' x τ Γ₃'' H.
dependent induction H.
Case "nil". destruct Γ₃'; inversion H.
Case "T". destruct Γ₃'; inversion H3; subst.
exists nil; exists G1; exists nil; exists G2; split; auto.
destruct (IHzip Γ₃' x0 τ Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (x ~ T t ++ x1); exists x2; exists (x ~ T t ++ x3); exists x4; split; auto.
Case "U". destruct Γ₃'; inversion H2; subst.
destruct (IHzip Γ₃' x τ Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (a ~ U ++ x0); exists x1; exists (a ~ U ++ x2); exists x3; split; auto.
Case "EU". destruct Γ₃'; inversion H2; subst.
destruct (IHzip Γ₃' x τ Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (a ~ E ++ x0); exists x1; exists (a ~ U ++ x2); exists x3; split; auto.
Case "E". destruct Γ₃'; inversion H2; subst.
destruct (IHzip Γ₃' x τ Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists x0; exists x1; exists (a ~ E ++ x2); exists x3; split; auto.
Case "Eq". destruct Γ₃'; inversion H3; subst.
destruct (IHzip Γ₃' x τ Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (a ~ Eq t ++ x0); exists x1; exists (a ~ Eq t ++ x2); exists x3; split; auto.
Qed.

Lemma zip_app_Eq_inv : forall Γ₁ Γ₂ Γ₃' a τ Γ₃'',
  zip Γ₁ Γ₂ (Γ₃' ++ a ~ Eq τ ++ Γ₃'') →
  exists Γ₁', exists Γ₁'', exists Γ₂', exists Γ₂'',
    Γ₁ = Γ₁' ++ a ~ Eq τ ++ Γ₁'' ∧ Γ₂ = Γ₂' ++ a ~ Eq τ ++ Γ₂''.
Proof.
intros Γ₁ Γ₂ Γ₃' a τ Γ₃'' H.
dependent induction H.
Case "nil". destruct Γ₃'; inversion H.
Case "T". destruct Γ₃'; inversion H3; subst.
destruct (IHzip Γ₃' a τ Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (x ~ T t ++ x0); exists x1; exists (x ~ T t ++ x2); exists x3; split; auto.
Case "U". destruct Γ₃'; inversion H2; subst.
destruct (IHzip Γ₃' a0 τ Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (a ~ U ++ x); exists x0; exists (a ~ U ++ x1); exists x2; split; auto.
Case "EU". destruct Γ₃'; inversion H2; subst.
destruct (IHzip Γ₃' a0 τ Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (a ~ E ++ x); exists x0; exists (a ~ U ++ x1); exists x2; split; auto.
Case "E". destruct Γ₃'; inversion H2; subst.
destruct (IHzip Γ₃' a0 τ Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists x; exists x0; exists (a ~ E ++ x1); exists x2; split; auto.
Case "Eq". destruct Γ₃'; inversion H3; subst.
exists nil; exists G1; exists nil; exists G2; split; auto.
destruct (IHzip Γ₃' a0 τ Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (a ~ Eq t ++ x); exists x0; exists (a ~ Eq t ++ x1); exists x2; split; auto.
Qed.

Lemma zip_app_U_inv : forall Γ₁ Γ₂ Γ₃' a Γ₃'',
  zip Γ₁ Γ₂ (Γ₃' ++ a ~ U ++ Γ₃'') →
  exists Γ₁', exists Γ₁'', exists Γ₂', exists Γ₂'',
    Γ₁ = Γ₁' ++ a ~ U ++ Γ₁'' ∧ Γ₂ = Γ₂' ++ a ~ U ++ Γ₂''.
Proof.
intros Γ₁ Γ₂ Γ₃' a Γ₃'' H.
dependent induction H.
Case "nil". destruct Γ₃'; inversion H.
Case "T". destruct Γ₃'; inversion H3; subst.
destruct (IHzip Γ₃' a Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (x ~ T t ++ x0); exists x1; exists (x ~ T t ++ x2); exists x3; split; auto.
Case "U". destruct Γ₃'; inversion H2; subst.
exists nil; exists G1; exists nil; exists G2; auto.
destruct (IHzip Γ₃' a0 Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (a ~ U ++ x); exists x0; exists (a ~ U ++ x1); exists x2; split; auto.
Case "EU". destruct Γ₃'; inversion H2; subst.
destruct (IHzip Γ₃' a0 Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (a ~ E ++ x); exists x0; exists (a ~ U ++ x1); exists x2; split; auto.
Case "E". destruct Γ₃'; inversion H2; subst.
destruct (IHzip Γ₃' a0 Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists x; exists x0; exists (a ~ E ++ x1); exists x2; split; auto.
Case "Eq". destruct Γ₃'; inversion H3; subst.
destruct (IHzip Γ₃' a0 Γ₃'') as [? [? [? [? [? ?]]]]]. simpl_env; auto.
subst. exists (a ~ Eq t ++ x); exists x0; exists (a ~ Eq t ++ x1); exists x2; split; auto.
Qed.

(** Renaming lemmas *)
Lemma zip_renameU : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a b,
  b ∉ dom (Γ₁ ++ Γ₁') ∪ dom (Γ₂ ++ Γ₂') ∪ dom (Γ₃ ++ Γ₃') →
  zip (Γ₁ ++ a ~ U ++ Γ₁') (Γ₂ ++ a ~ U ++ Γ₂') (Γ₃ ++ a ~ U ++ Γ₃') →
  zip (env_map (tsubst_typ (typ_var_f b) a) Γ₁ ++ b ~ U ++ Γ₁')
      (env_map (tsubst_typ (typ_var_f b) a) Γ₂ ++ b ~ U ++ Γ₂')
      (env_map (tsubst_typ (typ_var_f b) a) Γ₃ ++ b ~ U ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a b Hb H.
assert (uniq (Γ₁ ++ [(a, U)] ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ [(a, U)] ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ [(a, U)] ++ Γ₃')) by eauto with lngen.
simpl_env in *.
apply zip_app_inv in H. decompose record H; clear H; simpl_env in *.
inversion H7; subst.
apply uniq_app_inv in H3; auto.
apply uniq_app_inv in H4; auto.
destruct H3; destruct H4; subst; auto.
apply zip_app; auto.
  unfold env_map. solve_uniq.
  unfold env_map. solve_uniq.
  unfold env_map. solve_uniq.
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) x ++ nil).
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) x1 ++ nil).
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) Γ₃ ++ nil).
apply zip_tsubst; auto.
simpl_env. apply zip_app; my_auto.
Qed.

Lemma zip_renameEU : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a b,
  b ∉ dom (Γ₁ ++ Γ₁') ∪ dom (Γ₂ ++ Γ₂') ∪ dom (Γ₃ ++ Γ₃') →
  zip (Γ₁ ++ a ~ E ++ Γ₁') (Γ₂ ++ a ~ U ++ Γ₂') (Γ₃ ++ a ~ E ++ Γ₃') →
  zip (env_map (tsubst_typ (typ_var_f b) a) Γ₁ ++ b ~ E ++ Γ₁')
      (env_map (tsubst_typ (typ_var_f b) a) Γ₂ ++ b ~ U ++ Γ₂')
      (env_map (tsubst_typ (typ_var_f b) a) Γ₃ ++ b ~ E ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a b Hb H.
assert (uniq (Γ₁ ++ [(a, E)] ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ [(a, U)] ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ [(a, E)] ++ Γ₃')) by eauto with lngen.
simpl_env in *.
apply zip_app_inv in H. decompose record H; clear H; simpl_env in *.
inversion H7; subst.
SCase "EU".
apply uniq_app_inv in H3; auto.
apply uniq_app_inv in H4; auto.
destruct H3; destruct H4; subst; auto.
apply zip_app; auto.
  unfold env_map. solve_uniq.
  unfold env_map. solve_uniq.
  unfold env_map. solve_uniq.
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) x ++ nil).
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) x1 ++ nil).
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) Γ₃ ++ nil).
apply zip_tsubst; auto.
simpl_env. apply zip_app; my_auto.
SCase "E (absurd)".
assert (@U typ = @E typ). apply binds_unique with (x := a) (E := Γ₂ ++ [(a, U)] ++ Γ₂'); auto.
  rewrite H4; auto.
congruence.
Qed.

Lemma zip_renameE : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a b,
  b ∉ dom (Γ₁ ++ Γ₁') ∪ dom (Γ₂ ++ Γ₂') ∪ dom (Γ₃ ++ Γ₃') →
  zip Γ₁ Γ₂ Γ₃ → zip Γ₁' Γ₂' Γ₃' →
  zip (Γ₁ ++ Γ₁') (Γ₂ ++ a ~ E ++ Γ₂') (Γ₃ ++ a ~ E ++ Γ₃') →
  zip (env_map (tsubst_typ (typ_var_f b) a) Γ₁ ++ Γ₁')
      (env_map (tsubst_typ (typ_var_f b) a) Γ₂ ++ b ~ E ++ Γ₂')
      (env_map (tsubst_typ (typ_var_f b) a) Γ₃ ++ b ~ E ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a b Hb Hzip1 Hzip2 H.
assert (uniq (Γ₁ ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ [(a, E)] ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ [(a, E)] ++ Γ₃')) by eauto with lngen.
simpl_env in *.
apply zip_app; auto.
  unfold env_map. solve_uniq.
  unfold env_map. solve_uniq.
  unfold env_map. solve_uniq.
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) Γ₁ ++ nil).
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) Γ₂ ++ nil).
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) Γ₃ ++ nil).
apply zip_tsubst; auto.
simpl_env. apply zip_app.
  assert (dom Γ₁ [<=] dom Γ₃) by eauto with fzip. destruct_uniq; fsetdec.
  assert (dom Γ₂ [=] dom Γ₃) by eauto with fzip. destruct_uniq; fsetdec.
  solve_uniq.
  auto.
  my_auto.
Qed.

Lemma zip_renameEq : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a b τ,
  b ∉ dom (Γ₁ ++ Γ₁') ∪ dom (Γ₂ ++ Γ₂') ∪ dom (Γ₃ ++ Γ₃') →
  zip (Γ₁ ++ a ~ Eq τ ++ Γ₁') (Γ₂ ++ a ~ Eq τ ++ Γ₂') (Γ₃ ++ a ~ Eq τ ++ Γ₃') →
  zip (env_map (tsubst_typ (typ_var_f b) a) Γ₁ ++ b ~ Eq τ ++ Γ₁')
      (env_map (tsubst_typ (typ_var_f b) a) Γ₂ ++ b ~ Eq τ ++ Γ₂')
      (env_map (tsubst_typ (typ_var_f b) a) Γ₃ ++ b ~ Eq τ ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a b τ Hb H.
assert (uniq (Γ₁ ++ [(a, Eq τ)] ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ [(a, Eq τ)] ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ [(a, Eq τ)] ++ Γ₃')) by eauto with lngen.
simpl_env in *.
apply zip_app_inv in H. decompose record H; clear H; simpl_env in *.
inversion H7; subst.
apply uniq_app_inv in H3; auto.
apply uniq_app_inv in H4; auto.
destruct H3; destruct H4; subst; auto.
apply zip_app; auto.
  unfold env_map. solve_uniq.
  unfold env_map. solve_uniq.
  unfold env_map. solve_uniq.
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) x ++ nil).
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) x1 ++ nil).
rewrite_env (env_map (tsubst_typ (typ_var_f b) a) Γ₃ ++ nil).
apply zip_tsubst; auto.
simpl_env. apply zip_app; my_auto.
Qed.

(** Lemmas resulting from the combination of removal and inversion *)
Lemma zip_remove_T1 : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' x τ,
  zip (Γ₁ ++ x ~ T τ ++ Γ₁') (Γ₂ ++ x ~ T τ ++ Γ₂') (Γ₃ ++ x ~ T τ ++ Γ₃') →
  zip Γ₁ Γ₂ Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' x τ H.
assert (uniq (Γ₁ ++ x ~ T τ ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ x ~ T τ ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ x ~ T τ ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
auto.
Qed.

Lemma zip_remove_T2 : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' x τ,
  zip (Γ₁ ++ x ~ T τ ++ Γ₁') (Γ₂ ++ x ~ T τ ++ Γ₂') (Γ₃ ++ x ~ T τ ++ Γ₃') →
  zip Γ₁' Γ₂' Γ₃'.
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' x τ H.
assert (uniq (Γ₁ ++ x ~ T τ ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ x ~ T τ ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ x ~ T τ ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
auto.
Qed.

Lemma zip_remove_U1 : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a,
  zip (Γ₁ ++ a ~ U ++ Γ₁') (Γ₂ ++ a ~ U ++ Γ₂') (Γ₃ ++ a ~ U ++ Γ₃') →
  zip Γ₁ Γ₂ Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a H.
assert (uniq (Γ₁ ++ a ~ U ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ a ~ U ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ a ~ U ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
auto.
Qed.

Lemma zip_remove_U2 : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a,
  zip (Γ₁ ++ a ~ U ++ Γ₁') (Γ₂ ++ a ~ U ++ Γ₂') (Γ₃ ++ a ~ U ++ Γ₃') →
  zip Γ₁' Γ₂' Γ₃'.
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a H.
assert (uniq (Γ₁ ++ a ~ U ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ a ~ U ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ a ~ U ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
auto.
Qed.

Lemma zip_remove_Eq1 : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ,
  zip (Γ₁ ++ a ~ Eq τ ++ Γ₁') (Γ₂ ++ a ~ Eq τ ++ Γ₂') (Γ₃ ++ a ~ Eq τ ++ Γ₃') →
  zip Γ₁ Γ₂ Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ H.
assert (uniq (Γ₁ ++ a ~ Eq τ ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ a ~ Eq τ ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ a ~ Eq τ ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
auto.
Qed.

Lemma zip_remove_Eq2 : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ,
  zip (Γ₁ ++ a ~ Eq τ ++ Γ₁') (Γ₂ ++ a ~ Eq τ ++ Γ₂') (Γ₃ ++ a ~ Eq τ ++ Γ₃') →
  zip Γ₁' Γ₂' Γ₃'.
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ H.
assert (uniq (Γ₁ ++ a ~ Eq τ ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ a ~ Eq τ ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ a ~ Eq τ ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; my_auto.
apply uniq_app_inv in H3; my_auto.
destruct H4; destruct H3; subst.
auto.
Qed.

(** Other inversion lemmas wrt concatenation *)
Lemma zip_app_inv_strong : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'',
  zip Γ₁ Γ₂ Γ₃ →
  zip (Γ₁' ++ Γ₁ ++ Γ₁'') (Γ₂' ++ Γ₂ ++ Γ₂'') (Γ₃' ++ Γ₃ ++ Γ₃'') →
  zip (Γ₁' ++ Γ₁'') (Γ₂' ++ Γ₂'') (Γ₃' ++ Γ₃'').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' H H0.
induction H; simpl_env in *; auto; apply IHzip.
eauto using zip_subst.
eauto using zip_remove_U.
eauto using zip_remove_EU.
eauto using zip_remove_E.
eauto using zip_remove_Eq.
Qed.

Lemma zip_app_inv1 : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃',
  zip Γ₁ Γ₂ Γ₃ →
  zip (Γ₁ ++ Γ₁') (Γ₂ ++ Γ₂') (Γ₃ ++ Γ₃') →
  zip Γ₁' Γ₂' Γ₃'.
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' H H0.
rewrite_env (nil ++ Γ₁ ++ Γ₁') in H0.
rewrite_env (nil ++ Γ₂ ++ Γ₂') in H0.
rewrite_env (nil ++ Γ₃ ++ Γ₃') in H0.
apply zip_app_inv_strong in H0; auto.
Qed.

Lemma zip_app_inv2 : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃',
  zip Γ₁' Γ₂' Γ₃' →
  zip (Γ₁ ++ Γ₁') (Γ₂ ++ Γ₂') (Γ₃ ++ Γ₃') →
  zip Γ₁ Γ₂ Γ₃.
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' H H0.
rewrite_env (Γ₁ ++ Γ₁' ++ nil) in H0.
rewrite_env (Γ₂ ++ Γ₂' ++ nil) in H0.
rewrite_env (Γ₃ ++ Γ₃' ++ nil) in H0.
apply zip_app_inv_strong in H0; auto.
simpl_env in H0; auto.
Qed.

(** Lemmas about swapping of elements within environements *)
Lemma zip_upperU : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a,
  zip (Γ₁ ++ a ~ U ++ Γ₁' ++ Γ₁'')
      (Γ₂ ++ a ~ U ++ Γ₂' ++ Γ₂'')
      (Γ₃ ++ a ~ U ++ Γ₃' ++ Γ₃'') →
  zip Γ₁' Γ₂' Γ₃' →
  zip Γ₁'' Γ₂'' Γ₃'' →
  zip (Γ₁ ++ Γ₁' ++ a ~ U ++ Γ₁'')
      (Γ₂ ++ Γ₂' ++ a ~ U ++ Γ₂'')
      (Γ₃ ++ Γ₃' ++ a ~ U ++ Γ₃'').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a H H' H''.
assert (uniq (Γ₁ ++ [(a, U)] ++ Γ₁' ++ Γ₁'')) by eauto with lngen.
assert (uniq (Γ₂ ++ [(a, U)] ++ Γ₂' ++ Γ₂'')) by eauto with lngen.
assert (uniq (Γ₃ ++ [(a, U)] ++ Γ₃' ++ Γ₃'')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; auto.
apply uniq_app_inv in H3; auto.
destruct H4; destruct H3; subst.
apply zip_app; my_auto.
apply zip_app; my_auto.
Qed.

Lemma zip_upperEU : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a,
  zip (Γ₁ ++ a ~ E ++ Γ₁' ++ Γ₁'')
      (Γ₂ ++ a ~ U ++ Γ₂' ++ Γ₂'')
      (Γ₃ ++ a ~ E ++ Γ₃' ++ Γ₃'') →
  zip Γ₁' Γ₂' Γ₃' →
  zip Γ₁'' Γ₂'' Γ₃'' →
  zip (Γ₁ ++ Γ₁' ++ a ~ E ++ Γ₁'')
      (Γ₂ ++ Γ₂' ++ a ~ U ++ Γ₂'')
      (Γ₃ ++ Γ₃' ++ a ~ E ++ Γ₃'').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a H H' H''.
assert (uniq (Γ₁ ++ [(a, E)] ++ Γ₁' ++ Γ₁'')) by eauto with lngen.
assert (uniq (Γ₂ ++ [(a, U)] ++ Γ₂' ++ Γ₂'')) by eauto with lngen.
assert (uniq (Γ₃ ++ [(a, E)] ++ Γ₃' ++ Γ₃'')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
Case "EU".
apply uniq_app_inv in H4; auto.
apply uniq_app_inv in H3; auto.
destruct H4; destruct H3; subst.
apply zip_app; my_auto.
apply zip_app; my_auto.
Case "E".
assert (@E typ = U).
apply binds_unique with (x := a) (E := Γ₂ ++ [(a, U)] ++ Γ₂' ++ Γ₂''); auto.
rewrite H4; auto.
congruence.
Qed.

Lemma zip_upperE : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a,
  zip (Γ₁ ++ Γ₁' ++ Γ₁'')
      (Γ₂ ++ a ~ E ++ Γ₂' ++ Γ₂'')
      (Γ₃ ++ a ~ E ++ Γ₃' ++ Γ₃'') →
  zip Γ₁' Γ₂' Γ₃' →
  zip Γ₁'' Γ₂'' Γ₃'' →
  zip (Γ₁ ++ Γ₁' ++ Γ₁'')
      (Γ₂ ++ Γ₂' ++ a ~ E ++ Γ₂'')
      (Γ₃ ++ Γ₃' ++ a ~ E ++ Γ₃'').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a H H' H''.
assert (uniq (Γ₁ ++ Γ₁' ++ Γ₁'')) by eauto with lngen.
assert (uniq (Γ₂ ++ [(a, E)] ++ Γ₂' ++ Γ₂'')) by eauto with lngen.
assert (uniq (Γ₃ ++ [(a, E)] ++ Γ₃' ++ Γ₃'')) by eauto with lngen.
assert (a ∉ dom (Γ₁ ++ Γ₁' ++ Γ₁'')).
  assert (binds a E (Γ₃ ++ [(a, E)] ++ Γ₃' ++ Γ₃'')) by auto.
  eapply zip_binds_E3_inv in H3; eauto. destruct H3 as [[? ?] | [? ?]]; auto.
  elimtype False. analyze_binds_uniq H4; auto.
assert (zip Γ₁ Γ₂ Γ₃).
  eapply zip_app_inv2 with (Γ₁' := Γ₁' ++ Γ₁''); eauto.
  constructor; auto. solve_uniq.
  apply zip_app; my_auto.
apply zip_app; try solve_uniq.
apply zip_app; try solve_uniq.
Qed.

Lemma zip_lowerU : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a,
  zip (Γ₁ ++ Γ₁' ++ a ~ U ++ Γ₁'')
      (Γ₂ ++ Γ₂' ++ a ~ U ++ Γ₂'')
      (Γ₃ ++ Γ₃' ++ a ~ U ++ Γ₃'') →
  zip Γ₁' Γ₂' Γ₃' →
  zip Γ₁'' Γ₂'' Γ₃'' →
  zip (Γ₁ ++ a ~ U ++ Γ₁' ++ Γ₁'')
      (Γ₂ ++ a ~ U ++ Γ₂' ++ Γ₂'')
      (Γ₃ ++ a ~ U ++ Γ₃' ++ Γ₃'').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a H H' H''.
assert (uniq (Γ₁ ++ Γ₁' ++ [(a, U)] ++ Γ₁'')) by eauto with lngen.
assert (uniq (Γ₂ ++ Γ₂' ++ [(a, U)] ++ Γ₂'')) by eauto with lngen.
assert (uniq (Γ₃ ++ Γ₃' ++ [(a, U)] ++ Γ₃'')) by eauto with lngen.
rewrite_env ((Γ₁ ++ Γ₁') ++ [(a, U)] ++ Γ₁'') in H.
rewrite_env ((Γ₂ ++ Γ₂') ++ [(a, U)] ++ Γ₂'') in H.
rewrite_env ((Γ₃ ++ Γ₃') ++ [(a, U)] ++ Γ₃'') in H.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
apply uniq_app_inv in H4; simpl_env; auto.
apply uniq_app_inv in H3; simpl_env; auto.
destruct H4; destruct H3; subst.
apply zip_app_inv2 in H5; auto.
apply zip_app; my_auto.
apply zip_app; my_auto.
apply zip_app; my_auto.
Qed.

Lemma zip_lowerEU : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a,
  zip (Γ₁ ++ Γ₁' ++ a ~ E ++ Γ₁'')
      (Γ₂ ++ Γ₂' ++ a ~ U ++ Γ₂'')
      (Γ₃ ++ Γ₃' ++ a ~ E ++ Γ₃'') →
  zip Γ₁' Γ₂' Γ₃' →
  zip Γ₁'' Γ₂'' Γ₃'' →
  zip (Γ₁ ++ a ~ E ++ Γ₁' ++ Γ₁'')
      (Γ₂ ++ a ~ U ++ Γ₂' ++ Γ₂'')
      (Γ₃ ++ a ~ E ++ Γ₃' ++ Γ₃'').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a H H' H''.
assert (uniq (Γ₁ ++ Γ₁' ++ [(a, E)] ++ Γ₁'')) by eauto with lngen.
assert (uniq (Γ₂ ++ Γ₂' ++ [(a, U)] ++ Γ₂'')) by eauto with lngen.
assert (uniq (Γ₃ ++ Γ₃' ++ [(a, E)] ++ Γ₃'')) by eauto with lngen.
rewrite_env ((Γ₁ ++ Γ₁') ++ [(a, E)] ++ Γ₁'') in H.
rewrite_env ((Γ₂ ++ Γ₂') ++ [(a, U)] ++ Γ₂'') in H.
rewrite_env ((Γ₃ ++ Γ₃') ++ [(a, E)] ++ Γ₃'') in H.
apply zip_app_inv in H. decompose record H; clear H.
inversion H7; subst.
Case "EU".
apply uniq_app_inv in H4; simpl_env; auto.
apply uniq_app_inv in H3; simpl_env; auto.
destruct H4; destruct H3; subst.
apply zip_app_inv2 in H5; auto.
apply zip_app; my_auto.
apply zip_app; my_auto.
apply zip_app; my_auto.
Case "E".
assert (@E typ = U). simpl_env in *.
apply binds_unique with (x := a) (E := Γ₂ ++ Γ₂' ++ [(a, U)] ++ Γ₂''); auto.
rewrite H4; auto.
congruence.
Qed.

Lemma zip_lowerE : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a,
  zip (Γ₁ ++ Γ₁' ++ Γ₁'')
      (Γ₂ ++ Γ₂' ++ a ~ E ++ Γ₂'')
      (Γ₃ ++ Γ₃' ++ a ~ E ++ Γ₃'') →
  zip Γ₁' Γ₂' Γ₃' →
  zip Γ₁'' Γ₂'' Γ₃'' →
  zip (Γ₁ ++ Γ₁' ++ Γ₁'')
      (Γ₂ ++ a ~ E ++ Γ₂' ++ Γ₂'')
      (Γ₃ ++ a ~ E ++ Γ₃' ++ Γ₃'').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' Γ₁'' Γ₂'' Γ₃'' a H H' H''.
assert (uniq (Γ₁ ++ Γ₁' ++ Γ₁'')) by eauto with lngen.
assert (uniq (Γ₂ ++ Γ₂' ++ [(a, E)] ++ Γ₂'')) by eauto with lngen.
assert (uniq (Γ₃ ++ Γ₃' ++ [(a, E)] ++ Γ₃'')) by eauto with lngen.
assert (a ∉ dom (Γ₁ ++ Γ₁' ++ Γ₁'')).
  assert (binds a E (Γ₃ ++ Γ₃' ++ [(a, E)] ++ Γ₃'')) by auto.
  eapply zip_binds_E3_inv in H3; eauto. destruct H3 as [[? ?] | [? ?]]; auto.
  elimtype False. analyze_binds_uniq H4; auto. solve_uniq.
assert (zip Γ₁ Γ₂ Γ₃).
  eapply zip_app_inv2 with (Γ₁' := Γ₁' ++ Γ₁''); eauto.
  apply zip_app; my_auto.
apply zip_app; try solve_uniq.
constructor; my_auto.
apply zip_app; try solve_uniq.
Qed.

Lemma zip_swap_Eq : forall Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ a' τ',
  zip (Γ₁ ++ a ~ Eq τ ++ a' ~ Eq τ' ++ Γ₁')
      (Γ₂ ++ a ~ Eq τ ++ a' ~ Eq τ' ++ Γ₂')
      (Γ₃ ++ a ~ Eq τ ++ a' ~ Eq τ' ++ Γ₃') →
  zip (Γ₁ ++ a' ~ Eq τ' ++ a ~ Eq (tsubst_typ τ' a' τ) ++ Γ₁')
      (Γ₂ ++ a' ~ Eq τ' ++ a ~ Eq (tsubst_typ τ' a' τ) ++ Γ₂')
      (Γ₃ ++ a' ~ Eq τ' ++ a ~ Eq (tsubst_typ τ' a' τ) ++ Γ₃').
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₁' Γ₂' Γ₃' a τ a' τ' H.
assert (uniq (Γ₁ ++ [(a, Eq τ)] ++ [(a', Eq τ')] ++ Γ₁')) by eauto with lngen.
assert (uniq (Γ₂ ++ [(a, Eq τ)] ++ [(a', Eq τ')] ++ Γ₂')) by eauto with lngen.
assert (uniq (Γ₃ ++ [(a, Eq τ)] ++ [(a', Eq τ')] ++ Γ₃')) by eauto with lngen.
apply zip_app_inv in H. decompose record H; clear H; subst.
inversion H7; subst. inversion H14; subst.
apply uniq_app_inv in H3; auto. apply uniq_app_inv in H4; auto.
destruct H3; destruct H4; subst. inversion H6; inversion H3; subst.
apply zip_app; my_auto.
Qed.

(** Distributivity of zip *)
Lemma zip_distrib : forall Γ₁ Γ₂ Γ₃ Γ₂₃ Γ₁₂₃,
  zip Γ₁ Γ₂₃ Γ₁₂₃ → zip Γ₂ Γ₃ Γ₂₃ → pure Γ₁ →
  exists Γ₁₂, exists Γ₁', exists Γ₁₃,
    zip Γ₁ Γ₂ Γ₁₂ ∧ zip Γ₁' Γ₃ Γ₁₃ ∧ zip Γ₁₂ Γ₁₃ Γ₁₂₃ ∧ weakenU Γ₁' Γ₁.
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₂₃ Γ₁₂₃ H H0 H1.
generalize dependent Γ₁₂₃. generalize dependent Γ₁.
induction H0; intros.
Case "nil". inversion H; subst; eauto 9.
Case "T". inversion H4; subst.
edestruct IHzip with (Γ₁ := G0) as [? [? [? [? [? [? ?]]]]]]; eauto; clear IHzip.
intros a Ha; eapply (H3 a); auto.
exists (x ~ T t ++ x0). exists (x ~ T t ++ x1). exists (x ~ T t ++ x2).
split. auto. split.
constructor; auto. assert (dom x1 [<=] dom x2) by eauto with fzip.
  assert (dom x2 [=] dom G4) by eauto with fzip.
  assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
split. constructor; auto.
  assert (dom x0 [<=] dom G4) by eauto with fzip.
    assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
  assert (dom x2 [=] dom G4) by eauto with fzip.
    assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
constructor; auto. assert (dom x1 [<=] dom x2) by eauto with fzip.
  assert (dom x2 [=] dom G4) by eauto with fzip.
  assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
Case "U". inversion H3; subst.
edestruct IHzip with (Γ₁ := G0) as [? [? [? [? [? [? ?]]]]]]; eauto; clear IHzip.
intros b Hb; eapply (H2 b); auto.
exists (a ~ U ++ x). exists (a ~ U ++ x0). exists (a ~ U ++ x1).
split; auto. split.
constructor; auto. assert (dom x0 [<=] dom x1) by eauto with fzip.
  assert (dom x1 [=] dom G4) by eauto with fzip.
  assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
split. constructor; auto.
  assert (dom x [<=] dom G4) by eauto with fzip.
    assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
  assert (dom x1 [=] dom G4) by eauto with fzip.
    assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
constructor; auto. assert (dom x0 [<=] dom x1) by eauto with fzip.
  assert (dom x1 [=] dom G4) by eauto with fzip.
  assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
elimtype False. eapply (H2 a); auto.
Case "EU". inversion H3; subst.
edestruct IHzip as [? [? [? [? [? [? ?]]]]]]; eauto; clear IHzip.
exists (a ~ E ++ x). exists (a ~ U ++ x0). exists (a ~ U ++ x1).
split. auto.
split. constructor; auto. assert (dom x0 [<=] dom x1) by eauto with fzip.
  assert (dom x1 [=] dom G4) by eauto with fzip.
  assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
split. constructor; auto.
  assert (dom x [<=] dom G4) by eauto with fzip.
    assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
  assert (dom x1 [=] dom G4) by eauto with fzip.
    assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
constructor; auto. assert (dom x0 [<=] dom x1) by eauto with fzip.
  assert (dom x1 [=] dom G4) by eauto with fzip.
  assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
Case "E". inversion H3; subst.
edestruct IHzip as [? [? [? [? [? [? ?]]]]]]; eauto; clear IHzip.
exists x. exists x0. exists (a ~ E ++ x1).
split. auto. split.
constructor; auto. assert (dom x0 [<=] dom x1) by eauto with fzip.
  assert (dom x1 [=] dom G4) by eauto with fzip.
  assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
split. constructor; auto.
  assert (dom x [<=] dom G4) by eauto with fzip.
    assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
  assert (dom x1 [=] dom G4) by eauto with fzip.
    assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
auto.
Case "Eq". inversion H4; subst.
edestruct IHzip with (Γ₁ := G0) as [? [? [? [? [? [? ?]]]]]]; eauto; clear IHzip.
intros b Hb; eapply (H3 b); auto.
exists (a ~ Eq t ++ x). exists (a ~ Eq t ++ x0). exists (a ~ Eq t ++ x1).
split. auto. split.
constructor; auto. assert (dom x0 [<=] dom x1) by eauto with fzip.
  assert (dom x1 [=] dom G4) by eauto with fzip.
  assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
split. constructor; auto.
  assert (dom x [<=] dom G4) by eauto with fzip.
    assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
  assert (dom x1 [=] dom G4) by eauto with fzip.
    assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
constructor; auto.  assert (dom x0 [<=] dom x1) by eauto with fzip.
  assert (dom x1 [=] dom G4) by eauto with fzip.
  assert (dom G [=] dom G4) by eauto with fzip. fsetdec.
Qed.

(** Lemma about [weakenU] *)
Lemma zip_weakenU_inv : forall Γ₁ Γ₂ Γ₃ Γ₃',
  zip Γ₁ Γ₂ Γ₃ → weakenU Γ₃' Γ₃ →
  exists Γ₁', exists Γ₂', zip Γ₁' Γ₂' Γ₃' ∧
    weakenU Γ₁' Γ₁ ∧ weakenU Γ₂' Γ₂.
Proof.
intros Γ₁ Γ₂ Γ₃ Γ₃' H H0.
generalize dependent Γ₂. generalize dependent Γ₁.
induction H0; intros.
Case "nil". inversion H; subst; eauto.
Case "T". inversion H2; subst.
destruct (IHweakenU G0 G3) as [? [? [? [? ?]]]]; auto; clear IHweakenU.
assert (x ∉ dom x0).
  assert (dom x0 [<=] dom G1) by eauto with fzip. fsetdec.
assert (x ∉ dom x1).
  assert (dom x1 [=] dom G1) by eauto with fzip. fsetdec.
exists (x ~ T t ++ x0). exists (x ~ T t ++ x1). auto.
Case "U". inversion H1; subst.
destruct (IHweakenU G0 G3) as [? [? [? [? ?]]]]; auto; clear IHweakenU.
assert (a ∉ dom x).
  assert (dom x [<=] dom G1) by eauto with fzip. fsetdec.
assert (a ∉ dom x0).
  assert (dom x0 [=] dom G1) by eauto with fzip. fsetdec.
exists (a ~ U ++ x). exists (a ~ U ++ x0). auto.
Case "E". inversion H1; subst.
SCase "EU".
destruct (IHweakenU G0 G3) as [? [? [? [? ?]]]]; auto; clear IHweakenU.
assert (a ∉ dom x).
  assert (dom x [<=] dom G1) by eauto with fzip. fsetdec.
assert (a ∉ dom x0).
  assert (dom x0 [=] dom G1) by eauto with fzip. fsetdec.
exists (a ~ E ++ x). exists (a ~ U ++ x0). auto.
SCase "E".
destruct (IHweakenU Γ₁ G3) as [? [? [? [? ?]]]]; auto; clear IHweakenU.
assert (a ∉ dom x).
  assert (dom x [<=] dom G1) by eauto with fzip. fsetdec.
assert (a ∉ dom x0).
  assert (dom x0 [=] dom G1) by eauto with fzip. fsetdec.
exists x. exists (a ~ E ++ x0). auto.
Case "Eq". inversion H2; subst.
destruct (IHweakenU G0 G3) as [? [? [? [? ?]]]]; auto; clear IHweakenU.
assert (a ∉ dom x).
  assert (dom x [<=] dom G1) by eauto with fzip. fsetdec.
assert (a ∉ dom x0).
  assert (dom x0 [=] dom G1) by eauto with fzip. fsetdec.
exists (a ~ Eq t ++ x). exists (a ~ Eq t ++ x0). auto.
Case "weaken".
destruct (IHweakenU Γ₁ Γ₂) as [? [? [? [? ?]]]]; auto; clear IHweakenU.
assert (a ∉ dom x).
  assert (dom x [<=] dom G1) by eauto with fzip. fsetdec.
assert (a ∉ dom x0).
  assert (dom x0 [=] dom G1) by eauto with fzip. fsetdec.
exists (a ~ U ++ x). exists (a ~ U ++ x0). auto.
Qed.


From Coq Require Import Nat ZArith Bool.

Require Export MCPrelude
        MCReflect
        All_Forall
        MCArith
        MCCompare
        MCEquality
        MCList
        MCOption
        MCProd
        MCSquash
        MCRelations
        MCString
        MCTactics.InHypUnderBindersDo
        MCTactics.SpecializeUnderBindersBy
        MCTactics.Zeta1
        MCTactics.DestructHead
        MCTactics.SpecializeAllWays
        MCTactics.SplitInContext
        MCTactics.Head
        MCTactics.SpecializeBy
        MCTactics.UniquePose
        ReflectEq
        bytestring
.

Tactic Notation "destruct" "?" :=
  let E := fresh "E" in
  match goal with
    [ |- context[match ?X with _ => _ end]] => destruct X eqn:E
  | [ H : context[match ?X with _ => _ end] |- _] => destruct X eqn:E
  end.

Tactic Notation "destruct" "?" "in" hyp(H) :=
  let e := fresh "E" in
  match type of H with context [match ?x with _ => _ end] => destruct x eqn:e
  end.

Ltac cbnr := cbn; try reflexivity.

Ltac rdestruct H :=
  match type of H with
  | _ \/ _ => destruct H as [H|H]; [rdestruct H|rdestruct H]
  | _ /\ _ => let H' := fresh H in
            destruct H as [H|H']; [rdestruct H|rdestruct H']
  | prod _ _ => let H' := fresh H in
            destruct H as [H H']; rdestruct H; rdestruct H'
  | sigT _ => let H' := fresh H in
             destruct H as [H H']; rdestruct H; rdestruct H'
  | _ => idtac
  end.

(* This is an attempt to overcome the fact that auto/eauto *)
(* do not deal with products *)
Ltac rdest :=
  repeat match goal with
  | H : _ /\ _ |- _ => destruct H
  | H : prod _ _ |- _ => destruct H
  | H : sigT _ |- _ => destruct H
  | |- _ /\ _ => split
  | |- prod _ _ => split
  | |- sigT _ => eexists
  end.

Tactic Notation "toProp" ident(H) :=
  match type of H with
  | is_true (_ <? _)%nat => apply PeanoNat.Nat.ltb_lt in H
  | is_true (_ <=? _)%nat => apply PeanoNat.Nat.leb_le in H
  | is_true (_ =? _)%nat => apply PeanoNat.Nat.eqb_eq in H
  | (_ <? _)%nat  = true => apply PeanoNat.Nat.ltb_lt in H
  | (_ <=? _)%nat = true => apply PeanoNat.Nat.leb_le in H
  | (_ =? _)%nat  = true => apply PeanoNat.Nat.eqb_eq in H
  | (_ <? _)%nat  = false => apply PeanoNat.Nat.ltb_ge in H
  | (_ <=? _)%nat = false => apply PeanoNat.Nat.leb_gt in H
  | (_ =? _)%nat  = false => apply PeanoNat.Nat.eqb_neq in H

  | is_true (_ <? _)%Z => apply Z.ltb_lt in H
  | is_true (_ <=? _)%Z => apply Z.leb_le in H
  | is_true (_ =? _)%Z => apply Z.eqb_eq in H
  | (_ <? _)%Z  = true => apply Z.ltb_lt in H
  | (_ <=? _)%Z = true => apply Z.leb_le in H
  | (_ =? _)%Z  = true => apply Z.eqb_eq in H
  | (_ <? _)%Z  = false => apply Z.ltb_ge in H
  | (_ <=? _)%Z = false => apply Z.leb_gt in H
  | (_ =? _)%Z  = false => apply Z.eqb_neq in H

  | is_true (_ && _) => apply andb_true_iff in H
  | (_ && _) = true  => apply andb_true_iff in H
  | (_ && _) = false  => apply andb_false_iff in H

  | is_true (_ || _) => apply orb_true_iff in H
  | (_ || _) = true  => apply orb_true_iff in H
  | (_ || _) = false  => apply orb_false_iff in H
  end.

Tactic Notation "toProp" :=
  match goal with
  | |- is_true (_ <? _)%nat => apply PeanoNat.Nat.ltb_lt
  | |- is_true (_ <=? _)%nat => apply PeanoNat.Nat.leb_le
  | |- is_true (_ =? _)%nat => apply PeanoNat.Nat.eqb_eq
  | |- (_ <? _)%nat  = true => apply PeanoNat.Nat.ltb_lt
  | |- (_ <=? _)%nat = true => apply PeanoNat.Nat.leb_le
  | |- (_ =? _)%nat  = true => apply PeanoNat.Nat.eqb_eq
  | |- ( _ <? _)%nat  = false => apply PeanoNat.Nat.ltb_ge
  | |- (_ <=? _)%nat = false => apply PeanoNat.Nat.leb_gt
  | |- (_ =? _)%nat  = false => apply PeanoNat.Nat.eqb_neq

  | |- is_true (_ <? _)%Z => apply Z.ltb_lt
  | |- is_true (_ <=? _)%Z => apply Z.leb_le
  | |- is_true (_ =? _)%Z => apply Z.eqb_eq
  | |- (_ <? _)%Z  = true => apply Z.ltb_lt
  | |- (_ <=? _)%Z = true => apply Z.leb_le
  | |- (_ =? _)%Z  = true => apply Z.eqb_eq
  | |- (_ <? _)%Z  = false => apply Z.ltb_ge
  | |- (_ <=? _)%Z = false => apply Z.leb_gt
  | |- (_ =? _)%Z  = false => apply Z.eqb_neq

  | |- is_true (_ && _) => apply andb_true_iff; split
  | |- (_ && _) = true => apply andb_true_iff; split

  | |- is_true (_ || _) => apply orb_true_iff
  | |- (_ || _) = true => apply orb_true_iff

  | H : _ |- _ => toProp H
  end.

Tactic Notation "toProp" ident(H) "as" simple_intropattern(X) :=
   match type of H with
   | is_true (_ && _) => apply andb_true_iff in H; destruct H as X
   | (_ && _) = true  => apply andb_true_iff in H; destruct H as X
   | (_ && _) = false  => apply andb_false_iff in H; destruct H as X

   | is_true (_ || _) => apply orb_true_iff in H; destruct H as X
   | (_ || _) = true  => apply orb_true_iff in H; destruct H as X
   | (_ || _) = false  => apply orb_false_iff in H; destruct H as X
   end.

Tactic Notation "toProp" "as" simple_intropattern(X) :=
  match goal with
  | H : _ |- _ => toProp H as X
  end.

Ltac rtoProp :=
  repeat match goal with
  | H : is_true (_ && _) |- _ => apply andb_and in H; destruct H
  | |- context [is_true (_ && _)] => rewrite andb_and
  end.

Class Fuel := fuel : nat.

(** Such a useful tactic it should be part of the stdlib. *)
Ltac forward_gen H tac :=
  match type of H with
  | ?X -> _ => let H' := fresh in assert (H':X) ; [tac|specialize (H H'); clear H']
  end.

Ltac inv H := inversion_clear H.

Tactic Notation "forward" constr(H) := forward_gen H ltac:(idtac).
Tactic Notation "forward" constr(H) "by" tactic(tac) := forward_gen H tac.

#[global]
Hint Resolve Peano_dec.eq_nat_dec : eq_dec.

Ltac invs H := inversion H; subst; clear H.

Ltac generalize_eq x t :=
  set (x := t) in *; cut (x = t); [|reflexivity]; clearbody x.

Lemma iff_forall {A} B C (H : forall x : A, B x <-> C x)
  : (forall x, B x) <-> (forall x, C x).
  firstorder.
Defined.

Lemma iff_ex {A} B C (H : forall x : A, B x <-> C x)
  : (ex B) <-> (ex C).
  firstorder.
Defined.

Lemma if_true_false (b : bool) : (if b then true else false) = b.
  destruct b; reflexivity.
Qed.

Lemma iff_is_true_eq_bool (b b' : bool) :
  (b <-> b') -> b = b'.
Proof.
  destruct b, b'; cbnr; intros [H1 H2];
    try specialize (H1 eq_refl); try specialize (H2 eq_refl);
      discriminate.
Qed.

Lemma uip_bool (b1 b2 : bool) (p q : b1 = b2) : p = q.
Proof.
  destruct q. apply Eqdep_dec.UIP_refl_bool.
Qed.

Axiom todo : string -> forall {A}, A.
Ltac todo s := exact (todo s).

From Coq Require Import Extraction.
Extract Constant todo => "fun s -> failwith (Caml_bytestring.caml_string_of_bytestring s)".

From Ltac2 Require Import Init.
From Ltac2 Require Control Ltac1.

Ltac2 gtry (tac : unit -> unit) :=
  Control.plus tac (fun _ => ()).

Ltac gtry tac :=
  let f := ltac2:(tac |- gtry (fun () => Ltac1.run tac)) in
  f tac.

Tactic Notation "gtry" tactic3(tac) := gtry tac.


(*
 * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import VST.msl.base.
Require Import VST.msl.sepalg.
Require Import VST.msl.sepalg_generators.
Require Import VST.msl.psepalg.

(* This file defines a series of lemmas for proving functions from the carrier set
   of one SA to the carrier set of another are join homomorphisms, and then shows
   that some simple properties of SA elems, like identity, comparability, etc.,
   are preserved by join homs.  The idea is due to Rob.
*)

(* Two-argument join homomorphisms *)
Section join_hom2.
  Variables (A B C: Type)
            (JA: Join A)
            (JB: Join B)
            (JC: Join C)
            (f: A -> B -> C).

  Definition join_hom2 := forall (a1 a2 a3: A)(b1 b2 b3: B),
      join a1 a2 a3
      -> join b1 b2 b3
      -> join (f a1 b1) (f a2 b2) (f a3 b3).

  (* Two-argument join homomorphisms with a dummy argument *)
  Definition join_hom2' := forall (a1 a2 a3: A)(b1 b2 b3: B),
      join a1 a2 a3
      -> join (f a1 b1) (f a2 b2) (f a3 b3).
End join_hom2.

Arguments join_hom2 [A B C JA JB JC] _.
Arguments join_hom2' [A B C JA] _ _.

(* [id] is join hom *)
  Lemma join_hom_id (A: Type) (JA: Join A) : join_hom (fun x => x).
  Proof. unfold join_hom; auto. Qed.

(* Product SA
   Join hom functions on products *)
Section join_hom_prod.
  Variables (A A' B B': Type)
            (JA: Join A) (JA': Join A')
            (JB: Join B)  (JB': Join B')
            (f: A -> A') (g: B -> B')
            (join_hom_f: join_hom f)
            (join_hom_g: join_hom g).

  Lemma join_hom2_pair: join_hom2 (fun a b => (f a, g b)).
  Proof. firstorder. Qed.

  Lemma join_hom2_pair' : join_hom2 (fun (a: A) (b: B) => (a, b)).
  Proof. firstorder. Qed.

  (* The function from [(a,b)] to [(a',b')] *)
  Lemma join_hom_prod : join_hom (fun p => (f (fst p), g (snd p))).
  Proof. unfold join_hom; firstorder. Qed.

  (* The function from [a] to [(a', e)] *)
  Lemma join_hom_prodA
    : forall e: B', join e e e -> join_hom (fun a :A => (f a, e)).
  Proof.
    unfold join_hom in *; intros; simpl; split; auto.
    simpl; auto.
  Qed.

  Lemma join_hom_prodA'
    : forall e: B, join e e e -> join_hom (fun a :A'  => (a, e)).
  Proof.
    unfold join_hom in *; split; simpl; auto.
  Qed.

  (* The function from [b] to [(e, b')] *)
  Lemma join_hom_prodB
    : forall e: A', join e e e -> join_hom (fun b: B => (e, g b)).
  Proof.
    unfold join_hom in *; split; simpl; auto.
  Qed.

  Lemma join_hom_prodB'
    : forall e: A, join e e e -> join_hom (fun b : B' => (e, b)).
  Proof.
    unfold join_hom in *; simpl; split; auto.
  Qed.

  (* Projections are join hom. *)
  Lemma join_hom_proj1
    : join_hom (fun p: A*B => fst p).
  Proof. unfold join_hom; firstorder. Qed.

  Lemma join_hom_proj2
    : join_hom (fun p : A*B => snd p).
  Proof. unfold join_hom; firstorder. Qed.
End join_hom_prod.

Arguments join_hom2_pair [A A' B B' JA JA' JB JB'] _ _ _ _ _ _ _ _ _ _ _ _.
Arguments join_hom2_pair' [A B JA JB] _ _ _ _ _ _ _ _.
Arguments join_hom_prodA [A] _ [B' JA] _ [JB'] _ _ _ _ _ _ _ _.
Arguments join_hom_prodA' [A' B JA' JB] _ _ _ _ _ _.
Arguments join_hom_prodB [A' B] _ [JA' JB] _ _ _ _ _ _ _ _ _.
Arguments join_hom_prodB' [A B' JA JB'] _ _ _ _ _ _.
Arguments join_hom_proj1 [A B JA JB] _ _ _ _.
Arguments join_hom_proj2 [A B JA JB] _ _ _ _.

(* Disjoint Sum SA *)
Section join_hom_disjoint_sum.
  Variables (A A' B B': Type)
            (JA: Join A) (JA': Join A')
            (JB: Join B) (JB': Join B')
            (f: A -> A') (g: B -> B')
            (join_hom_f: join_hom f)
            (join_hom_g: join_hom g).
(*
   Definition saAorB := sa_sum saA saB.
  Definition saA'orB' := sa_sum saA' saB'.
*)
  Lemma join_hom_sum
    : join_hom (fun s: A+B =>
        match s with
          | inl x => inl _ (f x)
          | inr y => inr _ (g y)
        end).
  Proof.
    unfold join_hom.
    destruct x; destruct y; destruct z; firstorder.
  Qed.

  Lemma join_hom_sum_l
    : join_hom (fun s: A+B =>
        match s with
          | inl x => inl _ (f x)
          | inr y => inr _ y
        end).
  Proof.
    unfold join_hom.
    destruct x; destruct y; destruct z; firstorder.
  Qed.

  Lemma join_hom_sum_r
    : join_hom (fun s: A+B =>
        match s with
          | inl x => inl _ x
          | inr y => inr _ (g y)
        end).
  Proof.
    unfold join_hom.
    destruct x; destruct y; destruct z; firstorder.
  Qed.

  Lemma join_hom_inj_l
    : join_hom (fun a : A=> inl Void (f a)).
  Proof. firstorder. Qed.

  Lemma join_hom_inj_r
    : join_hom (fun b => inr Void (g b)).
  Proof. firstorder. Qed.

  (* Bijection between [A+unit] and [option A], for convenience later on *)
  Definition sa_sum_option (s: A+unit): option A :=
    match s with
      | inl s' => Some s'
      | inr _ => None
    end.

  Definition option_sa_sum (s: option A): A+unit :=
    match s with
      | Some s' => inl _ s'
      | None => inr _ tt
    end.

  Lemma sa_sum__option: forall s, sa_sum_option (option_sa_sum s) = s.
  Proof. destruct s; firstorder. Qed.

  Lemma option__sa_sum: forall s, option_sa_sum (sa_sum_option s) = s.
  Proof. destruct s; firstorder; destruct u; firstorder. Qed.

  Definition bij_sa_sum_option : bijection (A+unit) (option A) :=
    Bijection _ _ sa_sum_option option_sa_sum sa_sum__option option__sa_sum.
End join_hom_disjoint_sum.

(* List SA *)
Section join_hom_list.
  Variables (A: Type) (JA: Join A).

  Lemma join_hom_list_nil
    : join_hom (fun a => a :: nil).
  Proof.
    unfold join_hom;
      solve [constructor; auto || constructor].
  Qed.

  Lemma join_hom2_list_cons
    : join_hom2 (fun a l => a :: l).
  Proof.
    unfold join_hom2; constructor; auto.
  Qed.
End join_hom_list.

(* FPMs
   This section proves a join hom lemma specialized to finite partial maps
   producing [option]s.
*)
Section join_hom_fun.
  Variables (Key A: Type)
            (Key_dec_eq: forall k1 k2: Key, {k1=k2}+{~k1=k2})
            (JA: Join A).
(*
  Definition saKey := sa_equiv Key.
  Definition saKeyA := sa_prod saKey saA.
  Definition saKeyAList := sa_list saKeyA.
  Definition saSum := sa_sum saA sa_unit.
  Definition saRange := sa_bijection _ _ (bij_sa_sum_option A) _ saSum.
*)

  Fixpoint lookup k (rho: list (Key*A)) :=
    match rho with
      | nil => None
      | (k', a) :: rho' =>
          if Key_dec_eq k k' then Some a else lookup k rho'
    end.

  #[global] Instance Join_Key : Join Key := @Join_equiv Key.

  Lemma join_hom_fun
    : join_hom (fun env k => lookup k env).
  Proof.
    unfold join_hom; intros x y z H.
    induction H.

    (* env is nil *)
    simpl; auto. intro. constructor.

    (* env is cons *)
    simpl; intro x0.
    destruct x as [k1 a1]; destruct y as [k2 a2]; destruct z as [k3 a3].
    destruct H. simpl in *. destruct H. subst k2 k3.
    destruct (Key_dec_eq x0 k1); auto. constructor; auto.
  Qed.
End join_hom_fun.
Arguments lookup [Key A] _ _ _.

Lemma join_hom_bij {A: Type} `{Perm_alg A}
            {B: Type}
          (bij: bijection A B):
       @join_hom _ _ _ (Join_bij _ _ _ bij) (bij_f _ _ bij).
  Proof.
    unfold join_hom. intros. do 3 red.
    repeat rewrite bij_gf. auto.
  Qed.

(* Some simple properties preserved by join homs *)
  Lemma join_hom_join_sub {A}{B}`{Join A}`{Join B}:
     forall (f: A -> B) a1 a2, join_sub a1 a2 -> join_hom f -> join_sub (f a1) (f a2).
  Proof.
    intros.
    destruct H1 as [b H1].
    exists (f b).  auto.
  Qed.

  Lemma join_hom_identity  {A}{B}`{Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A}`{Perm_alg B}{SB: Sep_alg B}{CB: Disj_alg B}:
      forall (f: A -> B) a1, identity a1 -> join_hom f -> identity (f a1).
  Proof.
    intros.
    rewrite identity_unit_equiv in H1.
    rewrite identity_unit_equiv.
    unfold unit_for in *. auto.
  Qed.

  Lemma join_hom2_identity  {A}{B}{C}
          `{Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A}
          `{Perm_alg B}{SB: Sep_alg B}{CB: Disj_alg B}
          `{Perm_alg C}{SC: Sep_alg C}{CC: Disj_alg C}:
   forall (g: A -> B -> C) a1 b1,
      identity a1 -> identity b1 -> join_hom2 g -> identity (g a1 b1).
  Proof.
   intros.
    unfold join_hom2 in *.
    rewrite identity_unit_equiv in H2.
    rewrite identity_unit_equiv in H3.
    rewrite identity_unit_equiv.
    unfold unit_for in *. auto.
  Qed.

  Lemma join_hom_comparable {A}{B}`{Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}`{Perm_alg B}{SB:Sep_alg B}{FB: Flat_alg B}:
      forall (f: A -> B) a1 a2, comparable a1 a2 -> join_hom f -> comparable (f a1) (f a2).
  Proof.
    intros.
    unfold join_hom in *.
    destruct (comparable_common_unit H1) as [e [? ?]].
    apply common_unit_comparable.
    exists (f e); split; auto.
  Qed.

  Lemma join_hom2_comparable {A}{B}{C}
          `{Perm_alg A}{SA: Sep_alg A}{FA: Flat_alg A}`{Perm_alg B}{SB: Sep_alg B}{FB: Flat_alg B}`{Perm_alg C}{SC: Sep_alg C}{FC: Flat_alg C}:
   forall (g: A -> B -> C) a1 a2 b1 b2,
     comparable a1 a2
      -> comparable b1 b2
      -> join_hom2 g
      -> comparable (g a1 b1) (g a2 b2).
  Proof.
    intros.
    unfold join_hom2 in *.
    destruct (comparable_common_unit H2) as [ea [? ?]].
    destruct (comparable_common_unit H3) as [eb [? ?]].
    apply common_unit_comparable.
    exists (g ea eb); auto.
  Qed.

(* EXamples: *)

(*  This example doesn't make so much sense, as "comparable"
  is not so well-defined for Pos_algs
(* Finite Partial Maps from [nat]s to [option]s *)
Section fpm_ex.
  Variables (A: Type)
            (JA: Join A) (saA: Pos_alg A)(CA: Canc_alg A)
            (a b: A)
            (l: list (nat*A)).

  Definition mkEnv := fun p:nat*A => p :: l.
  Definition env1 := mkEnv (1%nat, a).
  Definition env2 := mkEnv (1%nat, b).
  Definition fpm (env: list (nat*A)) := fun k:nat => lookup eq_nat_dec k env.

Check Sep_sum.

 Definition saOption := Perm_bij _ _ _ _ (bij_sa_sum_option A).
  Definition saB := Perm_fun nat _ _ saOption.
  Local Instance Join_nat : Join nat := @Join_equiv nat.
  Local Instance Sep_nat : Sep_alg nat := Sep_equiv nat.

  Local Instance Canc_B : Canc_alg (nat -> option A).
  Proof. auto with typeclass_instances. Qed.

  Lemma fpm_comparable_ex
    : comparable (fpm env1) (fpm env2).
  Proof.
    simpl.

Check (@join_hom_comparable (list (nat*A)) _ _ _ _ _ fpm).
Print join_hom_comparable.
A, B, J, H,  J0, H0

    apply join_hom_comparable with (f := fpm).

; [ | apply join_hom_fun; auto].
    eapply join_hom2_comparable.
    eapply join_hom2_comparable with (g := fun a b => (a,b)).
    eapply comparable_refl.
    eapply H.
    eapply join_hom2_pair'.
    eapply comparable_refl.
    eapply join_hom2_list_cons.
Qed.

End fpm_ex.
*)


Require Import VST.progs.io_mem.
Require Import VST.progs.io_mem_specs.
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.

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

Definition putchars_spec := DECLARE _putchars putchars_spec.
Definition getchars_spec := DECLARE _getchars getchars_spec.

Lemma div_10_dec : forall n, 0 < n ->
  (Z.to_nat (n / 10) < Z.to_nat n)%nat.
Proof.
  intros.
  change 10 with (Z.of_nat 10).
  rewrite <- (Z2Nat.id n) by lia.
  rewrite <- div_Zdiv by discriminate.
  rewrite !Nat2Z.id.
  apply Nat2Z.inj_lt.
  rewrite div_Zdiv, Z2Nat.id by lia; simpl.
  apply Z.div_lt; auto; lia.
Qed.

Program Fixpoint chars_of_Z (n : Z) { measure (Z.to_nat n) } : list byte :=
  let n' := n / 10 in
  match n' <=? 0 with true => [Byte.repr (n + char0)] | false => chars_of_Z n' ++ [Byte.repr (n mod 10 + char0)] end.
Next Obligation.
Proof.
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous.
  eapply Z.lt_le_trans, Z_mult_div_ge with (b := 10); lia.
Defined.

(* The function computed by print_intr *)
Program Fixpoint intr n { measure (Z.to_nat n) } : list byte :=
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Byte.repr (n mod 10 + char0)]
  end.
Next Obligation.
Proof.
  apply div_10_dec.
  symmetry in Heq_anonymous; apply Z.leb_nle in Heq_anonymous; lia.
Defined.

Definition replace_list {X} i (l : list X) (l' : list X) :=
  sublist 0 i l ++ l' ++ sublist (i + Zlength l') (Zlength l) l.

Definition print_intr_spec :=
 DECLARE _print_intr
  WITH sh : share, i : Z, buf : val, contents : list val
  PRE [ tuint, tptr tuchar ]
    PROP (writable_share sh; 0 <= i <= Int.max_unsigned; Zlength (intr i) <= Zlength contents <= Int.max_signed)
    PARAMS (Vint (Int.repr i); buf)
    GLOBALS ()
    SEP (data_at sh (tarray tuchar (Zlength contents)) contents buf)
  POST [ tint ]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (Zlength (intr i)))))
    SEP (data_at sh (tarray tuchar (Zlength contents)) (replace_list 0 contents (map Vubyte (intr i))) buf).

Definition print_int_spec :=
 DECLARE _print_int
  WITH gv : globals, i : Z, tr : IO_itree
  PRE [ tuint ]
    PROP (0 <= i < 10000)
    PARAMS (Vint (Int.repr i))
    GLOBALS (gv)
    SEP (mem_mgr gv; ITREE (write_list stdout (chars_of_Z i ++ [Byte.repr newline]) ;; tr))
  POST [ tvoid ]
    PROP ()
    LOCAL ()
    SEP (mem_mgr gv; ITREE tr).

Definition for_loop {file_id} i z (body : Z -> itree (@IO_event file_id) bool) :=
  ITree.iter (fun '(b, j) => if (b : bool) then Ret (inr true) else if j <? z then b <- body j ;; Ret (inl (b, j + 1)) else Ret (inr false)) (false, i).

Definition sum_Z l := fold_right Z.add 0 l.

Definition read_sum_inner n nums j :=
  if orb (10 <=? Znth j nums) (Znth j nums <? 0) then Ret true
  else write_list stdout (chars_of_Z (n + sum_Z (sublist 0 (j + 1) nums)) ++ [Byte.repr newline]);; Ret false.

Definition read_sum n lc : IO_itree :=
  ITree.iter (fun '(b, n, lc) => if (b : bool) then Ret (inr tt) else
  if zlt n 1000 then
    let nums := map (fun c => Byte.unsigned c - char0) lc in
    b <- for_loop 0 4 (read_sum_inner n nums) ;; if (b : bool) then Ret (inl (true, n, lc)) else
    lc' <- read_list stdin 4;; Ret (inl (false, n + sum_Z nums, lc'))
  else Ret (inr tt)) (false, n, lc).

Definition main_itree := lc <- read_list stdin 4;; read_sum 0 lc.

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog main_itree gv
  POST [ tint ] PROP () LOCAL () SEP (mem_mgr gv; ITREE (Ret tt : @IO_itree (@IO_event nat))).

Definition Gprog : funspecs := ltac:(with_library prog [putchars_spec; getchars_spec;
  print_intr_spec; print_int_spec; main_spec]).

Lemma divu_repr : forall x y,
  0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned ->
  Int.divu (Int.repr x) (Int.repr y) = Int.repr (x / y).
Proof.
  intros; unfold Int.divu.
  rewrite !Int.unsigned_repr; auto.
Qed.

(*Opaque bind.

Opaque Nat.div Nat.modulo.*)

Lemma intr_eq : forall n, intr n =
  match n <=? 0 with
  | true => []
  | false => intr (n / 10) ++ [Byte.repr (n mod 10 + char0)]
  end.
Proof.
  intros.
  unfold intr at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold intr.
  destruct n; reflexivity.
Qed.

(* missing from standard library *)
Lemma Zdiv_le_compat_r : forall m n p, p > 0 -> m <= n -> m / p <= n / p.
Proof.
  intros; unfold Z.div.
  pose proof (Z_div_mod m _ H) as Hm.
  pose proof (Z_div_mod n _ H) as Hn.
  destruct (Z.div_eucl m p), (Z.div_eucl n p).
  destruct Hm, Hn; subst.
  destruct (zle z z1); auto.
  assert (p * z1 + p <= p * z); try lia.
  rewrite <- Z.mul_succ_r.
  apply Zmult_le_compat_l; lia.
Qed.

Lemma intr_lt : forall n, 0 < n -> Zlength (intr (n / 10)) = Zlength (intr n) - 1.
Proof.
  intros.
  rewrite (intr_eq n).
  destruct (n <=? 0) eqn: Hn.
  { apply Zle_bool_imp_le in Hn; lia. }
  rewrite Zlength_app, Zlength_cons, Zlength_nil; lia.
Qed.

Lemma replace_list_nil : forall {X} i (l : list X), 0 <= i <= Zlength l -> replace_list i l [] = l.
Proof.
  intros; unfold replace_list.
  rewrite Zlength_nil, Z.add_0_r; simpl.
  rewrite sublist_rejoin, sublist_same by lia; auto.
Qed.

Lemma replace_list_upd_snoc : forall {X} i (l l' : list X) x, 0 <= i -> i + Zlength l' < Zlength l ->
  upd_Znth (i + Zlength l') (replace_list i l l') x = replace_list i l (l' ++ [x]).
Proof.
  intros; unfold replace_list.
  rewrite upd_Znth_app2; rewrite ?Zlength_sublist; try rep_lia.
  f_equal.
  rewrite Z.sub_0_r, Z.add_simpl_l, upd_Znth_app2; rewrite ?Zlength_sublist; try rep_lia.
  rewrite Zminus_diag, Zlength_app, Zlength_cons, Zlength_nil, upd_Znth0_old, <- app_assoc; simpl; f_equal; f_equal.
  rewrite Zlength_sublist by rep_lia.
  rewrite sublist_sublist by rep_lia.
  f_equal; lia.
  { rewrite Zlength_sublist; rep_lia. }
  { rewrite Zlength_app, Zlength_sublist; rep_lia. }
Qed.

Lemma body_print_intr: semax_body Vprog Gprog f_print_intr print_intr_spec.
Proof.
  start_function.
  forward.
  forward_if (PROP ()
    LOCAL (temp _k (Vint (Int.repr (Zlength (intr i) - 1))))
    SEP (data_at sh (tarray tuchar (Zlength contents)) (replace_list 0 contents (map Vubyte (intr i))) buf)).
  - forward.
    rewrite divu_repr by rep_lia.
    forward.
    forward_call (sh, i / 10, buf, contents).
    { rewrite intr_lt by lia; split; auto; try lia.
      assert (i / 10 < i).
      { apply Z.div_lt; lia. }
       split.
      apply Z.div_pos; lia.
      rep_lia.
    }
    rewrite modu_repr by (lia || computable).
    assert (repable_signed (Zlength (intr (i / 10)))).
    { split; try rep_lia.
      rewrite intr_lt; try lia. }
    forward.
    { entailer!.
      split; try rep_lia.
      rewrite intr_lt; try lia. }
    entailer!.
    { rewrite intr_lt by lia; auto. }
    rewrite (intr_eq i).
    destruct (i <=? 0) eqn: Hi; [apply Zle_bool_imp_le in Hi; lia|].
    pose proof (Z_mod_lt i 10).
    rewrite <- (Zlength_map _ _ Vubyte), <- (Z.add_0_l (Zlength (map _ _))), replace_list_upd_snoc.
    rewrite (zero_ext_inrange 8 (Int.repr (i mod 10))), add_repr.
    rewrite zero_ext_inrange, map_app.
    unfold Vubyte at 3; simpl.
    rewrite Byte.unsigned_repr by (unfold char0; rep_lia); apply derives_refl.
    { rewrite Int.unsigned_repr; simpl; rep_lia. }
    { rewrite Int.unsigned_repr; simpl; rep_lia. }
    { lia. }
    { rewrite Zlength_map, intr_lt; rep_lia. }
  - forward.
    entailer!.
    rewrite replace_list_nil by rep_lia; auto.
  - forward.
    rewrite Z.sub_simpl_r; entailer!.
Qed.

Lemma chars_of_Z_eq : forall n, chars_of_Z n =
  let n' := n / 10 in
  match n' <=? 0 with true => [Byte.repr (n + char0)] | false => chars_of_Z n' ++ [Byte.repr (n mod 10 + char0)] end.
Proof.
  intros.
  unfold chars_of_Z at 1.
  rewrite Wf.WfExtensionality.fix_sub_eq_ext; simpl; fold chars_of_Z.
  destruct (_ <=? _); reflexivity.
Qed.

Lemma chars_of_Z_intr : forall n,
  chars_of_Z n = if n <=? 0 then [Byte.repr (n + char0)] else intr n.
Proof.
  intros.
  destruct (Z.leb_spec n 0).
  { rewrite chars_of_Z_eq; simpl.
    apply Zdiv_le_compat_r with (p := 10) in H; try lia.
    rewrite Zdiv_0_l in H.
    destruct (Z.leb_spec (n / 10) 0); auto; lia. }
  induction n as [? IH] using (well_founded_induction (Zwf.Zwf_well_founded 0)).
  rewrite chars_of_Z_eq, intr_eq.
  destruct (n <=? 0) eqn: Hn; [apply Zle_bool_imp_le in Hn; lia|].
  simpl.
  destruct (n / 10 <=? 0) eqn: Hdiv.
  - apply Zle_bool_imp_le in Hdiv.
    assert (0 <= n / 10).
    { apply Z.div_pos; lia. }
    assert (n / 10 = 0) as Hz by lia.
    rewrite Hz; simpl.
    apply Z.div_small_iff in Hz as [|]; try lia.
    rewrite Zmod_small; auto.
  - apply Z.leb_nle in Hdiv.
    rewrite IH; auto; try lia.
    split; try lia.
    apply Z.div_lt; auto; lia.
Qed.

Lemma intr_length : forall n a, 0 <= a -> n < Z.pow 10 a -> Zlength (intr n) <= a.
Proof.
  induction n using (well_founded_induction (Zwf.Zwf_well_founded 0)); intros.
  rewrite intr_eq.
  destruct (Z.leb_spec n 0); [rewrite Zlength_nil; lia|].
  rewrite Zlength_app.
  assert (Zlength (intr (n / 10)) <= a - 1); [|rewrite Zlength_cons, Zlength_nil; lia].
  assert (0 <= a - 1).
  { destruct (Z.eq_dec a 0); subst; simpl in *; lia. }
  apply H; auto.
  - split; try lia.
    apply Z.div_lt; auto; lia.
  - apply Zmult_lt_reg_r with 10; try lia.
    rewrite (Z.mul_comm (10 ^ _)), <- Z.pow_succ_r by auto.
    unfold Z.succ; rewrite Z.sub_simpl_r.
    eapply Z.le_lt_trans; eauto.
    rewrite Z.mul_comm; apply Z.mul_div_le; lia.
Qed.

Lemma chars_of_Z_length : forall n a, 0 < a -> n < Z.pow 10 a -> Zlength (chars_of_Z n) <= a.
Proof.
  intros.
  rewrite chars_of_Z_intr.
  destruct (Z.leb_spec n 0); [|apply intr_length; lia].
  rewrite Zlength_cons, Zlength_nil; lia.
Qed.

Lemma body_print_int: semax_body Vprog Gprog f_print_int print_int_spec.
Proof.
  start_function.
  forward_call (tarray tuchar 5, gv).
  { split; auto; simpl; computable. }
  Intro buf.
  forward_if (buf <> nullval).
  { if_tac; entailer!. }
  { forward_call 1; contradiction. }
  { forward.
    entailer!. }
  Intros; rewrite if_false by auto.
  forward_if (PROP ()
    LOCAL (temp _buf buf; gvars gv; temp _i (Vint (Int.repr i));
                 temp _k (Vint (Int.repr (Zlength (chars_of_Z i ++ [Byte.repr newline])))))
    SEP (mem_mgr gv; malloc_token Ews (tarray tuchar 5) buf;
            data_at Ews (tarray tuchar 5) (map Vubyte (chars_of_Z i) ++ Vubyte (Byte.repr newline) ::
              repeat Vundef (Z.to_nat (4 - Zlength (chars_of_Z i)))) buf;
            ITREE (write_list stdout (chars_of_Z i ++ [Byte.repr newline]);; tr))).
  - Intros.
    forward.
    forward.
    forward.
    entailer!.
  - Intros.
    sep_apply data_at__data_at.
    unfold default_val; simpl.
    assert (Zlength (intr i) <= 4).
    { apply intr_length; try lia. }
    forward_call (Ews, i, buf, [Vundef; Vundef; Vundef; Vundef; Vundef]).
    { rewrite !Zlength_cons, Zlength_nil.
      simpl; repeat (split; auto); rep_lia. }
    forward.
    { entailer!.
      rewrite !Zlength_cons, Zlength_nil; rep_lia. }
    forward.
    entailer!.
    { rewrite Zlength_app, Zlength_cons, Zlength_nil, chars_of_Z_intr.
      destruct (Z.leb_spec i 0); auto; lia. }
    unfold replace_list; simpl.
    rewrite (sublist_repeat _ _ 5 Vundef).
    rewrite !Zlength_cons, Zlength_nil, Zlength_map; simpl.
    rewrite upd_Znth_app2.
    rewrite Zlength_map, Zminus_diag, upd_Znth0_old, sublist_repeat; try lia.
    apply derives_refl'.
    f_equal.
    rewrite chars_of_Z_intr.
    destruct (Z.leb_spec i 0); try lia.
    rewrite zero_ext_inrange.
    f_equal; f_equal; f_equal; f_equal.
    rewrite Zlength_repeat; try lia.
    { simpl; rewrite Int.unsigned_repr; rep_lia. }
    { rewrite Zlength_repeat; lia. }
    { rewrite Zlength_repeat; lia. }
    { rewrite Zlength_map, Zlength_repeat; lia. }
    { rewrite Zlength_map; rep_lia. }
    { rewrite !Zlength_cons, Zlength_nil, Zlength_map; lia. }
  - forward_call (Ews, buf, chars_of_Z i ++ [Byte.repr newline],
      5, repeat Vundef (Z.to_nat (4 - Zlength (chars_of_Z i))), tr).
    { rewrite map_app, <- app_assoc; simpl; cancel. }
    forward_call (tarray tuchar 5, buf, gv).
    { rewrite if_false by auto; cancel. }
    forward.
Qed.

Lemma read_sum_eq : forall n lc, read_sum n lc ≈
  if zlt n 1000 then
    let nums := map (fun c => Byte.unsigned c - char0) lc in
    b <- for_loop 0 4 (read_sum_inner n nums) ;; if (b : bool) then Ret tt else
    lc' <- read_list stdin 4;; read_sum (n + sum_Z nums) lc'
  else Ret tt.
Proof.
  intros.
  unfold read_sum.
  rewrite unfold_iter.
  if_tac; [|rewrite bind_ret_l; reflexivity].
  rewrite bind_bind.
  apply eqit_bind; [|reflexivity].
  intros [].
  - rewrite bind_ret_l, tau_eutt.
    rewrite unfold_iter.
    rewrite bind_ret_l; reflexivity.
  - rewrite bind_bind.
    apply eqit_bind; [|reflexivity].
    intro.
    rewrite bind_ret_l, tau_eutt; reflexivity.
Qed.

Lemma for_loop_eq : forall {file_id} i z body,
  @for_loop file_id i z body ≈ if i <? z then b <- body i ;; if (b : bool) then Ret true else for_loop (i + 1) z body else Ret false.
Proof.
  intros.
  unfold for_loop.
  rewrite unfold_iter.
  simple_if_tac; [|rewrite bind_ret_l; reflexivity].
  rewrite bind_bind.
  apply eqit_bind; [|reflexivity].
  intros [].
  - rewrite bind_ret_l, tau_eutt, unfold_iter.
    rewrite bind_ret_l; reflexivity.
  - rewrite bind_ret_l, tau_eutt; reflexivity.
Qed.

Lemma sum_Z_app : forall l1 l2, sum_Z (l1 ++ l2) = sum_Z l1 + sum_Z l2.
Proof.
  induction l1; auto; simpl; intros.
  rewrite IHl1; lia.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  sep_apply (has_ext_ITREE(E := @IO_event nat)).
  rewrite <- (emp_sepcon (ITREE _)); Intros.
  replace_SEP 0 (mem_mgr gv) by (go_lower; apply create_mem_mgr).
  forward.
  forward_call (tarray tuchar 4, gv).
  { simpl; repeat (split; auto); rep_lia. }
  Intro buf.
  forward_if (buf <> nullval).
  { if_tac; entailer!. }
  { forward_call 1; contradiction. }
  { forward.
    entailer!. }
  Intros; rewrite if_false by auto.
  unfold main_itree.
  forward_call (Ews, buf, 4, fun lc => read_sum 0 lc).
  { simpl; cancel. }
  Intros lc.
  set (Inv := EX n : Z, EX lc : list byte,
    PROP (0 <= n < 1040)
    LOCAL (temp _i (Vint (Int.repr 4)); temp _buf buf; temp _n (Vint (Int.repr n)); gvars gv)
    SEP (ITREE (read_sum n lc); data_at Ews (tarray tuchar 4) (map Vubyte lc) buf;
      mem_mgr gv; malloc_token Ews (tarray tuchar 4) buf)).
  forward_while Inv.
  { Exists 0 lc; entailer!. }
  { entailer!. }
  - clear dependent lc; rename lc0 into lc.
    rewrite read_sum_eq.
    rewrite if_true by auto; simpl ITREE.
    set (nums := map (fun i => Byte.unsigned i - char0) lc).
    assert_PROP (Zlength lc = 4).
    { entailer!.
      rewrite Zlength_map in *; auto. }
    assert (Zlength nums = 4) by (subst nums; rewrite Zlength_map; auto).
    forward_for_simple_bound 4 (EX j : Z, PROP (0 <= n + sum_Z (sublist 0 j nums) < 1000 + 10 * j)
     LOCAL (temp _i (Vint (Int.repr 4)); temp _buf buf; temp _n (Vint (Int.repr (n + sum_Z (sublist 0 j nums)))); gvars gv)
     SEP (ITREE (b <- for_loop j 4
         (read_sum_inner n nums) ;; if (b : bool) then Ret tt else lc' <- read_list stdin 4 ;; read_sum (n + sum_Z nums) lc');
             data_at Ews (tarray tuchar 4) (map Vubyte lc) buf; mem_mgr gv; malloc_token Ews (tarray tuchar 4) buf)).
    + entailer!.
      { lia. }
    + simpl.
      forward.
      { entailer!.
        unfold Vubyte; simpl.
        rewrite Int.unsigned_repr; rep_lia. }
      forward.
      rewrite Znth_map by lia; simpl.
      rewrite zero_ext_inrange.
      forward.
      unfold Int.sub.
      rewrite !Int.unsigned_repr by rep_lia.
      forward_if (0 <= Byte.unsigned (Znth i lc) - char0 < 10).
      { forward_call (tarray tuchar 4, buf, gv).
        { rewrite if_false by auto; cancel. }
        forward.
        entailer!.
        rewrite for_loop_eq.
        destruct (Z.ltb_spec i 4); try lia.
        unfold read_sum_inner at 2.
        replace (_ || _)%bool with true.
        rewrite !bind_ret_l; auto.
        { symmetry; rewrite orb_true_iff.
          subst nums; rewrite Znth_map by lia.
          destruct (Z.ltb_spec (Byte.unsigned (Znth i lc) - char0) 0); auto.
          rewrite Int.unsigned_repr in * by (unfold char0 in *; rep_lia).
          left; apply Z.leb_le; unfold char0 in *; lia. } }
      { forward.
        entailer!.
        rewrite Int.unsigned_repr_eq in *.
        destruct (zlt (Byte.unsigned (Znth i lc)) char0).
        { unfold char0 in *; rewrite <- Z_mod_plus_full with (b := 1), Zmod_small in *; rep_lia. }
        unfold char0 in *; rewrite Zmod_small in *; rep_lia. }
      forward.
      rewrite add_repr.
      rewrite for_loop_eq.
      destruct (Z.ltb_spec i 4); try lia.
      unfold read_sum_inner at 2.
      unfold nums; rewrite Znth_map by lia.
      assert (((10 <=? Byte.unsigned (Znth i lc) - char0) || (Byte.unsigned (Znth i lc) - char0 <? 0))%bool = false) as Hin.
      { rewrite orb_false_iff.
        split; [apply Z.leb_nle | apply Z.ltb_nlt]; lia. }
      rewrite Hin.
      assert (sublist 0 (i + 1) nums = sublist 0 i nums ++ [Byte.unsigned (Znth i lc) - char0]) as Hi.
      { rewrite (sublist_split _ i (i + 1)), (sublist_one i (i + 1)) by lia.
        f_equal; subst nums.
        rewrite Znth_map by lia; auto. }
      forward_call (gv, n + sum_Z (sublist 0 (i + 1) nums),
        b <- for_loop (i + 1) 4 (read_sum_inner n nums) ;; if (b : bool) then Ret tt else lc' <- read_list stdin 4 ;; read_sum (n + sum_Z nums) lc').
      { entailer!.
        rewrite Hi, sum_Z_app; simpl.
        rewrite Z.add_assoc, Z.add_0_r; auto. }
      { rewrite sepcon_assoc; apply sepcon_derives; cancel.
        rewrite !bind_bind.
        apply ITREE_impl.
        apply eqit_bind; [|reflexivity].
        intros [].
        rewrite bind_ret_l; reflexivity. }
      { rewrite Hi, sum_Z_app; simpl; lia. }
      entailer!.
      { rewrite Hi, sum_Z_app; simpl.
        rewrite Z.add_0_r, Z.add_assoc; split; auto; lia. }
      { rewrite Int.unsigned_repr by rep_lia.
        pose proof (Byte.unsigned_range (Znth i lc)) as [_ Hmax].
        unfold Byte.modulus, two_power_nat in Hmax; simpl in *; lia. }
    + rewrite for_loop_eq.
      destruct (Z.ltb_spec 4 4); try lia.
      forward_call (Ews, buf, 4, fun lc' => read_sum (n + sum_Z nums) lc').
      { rewrite sepcon_assoc; apply sepcon_derives; cancel.
        simpl; rewrite bind_ret_l; auto. }
      Intros lc'.
      forward.
      rewrite sublist_same in * by auto.
      Exists (n + sum_Z nums, lc'); entailer!.
      apply derives_refl.
  - subst Inv.
    forward_call (tarray tuchar 4, buf, gv).
    { rewrite if_false by auto; cancel. }
    forward.
    cancel.
    rewrite read_sum_eq.
    rewrite if_false; [auto | lia].
Qed.

Definition ext_link := ext_link_prog prog.

Instance Espec : OracleKind := IO_Espec ext_link.

Lemma prog_correct:
  semax_prog prog main_itree Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_exit.
semax_func_cons body_free.
semax_func_cons body_malloc. apply semax_func_cons_malloc_aux.
semax_func_cons_ext.
{ simpl; Intro msg.
  apply typecheck_return_value with (t := Tint16signed); auto. }
semax_func_cons_ext.
semax_func_cons body_print_intr.
semax_func_cons body_print_int.
semax_func_cons body_main.
Qed.

Require Import VST.veric.SequentialClight.
Require Import VST.progs.io_mem_dry.

Definition init_mem_exists : { m | Genv.init_mem prog = Some m }.
Proof.
  unfold Genv.init_mem; simpl.
Ltac alloc_block m n := match n with
  | O => idtac
  | S ?n' => let m' := fresh "m" in let Hm' := fresh "Hm" in
    destruct (dry_mem_lemmas.drop_alloc m) as [m' Hm']; alloc_block m' n'
  end.
  alloc_block Mem.empty 60%nat.
  eexists; repeat match goal with H : ?a = _ |- match ?a with Some m' => _ | None => None end = _ => rewrite H end.
  reflexivity.
Qed.

Definition init_mem := proj1_sig init_mem_exists.

Definition main_block_exists : {b | Genv.find_symbol (Genv.globalenv prog) (AST.prog_main prog) = Some b}.
Proof.
  eexists; simpl.
  unfold Genv.find_symbol; simpl; reflexivity.
Qed.

Definition main_block := proj1_sig main_block_exists.

Theorem prog_toplevel : exists q,
  semantics.initial_core (Clight_core.cl_core_sem (globalenv prog)) 0 init_mem q init_mem (Vptr main_block Ptrofs.zero) [] /\
  forall n, @step_lemmas.dry_safeN _ _ _ _ semax.genv_symb_injective (Clight_core.cl_core_sem (globalenv prog))
             (io_dry_spec ext_link) {| genv_genv := Genv.globalenv prog; genv_cenv := prog_comp_env prog |} n
            main_itree q init_mem.
Proof.
  edestruct whole_program_sequential_safety_ext with (V := Vprog) as (b & q & Hb & Hq & Hsafe).
  - repeat intro; simpl. apply I.
  - apply juicy_dry_specs.
  - apply dry_spec_mem.
  - apply CSHL_Sound.semax_prog_sound, prog_correct.
  - apply (proj2_sig init_mem_exists).
  - exists q.
    rewrite (proj2_sig main_block_exists) in Hb; inv Hb.
    auto.
Qed.


From stdpp Require Import fin_maps fin_map_dom.

Section map_disjoint.
  Context `{FinMap K M}.

  Lemma solve_map_disjoint_singleton_1 {A} (m1 m2 : M A) i x :
    m1 ##ₘ <[i:=x]> m2 → {[ i:= x ]} ∪ m2 ##ₘ m1 ∧ m2 ##ₘ ∅.
  Proof. intros. solve_map_disjoint. Qed.

  Lemma solve_map_disjoint_singleton_2 {A} (m1 m2 : M A) i x :
    m2 !! i = None → m1 ##ₘ {[ i := x ]} ∪ m2 → m2 ##ₘ <[i:=x]> m1 ∧ m1 !! i = None.
  Proof. intros. solve_map_disjoint. Qed.
End map_disjoint.

Section map_dom.
  Context `{FinMapDom K M D}.

  Lemma set_solver_dom_subseteq {A} (i j : K) (x y : A) :
    {[i; j]} ⊆ dom D (<[i:=x]> (<[j:=y]> (∅ : M A))).
  Proof. set_solver. Qed.

  Lemma set_solver_dom_disjoint {A} (X : D) : dom D (∅ : M A) ## X.
  Proof. set_solver. Qed.
End map_dom.