Require Import GL4ip_PSGL4ip_calcs.
Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import ddT.
Require Import gen_tacs.
Require Import gen_seq.
Require Import List_lemmasT.
Require Import existsT.
Require Import univ_gen_ext.
Require Import GL4ip_PSGL4ip_list_lems.
Require Import dd_fc.
Require Import PeanoNat.
Require Import strong_inductionT.
Require Import GL4ip_exch.
Require Import GL4ip_wkn.
Require Import GL4ip_PSGL4ip_remove_list.
Require Import GL4ip_PSGL4ip_dec.
Require Import Lia.

Theorem ImpR_hpinv : forall (k : nat) concl
        (D0 : derrec GL4ip_rules (fun _ => False) concl),
        k = (derrec_height D0) ->
          ((forall prem, ((ImpRRule [prem] concl) ->
          existsT2 (D1 : derrec GL4ip_rules (fun _ => False) prem),
          derrec_height D1 <= k))).
Proof.
assert (DersNilF: dersrec GL4ip_rules (fun _ : Seq  => False) []).
apply dersrec_nil.
(* Setting up the strong induction on the height. *)
pose (strong_inductionT (fun (x:nat) => forall (concl : Seq)
  (D0 : derrec GL4ip_rules (fun _ : Seq => False) concl),
x = derrec_height D0 ->
((forall prem, ((ImpRRule [prem] concl) ->
          existsT2 (D1 : derrec GL4ip_rules (fun _ => False) prem),
          derrec_height D1 <= x))))).
