(* Sequent calculus with upper bounds on proof size.
   Useful for doing induction on.

   The main purpose this file is to provide the inversion lemmas (see the bottom part of the file).
 *)
From Coq Require Import ssreflect.
From stdpp Require Import prelude.
From bunched.algebra Require Import bi.
From bunched Require Import seqcalc bunch_decomp prelude.lists.

Reserved Notation "P ⊢ᴮ{ n } Q" (at level 99, n, Q at level 200, right associativity).
Reserved Notation "Δ =?{ n } Δ'" (at level 99, n at level 200).

Module SeqcalcHeight(R : ANALYTIC_STRUCT_EXT).
  Import R.
  Module S := Seqcalc(R).
  Import S.

  Implicit Type Δ : bunch.
  Implicit Type ψ ϕ : formula.

  (** ** Alternative formulation of bunch equivalences *)
  Inductive bunch_equiv : bunch → bunch → Prop :=
  | BE_cong C Δ1 Δ2 :
      Δ1 =? Δ2 →
      fill C Δ1 =? fill C Δ2
  | BE_comma_unit_l Δ :
      (empty ,, Δ)%B =? Δ
  | BE_comma_comm Δ1 Δ2 :
      (Δ1 ,, Δ2)%B =? (Δ2 ,, Δ1)%B
  | BE_comma_assoc Δ1 Δ2 Δ3 : (Δ1 ,, (Δ2 ,, Δ3))%B =? ((Δ1 ,, Δ2) ,, Δ3)%B
  | BE_semic_unit_l Δ : (top ;, Δ)%B =? Δ
  | BE_semic_comm Δ1 Δ2  : (Δ1 ;, Δ2)%B =? (Δ2 ;, Δ1)%B
  | BE_semic_assoc Δ1 Δ2 Δ3  : (Δ1 ;, (Δ2 ;, Δ3))%B =? ((Δ1 ;, Δ2) ;, Δ3)%B
  where "Δ =? Γ" := (bunch_equiv Δ%B Γ%B).

  Definition bunch_equiv_h := rtsc (bunch_equiv).

  Lemma bunch_equiv_1 Δ Δ' :
    (Δ =? Δ') → (Δ ≡ Δ').
  Proof. induction 1; by econstructor; eauto. Qed.

  Lemma bunch_equiv_2 Δ Δ' :
    (Δ ≡ Δ') → (bunch_equiv_h Δ Δ').
  Proof.
    induction 1.
    all: try by (eapply rtsc_lr; econstructor).
    - unfold bunch_equiv_h. reflexivity.
    - by symmetry.
    - etrans; eauto.
    - eapply rtc_congruence; eauto.
      intros X Y. apply sc_congruence. clear X Y.
      intros X Y ?. by econstructor.
  Qed.

  Local Lemma bunch_equiv_fill_1 Δ C ϕ :
    fill C (frml ϕ) =? Δ →
    ∃ C', Δ = fill C' (frml ϕ) ∧ (∀ Δ, fill C' Δ ≡ fill C Δ).
  Proof.
    intros Heq.
    remember (fill C (frml ϕ)) as Y.
    revert C HeqY.
    induction Heq=>C' heqY; symmetry in heqY.
    + apply bunch_decomp_complete in heqY.
      apply bunch_decomp_ctx in heqY.
      destruct heqY as [H1 | H2].
      * destruct H1 as [C1 [HC0%bunch_decomp_correct HC]].
        destruct (IHHeq C1 HC0) as [C2 [HΔ1 HC2]].
        simplify_eq/=.
        exists (C2 ++ C). rewrite fill_app. split; first done.
        intros Δ. rewrite !fill_app HC2 //.
      * destruct H2 as (C1 & C2 & HC1 & HC2 & Hdec0).
        specialize (Hdec0 Δ2). apply bunch_decomp_correct in Hdec0.
        exists (C1 Δ2). split ; eauto.
        intros Δ. rewrite HC1.
        assert (Δ1 ≡ Δ2) as <-.
        { by apply bunch_equiv_1. }
        by rewrite HC2.
    + apply bunch_decomp_complete in heqY.
      inversion heqY; simplify_eq/=.
      { inversion H3. }
      apply bunch_decomp_correct in H3.
      exists Π. split; eauto.
      intros X. rewrite fill_app /= left_id //.
    + apply bunch_decomp_complete in heqY.
      inversion heqY; simplify_eq/=.
      * exists (Π ++ [CtxCommaR Δ2]). split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
          by rewrite H3. }
        intros Δ. rewrite !fill_app/=.
        by rewrite comm.
      * exists (Π ++ [CtxCommaL Δ1]). split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
          by rewrite H3. }
        intros Δ. rewrite !fill_app/=.
        by rewrite comm.
    + apply bunch_decomp_complete in heqY.
      inversion heqY; simplify_eq/=.
      * exists (Π ++ [CtxCommaL Δ2;CtxCommaL Δ3])%B. split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
          by rewrite H3. }
        intros Δ. rewrite !fill_app/=.
        by rewrite assoc.
      * inversion H3; simplify_eq/=.
        ** exists (Π0 ++ [CtxCommaR Δ1;CtxCommaL Δ3])%B. split.
           { rewrite fill_app/=.
             apply bunch_decomp_correct in H4.
               by rewrite H4. }
           intros Δ. rewrite !fill_app/=.
           by rewrite assoc.
        ** exists (Π0 ++ [CtxCommaR (Δ1,,Δ2)])%B. split.
           { simpl. rewrite fill_app/=.
             apply bunch_decomp_correct in H4.
             by rewrite H4. }
           intros Δ. rewrite !fill_app/=.
           by rewrite assoc.
    + apply bunch_decomp_complete in heqY.
      inversion heqY; simplify_eq/=.
      { inversion H3. }
      apply bunch_decomp_correct in H3.
      exists Π. split; eauto.
      intros X. rewrite fill_app /= left_id //.
    + apply bunch_decomp_complete in heqY.
      inversion heqY; simplify_eq/=.
      * exists (Π ++ [CtxSemicR Δ2]). split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
          by rewrite H3. }
        intros Δ. rewrite !fill_app/=.
        by rewrite comm.
      * exists (Π ++ [CtxSemicL Δ1]). split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
          by rewrite H3. }
        intros Δ. rewrite !fill_app/=.
        by rewrite comm.
    + apply bunch_decomp_complete in heqY.
      inversion heqY; simplify_eq/=.
      * exists (Π ++ [CtxSemicL Δ2;CtxSemicL Δ3])%B. split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
          by rewrite H3. }
        intros Δ. rewrite !fill_app/=.
        by rewrite assoc.
      * inversion H3; simplify_eq/=.
        ** exists (Π0 ++ [CtxSemicR Δ1;CtxSemicL Δ3])%B. split.
           { rewrite fill_app/=.
             apply bunch_decomp_correct in H4.
               by rewrite H4. }
           intros Δ. rewrite !fill_app/=.
           by rewrite assoc.
        ** exists (Π0 ++ [CtxSemicR (Δ1;,Δ2)])%B. split.
           { simpl. rewrite fill_app/=.
             apply bunch_decomp_correct in H4.
             by rewrite H4. }
           intros Δ. rewrite !fill_app/=.
           by rewrite assoc.
  Qed.

  Local Lemma bunch_equiv_fill_2 Δ C ϕ :
    Δ =? fill C (frml ϕ) →
    ∃ C', Δ = fill C' (frml ϕ) ∧ (∀ Δ, fill C' Δ ≡ fill C Δ).
  Proof.
    intros Heq.
    remember (fill C (frml ϕ)) as Y.
    revert C HeqY.
    induction Heq=>C' heqY; symmetry in heqY.
    + apply bunch_decomp_complete in heqY.
      apply bunch_decomp_ctx in heqY.
      destruct heqY as [H1 | H2].
      * destruct H1 as [C1 [HC0%bunch_decomp_correct HC]].
        destruct (IHHeq C1 HC0) as [C2 [HΔ1 HC2]].
        simplify_eq/=.
        exists (C2 ++ C). rewrite fill_app. split; first done.
        intros Δ. rewrite !fill_app HC2 //.
      * destruct H2 as (C1 & C2 & HC1 & HC2 & Hdec0).
        specialize (Hdec0 Δ1). apply bunch_decomp_correct in Hdec0.
        exists (C1 Δ1). split ; eauto.
        intros Δ. rewrite HC1.
        assert (Δ1 ≡ Δ2) as ->.
        { by apply bunch_equiv_1. }
        by rewrite HC2.
    + exists (C' ++ [CtxCommaR empty]). simpl; split.
      { rewrite fill_app /=. by rewrite heqY. }
      intros X; rewrite fill_app/=.
      by rewrite left_id.
    + apply bunch_decomp_complete in heqY.
      inversion heqY; simplify_eq/=.
      * exists (Π ++ [CtxCommaR Δ1]). split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
          by rewrite H3. }
        intros Δ. rewrite !fill_app/=.
        by rewrite comm.
      * exists (Π ++ [CtxCommaL Δ2]). split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
          by rewrite H3. }
        intros Δ. rewrite !fill_app/=.
        by rewrite comm.
    + apply bunch_decomp_complete in heqY.
      inversion heqY; simplify_eq/=.
      * inversion H3; simplify_eq/=.
        ** exists (Π0 ++ [CtxCommaL (Δ2 ,, Δ3)])%B. split.
           { rewrite fill_app/=.
             apply bunch_decomp_correct in H4.
               by rewrite H4. }
           intros Δ. rewrite !fill_app/=.
           by rewrite assoc.
        ** exists (Π0 ++ [CtxCommaL Δ3;CtxCommaR Δ1])%B. split.
           { simpl. rewrite fill_app/=.
             apply bunch_decomp_correct in H4.
             by rewrite H4. }
           intros Δ. rewrite !fill_app/=.
           by rewrite assoc.
      * exists (Π ++ [CtxCommaR Δ2;CtxCommaR Δ1])%B. split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
            by rewrite H3. }
           intros Δ. rewrite !fill_app/=.
           by rewrite assoc.
    + exists (C' ++ [CtxSemicR top]). simpl; split.
      { rewrite fill_app /=. by rewrite heqY. }
      intros X; rewrite fill_app/=.
      by rewrite left_id.
    + apply bunch_decomp_complete in heqY.
      inversion heqY; simplify_eq/=.
      * exists (Π ++ [CtxSemicR Δ1]). split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
          by rewrite H3. }
        intros Δ. rewrite !fill_app/=.
        by rewrite comm.
      * exists (Π ++ [CtxSemicL Δ2]). split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
          by rewrite H3. }
        intros Δ. rewrite !fill_app/=.
        by rewrite comm.
    + apply bunch_decomp_complete in heqY.
      inversion heqY; simplify_eq/=.
      * inversion H3; simplify_eq/=.
        ** exists (Π0 ++ [CtxSemicL (Δ2 ;, Δ3)])%B. split.
           { rewrite fill_app/=.
             apply bunch_decomp_correct in H4.
             by rewrite H4. }
           intros Δ. rewrite !fill_app/=.
           by rewrite assoc.
        ** exists (Π0 ++ [CtxSemicL Δ3;CtxSemicR Δ1])%B. split.
           { simpl. rewrite fill_app/=.
             apply bunch_decomp_correct in H4.
             by rewrite H4. }
           intros Δ. rewrite !fill_app/=.
           by rewrite assoc.
      * exists (Π ++ [CtxSemicR Δ2;CtxSemicR Δ1])%B. split.
        { rewrite fill_app/=.
          apply bunch_decomp_correct in H3.
            by rewrite H3. }
           intros Δ. rewrite !fill_app/=.
           by rewrite assoc.
  Qed.

  Lemma bunch_equiv_fill Δ C ϕ :
    Δ ≡ (fill C (frml ϕ)) →
    ∃ C', Δ = fill C' (frml ϕ) ∧ (∀ Δ, fill C' Δ ≡ fill C Δ).
  Proof.
    intros H%bunch_equiv_2.
    revert Δ H. eapply rtc_ind_l.
    { exists C. eauto. }
    intros X Y HXY HY. clear HY.
    intros (C0 & -> & HC0).
    destruct HXY as [HXY|HXY].
    - apply bunch_equiv_fill_2 in HXY.
      destruct HXY as (C' & -> & HC').
      eexists; split; eauto.
      intros ?. by rewrite HC' HC0.
    - apply bunch_equiv_fill_1 in HXY.
      destruct HXY as (C' & -> & HC').
      eexists; split; eauto.
      intros ?. by rewrite HC' HC0.
  Qed.

  (** * SEQUENT CALCULUS *)
  Polymorphic Inductive proves : bunch → formula → nat → Prop :=
    (* structural *)
  | BI_Higher Δ ϕ n : (Δ ⊢ᴮ{n} ϕ) → (Δ ⊢ᴮ{S n} ϕ)
  | BI_Axiom (a : atom) : frml (ATOM a) ⊢ᴮ{0} ATOM a
  | BI_Equiv Δ Δ' ϕ n :
      (Δ ≡ Δ') → (Δ ⊢ᴮ{n} ϕ) →
      Δ' ⊢ᴮ{S n} ϕ
  | BI_Weaken C Δ Δ' ϕ n : (fill C Δ ⊢ᴮ{n} ϕ) →
                         fill C (Δ ;, Δ') ⊢ᴮ{S n} ϕ
  | BI_Contr C Δ ϕ n : (fill C (Δ ;, Δ) ⊢ᴮ{n} ϕ) →
                     fill C Δ ⊢ᴮ{S n} ϕ
  | BI_Simple_Ext Π (Δs : nat → bunch) n
    (Ts : list bterm) (T : bterm) ϕ :
    (Ts, T) ∈ rules →
    (∀ Ti, Ti ∈ Ts → fill Π (bterm_ctx_act Ti Δs) ⊢ᴮ{n} ϕ) →
    fill Π (bterm_ctx_act T Δs) ⊢ᴮ{S n} ϕ
  (* multiplicatives *)
  | BI_Emp_R :
      empty ⊢ᴮ{0} EMP
  | BI_Emp_L C ϕ n :
      (fill C empty ⊢ᴮ{n} ϕ) →
      fill C (frml EMP) ⊢ᴮ{S n} ϕ
  | BI_Sep_R Δ Δ' ϕ ψ n m :
      (Δ ⊢ᴮ{n} ϕ) →
      (Δ' ⊢ᴮ{m} ψ) →
      Δ ,, Δ' ⊢ᴮ{S (n `max` m)} SEP ϕ ψ
  | BI_Sep_L C ϕ ψ χ n :
      (fill C (frml ϕ ,, frml ψ) ⊢ᴮ{n} χ) →
      fill C (frml (SEP ϕ ψ)) ⊢ᴮ{S n} χ
  | BI_Wand_R Δ ϕ ψ n :
      (Δ ,, frml ϕ ⊢ᴮ{n} ψ) →
      Δ  ⊢ᴮ{S n} WAND ϕ ψ
  | BI_Wand_L C Δ ϕ ψ χ n m :
      (Δ ⊢ᴮ{n} ϕ) →
      (fill C (frml ψ) ⊢ᴮ{m} χ) →
      fill C (Δ ,, frml (WAND ϕ ψ)) ⊢ᴮ{S (n `max` m)} χ
    (* additives *)
  | BI_False_L C ϕ :
      fill C (frml BOT) ⊢ᴮ{0} ϕ
  | BI_True_R Δ :
      Δ ⊢ᴮ{0} TOP
  | BI_True_L C ϕ n :
      (fill C top ⊢ᴮ{n} ϕ) →
      fill C (frml TOP) ⊢ᴮ{S n} ϕ
  | BI_Conj_R Δ Δ' ϕ ψ n m :
      (Δ ⊢ᴮ{n} ϕ) →
      (Δ' ⊢ᴮ{m} ψ) →
      Δ ;, Δ' ⊢ᴮ{S (n `max` m)} CONJ ϕ ψ
  | BI_Conj_L C ϕ ψ χ n :
      (fill C (frml ϕ ;, frml ψ) ⊢ᴮ{n} χ) →
      fill C (frml (CONJ ϕ ψ)) ⊢ᴮ{S n} χ
  | BI_Disj_R1 Δ ϕ ψ n :
      (Δ ⊢ᴮ{n} ϕ) →
      Δ ⊢ᴮ{S n} DISJ ϕ ψ
  | BI_Disj_R2 Δ ϕ ψ n :
      (Δ ⊢ᴮ{n} ψ) →
      Δ ⊢ᴮ{S n} DISJ ϕ ψ
  | BI_Disj_L Π ϕ ψ χ n m :
      (fill Π (frml ϕ) ⊢ᴮ{n} χ) →
      (fill Π (frml ψ) ⊢ᴮ{m} χ) →
      fill Π (frml (DISJ ϕ ψ)) ⊢ᴮ{S (n `max` m)} χ
  | BI_Impl_R Δ ϕ ψ n :
      (Δ ;, frml ϕ ⊢ᴮ{n} ψ) →
      Δ  ⊢ᴮ{S n} IMPL ϕ ψ
  | BI_Impl_L C Δ ϕ ψ χ n m:
      (Δ ⊢ᴮ{n} ϕ) →
      (fill C (frml ψ) ⊢ᴮ{m} χ) →
      fill C (Δ ;, frml (IMPL ϕ ψ)) ⊢ᴮ{S (n `max` m)} χ
  where "Δ ⊢ᴮ{ n } ϕ" := (proves Δ%B ϕ%B n).

  Lemma provesN_proves n Δ ϕ :
    (Δ ⊢ᴮ{ n } ϕ) → Δ ⊢ᴮ ϕ.
  Proof.
    induction 1; try by econstructor; eauto.
    (* XXX: somehow, [try] is really needed here ^ *)
  Qed.

  Lemma proves_le n m Δ ϕ :
    n ≤ m → (Δ ⊢ᴮ{n} ϕ) → Δ ⊢ᴮ{m} ϕ.
  Proof.
    induction 1; auto.
    intros H1. eapply BI_Higher. eauto.
  Qed.

  Lemma proves_provesN Δ ϕ :
    (Δ ⊢ᴮ ϕ) → ∃ n, Δ ⊢ᴮ{n} ϕ.
  Proof.
    induction 1.
    all: try destruct IHproves as [n IH].
    all: try (destruct IHproves1 as [n1 IH1];
              destruct IHproves2 as [n2 IH2]).
    all: try by eexists; econstructor; eauto.
    (* The worst case: simple structural rules *)
    apply (Forall_forall (λ Ti, ∃ n : nat, fill Π (bterm_ctx_act Ti Δs) ⊢ᴮ{ n} ϕ)) in H1.
    apply Forall_exists_Forall2 in H1.
    destruct H1 as (ns & Hns).
    exists (S (max_list ns)).
    eapply BI_Simple_Ext; eauto.
    intros Ti HTi.
    destruct (elem_of_list_lookup_1 _ _ HTi) as [i Hi].
    destruct (ns !! i) as [n|] eqn:Hn; last first.
    { eapply Forall2_lookup_r in Hns; eauto.
      naive_solver. }
    eapply (proves_le n). {
      eapply max_list_elem_of_le.
      by eapply elem_of_list_lookup_2.
    }
    eapply Forall2_lookup_lr in Hns; eauto.
  Qed.

  (** * Inversion lemmas *)
  Local Ltac bind_ctx :=
    match goal with
    | [ |- fill ?C ?Δ,, ?Δ' ⊢ᴮ{_} _ ] =>
      replace (fill C Δ,, Δ')%B
      with (fill (C ++ [CtxCommaL Δ']) Δ)%B
      by rewrite fill_app//
    | [ |- fill ?C ?Δ;, ?Δ' ⊢ᴮ{_} _ ] =>
      replace (fill C Δ;, Δ')%B
      with (fill (C ++ [CtxSemicL Δ']) Δ)%B
      by rewrite fill_app//
    end.

  Local Ltac commute_left_rule IH :=
    intros ->; bind_ctx;
    econstructor; eauto; rewrite fill_app; by eapply IH.

  Lemma wand_r_inv' Δ ϕ ψ n :
    (Δ ⊢ᴮ{n} WAND ϕ ψ) →
    (Δ ,, frml ϕ ⊢ᴮ{n} ψ)%B.
  Proof.
    remember (WAND ϕ ψ) as A.
    intros H. revert ϕ ψ HeqA.
    induction H; intros A B; try by inversion 1.
    all: try by (commute_left_rule IHproves).
    - intros ->. by constructor; apply IHproves.
    - intros ->. eapply BI_Equiv.
      { rewrite -H. reflexivity. }
      by apply IHproves.
    - intros ->. bind_ctx.
      eapply BI_Simple_Ext; eauto.
      intros Ti HTi. rewrite fill_app. simpl.
      eapply H1; eauto.
    - intros ?; simplify_eq/=. by apply BI_Higher.
    - commute_left_rule IHproves2.
    - intros ?; simplify_eq/=.
      bind_ctx. eapply BI_Disj_L.
      + rewrite fill_app/=. by eapply IHproves1.
      + rewrite fill_app/=. by eapply IHproves2.
    - commute_left_rule IHproves2.
  Qed.

  Lemma impl_r_inv' Δ ϕ ψ n :
    (Δ ⊢ᴮ{n} IMPL ϕ ψ) →
    (Δ ;, frml ϕ ⊢ᴮ{n} ψ)%B.
  Proof.
    remember (IMPL ϕ ψ) as A.
    intros H. revert ϕ ψ HeqA.
    induction H; intros A B; try by inversion 1.
    all: try by (commute_left_rule IHproves).
    - intros ->. by constructor; apply IHproves.
    - intros ->. eapply BI_Equiv.
      { rewrite -H. reflexivity. }
      by apply IHproves.
    - intros ->. bind_ctx.
      eapply BI_Simple_Ext; eauto.
      intros Ti HTi. rewrite fill_app. simpl.
      eapply H1; eauto.
    - commute_left_rule IHproves2.
    - intros ?; simplify_eq/=.
      bind_ctx. eapply BI_Disj_L.
      + rewrite fill_app/=. by eapply IHproves1.
      + rewrite fill_app/=. by eapply IHproves2.
    - intros ?; simplify_eq/=. by apply BI_Higher.
    - commute_left_rule IHproves2.
  Qed.

  Lemma sep_l_inv' Δ C ϕ ψ χ n :
    (Δ ⊢ᴮ{n} χ) →
    Δ = fill C (frml (SEP ϕ ψ)) →
    (fill C (frml ϕ,, frml ψ) ⊢ᴮ{n} χ).
  Proof.
    revert C Δ χ.
    induction n using lt_wf_ind. rename H into IHproves.
    intros C Δ χ PROOF Heq. symmetry in Heq. revert Heq.
    inversion PROOF; simplify_eq/= => Heq.
    (* induction H => C' Heq; symmetry in Heq. *)
    - (* raising the pf height *)
      apply BI_Higher.
      eapply IHproves; eauto.
    - (* axiom *)
      apply fill_is_frml in Heq. destruct_and!; simplify_eq/=.
      (* eapply BI_Sep_R; by econstructor. *)
    - (* equivalence of bunches *)
      simplify_eq/=.
      destruct (bunch_equiv_fill _ _ _ H) as [C2 [-> HC2]].
      eapply BI_Equiv.
      { apply HC2. }
      eapply IHproves; eauto.
    - (* weakening *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          apply BI_Weaken.
          rewrite -fill_app.
          eapply IHproves; eauto.
          by apply bunch_decomp_correct, bunch_decomp_app.
        * rewrite !fill_app/=.
          by apply BI_Weaken.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Weaken.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* contraction *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2]; last first.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Contr.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
      + rename C0 into C'.
        destruct H1 as [C0 [HC0 ->]].
        apply bunch_decomp_correct in HC0.
        simplify_eq/=.
        assert (fill C' (fill C0 (frml ϕ,, frml ψ);, fill C0 (frml (SEP ϕ ψ))) ⊢ᴮ{ n0} χ) as IH1.
        { specialize (IHproves n0 (lt_n_Sn _)).
          set (C2 := (C0 ++ [CtxSemicL (fill C0 (frml (SEP ϕ ψ)))] ++ C')%B).
          specialize (IHproves C2 _ _ H).
          revert IHproves. rewrite /C2 !fill_app /=.
          eauto. }
        rewrite fill_app.
        apply BI_Contr.
        set (C2 := (C0 ++ [CtxSemicR (fill C0 (frml ϕ,, frml ψ))] ++ C')%B).
        replace (fill C' (fill C0 (frml ϕ,, frml ψ);, fill C0 (frml ϕ,, frml ψ)))%B
                   with (fill C2 (frml ϕ,, frml ψ))%B by rewrite fill_app//.
        eapply IHproves; eauto.
        rewrite /C2 fill_app//.
    - (* ext *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2]; last first.
      + destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        eapply BI_Simple_Ext; eauto.
        intros Ti Hi.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
      + destruct H1 as [C0 [HC0 ->]].
        apply bunch_decomp_correct in HC0.
        simplify_eq/=.
        apply bterm_ctx_act_decomp in HC0; last first.
        { by eapply (rules_good (Ts,T)). }
        destruct HC0 as (j & Π₀ & Hjfv & Hj & HC0).
        rewrite fill_app -HC0.
        eapply BI_Simple_Ext; eauto.
        revert Hj Hjfv IHproves H0.
        clear.
        intros Hj Hjfv IHproves Hpfs.
        intros Ti HTi. specialize (Hpfs Ti HTi).
        revert Π Hpfs. clear HTi.
        induction Ti=>Π Hpfs.
        { simpl.
          destruct (decide (j = x)) as [->|?].
          - rewrite functions.fn_lookup_insert.
            rewrite -fill_app.
            eapply IHproves; eauto.
            by rewrite fill_app -Hj.
          - rewrite functions.fn_lookup_insert_ne; auto. }
        { simpl.
          assert (fill ([CtxCommaL (bterm_ctx_act Ti2 Δs)]++Π) (bterm_ctx_act Ti1 (<[j:=fill Π₀ (frml ϕ,, frml ψ)]> Δs)) ⊢ᴮ{ n0} χ) as HH1.
          { eapply IHTi1. rewrite fill_app /=. eauto. }
          rewrite fill_app in HH1.
          simpl in HH1.
          replace
          (fill Π (bterm_ctx_act Ti1
             (<[j:=fill Π₀ (frml ϕ,, frml ψ)]> Δs),,bterm_ctx_act Ti2 (<[j:=fill Π₀ (frml ϕ,, frml ψ)]> Δs)))%B
            with
          (fill ([CtxCommaR (bterm_ctx_act Ti1 (<[j:=fill Π₀ (frml ϕ,, frml ψ)]> Δs))]++Π)
                (bterm_ctx_act Ti2 (<[j:=fill Π₀ (frml ϕ,, frml ψ)]> Δs)))%B
            by rewrite fill_app//.
          eapply IHTi2.
          rewrite fill_app/=//. }
        { simpl.
          assert (fill ([CtxSemicL (bterm_ctx_act Ti2 Δs)]++Π) (bterm_ctx_act Ti1 (<[j:=fill Π₀ (frml ϕ,, frml ψ)]> Δs)) ⊢ᴮ{ n0} χ) as HH1.
          { eapply IHTi1. rewrite fill_app /=. eauto. }
          rewrite fill_app in HH1.
          simpl in HH1.
          replace
          (fill Π (bterm_ctx_act Ti1
             (<[j:=fill Π₀ (frml ϕ,, frml ψ)]> Δs);,bterm_ctx_act Ti2 (<[j:=fill Π₀ (frml ϕ,, frml ψ)]> Δs)))%B
            with
          (fill ([CtxSemicR (bterm_ctx_act Ti1 (<[j:=fill Π₀ (frml ϕ,, frml ψ)]> Δs))]++Π)
                (bterm_ctx_act Ti2 (<[j:=fill Π₀ (frml ϕ,, frml ψ)]> Δs)))%B
            by rewrite fill_app//.
          eapply IHTi2.
          rewrite fill_app/=//. }
    - (* emp R *)
      exfalso.
      apply bunch_decomp_complete in Heq.
      inversion Heq.
    - (* emp L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Emp_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* sep R *)
      apply bunch_decomp_complete in Heq.
      inversion Heq; simplify_eq/=.
      + rewrite fill_app /=.
        eapply BI_Sep_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
      + rewrite fill_app /=.
        eapply BI_Sep_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
    - (* sep L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        by apply BI_Higher.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Sep_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* wand R *)
      apply BI_Wand_R.
      assert ((fill C (frml ϕ,, frml ψ),, frml ϕ0) =
                   fill (C ++ [CtxCommaL (frml ϕ0)]) (frml ϕ,, frml ψ))%B as ->.
      { rewrite fill_app//. }
      eapply IHproves; eauto. rewrite -Heq fill_app /= //.
    - (* wand L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          eapply BI_Wand_L; eauto.
          eapply IHproves; eauto; first lia.
          by apply bunch_decomp_correct.
        * exfalso. inversion H5.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Wand_L; eauto.
        rewrite -HC0.
        eapply IHproves; eauto; first lia.
        apply bunch_decomp_correct. apply Hdec0.
    - (* bot L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_False_L.
    - (* top R *) apply BI_True_R.
    - (* top L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_True_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* conjR *)
      apply bunch_decomp_complete in Heq.
      inversion Heq; simplify_eq/=.
      + rewrite fill_app /=.
        eapply BI_Conj_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
      + rewrite fill_app /=.
        eapply BI_Conj_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
    - (* conjL *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Conj_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* disj R 1 *)
      eapply BI_Disj_R1.
      eapply IHproves; eauto.
    - (* disj R 2 *)
      eapply BI_Disj_R2.
      eapply IHproves; eauto.
    - (* disj L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Disj_L.
        * rewrite -HC0.
          eapply IHproves; eauto; first lia.
          apply bunch_decomp_correct. apply Hdec0.
        * rewrite -HC0.
          eapply IHproves; eauto; first lia.
          apply bunch_decomp_correct. apply Hdec0.
    - (* impl R *)
      apply BI_Impl_R.
      assert ((fill C (frml ϕ,, frml ψ);, frml ϕ0) =
                   fill (C ++ [CtxSemicL (frml ϕ0)]) (frml ϕ,, frml ψ))%B as ->.
      { rewrite fill_app//. }
      eapply IHproves; eauto. rewrite -Heq fill_app /= //.
    -       apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          eapply BI_Impl_L; eauto.
          eapply IHproves; eauto; first lia.
          by apply bunch_decomp_correct.
        * exfalso. inversion H5.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Impl_L; eauto.
        rewrite -HC0.
        eapply IHproves; eauto; first lia.
        apply bunch_decomp_correct. apply Hdec0.
  Qed.

  Lemma conj_l_inv' Δ C ϕ ψ χ n :
    (Δ ⊢ᴮ{n} χ) →
    Δ = fill C (frml (CONJ ϕ ψ)) →
    (fill C (frml ϕ;, frml ψ) ⊢ᴮ{n} χ).
  Proof.
    revert C Δ χ.
    induction n using lt_wf_ind. rename H into IHproves.
    intros C Δ χ PROOF Heq. symmetry in Heq. revert Heq.
    inversion PROOF; simplify_eq/= => Heq.
    (* induction H => C' Heq; symmetry in Heq. *)
    - (* raising the pf height *)
      apply BI_Higher.
      eapply IHproves; eauto.
    - (* axiom *)
      apply fill_is_frml in Heq. destruct_and!; simplify_eq/=.
      (* eapply BI_Sep_R; by econstructor. *)
    - (* equivalence of bunches *)
      simplify_eq/=.
      destruct (bunch_equiv_fill _ _ _ H) as [C2 [-> HC2]].
      eapply BI_Equiv.
      { apply HC2. }
      eapply IHproves; eauto.
    - (* weakening *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          apply BI_Weaken.
          rewrite -fill_app.
          eapply IHproves; eauto.
          by apply bunch_decomp_correct, bunch_decomp_app.
        * rewrite !fill_app/=.
          by apply BI_Weaken.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Weaken.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* contraction *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2]; last first.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Contr.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
      + rename C0 into C'.
        destruct H1 as [C0 [HC0 ->]].
        apply bunch_decomp_correct in HC0.
        simplify_eq/=.
        assert (fill C' (fill C0 (frml ϕ;, frml ψ);, fill C0 (frml (CONJ ϕ ψ))) ⊢ᴮ{ n0} χ) as IH1.
        { specialize (IHproves n0 (lt_n_Sn _)).
          set (C2 := (C0 ++ [CtxSemicL (fill C0 (frml (CONJ ϕ ψ)))] ++ C')%B).
          specialize (IHproves C2 _ _ H).
          revert IHproves. rewrite /C2 !fill_app /=.
          eauto. }
        rewrite fill_app.
        apply BI_Contr.
        set (C2 := (C0 ++ [CtxSemicR (fill C0 (frml ϕ;, frml ψ))] ++ C')%B).
        replace (fill C' (fill C0 (frml ϕ;, frml ψ);, fill C0 (frml ϕ;, frml ψ)))%B
                   with (fill C2 (frml ϕ;, frml ψ))%B by rewrite fill_app//.
        eapply IHproves; eauto.
        rewrite /C2 fill_app//.
    - (* ext *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2]; last first.
      + destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        eapply BI_Simple_Ext; eauto.
        intros Ti Hi.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
      + destruct H1 as [C0 [HC0 ->]].
        apply bunch_decomp_correct in HC0.
        simplify_eq/=.
        apply bterm_ctx_act_decomp in HC0; last first.
        { by eapply (rules_good (Ts,T)). }
        destruct HC0 as (j & Π₀ & Hjfv & Hj & HC0).
        rewrite fill_app -HC0.
        eapply BI_Simple_Ext; eauto.
        revert Hj Hjfv IHproves H0.
        clear.
        intros Hj Hjfv IHproves Hpfs.
        intros Ti HTi. specialize (Hpfs Ti HTi).
        revert Π Hpfs. clear HTi.
        induction Ti=>Π Hpfs.
        { simpl.
          destruct (decide (j = x)) as [->|?].
          - rewrite functions.fn_lookup_insert.
            rewrite -fill_app.
            eapply IHproves; eauto.
            by rewrite fill_app -Hj.
          - rewrite functions.fn_lookup_insert_ne; auto. }
        { simpl.
          assert (fill ([CtxCommaL (bterm_ctx_act Ti2 Δs)]++Π) (bterm_ctx_act Ti1 (<[j:=fill Π₀ (frml ϕ;, frml ψ)]> Δs)) ⊢ᴮ{ n0} χ) as HH1.
          { eapply IHTi1. rewrite fill_app /=. eauto. }
          rewrite fill_app in HH1.
          simpl in HH1.
          replace
          (fill Π (bterm_ctx_act Ti1
             (<[j:=fill Π₀ (frml ϕ;, frml ψ)]> Δs),,bterm_ctx_act Ti2 (<[j:=fill Π₀ (frml ϕ;, frml ψ)]> Δs)))%B
            with
          (fill ([CtxCommaR (bterm_ctx_act Ti1 (<[j:=fill Π₀ (frml ϕ;, frml ψ)]> Δs))]++Π)
                (bterm_ctx_act Ti2 (<[j:=fill Π₀ (frml ϕ;, frml ψ)]> Δs)))%B
            by rewrite fill_app//.
          eapply IHTi2.
          rewrite fill_app/=//. }
        { simpl.
          assert (fill ([CtxSemicL (bterm_ctx_act Ti2 Δs)]++Π) (bterm_ctx_act Ti1 (<[j:=fill Π₀ (frml ϕ;, frml ψ)]> Δs)) ⊢ᴮ{ n0} χ) as HH1.
          { eapply IHTi1. rewrite fill_app /=. eauto. }
          rewrite fill_app in HH1.
          simpl in HH1.
          replace
          (fill Π (bterm_ctx_act Ti1
             (<[j:=fill Π₀ (frml ϕ;, frml ψ)]> Δs);,bterm_ctx_act Ti2 (<[j:=fill Π₀ (frml ϕ;, frml ψ)]> Δs)))%B
            with
          (fill ([CtxSemicR (bterm_ctx_act Ti1 (<[j:=fill Π₀ (frml ϕ;, frml ψ)]> Δs))]++Π)
                (bterm_ctx_act Ti2 (<[j:=fill Π₀ (frml ϕ;, frml ψ)]> Δs)))%B
            by rewrite fill_app//.
          eapply IHTi2.
          rewrite fill_app/=//. }
    - (* emp R *)
      exfalso.
      apply bunch_decomp_complete in Heq.
      inversion Heq.
    - (* emp L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Emp_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* sep R *)
      apply bunch_decomp_complete in Heq.
      inversion Heq; simplify_eq/=.
      + rewrite fill_app /=.
        eapply BI_Sep_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
      + rewrite fill_app /=.
        eapply BI_Sep_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
    - (* sep L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Sep_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* wand R *)
      apply BI_Wand_R.
      assert ((fill C (frml ϕ;, frml ψ),, frml ϕ0) =
                   fill (C ++ [CtxCommaL (frml ϕ0)]) (frml ϕ;, frml ψ))%B as ->.
      { rewrite fill_app//. }
      eapply IHproves; eauto. rewrite -Heq fill_app /= //.
    - (* wand L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          eapply BI_Wand_L; eauto.
          eapply IHproves; eauto; first lia.
          by apply bunch_decomp_correct.
        * exfalso. inversion H5.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Wand_L; eauto.
        rewrite -HC0.
        eapply IHproves; eauto; first lia.
        apply bunch_decomp_correct. apply Hdec0.
    - (* bot L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_False_L.
    - (* top R *) apply BI_True_R.
    - (* top L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_True_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* conjR *)
      apply bunch_decomp_complete in Heq.
      inversion Heq; simplify_eq/=.
      + rewrite fill_app /=.
        eapply BI_Conj_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
      + rewrite fill_app /=.
        eapply BI_Conj_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
    - (* conjL *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        by apply BI_Higher.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Conj_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* disj R 1 *)
      eapply BI_Disj_R1.
      eapply IHproves; eauto.
    - (* disj R 2 *)
      eapply BI_Disj_R2.
      eapply IHproves; eauto.
    - (* disj L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Disj_L.
        * rewrite -HC0.
          eapply IHproves; eauto; first lia.
          apply bunch_decomp_correct. apply Hdec0.
        * rewrite -HC0.
          eapply IHproves; eauto; first lia.
          apply bunch_decomp_correct. apply Hdec0.
    - (* impl R *)
      apply BI_Impl_R.
      assert ((fill C (frml ϕ;, frml ψ);, frml ϕ0) =
                   fill (C ++ [CtxSemicL (frml ϕ0)]) (frml ϕ;, frml ψ))%B as ->.
      { rewrite fill_app//. }
      eapply IHproves; eauto. rewrite -Heq fill_app /= //.
    -       apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          eapply BI_Impl_L; eauto.
          eapply IHproves; eauto; first lia.
          by apply bunch_decomp_correct.
        * exfalso. inversion H5.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Impl_L; eauto.
        rewrite -HC0.
        eapply IHproves; eauto; first lia.
        apply bunch_decomp_correct. apply Hdec0.
  Qed.

  Lemma top_l_inv' Δ C ϕ ψ χ n :
    (Δ ⊢ᴮ{n} χ) →
    Δ = fill C (frml TOP) →
    (fill C top ⊢ᴮ{n} χ).
  Proof.
    revert C Δ χ.
    induction n using lt_wf_ind. rename H into IHproves.
    intros C Δ χ PROOF Heq. symmetry in Heq. revert Heq.
    inversion PROOF; simplify_eq/= => Heq.
    (* induction H => C' Heq; symmetry in Heq. *)
    - (* raising the pf height *)
      apply BI_Higher.
      eapply IHproves; eauto.
    - (* axiom *)
      apply fill_is_frml in Heq. destruct_and!; simplify_eq/=.
    - (* equivalence of bunches *)
      simplify_eq/=.
      destruct (bunch_equiv_fill _ _ _ H) as [C2 [-> HC2]].
      eapply BI_Equiv.
      { apply HC2. }
      eapply IHproves; eauto.
    - (* weakening *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          apply BI_Weaken.
          rewrite -fill_app.
          eapply IHproves; eauto.
          by apply bunch_decomp_correct, bunch_decomp_app.
        * rewrite !fill_app/=.
          by apply BI_Weaken.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Weaken.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* contraction *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2]; last first.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Contr.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
      + rename C0 into C'.
        destruct H1 as [C0 [HC0 ->]].
        apply bunch_decomp_correct in HC0.
        simplify_eq/=.
        assert (fill C' (fill C0 top;, fill C0 (frml TOP)) ⊢ᴮ{ n0} χ) as IH1.
        { specialize (IHproves n0 (lt_n_Sn _)).
          set (C2 := (C0 ++ [CtxSemicL (fill C0 (frml TOP))] ++ C')%B).
          specialize (IHproves C2 _ _ H).
          revert IHproves. rewrite /C2 !fill_app /=.
          eauto. }
        rewrite fill_app.
        apply BI_Contr.
        set (C2 := (C0 ++ [CtxSemicR (fill C0 top)] ++ C')%B).
        replace (fill C' (fill C0 top;, fill C0 top))%B
                   with (fill C2 top)%B by rewrite fill_app//.
        eapply IHproves; eauto.
        rewrite /C2 fill_app//.
    - (* ext *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2]; last first.
      + destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        eapply BI_Simple_Ext; eauto.
        intros Ti Hi.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
      + destruct H1 as [C0 [HC0 ->]].
        apply bunch_decomp_correct in HC0.
        simplify_eq/=.
        apply bterm_ctx_act_decomp in HC0; last first.
        { by eapply (rules_good (Ts, T)). }
        destruct HC0 as (j & Π₀ & Hjfv & Hj & HC0).
        rewrite fill_app -HC0.
        eapply BI_Simple_Ext; eauto.
        revert Hj Hjfv IHproves H0.
        clear.
        intros Hj Hjfv IHproves Hpfs.
        intros Ti HTi. specialize (Hpfs Ti HTi).
        revert Π Hpfs. clear HTi.
        induction Ti=>Π Hpfs.
        { simpl.
          destruct (decide (j = x)) as [->|?].
          - rewrite functions.fn_lookup_insert.
            rewrite -fill_app.
            eapply IHproves; eauto.
            by rewrite fill_app -Hj.
          - rewrite functions.fn_lookup_insert_ne; auto. }
        { simpl.
          assert (fill ([CtxCommaL (bterm_ctx_act Ti2 Δs)]++Π) (bterm_ctx_act Ti1 (<[j:=fill Π₀ top]> Δs)) ⊢ᴮ{ n0} χ) as HH1.
          { eapply IHTi1. rewrite fill_app /=. eauto. }
          rewrite fill_app in HH1.
          simpl in HH1.
          replace
          (fill Π (bterm_ctx_act Ti1
             (<[j:=fill Π₀ top]> Δs),,bterm_ctx_act Ti2 (<[j:=fill Π₀ top]> Δs)))%B
            with
          (fill ([CtxCommaR (bterm_ctx_act Ti1 (<[j:=fill Π₀ top]> Δs))]++Π)
                (bterm_ctx_act Ti2 (<[j:=fill Π₀ top]> Δs)))%B
            by rewrite fill_app//.
          eapply IHTi2.
          rewrite fill_app/=//. }
        { simpl.
          assert (fill ([CtxSemicL (bterm_ctx_act Ti2 Δs)]++Π) (bterm_ctx_act Ti1 (<[j:=fill Π₀ top]> Δs)) ⊢ᴮ{ n0} χ) as HH1.
          { eapply IHTi1. rewrite fill_app /=. eauto. }
          rewrite fill_app in HH1.
          simpl in HH1.
          replace
          (fill Π (bterm_ctx_act Ti1
             (<[j:=fill Π₀ top]> Δs);,bterm_ctx_act Ti2 (<[j:=fill Π₀ top]> Δs)))%B
            with
          (fill ([CtxSemicR (bterm_ctx_act Ti1 (<[j:=fill Π₀ top]> Δs))]++Π)
                (bterm_ctx_act Ti2 (<[j:=fill Π₀ top]> Δs)))%B
            by rewrite fill_app//.
          eapply IHTi2.
          rewrite fill_app/=//. }
    - (* emp R *)
      exfalso.
      apply bunch_decomp_complete in Heq.
      inversion Heq.
    - (* emp L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Emp_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* sep R *)
      apply bunch_decomp_complete in Heq.
      inversion Heq; simplify_eq/=.
      + rewrite fill_app /=.
        eapply BI_Sep_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
      + rewrite fill_app /=.
        eapply BI_Sep_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
    - (* sep L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Sep_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* wand R *)
      apply BI_Wand_R.
      assert ((fill C top,, frml ϕ0) =
                   fill (C ++ [CtxCommaL (frml ϕ0)]) top)%B as ->.
      { rewrite fill_app//. }
      eapply IHproves; eauto. rewrite -Heq fill_app /= //.
    - (* wand L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          eapply BI_Wand_L; eauto.
          eapply IHproves; eauto; first lia.
          by apply bunch_decomp_correct.
        * exfalso. inversion H5.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Wand_L; eauto.
        rewrite -HC0.
        eapply IHproves; eauto; first lia.
        apply bunch_decomp_correct. apply Hdec0.
    - (* bot L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_False_L.
    - (* top R *) apply BI_True_R.
    - (* top L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        by eapply BI_Higher.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_True_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* conjR *)
      apply bunch_decomp_complete in Heq.
      inversion Heq; simplify_eq/=.
      + rewrite fill_app /=.
        eapply BI_Conj_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
      + rewrite fill_app /=.
        eapply BI_Conj_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
    - (* conjL *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Conj_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* disj R 1 *)
      eapply BI_Disj_R1.
      eapply IHproves; eauto.
    - (* disj R 2 *)
      eapply BI_Disj_R2.
      eapply IHproves; eauto.
    - (* disj L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Disj_L.
        * rewrite -HC0.
          eapply IHproves; eauto; first lia.
          apply bunch_decomp_correct. apply Hdec0.
        * rewrite -HC0.
          eapply IHproves; eauto; first lia.
          apply bunch_decomp_correct. apply Hdec0.
    - (* impl R *)
      apply BI_Impl_R.
      assert ((fill C top;, frml ϕ0) =
                   fill (C ++ [CtxSemicL (frml ϕ0)]) top)%B as ->.
      { rewrite fill_app//. }
      eapply IHproves; eauto. rewrite -Heq fill_app /= //.
    -       apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          eapply BI_Impl_L; eauto.
          eapply IHproves; eauto; first lia.
          by apply bunch_decomp_correct.
        * exfalso. inversion H5.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Impl_L; eauto.
        rewrite -HC0.
        eapply IHproves; eauto; first lia.
        apply bunch_decomp_correct. apply Hdec0.
  Qed.

  Lemma emp_l_inv' Δ C ϕ ψ χ n :
    (Δ ⊢ᴮ{n} χ) →
    Δ = fill C (frml EMP) →
    (fill C empty ⊢ᴮ{n} χ).
  Proof.
    revert C Δ χ.
    induction n using lt_wf_ind. rename H into IHproves.
    intros C Δ χ PROOF Heq. symmetry in Heq. revert Heq.
    inversion PROOF; simplify_eq/= => Heq.
    (* induction H => C' Heq; symmetry in Heq. *)
    - (* raising the pf height *)
      apply BI_Higher.
      eapply IHproves; eauto.
    - (* axiom *)
      apply fill_is_frml in Heq. destruct_and!; simplify_eq/=.
    - (* equivalence of bunches *)
      simplify_eq/=.
      destruct (bunch_equiv_fill _ _ _ H) as [C2 [-> HC2]].
      eapply BI_Equiv.
      { apply HC2. }
      eapply IHproves; eauto.
    - (* weakening *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          apply BI_Weaken.
          rewrite -fill_app.
          eapply IHproves; eauto.
          by apply bunch_decomp_correct, bunch_decomp_app.
        * rewrite !fill_app/=.
          by apply BI_Weaken.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Weaken.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* contraction *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2]; last first.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Contr.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
      + rename C0 into C'.
        destruct H1 as [C0 [HC0 ->]].
        apply bunch_decomp_correct in HC0.
        simplify_eq/=.
        assert (fill C' (fill C0 empty;, fill C0 (frml EMP)) ⊢ᴮ{ n0} χ) as IH1.
        { specialize (IHproves n0 (lt_n_Sn _)).
          set (C2 := (C0 ++ [CtxSemicL (fill C0 (frml EMP))] ++ C')%B).
          specialize (IHproves C2 _ _ H).
          revert IHproves. rewrite /C2 !fill_app /=.
          eauto. }
        rewrite fill_app.
        apply BI_Contr.
        set (C2 := (C0 ++ [CtxSemicR (fill C0 empty)] ++ C')%B).
        replace (fill C' (fill C0 empty;, fill C0 empty))%B
                   with (fill C2 empty)%B by rewrite fill_app//.
        eapply IHproves; eauto.
        rewrite /C2 fill_app//.
    - (* ext *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2]; last first.
      + destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        eapply BI_Simple_Ext; eauto.
        intros Ti Hi.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
      + destruct H1 as [C0 [HC0 ->]].
        apply bunch_decomp_correct in HC0.
        simplify_eq/=.
        apply bterm_ctx_act_decomp in HC0; last first.
        { by eapply (rules_good (Ts,T)). }
        destruct HC0 as (j & Π₀ & Hjfv & Hj & HC0).
        rewrite fill_app -HC0.
        eapply BI_Simple_Ext; eauto.
        revert Hj Hjfv IHproves H0.
        clear.
        intros Hj Hjfv IHproves Hpfs.
        intros Ti HTi. specialize (Hpfs Ti HTi).
        revert Π Hpfs. clear HTi.
        induction Ti=>Π Hpfs.
        { simpl.
          destruct (decide (j = x)) as [->|?].
          - rewrite functions.fn_lookup_insert.
            rewrite -fill_app.
            eapply IHproves; eauto.
            by rewrite fill_app -Hj.
          - rewrite functions.fn_lookup_insert_ne; auto. }
        { simpl.
          assert (fill ([CtxCommaL (bterm_ctx_act Ti2 Δs)]++Π) (bterm_ctx_act Ti1 (<[j:=fill Π₀ empty]> Δs)) ⊢ᴮ{ n0} χ) as HH1.
          { eapply IHTi1. rewrite fill_app /=. eauto. }
          rewrite fill_app in HH1.
          simpl in HH1.
          replace
          (fill Π (bterm_ctx_act Ti1
             (<[j:=fill Π₀ empty]> Δs),,bterm_ctx_act Ti2 (<[j:=fill Π₀ empty]> Δs)))%B
            with
          (fill ([CtxCommaR (bterm_ctx_act Ti1 (<[j:=fill Π₀ empty]> Δs))]++Π)
                (bterm_ctx_act Ti2 (<[j:=fill Π₀ empty]> Δs)))%B
            by rewrite fill_app//.
          eapply IHTi2.
          rewrite fill_app/=//. }
        { simpl.
          assert (fill ([CtxSemicL (bterm_ctx_act Ti2 Δs)]++Π) (bterm_ctx_act Ti1 (<[j:=fill Π₀ empty]> Δs)) ⊢ᴮ{ n0} χ) as HH1.
          { eapply IHTi1. rewrite fill_app /=. eauto. }
          rewrite fill_app in HH1.
          simpl in HH1.
          replace
          (fill Π (bterm_ctx_act Ti1
             (<[j:=fill Π₀ empty]> Δs);,bterm_ctx_act Ti2 (<[j:=fill Π₀ empty]> Δs)))%B
            with
          (fill ([CtxSemicR (bterm_ctx_act Ti1 (<[j:=fill Π₀ empty]> Δs))]++Π)
                (bterm_ctx_act Ti2 (<[j:=fill Π₀ empty]> Δs)))%B
            by rewrite fill_app//.
          eapply IHTi2.
          rewrite fill_app/=//. }
    - (* emp R *)
      exfalso.
      apply bunch_decomp_complete in Heq.
      inversion Heq.
    - (* emp L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        by eapply BI_Higher.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Emp_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* sep R *)
      apply bunch_decomp_complete in Heq.
      inversion Heq; simplify_eq/=.
      + rewrite fill_app /=.
        eapply BI_Sep_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
      + rewrite fill_app /=.
        eapply BI_Sep_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
    - (* sep L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Sep_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* wand R *)
      apply BI_Wand_R.
      assert ((fill C empty,, frml ϕ0) =
                   fill (C ++ [CtxCommaL (frml ϕ0)]) empty)%B as ->.
      { rewrite fill_app//. }
      eapply IHproves; eauto. rewrite -Heq fill_app /= //.
    - (* wand L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          eapply BI_Wand_L; eauto.
          eapply IHproves; eauto; first lia.
          by apply bunch_decomp_correct.
        * exfalso. inversion H5.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Wand_L; eauto.
        rewrite -HC0.
        eapply IHproves; eauto; first lia.
        apply bunch_decomp_correct. apply Hdec0.
    - (* bot L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_False_L.
    - (* true R *) apply BI_True_R.
    - (* true L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_True_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* conjR *)
      apply bunch_decomp_complete in Heq.
      inversion Heq; simplify_eq/=.
      + rewrite fill_app /=.
        eapply BI_Conj_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
      + rewrite fill_app /=.
        eapply BI_Conj_R; eauto.
        eapply IHproves; eauto; first lia.
        by apply bunch_decomp_correct.
    - (* conjL *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Conj_L.
        rewrite -HC0.
        eapply IHproves; eauto.
        apply bunch_decomp_correct. apply Hdec0.
    - (* disj R 1 *)
      eapply BI_Disj_R1.
      eapply IHproves; eauto.
    - (* disj R 2 *)
      eapply BI_Disj_R2.
      eapply IHproves; eauto.
    - (* disj L *)
      apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
      + destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Disj_L.
        * rewrite -HC0.
          eapply IHproves; eauto; first lia.
          apply bunch_decomp_correct. apply Hdec0.
        * rewrite -HC0.
          eapply IHproves; eauto; first lia.
          apply bunch_decomp_correct. apply Hdec0.
    - (* impl R *)
      apply BI_Impl_R.
      assert ((fill C empty;, frml ϕ0) =
                   fill (C ++ [CtxSemicL (frml ϕ0)]) empty)%B as ->.
      { rewrite fill_app//. }
      eapply IHproves; eauto. rewrite -Heq fill_app /= //.
    -       apply bunch_decomp_complete in Heq.
      apply bunch_decomp_ctx in Heq.
      destruct Heq as [H1 | H2].
      + destruct H1 as [C1 [HC0 HC]].
        inversion HC0; simplify_eq/=.
        * rewrite !fill_app/=.
          eapply BI_Impl_L; eauto.
          eapply IHproves; eauto; first lia.
          by apply bunch_decomp_correct.
        * exfalso. inversion H5.
      + rename C0 into C'.
        destruct H2 as (C0 & C1 & HC0 & HC1 & Hdec0).
        rewrite -HC1.
        apply BI_Impl_L; eauto.
        rewrite -HC0.
        eapply IHproves; eauto; first lia.
        apply bunch_decomp_correct. apply Hdec0.
  Qed.

  (** Derivable rules / inversion lemmas *)
  Lemma impl_r_inv Δ ϕ ψ :
    (Δ ⊢ᴮ IMPL ϕ ψ) →
    (Δ ;, frml ϕ ⊢ᴮ ψ)%B.
  Proof.
    intros [n H]%proves_provesN.
    eapply provesN_proves.
    by apply impl_r_inv'.
  Qed.
  Lemma wand_r_inv Δ ϕ ψ :
    (Δ ⊢ᴮ WAND ϕ ψ) →
    (Δ ,, frml ϕ ⊢ᴮ ψ)%B.
  Proof.
    intros [n H]%proves_provesN.
    eapply provesN_proves.
    by apply wand_r_inv'.
  Qed.
  Lemma sep_l_inv C ϕ ψ χ :
    (fill C (frml (SEP ϕ ψ)) ⊢ᴮ χ) →
    (fill C (frml ϕ,, frml ψ) ⊢ᴮ χ).
  Proof.
    intros [n H]%proves_provesN.
    eapply provesN_proves.
    eapply sep_l_inv'; eauto.
  Qed.
  Lemma conj_l_inv C ϕ ψ χ :
    (fill C (frml (CONJ ϕ ψ)) ⊢ᴮ χ) →
    (fill C (frml ϕ;, frml ψ) ⊢ᴮ χ).
  Proof.
    intros [n H]%proves_provesN.
    eapply provesN_proves.
    eapply conj_l_inv'; eauto.
  Qed.
  Lemma collapse_l_inv C Δ ϕ :
    (fill C (frml (collapse Δ)) ⊢ᴮ ϕ) →
    (fill C Δ ⊢ᴮ ϕ).
  Proof.
    revert C. induction Δ; simpl; first done.
    - intros C [n H]%proves_provesN.
      eapply provesN_proves.
      eapply top_l_inv'; eauto.
    - intros C [n H]%proves_provesN.
      eapply provesN_proves.
      eapply emp_l_inv'; eauto.
    - intros C H1.
      replace (fill C (Δ1,, Δ2))%B
        with (fill (CtxCommaR Δ1::C) Δ2) by reflexivity.
      apply IHΔ2. simpl.
      replace (fill C (Δ1,, frml (collapse Δ2)))%B
        with (fill (CtxCommaL (frml (collapse Δ2))::C) Δ1) by reflexivity.
      apply IHΔ1. simpl.
      by apply sep_l_inv.
    - intros C H1.
      replace (fill C (Δ1;, Δ2))%B
        with (fill (CtxSemicR Δ1::C) Δ2) by reflexivity.
      apply IHΔ2. simpl.
      replace (fill C (Δ1;, frml (collapse Δ2)))%B
        with (fill (CtxSemicL (frml (collapse Δ2))::C) Δ1) by reflexivity.
      apply IHΔ1. simpl.
      by apply conj_l_inv.
  Qed.
End SeqcalcHeight.


Require Import Min.

Require Import msl.msl_standard.
Require Import Maps.
Require Import FuncListMachine.
Require Import lemmas.
Require Import hoare_total.

Open Scope pred.

Section estep.
  Variable X:Type.
  Variable x:X.

  Inductive estep : program X -> store -> list (instr X) -> store -> list (instr X) -> Prop :=

  | estep_assert : forall p r i stk (P:X),
    (*----------------------------------------------------*)
      estep p r ((instr_assert P ;; i) :: stk) r (i :: stk)

  | estep_getlabel: forall p r l v i stk,
    (*----------------------------------------------------*)
      estep p r ((instr_getlabel l v ;; i) :: stk) (r#v <- (value_label l)) (i :: stk)

  | estep_fetch_field_0: forall p r v1 v2 i a0 a1 stk,
      r#v1 = Some (value_cons a0 a1) ->
    (*----------------------------------------------------*)
      estep p r ((instr_fetch_field v1 0 v2 ;; i) :: stk) (r#v2 <- a0) (i :: stk)

  | estep_fetch_field_1: forall p r v1 v2 i a0 a1 stk,
      r#v1 = Some (value_cons a0 a1) ->
    (*----------------------------------------------------*)
      estep p r ((instr_fetch_field v1 1 v2 ;; i) :: stk) (r#v2 <- a1) (i :: stk)

  | estep_cons: forall p r v1 v2 v3 i a1 a2 stk,
      r#v1 = Some a1 ->
      r#v2 = Some a2 ->
    (*----------------------------------------------------*)
      estep p r ((instr_cons v1 v2 v3 ;; i) :: stk) (r#v3 <- (value_cons a1 a2)) (i :: stk)

  | estep_seq: forall p r i1 i2 i3 stk,
    (*----------------------------------------------------*)
      estep p r (((i1 ;; i2) ;; i3) :: stk) r ((i1 ;; i2 ;; i3) :: stk)

  | estep_if_nil1 : forall p r v i1 i2 i stk,
      r#v = Some (value_label (L 0)) ->
    (*----------------------------------------------------*)
      estep p r ((instr_if_nil v i1 i2 ;; i) :: stk) r ((i1 ;; i) :: stk)

  | estep_if_nil2 : forall p r v i1 i2 i a1 a2 stk,
      r#v = Some (value_cons a1 a2) ->
    (*----------------------------------------------------*)
      estep p r ((instr_if_nil v i1 i2 ;; i) :: stk) r ((i2 ;; i) :: stk)

  | estep_call : forall p r v l i i' stk,
      r#v = Some (value_label l) ->
      p#l = Some i' ->
    (*----------------------------------------------------*)
      estep p r ((instr_call v ;; i) :: stk) r ((i' ;; instr_assert x) :: i :: stk)

  | estep_return : forall p r stk i,
    (*----------------------------------------------------*)
      estep p r ((instr_return ;; i) :: stk) r stk.

  Inductive estepstar : program X -> store -> list (instr X) -> store -> list (instr X) ->  Prop :=
  | estepstar_O: forall p s i, estepstar p s i s i
  | estepstar_S: forall p s i s' i' s'' i'',
              estep p s i s' i' ->
              estepstar p s' i' s'' i'' ->
              estepstar p s i s'' i''.

  Definition eventually_ehalts (p:program X) (r:store) (s:list (instr X)) : Prop :=
    exists r', estepstar p r s r' nil.

  Definition erase_instr : instruction -> instr X :=
    fmap_instr (fun _ => x).

  Definition erase_prog := map_fmap _ _ erase_instr.

  Theorem erase_step : forall p p' n r r' s s',
    step (K.squash (n,p)) p' r s r' s' ->
    estep (erase_prog p) r (List.map erase_instr s) r' (List.map erase_instr s') /\
    exists n', p' = K.squash (n',p).
  Proof.
    intros.
    inv H; unfold erase_instr; simpl in *;
      try (split; econstructor; eauto; fail).
    split.
    eapply estep_call; eauto.
    unfold prog_lookup in H1.
    rewrite K.unsquash_squash in H1.
    simpl in H1.
    unfold KnotInput.fmap in H1.
    eapply fmap_eqn2 in H1.
    destruct H1 as [i'' [? ?]].
    unfold erase_prog.
    erewrite fmap_eqn.
    2: eauto.
    f_equal.
    subst i'.
    clear.
    unfold erase_instr.
    induction i''; simpl; congruence.
    hnf in H2.
    rewrite K.knot_age1 in H2.
    rewrite K.unsquash_squash in H2.
    destruct n; try discriminate.
    inv H2.
    exists n.
    apply K.unsquash_inj.
    repeat rewrite K.unsquash_squash.
    f_equal.
    rewrite K.fmap_fmap.
    change (S n) with (1 +n).
    rewrite <- K.approx_approx1.
    auto.
  Qed.

  Lemma erase_halt' : forall n p p' r r' s,
    stepstar (K.squash (n,p)) p' r s r' nil ->
    estepstar (erase_prog p) r (List.map erase_instr s) r' nil.
  Proof.
    intros.
    remember (K.squash (n,p)) as phat.
    remember (@nil instruction) as s'.
    revert Heqphat Heqs'.
    revert n.
    induction H; intros.
    subst i.
    simpl.
    econstructor.
    subst.
    apply erase_step in H.
    destruct H.
    destruct H1.
    subst p'.
    spec IHstepstar x0.
    spec IHstepstar; auto.
    spec IHstepstar; auto.
    eapply estepstar_S; eauto.
  Qed.

  Theorem erase_halt : forall p n r s,
    eventually_halts (K.squash (n,p)) r s ->
    eventually_ehalts (erase_prog p) r (List.map erase_instr s).
  Proof.
    intros. hnf in H. hnf.
    destruct H as [p' [r' ?]].
    exists r'.
    eapply erase_halt'; eauto.
  Qed.

  Theorem total_correctness_full_erasure : forall G psi l t c r n,
    verify_prog psi G ->
    G |-- funptr l unit t (fun _ => TT) (fun _ => TT) ->
    proj1_sig t r n ->
    psi#l = Some c ->
    eventually_ehalts (erase_prog psi) r ((erase_instr c ;; instr_assert x) :: nil).
  Proof.
    intros.
    generalize (verify_halts t G psi l H H0 r n c H1 H2).
    apply erase_halt.
  Qed.

End estep.


From iris.algebra Require Import proofmode_classes.
From iris.base_logic Require Export derived.
From iris Require Import options.

Import base_logic.bi.uPred.

(* Setup of the proof mode *)
Section class_instances.
Context {M : ucmraT}.
Implicit Types P Q R : uPred M.

Global Instance into_pure_cmra_valid `{!CmraDiscrete A} (a : A) :
  @IntoPure (uPredI M) (✓ a) (✓ a).
Proof. by rewrite /IntoPure discrete_valid. Qed.

Global Instance from_pure_cmra_valid {A : cmraT} (a : A) :
  @FromPure (uPredI M) false (✓ a) (✓ a).
Proof.
  rewrite /FromPure /=. eapply bi.pure_elim=> // ?.
  rewrite -uPred.cmra_valid_intro //.
Qed.

Global Instance from_sep_ownM (a b1 b2 : M) :
  IsOp a b1 b2 →
  FromSep (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof. intros. by rewrite /FromSep -ownM_op -is_op. Qed.
Global Instance from_sep_ownM_core_id (a b1 b2 : M) :
  IsOp a b1 b2 → TCOr (CoreId b1) (CoreId b2) →
  FromAnd (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof.
  intros ? H. rewrite /FromAnd (is_op a) ownM_op.
  destruct H; by rewrite bi.persistent_and_sep.
Qed.

Global Instance into_and_ownM p (a b1 b2 : M) :
  IsOp a b1 b2 → IntoAnd p (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof.
  intros. apply bi.intuitionistically_if_mono. by rewrite (is_op a) ownM_op bi.sep_and.
Qed.

Global Instance into_sep_ownM (a b1 b2 : M) :
  IsOp a b1 b2 → IntoSep (uPred_ownM a) (uPred_ownM b1) (uPred_ownM b2).
Proof. intros. by rewrite /IntoSep (is_op a) ownM_op. Qed.
End class_instances.


(*
 * Vericert: Verified high-level synthesis.
 * Copyright (C) 2020 Yann Herklotz <yann@yannherklotz.com>
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <https://www.gnu.org/licenses/>.
 *)

(* begin hide *)
From Coq Require Import ZArith.ZArith FSets.FMapPositive Lia.
From compcert Require Import lib.Integers common.Values.
From vericert Require Import Vericertlib.
(* end hide *)

(*|
=====
Value
=====

A ``value`` is a bitvector with a specific size. We are using the implementation
of the bitvector by mit-plv/bbv, because it has many theorems that we can reuse.
However, we need to wrap it with an ``Inductive`` so that we can specify and
match on the size of the ``value``. This is necessary so that we can easily
store ``value`` of different sizes in a list or in a map.

Using the default ``word``, this would not be possible, as the size is part of
the type.
|*)

Definition value : Type := int.

(*|
Value conversions
=================

Various conversions to different number types such as ``N``, ``Z``, ``positive``
and ``int``, where the last one is a theory of integers of powers of 2 in
CompCert.
|*)

Definition valueToNat (v : value) : nat :=
  Z.to_nat (Int.unsigned v).

Definition natToValue (n : nat) : value :=
  Int.repr (Z.of_nat n).

Definition valueToN (v : value) : N :=
  Z.to_N (Int.unsigned v).

Definition NToValue (n : N) : value :=
  Int.repr (Z.of_N n).

Definition ZToValue (z : Z) : value :=
  Int.repr z.

Definition valueToZ (v : value) : Z :=
  Int.signed v.

Definition uvalueToZ (v : value) : Z :=
  Int.unsigned v.

Definition posToValue (p : positive) : value :=
  Int.repr (Z.pos p).

Definition valueToPos (v : value) : positive :=
  Z.to_pos (Int.unsigned v).

Definition intToValue (i : Integers.int) : value := i.

Definition valueToInt (i : value) : Integers.int := i.

Definition ptrToValue (i : ptrofs) : value := Ptrofs.to_int i.

Definition valueToPtr (i : value) : Integers.ptrofs :=
  Ptrofs.of_int i.

Definition valToValue (v : Values.val) : option value :=
  match v with
  | Values.Vint i => Some (intToValue i)
  | Values.Vptr b off => Some (ptrToValue off)
  | Values.Vundef => Some (ZToValue 0%Z)
  | _ => None
  end.

(*|
Convert a ``value`` to a ``bool``, so that choices can be made based on the
result. This is also because comparison operators will give back ``value``
instead of ``bool``, so if they are in a condition, they will have to be
converted before they can be used.
|*)

Definition valueToBool (v : value) : bool :=
  if Z.eqb (uvalueToZ v) 0 then false else true.

Definition boolToValue (b : bool) : value :=
  natToValue (if b then 1 else 0).

(*|
Arithmetic operations
---------------------
|*)

Inductive val_value_lessdef: val -> value -> Prop :=
| val_value_lessdef_int:
    forall i v',
    i = valueToInt v' ->
    val_value_lessdef (Vint i) v'
| val_value_lessdef_ptr:
    forall b off v',
    off = valueToPtr v' ->
    val_value_lessdef (Vptr b off) v'
| lessdef_undef: forall v, val_value_lessdef Vundef v.

Inductive opt_val_value_lessdef: option val -> value -> Prop :=
| opt_lessdef_some:
    forall v v', val_value_lessdef v v' -> opt_val_value_lessdef (Some v) v'
| opt_lessdef_none: forall v, opt_val_value_lessdef None v.

Lemma valueToZ_ZToValue :
  forall z,
  (Int.min_signed <= z <= Int.max_signed)%Z ->
  valueToZ (ZToValue z) = z.
Proof. auto using Int.signed_repr. Qed.

Lemma uvalueToZ_ZToValue :
  forall z,
  (0 <= z <= Int.max_unsigned)%Z ->
  uvalueToZ (ZToValue z) = z.
Proof. auto using Int.unsigned_repr. Qed.

Lemma valueToPos_posToValue :
  forall v,
  0 <= Z.pos v <= Int.max_unsigned ->
  valueToPos (posToValue v) = v.
Proof.
  unfold valueToPos, posToValue.
  intros. rewrite Int.unsigned_repr.
  apply Pos2Z.id. assumption.
Qed.

Lemma valueToInt_intToValue :
  forall v,
  valueToInt (intToValue v) = v.
Proof. auto. Qed.

Lemma valToValue_lessdef :
  forall v v',
    valToValue v = Some v' ->
    val_value_lessdef v v'.
Proof.
  intros.
  destruct v; try discriminate; constructor.
  unfold valToValue in H. inversion H.
  unfold valueToInt. unfold intToValue in H1. auto.
  inv H. symmetry. unfold valueToPtr, ptrToValue. apply Ptrofs.of_int_to_int. trivial.
Qed.

Ltac simplify_val := repeat (simplify; unfold uvalueToZ, valueToPtr, Ptrofs.of_int, valueToInt, intToValue,
                                       ptrToValue in *).

Ltac crush_val := simplify_val; try discriminate; try congruence; try lia; liapp; try assumption.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Postorder renumbering of RTL control-flow graphs. *)

Require Import Coqlib.
Require Import Maps.
Require Import Postorder.
Require Import AST.
Require Import RTL.

(** CompCert's dataflow analyses (module [Kildall]) are more precise
  and run faster when the sequence [1, 2, 3, ...]  is a postorder
  enumeration of the nodes of the control-flow graph.  This property
  can be guaranteed when generating the CFG (module [RTLgen]), but
  is, however, invalidated by further RTL optimization passes such as
  [Inlining].

  In this module, we renumber the nodes of RTL control-flow graphs
  to restore the postorder property given above.  In passing,
  we also eliminate CFG nodes that are not reachable from the entry point:
  these nodes are dead code. *)

Section RENUMBER.

Variable pnum: PTree.t positive.   (**r a postorder numbering *)

Definition renum_pc (pc: node) : node :=
  match pnum!pc with
  | Some pc' => pc'
  | None => 1%positive          (**r impossible case, never exercised *)
  end.

Definition renum_instr (i: instruction) : instruction :=
  match i with
  | Inop s => Inop (renum_pc s)
  | Iop op args res s => Iop op args res (renum_pc s)
  | Iload chunk addr args res s => Iload chunk addr args res (renum_pc s)
  | Istore chunk addr args src s => Istore chunk addr args src (renum_pc s)
  | Icall sg ros args res s => Icall sg ros args res (renum_pc s)
  | Itailcall sg ros args => i
  | Ibuiltin ef args res s => Ibuiltin ef args res (renum_pc s)
  | Icond cond args s1 s2 => Icond cond args (renum_pc s1) (renum_pc s2)
  | Ijumptable arg tbl => Ijumptable arg (List.map renum_pc tbl)
  | Ireturn or => i
  end.

Definition renum_node (c': code) (pc: node) (i: instruction) : code :=
  match pnum!pc with
  | None => c'
  | Some pc' => PTree.set pc' (renum_instr i) c'
  end.

Definition renum_cfg (c: code) : code :=
  PTree.fold renum_node c (PTree.empty instruction).

End RENUMBER.

Definition transf_function (f: function) : function :=
  let pnum := postorder (successors f) f.(fn_entrypoint) in
  mkfunction
    f.(fn_sig)
    f.(fn_params)
    f.(fn_stacksize)
    (renum_cfg pnum f.(fn_code))
    (renum_pc pnum f.(fn_entrypoint)).

Definition transf_fundef (fd: fundef) : fundef :=
  AST.transf_fundef transf_function fd.

Definition transf_program (p: program) : program :=
  AST.transform_program transf_fundef p.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export cequiv.

Lemma bcequiv_refl {o} :
  forall lib (b : @BTerm o),
    wf_bterm b
    -> bcequiv lib b b.
Proof.
  introv wf.
  destruct b as [l t].
  allrw @wf_bterm_iff.
  apply blift_approx_cequiv.
  - unfold approx_open_bterm, blift.
    exists l t t; dands; eauto 3 with slow.
  - unfold approx_open_bterm, blift.
    exists l t t; dands; eauto 3 with slow.
Qed.

Lemma bcequiv_nobnd {o} :
  forall lib (t u : @NTerm o),
    wf_term t
    -> wf_term u
    -> cequiv lib t u
    -> bcequiv lib (nobnd t) (nobnd u).
Proof.
  introv wft wfu ceq.
  applydup @cequiv_sym in ceq.
  apply cequiv_le_approx in ceq.
  apply cequiv_le_approx in ceq0.
  apply blift_approx_cequiv.
  - unfold approx_open_bterm, blift.
    exists ([] : list NVar) t u; dands; eauto 3 with slow.
    apply approx_implies_approx_open; auto.
  - unfold approx_open_bterm, blift.
    exists ([] : list NVar) u t; dands; eauto 3 with slow.
    apply approx_implies_approx_open; auto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/")
*** End:
*)


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 O E Eprime P A B C D A1 B1 C1 D1 C1prime M D1prime N : Universe, ((wd_ O E /\ (wd_ P B /\ (wd_ A B /\ (wd_ O M /\ (wd_ M C1 /\ (wd_ O C1 /\ (wd_ C1 C1prime /\ (wd_ O C1prime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ P A /\ (wd_ A C /\ (wd_ P C /\ (wd_ C D /\ (wd_ C1prime A1 /\ (wd_ O A1 /\ (wd_ O B1 /\ (wd_ M C1prime /\ (wd_ N O /\ (wd_ D1 N /\ (wd_ D1 D1prime /\ (wd_ N D1prime /\ (wd_ D1prime O /\ (wd_ O D1 /\ (wd_ P D /\ (wd_ A1 Eprime /\ (col_ P A B /\ (col_ P C D /\ (col_ O E A1 /\ (col_ O E B1 /\ (col_ O E C1 /\ (col_ O E D1 /\ (col_ O M N /\ (col_ C A B /\ (col_ N D1 D1prime /\ (col_ M C1 C1prime /\ (col_ O C1prime D1prime /\ (col_ O A1 C1 /\ col_ O C1 D1)))))))))))))))))))))))))))))))))))))) -> col_ P A C)).
Proof.
  time tac.
Qed.

End FOFProblem.