From Coq Require Import ssreflect ssrfun ssrbool.
Require Import Setoid.
Require Import List.
Require Import Ensembles.
Require Import Coq.Strings.String.

From Coq Require Import Logic.Classical_Prop.
From stdpp Require Import countable infinite.
From stdpp Require Import pmap gmap mapset fin_sets propset.
Require Import stdpp_ext.

Require Import extralibrary.

From MatchingLogic Require Export
  Signature
  Pattern
  Substitution
  Freshness
  SyntacticConstruct
  PatternContext
  ApplicationContext
  SyntaxLemmas.FreshnessSubstitution
  SyntaxLemmas.PatternCtxApplicationCtx
  SyntaxLemmas.FreshnessApplicationCtx
  SyntaxLemmas.ApplicationCtxSubstitution
  wftactics
.

Import MatchingLogic.Substitution.Notations.

Close Scope boolean_if_scope.

Section syntax.
  Context {Σ : Signature}.
  Open Scope ml_scope.

  Inductive is_subformula_of_ind : Pattern -> Pattern -> Prop :=
  | sub_eq ϕ₁ ϕ₂ : ϕ₁ = ϕ₂ -> is_subformula_of_ind ϕ₁ ϕ₂
  | sub_app_l ϕ₁ ϕ₂ ϕ₃ : is_subformula_of_ind ϕ₁ ϕ₂ -> is_subformula_of_ind ϕ₁ (patt_app ϕ₂ ϕ₃)
  | sub_app_r ϕ₁ ϕ₂ ϕ₃ : is_subformula_of_ind ϕ₁ ϕ₃ -> is_subformula_of_ind ϕ₁ (patt_app ϕ₂ ϕ₃)
  | sub_imp_l ϕ₁ ϕ₂ ϕ₃ : is_subformula_of_ind ϕ₁ ϕ₂ -> is_subformula_of_ind ϕ₁ (patt_imp ϕ₂ ϕ₃)
  | sub_imp_r ϕ₁ ϕ₂ ϕ₃ : is_subformula_of_ind ϕ₁ ϕ₃ -> is_subformula_of_ind ϕ₁ (patt_imp ϕ₂ ϕ₃)
  | sub_exists ϕ₁ ϕ₂ : is_subformula_of_ind ϕ₁ ϕ₂ -> is_subformula_of_ind ϕ₁ (patt_exists ϕ₂)
  | sub_mu ϕ₁ ϕ₂ : is_subformula_of_ind ϕ₁ ϕ₂ -> is_subformula_of_ind ϕ₁ (patt_mu ϕ₂)
  .

  Fixpoint is_subformula_of ϕ₁ ϕ₂ : bool :=
    (decide_rel (=) ϕ₁ ϕ₂)
    || match ϕ₂ with
       | patt_app l r | patt_imp l r => is_subformula_of ϕ₁ l || is_subformula_of ϕ₁ r
       | patt_exists phi | patt_mu phi => is_subformula_of ϕ₁ phi
       | _ => false
       end.

  Lemma is_subformula_of_P ϕ₁ ϕ₂ : reflect (is_subformula_of_ind ϕ₁ ϕ₂) (is_subformula_of ϕ₁ ϕ₂).
  Proof.
    unfold is_subformula_of.
    remember ϕ₂. revert p Heqp.

    (* TODO *)
    induction ϕ₂; move=> p Heqp; destruct (decide_rel (=) ϕ₁ p) eqn:Heq2;
                           rewrite Heqp; rewrite -Heqp; rewrite Heq2; simpl; rewrite Heqp;
                             try (apply ReflectT; subst; apply sub_eq; reflexivity);
                             try (apply ReflectF; intros Contra; inversion Contra; subst; contradiction).
    all: fold is_subformula_of in *.
    - destruct (IHϕ₂1 ϕ₂1),(IHϕ₂2 ϕ₂2); simpl; try reflexivity.
      + apply ReflectT. apply sub_app_l. assumption.
      + apply ReflectT. apply sub_app_l. assumption.
      + apply ReflectT. apply sub_app_r. assumption.
      + apply ReflectF. intros Contra. inversion Contra; subst; contradiction.
    - destruct (IHϕ₂1 ϕ₂1),(IHϕ₂2 ϕ₂2); simpl; try reflexivity.
      + apply ReflectT. apply sub_imp_l. assumption.
      + apply ReflectT. apply sub_imp_l. assumption.
      + apply ReflectT. apply sub_imp_r. assumption.
      + apply ReflectF. intros Contra. inversion Contra; subst; contradiction.
    - destruct (IHϕ₂ ϕ₂). reflexivity.
      + apply ReflectT. apply sub_exists. assumption.
      + apply ReflectF. intros Contra. inversion Contra; subst; contradiction.
    - destruct (IHϕ₂ ϕ₂). reflexivity.
      + apply ReflectT. apply sub_mu. assumption.
      + apply ReflectF. intros Contra. inversion Contra; subst; contradiction.
  Qed.

  Lemma is_subformula_of_refl ϕ:
    is_subformula_of ϕ ϕ = true.
  Proof.
    destruct (is_subformula_of_P ϕ ϕ).
    - reflexivity.
    - assert (H: is_subformula_of_ind ϕ ϕ).
      apply sub_eq. reflexivity. contradiction.
  Qed.

  Lemma bsvar_subst_contains_subformula ϕ₁ ϕ₂ dbi :
    bsvar_occur ϕ₁ dbi = true ->
    is_subformula_of_ind ϕ₂ (ϕ₁^[svar: dbi ↦ ϕ₂]).
  Proof.
    generalize dependent dbi.
    induction ϕ₁; intros dbi H; simpl; simpl in H; try inversion H.
    - case_match; subst.
      + case_match; try lia. constructor. reflexivity.
      + congruence.
    - specialize (IHϕ₁1 dbi). specialize (IHϕ₁2 dbi).
      move: H H1 IHϕ₁1 IHϕ₁2.
      case: (bsvar_occur ϕ₁1 dbi); case: (bsvar_occur ϕ₁2 dbi); move=> H H1 IHϕ₁₁ IHϕ₁₂.
      + apply sub_app_l. auto.
      + apply sub_app_l. auto.
      + apply sub_app_r. auto.
      + done.
    - specialize (IHϕ₁1 dbi). specialize (IHϕ₁2 dbi).
      move: H H1 IHϕ₁1 IHϕ₁2.
      case: (bsvar_occur ϕ₁1 dbi); case: (bsvar_occur ϕ₁2 dbi); move=> H H1 IHϕ₁₁ IHϕ₁₂.
      + apply sub_imp_l. auto.
      + apply sub_imp_l. auto.
      + apply sub_imp_r. auto.
      + done.
    - apply sub_exists. auto.
    - apply sub_mu. apply IHϕ₁. auto.
  Qed.

  Lemma bevar_subst_contains_subformula ϕ₁ ϕ₂ dbi :
    bevar_occur ϕ₁ dbi = true ->
    is_subformula_of_ind ϕ₂ (ϕ₁^[evar: dbi ↦ ϕ₂]).
  Proof.
    generalize dependent dbi.
    induction ϕ₁; intros dbi H; simpl; simpl in H; try inversion H.
    - case_match; subst.
      + case_match; try lia. constructor. reflexivity.
      + congruence.
    - specialize (IHϕ₁1 dbi). specialize (IHϕ₁2 dbi).
      move: H H1 IHϕ₁1 IHϕ₁2.
      case: (bevar_occur ϕ₁1 dbi); case: (bevar_occur ϕ₁2 dbi); move=> H H1 IHϕ₁₁ IHϕ₁₂.
      + apply sub_app_l. auto.
      + apply sub_app_l. auto.
      + apply sub_app_r. auto.
      + done.
    - specialize (IHϕ₁1 dbi). specialize (IHϕ₁2 dbi).
      move: H H1 IHϕ₁1 IHϕ₁2.
      case: (bevar_occur ϕ₁1 dbi); case: (bevar_occur ϕ₁2 dbi); move=> H H1 IHϕ₁₁ IHϕ₁₂.
      + apply sub_imp_l. auto.
      + apply sub_imp_l. auto.
      + apply sub_imp_r. auto.
      + done.
    - apply sub_exists. auto.
    - apply sub_mu. apply IHϕ₁. auto.
  Qed.

  Lemma free_evars_subformula ϕ₁ ϕ₂ :
    is_subformula_of_ind ϕ₁ ϕ₂ -> free_evars ϕ₁ ⊆ free_evars ϕ₂.
  Proof.
    intros H. induction H.
    * subst. apply PreOrder_Reflexive.
    * simpl. eapply PreOrder_Transitive.
      apply IHis_subformula_of_ind.
      apply union_subseteq_l.
    * simpl. eapply PreOrder_Transitive.
      apply IHis_subformula_of_ind.
      apply union_subseteq_r.
    * simpl. eapply PreOrder_Transitive.
      apply IHis_subformula_of_ind.
      apply union_subseteq_l.
    * simpl. eapply PreOrder_Transitive.
      apply IHis_subformula_of_ind.
      apply union_subseteq_r.
    * simpl. auto.
    * simpl. auto.
  Qed.

  Corollary evar_fresh_in_subformula x ϕ₁ ϕ₂ :
    is_subformula_of_ind ϕ₁ ϕ₂ ->
    evar_is_fresh_in x ϕ₂ ->
    evar_is_fresh_in x ϕ₁.
  Proof.
    unfold evar_is_fresh_in.
    intros Hsub Hfresh.
    apply free_evars_subformula in Hsub.
    auto.
  Qed.

  Corollary evar_fresh_in_subformula' x ϕ₁ ϕ₂ :
    is_subformula_of ϕ₁ ϕ₂ ->
    evar_is_fresh_in x ϕ₂ ->
    evar_is_fresh_in x ϕ₁.
  Proof.
    intros Hsub Hfr.
    pose proof (H := elimT (is_subformula_of_P ϕ₁ ϕ₂) Hsub).
    eapply evar_fresh_in_subformula. eauto. auto.
  Qed.

  Lemma free_svars_subformula ϕ₁ ϕ₂ :
    is_subformula_of_ind ϕ₁ ϕ₂ -> free_svars ϕ₁ ⊆ free_svars ϕ₂.
  Proof.
    intros H. induction H.
    * subst. apply PreOrder_Reflexive.
    * simpl. eapply PreOrder_Transitive.
      apply IHis_subformula_of_ind.
      apply union_subseteq_l.
    * simpl. eapply PreOrder_Transitive.
      apply IHis_subformula_of_ind.
      apply union_subseteq_r.
    * simpl. eapply PreOrder_Transitive.
      apply IHis_subformula_of_ind.
      apply union_subseteq_l.
    * simpl. eapply PreOrder_Transitive.
      apply IHis_subformula_of_ind.
      apply union_subseteq_r.
    * simpl. auto.
    * simpl. auto.
  Qed.

  Corollary svar_fresh_in_subformula x ϕ₁ ϕ₂ :
    is_subformula_of_ind ϕ₁ ϕ₂ ->
    svar_is_fresh_in x ϕ₂ ->
    svar_is_fresh_in x ϕ₁.
  Proof.
    unfold svar_is_fresh_in.
    intros Hsub Hfresh.
    apply free_svars_subformula in Hsub.
    auto.
  Qed.

  Lemma free_evars_bsvar_subst ϕ₁ ϕ₂ dbi:
    free_evars (ϕ₁^[svar: dbi ↦ ϕ₂]) ⊆ free_evars ϕ₁ ∪ free_evars ϕ₂.
  Proof.
    generalize dependent dbi.
    induction ϕ₁; intros db; simpl.
    - apply union_subseteq_l.
    - apply empty_subseteq.
    - apply empty_subseteq.
    - case_match; set_solver.
    - apply empty_subseteq.
    - specialize (IHϕ₁1 db).
      specialize (IHϕ₁2 db).
      remember (free_evars (ϕ₁1^[svar: db ↦ ϕ₂])) as A1.
      remember (free_evars (ϕ₁2^[svar: db ↦ ϕ₂])) as A2.
      remember (free_evars ϕ₁1) as B1.
      remember (free_evars ϕ₁2) as B2.
      remember (free_evars ϕ₂) as C.
      rewrite <- union_assoc_L.
      rewrite {1}[B2 ∪ C]union_comm_L.
      rewrite -{1}[C]union_idemp_L.
      rewrite -[C ∪ C ∪ B2]union_assoc_L.
      rewrite [B1 ∪ _]union_assoc_L.
      rewrite [C ∪ B2]union_comm_L.
      apply union_mono; auto.
    - apply empty_subseteq.
    - specialize (IHϕ₁1 db).
      specialize (IHϕ₁2 db).
      remember (free_evars (ϕ₁1^[svar: db ↦ ϕ₂])) as A1.
      remember (free_evars (ϕ₁2^[svar: db ↦ ϕ₂])) as A2.
      remember (free_evars ϕ₁1) as B1.
      remember (free_evars ϕ₁2) as B2.
      remember (free_evars ϕ₂) as C.
      rewrite <- union_assoc_L.
      rewrite {1}[B2 ∪ C]union_comm_L.
      rewrite -{1}[C]union_idemp_L.
      rewrite -[C ∪ C ∪ B2]union_assoc_L.
      rewrite [B1 ∪ _]union_assoc_L.
      rewrite [C ∪ B2]union_comm_L.
      apply union_mono; auto.
    - auto.
    - auto.
  Qed.

  Lemma free_svars_bevar_subst ϕ₁ ϕ₂ dbi:
    free_svars (ϕ₁^[evar: dbi ↦ ϕ₂]) ⊆ free_svars ϕ₁ ∪ free_svars ϕ₂.
  Proof.
    generalize dependent dbi.
    induction ϕ₁; intros db; simpl.
    - apply empty_subseteq.
    - apply union_subseteq_l.
    - case_match; set_solver.
    - apply empty_subseteq.
    - apply empty_subseteq.
    - specialize (IHϕ₁1 db).
      specialize (IHϕ₁2 db).
      remember (free_svars (ϕ₁1^[evar: db ↦ ϕ₂])) as A1.
      remember (free_svars (ϕ₁2^[evar: db ↦ ϕ₂])) as A2.
      remember (free_svars ϕ₁1) as B1.
      remember (free_svars ϕ₁2) as B2.
      remember (free_svars ϕ₂) as C.
      rewrite <- union_assoc_L.
      rewrite {1}[B2 ∪ C]union_comm_L.
      rewrite -{1}[C]union_idemp_L.
      rewrite -[C ∪ C ∪ B2]union_assoc_L.
      rewrite [B1 ∪ _]union_assoc_L.
      rewrite [C ∪ B2]union_comm_L.
      apply union_mono; auto.
    - apply empty_subseteq.
    - specialize (IHϕ₁1 db).
      specialize (IHϕ₁2 db).
      remember (free_svars (ϕ₁1^[evar: db ↦ ϕ₂])) as A1.
      remember (free_svars (ϕ₁2^[evar: db ↦ ϕ₂])) as A2.
      remember (free_svars ϕ₁1) as B1.
      remember (free_svars ϕ₁2) as B2.
      remember (free_svars ϕ₂) as C.
      rewrite <- union_assoc_L.
      rewrite {1}[B2 ∪ C]union_comm_L.
      rewrite -{1}[C]union_idemp_L.
      rewrite -[C ∪ C ∪ B2]union_assoc_L.
      rewrite [B1 ∪ _]union_assoc_L.
      rewrite [C ∪ B2]union_comm_L.
      apply union_mono; auto.
    - auto.
    - auto.
  Qed.

  Lemma free_evars_bsvar_subst_1 ϕ₁ ϕ₂ dbi:
    free_evars ϕ₁ ⊆ free_evars (ϕ₁^[svar: dbi ↦ ϕ₂]).
  Proof.
    generalize dependent dbi.
    induction ϕ₁; intros dbi; simpl; try apply reflexivity.
    - apply empty_subseteq.
    - apply union_mono; auto.
    - apply union_mono; auto.
    - auto.
    - auto.
  Qed.

  Lemma free_svars_bevar_subst_1 ϕ₁ ϕ₂ dbi:
    free_svars ϕ₁ ⊆ free_svars (ϕ₁^[evar: dbi ↦ ϕ₂]).
  Proof.
    generalize dependent dbi.
    induction ϕ₁; intros dbi; simpl; try apply reflexivity.
    - apply empty_subseteq.
    - apply union_mono; auto.
    - apply union_mono; auto.
    - auto.
    - auto.
  Qed.

  Corollary free_evars_bsvar_subst_eq ϕ₁ ϕ₂ dbi:
    bsvar_occur ϕ₁ dbi ->
    free_evars (ϕ₁^[svar: dbi ↦ ϕ₂]) = free_evars ϕ₁ ∪ free_evars ϕ₂.
  Proof.
    intros H.
    apply (anti_symm subseteq).
    - apply free_evars_bsvar_subst.
    - apply union_least.
      + apply free_evars_bsvar_subst_1.
      + pose proof (Hsub := bsvar_subst_contains_subformula ϕ₁ ϕ₂ dbi H).
        apply free_evars_subformula. auto.
  Qed.

  Corollary free_svars_bevar_subst_eq ϕ₁ ϕ₂ dbi:
    bevar_occur ϕ₁ dbi ->
    free_svars (ϕ₁^[evar: dbi ↦ ϕ₂]) = free_svars ϕ₁ ∪ free_svars ϕ₂.
  Proof.
    intros H.
    apply (anti_symm subseteq).
    - apply free_svars_bevar_subst.
    - apply union_least.
      + apply free_svars_bevar_subst_1.
      + pose proof (Hsub := bevar_subst_contains_subformula ϕ₁ ϕ₂ dbi H).
        apply free_svars_subformula. auto.
  Qed.

  Lemma wfc_mu_aux_implies_not_bsvar_occur phi ns :
    well_formed_closed_mu_aux phi ns ->
    bsvar_occur phi ns = false.
  Proof.
    move: ns.
    induction phi; intros ns Hwfc; simpl; simpl in Hwfc; auto.
    - repeat case_match; try lia. congruence.
    - apply andb_true_iff in Hwfc.
      destruct Hwfc as [Hwfc1 Hwfc2].
      destruct (bsvar_occur phi1 ns) eqn:Heq1, (bsvar_occur phi2 ns) eqn:Heq2; simpl.
      rewrite IHphi1 in Heq1. assumption. congruence.
      rewrite IHphi1 in Heq1. assumption. congruence.
      rewrite IHphi2 in Heq2. assumption. congruence.
      rewrite IHphi2 in Heq2. assumption. congruence.
    - apply andb_true_iff in Hwfc.
      destruct Hwfc as [Hwfc1 Hwfc2].
      destruct (bsvar_occur phi1 ns) eqn:Heq1, (bsvar_occur phi2 ns) eqn:Heq2; simpl.
      rewrite IHphi1 in Heq1. assumption. congruence.
      rewrite IHphi1 in Heq1. assumption. congruence.
      rewrite IHphi2 in Heq2. assumption. congruence.
      rewrite IHphi2 in Heq2. assumption. congruence.
  Qed.

  Lemma wfc_ex_aux_implies_not_bevar_occur phi ne :
    well_formed_closed_ex_aux phi ne ->
    bevar_occur phi ne = false.
  Proof.
    move: ne.
    induction phi; intros ne Hwfc; simpl; simpl in Hwfc; auto.
    - apply bool_decide_eq_false.
      case_match;[lia|congruence].
    - apply andb_true_iff in Hwfc.
      destruct Hwfc as [Hwfc1 Hwfc2].
      erewrite IHphi1; eauto.
    - apply andb_true_iff in Hwfc.
      destruct Hwfc as [Hwfc1 Hwfc2].
      erewrite IHphi1, IHphi2; eauto.
  Qed.

  Corollary wfc_mu_implies_not_bsvar_occur phi n :
    well_formed_closed_mu_aux phi 0 ->
    ~ bsvar_occur phi n.
  Proof.
    intros H.
    erewrite wfc_mu_aux_implies_not_bsvar_occur. exact notF.
    unfold well_formed_closed in H.
    eapply well_formed_closed_mu_aux_ind.
    2: eassumption. lia.
  Qed.

  Lemma wfc_ex_implies_not_bevar_occur phi n :
    well_formed_closed_ex_aux phi 0 ->
    bevar_occur phi n = false.
  Proof.
    intros H.
    erewrite wfc_ex_aux_implies_not_bevar_occur.
    { reflexivity. }
    eapply well_formed_closed_ex_aux_ind.
    2: apply H.
    lia.
  Qed.

  Lemma not_bsvar_occur_bsvar_subst phi psi n:
    well_formed_closed_mu_aux psi 0 -> well_formed_closed_mu_aux phi n ->
    ~ bsvar_occur (phi^[svar: n ↦ psi]) n.
  Proof.
    move: n.
    induction phi; intros n' H H0; simpl; auto.
    - intros Hcontra.
      case_match.
      + subst. simpl in Hcontra. case_match.
        * lia.
        * congruence.
      + apply wfc_mu_implies_not_bsvar_occur with (n := n') in H. congruence.
      + subst. simpl in Hcontra. inversion H0. case_match.
        * lia.
        * congruence.
    - intros Hcontra.
      destruct (bsvar_occur (phi1^[svar: n' ↦ psi]) n') eqn:Heq1, (bsvar_occur (phi2^[svar: n' ↦ psi]) n') eqn:Heq2.
      + eapply IHphi2; eauto. now apply andb_true_iff in H0.
      + eapply IHphi1; eauto. now apply andb_true_iff in H0.
      + eapply IHphi2; eauto. now apply andb_true_iff in H0.
      + simpl in Hcontra. congruence.
    - intros Hcontra.
      destruct (bsvar_occur ((phi1^[svar: n' ↦ psi])) n')
               eqn:Heq1, (bsvar_occur ((phi2^[svar: n' ↦ psi])) n') eqn:Heq2.
      + eapply IHphi1; eauto. now apply andb_true_iff in H0.
      + eapply IHphi1; eauto. now apply andb_true_iff in H0.
      + eapply IHphi2; eauto. now apply andb_true_iff in H0.
      + simpl in Hcontra. congruence.
  Qed.

  Lemma not_bsvar_occur_impl_no_neg_occ_and_no_pos_occ phi n:
    ~ bsvar_occur phi n ->
    no_negative_occurrence_db_b n phi && no_positive_occurrence_db_b n phi.
  Proof.
    move: n.
    induction phi; intros n' H; simpl; simpl in H; cbn; auto.
    - unfold not in H.
      case_match; auto.
    - destruct (bsvar_occur phi1 n') eqn: Heq3;
        destruct (bsvar_occur phi2 n') eqn:Heq4;
        simpl; auto.
      specialize (IHphi1 n'). specialize (IHphi2 n').
      rewrite Heq3 in IHphi1. rewrite Heq4 in IHphi2. clear Heq3 Heq4.
      specialize (IHphi1 ssrbool.not_false_is_true).
      specialize (IHphi2 ssrbool.not_false_is_true).
      apply andb_true_iff in IHphi1.
      apply andb_true_iff in IHphi2.
      destruct IHphi1 as [H1n H1p].
      destruct IHphi2 as [H2n H2p].
      rewrite H1n. rewrite H1p. rewrite H2n. rewrite H2p.
      simpl. reflexivity.
    - destruct (bsvar_occur phi1 n') eqn: Heq3;
        destruct (bsvar_occur phi2 n') eqn:Heq4;
        simpl; auto.
      specialize (IHphi1 n'). specialize (IHphi2 n').
      rewrite Heq3 in IHphi1. rewrite Heq4 in IHphi2. clear Heq3 Heq4.
      specialize (IHphi1 ssrbool.not_false_is_true).
      specialize (IHphi2 ssrbool.not_false_is_true).
      apply andb_true_iff in IHphi1.
      apply andb_true_iff in IHphi2.
      destruct IHphi1 as [H1n H1p].
      destruct IHphi2 as [H2n H2p].
      fold no_negative_occurrence_db_b no_positive_occurrence_db_b.
      rewrite H1n. rewrite H1p. rewrite H2n. rewrite H2p.
      simpl. reflexivity.
  Qed.

  Corollary not_bsvar_occur_impl_pos_occ_db phi n:
    ~ bsvar_occur phi n ->
    no_positive_occurrence_db_b n phi.
  Proof.
    intros H.
    pose proof (H1 := not_bsvar_occur_impl_no_neg_occ_and_no_pos_occ _ _ H).
    now apply andb_true_iff in H1.
  Qed.

  Corollary not_bsvar_occur_impl_neg_occ_db phi n:
    ~ bsvar_occur phi n ->
    no_negative_occurrence_db_b n phi.
  Proof.
    intros H.
    pose proof (H1 := not_bsvar_occur_impl_no_neg_occ_and_no_pos_occ _ _ H).
    now apply andb_true_iff in H1.
  Qed.

  Lemma x_eq_fresh_impl_x_notin_free_evars x ϕ:
    x = fresh_evar ϕ ->
    x ∉ free_evars ϕ.
  Proof.
    intros H.
    rewrite H.
    unfold fresh_evar.
    apply set_evar_fresh_is_fresh'.
  Qed.

  Hint Resolve x_eq_fresh_impl_x_notin_free_evars : core.

End syntax.

Module Notations.
  (* TODO: change Bot and Top to unicode symbols *)
  (* TODO: this associativity is wrong! However, stdpp disallows defining it otherwise. We could use @ instead, associated to the left *)
  Notation "a $ b" := (patt_app a b) (at level 65, right associativity) : ml_scope.
  Notation "'Bot'" := patt_bott : ml_scope.
  Notation "⊥" := patt_bott : ml_scope.
  Notation "a ---> b"  := (patt_imp a b) (at level 75, right associativity) : ml_scope.
  Notation "'ex' , phi" := (patt_exists phi) (at level 80) : ml_scope.
  Notation "'mu' , phi" := (patt_mu phi) (at level 80) : ml_scope.

  (*Notation "AC [ p ]" := (subst_ctx AC p) (at level 90) : ml_scope.*)
  Notation "C [ p ]" := (emplace C p) (at level 90) : ml_scope.

End Notations.

Module BoundVarSugar.
  (* Element variables - bound *)
  Notation b0 := (patt_bound_evar 0).
  Notation b1 := (patt_bound_evar 1).
  Notation b2 := (patt_bound_evar 2).
  Notation b3 := (patt_bound_evar 3).
  Notation b4 := (patt_bound_evar 4).
  Notation b5 := (patt_bound_evar 5).
  Notation b6 := (patt_bound_evar 6).
  Notation b7 := (patt_bound_evar 7).
  Notation b8 := (patt_bound_evar 8).
  Notation b9 := (patt_bound_evar 9).

  Notation B0 := (patt_bound_svar 0).
  Notation B1 := (patt_bound_svar 1).
  Notation B2 := (patt_bound_svar 2).
  Notation B3 := (patt_bound_svar 3).
  Notation B4 := (patt_bound_svar 4).
  Notation B5 := (patt_bound_svar 5).
  Notation B6 := (patt_bound_svar 6).
  Notation B7 := (patt_bound_svar 7).
  Notation B8 := (patt_bound_svar 8).
  Notation B9 := (patt_bound_svar 9).

End BoundVarSugar.

#[export]
 Hint Resolve
 evar_is_fresh_in_richer
 set_evar_fresh_is_fresh
 set_svar_fresh_is_fresh
 x_eq_fresh_impl_x_notin_free_evars
  : core.

#[export]
 Hint Extern 0 (is_true (@well_formed _ _)) => unfold is_true : core.

#[export]
 Hint Resolve well_formed_bott : core.

#[export]
 Hint Resolve well_formed_imp : core.

#[export]
 Hint Resolve well_formed_app : core.

#[export]
 Hint Resolve wf_sctx : core.

#[export]
 Hint Resolve well_formed_ex_app : core.

#[export]
 Hint Resolve well_formed_impl_well_formed_ex : core.

#[export]
 Hint Resolve well_formed_free_evar_subst : core.

#[export]
 Hint Resolve well_formed_free_evar_subst_0 : core.

#[export]
 Hint Resolve <- evar_is_fresh_in_exists : core.

#[export]
 Hint Resolve evar_is_fresh_in_evar_quantify : core.

(* Tactics for resolving goals involving sets *)
(*
        eauto 5 using @sets.elem_of_union_l, @sets.elem_of_union_r with typeclass_instances.
 *)
(*
  eauto depth using @sets.union_subseteq_l, @sets.union_subseteq_r
    with typeclass_instances.
 *)

(*
#[export]
 Hint Extern 10 (free_evars _ ⊆ free_evars _) => solve_free_evars_inclusion : core.
 *)

#[export]
 Hint Resolve wf_imp_wfc : core.

#[export]
 Hint Resolve wfc_ex_implies_not_bevar_occur : core.

Section with_signature.
  Context {Σ : Signature}.
  Open Scope ml_scope.

  Definition evar_quantify_ctx (x : evar) (n : db_index) (C : PatternCtx) : PatternCtx :=
    match decide (x = pcEvar C)  with
    | left _ => C
    | right pf => Build_PatternCtx (pcEvar C) ((pcPattern C)^{{evar: x ↦ n}})
    end.

  Lemma is_linear_context_evar_quantify (x : evar) (n : db_index) (C : PatternCtx) :
    is_linear_context C ->
    is_linear_context (evar_quantify_ctx x n C).
  Proof.
    intros Hlin. unfold evar_quantify_ctx.
    unfold is_linear_context in *.
    destruct (decide (x = pcEvar C)); simpl.
    - assumption.
    - destruct C. simpl in *.
      rename pcEvar into pcEvar0. rename pcPattern into pcPattern0.
      assert (count_evar_occurrences pcEvar0 (pcPattern0^{{evar: x ↦ n}})
              = count_evar_occurrences pcEvar0 pcPattern0).
      {
        clear Hlin.
        move: n.
        induction pcPattern0; intros n'; simpl in *; try lia.
        + destruct (decide (x0 = pcEvar0)); subst; simpl in *.
          * destruct (decide (x = pcEvar0)); try contradiction; simpl in *.
            destruct (decide (pcEvar0 = pcEvar0)); try contradiction. reflexivity.
          * destruct (decide (x = x0)); simpl; try reflexivity.
            destruct (decide (x0 = pcEvar0)); try contradiction.
            reflexivity.
        + rewrite IHpcPattern0_1. rewrite IHpcPattern0_2. reflexivity.
        + rewrite IHpcPattern0_1. rewrite IHpcPattern0_2. reflexivity.
        + rewrite IHpcPattern0. reflexivity.
        + rewrite IHpcPattern0. reflexivity.
      }
      congruence.
  Qed.

  Definition svar_quantify_ctx (X : svar) (n : db_index) (C : PatternCtx) : PatternCtx :=
    Build_PatternCtx (pcEvar C) ((pcPattern C)^{{svar: X ↦ n}}).

  Lemma is_linear_context_svar_quantify (X : svar) (n : db_index) (C : PatternCtx) :
    is_linear_context C ->
    is_linear_context (svar_quantify_ctx X n C).
  Proof.
    intros Hlin. unfold svar_quantify_ctx. unfold is_linear_context in *.
    destruct C. simpl in *.
    rename pcEvar into pcEvar0. rename pcPattern into pcPattern0.
    assert (count_evar_occurrences pcEvar0 (pcPattern0^{{svar: X ↦ n}})
            = count_evar_occurrences pcEvar0 pcPattern0).
    {
      clear Hlin.
      move: n.
      induction pcPattern0; intros n'; simpl in *; try lia.
      + case_match; subst; simpl in *; reflexivity.
      + rewrite IHpcPattern0_1. rewrite IHpcPattern0_2. reflexivity.
      + rewrite IHpcPattern0_1. rewrite IHpcPattern0_2. reflexivity.
      + rewrite IHpcPattern0. reflexivity.
      + rewrite IHpcPattern0. reflexivity.
    }
    congruence.
  Qed.

  Lemma svar_quantify_free_evar_subst ψ ϕ x X n:
    ψ^[[evar: x ↦ ϕ]]^{{svar: X ↦ n}} =
    ψ^{{svar: X ↦ n}}^[[evar: x ↦ ϕ^{{svar: X ↦ n}}]].
  Proof.
    move: n.
    induction ψ; intros n'; simpl; auto.
    - case_match.
      + auto.
      + simpl. reflexivity.
    - case_match; reflexivity.
    - rewrite IHψ1. rewrite IHψ2. reflexivity.
    - rewrite IHψ1. rewrite IHψ2. reflexivity.
    - rewrite IHψ. reflexivity.
    - rewrite IHψ. Fail reflexivity.
  Abort. (* OOPS, does not hold. The problem is that [free_evar_subst'] does not wrap the target
            in nest_mu. *)

  Lemma svar_quantify_emplace X n C ϕ:
    (emplace C ϕ)^{{svar: X ↦ n}} = emplace (svar_quantify_ctx X n C) (ϕ^{{svar: X ↦ n}}).
  Proof.
    destruct C.
    unfold svar_quantify_ctx,emplace. simpl.
  Abort.

  Lemma evar_quantify_subst_ctx x n AC ϕ:
    x ∉ AC_free_evars AC ->
    (subst_ctx AC ϕ)^{{evar: x ↦ n}} = subst_ctx AC (ϕ^{{evar: x ↦ n}}).
  Proof.
    intros Hx.
    induction AC.
    - reflexivity.
    - simpl. simpl in Hx.
      rewrite IHAC.
      { set_solver. }
      rewrite [p^{{evar: x ↦ n}}]evar_quantify_fresh.
      unfold evar_is_fresh_in. set_solver.
      reflexivity.
    - simpl. simpl in Hx.
      rewrite IHAC.
      { set_solver. }
      rewrite [p^{{evar: x ↦ n}}]evar_quantify_fresh.
      unfold evar_is_fresh_in. set_solver.
      reflexivity.
  Qed.

   Lemma wfp_free_svar_subst ϕ ψ X:
    well_formed_closed_mu_aux ψ 0 ->
    well_formed_positive ψ = true ->
    well_formed_positive ϕ = true ->
    svar_has_negative_occurrence X ϕ = false ->
    well_formed_positive (ϕ^[[svar: X ↦ ψ]]) = true
  with wfp_neg_free_svar_subst ϕ ψ X:
    well_formed_closed_mu_aux ψ 0 ->
    well_formed_positive ψ = true ->
    well_formed_positive ϕ = true ->
    svar_has_positive_occurrence X ϕ = false ->
    well_formed_positive (ϕ^[[svar: X ↦ ψ]]) = true.
  Proof.
    - intros Hwfcψ Hwfpψ Hwfpϕ Hnoneg.
      induction ϕ; simpl; auto.
      + case_match; [|reflexivity].
        assumption.
      + cbn in Hnoneg. cbn in Hwfpϕ.
        apply orb_false_iff in Hnoneg.
        destruct_and!.
        specialize (IHϕ1 ltac:(assumption) ltac:(assumption)).
        specialize (IHϕ2 ltac:(assumption) ltac:(assumption)).
        split_and!; auto.
      + cbn in Hnoneg. cbn in Hwfpϕ.
        apply orb_false_iff in Hnoneg.
        destruct_and!.
        pose proof (IH1 := wfp_neg_free_svar_subst ϕ1 ψ X ltac:(assumption)).
        feed specialize IH1.
        { assumption. }
        { assumption. }
        { assumption. }
        specialize (IHϕ2 ltac:(assumption)).
        split_and!; auto.
      + cbn in Hnoneg. cbn in Hwfpϕ. destruct_and!.
        rewrite IHϕ. assumption. assumption. split_and!; auto.
        rewrite nno_free_svar_subst.
        assumption. assumption.
    -
      intros Hwfcψ Hwfpψ Hwfpϕ Hnoneg.
      induction ϕ; simpl; auto.
      + case_match; [|reflexivity].
        assumption.
      + cbn in Hnoneg. cbn in Hwfpϕ.
        apply orb_false_iff in Hnoneg.
        destruct_and!.
        specialize (IHϕ1 ltac:(assumption) ltac:(assumption)).
        specialize (IHϕ2 ltac:(assumption) ltac:(assumption)).
        split_and!; auto.
      + cbn in Hnoneg. cbn in Hwfpϕ.
        apply orb_false_iff in Hnoneg.
        destruct_and!.
        pose proof (IH1 := wfp_free_svar_subst ϕ1 ψ X ltac:(assumption)).
        feed specialize IH1.
        { assumption. }
        { assumption. }
        { assumption. }
        specialize (IHϕ2 ltac:(assumption)).
        split_and!; auto.
      + cbn in Hnoneg. cbn in Hwfpϕ. destruct_and!.
        rewrite IHϕ. assumption. assumption. split_and!; auto.
        rewrite nno_free_svar_subst.
        assumption. assumption.
  Qed.

  Lemma count_evar_occurrences_bevar_subst pcEvar ϕ ψ k:
    count_evar_occurrences pcEvar ψ = 0 ->
    count_evar_occurrences pcEvar (ϕ^[evar: k ↦ ψ]) = count_evar_occurrences pcEvar ϕ.
  Proof.
    intros H.
    move: k.
    induction ϕ; intros k; simpl; auto.
    - case_match; auto.
  Qed.

  Lemma count_evar_occurrences_evar_open pcEvar ϕ x:
    pcEvar <> x ->
    count_evar_occurrences pcEvar (ϕ^{evar: 0 ↦ x}) = count_evar_occurrences pcEvar ϕ.
  Proof.
    intros H. apply count_evar_occurrences_bevar_subst. simpl. case_match; congruence.
  Qed.

  Lemma count_evar_occurrences_svar_open x dbi ϕ ψ:
    count_evar_occurrences x ψ = 0 ->
    count_evar_occurrences x (ϕ^[svar: dbi ↦ ψ]) = count_evar_occurrences x ϕ.
  Proof.
    move: dbi.
    induction ϕ; intros dbi H; simpl; auto.
    case_match; auto.
  Qed.

  Lemma free_evar_subst_bsvar_subst ϕ ψ ξ x dbi:
    well_formed_closed_mu_aux ξ 0 ->
    evar_is_fresh_in x ψ ->
    (ϕ^[svar: dbi ↦ ψ])^[[evar:x ↦ ξ]]
    = (ϕ^[[evar:x ↦ ξ]])^[svar: dbi ↦ ψ].
  Proof.
    move: dbi.
    induction ϕ; intros dbi H1 H2; simpl; auto.
    - repeat case_match; auto.
      erewrite well_formed_bsvar_subst. reflexivity.
      2: eassumption.
      lia.
    - repeat case_match; auto.
      apply free_evar_subst_no_occurrence. assumption.
    - rewrite IHϕ1; auto. rewrite IHϕ2; auto.
    - rewrite IHϕ1; auto. rewrite IHϕ2; auto.
    - rewrite IHϕ; auto.
    - rewrite IHϕ; auto.
  Qed.

  Lemma wf_svar_open_from_wf_mu X ϕ:
    well_formed (patt_mu ϕ) ->
    well_formed (ϕ^{svar: 0 ↦ X}).
  Proof.
    intros H. (*compoundDecomposeWfGoal.
    apply (unary_wfxy_compose _).*) wf_auto2.
    (*
    wf_auto2_fast_done.
    compositeSimplifyAllWfHyps.
    wf_auto2_composite_step.
    wf_auto2_composite_step.
    Set Printing All.
    Search well_formed svar_open.
    wf_auto2.
    destruct_and!;
        [ (apply wfp_svar_open; auto)
        | (apply wfc_mu_aux_body_mu_imp1; assumption)
        | (apply wfc_ex_aux_body_mu_imp1; assumption)
        ].
    *)
  Qed.

  Lemma wfcex_after_subst_impl_wfcex_before ϕ ψ x dbi:
    well_formed_closed_ex_aux (ϕ^[[evar:x ↦ ψ]]) dbi = true ->
    well_formed_closed_ex_aux ϕ dbi = true.
  Proof.
    intros Hsubst.
    move: dbi Hsubst.
    induction ϕ; intros dbi Hsubst; simpl in *; try reflexivity; auto with nocore.
    - apply andb_prop in Hsubst. destruct Hsubst as [Hsubst1 Hsubst2].
      specialize (IHϕ1 dbi Hsubst1).
      specialize (IHϕ2 dbi Hsubst2).
      rewrite IHϕ1 IHϕ2.
      reflexivity.
    - apply andb_prop in Hsubst. destruct Hsubst as [Hsubst1 Hsubst2].
      specialize (IHϕ1 dbi Hsubst1).
      specialize (IHϕ2 dbi Hsubst2).
      rewrite IHϕ1 IHϕ2.
      reflexivity.
  Qed.

  Lemma wfcmu_after_subst_impl_wfcmu_before ϕ ψ x dbi:
    well_formed_closed_mu_aux (ϕ^[[evar:x ↦ ψ]]) dbi = true ->
    well_formed_closed_mu_aux ϕ dbi = true.
  Proof.
    intros Hsubst.
    move: dbi Hsubst.
    induction ϕ; intros dbi Hsubst; simpl in *; try reflexivity; auto with nocore.
    - apply andb_prop in Hsubst. destruct Hsubst as [Hsubst1 Hsubst2].
      specialize (IHϕ1 dbi Hsubst1).
      specialize (IHϕ2 dbi Hsubst2).
      rewrite IHϕ1 IHϕ2.
      reflexivity.
    - apply andb_prop in Hsubst. destruct Hsubst as [Hsubst1 Hsubst2].
      specialize (IHϕ1 dbi Hsubst1).
      specialize (IHϕ2 dbi Hsubst2).
      rewrite IHϕ1 IHϕ2.
      reflexivity.
  Qed.

  Lemma nno_after_subst_impl_nno_before ϕ ψ x dbi:
    no_negative_occurrence_db_b dbi (ϕ^[[evar:x ↦ ψ]]) = true ->
    no_negative_occurrence_db_b dbi ϕ = true
  with npo_after_subst_impl_npo_before ϕ ψ x dbi:
    no_positive_occurrence_db_b dbi (ϕ^[[evar:x ↦ ψ]]) = true ->
    no_positive_occurrence_db_b dbi ϕ = true.
  Proof.
    - move: dbi.
      induction ϕ; intros dbi Hsubst; cbn in *; try reflexivity; auto with nocore.
      + apply andb_prop in Hsubst. destruct Hsubst as [Hsubst1 Hsubst2].
        specialize (IHϕ1 dbi Hsubst1).
        specialize (IHϕ2 dbi Hsubst2).
        rewrite IHϕ1. rewrite IHϕ2.
        reflexivity.
      + apply andb_prop in Hsubst. destruct Hsubst as [Hsubst1 Hsubst2].
        fold no_positive_occurrence_db_b in Hsubst1.
        fold no_positive_occurrence_db_b.
        specialize (IHϕ2 dbi Hsubst2).
        rewrite IHϕ2.
        erewrite npo_after_subst_impl_npo_before.
        reflexivity. eassumption.
    - move: dbi.
      induction ϕ; intros dbi Hsubst; cbn in *; try reflexivity; auto with nocore.
      + apply andb_prop in Hsubst. destruct Hsubst as [Hsubst1 Hsubst2].
        specialize (IHϕ1 dbi Hsubst1).
        specialize (IHϕ2 dbi Hsubst2).
        rewrite IHϕ1. rewrite IHϕ2.
        reflexivity.
      + apply andb_prop in Hsubst. destruct Hsubst as [Hsubst1 Hsubst2].
        fold no_negative_occurrence_db_b in Hsubst1.
        fold no_negative_occurrence_db_b.
        specialize (IHϕ2 dbi Hsubst2).
        rewrite IHϕ2.
        erewrite nno_after_subst_impl_nno_before.
        reflexivity. eassumption.
  Qed.

  Lemma wfp_after_subst_impl_wfp_before ϕ ψ x:
    well_formed_positive (ϕ^[[evar:x ↦ ψ]]) = true ->
    well_formed_positive ϕ = true.
  Proof.
    intros Hsubst.
    move: Hsubst.
    induction ϕ; intros Hsubst; simpl in *; try reflexivity; auto with nocore.
    - apply andb_prop in Hsubst. destruct Hsubst as [Hsubst1 Hsubst2].
      specialize (IHϕ1 Hsubst1).
      specialize (IHϕ2 Hsubst2).
      rewrite IHϕ1. rewrite IHϕ2.
      reflexivity.
    - apply andb_prop in Hsubst. destruct Hsubst as [Hsubst1 Hsubst2].
      specialize (IHϕ1 Hsubst1).
      specialize (IHϕ2 Hsubst2).
      rewrite IHϕ1. rewrite IHϕ2.
      reflexivity.
    - apply andb_prop in Hsubst. destruct Hsubst as [Hnno Hsubst].
      specialize (IHϕ Hsubst).
      rewrite IHϕ.
      erewrite nno_after_subst_impl_nno_before.
      reflexivity. eassumption.
  Qed.

  Lemma wf_after_subst_impl_wf_before ϕ ψ x:
    well_formed (ϕ^[[evar:x ↦ ψ]]) = true ->
    well_formed ϕ = true.
  Proof.
    intros H.
    unfold well_formed,well_formed_closed in *.
    destruct_and!.
    split_and!.
    - eapply wfp_after_subst_impl_wfp_before. eassumption.
    - eapply wfcmu_after_subst_impl_wfcmu_before. eassumption.
    - eapply wfcex_after_subst_impl_wfcex_before. eassumption.
  Qed.

  Lemma wf_emplaced_impl_wf_context (C : PatternCtx) (ψ : Pattern) :
    well_formed (emplace C ψ) = true ->
    PC_wf C.
  Proof.
    intros H.
    unfold emplace in H. unfold PC_wf.
    eapply wf_after_subst_impl_wf_before.
    eassumption.
  Qed.

  Global Instance evar_is_fresh_in_dec (x : evar) (p : Pattern) :
    Decision (evar_is_fresh_in x p).
  Proof.
    unfold evar_is_fresh_in.
    apply not_dec. apply gset_elem_of_dec.
  Defined.

  Definition evar_is_fresh_in_list (x : evar) (l : list Pattern) :=
    Forall (evar_is_fresh_in x) l.

  Global Instance evar_is_fresh_in_list_dec (x : evar) (l : list Pattern) :
    Decision (evar_is_fresh_in_list x l).
  Proof.
    unfold Decision. unfold evar_is_fresh_in_list.
    apply Forall_dec.
    intros p.
    apply evar_is_fresh_in_dec.
  Defined.

  Lemma evar_fresh_in_foldr x g l:
  evar_is_fresh_in x (foldr patt_imp g l) <-> evar_is_fresh_in x g /\ evar_is_fresh_in_list x l.
  Proof.
  induction l; simpl; split; intros H.
  - split;[assumption|]. unfold evar_is_fresh_in_list. apply Forall_nil. exact I.
  - destruct H as [H _]. exact H.
  - unfold evar_is_fresh_in_list,evar_is_fresh_in in *. simpl in *.
    split;[set_solver|].
    apply Forall_cons.
    destruct IHl as [IHl1 IHl2].
    split;[set_solver|].
    apply IHl1. set_solver.
  - unfold evar_is_fresh_in_list,evar_is_fresh_in in *. simpl in *.
    destruct IHl as [IHl1 IHl2].
    destruct H as [H1 H2].
    inversion H2; subst.
    specialize (IHl2 (conj H1 H4)).
    set_solver.
  Qed.

  Global Instance svar_is_fresh_in_dec (X : svar) (p : Pattern) :
    Decision (svar_is_fresh_in X p).
  Proof.
    unfold svar_is_fresh_in.
    apply not_dec. apply gset_elem_of_dec.
  Defined.

  Definition svar_is_fresh_in_list (X : svar) (l : list Pattern) :=
    Forall (svar_is_fresh_in X) l.

  Global Instance svar_is_fresh_in_list_dec (X : svar) (l : list Pattern) :
    Decision (svar_is_fresh_in_list X l).
  Proof.
    unfold Decision. unfold svar_is_fresh_in_list.
    apply Forall_dec.
    intros p.
    apply svar_is_fresh_in_dec.
  Defined.

  Lemma wfc_ex_lower ϕ n:
    bevar_occur ϕ n = false ->
    well_formed_closed_ex_aux ϕ (S n) = true ->
    well_formed_closed_ex_aux ϕ n = true.
  Proof.
    intros H1 H2.
    move: n H1 H2.
    induction ϕ; intros n' H1 H2; simpl in *; auto.
    - repeat case_match; auto. lia.
    - apply orb_false_elim in H1. destruct_and!.
      erewrite -> IHϕ1 by eassumption.
      erewrite -> IHϕ2 by eassumption.
      reflexivity.
    - apply orb_false_elim in H1. destruct_and!.
      erewrite -> IHϕ1 by eassumption.
      erewrite -> IHϕ2 by eassumption.
      reflexivity.
  Qed.

  Lemma wfc_mu_lower ϕ n:
    bsvar_occur ϕ n = false ->
    well_formed_closed_mu_aux ϕ (S n) = true ->
    well_formed_closed_mu_aux ϕ n = true.
  Proof.
    intros H1 H2.
    move: n H1 H2.
    induction ϕ; intros n' H1 H2; simpl in *; auto.
    - repeat case_match; auto. lia.
    - apply orb_false_elim in H1. destruct_and!.
      erewrite -> IHϕ1 by eassumption.
      erewrite -> IHϕ2 by eassumption.
      reflexivity.
    - apply orb_false_elim in H1. destruct_and!.
      erewrite -> IHϕ1 by eassumption.
      erewrite -> IHϕ2 by eassumption.
      reflexivity.
  Qed.

  Lemma wf_ex_quan_impl_wf (x : evar) (ϕ : Pattern):
    bevar_occur ϕ 0 = false ->
    well_formed (exists_quantify x ϕ) = true ->
    well_formed ϕ = true.
  Proof.
    intros H0 H. unfold exists_quantify in H.
    unfold well_formed, well_formed_closed in *. destruct_and!. simpl in *.
    split_and!.
    - eapply wfp_evar_quan_impl_wfp. eassumption.
    - eapply wfcmu_evar_quan_impl_wfcmu. eassumption.
    - apply wfcex_evar_quan_impl_wfcex in H3.
      apply wfc_ex_lower; assumption.
  Qed.

  Lemma bevar_occur_evar_open_2 dbi x ϕ:
    well_formed_closed_ex_aux ϕ dbi ->
    bevar_occur (ϕ^{evar: dbi ↦ x}) dbi = false.
  Proof.
    move: dbi.
    unfold evar_open.
    induction ϕ; intros dbi Hwf; simpl; try reflexivity.
    - case_match; simpl; auto.
      case_match; try lia. simpl in Hwf. case_match; [lia | congruence ].
    - simpl in Hwf. destruct_and!.
      rewrite IHϕ1; auto. rewrite IHϕ2; auto.
    - simpl in Hwf. destruct_and!.
      rewrite IHϕ1; auto. rewrite IHϕ2; auto.
    - rewrite IHϕ; auto.
    - rewrite IHϕ; auto.
  Qed.

  Lemma bsvar_occur_svar_open_2 dbi X ϕ:
    well_formed_closed_mu_aux ϕ dbi ->
    bsvar_occur (ϕ^{svar: dbi ↦ X}) dbi = false.
  Proof.
    move: dbi.
    unfold svar_open.
    induction ϕ; intros dbi Hwf; simpl; try reflexivity.
    - case_match; simpl; auto.
      case_match; try lia. simpl in Hwf. case_match; [lia | congruence ].
    - simpl in Hwf. destruct_and!.
      rewrite IHϕ1; auto. rewrite IHϕ2; auto.
    - simpl in Hwf. destruct_and!.
      rewrite IHϕ1; auto. rewrite IHϕ2; auto.
    - rewrite IHϕ; auto.
    - rewrite IHϕ; auto.
  Qed.

  Lemma svar_has_negative_occurrence_free_evar_subst
    (ϕ ψ: Pattern) (x : evar) (X : svar) :
    svar_is_fresh_in X ψ ->
    svar_has_negative_occurrence X ϕ^[[evar:x↦ψ]] = svar_has_negative_occurrence X ϕ
  with svar_has_positive_occurrence_free_evar_subst
    (ϕ ψ: Pattern) (x : evar) (X : svar) :
    svar_is_fresh_in X ψ ->
    svar_has_positive_occurrence X ϕ^[[evar:x↦ψ]] = svar_has_positive_occurrence X ϕ
  .
  Proof.
    {
      intros HXψ.
      induction ϕ; cbn in *; try reflexivity.
      {
        destruct (decide (x = x0)).
        {
          apply svar_hno_false_if_fresh.
          exact HXψ.
        }
        {
          cbn. reflexivity.
        }
      }
      {
        by rewrite IHϕ1 IHϕ2.
      }
      {
        fold svar_has_positive_occurrence.
        rewrite IHϕ2.
        rewrite svar_has_positive_occurrence_free_evar_subst.
        { exact HXψ. }
        reflexivity.
      }
      {
        exact IHϕ.
      }
      {
        exact IHϕ.
      }
    }
    {
      intros HXψ.
      induction ϕ; cbn in *; try reflexivity.
      {
        destruct (decide (x = x0)).
        {
          apply svar_hpo_false_if_fresh.
          exact HXψ.
        }
        {
          cbn. reflexivity.
        }
      }
      {
        by rewrite IHϕ1 IHϕ2.
      }
      {
        fold svar_has_negative_occurrence.
        rewrite IHϕ2.
        rewrite svar_has_negative_occurrence_free_evar_subst.
        { exact HXψ. }
        reflexivity.
      }
      {
        exact IHϕ.
      }
      {
        exact IHϕ.
      }
    }
  Qed.

  Fixpoint maximal_mu_depth_to (depth : nat) (E : evar) (ψ : Pattern) : nat :=
    match ψ with
    | patt_bott => 0
    | patt_sym _ => 0
    | patt_bound_evar _ => 0
    | patt_bound_svar _ => 0
    | patt_free_svar _ => 0
    | patt_free_evar E' =>
      match (decide (E' = E)) with
      | left _ => depth
      | right _ => 0
      end
    | patt_imp ψ₁ ψ₂
      => Nat.max
        (maximal_mu_depth_to depth E ψ₁)
        (maximal_mu_depth_to depth E ψ₂)
    | patt_app ψ₁ ψ₂
      => Nat.max
        (maximal_mu_depth_to depth E ψ₁)
        (maximal_mu_depth_to depth E ψ₂)
    | patt_exists ψ' =>
      maximal_mu_depth_to depth E ψ'
    | patt_mu ψ' =>
      maximal_mu_depth_to (S depth) E ψ'
    end.

  Fixpoint maximal_mu_depth_to_sv (depth : nat) (V : svar) (ψ : Pattern) : nat :=
    match ψ with
    | patt_bott => 0
    | patt_sym _ => 0
    | patt_bound_evar _ => 0
    | patt_bound_svar _ => 0
    | patt_free_evar _ => 0
    | patt_free_svar V' =>
      match (decide (V' = V)) with
      | left _ => depth
      | right _ => 0
      end
    | patt_imp ψ₁ ψ₂
      => Nat.max
        (maximal_mu_depth_to_sv depth V ψ₁)
        (maximal_mu_depth_to_sv depth V ψ₂)
    | patt_app ψ₁ ψ₂
      => Nat.max
        (maximal_mu_depth_to_sv depth V ψ₁)
        (maximal_mu_depth_to_sv depth V ψ₂)
    | patt_exists ψ' =>
      maximal_mu_depth_to_sv depth V ψ'
    | patt_mu ψ' =>
      maximal_mu_depth_to_sv (S depth) V ψ'
    end.

  Lemma maximal_mu_depth_to_svar_open depth E n X ψ:
  maximal_mu_depth_to depth E (ψ^{svar: n ↦ X})
    = maximal_mu_depth_to depth E ψ.
  Proof.
    unfold svar_open.
    move: depth n.
    induction ψ; intros depth n'; simpl; try reflexivity; auto.
    {
      case_match; simpl; try reflexivity.
    }
  Qed.

  Lemma maximal_mu_depth_to_sv_evar_open depth V n X ψ:
    maximal_mu_depth_to_sv depth V (ψ^{evar: n ↦ X})
    = maximal_mu_depth_to_sv depth V ψ.
  Proof.
    unfold evar_open.
    move: depth n.
    induction ψ; intros depth n'; simpl; try reflexivity; auto.
    {
      case_match; simpl; try reflexivity.
    }
  Qed.

  Lemma evar_open_mu_depth depth E n x ψ:
    E <> x ->
    maximal_mu_depth_to depth E (ψ^{evar: n ↦ x})
    = maximal_mu_depth_to depth E ψ.
  Proof.
    intros Hne.
    unfold evar_open.
    move: depth n.
    induction ψ; intros depth n'; simpl; try reflexivity; auto.
    {
      case_match; simpl; try reflexivity.
      case_match; simpl; try reflexivity.
      subst. contradiction.
    }
  Qed.

  Lemma svar_open_mu_depth_sc depth V n x ψ:
  V <> x ->
  maximal_mu_depth_to_sv depth V (ψ^{svar: n ↦ x})
  = maximal_mu_depth_to_sv depth V ψ.
  Proof.
    intros Hne.
    unfold svar_open.
    move: depth n.
    induction ψ; intros depth n'; simpl; try reflexivity; auto.
    {
      case_match; simpl; try reflexivity.
      case_match; simpl; try reflexivity.
      subst. contradiction.
    }
  Qed.

  Lemma svar_open_mu_depth depth E n X ψ:
    maximal_mu_depth_to depth E (ψ^{svar: n ↦ X})
    = maximal_mu_depth_to depth E ψ.
  Proof.
    unfold svar_open.
    move: depth n.
    induction ψ; intros depth n'; simpl; try reflexivity; auto.
    {
      case_match; simpl; try reflexivity.
    }
  Qed.

  Lemma maximal_mu_depth_to_0 E ψ depth:
    E ∉ free_evars ψ ->
    maximal_mu_depth_to depth E ψ = 0.
  Proof.
    intros Hnotin.
    move: E depth Hnotin.
    induction ψ; intros E depth Hnotin; simpl in *; try reflexivity.
    { case_match. set_solver. reflexivity. }
    { rewrite IHψ1. set_solver. rewrite IHψ2. set_solver. reflexivity. }
    { rewrite IHψ1. set_solver. rewrite IHψ2. set_solver. reflexivity. }
    { rewrite IHψ. exact Hnotin. reflexivity. }
    { rewrite IHψ. exact Hnotin. reflexivity. }
  Qed.

  Lemma maximal_mu_depth_to_sv_0 V ψ depth:
    V ∉ free_svars ψ ->
    maximal_mu_depth_to_sv depth V ψ = 0.
  Proof.
    intros Hnotin.
    move: V depth Hnotin.
    induction ψ; intros E depth Hnotin; simpl in *; try reflexivity.
    { case_match. set_solver. reflexivity. }
    { rewrite IHψ1. set_solver. rewrite IHψ2. set_solver. reflexivity. }
    { rewrite IHψ1. set_solver. rewrite IHψ2. set_solver. reflexivity. }
    { rewrite IHψ. exact Hnotin. reflexivity. }
    { rewrite IHψ. exact Hnotin. reflexivity. }
  Qed.

  Lemma maximal_mu_depth_to_S E ψ depth:
    E ∈ free_evars ψ ->
    maximal_mu_depth_to (S depth) E ψ
    = S (maximal_mu_depth_to depth E ψ).
  Proof.
    intros Hin.
    move: E depth Hin.
    induction ψ; intros E depth Hin; simpl in *; try set_solver.
    { case_match. reflexivity. set_solver. }
    {
      destruct (decide (E ∈ free_evars ψ1)),(decide (E ∈ free_evars ψ2)).
      {
        rewrite IHψ1. assumption. rewrite IHψ2. assumption. simpl. reflexivity.
      }
      {
        rewrite IHψ1. assumption.
        apply maximal_mu_depth_to_0 with (depth := S depth) in n
          as n'.
        apply maximal_mu_depth_to_0 with (depth := depth) in n.
        rewrite n. lia.
      }
      {
        rewrite IHψ2. assumption.
        apply maximal_mu_depth_to_0 with (depth := S depth) in n
          as n'.
        apply maximal_mu_depth_to_0 with (depth := depth) in n.
        rewrite n. lia.
      }
      {
        exfalso. set_solver.
      }
    }
    {
      destruct (decide (E ∈ free_evars ψ1)),(decide (E ∈ free_evars ψ2)).
      {
        rewrite IHψ1. assumption. rewrite IHψ2. assumption. simpl. reflexivity.
      }
      {
        rewrite IHψ1. assumption.
        apply maximal_mu_depth_to_0 with (depth := S depth) in n
          as n'.
        apply maximal_mu_depth_to_0 with (depth := depth) in n.
        rewrite n. lia.
      }
      {
        rewrite IHψ2. assumption.
        apply maximal_mu_depth_to_0 with (depth := S depth) in n
          as n'.
        apply maximal_mu_depth_to_0 with (depth := depth) in n.
        rewrite n. lia.
      }
      {
        exfalso. set_solver.
      }
    }
  Qed.

  Lemma maximal_mu_depth_to_sv_S V ψ depth:
    V ∈ free_svars ψ ->
    maximal_mu_depth_to_sv (S depth) V ψ
    = S (maximal_mu_depth_to_sv depth V ψ).
  Proof.
    intros Hin.
    move: V depth Hin.
    induction ψ; intros V depth Hin; simpl in *; try set_solver.
    { case_match. reflexivity. set_solver. }
    {
      destruct (decide (V ∈ free_svars ψ1)),(decide (V ∈ free_svars ψ2)).
      {
        rewrite IHψ1. assumption. rewrite IHψ2. assumption. simpl. reflexivity.
      }
      {
        rewrite IHψ1. assumption.
        apply maximal_mu_depth_to_sv_0 with (depth := S depth) in n
          as n'.
        apply maximal_mu_depth_to_sv_0 with (depth := depth) in n.
        rewrite n. lia.
      }
      {
        rewrite IHψ2. assumption.
        apply maximal_mu_depth_to_sv_0 with (depth := S depth) in n
          as n'.
        apply maximal_mu_depth_to_sv_0 with (depth := depth) in n.
        rewrite n. lia.
      }
      {
        exfalso. set_solver.
      }
    }
    {
      destruct (decide (V ∈ free_svars ψ1)),(decide (V ∈ free_svars ψ2)).
      {
        rewrite IHψ1. assumption. rewrite IHψ2. assumption. simpl. reflexivity.
      }
      {
        rewrite IHψ1. assumption.
        apply maximal_mu_depth_to_sv_0 with (depth := S depth) in n
          as n'.
        apply maximal_mu_depth_to_sv_0 with (depth := depth) in n.
        rewrite n. lia.
      }
      {
        rewrite IHψ2. assumption.
        apply maximal_mu_depth_to_sv_0 with (depth := S depth) in n
          as n'.
        apply maximal_mu_depth_to_sv_0 with (depth := depth) in n.
        rewrite n. lia.
      }
      {
        exfalso. set_solver.
      }
    }
  Qed.

  Definition mu_in_evar_path E ψ sdepth
  := negb (Nat.eqb 0 (maximal_mu_depth_to sdepth E ψ)).

End with_signature.

(* TODO remove these hints *)

#[export]
 Hint Resolve well_formed_positive_svar_quantify : core.

#[export]
 Hint Resolve no_positive_occurrence_svar_quantify : core.

#[export]
 Hint Resolve no_negative_occurrence_svar_quantify : core.

#[export]
 Hint Resolve wfc_impl_no_neg_occ : core.

#[export]
 Hint Resolve wfp_free_svar_subst : core.

#[export]
 Hint Resolve wfp_neg_free_svar_subst : core.

#[export]
 Hint Resolve svar_quantify_closed_ex : core.

#[export]
 Hint Resolve svar_quantify_closed_mu : core.

#[export]
 Hint Resolve evar_quantify_positive : core.

#[export]
 Hint Resolve evar_quantify_closed_mu : core.

#[export]
 Hint Resolve evar_quantify_closed_ex : core.

#[export]
 Hint Resolve wfp_evar_open : core.

#[export]
 Hint Resolve wfc_mu_aux_body_ex_imp1 : core.

#[export]
 Hint Resolve wfc_ex_aux_body_ex_imp1 : core.

#[export]
Hint Resolve bevar_subst_positive_2 : core.

#[export]
Hint Resolve wfc_mu_aux_bevar_subst : core.

#[export]
Hint Resolve wfc_ex_aux_bevar_subst : core.

#[export]
Hint Resolve wfp_svar_open : core.

#[export]
 Hint Resolve wfc_mu_free_evar_subst : core.


(* Sections taking care of let-ins for inductive types *)

Section Foo.

Inductive foo (A : Type) (x : A) (y := x) (y : A) := Foo.

End Foo.

Section Foo2.

Variable B : Type.
Variable b : B.
Let c := b.
Inductive foo2 (A : Type) (x : A) (y := x) (y : A) := Foo2 : c=c -> foo2 A x y.

End Foo2.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall H K O L Hprime Kprime Oprime Lprime Kprimeprime Lprimeprime I Iprime : Universe, ((wd_ Oprime Kprimeprime /\ (wd_ Oprime Kprime /\ (wd_ Oprime Lprimeprime /\ (wd_ Oprime Lprime /\ (wd_ O H /\ (wd_ K I /\ (wd_ I L /\ (wd_ K L /\ (wd_ O I /\ (wd_ Oprime Iprime /\ (wd_ Iprime Lprimeprime /\ (wd_ Kprimeprime Iprime /\ (wd_ Iprime Lprimeprime /\ (wd_ Kprimeprime Lprimeprime /\ (wd_ K O /\ (col_ Oprime Kprime Kprimeprime /\ (col_ Oprime Lprime Lprimeprime /\ (col_ K I L /\ (col_ Oprime Iprime Hprime /\ (col_ O I H /\ (col_ Kprimeprime Iprime Lprimeprime /\ col_ Kprimeprime Oprime Iprime))))))))))))))))))))) -> col_ Kprime Oprime Lprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import BGPSpec.
Require Import Miscy.
Require Import Fairness.
Require Import Environment.
Require Import Evolution.
Require Import InitState.

Section GaoRexford.
  Context `{PR:@PrefixClass}.
  Context `{IT:@InternetTopologyClass}.
  Context `{AT:@AttributesClass IT}.
  Context `{IP:@InitialPrefixClass PR IT AT}.
  Context `{OD:@OrderingClass IT AT}.
  Context `{RU:@RuleClass IT AT PR IP OD}.
  Context `{IS:@InitialState PR IT AT IP OD RU}.

  Definition TO := @fullMeshTopology IT.
  Definition PA := @pathAttributesAttributes IT AT.
  Definition CO := @configClass IT AT PR IP OD RU.

  Variable e:@evolutionFrom _ (@FairTransition PR TO PA CO) s0.

  Definition InternetConverges : Type.
    refine { A:(forall (p:Prefix) x (r:router x), RoutingInformation) | _ }.
    refine (eventually _ (@FairTransition PR TO PA CO) (fun s => _) (s0;e)).
    refine (forall (x:AS) (r:router x) (p:Prefix), _ : Prop).
    refine (locRIB (routerState (networkState' s) (x;r)) p = A p x r).
  Defined.

  (*
  above is the trusted definition of what
  it means for the internet to converge
  ----------------------------------------------
  below is the proof that the internet converges
  *)

  Require Import Evolution.
  Require Import Claims.
  Require Import DominantConvergence.
  Require Import InternalConvergence.
  Require Import BGPConvergence.
  Require Import EvolutionLemmas.
  Require Import Sugar.
  Require Import PathInvariant.

  Opaque export'.
  Opaque import'.
  Opaque eqDecide.
  Opaque enumerate.
  Opaque argMax.

  Definition CV := convergence (s0;e).

  Section SinglePrefix.
    Variable prefix:Prefix.

    Definition SP := singlePrefixClass prefix.
    Existing Instance SP.

    Definition BC := @bgpConvergence PR IT AT IP OD RU IS e SP.

    Definition CD := @convergenceDefinitions PR IT AT IP OD RU CV SP BC.

    Definition LC := @linkConverges PR IT AT IP OD RU IS e prefix.

    Definition AC := @asConvergenceLemmas PR IT AT IP OD RU CV SP BC.

    Definition RouterPrefixConverges : Type.
      refine (forall x (r:router x), _).
      refine {a : RoutingInformation | @converges _ CV (fun s => _)}.
      refine (locRIB (ribs s x r) p = a).
    Defined.

    Definition routerPrefixConverges : RouterPrefixConverges.
      specialize (@Claim2 PR IT AT IP SP CD LC AC); intros h.
      intros x r.
      specialize (h x r).
      apply indefinite_description.
      destruct h as [i [a h]].
      unfold StableRouter in h.
      eexists.
      refine (impliedConverges _ _ (combineConverges _
               (alwaysEConverges e (ribsFromInConverges e)) h)); clear h.
      intros s [ribsIn [hI hA]].
      destruct (ribsIn p x r) as [loc _].
      rewrite loc; clear loc.
      unfold bestImport, imports in *.
      cbn in *.
      rewrite hI.
      rewrite hA.
      reflexivity.
    Defined.
  End SinglePrefix.

  Lemma internetConverges : InternetConverges.
    unfold InternetConverges.
    specialize (routerPrefixConverges); intros h.
    unfold RouterPrefixConverges in h.
    refine ((fun h' => _) (fun p x => _)); revgoals. {
      exact (swap_ex_forall (h p x)).
    } clear h; rename h' into h.
    refine ((fun h' => _) (fun p => _)); revgoals. {
      exact (swap_ex_forall (h p)).
    } clear h; rename h' into h.
    apply swap_ex_forall in h.
    cbn in h.
    destruct h as [A h].
    exists A.
    refine (_ : @converges _ CV _).
    apply (distributeForallConverges _); intros x.
    apply (distributeForallConverges _); intros r.
    apply (distributeForallConverges _); intros p.
    apply h.
  Qed.
End GaoRexford.


From fae_gtlc_mu.refinements.static_gradual Require Export compat_cast.defs.
From fae_gtlc_mu.cast_calculus Require Export lang.

Section compat_cast_identity.
  Context `{!implG Σ,!specG Σ}.
  Local Hint Resolve to_of_val : core.

  (** The case `atomic_Base` in our proof by induction on the alternative consistency relation. *)
  Lemma back_cast_ar_base_base:
    ∀ A : list (type * type), back_cast_ar (atomic_Base A).
  Proof.
    intros A.
    rewrite /back_cast_ar. iIntros (ei' K' v v' fs) "(#Hfs & #Hvv' & #Hei' & Hv')".
    rewrite interp_rw_TUnit.
    iDestruct "Hvv'" as "%"; inversion H. simpl in *. rewrite H0 H1. clear v v' H H0 H1.
    asimpl. wp_head.
    iMod (step_pure _ ei' K'
                    (Cast Unit TUnit TUnit)
                    Unit with "[Hv']") as "Hv'". intros. eapply IdBase. by simpl. auto.
    iSplitR. done. done. asimpl. wp_value. iExists UnitV. iSplitL. done. rewrite interp_rw_TUnit. done.
  Qed.

  (** The case `atomic_Unknown` in our proof by induction on the alternative consistency relation. *)
  Lemma back_cast_ar_star_star:
    ∀ A : list (type * type), back_cast_ar (atomic_Unknown A).
  Proof.
    intros A.
    rewrite /back_cast_ar. iIntros (ei' K' v v' fs) "(#Hfs & #Hvv' & #Hei' & Hv')".
    asimpl. wp_head.
    iMod (step_pure _ ei' K'
                    (Cast v' ⋆ ⋆)
                    v' with "[Hv']") as "Hv'". intros. eapply IdStar. by simpl. auto.
    iSplitR. done. done. asimpl. wp_value. iExists v'. iSplitL. done. done.
  Qed.

End compat_cast_identity.


(** * LogRel.Fundamental: declarative typing implies the logical relation for any generic instance. *)
From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening
  DeclarativeTyping DeclarativeInstance GenericTyping LogicalRelation Validity.
From LogRel.LogicalRelation Require Import Escape Irrelevance Reflexivity Transitivity Universe Weakening Neutral Induction NormalRed.
From LogRel.Substitution Require Import Irrelevance Properties Conversion Reflexivity SingleSubst Escape.
From LogRel.Substitution.Introductions Require Import Application Universe Pi Lambda Var Nat Empty SimpleArr.

Set Primitive Projections.
Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.
Set Printing Primitive Projection Parameters.

(** ** Definitions *)

(** These records bundle together all the validity data: they do not only say that the
relevant relation holds, but also that all its boundaries hold as well. For instance,
FundTm tells that not only the term is valid at a given type, but also that this type is
itself valid, and that the context is as well. This is needed because the definition of
later validity relations depends on earlier ones, and makes using the fundamental lemma
easier, because we can simply invoke it to get all the validity properties we need. *)

Definition FundCon `{GenericTypingProperties}
  (Γ : context) : Type := [||-v Γ ].

Module FundTy.
  Record FundTy `{GenericTypingProperties} {Γ : context} {A : term}
  : Type := {
    VΓ : [||-v Γ ];
    VA : [ Γ ||-v< one > A | VΓ ]
  }.

  Arguments FundTy {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}.
End FundTy.

Export FundTy(FundTy,Build_FundTy).

Module FundTyEq.
  Record FundTyEq `{GenericTypingProperties}
    {Γ : context} {A B : term}
  : Type := {
    VΓ : [||-v Γ ];
    VA : [ Γ ||-v< one > A | VΓ ];
    VB : [ Γ ||-v< one > B | VΓ ];
    VAB : [ Γ ||-v< one > A ≅ B | VΓ | VA ]
  }.
  Arguments FundTyEq {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}.
End FundTyEq.

Export FundTyEq(FundTyEq,Build_FundTyEq).

Module FundTm.
  Record FundTm `{GenericTypingProperties}
    {Γ : context} {A t : term}
  : Type := {
    VΓ : [||-v Γ ];
    VA : [ Γ ||-v< one > A | VΓ ];
    Vt : [ Γ ||-v< one > t : A | VΓ | VA ];
  }.
  Arguments FundTm {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}.
End FundTm.

Export FundTm(FundTm,Build_FundTm).

Module FundTmEq.
  Record FundTmEq `{GenericTypingProperties}
    {Γ : context} {A t u : term}
  : Type := {
    VΓ : [||-v Γ ];
    VA : [ Γ ||-v< one > A | VΓ ];
    Vt : [ Γ ||-v< one > t : A | VΓ | VA ];
    Vu : [ Γ ||-v< one > u : A | VΓ | VA ];
    Vtu : [ Γ ||-v< one > t ≅ u : A | VΓ | VA ];
  }.
  Arguments FundTmEq {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}.
End FundTmEq.

Export FundTmEq(FundTmEq,Build_FundTmEq).

Module FundSubst.
  Record FundSubst `{GenericTypingProperties}
    {Γ Δ : context} {wfΓ : [|- Γ]} {σ : nat -> term}
  : Type := {
    VΔ : [||-v Δ ] ;
    Vσ : [VΔ | Γ ||-v σ : Δ | wfΓ] ;
  }.
  Arguments FundSubst {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}.
End FundSubst.

Export FundSubst(FundSubst,Build_FundSubst).

Module FundSubstConv.
  Record FundSubstConv `{GenericTypingProperties}
    {Γ Δ : context} {wfΓ : [|- Γ]} {σ σ' : nat -> term}
  : Type := {
    VΔ : [||-v Δ ] ;
    Vσ : [VΔ | Γ ||-v σ : Δ | wfΓ] ;
    Vσ' : [VΔ | Γ ||-v σ' : Δ | wfΓ ] ;
    Veq : [VΔ | Γ ||-v σ ≅ σ' : Δ | wfΓ | Vσ] ;
  }.
  Arguments FundSubstConv {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _}.
End FundSubstConv.

Export FundSubstConv(FundSubstConv,Build_FundSubstConv).

(** ** The main proof *)

(** Each cases of the fundamental lemma is proven separately, and the final proof simply
brings them all together. *)

Section Fundamental.
  (** We need to have in scope both the declarative instance and a generic one, which we use
  for the logical relation. *)
  Context `{GenericTypingProperties}.
  Import DeclarativeTypingData.

  Lemma FundConNil : FundCon ε.
  Proof.
  unshelve econstructor.
  + unshelve econstructor.
    - intros; exact unit.
    - intros; exact unit.
  + constructor.
  Qed.

  Lemma FundConCons (Γ : context) (A : term)
  (wfΓ : [ |-[ de ] Γ]) (fΓ : FundCon Γ) (tA : [Γ |-[ de ] A]) (fA : FundTy Γ A) : FundCon (Γ,, A).
  Proof.
    destruct fA as [ VΓ VA ].
    eapply validSnoc. exact VA.
  Qed.

  Lemma FundTyU (Γ : context) (tΓ : [ |-[ de ] Γ]) (fΓ : FundCon Γ) : FundTy Γ U.
  Proof.
    unshelve econstructor.
    - assumption.
    - unshelve econstructor.
      + intros * _. apply LRU_.
        econstructor; tea; [constructor|].
        cbn; eapply redtywf_refl; gen_typing.
      + intros * _ _. simpl. constructor.
        cbn; eapply redtywf_refl; gen_typing.
  Qed.

  Lemma FundTyPi (Γ : context) (F G : term)
    (tF : [Γ |-[ de ] F]) (fF : FundTy Γ F)
    (tG : [Γ,, F |-[ de ] G]) (fG : FundTy (Γ,, F) G)
    : FundTy Γ (tProd F G).
  Proof.
    destruct fF as [ VΓ VF ]. destruct fG as [ VΓF VG ].
    econstructor.
    unshelve eapply (PiValid VΓ).
    - assumption.
    - now eapply irrelevanceValidity.
  Qed.

  Lemma FundTyUniv (Γ : context) (A : term)
    (tA : [Γ |-[ de ] A : U]) (fA : FundTm Γ U A)
    : FundTy Γ A.
  Proof.
    destruct fA as [ VΓ VU [ RA RAext ] ]. econstructor.
    unshelve econstructor.
    - intros * vσ.
      eapply UnivEq. exact (RA _ _ wfΔ vσ).
    - intros * vσ' vσσ'.
      eapply UnivEqEq. exact (RAext _ _ _ wfΔ vσ vσ' vσσ').
  Qed.

  Lemma FundTmVar : forall (Γ : context) (n : nat) decl,
    [ |-[ de ] Γ] -> FundCon Γ ->
    in_ctx Γ n decl -> FundTm Γ decl (tRel n).
  Proof.
    intros Γ n d wfΓ FΓ hin; induction hin;
      destruct (invValiditySnoc FΓ) as [l [VΓ [VA _]]]; clear FΓ.
    - renToWk; rewrite <- (wk1_ren_on Γ d d).
      eexists _ _; unshelve eapply var0Valid; tea.
      now eapply embValidTyOne.
    - renToWk; rewrite <- (wk1_ren_on Γ d' d).
      destruct (IHhin (boundary_ctx_ctx wfΓ) VΓ); cbn in *.
      econstructor. set (ρ := wk1 _).
      replace (tRel _) with (tRel n)⟨ρ⟩ by (unfold ρ; now bsimpl).
      unshelve eapply wk1ValidTm; cycle 1; tea; now eapply irrelevanceValidity.
  Qed.

  Lemma FundTmProd : forall (Γ : context) (A B : term),
    [Γ |-[ de ] A : U] -> FundTm Γ U A ->
    [Γ,, A |-[ de ] B : U] ->
    FundTm (Γ,, A) U B -> FundTm Γ U (tProd A B).
  Proof.
    intros * ? [] ? []; econstructor.
    eapply PiValidU; irrValid.
    Unshelve.
    3: eapply UValid.
    2: eapply univValid.
    all:tea.
  Qed.

  Lemma FundTmLambda : forall (Γ : context) (A B t : term),
    [Γ |-[ de ] A] ->
    FundTy Γ A ->
    [Γ,, A |-[ de ] t : B] ->
    FundTm (Γ,, A) B t -> FundTm Γ (tProd A B) (tLambda A t).
  Proof.
    intros * ?[]?[]; econstructor.
    eapply lamValid; irrValid.
    Unshelve. all: irrValid.
  Qed.

  Lemma FundTmApp : forall (Γ : context) (f a A B : term),
    [Γ |-[ de ] f : tProd A B] ->
    FundTm Γ (tProd A B) f ->
    [Γ |-[ de ] a : A] -> FundTm Γ A a -> FundTm Γ B[a..] (tApp f a).
  Proof.
    intros * ?[]?[]; econstructor.
    now eapply appValid.
    Unshelve. all: irrValid.
  Qed.

  Lemma FundTmConv : forall (Γ : context) (t A B : term),
    [Γ |-[ de ] t : A] -> FundTm Γ A t ->
    [Γ |-[ de ] A ≅ B] -> FundTyEq Γ A B -> FundTm Γ B t.
  Proof.
    intros * ?[]?[]; econstructor.
    eapply conv; irrValid.
    Unshelve. all: tea.
  Qed.

  Lemma FundTyEqPiCong : forall (Γ : context) (A B C D : term),
    [Γ |-[ de ] A ] ->
    FundTy Γ A ->
    [Γ |-[ de ] A ≅ B] ->
    FundTyEq Γ A B ->
    [Γ,, A |-[ de ] C ≅ D] ->
    FundTyEq (Γ,, A) C D -> FundTyEq Γ (tProd A C) (tProd B D).
  Proof.
    intros * ?[]?[]?[]; econstructor.
    - eapply PiValid. eapply irrelevanceLift; tea; irrValid.
    - eapply PiCong. 1: eapply irrelevanceLift; tea.
      all: irrValid.
    Unshelve. all: tea; irrValid.
  Qed.

  Lemma FundTyEqRefl : forall (Γ : context) (A : term),
    [Γ |-[ de ] A] -> FundTy Γ A -> FundTyEq Γ A A.
  Proof.
    intros * ?[]; unshelve econstructor; tea; now eapply reflValidTy.
  Qed.

  Lemma FundTyEqSym : forall (Γ : context) (A B : term),
    [Γ |-[ de ] A ≅ B] -> FundTyEq Γ A B -> FundTyEq Γ B A.
  Proof.
    intros * ? [];  unshelve econstructor; tea.
    now eapply symValidEq.
  Qed.

  Lemma FundTyEqTrans : forall (Γ : context) (A B C : term),
    [Γ |-[ de ] A ≅ B] -> FundTyEq Γ A B ->
    [Γ |-[ de ] B ≅ C] -> FundTyEq Γ B C ->
    FundTyEq Γ A C.
  Proof.
    intros * ?[]?[]; unshelve econstructor; tea. 1:irrValid.
    eapply transValidEq; irrValid.
    Unshelve. tea.
  Qed.

  Lemma FundTyEqUniv : forall (Γ : context) (A B : term),
    [Γ |-[ de ] A ≅ B : U] -> FundTmEq Γ U A B -> FundTyEq Γ A B.
  Proof.
    intros * ?[]; unshelve econstructor; tea.
    1,2: now eapply univValid.
    now eapply univEqValid.
  Qed.

  Lemma FundTmEqBRed : forall (Γ : context) (a t A B : term),
    [Γ |-[ de ] A] ->
    FundTy Γ A ->
    [Γ,, A |-[ de ] t : B] ->
    FundTm (Γ,, A) B t ->
    [Γ |-[ de ] a : A] ->
    FundTm Γ A a -> FundTmEq Γ B[a..] (tApp (tLambda A t) a) t[a..].
  Proof.
    intros * ?[]?[]?[]; econstructor.
    - eapply appValid. eapply lamValid. irrValid.
    - unshelve epose (substSTm _ _).
      8-12: irrValid.
      tea.
    - unshelve epose (betaValid VA _ _ _). 2,5-7:irrValid.
      Unshelve. all: tea; try irrValid.
  Qed.

  Lemma FundTmEqPiCong : forall (Γ : context) (A B C D : term),
    [Γ |-[ de ] A : U] -> FundTm Γ U A ->
    [Γ |-[ de ] A ≅ B : U] -> FundTmEq Γ U A B ->
    [Γ,, A |-[ de ] C ≅ D : U] -> FundTmEq (Γ,, A) U C D ->
    FundTmEq Γ U (tProd A C) (tProd B D).
  Proof.
    intros * ?[]?[]?[].
    assert (VA' : [Γ ||-v<one> A | VΓ]) by now eapply univValid.
    assert [Γ ||-v<one> A ≅ B | VΓ | VA'] by (eapply univEqValid; irrValid).
    opector; tea.
    - edestruct FundTmProd. 5: irrValid.
      1,3: eapply ty_sound; now eapply escapeTm.
      all: unshelve econstructor; irrValid.
    - edestruct FundTmProd. 5: irrValid.
      1,3: eapply ty_sound; eapply escapeTm; tea.
      1: eapply irrelevanceTmLift; tea; irrValid.
      1: unshelve econstructor; irrValid.
      opector.
      + eapply validSnoc; now eapply univValid.
      + eapply irrelevanceLift; irrValid.
      + eapply irrelevanceTmLift; irrValid.
    - unshelve epose (PiCongTm _ _ _ _ _ _ _ _ _ _ _).
      16: irrValid.
      2: tea.
      2,3,8: irrValid.
      all: try irrValid.
      + now eapply univValid.
      + eapply irrelevanceLift; irrValid.
      + eapply irrelevanceTmLift; irrValid.
      Unshelve.
      all: try irrValid.
      1: unshelve eapply irrelevanceLift; cycle 3; try irrValid.
      unshelve eapply univValid; cycle 1; try irrValid.
  Qed.

  Lemma FundTmEqAppCong : forall (Γ : context) (a b f g A B : term),
    [Γ |-[ de ] f ≅ g : tProd A B] -> FundTmEq Γ (tProd A B) f g ->
    [Γ |-[ de ] a ≅ b : A] -> FundTmEq Γ A a b ->
    FundTmEq Γ B[a..] (tApp f a) (tApp g b).
  Proof.
    intros * ?[]?[]; econstructor.
    - eapply appValid; irrValid.
    - eapply conv. 2: eapply appValid; irrValid.
      eapply substSΠeq; try irrValid.
      1: eapply reflValidTy.
      now eapply symValidTmEq.
    - eapply appcongValid; irrValid.
    Unshelve. all: irrValid.
  Qed.

  Lemma FundTmEqFunExt : forall (Γ : context) (f g A B : term),
    [Γ |-[ de ] A] -> FundTy Γ A ->
    [Γ |-[ de ] f : tProd A B] -> FundTm Γ (tProd A B) f ->
    [Γ |-[ de ] g : tProd A B] -> FundTm Γ (tProd A B) g ->
    [Γ,, A |-[ de ] tApp (f⟨↑⟩) (tRel 0) ≅ tApp (g⟨↑⟩) (tRel 0) : B] -> FundTmEq (Γ,, A) B (tApp (f⟨↑⟩) (tRel 0)) (tApp (g⟨↑⟩) (tRel 0)) ->
    FundTmEq Γ (tProd A B) f g.
  Proof.
    intros * ?[]?[VΓ0 VA0]?[]?[].
    assert [Γ ||-v< one > g : tProd A B | VΓ0 | VA0].
    1:{
      eapply conv.
      2: irrValid.
      eapply symValidEq. eapply PiCong.
      eapply irrelevanceLift.
      1,3,4: eapply reflValidTy.
      irrValid.
    }
    econstructor.
    3: eapply etaeqValid.
    5: do 2 rewrite wk1_ren_on.
    Unshelve. all: irrValid.
  Qed.

  Lemma FundTmEqRefl : forall (Γ : context) (t A : term),
    [Γ |-[ de ] t : A] -> FundTm Γ A t ->
    FundTmEq Γ A t t.
  Proof.
    intros * ?[]; econstructor; tea; now eapply reflValidTm.
  Qed.

  Lemma FundTmEqSym : forall (Γ : context) (t t' A : term),
    [Γ |-[ de ] t ≅ t' : A] -> FundTmEq Γ A t t' ->
    FundTmEq Γ A t' t.
  Proof.
    intros * ?[]; econstructor; tea; now eapply symValidTmEq.
  Qed.

  Lemma FundTmEqTrans : forall (Γ : context) (t t' t'' A : term),
    [Γ |-[ de ] t ≅ t' : A] -> FundTmEq Γ A t t' ->
    [Γ |-[ de ] t' ≅ t'' : A] -> FundTmEq Γ A t' t'' ->
    FundTmEq Γ A t t''.
  Proof.
    intros * ?[]?[]; econstructor; tea.
    1: irrValid.
    eapply transValidTmEq; irrValid.
  Qed.

  Lemma FundTmEqConv : forall (Γ : context) (t t' A B : term),
    [Γ |-[ de ] t ≅ t' : A] -> FundTmEq Γ A t t' ->
    [Γ |-[ de ] A ≅ B] -> FundTyEq Γ A B ->
    FundTmEq Γ B t t'.
  Proof.
    intros * ?[]?[]; econstructor.
    1,2: eapply conv; irrValid.
    eapply convEq; irrValid.
    Unshelve. all: irrValid.
  Qed.

  Lemma FundTyNat : forall Γ : context, [ |-[ de ] Γ] -> FundCon Γ -> FundTy Γ tNat.
  Proof.
    intros ???; unshelve econstructor; tea;  eapply natValid.
  Qed.

  Lemma FundTmNat : forall Γ : context, [ |-[ de ] Γ] -> FundCon Γ -> FundTm Γ U tNat.
  Proof.
    intros ???; unshelve econstructor; tea.
    2: eapply natTermValid.
  Qed.

  Lemma FundTmZero : forall Γ : context, [ |-[ de ] Γ] -> FundCon Γ -> FundTm Γ tNat tZero.
  Proof.
    intros; unshelve econstructor; tea.
    2:eapply zeroValid.
  Qed.

  Lemma FundTmSucc : forall (Γ : context) (n : term),
    [Γ |-[ de ] n : tNat] -> FundTm Γ tNat n -> FundTm Γ tNat (tSucc n).
  Proof.
    intros * ?[]; unshelve econstructor; tea.
    eapply irrelevanceTm; eapply succValid; irrValid.
    Unshelve. tea.
  Qed.

  Lemma FundTmNatElim : forall (Γ : context) (P hz hs n : term),
    [Γ,, tNat |-[ de ] P] ->
    FundTy (Γ,, tNat) P ->
    [Γ |-[ de ] hz : P[tZero..]] ->
    FundTm Γ P[tZero..] hz ->
    [Γ |-[ de ] hs : elimSuccHypTy P] ->
    FundTm Γ (elimSuccHypTy P) hs ->
    [Γ |-[ de ] n : tNat] ->
    FundTm Γ tNat n -> FundTm Γ P[n..] (tNatElim P hz hs n).
  Proof.
    intros * ?[]?[]?[]?[]; unshelve econstructor; tea.
    2: eapply natElimValid; irrValid.
    Unshelve. all: irrValid.
  Qed.

  Lemma FundTyEmpty : forall Γ : context, [ |-[ de ] Γ] -> FundCon Γ -> FundTy Γ tEmpty.
  Proof.
    intros ???; unshelve econstructor; tea;  eapply emptyValid.
  Qed.

  Lemma FundTmEmpty : forall Γ : context, [ |-[ de ] Γ] -> FundCon Γ -> FundTm Γ U tEmpty.
  Proof.
    intros ???; unshelve econstructor; tea.
    2: eapply emptyTermValid.
  Qed.

  Lemma FundTmEmptyElim : forall (Γ : context) (P n : term),
    [Γ,, tEmpty |-[ de ] P] ->
    FundTy (Γ,, tEmpty) P ->
    [Γ |-[ de ] n : tEmpty] ->
    FundTm Γ tEmpty n -> FundTm Γ P[n..] (tEmptyElim P n).
  Proof.
    intros * ?[]?[]; unshelve econstructor; tea.
    2: eapply emptyElimValid; irrValid.
    Unshelve. 1,2: irrValid.
  Qed.

  Lemma FundTmEqSuccCong : forall (Γ : context) (n n' : term),
    [Γ |-[ de ] n ≅ n' : tNat] ->
    FundTmEq Γ tNat n n' -> FundTmEq Γ tNat (tSucc n) (tSucc n').
  Proof.
    intros * ?[]; unshelve econstructor; tea.
    1,2: eapply irrelevanceTm; eapply succValid; irrValid.
    eapply irrelevanceTmEq; eapply succcongValid; irrValid.
    Unshelve. all: tea.
  Qed.

  Lemma FundTmEqNatElimCong : forall (Γ : context)
      (P P' hz hz' hs hs' n n' : term),
    [Γ,, tNat |-[ de ] P ≅ P'] ->
    FundTyEq (Γ,, tNat) P P' ->
    [Γ |-[ de ] hz ≅ hz' : P[tZero..]] ->
    FundTmEq Γ P[tZero..] hz hz' ->
    [Γ |-[ de ] hs ≅ hs' : elimSuccHypTy P] ->
    FundTmEq Γ (elimSuccHypTy P) hs hs' ->
    [Γ |-[ de ] n ≅ n' : tNat] ->
    FundTmEq Γ tNat n n' ->
    FundTmEq Γ P[n..] (tNatElim P hz hs n) (tNatElim P' hz' hs' n').
  Proof.
    intros * ?[? VP0 VP0']?[VΓ0]?[]?[].
    pose (VN := natValid (l:=one) VΓ0).
    assert (VP' : [ _ ||-v<one> P' | validSnoc VΓ0 VN]) by irrValid.
    assert [Γ ||-v< one > hz' : P'[tZero..] | VΓ0 | substS VP' (zeroValid VΓ0)]. 1:{
      eapply conv. 2: irrValid.
      eapply substSEq. 2,3: irrValid.
      1: eapply reflValidTy.
      2: eapply reflValidTm.
      all: eapply zeroValid.
    }
    assert [Γ ||-v< one > hs' : elimSuccHypTy P' | VΓ0 | elimSuccHypTyValid VΓ0 VP']. 1:{
      eapply conv. 2: irrValid.
      eapply elimSuccHypTyCongValid; irrValid.
    }
    unshelve econstructor; tea.
    2: eapply natElimValid; irrValid.
    + eapply conv.
      2: eapply irrelevanceTm; now eapply natElimValid.
      eapply symValidEq.
      eapply substSEq; tea.
      2,3: irrValid.
      eapply reflValidTy.
    + eapply natElimCongValid; tea; try irrValid.
    Unshelve. all: try irrValid.
    1: eapply zeroValid.
    1: unshelve eapply substS; try irrValid.
  Qed.

  Lemma FundTmEqNatElimZero : forall (Γ : context) (P hz hs : term),
    [Γ,, tNat |-[ de ] P] ->
    FundTy (Γ,, tNat) P ->
    [Γ |-[ de ] hz : P[tZero..]] ->
    FundTm Γ P[tZero..] hz ->
    [Γ |-[ de ] hs : elimSuccHypTy P] ->
    FundTm Γ (elimSuccHypTy P) hs ->
    FundTmEq Γ P[tZero..] (tNatElim P hz hs tZero) hz.
  Proof.
    intros * ?[]?[]?[]; unshelve econstructor; tea.
    3: irrValid.
    3: eapply natElimZeroValid; irrValid.
    eapply natElimValid; irrValid.
    Unshelve. irrValid.
  Qed.

  Lemma FundTmEqNatElimSucc : forall (Γ : context) (P hz hs n : term),
    [Γ,, tNat |-[ de ] P] ->
    FundTy (Γ,, tNat) P ->
    [Γ |-[ de ] hz : P[tZero..]] ->
    FundTm Γ P[tZero..] hz ->
    [Γ |-[ de ] hs : elimSuccHypTy P] ->
    FundTm Γ (elimSuccHypTy P) hs ->
    [Γ |-[ de ] n : tNat] ->
    FundTm Γ tNat n ->
    FundTmEq Γ P[(tSucc n)..] (tNatElim P hz hs (tSucc n))
      (tApp (tApp hs n) (tNatElim P hz hs n)).
  Proof.
    intros * ?[]?[]?[]?[]; unshelve econstructor; tea.
    4: eapply natElimSuccValid; irrValid.
    1: eapply natElimValid; irrValid.
    eapply simple_appValid.
    2: eapply natElimValid; irrValid.
    eapply irrelevanceTm'.
    2: now eapply appValid.
    now bsimpl.
    Unshelve. all: try irrValid.
    eapply simpleArrValid; eapply substS; tea.
    1,2: irrValid.
    eapply succValid; irrValid.
  Qed.

  Lemma FundTmEqEmptyElimCong : forall (Γ : context)
      (P P' n n' : term),
    [Γ,, tEmpty |-[ de ] P ≅ P'] ->
    FundTyEq (Γ,, tEmpty) P P' ->
    [Γ |-[ de ] n ≅ n' : tEmpty] ->
    FundTmEq Γ tEmpty n n' ->
    FundTmEq Γ P[n..] (tEmptyElim P n) (tEmptyElim P' n').
  Proof.
    intros * ?[? VP0 VP0']?[VΓ0].
    pose (VN := emptyValid (l:=one) VΓ0).
    assert (VP' : [ _ ||-v<one> P' | validSnoc VΓ0 VN]) by irrValid.
    unshelve econstructor; tea.
    2: eapply emptyElimValid; irrValid.
    + eapply conv.
      2: eapply irrelevanceTm; now eapply emptyElimValid.
      eapply symValidEq.
      eapply substSEq; tea.
      2,3: irrValid.
      eapply reflValidTy.
    + eapply emptyElimCongValid; tea; try irrValid.
    Unshelve. all: try irrValid.
    1: unshelve eapply substS; try irrValid.
  Qed.

Lemma Fundamental : (forall Γ : context, [ |-[ de ] Γ ] -> FundCon (ta := ta) Γ)
    × (forall (Γ : context) (A : term), [Γ |-[ de ] A] -> FundTy (ta := ta) Γ A)
    × (forall (Γ : context) (A t : term), [Γ |-[ de ] t : A] -> FundTm (ta := ta) Γ A t)
    × (forall (Γ : context) (A B : term), [Γ |-[ de ] A ≅ B] -> FundTyEq (ta := ta) Γ A B)
    × (forall (Γ : context) (A t u : term), [Γ |-[ de ] t ≅ u : A] -> FundTmEq (ta := ta) Γ A t u).
  Proof.
  apply WfDeclInduction.
  + apply FundConNil.
  + apply FundConCons.
  + apply FundTyU.
  + apply FundTyPi.
  + apply FundTyNat.
  + apply FundTyEmpty.
  + apply FundTyUniv.
  + apply FundTmVar.
  + apply FundTmProd.
  + apply FundTmLambda.
  + apply FundTmApp.
  + apply FundTmNat.
  + apply FundTmZero.
  + apply FundTmSucc.
  + apply FundTmNatElim.
  + apply FundTmEmpty.
  + apply FundTmEmptyElim.
  + apply FundTmConv.
  + apply FundTyEqPiCong.
  + apply FundTyEqRefl.
  + apply FundTyEqUniv.
  + apply FundTyEqSym.
  + apply FundTyEqTrans.
  + apply FundTmEqBRed.
  + apply FundTmEqPiCong.
  + apply FundTmEqAppCong.
  + apply FundTmEqFunExt.
  + apply FundTmEqSuccCong.
  + apply FundTmEqNatElimCong.
  + apply FundTmEqNatElimZero.
  + apply FundTmEqNatElimSucc.
  + apply FundTmEqEmptyElimCong.
  + apply FundTmEqRefl.
  + apply FundTmEqConv.
  + apply FundTmEqSym.
  + apply FundTmEqTrans.
  Qed.

(** ** Well-typed substitutions are also valid *)

  Corollary Fundamental_subst Γ Δ σ (wfΓ : [|-[ta] Γ ]) :
    [|-[de] Δ] ->
    [Γ |-[de]s σ : Δ] ->
    FundSubst Γ Δ wfΓ σ.
  Proof.
    intros HΔ.
    induction 1 as [|σ Δ A Hσ IH Hσ0].
    - exists validEmpty.
      now constructor.
    - inversion HΔ as [|?? HΔ' HA] ; subst ; clear HΔ ; refold.
      destruct IH ; tea.
      apply Fundamental in Hσ0 as [?? Hσ0].
      cbn in *.
      eapply reducibleTm in Hσ0.
      eapply Fundamental in HA as [].
      unshelve econstructor.
      1: now eapply validSnoc.
      unshelve econstructor.
      + now eapply irrelevanceSubst.
      + cbn; irrelevance0.
        2: eassumption.
        reflexivity.
  Qed.

  Corollary Fundamental_subst_conv Γ Δ σ σ' (wfΓ : [|-[ta] Γ ]) :
    [|-[de] Δ] ->
    [Γ |-[de]s σ ≅ σ' : Δ] ->
    FundSubstConv Γ Δ wfΓ σ σ'.
  Proof.
    intros HΔ.
    induction 1 as [|σ τ Δ A Hσ IH Hσ0].
    - unshelve econstructor.
      1: eapply validEmpty.
      all: now econstructor.
    - inversion HΔ as [|?? HΔ' HA] ; subst ; clear HΔ ; refold.
      destruct IH ; tea.
      apply Fundamental in Hσ0 as [?? Hσ0 Hτ0 Ηστ] ; cbn in *.
      eapply Fundamental in HA as [? HA].
      unshelve econstructor.
      + now eapply validSnoc.
      + unshelve econstructor.
        1: now irrValid.
        cbn.
        irrelevanceRefl.
        now eapply reducibleTm.
      + unshelve econstructor.
        1: now eapply irrelevanceSubst.
        cbn.
        unshelve irrelevanceRefl.
        2: now unshelve eapply HA ; tea ; irrValid.
        cbn.
        unshelve eapply LRTmRedConv.
        3: now eapply reducibleTy.
        * irrelevanceRefl.
          unshelve eapply HA ; tea.
          all: now irrValid.
        * irrelevanceRefl.
          now eapply reducibleTm.
      + unshelve econstructor ; cbn in *.
        * now irrValid.
        * irrelevanceRefl.
          now eapply reducibleTmEq.
  Qed.

End Fundamental.


From Undecidability Require Import Synthetic.DecidabilityFacts Synthetic.SemiDecidabilityFacts Synthetic.EnumerabilityFacts Synthetic.ListEnumerabilityFacts reductions partial embed_nat ReducibilityFacts truthtables.
Require Import Setoid Program Lia List.

Axiom φ : nat -> nat -> option nat.

Axiom EAB : forall p, enumerable p <-> exists c, enumerator (φ c) p.

Definition W c x := exists n, φ c n = Some x.

Lemma W_spec : forall p, enumerable p <-> exists c, forall x, p x <-> W c x.
Proof.
  eapply EAB.
Qed.

Lemma do_EA p : enumerable p -> exists c, forall x, p x <-> W c x.
Proof.
  eapply W_spec.
Qed.

Axiom s : nat -> nat -> nat.

Axiom SMN : forall c x y, W (s c x) y <-> W c ⟨x,y⟩.

Definition EAs := exists φ, forall p : nat -> nat -> Prop, enumerable (fun! ⟨x,y⟩ => p x y) ->
                                        exists c : nat -> nat, forall x, enumerator (φ (c x)) (p x).

Lemma EAS' :
  forall p : nat -> nat -> Prop, enumerable (fun! ⟨x,y⟩ => p x y) ->
                                        exists c : nat -> nat, forall x y, W (c x) y <-> p x y.
Proof.
  intros p Hp.
  destruct (do_EA _ Hp) as [c Hc].
  exists (fun x => s c x). intros x y.
  now rewrite SMN, <- Hc, embedP.
Qed.

Lemma EAS :
  forall p : nat -> nat -> Prop, enumerable (uncurry p) ->
                                        exists c : nat -> nat, forall x y, W (c x) y <-> p x y.
Proof.
  intros p Hp. eapply EAS'.
  eapply enumerable_red. 4: exact Hp.
  exists (fun! ⟨x,y⟩ => (x,y)).
  - intros xy. now destruct (unembed xy) as [x y].
  - eauto.
  - now eapply discrete_prod; eapply discrete_nat.
Qed.

Lemma EAS_datatype X (p : X -> nat -> Prop) (x0 : X) :
  datatype X ->
  enumerable (uncurry p) ->
  exists c : X -> nat, forall x y, W (c x) y <-> p x y.
Proof.
  intros (I & R & HIR) Ep.
  destruct (EAS (fun x y => if R x is Some l then p l y else p x0 y)) as [c Hc].
  - eapply enumerable_red.
    4: eapply Ep.
    + exists (fun '(x, y) => if R x is Some l then (l,y) else (x0, y)).
      intros [x y]. cbn.
      destruct (R x); reflexivity.
    + eauto.
    + eapply discrete_prod. eapply datatype_discrete. now exists I, R.
      eapply discrete_nat.
  - exists (fun l => c (I l)). intros. now rewrite Hc, HIR.
Qed.

Lemma EAS_list (p : list nat -> nat -> Prop) : enumerable (uncurry p) ->
                                      exists c : list nat -> nat, forall x y, W (c x) y <-> p x y.
Proof.
  intros. eapply EAS_datatype; eauto.
  - exact nil.
  - eapply enumerable_discrete_datatype.
    eapply discrete_list, discrete_nat.
    eauto.
Qed.

Lemma List_id : exists c_l, forall (l : list nat), forall x, W (c_l l) x <-> List.In x l.
Proof.
  eapply EAS_list.
  eapply decidable_enumerable. 2:eauto.
  eapply decidable_iff. econstructor.
  intros [x y]. cbn. exact _.
Qed.

Notation π1 := (fun! ⟨x, y⟩ => x).
Notation π2 := (fun! ⟨x, y⟩ => y).

Lemma enumerable_W : enumerable (fun '(x, y) => W x y).
Proof.
  exists (fun p => let (n,m) := unembed p in if φ n m is Some m then Some (n, m) else None).
  intros [n m].
  split.
  - intros H.
    cbv in H. destruct H as [n' H].
    exists (embed (n, n')). rewrite embedP. cbn. now rewrite H.
  - unfold W.
    intros [p H].
    destruct (unembed p) as [n' m'].
    exists m'.
    destruct (φ n' m') eqn:E; inversion H; now subst.
Qed.

Lemma W_maximal (p : nat -> Prop) :
  enumerable p -> p ⪯ₘ uncurry W.
Proof.
  intros Hp.
  destruct (do_EA p Hp) as [c Hc].
  exists (fun x => (c, x)). exact Hc.
Qed.

Lemma SMN' : forall f, exists k, forall c x, W (k c) x <-> W c (f x).
Proof.
  intros f.
  eapply EAS.
  eapply enumerable_red with (q := uncurry W).
  - exists (fun '(x,y) => (x, f y)). now intros [x y].
  - eauto.
  - eapply discrete_prod; now eapply discrete_nat.
  - eapply enumerable_W.
Qed.

Lemma TT :
  forall f : nat -> { Q : list nat & truthtable},
    exists c : list nat -> nat, forall l x, W (c l) x <-> eval_tt (projT2 (f x)) (List.map (fun x => negb (inb (uncurry Nat.eqb) x l)) (projT1 (f x))) = false.
Proof.
  intros f.
  eapply EAS_list.
  eapply decidable_enumerable. 2:eauto.
  eapply decidable_iff. econstructor.
  intros [x y]. cbn. exact _.
Qed.

Tactic Notation "intros" "⟨" ident(n) "," ident(m) "⟩" :=
  let nm := fresh "nm" in
  let E := fresh "E" in
  intros nm; destruct (unembed nm) as [n m] eqn:E.

Lemma EAS_datatype_direct X (p : X -> nat -> Prop) (x0 : X) :
  datatype X ->
  enumerable (uncurry p) ->
  exists c : X -> nat, forall x y, W (c x) y <-> p x y.
Proof.
  intros (I & R & (R' & HIR) % (retraction_to_tight _ _ _) ) Hp.
  assert (enumerable (fun! ⟨n,m⟩ => if R' n is Some x then p x m else False)). {
    destruct Hp as [e He].
    exists (fun n => if e n is Some (x, m) then Some ⟨I x, m⟩ else None).
    intros ⟨n,m⟩.
    split.
    - destruct (R' n) eqn:ER; [ intros [n' H] % (He (_,_)) | intros []].
      exists n'. rewrite H. f_equal.
      rewrite <- embedP. rewrite unembedP.
      rewrite <- (@unembedP nm), E. repeat f_equal. now eapply HIR.
    - intros [n' H]. destruct (e n') as [ [x m'] | ] eqn:E2; try congruence.
      inv H. rewrite embedP in E. inv E. destruct (HIR x) as [-> _].
      eapply (He (_,_)). eauto.
  }

  destruct (do_EA _ H) as [c Hc].
  exists (fun x => s c (I x)).
  intros x y.
  rewrite SMN, <- Hc, embedP.
  now destruct (HIR x) as [-> _].
Qed.

Definition K0 c := W c c.

Lemma K0_not_enumerable : ~ enumerable (compl K0).
Proof.
  intros [c Hc] % do_EA. specialize (Hc c).
  unfold K0, compl in Hc. tauto.
Qed.

Lemma W_uncurry_red:
  (fun! ⟨ n, m ⟩ => W n m) ⪯ₘ uncurry W.
Proof.
  exists (fun! ⟨n,m⟩ => (n,m)). intros nm. destruct (unembed nm) as [n m]. reflexivity.
Qed.

Lemma K0_red:
  K0 ⪯ₘ uncurry W.
Proof.
  exists (fun n => (n,n)). intros n. reflexivity.
Qed.

Lemma W_uncurry_red':
  uncurry W ⪯ₘ (fun! ⟨ n, m ⟩ => W n m).
Proof.
  exists (fun '(n,m) => ⟨n,m⟩). intros [n m]. now rewrite embedP.
Qed.

Hint Resolve discrete_prod discrete_nat : core.

Lemma W_not_enumerable : ~ enumerable (compl (uncurry W)).
Proof.
  eapply not_coenumerable; eauto.
  - eapply K0_red.
  - eapply K0_not_enumerable.
Qed.

Lemma K0_enum : enumerable K0.
Proof.
  eapply enumerable_red with (q := uncurry W).
  eapply K0_red. all:eauto.
  eapply enumerable_W.
Qed.

Lemma red_tt_not_red_m :
  compl K0 ⪯ₜₜ K0 /\ ~ compl K0 ⪯ₘ K0.
Proof.
  split.
  - eapply red_tt_complement.
  - intros H % enumerable_red.
    + now eapply K0_not_enumerable.
    + eauto.
    + eapply discrete_nat.
    + eapply K0_enum.
Qed.

Notation "m-complete p" := (forall q : nat -> Prop, enumerable q -> q ⪯ₘ p) (at level 10).

Lemma m_complete_W :
  m-complete (fun! ⟨n,m⟩ =>  W n m).
Proof.
  intros q [c Hc] % do_EA.
  exists (fun x => ⟨c,x⟩). intros x.
  now rewrite embedP.
Qed.

Lemma enum_iff (p : nat -> Prop) : enumerable p <-> semi_decidable p.
Proof.
  split.
  - intros H. eapply enumerable_semi_decidable. eapply discrete_nat. eassumption.
  - intros H. eapply semi_decidable_enumerable. eauto. eauto.
Qed.

Lemma generative_W :   generative (fun! ⟨ n, m ⟩ => W n m).
Proof.
  eapply unbounded_generative. intros x y; destruct (PeanoNat.Nat.eq_dec x y); eauto.
  destruct (do_EA (fun _ => True)) as [c_top H_top]. {
    eapply decidable_enumerable. 2:eauto. exists (fun _ => true). firstorder.
  }
  intros n. exists (map (fun m => ⟨c_top,m⟩) (seq 0 n)). split.
  now rewrite map_length, seq_length. split.
  eapply NoDup_map. intros ? ? E % (f_equal unembed). rewrite !embedP in E. congruence. eapply seq_NoDup.
  intros ? (? & <- & ?) % in_map_iff. rewrite embedP. firstorder.
Qed.