apply s. intros n IH. clear s.
(* Now we do the actual proof-theoretical work. *)
intros s D0. remember D0 as D0'. destruct D0.
(* D0 is a leaf *)
- destruct f.
(* D0 is ends with an application of rule *)
- intros hei. intros prem RA. inversion RA. subst.
  inversion g ; subst.
  (* IdP *)
  * inversion H.
  (* BotL *)
  * inversion H. subst. assert (InT (⊥) (Γ0 ++ A :: Γ1)). assert (InT (⊥) (Γ0 ++ Γ1)).
    rewrite <- H2. apply InT_or_app. right. apply InT_eq.
    apply InT_app_or in H0. destruct H0. apply InT_or_app. auto. apply InT_or_app. right.
    apply InT_cons. auto. apply InT_split in H0. destruct H0. destruct s. rewrite e.
    assert (BotLRule [] (x ++ ⊥ :: x0, B)). apply BotLRule_I. apply BotL in H0.
    pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
    (ps:=[]) (x ++ ⊥ :: x0, B) H0 DersNilF). exists d0.
    simpl. rewrite dersrec_height_nil. lia. reflexivity.
   (* AndR *)
  * inversion H.
  (* AndL *)
  * inversion H. subst. apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
   + simpl. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
      assert (AndLRule  [((Γ2 ++ [A]) ++ A0 :: B0 :: Γ3, B)]
      ((Γ2 ++ [A]) ++ And A0 B0 :: Γ3, B)). apply AndLRule_I. apply AndL in H0.
      assert (J4: ImpRRule [(Γ2 ++ A :: A0 :: B0 :: Γ3, B)]
      (Γ2 ++ A0 :: B0 :: Γ3, Imp A B)). apply ImpRRule_I.
      repeat rewrite <- app_assoc in H0. simpl in H0.
      assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
      assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
      pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
      pose (dlCons x1 DersNilF).
      pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ2 ++ A :: A0 :: B0 :: Γ3, B)])
      (Γ2 ++ A :: And A0 B0 :: Γ3, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
      lia. reflexivity.
   + destruct x.
      { simpl in e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
        assert (AndLRule  [(Γ2 ++ A :: A0 :: B0 :: Γ3, B)]
        ((Γ2 ++ []) ++ A :: And A0 B0 :: Γ3, B)).
        assert (Γ2 ++ A :: A0 :: B0 :: Γ3 = (Γ2 ++ [A]) ++ A0 :: B0 :: Γ3). repeat rewrite <- app_assoc ; auto.
        assert ((Γ2 ++ []) ++ A :: And A0 B0 :: Γ3 = (Γ2 ++ [A]) ++ And A0 B0 :: Γ3). repeat rewrite <- app_assoc ; auto.
        rewrite H0. clear H0. rewrite H1. clear H1. apply AndLRule_I. apply AndL in H0.
        assert (J4: ImpRRule [(Γ2 ++ A :: A0 :: B0 :: Γ3, B)]
        (Γ2 ++ A0 :: B0 :: Γ3, Imp A B)). apply ImpRRule_I.
        assert (J5: derrec_height x < S (dersrec_height d)). lia.
        assert (J6: derrec_height x = derrec_height x). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
        pose (dlCons x0 DersNilF).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ2 ++ A :: A0 :: B0 :: Γ3, B)])
       ((Γ2 ++ []) ++ A :: And A0 B0 :: Γ3, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
      { inversion e0.  subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
         pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
         assert (AndLRule  [(Γ2 ++ A0 :: B0 :: x ++ A :: Γ1, B)]
       ((Γ2 ++ And A0 B0 :: x) ++ A :: Γ1, B)). repeat rewrite <- app_assoc. apply AndLRule_I. apply AndL in H0.
        assert (J4: ImpRRule [((Γ2 ++ A0 :: B0 :: x) ++ A :: Γ1, B)]
        ((Γ2 ++ A0 :: B0 :: x) ++ Γ1, Imp A B)). apply ImpRRule_I. repeat rewrite <- app_assoc in J4. simpl in J4.
        assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
        assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
        pose (dlCons x1 DersNilF).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ2 ++ A0 :: B0 :: x ++ A :: Γ1, B)])
        ((Γ2 ++ And A0 B0 :: x) ++ A :: Γ1, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
    + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
       pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
       assert (AndLRule  [((Γ0 ++ A :: x) ++ A0 :: B0 :: Γ3, B)]
      ((Γ0 ++ A :: x) ++ And A0 B0 :: Γ3, B)). apply AndLRule_I. apply AndL in H0. repeat rewrite <- app_assoc in H0.
      simpl in H0.
      assert (J4: ImpRRule [(Γ0 ++ A :: x ++ A0 :: B0 :: Γ3, B)]
      ((Γ0 ++ x) ++ A0 :: B0 :: Γ3, Imp A B)). repeat rewrite <- app_assoc. apply ImpRRule_I.
      assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
      assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
      pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
      pose (dlCons x1 DersNilF).
      pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ0 ++ A :: x ++ A0 :: B0 :: Γ3, B)])
      (Γ0 ++ A :: x ++ And A0 B0 :: Γ3, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
      lia. reflexivity.
  (* OrR1 *)
  * inversion H.
  (* OrR2 *)
  * inversion H.
  (* OrL *)
  * inversion H. subst. apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
   + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
      repeat rewrite <- app_assoc. simpl.
      assert (OrLRule [((Γ2 ++ [A]) ++ A0:: Γ3, B);((Γ2 ++ [A]) ++ B0 :: Γ3, B)]
      ((Γ2 ++ [A]) ++ Or A0 B0 :: Γ3, B)). apply OrLRule_I. apply OrL in H0.
      repeat rewrite <- app_assoc in H0. simpl in H0.
      assert (J4: ImpRRule [(Γ2 ++ A :: A0 :: Γ3, B)]
      (Γ2 ++ A0 :: Γ3, Imp A B)). apply ImpRRule_I.
      assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
      assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
      pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
      assert (J7: ImpRRule [(Γ2 ++ A :: B0 :: Γ3, B)]
      (Γ2 ++ B0 :: Γ3, Imp A B)). apply ImpRRule_I.
      assert (J8: derrec_height x1 < S (dersrec_height d)). lia.
      assert (J9: derrec_height x1 = derrec_height x1). reflexivity.
      pose (IH _ J8 _ _ J9). pose (s _ J7). destruct s0. clear s.
      pose (dlCons x3 DersNilF). pose (dlCons x2 d0).
      pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ2 ++ A :: A0 :: Γ3, B); (Γ2 ++ A :: B0 :: Γ3, B)])
      (Γ2 ++ A :: Or A0 B0 :: Γ3, B) H0 d1). exists d2. simpl. rewrite dersrec_height_nil.
      lia. reflexivity.
   + destruct x.
      { simpl in e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
        repeat rewrite <- app_assoc. simpl.
        assert (OrLRule [((Γ2 ++ [A]) ++ A0:: Γ3, B);((Γ2 ++ [A]) ++ B0 :: Γ3, B)]
        ((Γ2 ++ [A]) ++ Or A0 B0 :: Γ3, B)). apply OrLRule_I. apply OrL in H0.
        repeat rewrite <- app_assoc in H0. simpl in H0.
        assert (J4: ImpRRule [(Γ2 ++ A :: A0 :: Γ3, B)]
        (Γ2 ++ A0 :: Γ3, Imp A B)). apply ImpRRule_I.
        assert (J5: derrec_height x < S (dersrec_height d)). lia.
        assert (J6: derrec_height x = derrec_height x). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
        assert (J7: ImpRRule [(Γ2 ++ A :: B0 :: Γ3, B)]
        (Γ2 ++ B0 :: Γ3, Imp A B)). apply ImpRRule_I.
        assert (J8: derrec_height x0 < S (dersrec_height d)). lia.
        assert (J9: derrec_height x0 = derrec_height x0). reflexivity.
        pose (IH _ J8 _ _ J9). pose (s _ J7). destruct s0. clear s.
        pose (dlCons x2 DersNilF). pose (dlCons x1 d0).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ2 ++ A :: A0 :: Γ3, B); (Γ2 ++ A :: B0 :: Γ3, B)])
        (Γ2 ++ A :: Or A0 B0 :: Γ3, B) H0 d1). exists d2. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
      { inversion e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
        repeat rewrite <- app_assoc. simpl.
        assert (OrLRule [(Γ2 ++ A0 :: x ++ A :: Γ1, B);(Γ2 ++ B0 :: x ++ A :: Γ1, B)]
        (Γ2 ++ Or A0 B0 :: x ++ A :: Γ1, B)). apply OrLRule_I. apply OrL in H0.
        assert (J4: ImpRRule [((Γ2 ++ A0 :: x) ++ A :: Γ1, B)]
        ((Γ2 ++ A0 :: x) ++ Γ1, Imp A B)). apply ImpRRule_I.
        repeat rewrite <- app_assoc in J4. simpl in J4.
        assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
        assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
        assert (J7: ImpRRule [((Γ2 ++ B0 :: x) ++ A :: Γ1, B)]
        ((Γ2 ++ B0 :: x) ++ Γ1, Imp A B)). apply ImpRRule_I.
        repeat rewrite <- app_assoc in J7. simpl in J7.
        assert (J8: derrec_height x1 < S (dersrec_height d)). lia.
        assert (J9: derrec_height x1 = derrec_height x1). reflexivity.
        pose (IH _ J8 _ _ J9). pose (s _ J7). destruct s0. clear s.
        pose (dlCons x3 DersNilF). pose (dlCons x2 d0).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ2 ++ A0 :: x ++ A :: Γ1, B); (Γ2 ++ B0 :: x ++ A :: Γ1, B)])
        (Γ2 ++ Or A0 B0 :: x ++ A :: Γ1, B) H0 d1). exists d2. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
    +  assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
        assert (OrLRule [((Γ0 ++ A :: x) ++ A0 :: Γ3, B);((Γ0 ++ A :: x) ++ B0 :: Γ3, B)]
        ((Γ0 ++ A :: x) ++ Or A0 B0 :: Γ3, B)). apply OrLRule_I. apply OrL in H0.
        repeat rewrite <- app_assoc in H0. simpl in H0.
        assert (J4: ImpRRule [(Γ0 ++ A :: x ++ A0 :: Γ3, B)]
        ((Γ0 ++ x) ++ A0 :: Γ3, Imp A B)). repeat rewrite <- app_assoc. apply ImpRRule_I.
        assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
        assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
        assert (J7: ImpRRule [(Γ0 ++ A :: x ++ B0 :: Γ3, B)]
        ((Γ0 ++ x) ++ B0 :: Γ3, Imp A B)). repeat rewrite <- app_assoc. apply ImpRRule_I.
        assert (J8: derrec_height x1 < S (dersrec_height d)). lia.
        assert (J9: derrec_height x1 = derrec_height x1). reflexivity.
        pose (IH _ J8 _ _ J9). pose (s _ J7). destruct s0. clear s.
        pose (dlCons x3 DersNilF). pose (dlCons x2 d0).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ0 ++ A :: x ++ A0 :: Γ3, B); (Γ0 ++ A :: x ++ B0 :: Γ3, B)])
        (Γ0 ++ A :: x ++ Or A0 B0 :: Γ3, B) H0 d1). exists d2. simpl. rewrite dersrec_height_nil.
        lia. reflexivity.
  (* ImpR *)
  * inversion H. subst. simpl. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
    assert (J1: derrec_height x = derrec_height x). auto.
    assert (J2: list_exch_L (Γ2 ++ A :: Γ3, B) (A :: Γ0 ++ Γ1, B)).
    rewrite <- H2. assert (A :: Γ2 ++ Γ3 = [] ++ [A] ++ Γ2 ++ [] ++ Γ3). auto. rewrite H0.
    assert (Γ2 ++ A :: Γ3 = [] ++ [] ++ Γ2 ++ [A] ++ Γ3). auto. rewrite H1. apply list_exch_LI.
    pose (GL4ip_hpadm_list_exch_L (derrec_height x) (Γ2 ++ A :: Γ3, B) x J1 (A :: Γ0 ++ Γ1, B) J2).
    destruct s.
    assert (J3: derrec_height x0 = derrec_height x0). auto.
    assert (J4: list_exch_L (A :: Γ0 ++ Γ1, B) (Γ0 ++ A :: Γ1, B)).
    assert (A :: Γ0 ++ Γ1 = [] ++ [A] ++ Γ0 ++ [] ++ Γ1). auto. rewrite H0.
    assert (Γ0 ++ A :: Γ1 = [] ++ [] ++ Γ0 ++ [A] ++ Γ1). auto. rewrite H1. apply list_exch_LI.
    pose (GL4ip_hpadm_list_exch_L (derrec_height x0) (A :: Γ0 ++ Γ1, B) x0 J3 (Γ0 ++ A :: Γ1, B) J4).
    destruct s. exists x1. lia.
  (* AtomImpL1 *)
  * inversion H. subst. apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
 + simpl. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
      assert (AtomImpL1Rule  [((Γ2 ++ [A]) ++ # P :: Γ3 ++ A0 :: Γ4, B)]
      ((Γ2 ++ [A]) ++ # P :: Γ3 ++ Imp # P A0 :: Γ4, B)). apply AtomImpL1Rule_I. apply AtomImpL1 in H0.
      repeat rewrite <- app_assoc in H0. simpl in H0.
      assert (J4: ImpRRule [(Γ2 ++ A :: # P :: Γ3 ++ A0 :: Γ4, B)]
      (Γ2 ++ # P :: Γ3 ++ A0 :: Γ4, Imp A B)). apply ImpRRule_I.
      assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
      assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
      pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
      pose (dlCons x1 DersNilF).
      pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ2 ++ A :: # P :: Γ3 ++ A0 :: Γ4, B)])
      (Γ2 ++ A :: # P :: Γ3 ++ Imp # P A0 :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
      lia. reflexivity.
   + destruct x.
      { simpl in e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
        assert (AtomImpL1Rule  [(Γ2 ++ A :: # P :: Γ3 ++ A0 :: Γ4, B)]
        ((Γ2 ++ []) ++ A :: # P :: Γ3 ++ Imp # P A0 :: Γ4, B)).
        assert (Γ2 ++ A ::# P :: Γ3 ++ A0 :: Γ4 = (Γ2 ++ [A]) ++ # P :: Γ3 ++ A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
        assert ((Γ2 ++ []) ++ A :: # P :: Γ3 ++ Imp # P A0 :: Γ4 = (Γ2 ++ [A]) ++ # P :: Γ3 ++ Imp # P A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
        rewrite H0. clear H0. rewrite H1. clear H1. apply AtomImpL1Rule_I. apply AtomImpL1 in H0.
        assert (J4: ImpRRule [(Γ2 ++ A :: # P :: Γ3 ++ A0 :: Γ4, B)]
        (Γ2 ++ # P :: Γ3 ++ A0 :: Γ4, Imp A B)). apply ImpRRule_I.
        assert (J5: derrec_height x < S (dersrec_height d)). lia.
        assert (J6: derrec_height x = derrec_height x). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
        pose (dlCons x0 DersNilF).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ2 ++ A :: # P :: Γ3 ++ A0 :: Γ4, B)])
        ((Γ2 ++ []) ++ A :: # P :: Γ3 ++ Imp # P A0 :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
      { inversion e0.  subst. apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
        - assert (J30: dersrec_height d = dersrec_height d). reflexivity.
          pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
          assert (AtomImpL1Rule  [(Γ2 ++ # P :: (Γ3 ++ [A]) ++ A0 :: Γ4, B)]
          ((Γ2 ++ # P :: Γ3) ++ A :: Imp # P A0 :: Γ4, B)).
          assert ((Γ2 ++ # P :: Γ3) ++ A :: Imp # P A0 :: Γ4 =Γ2 ++ # P :: (Γ3 ++ [A]) ++ Imp # P A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
          rewrite H0. clear H0. apply AtomImpL1Rule_I. apply AtomImpL1 in H0.
          assert (J4: ImpRRule [(Γ2 ++ # P :: (Γ3 ++ [A]) ++ A0 :: Γ4, B)]
          (Γ2 ++ # P :: Γ3 ++ A0 :: Γ4, Imp A B)).
          assert (Γ2 ++ # P :: (Γ3 ++ [A]) ++ A0 :: Γ4 = (Γ2 ++ # P :: Γ3) ++ A :: A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
          assert (Γ2 ++ # P :: Γ3 ++ A0 :: Γ4 = (Γ2 ++ # P :: Γ3) ++ A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
          rewrite H1. rewrite H2. apply ImpRRule_I.
          assert (J5: derrec_height x < S (dersrec_height d)). lia.
          assert (J6: derrec_height x = derrec_height x). reflexivity.
          pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
          pose (dlCons x1 DersNilF).
          pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
          (ps:=[(Γ2 ++ # P :: (Γ3 ++ [A]) ++ A0 :: Γ4, B)])
          ((Γ2 ++ # P :: Γ3) ++ A :: Imp # P A0 :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
          lia. reflexivity.
        - destruct x0 ; simpl in e1 ; subst.
          * assert (J30: dersrec_height d = dersrec_height d). reflexivity.
            pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
            assert (AtomImpL1Rule  [(Γ2 ++ # P :: (Γ3 ++ [A]) ++ A0 :: Γ4, B)]
            ((Γ2 ++ # P :: Γ3 ++ []) ++ A :: Imp # P A0 :: Γ4, B)).
            assert ((Γ2 ++ # P :: Γ3 ++ []) ++ A :: Imp # P A0 :: Γ4 =Γ2 ++ # P :: (Γ3 ++ [A]) ++ Imp # P A0 :: Γ4).
            repeat rewrite <- app_assoc ; simpl ; repeat rewrite <- app_assoc ; auto.
            rewrite H0. clear H0. apply AtomImpL1Rule_I. apply AtomImpL1 in H0.
            assert (J4: ImpRRule [(Γ2 ++ # P :: (Γ3 ++ [A]) ++ A0 :: Γ4, B)]
            (Γ2 ++ # P :: Γ3 ++ A0 :: Γ4, Imp A B)).
            assert (Γ2 ++ # P :: (Γ3 ++ [A]) ++ A0 :: Γ4 = (Γ2 ++ # P :: Γ3) ++ A :: A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
            assert (Γ2 ++ # P :: Γ3 ++ A0 :: Γ4 = (Γ2 ++ # P :: Γ3) ++ A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
            rewrite H1. rewrite H2. apply ImpRRule_I.
            assert (J5: derrec_height x < S (dersrec_height d)). lia.
            assert (J6: derrec_height x = derrec_height x). reflexivity.
            pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
            pose (dlCons x0 DersNilF).
            pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
            (ps:=[(Γ2 ++ # P :: (Γ3 ++ [A]) ++ A0 :: Γ4, B)])
            ((Γ2 ++ # P :: Γ3 ++ []) ++ A :: Imp # P A0 :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
            lia. reflexivity.
          * inversion e1. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
            pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
            assert (AtomImpL1Rule  [((Γ2 ++ # P :: Γ3 ++ A0 :: x0) ++ A :: Γ1, B)]
            ((Γ2 ++ # P :: Γ3 ++ Imp # P A0 :: x0) ++ A :: Γ1, B)). repeat rewrite <- app_assoc. simpl.
            repeat rewrite <- app_assoc. apply AtomImpL1Rule_I. apply AtomImpL1 in H0.
            assert (J4: ImpRRule [((Γ2 ++ # P :: Γ3 ++ A0 :: x0) ++ A :: Γ1, B)]
            ((Γ2 ++ # P :: Γ3 ++ A0 :: x0) ++ Γ1, Imp A B)). apply ImpRRule_I.
            repeat rewrite <- app_assoc in J4. simpl in J4. repeat rewrite <- app_assoc in J4. simpl in J4.
            assert (J5: derrec_height x < S (dersrec_height d)). lia.
            assert (J6: derrec_height x = derrec_height x). reflexivity.
            pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
            pose (dlCons x1 DersNilF). rewrite <- app_assoc in H0. simpl in H0. rewrite <- app_assoc in H0.
            pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
            (ps:=[(Γ2 ++ # P :: Γ3 ++ A0 :: x0 ++ A :: Γ1, B)])
            ((Γ2 ++ # P :: Γ3 ++ Imp # P A0 :: x0) ++ A :: Γ1, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
            lia. reflexivity.
        - assert (J30: dersrec_height d = dersrec_height d). reflexivity.
          pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
          assert (AtomImpL1Rule  [(Γ2 ++ # P :: (x ++ A :: x0) ++ A0 :: Γ4, B)]
          ((Γ2 ++ # P :: x) ++ A :: x0 ++ Imp # P A0 :: Γ4, B)).
          assert ((Γ2 ++ # P :: x) ++ A :: x0 ++ Imp # P A0 :: Γ4 = Γ2 ++ # P :: (x ++ A :: x0) ++ Imp # P A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
          rewrite H0. clear H0. apply AtomImpL1Rule_I. apply AtomImpL1 in H0.
          assert (J4: ImpRRule [(Γ2 ++ # P :: (x ++ A :: x0) ++ A0 :: Γ4, B)]
          (Γ2 ++ # P :: (x ++ x0) ++ A0 :: Γ4, Imp A B)).
          assert (Γ2 ++ # P :: (x ++ x0) ++ A0 :: Γ4 = (Γ2 ++ # P :: x) ++ x0 ++ A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
          assert (Γ2 ++ # P :: (x ++ A :: x0) ++ A0 :: Γ4 = (Γ2 ++ # P :: x) ++ A :: x0 ++ A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
          rewrite H1. rewrite H2. apply ImpRRule_I.
          assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
          assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
          pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
          pose (dlCons x2 DersNilF).
          pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
          (ps:=[(Γ2 ++ # P :: (x ++ A :: x0) ++ A0 :: Γ4, B)])
          ((Γ2 ++ # P :: x) ++ A :: x0 ++ Imp # P A0 :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
          lia. reflexivity. }
    + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
       pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
       assert (AtomImpL1Rule  [(Γ0 ++ A :: x ++ # P :: Γ3 ++ A0 :: Γ4, B)]
       (Γ0 ++ A :: x ++ # P :: Γ3 ++ Imp # P A0 :: Γ4, B)).
       assert (Γ0 ++ A :: x ++ # P :: Γ3 ++ Imp # P A0 :: Γ4 = (Γ0 ++ A :: x) ++ # P :: Γ3 ++ Imp # P A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
       assert (Γ0 ++ A :: x ++ # P :: Γ3 ++ A0 :: Γ4 = (Γ0 ++ A :: x) ++ # P :: Γ3 ++ A0 :: Γ4). repeat rewrite <- app_assoc ; auto.
       rewrite H0. rewrite H1. apply AtomImpL1Rule_I. apply AtomImpL1 in H0.
       assert (J4: ImpRRule [(Γ0 ++ A :: x ++ # P :: Γ3 ++ A0 :: Γ4, B)]
       ((Γ0 ++ x) ++ # P :: Γ3 ++ A0 :: Γ4, Imp A B)). repeat rewrite <- app_assoc. apply ImpRRule_I.
       assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
       assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
       pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
       pose (dlCons x1 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:= [(Γ0 ++ A :: x ++ # P :: Γ3 ++ A0 :: Γ4, B)])
       (Γ0 ++ A :: x ++ # P :: Γ3 ++ Imp # P A0 :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
       lia. reflexivity.
  (* AtomImpL2 *)
  * inversion H. subst. apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
 + simpl. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
      assert (AtomImpL2Rule  [((Γ2 ++ [A]) ++ A0 :: Γ3 ++ # P :: Γ4, B)]
      ((Γ2 ++ [A]) ++ Imp # P A0 :: Γ3 ++ # P :: Γ4, B)). apply AtomImpL2Rule_I. apply AtomImpL2 in H0.
      repeat rewrite <- app_assoc in H0. simpl in H0.
      assert (J4: ImpRRule [(Γ2 ++ A :: A0 :: Γ3 ++ # P :: Γ4, B)]
      (Γ2 ++ A0 :: Γ3 ++ # P :: Γ4, Imp A B)). apply ImpRRule_I.
      assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
      assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
      pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
      pose (dlCons x1 DersNilF).
      pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ2 ++ A ::A0 :: Γ3 ++  # P :: Γ4, B)])
      (Γ2 ++ A :: Imp # P A0 :: Γ3 ++ # P :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
      lia. reflexivity.
   + destruct x.
      { simpl in e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
        assert (AtomImpL2Rule  [(Γ2 ++ A ::A0  :: Γ3 ++ # P :: Γ4, B)]
        ((Γ2 ++ []) ++ A ::  Imp # P A0 :: Γ3 ++# P :: Γ4, B)).
        assert (Γ2 ++ A :: A0 :: Γ3 ++ # P :: Γ4 = (Γ2 ++ [A]) ++ A0 :: Γ3 ++ # P :: Γ4). repeat rewrite <- app_assoc ; auto.
        assert ((Γ2 ++ []) ++ A :: Imp # P A0 :: Γ3 ++ # P :: Γ4 = (Γ2 ++ [A]) ++ Imp # P A0 :: Γ3 ++ # P :: Γ4). repeat rewrite <- app_assoc ; auto.
        rewrite H0. clear H0. rewrite H1. clear H1. apply AtomImpL2Rule_I. apply AtomImpL2 in H0.
        assert (J4: ImpRRule [(Γ2 ++ A :: A0 :: Γ3 ++ # P :: Γ4, B)]
        (Γ2 ++ A0  :: Γ3 ++ # P :: Γ4, Imp A B)). apply ImpRRule_I.
        assert (J5: derrec_height x < S (dersrec_height d)). lia.
        assert (J6: derrec_height x = derrec_height x). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
        pose (dlCons x0 DersNilF).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ2 ++ A :: A0 :: Γ3 ++ # P :: Γ4, B)])
        ((Γ2 ++ []) ++ A ::Imp # P A0  :: Γ3 ++ # P :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
      { inversion e0.  subst. apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
        - assert (J30: dersrec_height d = dersrec_height d). reflexivity.
          pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
          assert (AtomImpL2Rule  [(Γ2 ++ A0 :: (Γ3 ++ [A]) ++ # P :: Γ4, B)]
          ((Γ2 ++ Imp # P A0 :: Γ3) ++ A ::# P  :: Γ4, B)).
          assert ((Γ2 ++ Imp # P A0 :: Γ3) ++ A :: # P :: Γ4 =Γ2 ++ Imp # P A0 :: (Γ3 ++ [A]) ++ # P :: Γ4). repeat rewrite <- app_assoc ; auto.
          rewrite H0. clear H0. apply AtomImpL2Rule_I. apply AtomImpL2 in H0.
          assert (J4: ImpRRule [(Γ2 ++ A0 :: (Γ3 ++ [A]) ++ # P :: Γ4, B)]
          (Γ2 ++A0 :: Γ3 ++ # P :: Γ4, Imp A B)).
          assert (Γ2 ++A0  :: (Γ3 ++ [A]) ++ # P :: Γ4 = (Γ2 ++ A0 :: Γ3) ++ A :: # P :: Γ4). repeat rewrite <- app_assoc ; auto.
          assert (Γ2 ++A0  :: Γ3 ++ # P :: Γ4 = (Γ2 ++ A0:: Γ3) ++ # P  :: Γ4). repeat rewrite <- app_assoc ; auto.
          rewrite H1. rewrite H2. apply ImpRRule_I.
          assert (J5: derrec_height x < S (dersrec_height d)). lia.
          assert (J6: derrec_height x = derrec_height x). reflexivity.
          pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
          pose (dlCons x1 DersNilF).
          pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
          (ps:=[(Γ2 ++ A0 :: (Γ3 ++ [A]) ++ # P :: Γ4, B)])
          ((Γ2 ++ Imp # P A0 :: Γ3) ++ A :: # P :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
          lia. reflexivity.
        - destruct x0 ; simpl in e1 ; subst.
          * assert (J30: dersrec_height d = dersrec_height d). reflexivity.
            pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
            assert (AtomImpL2Rule  [(Γ2 ++ A0 :: (Γ3 ++ [A]) ++ # P :: Γ4, B)]
            ((Γ2 ++ Imp # P A0 :: Γ3 ++ []) ++ A :: # P :: Γ4, B)).
            assert ((Γ2 ++ Imp # P A0 :: Γ3 ++ []) ++ A :: # P :: Γ4 =Γ2 ++ Imp # P A0 :: (Γ3 ++ [A]) ++ # P :: Γ4).
            repeat rewrite <- app_assoc ; simpl ; repeat rewrite <- app_assoc ; auto.
            rewrite H0. clear H0. apply AtomImpL2Rule_I. apply AtomImpL2 in H0.
            assert (J4: ImpRRule [(Γ2 ++A0  :: (Γ3 ++ [A]) ++ # P :: Γ4, B)]
            (Γ2 ++ A0 :: Γ3 ++ # P :: Γ4, Imp A B)).
            assert (Γ2 ++ A0 :: (Γ3 ++ [A]) ++ # P :: Γ4 = (Γ2 ++ A0 :: Γ3) ++ A :: # P :: Γ4). repeat rewrite <- app_assoc ; auto.
            assert (Γ2 ++ A0 :: Γ3 ++ # P :: Γ4 = (Γ2 ++ A0 :: Γ3) ++ # P :: Γ4). repeat rewrite <- app_assoc ; auto.
            rewrite H1. rewrite H2. apply ImpRRule_I.
            assert (J5: derrec_height x < S (dersrec_height d)). lia.
            assert (J6: derrec_height x = derrec_height x). reflexivity.
            pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
            pose (dlCons x0 DersNilF).
            pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
            (ps:=[(Γ2 ++ A0 :: (Γ3 ++ [A]) ++ # P :: Γ4, B)])
            ((Γ2 ++ Imp # P A0 :: Γ3 ++ []) ++ A :: # P :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
            lia. reflexivity.
          * inversion e1. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
            pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
            assert (AtomImpL2Rule  [((Γ2 ++ A0 :: Γ3 ++ # P :: x0) ++ A :: Γ1, B)]
            ((Γ2 ++ Imp # P A0 :: Γ3 ++ # P :: x0) ++ A :: Γ1, B)). repeat rewrite <- app_assoc. simpl.
            repeat rewrite <- app_assoc. apply AtomImpL2Rule_I. apply AtomImpL2 in H0.
            assert (J4: ImpRRule [((Γ2 ++  A0 :: Γ3 ++ # P :: x0) ++ A :: Γ1, B)]
            ((Γ2 ++ A0 :: Γ3 ++ # P :: x0) ++ Γ1, Imp A B)). apply ImpRRule_I.
            repeat rewrite <- app_assoc in J4. simpl in J4. repeat rewrite <- app_assoc in J4. simpl in J4.
            assert (J5: derrec_height x < S (dersrec_height d)). lia.
            assert (J6: derrec_height x = derrec_height x). reflexivity.
            pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
            pose (dlCons x1 DersNilF). rewrite <- app_assoc in H0. simpl in H0. rewrite <- app_assoc in H0.
            pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
            (ps:=[(Γ2 ++ A0 :: Γ3 ++ # P :: x0 ++ A :: Γ1, B)])
            ((Γ2 ++ Imp # P A0 :: Γ3 ++ # P :: x0) ++ A :: Γ1, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
            lia. reflexivity.
        - assert (J30: dersrec_height d = dersrec_height d). reflexivity.
          pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
          assert (AtomImpL2Rule  [(Γ2 ++ A0 :: (x ++ A :: x0) ++ # P :: Γ4, B)]
          ((Γ2 ++ Imp # P A0 :: x) ++ A :: x0 ++ # P :: Γ4, B)).
          assert ((Γ2 ++ Imp # P A0 :: x) ++ A :: x0 ++ # P :: Γ4 = Γ2 ++ Imp # P A0 :: (x ++ A :: x0) ++ # P :: Γ4). repeat rewrite <- app_assoc ; auto.
          rewrite H0. clear H0. apply AtomImpL2Rule_I. apply AtomImpL2 in H0.
          assert (J4: ImpRRule [(Γ2 ++A0  :: (x ++ A :: x0) ++ # P :: Γ4, B)]
          (Γ2 ++ A0 :: (x ++ x0) ++ # P :: Γ4, Imp A B)).
          assert (Γ2 ++  A0:: (x ++ x0) ++ # P :: Γ4 = (Γ2 ++A0  :: x) ++ x0 ++ # P :: Γ4). repeat rewrite <- app_assoc ; auto.
          assert (Γ2 ++ A0 :: (x ++ A :: x0) ++ # P :: Γ4 = (Γ2 ++ A0 :: x) ++ A :: x0 ++ # P :: Γ4). repeat rewrite <- app_assoc ; auto.
          rewrite H1. rewrite H2. apply ImpRRule_I.
          assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
          assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
          pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
          pose (dlCons x2 DersNilF).
          pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
          (ps:=[(Γ2 ++A0  :: (x ++ A :: x0) ++ # P :: Γ4, B)])
          ((Γ2 ++  Imp # P A0 :: x) ++ A :: x0 ++ # P :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
          lia. reflexivity. }
    + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
       pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
       assert (AtomImpL2Rule  [(Γ0 ++ A :: x ++ A0 :: Γ3 ++ # P :: Γ4, B)]
       (Γ0 ++ A :: x ++ Imp # P A0 :: Γ3 ++ # P :: Γ4, B)).
       assert (Γ0 ++ A :: x ++ Imp # P A0 :: Γ3 ++ # P :: Γ4 = (Γ0 ++ A :: x) ++ Imp # P A0 :: Γ3 ++ # P :: Γ4). repeat rewrite <- app_assoc ; auto.
       assert (Γ0 ++ A :: x ++ A0 :: Γ3 ++ # P :: Γ4 = (Γ0 ++ A :: x) ++ A0 :: Γ3 ++ # P :: Γ4). repeat rewrite <- app_assoc ; auto.
       rewrite H0. rewrite H1. apply AtomImpL2Rule_I. apply AtomImpL2 in H0.
       assert (J4: ImpRRule [(Γ0 ++ A :: x ++ A0  :: Γ3 ++ # P:: Γ4, B)]
       ((Γ0 ++ x) ++ A0 :: Γ3 ++ # P :: Γ4, Imp A B)). repeat rewrite <- app_assoc. apply ImpRRule_I.
       assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
       assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
       pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
       pose (dlCons x1 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:= [(Γ0 ++ A :: x ++ A0 :: Γ3 ++ # P :: Γ4, B)])
       (Γ0 ++ A :: x ++Imp # P A0 :: Γ3 ++ # P :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
       lia. reflexivity.
 (* AndImpL *)
  * inversion H. subst. apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
   + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
       pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
       assert (AndImpLRule  [((Γ2 ++ [A]) ++ Imp A0 (Imp B0 C) :: Γ3, B)]
       ((Γ2 ++ [A]) ++ Imp (And A0 B0) C :: Γ3, B)). apply AndImpLRule_I. apply AndImpL in H0.
       repeat rewrite <- app_assoc in H0. simpl in H0.
       assert (J4: ImpRRule [(Γ2 ++ A :: Imp A0 (Imp B0 C) :: Γ3, B)]
       (Γ2 ++ Imp A0 (Imp B0 C) :: Γ3, Imp A B)). apply ImpRRule_I.
       assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
       assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
       pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
       pose (dlCons x1 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[(Γ2 ++ A :: Imp A0 (Imp B0 C) :: Γ3, B)])
       (Γ2 ++ A :: Imp (And A0 B0) C :: Γ3, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
       lia. reflexivity.
   + destruct x.
      { simpl in e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
         pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
         assert (AndImpLRule  [((Γ2 ++ [A]) ++ Imp A0 (Imp B0 C) :: Γ3, B)]
         ((Γ2 ++ []) ++ A :: Imp (And A0 B0) C :: Γ3, B)).
         assert ((Γ2 ++ []) ++ A :: Imp (And A0 B0) C :: Γ3 = (Γ2 ++ [A]) ++ Imp (And A0 B0) C :: Γ3).
         repeat rewrite <- app_assoc. reflexivity. rewrite H0. apply AndImpLRule_I. apply AndImpL in H0.
         assert (J4: ImpRRule [((Γ2 ++ [A]) ++ Imp A0 (Imp B0 C) :: Γ3, B)]
        (Γ2 ++ Imp A0 (Imp B0 C) :: Γ3, Imp A B)). repeat rewrite <- app_assoc. apply ImpRRule_I.
         assert (J5: derrec_height x < S (dersrec_height d)). lia.
         assert (J6: derrec_height x = derrec_height x). reflexivity.
         pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
         pose (dlCons x0 DersNilF).
         pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
         (ps:=[((Γ2 ++ [A]) ++ Imp A0 (Imp B0 C) :: Γ3, B)])
         ((Γ2 ++ []) ++ A :: Imp (And A0 B0) C :: Γ3, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
         lia. reflexivity. }
      { inversion e0.  subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
         pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
         assert (AndImpLRule  [(Γ2 ++ Imp A0 (Imp B0 C) :: x ++ A :: Γ1, B)]
         ((Γ2 ++ Imp (And A0 B0) C :: x) ++ A :: Γ1, B)). repeat rewrite <- app_assoc. apply AndImpLRule_I.
         apply AndImpL in H0.
         assert (J4: ImpRRule [((Γ2 ++ Imp A0 (Imp B0 C) :: x) ++ A :: Γ1, B)]
         ((Γ2 ++ Imp A0 (Imp B0 C) :: x) ++ Γ1, Imp A B)). apply ImpRRule_I. repeat rewrite <- app_assoc in J4.
         simpl in J4.
         assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
         assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
         pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
         pose (dlCons x1 DersNilF).
         pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
         (ps:=[(Γ2 ++ Imp A0 (Imp B0 C) :: x ++ A :: Γ1, B)])
         ((Γ2 ++ Imp (And A0 B0) C :: x) ++ A :: Γ1, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
         lia. reflexivity. }
    + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
       pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
       assert (AndImpLRule [((Γ0 ++ A :: x) ++ Imp A0 (Imp B0 C) :: Γ3, B)]
       ((Γ0 ++ A :: x) ++ Imp (And A0 B0) C :: Γ3, B)). apply AndImpLRule_I. repeat rewrite <- app_assoc in H0. simpl in H0.
       assert (J4: ImpRRule [(Γ0 ++ A :: x ++ Imp A0 (Imp B0 C) :: Γ3, B)]
       ((Γ0 ++ x) ++ Imp A0 (Imp B0 C) :: Γ3, Imp A B)). repeat rewrite <- app_assoc. apply ImpRRule_I.
       assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
       assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
       pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
       pose (dlCons x1 DersNilF). apply AndImpL in H0.
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[(Γ0 ++ A :: x ++ Imp A0 (Imp B0 C) :: Γ3, B)])
       (Γ0 ++ A :: x ++ Imp (And A0 B0) C :: Γ3, B) H0 d0). repeat rewrite <- app_assoc. exists d1. simpl. rewrite dersrec_height_nil. lia. reflexivity.
  (* OrImpL *)
  * inversion H. subst. apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
   + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
       pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
       assert (OrImpLRule  [((Γ2 ++ [A]) ++ Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, B)]
       ((Γ2 ++ [A]) ++ Imp (Or A0 B0) C :: Γ3 ++ Γ4, B)). apply OrImpLRule_I. apply OrImpL in H0.
       repeat rewrite <- app_assoc in H0. simpl in H0.
       assert (J4: ImpRRule [(Γ2 ++ A :: Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, B)]
       (Γ2 ++ Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, Imp A B)). apply ImpRRule_I.
       assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
       assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
       pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
       pose (dlCons x1 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[(Γ2 ++ A :: Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, B)])
       (Γ2 ++ A :: Imp (Or A0 B0) C :: Γ3 ++ Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
       lia. reflexivity.
   + destruct x.
      { simpl in e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
       pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
       assert (OrImpLRule  [((Γ2 ++ [A]) ++ Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, B)]
       ((Γ2 ++ []) ++ A :: Imp (Or A0 B0) C :: Γ3 ++ Γ4, B)).
       assert ((Γ2 ++ []) ++ A :: Imp (Or A0 B0) C :: Γ3 ++ Γ4 = (Γ2 ++ [A]) ++ Imp (Or A0 B0) C :: Γ3 ++ Γ4).
       repeat rewrite <- app_assoc. auto. rewrite H0. apply OrImpLRule_I. apply OrImpL in H0.
       assert (J4: ImpRRule [((Γ2 ++ [A]) ++ Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, B)]
       (Γ2 ++ Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, Imp A B)). repeat rewrite <- app_assoc. apply ImpRRule_I.
       assert (J5: derrec_height x < S (dersrec_height d)). lia.
       assert (J6: derrec_height x = derrec_height x). reflexivity.
       pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
       pose (dlCons x0 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[((Γ2 ++ [A]) ++ Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, B)])
       ((Γ2 ++ []) ++ A :: Imp (Or A0 B0) C :: Γ3 ++ Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
       lia. reflexivity. }
      { inversion e0.  subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
         pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s. simpl.
         apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
         - assert (OrImpLRule  [(Γ2 ++ Imp A0 C :: Γ3 ++  Imp B0 C :: A :: Γ4, B)]
           ((Γ2 ++ Imp (Or A0 B0) C :: Γ3) ++ A :: Γ4, B)). repeat rewrite <- app_assoc. apply OrImpLRule_I.
           apply OrImpL in H0.
           assert (J4: ImpRRule [((Γ2 ++ Imp A0 C :: Γ3 ++ [Imp B0 C]) ++ A :: Γ4, B)]
           ((Γ2 ++ Imp A0 C :: Γ3 ++ [Imp B0 C]) ++ Γ4, Imp A B)). apply ImpRRule_I.
           repeat rewrite <- app_assoc in J4. simpl in J4. repeat rewrite <- app_assoc in J4. simpl in J4.
           assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
           assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
           pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
           pose (dlCons x DersNilF).
           pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
           (ps:=[(Γ2 ++ Imp A0 C :: Γ3 ++ Imp B0 C :: A :: Γ4, B)])
           ((Γ2 ++ Imp (Or A0 B0) C :: Γ3) ++ A :: Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
           lia. reflexivity.
         - assert (OrImpLRule  [(Γ2 ++ Imp A0 C :: Γ3 ++ Imp B0 C :: x1 ++ A :: Γ1, B)]
           ((Γ2 ++ Imp (Or A0 B0) C :: Γ3 ++ x1) ++ A :: Γ1, B)). repeat rewrite <- app_assoc.
           simpl. repeat rewrite <- app_assoc. apply OrImpLRule_I. apply OrImpL in H0.
           assert (J4: ImpRRule [(Γ2 ++ Imp A0 C :: Γ3 ++ Imp B0 C :: x1 ++ A :: Γ1, B)]
           (Γ2 ++ Imp A0 C :: Γ3 ++ Imp B0 C :: x1 ++ Γ1, Imp A B)).
           assert (Γ2 ++ Imp A0 C :: Γ3 ++ Imp B0 C :: x1 ++ A :: Γ1 = (Γ2 ++ Imp A0 C :: Γ3 ++ Imp B0 C :: x1) ++ A :: Γ1).
           repeat rewrite <- app_assoc. simpl. repeat rewrite <- app_assoc. auto. rewrite H1.
           assert (Γ2 ++ Imp A0 C :: Γ3 ++ Imp B0 C :: x1 ++ Γ1 = (Γ2 ++ Imp A0 C :: Γ3 ++ Imp B0 C :: x1) ++ Γ1).
           repeat rewrite <- app_assoc. simpl. repeat rewrite <- app_assoc. auto. rewrite H2.
           apply ImpRRule_I.
           assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
           assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
           pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
           pose (dlCons x DersNilF).
           pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
           (ps:=[(Γ2 ++ Imp A0 C :: Γ3 ++ Imp B0 C :: x1 ++ A :: Γ1, B)])
           ((Γ2 ++ Imp (Or A0 B0) C :: Γ3 ++ x1) ++ A :: Γ1, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
           lia. reflexivity.
         - assert (OrImpLRule  [((Γ2 ++ Imp A0 C :: x) ++ A :: x1 ++ Imp B0 C :: Γ4, B)]
           ((Γ2 ++ Imp (Or A0 B0) C :: x) ++ A :: x1 ++ Γ4, B)).
           assert ((Γ2 ++ Imp A0 C :: x) ++ A :: x1 ++ Imp B0 C :: Γ4 = Γ2 ++ Imp A0 C :: (x ++ A :: x1) ++ Imp B0 C :: Γ4).
           repeat rewrite <- app_assoc. auto. rewrite H0.
           assert ((Γ2 ++ Imp (Or A0 B0) C :: x) ++ A :: x1 ++ Γ4 = Γ2 ++ Imp (Or A0 B0) C :: (x ++ A :: x1) ++ Γ4).
           repeat rewrite <- app_assoc. auto. rewrite H1.
           apply OrImpLRule_I. apply OrImpL in H0.
           assert (J4: ImpRRule [((Γ2 ++ Imp A0 C :: x) ++ A :: x1 ++ Imp B0 C :: Γ4, B)]
           (Γ2 ++ Imp A0 C :: (x ++ x1) ++ Imp B0 C :: Γ4, Imp A B)).
           assert (Γ2 ++ Imp A0 C :: (x ++ x1) ++ Imp B0 C :: Γ4 = (Γ2 ++ Imp A0 C :: x) ++ x1 ++ Imp B0 C :: Γ4).
           repeat rewrite <- app_assoc. auto. rewrite H1. apply ImpRRule_I.
           assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
           assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
           pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
           pose (dlCons x2 DersNilF).
           pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
           (ps:=[((Γ2 ++ Imp A0 C :: x) ++ A :: x1 ++ Imp B0 C :: Γ4, B)])
           ((Γ2 ++ Imp (Or A0 B0) C :: x) ++ A :: x1 ++ Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
           lia. reflexivity. }
    + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
       pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
       assert (OrImpLRule  [((Γ0 ++ A :: x) ++ Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, B)]
       (Γ0 ++ A :: x ++ Imp (Or A0 B0) C :: Γ3 ++ Γ4, B)).
       assert (Γ0 ++ A :: x ++ Imp (Or A0 B0) C :: Γ3 ++ Γ4 = (Γ0 ++ A :: x) ++ Imp (Or A0 B0) C :: Γ3 ++ Γ4).
       repeat rewrite <- app_assoc. auto. rewrite H0.
       apply OrImpLRule_I. apply OrImpL in H0.
       assert (J4: ImpRRule [((Γ0 ++ A :: x) ++ Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, B)]
       ((Γ0 ++ x) ++ Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, Imp A B)). repeat rewrite <- app_assoc. apply ImpRRule_I.
       assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
       assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
       pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
       pose (dlCons x1 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[((Γ0 ++ A :: x) ++ Imp A0 C :: Γ3 ++ Imp B0 C :: Γ4, B)])
       (Γ0 ++ A :: x ++ Imp (Or A0 B0) C :: Γ3 ++ Γ4, B) H0 d0). exists d1. simpl. rewrite dersrec_height_nil.
       lia. reflexivity.
  (* ImpImpL *)
 * inversion H. subst. apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
   + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl.
      assert (ImpImpLRule [(Γ2 ++ A :: Imp B0 C :: Γ3, Imp A0 B0); (Γ2 ++ A :: C :: Γ3, B)]
      (Γ2 ++ A :: Imp (Imp A0 B0) C :: Γ3, B)).
      assert (Γ2 ++ A :: Imp B0 C :: Γ3 = (Γ2 ++ [A]) ++ Imp B0 C :: Γ3). repeat rewrite <- app_assoc ; auto.
      rewrite H0. assert (Γ2 ++ A :: C :: Γ3 = (Γ2 ++ [A]) ++ C :: Γ3). repeat rewrite <- app_assoc ; auto.
      rewrite H1. assert (Γ2 ++ A :: Imp (Imp A0 B0) C :: Γ3 = (Γ2 ++ [A]) ++ Imp (Imp A0 B0) C :: Γ3). repeat rewrite <- app_assoc ; auto.
      rewrite H2. apply ImpImpLRule_I. apply ImpImpL in H0.
      assert (J4: ImpRRule [(Γ2 ++ A :: C :: Γ3, B)] (Γ2 ++ C :: Γ3, Imp A B)). apply ImpRRule_I.
      assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
      assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
      pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
      assert (J1: derrec_height x0 = derrec_height x0). auto.
      assert (J2: wkn_L A (Γ2 ++ Imp B0 C :: Γ3, Imp A0 B0) (Γ2 ++ A :: Imp B0 C :: Γ3, Imp A0 B0)).
      apply wkn_LI.
      pose (@GL4ip_wkn_L (derrec_height x0) _ x0 J1 (Γ2 ++ A :: Imp B0 C :: Γ3, Imp A0 B0) A J2). destruct s.
      pose (dlCons x2 DersNilF). pose (dlCons x3 d0).
      pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ2 ++ A :: Imp B0 C :: Γ3, Imp A0 B0); (Γ2 ++ A :: C :: Γ3, B)])
      (Γ2 ++ A :: Imp (Imp A0 B0) C :: Γ3, B) H0 d1). exists d2. simpl. rewrite dersrec_height_nil.
      lia. reflexivity.
   + destruct x.
      { simpl in e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl.
        assert (ImpImpLRule [(Γ2 ++ A :: Imp B0 C :: Γ3, Imp A0 B0); (Γ2 ++ A :: C :: Γ3, B)]
        ((Γ2 ++ []) ++ A :: Imp (Imp A0 B0) C :: Γ3, B)).
        assert (Γ2 ++ A :: Imp B0 C :: Γ3 = (Γ2 ++ [A]) ++ Imp B0 C :: Γ3). repeat rewrite <- app_assoc ; auto.
        rewrite H0. assert (Γ2 ++ A :: C :: Γ3 = (Γ2 ++ [A]) ++ C :: Γ3). repeat rewrite <- app_assoc ; auto.
        rewrite H1. assert ((Γ2 ++ []) ++ A :: Imp (Imp A0 B0) C :: Γ3 = (Γ2 ++ [A]) ++ Imp (Imp A0 B0) C :: Γ3). repeat rewrite <- app_assoc ; auto.
        rewrite H2. apply ImpImpLRule_I. apply ImpImpL in H0.
        assert (J4: ImpRRule [(Γ2 ++ A :: C :: Γ3, B)] (Γ2 ++ C :: Γ3, Imp A B)). apply ImpRRule_I.
        assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
        assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
        assert (J1: derrec_height x = derrec_height x). auto.
        assert (J2: wkn_L A (Γ2 ++ Imp B0 C :: Γ3, Imp A0 B0) (Γ2 ++ A :: Imp B0 C :: Γ3, Imp A0 B0)).
        apply wkn_LI.
        pose (@GL4ip_wkn_L (derrec_height x) _ x J1 (Γ2 ++ A :: Imp B0 C :: Γ3, Imp A0 B0) A J2). destruct s.
        pose (dlCons x1 DersNilF). pose (dlCons x2 d0).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ2 ++ A :: Imp B0 C :: Γ3, Imp A0 B0); (Γ2 ++ A :: C :: Γ3, B)])
        ((Γ2 ++ []) ++ A :: Imp (Imp A0 B0) C :: Γ3, B) H0 d1). exists d2. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
      { inversion e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
        repeat rewrite <- app_assoc. simpl.
        assert (ImpImpLRule [(Γ2 ++ Imp B0 C :: x ++ A :: Γ1, Imp A0 B0); (Γ2 ++ C :: x ++ A :: Γ1, B)]
        (Γ2 ++ Imp (Imp A0 B0) C :: x ++ A :: Γ1, B)). apply ImpImpLRule_I. apply ImpImpL in H0.
        assert (J4: ImpRRule [(Γ2 ++ C :: x ++ A :: Γ1, B)] (Γ2 ++ C :: x ++ Γ1, Imp A B)).
        assert (Γ2 ++ C :: x ++ A :: Γ1 = (Γ2 ++ C :: x) ++ A :: Γ1). repeat rewrite <- app_assoc ; auto.
        rewrite H1. assert (Γ2 ++ C :: x ++ Γ1 = (Γ2 ++ C :: x) ++ Γ1). repeat rewrite <- app_assoc ; auto.
        rewrite H2. apply ImpRRule_I.
        assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
        assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
        assert (J1: derrec_height x0 = derrec_height x0). auto.
        assert (J2: wkn_L A (Γ2 ++ Imp B0 C :: x ++ Γ1, Imp A0 B0) (Γ2 ++ Imp B0 C :: x ++ A :: Γ1, Imp A0 B0)).
        assert (Γ2 ++ Imp B0 C :: x ++ Γ1 = (Γ2 ++ Imp B0 C :: x) ++ Γ1). repeat rewrite <- app_assoc ; auto.
        rewrite H1. assert (Γ2 ++ Imp B0 C :: x ++ A :: Γ1 = (Γ2 ++ Imp B0 C :: x) ++ A :: Γ1). repeat rewrite <- app_assoc ; auto.
        rewrite H2. apply wkn_LI.
        pose (@GL4ip_wkn_L (derrec_height x0) _ x0 J1 _ A J2). destruct s.
        pose (dlCons x2 DersNilF). pose (dlCons x3 d0).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ2 ++ Imp B0 C :: x ++ A :: Γ1, Imp A0 B0); (Γ2 ++ C :: x ++ A :: Γ1, B)])
       (Γ2 ++ Imp (Imp A0 B0) C :: x ++ A :: Γ1, B) H0 d1). exists d2. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
    + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
        repeat rewrite <- app_assoc. simpl.
        assert (ImpImpLRule [((Γ0 ++ A :: x) ++ Imp B0 C :: Γ3, Imp A0 B0); ((Γ0 ++ A :: x) ++ C :: Γ3, B)]
        (Γ0 ++ A :: x ++ Imp (Imp A0 B0) C :: Γ3, B)).
        assert (Γ0 ++ A :: x ++ Imp (Imp A0 B0) C :: Γ3 =  (Γ0 ++ A :: x) ++ Imp (Imp A0 B0) C :: Γ3).
        repeat rewrite <- app_assoc ; auto. rewrite H0. apply ImpImpLRule_I. apply ImpImpL in H0.
        assert (J4: ImpRRule [((Γ0 ++ A :: x) ++ C :: Γ3, B)] ((Γ0 ++ x) ++ C :: Γ3, Imp A B)).
        repeat rewrite <- app_assoc. apply ImpRRule_I.
        assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
        assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s.
        assert (J1: derrec_height x0 = derrec_height x0). auto.
        assert (J2: wkn_L A ((Γ0 ++ x) ++ Imp B0 C :: Γ3, Imp A0 B0) ((Γ0 ++ A :: x) ++ Imp B0 C :: Γ3, Imp A0 B0)).
        repeat rewrite <- app_assoc. apply wkn_LI.
        pose (@GL4ip_wkn_L (derrec_height x0) _ x0 J1 _ A J2). destruct s.
        pose (dlCons x2 DersNilF). pose (dlCons x3 d0).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[((Γ0 ++ A :: x) ++ Imp B0 C :: Γ3, Imp A0 B0); ((Γ0 ++ A :: x) ++ C :: Γ3, B)])
        (Γ0 ++ A :: x ++ Imp (Imp A0 B0) C :: Γ3, B) H0 d1). exists d2. simpl. rewrite dersrec_height_nil.
        lia. reflexivity.
  (* BoxImpL *)
 * inversion X. subst. apply app2_find_hole in H. destruct H. repeat destruct s ; destruct p ; subst.
   + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl.
      apply univ_gen_ext_splitR in X0. destruct X0. destruct s. repeat destruct p. subst.
      assert (J4: ImpRRule [(Γ2 ++ A :: B0 :: Γ3, B)] (Γ2 ++ B0 :: Γ3, Imp A B)). apply ImpRRule_I.
      assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
      assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
      pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s. destruct (dec_is_boxedT A).
      { assert (BoxImpLRule [(XBoxed_list (x2 ++ A :: x3) ++ [Box A0], A0); (Γ2 ++ A :: B0 :: Γ3, B)]
        (Γ2 ++ A :: Imp (Box A0) B0 :: Γ3, B)).
        assert (Γ2 ++ A :: Imp (Box A0) B0 :: Γ3 =  (Γ2 ++ [A]) ++ Imp (Box A0) B0 :: Γ3).
        repeat rewrite <- app_assoc ; auto. rewrite H.
        assert (Γ2 ++ A :: B0 :: Γ3 =  (Γ2 ++ [A]) ++ B0 :: Γ3).
        repeat rewrite <- app_assoc ; auto. rewrite H0. apply BoxImpLRule_I ; auto. intro.
        intros. apply in_app_or in H2. destruct H2. apply H1. apply in_or_app ; auto. inversion H2 ; subst. auto.
        apply H1 ; apply in_or_app ; auto. repeat rewrite <- app_assoc. simpl. apply univ_gen_ext_combine.
        auto. apply univ_gen_ext_cons ; auto. apply BoxImpL in X0.
        assert (J1: derrec_height x0 = derrec_height x0). auto.
        assert (J2: wkn_L A (XBoxed_list (x2 ++ x3) ++ [Box A0], A0) ((XBoxed_list x2) ++ A :: (XBoxed_list x3) ++ [Box A0], A0)).
        repeat rewrite XBox_app_distrib. repeat rewrite <- app_assoc. apply wkn_LI.
        pose (@GL4ip_wkn_L (derrec_height x0) _ x0 J1 _ A J2). destruct s.
        assert (J3: derrec_height x5 = derrec_height x5). auto.
        assert (J31: wkn_L (unBox_formula A) ((XBoxed_list x2) ++ A :: (XBoxed_list x3) ++ [Box A0], A0) (XBoxed_list (x2 ++ A :: x3) ++ [Box A0], A0)).
        repeat rewrite XBox_app_distrib. simpl. repeat rewrite <- app_assoc. apply wkn_LI.
        pose (@GL4ip_wkn_L (derrec_height x5) _ x5 J3 _ (unBox_formula A) J31). destruct s.
        pose (dlCons x4 DersNilF). pose (dlCons x6 d0).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(XBoxed_list (x2 ++ A :: x3) ++ [Box A0], A0); (Γ2 ++ A :: B0 :: Γ3, B)])
        (Γ2 ++ A :: Imp (Box A0) B0 :: Γ3, B) X0 d1). exists d2. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
      { assert (BoxImpLRule [(XBoxed_list (x2 ++ x3) ++ [Box A0], A0); (Γ2 ++ A :: B0 :: Γ3, B)]
        (Γ2 ++ A :: Imp (Box A0) B0 :: Γ3, B)).
        assert (Γ2 ++ A :: Imp (Box A0) B0 :: Γ3 =  (Γ2 ++ [A]) ++ Imp (Box A0) B0 :: Γ3).
        repeat rewrite <- app_assoc ; auto. rewrite H.
        assert (Γ2 ++ A :: B0 :: Γ3 =  (Γ2 ++ [A]) ++ B0 :: Γ3).
        repeat rewrite <- app_assoc ; auto. rewrite H0. apply BoxImpLRule_I ; auto. repeat rewrite <- app_assoc. simpl.
        apply univ_gen_ext_combine ; auto. apply univ_gen_ext_extra ; auto. apply BoxImpL in X0.
        pose (dlCons x4 DersNilF). pose (dlCons x0 d0).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(XBoxed_list (x2 ++ x3) ++ [Box A0], A0); (Γ2 ++ A :: B0 :: Γ3, B)])
        (Γ2 ++ A :: Imp (Box A0) B0 :: Γ3, B) X0 d1). exists d2. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
   + destruct x.
      { simpl in e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl.
        apply univ_gen_ext_splitR in X0. destruct X0. destruct s. repeat destruct p. subst.
        assert (J4: ImpRRule [(Γ2 ++ A :: B0 :: Γ3, B)] (Γ2 ++ B0 :: Γ3, Imp A B)). apply ImpRRule_I.
        assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
        assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s. destruct (dec_is_boxedT A).
        - assert (BoxImpLRule [(XBoxed_list (x1 ++ A :: x2) ++ [Box A0], A0); (Γ2 ++ A :: B0 :: Γ3, B)]
          ((Γ2 ++ []) ++ A :: Imp (Box A0) B0 :: Γ3, B)).
          assert ((Γ2 ++ []) ++ A :: Imp (Box A0) B0 :: Γ3 =  (Γ2 ++ [A]) ++ Imp (Box A0) B0 :: Γ3).
          repeat rewrite <- app_assoc ; auto. rewrite H.
          assert (Γ2 ++ A :: B0 :: Γ3 =  (Γ2 ++ [A]) ++ B0 :: Γ3).
          repeat rewrite <- app_assoc ; auto. rewrite H0. apply BoxImpLRule_I ; auto. intro.
          intros. apply in_app_or in H2. destruct H2. apply H1. apply in_or_app ; auto. inversion H2 ; subst. auto.
          apply H1 ; apply in_or_app ; auto. repeat rewrite <- app_assoc. simpl. apply univ_gen_ext_combine.
          auto. apply univ_gen_ext_cons ; auto. apply BoxImpL in X0.
          assert (J1: derrec_height x = derrec_height x). auto.
          assert (J2: wkn_L A (XBoxed_list (x1 ++ x2) ++ [Box A0], A0) ((XBoxed_list x1) ++ A :: (XBoxed_list x2) ++ [Box A0], A0)).
          repeat rewrite XBox_app_distrib. repeat rewrite <- app_assoc. apply wkn_LI.
          pose (@GL4ip_wkn_L (derrec_height x) _ x J1 _ A J2). destruct s.
          assert (J3: derrec_height x4 = derrec_height x4). auto.
          assert (J31: wkn_L (unBox_formula A) ((XBoxed_list x1) ++ A :: (XBoxed_list x2) ++ [Box A0], A0) (XBoxed_list (x1 ++ A :: x2) ++ [Box A0], A0)).
          repeat rewrite XBox_app_distrib. simpl. repeat rewrite <- app_assoc. apply wkn_LI.
          pose (@GL4ip_wkn_L (derrec_height x4) _ x4 J3 _ (unBox_formula A) J31). destruct s.
          pose (dlCons x3 DersNilF). pose (dlCons x5 d0).
          pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
          (ps:=[(XBoxed_list (x1 ++ A :: x2) ++ [Box A0], A0); (Γ2 ++ A :: B0 :: Γ3, B)])
          ((Γ2 ++ []) ++ A :: Imp (Box A0) B0 :: Γ3, B) X0 d1). exists d2. simpl. rewrite dersrec_height_nil.
          lia. reflexivity.
        - assert (BoxImpLRule [(XBoxed_list (x1 ++ x2) ++ [Box A0], A0); (Γ2 ++ A :: B0 :: Γ3, B)]
          ((Γ2 ++ []) ++ A :: Imp (Box A0) B0 :: Γ3, B)).
          assert ((Γ2 ++ []) ++ A :: Imp (Box A0) B0 :: Γ3 =  (Γ2 ++ [A]) ++ Imp (Box A0) B0 :: Γ3).
          repeat rewrite <- app_assoc ; auto. rewrite H.
          assert (Γ2 ++ A :: B0 :: Γ3 =  (Γ2 ++ [A]) ++ B0 :: Γ3).
          repeat rewrite <- app_assoc ; auto. rewrite H0. apply BoxImpLRule_I ; auto. repeat rewrite <- app_assoc. simpl.
          apply univ_gen_ext_combine ; auto. apply univ_gen_ext_extra ; auto. apply BoxImpL in X0.
          pose (dlCons x3 DersNilF). pose (dlCons x d0).
          pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
          (ps:=[(XBoxed_list (x1 ++ x2) ++ [Box A0], A0); (Γ2 ++ A :: B0 :: Γ3, B)])
          ((Γ2 ++ []) ++ A :: Imp (Box A0) B0 :: Γ3, B) X0 d1). exists d2. simpl. rewrite dersrec_height_nil.
          lia. reflexivity. }
      { inversion e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl.
        apply univ_gen_ext_splitR in X0. destruct X0. destruct s. repeat destruct p. subst. apply univ_gen_ext_splitR in u0.
        destruct u0. destruct s. repeat destruct p ; subst.
        assert (J4: ImpRRule [((Γ2 ++ B0 :: x) ++ A :: Γ1, B)] ((Γ2 ++ B0 :: x) ++ Γ1, Imp A B)). apply ImpRRule_I.
        repeat rewrite <- app_assoc in J4. simpl in J4.
        assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
        assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
        pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s. destruct (dec_is_boxedT A).
        - assert (BoxImpLRule [(XBoxed_list (x2 ++ x4 ++ A :: x5) ++ [Box A0], A0); (Γ2 ++ B0 :: x ++ A :: Γ1, B)]
          ((Γ2 ++ Imp (Box A0) B0 :: x) ++ A :: Γ1, B)). repeat rewrite <- app_assoc. apply BoxImpLRule_I ; auto.
          intro. intros. apply in_app_or in H. destruct H. apply H1. apply in_or_app ; auto. apply in_app_or in H. destruct H.
          apply H1. apply in_or_app ; right ; apply in_or_app;  auto. inversion H ; subst. auto.
          apply H1 ; apply in_or_app ; right ; apply in_or_app ; auto. apply univ_gen_ext_combine.
          auto. apply univ_gen_ext_combine ; auto. apply univ_gen_ext_cons ; auto. apply BoxImpL in X0.
          assert (J1: derrec_height x0 = derrec_height x0). auto.
          assert (J2: wkn_L A (XBoxed_list (x2 ++ x4 ++ x5) ++ [Box A0], A0) ((XBoxed_list (x2 ++ x4)) ++ A :: (XBoxed_list x5) ++ [Box A0], A0)).
          assert (XBoxed_list (x2 ++ x4 ++ x5) ++ [Box A0] = (XBoxed_list (x2 ++ x4)) ++ (XBoxed_list x5) ++ [Box A0]).
          repeat rewrite XBox_app_distrib. repeat rewrite <- app_assoc. auto. rewrite H. apply wkn_LI.
          pose (@GL4ip_wkn_L (derrec_height x0) _ x0 J1 _ A J2). destruct s.
          assert (J3: derrec_height x6 = derrec_height x6). auto.
          assert (J31: wkn_L (unBox_formula A)  (XBoxed_list (x2 ++ x4) ++ A :: XBoxed_list x5 ++ [Box A0], A0)
          (XBoxed_list (x2 ++ x4 ++ A :: x5) ++ [Box A0], A0)).
          assert (XBoxed_list (x2 ++ x4 ++ A :: x5) ++ [Box A0] = (XBoxed_list (x2 ++ x4)) ++ unBox_formula A :: A :: (XBoxed_list x5) ++ [Box A0]).
          repeat rewrite XBox_app_distrib. repeat rewrite <- app_assoc. auto. rewrite H. apply wkn_LI.
          pose (@GL4ip_wkn_L (derrec_height x6) _ x6 J3 _ (unBox_formula A) J31). destruct s.
          pose (dlCons x3 DersNilF). pose (dlCons x7 d0).
          pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
          (ps:=[(XBoxed_list (x2 ++ x4 ++ A :: x5) ++ [Box A0], A0); (Γ2 ++ B0 :: x ++ A :: Γ1, B)])
          ((Γ2 ++ Imp (Box A0) B0 :: x) ++ A :: Γ1, B) X0 d1). exists d2. simpl. rewrite dersrec_height_nil.
          lia. reflexivity.
        - assert (BoxImpLRule [(XBoxed_list (x2 ++ x4 ++ x5) ++ [Box A0], A0); (Γ2 ++ B0 :: x ++ A :: Γ1, B)]
          ((Γ2 ++ Imp (Box A0) B0 :: x) ++ A :: Γ1, B)). repeat rewrite <- app_assoc. apply BoxImpLRule_I ; auto.
          apply univ_gen_ext_combine ; auto.  apply univ_gen_ext_combine ; auto. apply univ_gen_ext_extra ; auto. apply BoxImpL in X0.
          pose (dlCons x3 DersNilF). pose (dlCons x0 d0).
          pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
          (ps:=[(XBoxed_list (x2 ++ x4 ++ x5) ++ [Box A0], A0); (Γ2 ++ B0 :: x ++ A :: Γ1, B)])
          ((Γ2 ++ Imp (Box A0) B0 :: x) ++ A :: Γ1, B) X0 d1). exists d2. simpl. rewrite dersrec_height_nil.
          lia. reflexivity. }
    + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl.
      apply univ_gen_ext_splitR in X0. destruct X0. destruct s. repeat destruct p. subst. apply univ_gen_ext_splitR in u.
      destruct u. destruct s. repeat destruct p ; subst.
      assert (J4: ImpRRule [(Γ0 ++ A :: x ++ B0 :: Γ3, B)] ((Γ0 ++ x) ++ B0 :: Γ3, Imp A B)).
      repeat rewrite <- app_assoc. apply ImpRRule_I.
      assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
      assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
      pose (IH _ J5 _ _ J6). pose (s _ J4). destruct s0. clear s. destruct (dec_is_boxedT A).
      { assert (BoxImpLRule [(XBoxed_list (x4 ++ A :: x5 ++ x3) ++ [Box A0], A0); (Γ0 ++ A :: x ++ B0 :: Γ3, B)]
        (Γ0 ++ A :: x ++ Imp (Box A0) B0 :: Γ3, B)).
        assert (Γ0 ++ A :: x ++ B0 :: Γ3 = (Γ0 ++ A :: x) ++ B0 :: Γ3). repeat rewrite <- app_assoc. auto.
        rewrite H. assert (Γ0 ++ A :: x ++ Imp (Box A0) B0 :: Γ3 = (Γ0 ++ A :: x) ++ Imp (Box A0) B0 :: Γ3). repeat rewrite <- app_assoc. auto.
        rewrite H0. apply BoxImpLRule_I ; auto. clear H. clear H0.
        intro. intros. apply in_app_or in H. destruct H. apply H1. apply in_or_app ; left. apply in_or_app ; auto.
        inversion H. subst ; auto. apply in_app_or in H0. destruct H0.
        apply H1. apply in_or_app ; left ; apply in_or_app;  auto.
        apply H1 ; apply in_or_app ; auto. repeat rewrite <- app_assoc. simpl. apply univ_gen_ext_combine ; auto.
        apply univ_gen_ext_cons ; auto. apply univ_gen_ext_combine ; auto. apply BoxImpL in X0.
        assert (J1: derrec_height x0 = derrec_height x0). auto.
        assert (J2: wkn_L A (XBoxed_list ((x4 ++ x5) ++ x3) ++ [Box A0], A0) ((XBoxed_list x4) ++ A :: (XBoxed_list (x5 ++ x3)) ++ [Box A0], A0)).
        repeat rewrite XBox_app_distrib. repeat rewrite <- app_assoc. apply wkn_LI.
        pose (@GL4ip_wkn_L (derrec_height x0) _ x0 J1 _ A J2). destruct s.
        assert (J3: derrec_height x6 = derrec_height x6). auto.
        assert (J31: wkn_L (unBox_formula A)  (XBoxed_list x4 ++ A :: XBoxed_list (x5 ++ x3) ++ [Box A0], A0)
        (XBoxed_list (x4 ++ A :: x5 ++ x3) ++ [Box A0], A0)).
        repeat rewrite XBox_app_distrib. repeat rewrite <- app_assoc. simpl.
        repeat rewrite XBox_app_distrib. repeat rewrite <- app_assoc. apply wkn_LI.
        pose (@GL4ip_wkn_L (derrec_height x6) _ x6 J3 _ (unBox_formula A) J31). destruct s.
        pose (dlCons x2 DersNilF). pose (dlCons x7 d0).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(XBoxed_list (x4 ++ A :: x5 ++ x3) ++ [Box A0], A0); (Γ0 ++ A :: x ++ B0 :: Γ3, B)])
        (Γ0 ++ A :: x ++ Imp (Box A0) B0 :: Γ3, B) X0 d1). exists d2. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
      { assert (BoxImpLRule [(XBoxed_list ((x4 ++ x5) ++ x3) ++ [Box A0], A0); (Γ0 ++ A :: x ++ B0 :: Γ3, B)]
        (Γ0 ++ A :: x ++ Imp (Box A0) B0 :: Γ3, B)).
        assert (Γ0 ++ A :: x ++ B0 :: Γ3 = (Γ0 ++ A :: x) ++ B0 :: Γ3). repeat rewrite <- app_assoc ; auto.
        rewrite H. assert (Γ0 ++ A :: x ++ Imp (Box A0) B0 :: Γ3 = (Γ0 ++ A :: x) ++ Imp (Box A0) B0 :: Γ3). repeat rewrite <- app_assoc ; auto.
        rewrite H0. apply BoxImpLRule_I ; auto. repeat rewrite <- app_assoc.
        apply univ_gen_ext_combine ; auto. simpl. apply univ_gen_ext_extra ; auto. apply univ_gen_ext_combine ; auto. apply BoxImpL in X0.
        pose (dlCons x2 DersNilF). pose (dlCons x0 d0).
        pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
        (ps:=[(XBoxed_list ((x4 ++ x5) ++ x3) ++ [Box A0], A0); (Γ0 ++ A :: x ++ B0 :: Γ3, B)])
        (Γ0 ++ A :: x ++ Imp (Box A0) B0 :: Γ3, B) X0 d1). exists d2. simpl. rewrite dersrec_height_nil.
        lia. reflexivity. }
  (* GLR *)
  * inversion X.
Qed.

Theorem ImpR_inv : forall concl prem, (derrec GL4ip_rules (fun _ => False) concl) ->
                                      (ImpRRule [prem] concl) ->
                                      (derrec GL4ip_rules (fun _ => False) prem).
Proof.
intros.
assert (J1: derrec_height X = derrec_height X). reflexivity.
pose (ImpR_hpinv _  _ X J1). pose (s _ H). destruct s0. assumption.
Qed.


Require Export Stlc.Classes.
Require Import Stlc.DefinitionsSyntax.
Require Import Stlc.Lemmas.

(***********************************************************************)
(** * Class  instances *)
(***********************************************************************)

#[global] Instance Syntax_exp : Syntax exp := {
    fv := fun {n} => @fv_exp n;
    size := fun {n} => @size_exp n;
    weaken := fun {n} =>  @weaken_exp n;
    close := fun {n} => @close_exp_wrt_exp n;
}.

#[global] Opaque Syntax_exp.

#[global] Instance Subst_exp : Subst exp exp := {
    open := fun {n} => @open_exp_wrt_exp n;
    subst := fun {n} => @subst_exp_wrt_exp n
}.
#[global] Opaque Subst_exp.

#[global] Instance STE :  SyntaxTheory exp := {
  size_weaken := size_exp_weaken_exp;
  fv_weaken := fv_exp_weaken_exp;
  size_min  := size_exp_min;
  size_close := size_exp_close_exp_wrt_exp;
  close_inj := close_exp_wrt_exp_inj;
  close_weaken := close_exp_wrt_exp_weaken_exp;
  fv_close := fv_exp_close_exp_wrt_exp;
}.

#[global] Opaque STE.

#[global] Instance SSTE : SubstTheory exp exp := {
  size_open := size_exp_open_exp_wrt_exp;
  open_weaken := open_exp_wrt_exp_weaken_exp;
  fv_open_lower := fv_exp_open_exp_wrt_exp_lower;
  fv_open_upper := fv_exp_open_exp_wrt_exp_upper;
  fv_subst_fresh := fv_exp_subst_exp_wrt_exp_fresh;
  fv_subst_lower := fv_exp_subst_exp_wrt_exp_lower;
  fv_subst_notin := fv_exp_subst_exp_wrt_exp_notin;
  fv_subst_upper := fv_exp_subst_exp_wrt_exp_upper;

  subst_close := subst_exp_close_exp_wrt_exp;
  subst_fresh_eq := subst_exp_wrt_exp_fresh_eq;
  subst_fresh_same := subst_exp_wrt_exp_fresh_same;
  subst_weaken := subst_exp_wrt_exp_weaken_exp;
  subst_spec := subst_exp_wrt_exp_spec;
}.

#[global] Instance SVSTE :  SubstVarTheory exp exp (@var_f) := {
  size_open_var := size_exp_open_exp_wrt_exp_var;
  close_open := close_exp_wrt_exp_open_exp_wrt_exp;
  open_close := open_exp_wrt_exp_close_exp_wrt_exp;
  open_inj := open_exp_wrt_exp_inj;
  subst_open_var := subst_exp_open_exp_wrt_exp_var;
  subst_close_open :=
    subst_exp_wrt_exp_close_exp_wrt_exp_open_exp_wrt_exp;
  subst_intro := subst_exp_wrt_exp_intro;

}.

#[global] Opaque SVSTE.

#[global] Instance SSSTE : SubstSubstTheory exp exp := {
  subst_open := subst_exp_open_exp_wrt_exp;
  subst_subst := subst_exp_wrt_exp_subst_exp_wrt_exp;
}.

#[global] Opaque SSSTE.


Require Import Fiat.Common
        Fiat.ADTNotation.BuildADT Fiat.ADTRefinement.Core
        Fiat.ADTRefinement.SetoidMorphisms.

(* A notation-friendly version of the setoid morphisms
   infrastructure for ADT refinement. *)

Theorem refineADT_BuildADT_Rep n n' consSigs methSigs oldRep newRep
      (AbsR : oldRep -> newRep -> Prop)
: @respectful_heteroT _ _ _ _
      (fun oldCons newCons =>
         forall consIdx,
           @refineConstructor oldRep newRep AbsR
                          _
                          (getConsDef oldCons consIdx)
                          (getConsDef newCons consIdx))
      (fun x y => @respectful_heteroT _ _ _ _
                    (fun oldMeth newMeth =>
                       forall methIdx,
                         @refineMethod oldRep newRep AbsR _ _
                                         (getMethDef oldMeth methIdx)
                                         (getMethDef newMeth methIdx))
                    (fun m m' => refineADT))
     (@BuildADT oldRep n n' consSigs methSigs)
     (@BuildADT newRep n n' consSigs methSigs).
 Proof.
   unfold Proper, respectful_heteroT; intros.
   let A := match goal with |- refineADT ?A ?B => constr:(A) end in
   let B := match goal with |- refineADT ?A ?B => constr:(B) end in
   eapply (@refinesADT _ A B AbsR);
     unfold id, pointwise_relation in *; simpl in *; intros; eauto.
 Qed.

Lemma refineADT_BuildADT_Both
      rep n n' consigs methSigs
: forall oldCons newCons,
    (forall consIdx, @refineConstructor _ _ eq _
                                   (getConsDef oldCons consIdx)
                                   (getConsDef newCons consIdx))
    -> forall oldMeth newMeth,
         (forall methIdx, @refineMethod _ _ eq _ _
                                         (getMethDef oldMeth methIdx)
                                         (getMethDef newMeth methIdx))
         -> refineADT (@BuildADT n n' rep consigs methSigs oldCons oldMeth)
                      (@BuildADT n n' rep consigs methSigs newCons newMeth).
Proof.
  intros; eapply refineADT_BuildADT_Rep; eauto; reflexivity.
Qed.

(*Add Parametric Morphism rep consigs methSigs
: (@BuildADT rep consigs methSigs)
    with signature
    (fun oldCons newCons =>
       forall consIdx, @refineConsator _ _ eq _
                                  (getConsDef oldCons consIdx)
                                  (getConsDef newCons consIdx))
      ==> (fun oldMeth newMeth =>
             forall methIdx, @refineMetherver _ _ eq _ _
                                         (getMethDef oldMeth methIdx)
                                         (getMethDef newMeth methIdx))
      ==> refineADT
      as refineADT_BuildADT_Both.
Proof.
  intros; apply refineADT_BuildADT_Both'.
Qed.*)


From stdpp Require Export BVbase tactics.
From stdpp Require Import options.

Section definitions.
  Context {A T : Type} `{EqDecision A}.
  Global Instance fn_insert : Insert A T (A → T) :=
    λ a t f b, if decide (a = b) then t else f b.
  Global Instance fn_alter : Alter A T (A → T) :=
    λ (g : T → T) a f b, if decide (a = b) then g (f a) else f b.
End definitions.

(* TODO: For now, we only have the properties here that do not need a notion
   of equality of functions. *)

Section functions.
  Context {A T : Type} `{!EqDecision A}.

  Lemma fn_lookup_insert (f : A → T) a t : <[a:=t]>f a = t.
  Proof. unfold insert, fn_insert. by destruct (decide (a = a)). Qed.
  Lemma fn_lookup_insert_rev  (f : A → T) a t1 t2 :
    <[a:=t1]>f a = t2 → t1 = t2.
  Proof. rewrite fn_lookup_insert. congruence. Qed.
  Lemma fn_lookup_insert_ne (f : A → T) a b t : a ≠ b → <[a:=t]>f b = f b.
  Proof. unfold insert, fn_insert. by destruct (decide (a = b)). Qed.

  Lemma fn_lookup_alter (g : T → T) (f : A → T) a : alter g a f a = g (f a).
  Proof. unfold alter, fn_alter. by destruct (decide (a = a)). Qed.
  Lemma fn_lookup_alter_ne (g : T → T) (f : A → T) a b :
    a ≠ b → alter g a f b = f b.
  Proof. unfold alter, fn_alter. by destruct (decide (a = b)). Qed.
End functions.


From cgraphs.lambdabar Require Export langdef.

Notation vertex := nat.
Definition label : Type := bool * type * type.

(* ----------- *)
(* Boilerplate *)

(* Canonical Structure vertexO := leibnizO vertex. *)
Canonical Structure typeO := leibnizO type.
Canonical Structure labelO := prodO boolO (prodO typeO typeO).
(*
Global Instance vertex_eqdecision : EqDecision vertex.
Proof.
  intros [n|n] [m|m]; unfold Decision; destruct (decide (n = m));
  subst; eauto; right; intro; simplify_eq.
Qed.
Global Instance vertex_countable : Countable vertex.
Proof.
  refine (inj_countable' (λ l, match l with
  | VThread n => inl n
  | VBarrier n => inr n
  end) (λ l, match l with
  | inl n => VThread n
  | inr n => VBarrier n
  end) _); by intros [].
Qed. *)

(* End boilerplate *)
(* --------------- *)

Notation rProp := (hProp vertex labelO).

Definition linbox l (P : rProp) : rProp :=
  match l with
  | Lin => P
  | Unr => □ P
  end.

Fixpoint rtyped (Γ : env) e t : rProp :=
  match e with
  | Val v => ⌜⌜ env_unr Γ ⌝⌝ ∗ vtyped v t
  | Var x => ⌜⌜ env_var Γ x t ⌝⌝
  | Fun x e =>
      ∃ l t1 t2, ⌜⌜ t = FunT l t1 t2 ⌝⌝  ∗
      ∃ Γ', ⌜⌜ env_bind Γ' x t1 Γ ∧ (l = Unr -> env_unr Γ) ⌝⌝ ∗
      linbox l (rtyped Γ' e t2)
  | App e1 e2 =>
      ∃ Γ1 Γ2, ⌜⌜ env_split Γ Γ1 Γ2 ⌝⌝ ∗
      ∃ t1 l,
      rtyped Γ1 e1 (FunT l t1 t) ∗
      rtyped Γ2 e2 t1
  | Unit => ⌜⌜ t = UnitT ∧ env_unr Γ ⌝⌝
  | Pair e1 e2 =>
      ∃ Γ1 Γ2, ⌜⌜ env_split Γ Γ1 Γ2 ⌝⌝ ∗
      ∃ t1 t2, ⌜⌜ t = PairT t1 t2 ⌝⌝ ∗
      rtyped Γ1 e1 t1 ∗ rtyped Γ2 e2 t2
  | LetPair e1 e2 =>
      ∃ Γ1 Γ2, ⌜⌜ env_split Γ Γ1 Γ2 ⌝⌝ ∗
      ∃ t1 t2,
      rtyped Γ1 e1 (PairT t1 t2) ∗
      rtyped Γ2 e2 (FunT Lin t1 (FunT Lin t2 t))
  | Sum i e =>
      ∃ n (ts : fin n -> type) (i' : fin n), ⌜⌜ t = SumT n ts ⌝⌝ ∗ ⌜⌜ i = i' ⌝⌝ ∗
      rtyped Γ e (ts i')
  | MatchSum n e es =>
      ∃ Γ1 Γ2, ⌜⌜ env_split Γ Γ1 Γ2 ∧ (n = 0 -> env_unr Γ2)⌝⌝ ∗
      ∃ ts,
      rtyped Γ1 e (SumT n ts) ∗
      if decide (n=0) then ⌜⌜ env_unr Γ2 ⌝⌝ else (∀ i, rtyped Γ2 (es i) (FunT Lin (ts i) t))
  | Fork e =>
      ∃ t1 t2, ⌜⌜ t = FunT Lin t1 t2 ⌝⌝ ∗
      rtyped Γ e (FunT Lin (FunT Lin t2 t1) UnitT)
  end
with vtyped v t :=
  match v with
  | FunV x e =>
      ∃ l t1 t2, ⌜⌜ t = FunT l t1 t2 ⌝⌝ ∗ linbox l (rtyped {[ x := t1 ]} e t2)
  | UnitV => ⌜⌜ t = UnitT ⌝⌝
  | PairV v1 v2 =>
      ∃ t1 t2, ⌜⌜ t = PairT t1 t2 ⌝⌝ ∗
      vtyped v1 t1 ∗ vtyped v2 t2
  | SumV i v =>
      ∃ n ts (i' : fin n), ⌜⌜ t = SumT n ts ∧ i = i' ⌝⌝ ∗
      vtyped v (ts i')
  | BarrierV k =>
      ∃ t1 t2, ⌜⌜ t = FunT Lin t1 t2 ⌝⌝ ∗
      own_out k ((false,(t1,t2)) : labelO)
  end.

Lemma typed_rtyped Γ e t :
  ⌜⌜ typed Γ e t ⌝⌝ -∗ rtyped Γ e t.
Proof.
  iIntros (H).
  iInduction e as [] "IH" forall (t Γ H);
  inv H; simpl; eauto; repeat iExists _; iSplitL; eauto;
  repeat iExists _; try iSplitL; eauto; try iSplitL;
  try destruct l; try case_decide; repeat iIntros (?);
  try iApply ("IH" with "[%]") || iApply ("IH1" with "[%]"); eauto.
Qed.

(* From stdpp's naive_solver *)
Ltac simp :=
  repeat match goal with
  (**i solve the goal *)
  | |- _ => fast_done
  (**i intros *)
  | |- ∀ _, _ => intro
  (**i simplification of assumptions *)
  | H : False |- _ => destruct H
  | H : _ ∧ _ |- _ =>
     (* Work around bug https://coq.inria.fr/bugs/show_bug.cgi?id=2901 *)
     let H1 := fresh in let H2 := fresh in
     destruct H as [H1 H2]; try clear H
  | H : ∃ _, _  |- _ =>
     let x := fresh in let Hx := fresh in
     destruct H as [x Hx]; try clear H
  | H : ?P → ?Q, H2 : ?P |- _ => specialize (H H2)
  | H : Is_true (bool_decide _) |- _ => apply (bool_decide_unpack _) in H
  | H : Is_true (_ && _) |- _ => apply andb_True in H; destruct H
  (**i simplify and solve equalities *)
  | |- _ => progress simplify_eq/=
  (**i operations that generate more subgoals *)
  (* | |- _ ∧ _ => split *)
  (* | |- Is_true (bool_decide _) => apply (bool_decide_pack _) *)
  (* | |- Is_true (_ && _) => apply andb_True; split *)
  (* | H : _ ∨ _ |- _ => *)
     (* let H1 := fresh in destruct H as [H1|H1]; try clear H *)
  (* | H : Is_true (_ || _) |- _ => *)
     (* apply orb_True in H; let H1 := fresh in destruct H as [H1|H1]; try clear H *)
  (**i solve the goal using the user supplied tactic *)
  end.

Ltac iDestr H := repeat (iDestruct "H" as %? || iDestruct H as (?) H).
Ltac iSpl := repeat (iExists _ || iSplit || iIntros (?)).

Lemma unrestricted_box v t :
  unr t -> vtyped v t -∗ □ vtyped v t.
Proof.
  iIntros (H) "H".
  iInduction v as [] "IH" forall (t H); simpl;
  iDestr "H"; simp; inv H; simp; eauto.
  - iDestruct "H" as "#H". iModIntro. eauto.
  - iDestruct "H" as "[H1 H2]".
    iDestruct ("IH" with "[%] H1") as "H1"; first done.
    iDestruct ("IH1" with "[%] H2") as "H2"; first done.
    iDestruct "H1" as "#H1".
    iDestruct "H2" as "#H2".
    iModIntro. repeat (iExists _ || iSplitL); eauto.
  - iDestruct ("IH" with "[%] H") as "H"; first done.
    iDestruct "H" as "#H". iModIntro. eauto.
Qed.

Definition substR (Γ : env) x v := from_option (vtyped v) emp%I (Γ !! x).

Ltac sdec := repeat case_decide; simplify_eq; simpl in *; eauto; try done.
Ltac smap := repeat (rewrite lookup_alter_spec || rewrite lookup_union || rewrite lookup_insert_spec || rewrite lookup_delete_spec || sdec).

Lemma env_unr_substR Γ x v :
  env_unr Γ -> substR Γ x v ⊢ emp.
Proof.
  rewrite /env_unr /substR.
  destruct (Γ !! x) eqn:E; simp.
  rewrite unrestricted_box; eauto.
Qed.

Lemma env_split_substR Γ Γ1 Γ2 x v :
  env_split Γ Γ1 Γ2 -> substR Γ x v ⊢ substR Γ1 x v ∗ substR Γ2 x v.
Proof.
  rewrite /env_split /substR. simp.
  rewrite lookup_union.
  destruct (Γ1 !! x) eqn:E;
  destruct (Γ2 !! x) eqn:F; rewrite ?E ?F; simpl; eauto.
  edestruct (H1 x); eauto. simp.
  iIntros "H".
  iDestruct (unrestricted_box with "H") as "H"; eauto.
  iDestruct "H" as "#H". iSplitL; eauto.
Qed.

Lemma env_var_substR Γ x y v t :
  env_var Γ y t ->
  substR Γ x v ⊢ if decide (x = y) then vtyped v t else emp.
Proof.
  rewrite /env_var /substR. simp. smap.
  destruct (_!!_) eqn:E; simp.
  rewrite unrestricted_box; eauto.
Qed.

Lemma env_bind_substR Γ Γ' l x y v t :
  (l = Unr -> env_unr Γ) -> env_bind Γ' y t Γ ->
  substR Γ x v ⊢ if decide (x = y) then emp else linbox l (substR Γ' x v).
Proof.
  rewrite /env_bind /substR. simp. smap.
  - destruct (Γ !! y) eqn:E; simpl; eauto.
    rewrite unrestricted_box; eauto.
  - destruct (Γ !! x) eqn:E; rewrite ?E; destruct l; eauto; simpl.
    rewrite {1}unrestricted_box; eauto.
    eapply H; eauto.
Qed.

Lemma env_unr_delete Γ x :
  env_unr Γ -> env_unr (delete x Γ).
Proof.
  rewrite /env_unr. intros ???. smap.
Qed.

Lemma env_split_delete Γ Γ1 Γ2 x :
  env_split Γ Γ1 Γ2 -> env_split (delete x Γ) (delete x Γ1) (delete x Γ2).
Proof.
  rewrite /env_split /disj. simp.
  split; [apply delete_union|].
  intros ???. smap.
Qed.

Lemma env_var_delete y x Γ t :
  env_var Γ x t -> if decide (y = x) then env_unr (delete y Γ) else env_var (delete y Γ) x t.
Proof.
  rewrite /env_var /env_unr. simp. smap.
  - simp. revert H. smap.
  - exists (delete y H0). split.
    + apply map_eq. intro. smap.
    + intros ??. smap.
Qed.

Lemma env_bind_delete x y t Γ Γ' :
  env_bind Γ' x t Γ ->
  env_bind (if decide (y = x) then Γ' else delete y Γ') x t (delete y Γ).
Proof.
  rewrite /env_bind. simp.
  split.
  - apply map_eq. intro. smap.
  - intro. smap.
Qed.

Lemma env_unr_empty :
  env_unr ∅.
Proof.
  rewrite /env_unr. intros ??. smap.
Qed.

Lemma env_split_empty Γ1 Γ2 :
  env_split ∅ Γ1 Γ2 <-> Γ1 = ∅ ∧ Γ2 = ∅.
Proof.
  rewrite /env_split.
  split. simp.
  - symmetry in H0.
    pose proof (map_positive_l _ _ H0). subst.
    rewrite left_id in H0. subst. eauto.
  - simp. rewrite left_id. split; eauto.
    rewrite /disj. intros ??. smap.
Qed.

Lemma env_var_empty x t :
  env_var ∅ x t <-> False.
Proof.
  rewrite /env_var. split; simp.
  rewrite map_eq_iff in H. specialize (H x). revert H. smap.
Qed.

Lemma env_bind_empty Γ x t1 :
  env_bind Γ x t1 ∅ <-> Γ = {[ x := t1 ]}.
Proof.
  rewrite /env_bind. repeat split; simp.
Qed.

Lemma linbox_mono P Q l :
  □ (P -∗ Q) -∗ linbox l P -∗ linbox l Q.
Proof.
  iIntros "#H P".
  destruct l; simpl; [|iDestruct "P" as "#P"; iModIntro];
  iApply "H"; done.
Qed.

Lemma linbox_sep P Q l :
  linbox l P ∗ linbox l Q ⊢ linbox l (P ∗ Q).
Proof.
  destruct l; simpl; eauto.
  iIntros "[#H #R]". iModIntro.
  iSplitL; eauto.
Qed.

Lemma substitution Γ x v e t :
  substR Γ x v ∗
  rtyped Γ e t -∗
  rtyped (delete x Γ) (subst x v e) t.
Proof.
  iIntros "RH".
  iInduction e as [] "IH" forall (Γ t); simpl;
  iDestruct "RH" as "[R H]"; iDestr "H"; try iDestruct "H" as "[H Q]"; simp.
  - rewrite env_unr_substR //. iSpl; eauto using env_unr_delete.
  - rewrite env_var_substR //.
    eapply (env_var_delete x) in H.
    case_decide; subst; simpl; iFrame; iPureIntro; eauto.
  - iExists _,_,_. iSplit; first done.
    iExists _. iSplit; eauto 6 using env_bind_delete, env_unr_delete.
    rewrite env_bind_substR; eauto.
    case_decide; subst; iFrame.
    iApply linbox_mono; eauto.
    iApply linbox_sep. iFrame.
  - iDestruct (env_split_substR with "R") as "[R1 R2]"; eauto.
    iSpl; eauto using env_split_delete.
    iSplitL "H R1"; (iApply "IH" || iApply "IH1"); eauto with iFrame.
  - rewrite env_unr_substR //.
    eauto using env_unr_delete.
  - iDestruct (env_split_substR with "R") as "[R1 R2]"; eauto.
    iSpl; eauto using env_split_delete.
    iSplitL "H R1"; (iApply "IH" || iApply "IH1"); eauto with iFrame.
  - iDestruct (env_split_substR with "R") as "[R1 R2]"; eauto.
    iSpl; eauto using env_split_delete.
    iSplitL "H R1"; (iApply "IH" || iApply "IH1"); eauto with iFrame.
  - iSpl; eauto. iApply "IH". iFrame.
  - iDestruct (env_split_substR with "R") as "[R1 R2]"; eauto.
    iSpl; first iPureIntro; eauto using env_split_delete, env_unr_delete.
    case_decide; subst.
    { iDestruct "Q" as "%". iSplit; eauto using env_unr_delete.
      eapply env_unr_substR in H. rewrite H.
      iApply "IH1". iFrame. }
    iSplitL "H R1"; iSpl; (iApply "IH" || iApply "IH1"); eauto with iFrame.
  - iSpl; eauto. (iApply "IH" || iApply "IH1"); eauto with iFrame.
Qed.

Fixpoint rtyped0 e t : rProp :=
  match e with
  | Val v => vtyped v t
  | Var x => False
  | Fun x e =>
      ∃ l t1 t2, ⌜⌜ t = FunT l t1 t2 ⌝⌝ ∗
      ∃ Γ, ⌜⌜ env_bind Γ x t1 ∅ ⌝⌝ ∗
      linbox l (rtyped Γ e t2)
  | App e1 e2 =>
      ∃ t1 l,
      rtyped0 e1 (FunT l t1 t) ∗
      rtyped0 e2 t1
  | Unit => ⌜⌜ t = UnitT ⌝⌝
  | Pair e1 e2 =>
      ∃ t1 t2, ⌜⌜ t = PairT t1 t2 ⌝⌝ ∗
      rtyped0 e1 t1 ∗ rtyped0 e2 t2
  | LetPair e1 e2 =>
      ∃ t1 t2,
      rtyped0 e1 (PairT t1 t2) ∗
      rtyped0 e2 (FunT Lin t1 (FunT Lin t2 t))
  | Sum i e =>
      ∃ n (ts : fin n -> type) (i' : fin n), ⌜⌜ t = SumT n ts ⌝⌝ ∗ ⌜⌜ i = i' ⌝⌝ ∗
      rtyped0 e (ts i')
  | MatchSum n e es =>
      ∃ ts,
      rtyped0 e (SumT n ts) ∗
      if decide (n=0) then emp else (∀ i, rtyped0 (es i) (FunT Lin (ts i) t))
  | Fork e =>
      ∃ t1 t2, ⌜⌜ t = FunT Lin t1 t2 ⌝⌝ ∗
      rtyped0 e (FunT Lin (FunT Lin t2 t1) UnitT)
  end.

Lemma rtyped_rtyped0 e t :
  rtyped ∅ e t ⊣⊢ rtyped0 e t.
Proof.
  revert t. induction e; intros; simpl;
  iSplit; iIntros "H";
  try setoid_rewrite env_split_empty;
  try setoid_rewrite env_var_empty;
  try setoid_rewrite env_bind_empty;
  iDestr "H"; simp; eauto using env_unr_empty;
  try iDestruct "H" as "[H Q]";
  repeat (iExists _ || iSplit); eauto using env_unr_empty;
  rewrite ?H ?IHe ?IHe1 ?IHe2; try case_decide; iFrame; eauto using env_unr_empty;
  iIntros (?); setoid_rewrite H; eauto.
Qed.

Lemma substitution0 v t1 t2 x e :
  vtyped v t1 ∗
  rtyped {[ x := t1 ]} e t2 -∗
  rtyped0 (subst x v e) t2.
Proof.
  rewrite -rtyped_rtyped0.
  iIntros "[H Q]".
  iDestruct (substitution _ x v e t2 with "[H Q]") as "H"; iFrame.
  - rewrite /substR lookup_singleton //.
  - rewrite delete_singleton //.
Qed.

Lemma pure_preservation e e' t :
  pure_step e e' ->
  rtyped0 e t -∗ rtyped0 e' t.
Proof.
  intros []; simpl;
  iIntros "H";
  try setoid_rewrite env_bind_empty;
  repeat (iDestr "H" || iDestruct "H" as "[H ?]"); simp;
  repeat (iExists _ || iSplit || case_decide); eauto with iFrame.
  - iApply substitution0. iFrame. by destruct l0.
  - subst. inv_fin i'.
Qed.

Lemma replacement1 k e B :
  ctx1 k ->
  rtyped0 (k e) B -∗ ∃ t, rtyped0 e t ∗ ∀ e', rtyped0 e' t -∗ rtyped0 (k e') B.
Proof.
  destruct 1; simpl; iIntros "H";
  iDestr "H"; try iDestruct "H" as "[H Q]";
  eauto 8 with iFrame.
Qed.

Lemma replacement k e B :
  ctx k ->
  rtyped0 (k e) B ⊣⊢ ∃ t, rtyped0 e t ∗ ∀ e', rtyped0 e' t -∗ rtyped0 (k e') B.
Proof.
  intros Hk.
  iSplit; iIntros "H"; last first.
  { iDestruct "H" as (t) "[H Q]". by iApply "Q". }
  iInduction Hk as [] "IH" forall (B e); simpl.
  { iExists _. iFrame. eauto. } subst.
  iDestruct (replacement1 with "H") as (?) "[H R]"; eauto.
  iDestruct ("IH" with "H") as (?) "[Q H]".
  iExists _. iFrame. iIntros (?) "?".
  iApply "R". iApply "H". done.
Qed.

Ltac solve_ctx := solve [iPureIntro; do 2 eexists; split; last done; eauto using ctx, ctx1].
Ltac solve_step := solve [iPureIntro; do 2 eexists; split; eauto using Ctx_id; simp; eauto using pure_step].

Ltac solve_pr := simp; try (solve_ctx || solve_step).

Lemma pure_progress e t :
  rtyped0 e t -∗ ⌜ (∃ v, e = Val v) ∨
    ∃ k e0, (ctx k ∧ e = k e0) ∧
      ((∃ e', pure_step e0 e') ∨
       (∃ v, e0 = Fork (Val v)) ∨
       (∃ v k, e0 = App (Val $ BarrierV k) (Val v))) ⌝.
Proof.
  iIntros "H".
  iInduction e as [] "IH" forall (t); simpl; eauto;
  iDestr "H";
  try iDestruct "H" as "[H Q]"; simp;
  try iDestruct ("IH" with "H") as %H;
  try iDestruct ("IH1" with "H") as %H;
  try iDestruct ("IH1" with "Q") as %Q; iRight;
  try destruct H; solve_pr;
  try destruct Q; solve_pr;
  destruct H0; simpl; iDestr "H"; solve_pr.
Qed.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Omega.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From libs Require Import edone bcase fset base sltype.
Require Import CTL_def dags demo.

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

Implicit Types (C D L : clause) (S : {fset clause}).

Arguments prune_sub {T p S}.
Prenex Implicits prune_sub.

(** * Pruning *)

Section Prune.
  Variable (F : {fset sform}).
  Hypothesis (sfc_F : sf_closed F).

  Definition U := powerset F.
  Definition S0 := [fset L in U | literalC L && lcons L].

  Lemma Fsub s t X : t \in ssub s -> s \in X -> X \in U -> t \in F.
  Proof.
    move => Hsub sX XU. rewrite powersetE in XU.
    have/(sf_ssub sfc_F)/subP : s \in F by exact: (subP XU).
    by apply.
  Qed.

  Lemma ReqU L C : L \in U -> C \in Req L -> C \in U.
  Proof.
    move => inU. rewrite !inE. case/predU1P => [->|]; first by rewrite RinU.
    case/fimsetP => s. rewrite inE andbC. move: s => [[|p|? ?|s|? ?|? ?] [|]] //= inL ->.
    rewrite powersetU RinU // andbT powersetE fsub1.
    apply: Fsub inL inU. by rewrite /= !inE ssub_refl.
  Qed.

  Lemma SsubU S : S `<=` S0 -> {subset S <= U}.
  Proof. move => sub_S. apply/subP. apply: sub_trans sub_S _. exact: subsep. Qed.

  Definition pAXn L S :=
    [some C in Req L, ~~ suppS S C].
  Definition pAU C S :=
   [some u in C, if u is fAX (fAU s t)^+ then ~~ fulfillsAU S S0 s t C else false].
  Definition pAR C S :=
   [some u in C, if u is fAX (fAR s t)^- then ~~ fulfillsAR S S0 s t C else false].

  Definition pcond L S := [|| pAXn L S, pAU L S | pAR L S].

  Definition DD := prune pcond S0.

  (** ** Pruning yields a demo  *)

  Definition subDD : {subset DD <= U}.
  Proof. apply: SsubU. exact: prune_sub. Qed.

  Lemma AXn_complete_DD : AXn_complete DD.
  Proof.
    move => L C /pruneE. rewrite !negb_or. case/and3P => [/hasPn H _ _] /H {H L}.
    rewrite negbK. case/hasP => L ? ?. by exists L; bcase.
  Qed.

  Lemma fulfillsAU_DD s t L : L \in DD -> fAX (fAU s t)^+ \in L -> fulfillsAU DD S0 s t L.
  Proof.
    move => inDD inL.
    move: (inDD)  => /pruneE. rewrite !negb_or. case/and3P => [_ H _].
    move/hasPn : H => /(_ _ inL). by rewrite negbK.
  Qed.

  Lemma fulfillsAR_DD s t L : L \in DD -> fAX (fAR s t)^- \in L -> fulfillsAR DD S0 s t L.
  Proof.
    move => inDD inL.
    move: (inDD)  => /pruneE. rewrite !negb_or. case/and3P => [_ _ H].
    move/hasPn : H => /(_ _ inL). by rewrite negbK.
  Qed.

  Lemma demoDD_S0 : demo DD S0.
  Proof.
    have lc C : C \in S0 -> lcons C by rewrite inE; bcase.
    have sub : {subset DD <= S0} by apply/subP; exact: prune_sub.
    by split; auto using fulfillsAR_DD, fulfillsAU_DD,AXn_complete_DD.
  Qed.

  Lemma DD_size : size S0 <= 2^(size F).
  Proof. rewrite -powerset_size. apply: subset_size. exact: subsep. Qed.

  Lemma Fs_size : size (Fs DD) <= size F.
  Proof.
    apply : subset_size. apply/subP => s. case/cupP => C /and3P[C1 _ C2].
    move/(subP prune_sub) : C1. rewrite inE => /and3P [H _ _].
    move: H. rewrite powersetE. by move/subP; apply.
  Qed.

  Lemma DD_small_model u L : u \in Fs DD -> L \in DD ->
    exists2 M : fmodel, #|M| <= size F * 2 ^ (2 * (size F) + 1)
                      & exists (w : M), forall s : sform, L |> s -> eval (interp' s) w.
  Proof.
    move => inFs inDD.
    case: (small_models inFs demoDD_S0) => M M1 M2.
    exists M; last exact: M2.
    apply: leq_trans M1 _.
    rewrite addn1 [2 ^ _]expnS expnM -mulnn expnMn.
    rewrite !mulnA. rewrite leq_mul ?DD_size // ?[_ * 2]mulnC -?mulnA ?leq_mul2l.
    by rewrite leq_mul ?DD_size ?Fs_size.
  Qed.

  Lemma DD_sat u L : u \in Fs DD -> L \in DD ->
    exists (M : fmodel) (w : M), forall s : sform, L |> s -> eval (interp' s) w.
  Proof. move => inFs inD. case: (DD_small_model inFs inD) => M _ ?. by exists M. Qed.

  (** ** Refutation Calculus *)

  Definition coref (ref : clause -> Prop) S :=
    forall C, C \in S0 `\` S -> ref C.

  Inductive ref : clause -> Prop :=
  | R1 S C : C \in U -> coref ref S -> ~~ suppS S C -> ref C
  | R2 C D : D \in Req C -> ref D -> ref C
  | R3 S C : S `<=` S0 -> coref ref S -> C \in S -> pAR C S -> ref C
  | R4 S C : S `<=` S0 -> coref ref S -> C \in S -> pAU C S -> ref C.

  Lemma corefD1 S C : ref C -> coref ref S -> coref ref (S `\` [fset C]).
  Proof.
    move => rC coS D. rewrite !in_fsetD negb_and andb_orr -in_fsetD negbK in_fset1.
    case/orP; first exact: coS. by case/andP => [_ /eqP->].
  Qed.

  Lemma coref_DD : coref ref DD.
  Proof.
    apply: prune_myind => [C|C S]; first by rewrite inE andbN.
    case/or3P.
    - case/hasP => D D1 D2 inS corefS H. apply: corefD1 (corefS).
      apply: R2 (D1) _ => //. apply: R1 D2 => //. apply: ReqU D1. exact: (SsubU H).
    - move => H inS corefS ?. apply: corefD1 (corefS). exact: R4 H.
    - move => H inS corefS ?. apply: corefD1 (corefS). exact: R3 H.
  Qed.

  Lemma DD_refute C : C \in U -> ~~ suppS DD C -> ref C.
  Proof. move => inU. apply: R1 inU _  => //. exact: coref_DD. Qed.

End Prune.

(** ** Refutation Completeness *)

Theorem ref_compl (F C: clause) u (sfc_F : sf_closed F) (inhF : u \in F) (inU : C \in U F) :
      (ref F C)
    + (exists2 M:fmodel, #|M| <= size F * 2 ^ (2 * size F + 1) &
       exists w:M, forall s, s \in C -> eval (interp' s) w).
Proof.
  case: (boolP (suppS (DD F) C)) => H; [right|left]; last exact: DD_refute.
  case: (fset0Vmem C) => [E|[s inC]];subst.
  - exists unit_model.
    + rewrite card_unit muln_gt0 expn_gt0 /= andbT. apply/size_gt0P. by exists u.
    + exists tt => s. by rewrite inE.
  - case/hasP : H => D D1 /allP H. move: (H _ inC)=>/suppE/emptyPn [v inD].
    have inFs : v \in Fs (DD F) by apply/cupP; exists D; bcase.
    case: (DD_small_model inFs D1) => M ? [w Hw]. exists M => //; exists w.
    move => t /H. exact: Hw.
Qed.


Require Export Iron.Language.SystemF2Effect.Type.Relation.KindT.Base.

(* Weaken store properties in kind judgement. *)
Lemma kind_stprops_snoc
 : forall ke sp p t k
 ,  KindT ke sp        t k
 -> KindT ke (p <: sp) t k.
Proof.
 intros. gen ke k.
 induction t; intros; inverts_kind; burn.

 Case "TCon2".
  destruct tc. norm. inverts H2.
  eapply KiCon2.
  destruct t1. simpl in *. eauto.
  eauto. eauto.
Qed.
Hint Resolve kind_stprops_snoc.

Lemma kind_stprops_cons
 :  forall ke sp p t k
 ,  KindT ke sp t k
 -> KindT ke (sp :> p) t k.
Proof.
 intros. gen ke k.
 induction t; intros; inverts_kind; burn.

 Case "TCon2".
  destruct tc. snorm. inverts H2.
  eapply KiCon2; eauto.
  destruct t1. snorm.
Qed.
Hint Resolve kind_stprops_cons.


From isla Require Import opsem.

Definition a10 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 13%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x10" [] (RegVal_Base (Val_Symbolic 13%Z)) Mk_annot :t:
  Smt (DefineConst 14%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 13%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x1%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "x10" [] (RegVal_Base (Val_Symbolic 14%Z)) Mk_annot :t:
  WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
  tnil
.