Require Import GLS_PSGLS_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 GLS_PSGLS_list_lems.
Require Import dd_fc.
Require Import PeanoNat.
Require Import strong_inductionT.
Require Import PSGLS_termination_measure.
Require Import PSGLS_termination.
Require Import GLS_exch.
Require Import GLS_ctr.
Require Import GLS_wkn.
Require Import GLS_PSGLS_remove_list.
Require Import GLS_PSGLS_dec.
Require Import GLS_inv_ImpR_ImpL.
Require Import Lia.

Delimit Scope My_scope with M.
Open Scope My_scope.
Set Implicit Arguments.

Theorem GLS_cut_adm_main : forall n k A s Γ0 Γ1 Δ0 Δ1,
                      (n = size_form A) ->
                      (k = mhd s) ->
                      (s = (Γ0 ++ Γ1, Δ0 ++ Δ1)) ->
                      (GLS_prv (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)) ->
                      (GLS_prv (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)) ->
                      (GLS_prv s).
Proof.
(* The proof is by induction on, first, size_form of the cut formula and on, second, the mhd
   of the sequent-conclusion. *)
(* We set up the strong induction on n properly first. *)
pose (d:=strong_inductionT (fun (x:nat) => forall k A s Γ0 Γ1 Δ0 Δ1,
                      x = size_form A ->
                      (k = mhd s) ->
                      (s = (Γ0 ++ Γ1, Δ0 ++ Δ1)) ->
                      ((GLS_prv (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)) ->
                      (GLS_prv (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)) ->
                      (GLS_prv s)))).
apply d. clear d. intros n PIH.
pose (d:=strong_inductionT (fun (x:nat) => forall A s Γ0 Γ1 Δ0 Δ1,
                      n = size_form A ->
                      (x = mhd s) ->
                      (s = (Γ0 ++ Γ1, Δ0 ++ Δ1)) ->
                      ((GLS_prv (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)) ->
                      (GLS_prv (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)) ->
                      (GLS_prv s)))).
apply d. clear d. intros k SIH.

(* Now we do the actual proof-theoretical work. *)
assert (DersNilF: dersrec GLS_rules (fun _ : Seq => False) []).
apply dersrec_nil.
assert (DersNilT: dersrec GLS_rules (fun _ : Seq => True) []).
apply dersrec_nil.
assert (PSDersNilF: dersrec PSGLS_rules (fun _ : Seq => False) []).
apply dersrec_nil.
assert (PSDersNilT: dersrec PSGLS_rules (fun _ : Seq => True) []).
apply dersrec_nil.

intros A s Γ0 Γ1 Δ0 Δ1 size MHD E D0 D1. inversion D0. inversion H.
inversion D1. inversion H0.

inversion X ; subst.

(* Left rule is IdP *)
- inversion H1. subst. apply list_split_form in H3. repeat destruct H3.
  * destruct s.
    + repeat destruct p. subst. inversion X1.
    (* Right rule is IdP *)
    { inversion H. subst. assert (J0 : InT (# P0) (Γ0 ++ # P :: Γ1)). rewrite <- H6. apply InT_or_app.
      right. apply InT_eq. apply InT_app_or in J0. destruct J0.
      - apply InT_split in i. destruct i. destruct s. subst. rewrite H2. repeat rewrite <- app_assoc.
        assert (IdPRule [] (x ++ (# P0 :: x0) ++ Γ1, Δ2 ++ # P0 :: Δ3)). apply IdPRule_I. apply IdP in H0.
        pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
        (ps:=[]) (x ++ (# P0 :: x0) ++ Γ1, Δ2 ++ # P0 :: Δ3) H0 DersNilF). assumption.
      - inversion i.
        + inversion H3. subst.
          assert (IdPRule [] (Γ2 ++ # P0 :: Γ3, Δ2 ++ # P0 :: Δ3)). apply IdPRule_I. apply IdP in H0.
          pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
          (ps:=[]) (Γ2 ++ # P0 :: Γ3, Δ2 ++ # P0 :: Δ3) H0 DersNilF). assumption.
        + apply InT_split in H3. destruct H3. destruct s. subst.
          assert (J0 : InT (# P0) (Γ2 ++ # P :: Γ3)). rewrite H2. apply InT_or_app.
          right. apply InT_or_app. right. apply InT_eq. apply InT_split in J0. destruct J0. destruct  s.
          rewrite e. assert (IdPRule [] (x1 ++ # P0 :: x2, Δ2 ++ # P0 :: Δ3)).
          apply IdPRule_I. apply IdP in H0.
          pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
          (ps:=[]) (x1 ++ # P0 :: x2, Δ2 ++ # P0 :: Δ3) H0 DersNilF). assumption. }
    (* Right rule is BotL *)
    { inversion H. subst. assert (J0 : InT (⊥) (Γ0 ++ # P :: Γ1)). rewrite <- H6. apply InT_or_app.
      right. apply InT_eq. apply InT_app_or in J0. destruct J0.
      - apply InT_split in i. destruct i. destruct s. subst. rewrite H2. rewrite <- app_assoc.
        assert (BotLRule [] (x ++ (⊥ :: x0) ++ Γ1, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
        pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
        (ps:=[]) (x ++ (⊥ :: x0) ++ Γ1, Δ0 ++ Δ1) H0 DersNilF). assumption.
      - inversion i.
        + inversion H3.
        + apply InT_split in H3. destruct H3. destruct s. subst. rewrite H2. rewrite app_assoc.
          assert (BotLRule [] ((Γ0 ++ x) ++ ⊥ :: x0, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
          pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
          (ps:=[]) ((Γ0 ++ x) ++ ⊥ :: x0, Δ0 ++ Δ1) H0 DersNilF). assumption. }
    (* Right rule is ImpR *)
    { inversion H. subst. assert (InT  # P (Γ0 ++ Γ1)). rewrite <- H2. apply InT_or_app.
      right. apply InT_eq. apply InT_app_or in H0. destruct H0.
      - apply InT_split in i. destruct i.
        destruct s. subst. repeat rewrite <- app_assoc in D1. simpl in D1.
        assert (E0: derrec_height D1 = derrec_height D1). reflexivity.
        assert (J0 : ctr_L # P (x ++ # P :: x0 ++ # P :: Γ1, Δ0 ++ Δ1)
        (x ++ # P :: x0 ++ Γ1, Δ0 ++ Δ1)). apply ctr_LI.
        pose (@GLS_hpadm_ctr_L (derrec_height D1) (x ++ # P :: x0 ++ # P :: Γ1, Δ0 ++ Δ1)
        D1 E0 (x ++ # P :: x0 ++ Γ1, Δ0 ++ Δ1) (# P) J0). destruct s. clear l. rewrite H2.
        rewrite <- app_assoc. rewrite H7. assumption.
      - apply InT_split in i. destruct i. destruct s. subst.
        assert (E0: derrec_height D1 = derrec_height D1). reflexivity.
        assert (J0 : ctr_L # P (Γ0 ++ # P :: x ++ # P :: x0, Δ0 ++ Δ1)
        (Γ0 ++ # P :: x ++ x0, Δ0 ++ Δ1)). apply ctr_LI.
        pose (@GLS_hpadm_ctr_L (derrec_height D1) (Γ0 ++ # P :: x ++ # P :: x0, Δ0 ++ Δ1)
        D1 E0 (Γ0 ++ # P :: x ++ x0, Δ0 ++ Δ1) (# P) J0). destruct s. clear l. rewrite H2.
        assert (J5 : list_exch_L (Γ0 ++ # P :: x ++ x0, Δ0 ++ Δ1) (Γ0 ++ x ++ # P :: x0, Δ0 ++ Δ1)).
        assert (Γ0 ++ # P :: x ++ x0 = Γ0 ++ [# P] ++ x ++ [] ++  x0). reflexivity. rewrite H0. clear H0.
        assert (Γ0 ++ x ++ # P :: x0 = Γ0 ++ [] ++ x ++ [# P] ++ x0). reflexivity. rewrite H0. clear H0.
        apply list_exch_LI. pose (GLS_adm_list_exch_L x1 J5). rewrite H7. assumption. }
    (* Right rule is ImpL *)
    { inversion H. subst. assert (InT  # P (Γ0 ++ Γ1)). rewrite <- H2. apply InT_or_app.
      right. apply InT_eq. apply InT_app_or in H0. destruct H0.
      - apply InT_split in i. destruct i.
        destruct s. subst. repeat rewrite <- app_assoc in D1. simpl in D1.
        assert (E0: derrec_height D1 = derrec_height D1). reflexivity.
        assert (J0 : ctr_L # P (x ++ # P :: x0 ++ # P :: Γ1, Δ0 ++ Δ1)
        (x ++ # P :: x0 ++ Γ1, Δ0 ++ Δ1)). apply ctr_LI.
        pose (@GLS_hpadm_ctr_L (derrec_height D1) (x ++ # P :: x0 ++ # P :: Γ1, Δ0 ++ Δ1)
        D1 E0 (x ++ # P :: x0 ++ Γ1, Δ0 ++ Δ1) (# P) J0). destruct s. clear l. rewrite H2.
        rewrite <- app_assoc. rewrite H7. assumption.
      - apply InT_split in i. destruct i. destruct s. subst.
        assert (E0: derrec_height D1 = derrec_height D1). reflexivity.
        assert (J0 : ctr_L # P (Γ0 ++ # P :: x ++ # P :: x0, Δ0 ++ Δ1)
        (Γ0 ++ # P :: x ++ x0, Δ0 ++ Δ1)). apply ctr_LI.
        pose (@GLS_hpadm_ctr_L (derrec_height D1) (Γ0 ++ # P :: x ++ # P :: x0, Δ0 ++ Δ1)
        D1 E0 (Γ0 ++ # P :: x ++ x0, Δ0 ++ Δ1) (# P) J0). destruct s. clear l. rewrite H2.
        assert (J5 : list_exch_L (Γ0 ++ # P :: x ++ x0, Δ0 ++ Δ1) (Γ0 ++ x ++ # P :: x0, Δ0 ++ Δ1)).
        assert (Γ0 ++ # P :: x ++ x0 = Γ0 ++ [# P] ++ x ++ [] ++  x0). reflexivity. rewrite H0. clear H0.
        assert (Γ0 ++ x ++ # P :: x0 = Γ0 ++ [] ++ x ++ [# P] ++ x0). reflexivity. rewrite H0. clear H0.
        apply list_exch_LI. pose (GLS_adm_list_exch_L x1 J5). rewrite H7. assumption. }
    (* Right rule is GLR *)
    { inversion X3. subst. assert (InT  # P (Γ0 ++ Γ1)). rewrite <- H2. apply InT_or_app.
      right. apply InT_eq. apply InT_app_or in H. destruct H.
      - apply InT_split in i. destruct i.
        destruct s. subst. repeat rewrite <- app_assoc in D1. simpl in D1.
        assert (E0: derrec_height D1 = derrec_height D1). reflexivity.
        assert (J0 : ctr_L # P (x ++ # P :: x0 ++ # P :: Γ1, Δ0 ++ Δ1)
        (x ++ # P :: x0 ++ Γ1, Δ0 ++ Δ1)). apply ctr_LI.
        pose (@GLS_hpadm_ctr_L (derrec_height D1) (x ++ # P :: x0 ++ # P :: Γ1, Δ0 ++ Δ1)
        D1 E0 (x ++ # P :: x0 ++ Γ1, Δ0 ++ Δ1) (# P) J0). destruct s. clear l. rewrite H2.
        rewrite <- app_assoc. rewrite H6. assumption.
      - apply InT_split in i. destruct i. destruct s. subst.
        assert (E0: derrec_height D1 = derrec_height D1). reflexivity.
        assert (J0 : ctr_L # P (Γ0 ++ # P :: x ++ # P :: x0, Δ0 ++ Δ1)
        (Γ0 ++ # P :: x ++ x0, Δ0 ++ Δ1)). apply ctr_LI.
        pose (@GLS_hpadm_ctr_L (derrec_height D1) (Γ0 ++ # P :: x ++ # P :: x0, Δ0 ++ Δ1)
        D1 E0 (Γ0 ++ # P :: x ++ x0, Δ0 ++ Δ1) (# P) J0). destruct s. clear l. rewrite H2.
        assert (J5 : list_exch_L (Γ0 ++ # P :: x ++ x0, Δ0 ++ Δ1) (Γ0 ++ x ++ # P :: x0, Δ0 ++ Δ1)).
        assert (Γ0 ++ # P :: x ++ x0 = Γ0 ++ [# P] ++ x ++ [] ++  x0). reflexivity. rewrite H. clear H.
        assert (Γ0 ++ x ++ # P :: x0 = Γ0 ++ [] ++ x ++ [# P] ++ x0). reflexivity. rewrite H. clear H.
        apply list_exch_LI. pose (GLS_adm_list_exch_L x1 J5). rewrite H6. assumption. }
    + repeat destruct s. repeat destruct p. subst. assert (IdPRule []  (Γ2 ++ # P :: Γ3, (Δ0 ++ x0) ++ # P :: Δ3)).
      apply IdPRule_I. rewrite <- app_assoc in H. apply IdP in H.
      pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
      (ps:=[])  (Γ2 ++ # P :: Γ3, Δ0 ++ x0 ++ # P :: Δ3) H DersNilF). assumption.
  * repeat destruct s. repeat destruct p. subst. assert (IdPRule [] (Γ2 ++ # P :: Γ3, Δ2 ++ # P :: x ++ Δ1)).
    apply IdPRule_I. apply IdP in H. rewrite <- app_assoc.
    pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
    (ps:=[]) (Γ2 ++ # P :: Γ3, Δ2 ++ (# P :: x) ++ Δ1) H DersNilF). assumption.

(* Left rule is BotL *)
- inversion H1. subst. assert (BotLRule [] (Γ2 ++ ⊥ :: Γ3, Δ0 ++ Δ1)).
  apply BotLRule_I. apply BotL in H.
  pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
  (ps:=[]) (Γ2 ++ ⊥ :: Γ3, Δ0 ++ Δ1) H DersNilF).
  assumption.

(* Left rule is ImpR *)
- inversion H1. subst. apply list_split_form in H3. destruct H3.
  * destruct s.
    + repeat destruct p. subst. inversion X1.
      (* Right rule is IdP *)
      { inversion H. subst. assert (J0 : InT (# P) (Γ0 ++ (A0 → B) :: Γ1)). rewrite <- H6. apply InT_or_app.
        right. apply InT_eq. apply InT_app_or in J0. destruct J0.
        - apply InT_split in i. destruct i. destruct s. subst. rewrite H2. rewrite <- app_assoc.
          assert (IdPRule [] (x ++ (# P :: x0) ++ Γ1, Δ2 ++ # P :: Δ3)). apply IdPRule_I. apply IdP in H0.
          pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
          (ps:=[]) (x ++ (# P :: x0) ++ Γ1, Δ2 ++ # P :: Δ3) H0 DersNilF). assumption.
        - inversion i.
          * inversion H3.
          * apply InT_split in H3. destruct H3. destruct s. subst. rewrite H2. rewrite app_assoc.
            assert (IdPRule [] ((Γ0 ++ x) ++ # P :: x0, Δ2 ++ # P :: Δ3)). apply IdPRule_I. apply IdP in H0.
            pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
            (ps:=[]) ((Γ0 ++ x) ++ # P :: x0, Δ2 ++ # P :: Δ3) H0 DersNilF). assumption. }
      (* Right rule is BotL *)
      { inversion H. subst. rewrite H2. assert (J0 : InT (⊥) (Γ0 ++ (A0 → B) :: Γ1)). rewrite <- H6. apply InT_or_app.
        right. apply InT_eq. apply InT_app_or in J0. destruct J0.
        - apply InT_split in i. destruct i. destruct s. subst. rewrite <- app_assoc.
          assert (BotLRule [] (x ++ (⊥ :: x0) ++ Γ1, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
          pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
          (ps:=[]) (x ++ (⊥ :: x0) ++ Γ1, Δ0 ++ Δ1) H0 DersNilF). assumption.
        - inversion i.
          * inversion H3.
          * apply InT_split in H3. destruct H3. destruct s. subst. rewrite app_assoc.
            assert (BotLRule [] ((Γ0 ++ x) ++ ⊥ :: x0, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
            pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
            (ps:=[]) ((Γ0 ++ x) ++ ⊥ :: x0, Δ0 ++ Δ1) H0 DersNilF). assumption. }
      (* Right rule is ImpR *)
      { inversion H. subst. inversion X0. inversion X2. subst. clear X4. clear X6. rewrite <- H7 in D1.
        assert (J1 : list_exch_L (Γ4 ++ A :: Γ5, Δ2 ++ B0 :: Δ3) (A :: Γ0 ++ A0 → B :: Γ1, Δ2 ++ B0 :: Δ3)).
        assert (Γ4 ++ A :: Γ5 = [] ++ [] ++ Γ4 ++ [A] ++ Γ5). reflexivity. rewrite H0. clear H0.
        assert (A :: Γ0 ++ A0 → B :: Γ1 = [] ++ [A] ++ Γ4 ++ [] ++ Γ5). rewrite <- H6. reflexivity.
        rewrite H0. clear H0. apply list_exch_LI. pose (d:=GLS_adm_list_exch_L X5 J1). rewrite H2.
        assert (ImpRRule [([] ++ A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3)] ([] ++ Γ0 ++ Γ1, Δ2 ++ A → B0 :: Δ3)). apply ImpRRule_I.
        simpl in H0.
        assert (J3: PSGLS_rules [(A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3)] (Γ0 ++ Γ1, Δ2 ++ A → B0 :: Δ3)).
        apply PSImpR ; try intro ; try apply f ; try rewrite <- H7 ; try auto ; try assumption.
        assert (J31: GLS_rules [(A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3)] (Γ0 ++ Γ1, Δ2 ++ A → B0 :: Δ3)).
        apply ImpR ; try assumption.
        assert (J21: In (A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3) [(A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3)]). apply in_eq.
        pose (RA_mhd_decreases J3 _ J21). rewrite <- H7 in SIH.
        assert (J5: size_form (A0 → B) = size_form (A0 → B)). reflexivity.
        assert (J6: mhd (A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3) = mhd (A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3)). reflexivity.
        assert (J7 : (A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3) = ((A :: Γ0) ++ Γ1, [] ++ Δ2 ++ B0 :: Δ3)). reflexivity.
        pose (d0:=@SIH (mhd (A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3)) l (A0 → B) (A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3)
        (A :: Γ0) Γ1 [] (Δ2 ++ B0 :: Δ3) J5 J6 J7). simpl in d0.
        assert (J8 : list_exch_R (Γ0 ++ Γ1, Δ0 ++ A0 → B :: Δ1) (Γ0 ++ Γ1, A0 → B :: Δ2 ++ A → B0 :: Δ3)).
        assert (Δ0 ++ A0 → B :: Δ1 = [] ++ [] ++ Δ0 ++ [A0 → B] ++ Δ1). reflexivity. rewrite H3. clear H3.
        assert (A0 → B :: Δ2 ++ A → B0 :: Δ3 = [] ++ [A0 → B] ++ Δ0 ++ [] ++ Δ1). rewrite H7.
        reflexivity. rewrite H3. clear H3. apply list_exch_RI. pose (d1:=GLS_adm_list_exch_R D0 J8).
        assert (ImpRRule [([] ++ A :: Γ0 ++ Γ1, (A0 → B :: Δ2) ++ B0 :: Δ3)] ([] ++ Γ0 ++ Γ1, (A0 → B :: Δ2) ++ A → B0 :: Δ3)).
        apply ImpRRule_I. simpl in H3. pose (d2:=ImpR_inv d1 H3). pose (d3:=d0 d2 d). pose (dlCons d3 DersNilF).
        apply ImpR in H0 ; try intro ; try apply f ; try rewrite <- H7 ; try auto ; try assumption.
        pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3)]) (Γ0 ++ Γ1, Δ2 ++ A → B0 :: Δ3) H0 d4). assumption. }
      (* Right rule is ImpL *)
      { inversion H. subst. inversion X0. inversion X2. subst. clear X4. inversion X6. subst. clear X7.
        clear X6. apply list_split_form in H6. destruct H6.
        - destruct s.
          * repeat destruct p. inversion e0. subst. rewrite H2.
            assert (J1 : list_exch_L (Γ2 ++ A0 :: Γ3, Δ0 ++ B :: Δ1) (A0 :: Γ0 ++ Γ1, Δ0 ++ B :: Δ1)).
            assert (Γ2 ++ A0 :: Γ3 = [] ++ [] ++ Γ2 ++ [A0] ++ Γ3). reflexivity. rewrite H0. clear H0.
            assert (A0 :: Γ0 ++ Γ1 = [] ++ [A0] ++ Γ2 ++ [] ++ Γ3). rewrite <- H2. reflexivity.
            rewrite H0. clear H0. apply list_exch_LI. pose (d:=GLS_adm_list_exch_L X3 J1).
            assert (J2 : list_exch_R (A0 :: Γ0 ++ Γ1, Δ0 ++ B :: Δ1) (A0 :: Γ0 ++ Γ1, B :: Δ2 ++ Δ3)).
            assert (Δ0 ++ B :: Δ1 = [] ++ [] ++ Δ0 ++ [B] ++ Δ1). reflexivity. rewrite H0. clear H0.
            assert (B :: Δ2 ++ Δ3 = [] ++ [B] ++ Δ0 ++ [] ++ Δ1). rewrite H7. reflexivity. rewrite H0. clear H0.
            apply list_exch_RI. pose (d0:=GLS_adm_list_exch_R d J2).
            assert (J3: size_form A0 < size_form (A0 → B)). simpl. lia.
            assert (J4: size_form A0 = size_form A0). reflexivity.
            assert (J5: mhd (Γ2 ++ Γ3, B :: Δ2 ++ Δ3) = mhd (Γ2 ++ Γ3, B :: Δ2 ++ Δ3)). reflexivity.
            assert (J6: (Γ2 ++ Γ3, B :: Δ2 ++ Δ3) = ([] ++ Γ2 ++ Γ3, (B :: Δ2) ++ Δ3)). reflexivity.
            pose (d1:=PIH _ J3 (mhd (Γ2 ++ Γ3, B :: Δ2 ++ Δ3)) A0 (Γ2 ++ Γ3, B :: Δ2 ++ Δ3) [] (Γ2 ++ Γ3)
            (B :: Δ2) Δ3 J4 J5 J6). simpl in d1.
            assert (J7 : wkn_R B (Γ2 ++ Γ3, Δ2 ++ A0 :: Δ3) (Γ2 ++ Γ3, B :: Δ2 ++ A0 :: Δ3)).
            assert ((Γ2 ++ Γ3, Δ2 ++ A0 :: Δ3) = (Γ2 ++ Γ3, [] ++ Δ2 ++ A0 :: Δ3)). reflexivity. rewrite H0. clear H0.
            assert ((Γ2 ++ Γ3, B :: Δ2 ++ A0 :: Δ3) = (Γ2 ++ Γ3, [] ++ B :: Δ2 ++ A0 :: Δ3)).
            reflexivity. rewrite H0. clear H0. apply wkn_RI. rewrite <- H2 in X5.
            assert (J8 : derrec_height X5 = derrec_height X5).
            reflexivity. pose (GLS_wkn_R X5 J8 J7). destruct s. rewrite <- H2 in d0. pose (d2:=d1 x d0).
            assert (J9: size_form B < size_form (A0 → B)). simpl. lia.
            assert (J10: size_form B = size_form B). reflexivity.
            assert (J11: mhd (Γ2 ++ Γ3, Δ2 ++ Δ3) = mhd (Γ2 ++ Γ3, Δ2 ++ Δ3)). reflexivity.
            assert (J12: (Γ2 ++ Γ3, Δ2 ++ Δ3) = (Γ2 ++ Γ3, [] ++ Δ2 ++ Δ3)). reflexivity.
            pose (d3:=PIH _ J9 (mhd (Γ2 ++ Γ3, Δ2 ++ Δ3)) B (Γ2 ++ Γ3, Δ2 ++ Δ3) Γ2 Γ3
            [] (Δ2 ++ Δ3) J10 J11 J12). simpl in d3.
            assert (J30 : list_exch_L (Γ0 ++ B :: Γ1, Δ2 ++ Δ3) (B :: Γ2 ++ Γ3, Δ2 ++ Δ3)).
            assert (Γ0 ++ B :: Γ1 = [] ++ [] ++ Γ0 ++ [B] ++ Γ1). reflexivity. rewrite H0. clear H0.
            assert (B :: Γ2 ++ Γ3 = [] ++ [B] ++ Γ0 ++ [] ++ Γ1). rewrite H2. reflexivity.
            rewrite H0. clear H0. apply list_exch_LI. pose (d4:=GLS_adm_list_exch_L X4 J30).
            assert (J40 : list_exch_L (B :: Γ2 ++ Γ3, Δ2 ++ Δ3) (Γ2 ++ B :: Γ3, Δ2 ++ Δ3)).
            assert (Γ2 ++ B :: Γ3 = [] ++ [] ++ Γ2 ++ [B] ++ Γ3). reflexivity. rewrite H0. clear H0.
            assert (B :: Γ2 ++ Γ3 = [] ++ [B] ++ Γ2 ++ [] ++ Γ3). reflexivity. rewrite H0. clear H0.
            apply list_exch_LI. pose (d5:=GLS_adm_list_exch_L d4 J40). pose (d3 d2 d5). rewrite <- H2. assumption.
          * repeat destruct s. repeat destruct p. subst. rewrite H2. repeat rewrite <- app_assoc in X5. repeat rewrite <- app_assoc in X4.
            simpl in X4. simpl in X5.
            assert (J1 : list_exch_R (Γ0 ++ x0 ++ A → B0 :: Γ5, Δ0 ++ A0 → B :: Δ1) (Γ0 ++ x0 ++ A → B0 :: Γ5, A0 → B :: Δ2 ++ Δ3)).
            assert (Δ0 ++ A0 → B :: Δ1 = [] ++ [] ++ Δ0 ++ [A0 → B] ++ Δ1). reflexivity. rewrite H0. clear H0.
            assert (A0 → B :: Δ2 ++ Δ3 = [] ++ [A0 → B] ++ Δ0 ++ [] ++ Δ1). rewrite H7. reflexivity. rewrite H0. clear H0. apply list_exch_RI.
            pose (d:=GLS_adm_list_exch_R D0 J1).
            assert (ImpLRule [((Γ0 ++ x0) ++ Γ5, Δ2 ++ A :: Δ3); ((Γ0 ++ x0) ++ B0 :: Γ5, Δ2 ++ Δ3)] ((Γ0 ++ x0) ++ A → B0 :: Γ5, Δ2 ++ Δ3)).
            apply ImpLRule_I. simpl in H0. repeat rewrite <- app_assoc in H0.
            assert (J3: PSGLS_rules [(Γ0 ++ x0 ++ Γ5, Δ2 ++ A :: Δ3); (Γ0 ++ x0 ++ B0 :: Γ5, Δ2 ++ Δ3)] (Γ0 ++ x0 ++ A → B0 :: Γ5, Δ2 ++ Δ3)).
            apply PSImpL ; try intro ; try apply f ; try rewrite <- H7 ; try repeat rewrite <- app_assoc ; try auto ; try assumption.
            assert (J21: In (Γ0 ++ x0 ++ Γ5, Δ2 ++ A :: Δ3) [(Γ0 ++ x0 ++ Γ5, Δ2 ++ A :: Δ3); (Γ0 ++ x0 ++ B0 :: Γ5, Δ2 ++ Δ3)]). apply in_eq.
            pose (RA_mhd_decreases J3 _ J21). rewrite <- H7 in SIH.
            assert (J5: size_form (A0 → B) = size_form (A0 → B)). reflexivity.
            assert (J6: mhd (Γ0 ++ x0 ++ Γ5, Δ2 ++ A :: Δ3) = mhd (Γ0 ++ x0 ++ Γ5, Δ2 ++ A :: Δ3)). reflexivity.
            assert (J7 : (Γ0 ++ x0 ++ Γ5, Δ2 ++ A :: Δ3) = (Γ0 ++ x0 ++ Γ5, [] ++ Δ2 ++ A :: Δ3)). reflexivity.
            pose (d0:=@SIH (mhd (Γ0 ++ x0 ++ Γ5, Δ2 ++ A :: Δ3)) l (A0 → B) (Γ0 ++ x0 ++ Γ5, Δ2 ++ A :: Δ3)
            Γ0 (x0 ++ Γ5) [] (Δ2 ++ A :: Δ3) J5 J6 J7). simpl in d0.
            assert (J22: In (Γ0 ++ x0 ++ B0 :: Γ5, Δ2 ++ Δ3) [(Γ0 ++ x0 ++ Γ5, Δ2 ++ A :: Δ3); (Γ0 ++ x0 ++ B0 :: Γ5, Δ2 ++ Δ3)]).
            apply in_cons. apply in_eq. pose (RA_mhd_decreases J3 _ J22).
            assert (J8: size_form (A0 → B) = size_form (A0 → B)). reflexivity.
            assert (J9: mhd (Γ0 ++ x0 ++ B0 :: Γ5, Δ2 ++ Δ3) = mhd (Γ0 ++ x0 ++ B0 :: Γ5, Δ2 ++ Δ3)). reflexivity.
            assert (J10: (Γ0 ++ x0 ++ B0 :: Γ5, Δ2 ++ Δ3) = (Γ0 ++ x0 ++ B0 :: Γ5, [] ++ Δ2 ++ Δ3)). reflexivity.
            pose (d1:=@SIH (mhd (Γ0 ++ x0 ++ B0 :: Γ5, Δ2 ++ Δ3)) l0 (A0 → B) (Γ0 ++ x0 ++ B0 :: Γ5, Δ2 ++ Δ3)
            Γ0 (x0 ++ B0 :: Γ5) [] (Δ2 ++ Δ3) J8 J9 J10). simpl in d1.
            assert (ImpLRule [((Γ0 ++ x0) ++ Γ5, (A0 → B :: Δ2) ++ A :: Δ3); ((Γ0 ++ x0) ++ B0 :: Γ5, (A0 → B :: Δ2) ++ Δ3)] ((Γ0 ++ x0) ++ A → B0 :: Γ5, (A0 → B :: Δ2) ++ Δ3)).
            apply ImpLRule_I. repeat rewrite <- app_assoc in H3. pose (ImpL_inv d H3). destruct p as [d2 d3].
            pose (d4:=d0 d2 X5). pose (d5:=d1 d3 X4). apply ImpL in H0 ; try intro ; try apply f ; try repeat rewrite <- app_assoc ; try rewrite <- H7 ;
            try repeat rewrite app_nil_r ; try auto ; try assumption. pose (dlCons d5 DersNilF). pose (dlCons d4 d6).
            pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
            (ps:=[(Γ0 ++ x0 ++ Γ5, Δ2 ++ A :: Δ3); (Γ0 ++ x0 ++ B0 :: Γ5, Δ2 ++ Δ3)]) (Γ0 ++ x0 ++ A → B0 :: Γ5, Δ2 ++ Δ3) H0 d7).
            assumption.
        - repeat destruct s. repeat destruct p. subst. rewrite H2. rewrite <- app_assoc. rewrite <- app_assoc in D0.
          assert (J1 : list_exch_R (Γ4 ++ (A → B0 :: x) ++ Γ1, Δ0 ++ A0 → B :: Δ1) (Γ4 ++ (A → B0 :: x) ++ Γ1, A0 → B :: Δ2 ++ Δ3)).
          assert (Δ0 ++ A0 → B :: Δ1 = [] ++ [] ++ Δ0 ++ [A0 → B] ++ Δ1). reflexivity. rewrite H0. clear H0.
          assert (A0 → B :: Δ2 ++ Δ3 = [] ++ [A0 → B] ++ Δ0 ++ [] ++ Δ1). rewrite H7. reflexivity. rewrite H0. clear H0. apply list_exch_RI.
          pose (d:=GLS_adm_list_exch_R D0 J1).
          assert (ImpLRule [(Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ4 ++ (B0 :: x) ++ Γ1, Δ2 ++ Δ3)] (Γ4 ++ (A → B0 :: x) ++ Γ1, Δ2 ++ Δ3)).
          apply ImpLRule_I. simpl in H0.
          assert (J3: PSGLS_rules [(Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ4 ++ B0 :: x ++ Γ1, Δ2 ++ Δ3)] (Γ4 ++ A → B0 :: x ++ Γ1, Δ2 ++ Δ3)).
          apply PSImpL ; try intro ; try apply f ; try rewrite <- H7 ; try repeat rewrite <- app_assoc ; try auto ; try assumption.
          assert (J21: In (Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3) [(Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ4 ++ B0 :: x ++ Γ1, Δ2 ++ Δ3)]). apply in_eq.
          pose (RA_mhd_decreases J3 _ J21). rewrite <- H7 in SIH. rewrite <- app_assoc in SIH.
          assert (J5: size_form (A0 → B) = size_form (A0 → B)). reflexivity.
          assert (J6: mhd (Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3) = mhd (Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3)). reflexivity.
          assert (J7 : (Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3) = ((Γ4 ++ x) ++ Γ1, [] ++ Δ2 ++ A :: Δ3)). rewrite <- app_assoc. reflexivity.
          pose (d0:=@SIH (mhd (Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3)) l (A0 → B) (Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3)
          (Γ4 ++ x) Γ1 [] (Δ2 ++ A :: Δ3) J5 J6 J7). simpl in d0. repeat rewrite <- app_assoc in d0.
          assert (J22: In (Γ4 ++ B0 :: x ++ Γ1, Δ2 ++ Δ3) [(Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ4 ++ B0 :: x ++ Γ1, Δ2 ++ Δ3)]).
          apply in_cons. apply in_eq. pose (RA_mhd_decreases J3 _ J22).
          assert (J8: size_form (A0 → B) = size_form (A0 → B)). reflexivity.
          assert (J9: mhd (Γ4 ++ B0 :: x ++ Γ1, Δ2 ++ Δ3) = mhd (Γ4 ++ B0 :: x ++ Γ1, Δ2 ++ Δ3)). reflexivity.
          assert (J10: (Γ4 ++ B0 :: x ++ Γ1, Δ2 ++ Δ3) = ((Γ4 ++ B0 :: x) ++ Γ1, [] ++ Δ2 ++ Δ3)). rewrite <- app_assoc. reflexivity.
          pose (d1:=@SIH (mhd (Γ4 ++ B0 :: x ++ Γ1, Δ2 ++ Δ3)) l0 (A0 → B) (Γ4 ++ B0 :: x ++ Γ1, Δ2 ++ Δ3)
          (Γ4 ++ B0 :: x) Γ1 [] (Δ2 ++ Δ3) J8 J9 J10). simpl in d1.
          assert (ImpLRule [(Γ4 ++ x ++ Γ1, (A0 → B :: Δ2) ++ A :: Δ3); (Γ4 ++ (B0 :: x) ++ Γ1, (A0 → B :: Δ2) ++ Δ3)] (Γ4 ++ (A → B0 :: x) ++ Γ1, (A0 → B :: Δ2) ++ Δ3)).
          apply ImpLRule_I. repeat rewrite <- app_assoc in H3. pose (ImpL_inv d H3). destruct p as [d2 d3].
          pose (d4:=d0 d2 X5). repeat rewrite <- app_assoc in d1. pose (d5:=d1 d3 X4). apply ImpL in H0 ; try intro ; try apply f ; try repeat rewrite <- app_assoc ; try rewrite <- H7 ;
          try repeat rewrite app_nil_r ; try auto ; try assumption. pose (dlCons d5 DersNilF). pose (dlCons d4 d6).
          pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
          (ps:=[(Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ4 ++ B0 :: x ++ Γ1, Δ2 ++ Δ3)]) (Γ4 ++ (A → B0 :: x) ++ Γ1, Δ2 ++ Δ3) H0 d7).
          assumption. }
      (* Right rule is GLR *)
      { inversion X3. subst. rewrite H2.
        assert (GLRRule [(XBoxed_list BΓ ++ [Box A], [A])] (Γ0 ++ Γ1, Δ2 ++ Box A :: Δ3)).
        apply GLRRule_I ; try assumption.
        apply univ_gen_ext_splitR in X4. destruct X4. destruct s. repeat destruct p. subst.
        apply univ_gen_ext_combine. assumption. apply univ_gen_ext_not_In_delete in u0. assumption.
        intro. assert (In (A0 → B) (x ++ x0)). apply in_or_app. auto. apply H5 in H0. destruct H0.
        inversion H0. apply GLR in X5.
        pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(XBoxed_list BΓ ++ [Box A], [A])]) (Γ0 ++ Γ1, Δ2 ++ Box A :: Δ3) X5 X2).
        assumption. }
    + repeat destruct s. repeat destruct p. subst.
      assert (J5 : list_exch_L (Γ0 ++ A :: Γ1, Δ0 ++ x0 ++ A0 → B :: Δ3) (A :: Γ2 ++ Γ3, Δ0 ++ x0 ++ A0 → B :: Δ3)).
      rewrite H2. assert (Γ0 ++ A :: Γ1 = [] ++ [] ++ Γ0 ++ [A] ++ Γ1). reflexivity. rewrite H. clear H.
      assert (A :: Γ0 ++ Γ1 = [] ++ [A] ++ Γ0 ++ [] ++ Γ1). reflexivity. rewrite H. clear H.
      apply list_exch_LI. pose (d:=GLS_adm_list_exch_L D1 J5).
      assert (ImpRRule [((A :: Γ2) ++ A0 :: Γ3, (Δ0 ++ x0) ++ B :: Δ3)] ((A :: Γ2) ++ Γ3, (Δ0 ++ x0) ++ A0 → B :: Δ3)).
      apply ImpRRule_I. repeat rewrite <- app_assoc in H. pose (d0:=ImpR_inv d H).
      assert (ImpRRule [(Γ2 ++ A0 :: Γ3, (Δ0 ++ x0) ++ B :: Δ3)] (Γ2 ++ Γ3, (Δ0 ++ x0) ++ A0 → B :: Δ3)).
      apply ImpRRule_I. repeat rewrite <- app_assoc in H0.
      assert (PSGLS_rules [(Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3)] (Γ2 ++ Γ3, Δ0 ++ x0 ++ A0 → B :: Δ3)).
      apply PSImpR ; try intro ; try apply f ; try rewrite <- H2 ; try rewrite <- app_assoc ; try auto ; try assumption.
      assert (GLS_rules [(Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3)] (Γ2 ++ Γ3, Δ0 ++ x0 ++ A0 → B :: Δ3)).
      apply ImpR. assumption.
      assert (J21: In (Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3) [(Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3)]). apply in_eq.
      pose (RA_mhd_decreases X3 (Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3) J21).
      assert (J2 : mhd (Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3) = mhd (Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3)). reflexivity.
      assert (J3 : size_form A = size_form A). reflexivity.
      assert (J4 : (Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3) = ([] ++ Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3)).
      repeat rewrite <- app_assoc. reflexivity. rewrite <- H2 in SIH.
      pose (d1:=@SIH (mhd (Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3)) l A (Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3)
      [] (Γ2 ++ A0 :: Γ3) Δ0 (x0 ++ B :: Δ3) J3 J2 J4). repeat rewrite <- app_assoc in d1. simpl in d1.
      inversion X0. subst. clear X6. repeat rewrite <- app_assoc in X5. pose (d2:=d1 X5 d0). pose (dlCons d2 DersNilF).
      pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3)]) (Γ2 ++ Γ3, Δ0 ++ x0 ++ A0 → B :: Δ3) X4 d3). assumption.
  * repeat destruct s. repeat destruct p. subst. repeat rewrite <- app_assoc. repeat rewrite <- app_assoc in D1.
    assert (J5 : list_exch_L (Γ0 ++ A :: Γ1, Δ2 ++ (A0 → B :: x) ++ Δ1) (A :: Γ2 ++ Γ3, Δ2 ++ (A0 → B :: x) ++ Δ1)).
    assert (Γ0 ++ A :: Γ1 = [] ++ [] ++ Γ0 ++ [A] ++ Γ1). reflexivity. rewrite H. clear H.
    assert (A :: Γ2 ++ Γ3 = [] ++ [A] ++ Γ0 ++ [] ++ Γ1). rewrite H2. reflexivity. rewrite H. clear H.
    apply list_exch_LI. pose (d:=GLS_adm_list_exch_L D1 J5).
    assert (ImpRRule [((A :: Γ2) ++ A0 :: Γ3, Δ2 ++ B :: x ++ Δ1)] ((A :: Γ2) ++ Γ3, Δ2 ++ (A0 → B :: x) ++ Δ1)).
    apply ImpRRule_I. repeat rewrite <- app_assoc in H. pose (d0:=ImpR_inv d H).
    assert (ImpRRule [(Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1)] (Γ2 ++ Γ3, Δ2 ++ (A0 → B :: x) ++ Δ1)).
    apply ImpRRule_I.
    assert (PSGLS_rules [(Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1)] (Γ2 ++ Γ3, Δ2 ++ (A0 → B :: x) ++ Δ1)).
    apply PSImpR ; try intro ; try apply f ; try repeat rewrite <- app_assoc ; try rewrite <- H2 ; try auto ; try assumption.
    assert (GLS_rules [(Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1)] (Γ2 ++ Γ3, Δ2 ++ (A0 → B :: x) ++ Δ1)).
    apply ImpR ; try assumption.
    assert (J21: In (Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1) [(Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1)]). apply in_eq.
    pose (RA_mhd_decreases X3 (Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1) J21). rewrite <- H2 in SIH.
    assert (J2 : mhd (Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1) = mhd (Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1)).
    repeat rewrite <- app_assoc. reflexivity.
    assert (J3 : size_form A = size_form A). reflexivity.
    assert (J4 : (Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1) = ([] ++ Γ2 ++ A0 :: Γ3, (Δ2 ++ B :: x) ++ Δ1)).
    repeat rewrite <- app_assoc. reflexivity. repeat rewrite <- app_assoc in SIH.
    pose (d1:=@SIH (mhd (Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1)) l A (Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1)
    [] (Γ2 ++ A0 :: Γ3) (Δ2 ++ (B :: x)) Δ1 J3 J2 J4). simpl in d1. repeat rewrite <- app_assoc in d1.
    inversion X0. subst. pose (d2:=d1 X5 d0). pose (dlCons d2 DersNilF).
    pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
    (ps:=[(Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1)]) (Γ2 ++ Γ3, Δ2 ++ (A0 → B :: x) ++ Δ1) X4 d3). assumption.

(* Left rule is ImpL *)
- inversion H1. subst. inversion X0. inversion X4. subst. clear X6. clear X4.
  assert (J5 : list_exch_L (Γ0 ++ A :: Γ1, Δ0 ++ Δ1) (A :: Γ2 ++ A0 → B :: Γ3, Δ0 ++ Δ1)).
  rewrite H2. assert (Γ0 ++ A :: Γ1 = [] ++ [] ++ Γ0 ++ [A] ++ Γ1).
  reflexivity. rewrite H. clear H.
  assert (A :: Γ0 ++ Γ1 = [] ++ [A] ++ Γ0 ++ [] ++ Γ1). reflexivity. rewrite H. clear H.
  apply list_exch_LI. pose (d:=GLS_adm_list_exch_L D1 J5). rewrite H3 in X5.
  assert (J40 : list_exch_R (Γ2 ++ Γ3, Δ2 ++ A0 :: Δ3) (Γ2 ++ Γ3, A0 :: Δ0 ++ A :: Δ1)).
  rewrite <- H3. assert (Δ2 ++ A0 :: Δ3 = [] ++ [] ++ Δ2 ++ [A0] ++ Δ3).
  reflexivity. rewrite H. clear H.
  assert (A0 :: Δ2 ++ Δ3 = [] ++ [A0] ++ Δ2 ++ [] ++ Δ3). reflexivity. rewrite H. clear H.
  apply list_exch_RI. pose (d0:=GLS_adm_list_exch_R X3 J40).
  assert (ImpLRule [(A :: Γ2 ++ Γ3, [] ++ A0 :: Δ0 ++ Δ1); (A :: Γ2 ++ B :: Γ3, [] ++ Δ0 ++ Δ1)] (A :: Γ2 ++ A0 → B :: Γ3, [] ++ Δ0 ++ Δ1)).
  assert ((A :: Γ2 ++ A0 → B :: Γ3, [] ++ Δ0 ++ Δ1) = ((A :: Γ2) ++ A0 → B :: Γ3, [] ++ Δ0 ++ Δ1)). reflexivity.
  rewrite H. clear H.
  assert ((A :: Γ2 ++ Γ3, [] ++ A0 :: Δ0 ++ Δ1) = ((A :: Γ2) ++ Γ3, [] ++ A0 :: Δ0 ++ Δ1)). reflexivity.
  rewrite H. clear H.
  assert ((A :: Γ2 ++ B :: Γ3, [] ++ Δ0 ++ Δ1) = ((A :: Γ2) ++ B :: Γ3, [] ++ Δ0 ++ Δ1)). reflexivity.
  rewrite H. clear H. apply ImpLRule_I. simpl in H. pose (ImpL_inv d H). destruct p as [d1 d2].
  assert (ImpLRule [(Γ2 ++ Γ3, [] ++ A0 :: Δ0 ++ Δ1); (Γ2 ++ B :: Γ3, [] ++ Δ0 ++ Δ1)] (Γ2 ++ A0 → B :: Γ3, [] ++ Δ0 ++ Δ1)).
  apply ImpLRule_I. simpl in H0.
  assert (PSGLS_rules [(Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1); (Γ2 ++ B :: Γ3, Δ0 ++ Δ1)] (Γ2 ++ A0 → B :: Γ3, Δ0 ++ Δ1)).
  apply PSImpL ; try intro ; try apply f ; try rewrite <- H2 ; try rewrite <- app_assoc ; try auto ; try assumption.
  assert (GLS_rules [(Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1); (Γ2 ++ B :: Γ3, Δ0 ++ Δ1)] (Γ2 ++ A0 → B :: Γ3, Δ0 ++ Δ1)).
  apply ImpL. assumption.
  assert (J21: In (Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1) [(Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1); (Γ2 ++ B :: Γ3, Δ0 ++ Δ1)]).
  apply in_eq. pose (RA_mhd_decreases X4 (Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1) J21).
  assert (J2 : mhd (Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1) = mhd (Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1)). reflexivity.
  assert (J3 : size_form A = size_form A). reflexivity.
  assert (J4 : (Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1) = ([] ++ Γ2 ++ Γ3, (A0 :: Δ0) ++ Δ1)).
  repeat rewrite <- app_assoc. reflexivity. rewrite <- H2 in SIH.
  pose (d3:=@SIH (mhd (Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1)) l A (Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1)
  [] (Γ2 ++ Γ3) (A0 :: Δ0) Δ1 J3 J2 J4). repeat rewrite <- app_assoc in d3. simpl in d3.
  pose (d4:=d3 d0 d1).
  assert (J31: In (Γ2 ++ B :: Γ3, Δ0 ++ Δ1) [(Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1); (Γ2 ++ B :: Γ3, Δ0 ++ Δ1)]).
  apply in_cons. apply in_eq. pose (RA_mhd_decreases X4 (Γ2 ++ B :: Γ3, Δ0 ++ Δ1) J31).
  assert (J32 : mhd (Γ2 ++ B :: Γ3, Δ0 ++ Δ1) = mhd (Γ2 ++ B :: Γ3, Δ0 ++ Δ1)). reflexivity.
  assert (J33 : size_form A = size_form A). reflexivity.
  assert (J34 : (Γ2 ++ B :: Γ3, Δ0 ++ Δ1) = ([] ++ Γ2 ++ B :: Γ3, Δ0 ++ Δ1)).
  repeat rewrite <- app_assoc. reflexivity.
  pose (d5:=@SIH (mhd (Γ2 ++ B :: Γ3, Δ0 ++ Δ1)) l0 A (Γ2 ++ B :: Γ3, Δ0 ++ Δ1)
  [] (Γ2 ++ B :: Γ3) Δ0 Δ1 J33 J32 J34). repeat rewrite <- app_assoc in d5. simpl in d5.
  pose (d6:=d5 X5 d2). pose (dlCons d6 DersNilF). pose (dlCons d4 d7).
  pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
  (ps:=[(Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1); (Γ2 ++ B :: Γ3, Δ0 ++ Δ1)]) (Γ2 ++ A0 → B :: Γ3, Δ0 ++ Δ1) X6 d8). assumption.

(* Left rule is GLR *)
- inversion X3. subst. apply list_split_form in H2. destruct H2.
  * destruct s.
    + repeat destruct p. subst. inversion X1.
      (* Right rule is IdP *)
      { inversion H. subst. assert (J0 : InT (# P) (Γ0 ++ Box A0 :: Γ1)). rewrite <- H5. apply InT_or_app.
        right. apply InT_eq. apply InT_app_or in J0. destruct J0.
        - apply InT_split in i. destruct i. destruct s. subst. rewrite <- app_assoc.
          assert (IdPRule [] (x ++ (# P :: x0) ++ Γ1, Δ2 ++ # P :: Δ3)). apply IdPRule_I. apply IdP in H0.
          pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
          (ps:=[]) (x ++ (# P :: x0) ++ Γ1, Δ2 ++ # P :: Δ3) H0 DersNilF). assumption.
        - inversion i.
          * inversion H2.
          * apply InT_split in H2. destruct H2. destruct s. subst. rewrite app_assoc.
            assert (IdPRule [] ((Γ0 ++ x) ++ # P :: x0, Δ2 ++ # P :: Δ3)). apply IdPRule_I. apply IdP in H0.
            pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
            (ps:=[]) ((Γ0 ++ x) ++ # P :: x0, Δ2 ++ # P :: Δ3) H0 DersNilF). assumption. }
      (* Right rule is BotL *)
      { inversion H. subst. assert (J0 : InT (⊥) (Γ0 ++ Box A0 :: Γ1)). rewrite <- H5. apply InT_or_app.
        right. apply InT_eq. apply InT_app_or in J0. destruct J0.
        - apply InT_split in i. destruct i. destruct s. subst. rewrite <- app_assoc.
          assert (BotLRule [] (x ++ (⊥ :: x0) ++ Γ1, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
          pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
          (ps:=[]) (x ++ (⊥ :: x0) ++ Γ1, Δ0 ++ Δ1) H0 DersNilF). assumption.
        - inversion i.
          * inversion H2.
          * apply InT_split in H2. destruct H2. destruct s. subst. rewrite app_assoc.
            assert (BotLRule [] ((Γ0 ++ x) ++ ⊥ :: x0, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
            pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
            (ps:=[]) ((Γ0 ++ x) ++ ⊥ :: x0, Δ0 ++ Δ1) H0 DersNilF). assumption. }
      (* Right rule is ImpR *)
      { inversion H. subst. inversion X2. subst. clear X6. rewrite <- H6 in D1.
        assert (J1 : list_exch_L (Γ2 ++ A :: Γ3, Δ2 ++ B :: Δ3) (A :: Γ0 ++ Box A0 :: Γ1, Δ2 ++ B :: Δ3)).
        assert (Γ2 ++ A :: Γ3 = [] ++ [] ++ Γ2 ++ [A] ++ Γ3). reflexivity. rewrite H0. clear H0.
        assert (A :: Γ0 ++ Box A0 :: Γ1 = [] ++ [A] ++ Γ2 ++ [] ++ Γ3). rewrite <- H5. reflexivity.
        rewrite H0. clear H0. apply list_exch_LI. pose (d:=GLS_adm_list_exch_L X5 J1).
        assert (ImpRRule [([] ++ A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3)] ([] ++ Γ0 ++ Γ1, Δ2 ++ A → B :: Δ3)). apply ImpRRule_I.
        simpl in H0.
        assert (J3: PSGLS_rules [(A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3)] (Γ0 ++ Γ1, Δ2 ++ A → B :: Δ3)).
        apply PSImpR ; try intro ; try apply f ; try rewrite <- H6 ; try auto ; try assumption.
        assert (J31: GLS_rules [(A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3)] (Γ0 ++ Γ1, Δ2 ++ A → B :: Δ3)).
        apply ImpR ; try assumption.
        assert (J21: In (A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3) [(A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3)]). apply in_eq.
        pose (RA_mhd_decreases J3 _ J21). rewrite <- H6 in SIH.
        assert (J5: size_form (Box A0) = size_form (Box A0)). reflexivity.
        assert (J6: mhd (A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3) = mhd (A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3)). reflexivity.
        assert (J7 : (A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3) = ((A :: Γ0) ++ Γ1, [] ++ Δ2 ++ B :: Δ3)). reflexivity.
        pose (d0:=@SIH (mhd (A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3)) l (Box A0) (A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3)
        (A :: Γ0) Γ1 [] (Δ2 ++ B :: Δ3) J5 J6 J7). simpl in d0.
        assert (J8 : list_exch_R (Γ0 ++ Γ1, Δ0 ++ Box A0 :: Δ1) (Γ0 ++ Γ1, Box A0 :: Δ2 ++ A → B :: Δ3)).
        assert (Δ0 ++ Box A0 :: Δ1 = [] ++ [] ++ Δ0 ++ [Box A0] ++ Δ1). reflexivity. rewrite H2. clear H2.
        assert (Box A0 :: Δ2 ++ A → B :: Δ3 = [] ++ [Box A0] ++ Δ0 ++ [] ++ Δ1). rewrite H6.
        reflexivity. rewrite H2. clear H2. apply list_exch_RI. pose (d1:=GLS_adm_list_exch_R D0 J8).
        assert (ImpRRule [([] ++ A ::Γ0 ++ Γ1, (Box A0 :: Δ2) ++ B :: Δ3)] ([] ++ Γ0 ++ Γ1, (Box A0 :: Δ2) ++ A → B :: Δ3)).
        apply ImpRRule_I. simpl in H2. pose (d2:=ImpR_inv d1 H2). pose (d3:=d0 d2 d). pose (dlCons d3 DersNilF).
        apply ImpR in H0 ; try intro ; try apply f ; try rewrite <- H7 ; try auto ; try assumption.
        pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3)]) (Γ0 ++ Γ1, Δ2 ++ A → B :: Δ3) H0 d4). assumption. }
      (* Right rule is ImpL *)
      { inversion H. subst. apply list_split_form in H5. destruct H5.
        - destruct s.
          + repeat destruct p. inversion e0.
          + repeat destruct s. repeat destruct p. subst. repeat rewrite <- app_assoc in H. repeat rewrite <- app_assoc in X2.
            assert (J2: list_exch_R (Γ0 ++ x0 ++ A → B :: Γ3, Δ0 ++ Box A0 :: Δ1) (Γ0 ++ x0 ++ A → B :: Γ3, Box A0 :: Δ2 ++ Δ3)).
            assert (Δ0 ++ Box A0 :: Δ1 = [] ++ [] ++ Δ0 ++ [Box A0] ++ Δ1). reflexivity. rewrite H0. clear H0.
            assert (Box A0 :: Δ2 ++ Δ3 = [] ++ [Box A0] ++ Δ0 ++ [] ++ Δ1). rewrite H6. reflexivity. rewrite H0. clear H0.
            apply list_exch_RI. pose (d:=GLS_adm_list_exch_R D0 J2).
            assert (ImpLRule [((Γ0 ++ x0) ++ Γ3, (Box A0 :: Δ2) ++ A :: Δ3); ((Γ0 ++ x0) ++ B :: Γ3, (Box A0 :: Δ2) ++ Δ3)]
            ((Γ0 ++ x0) ++ A → B :: Γ3, (Box A0 :: Δ2) ++ Δ3)). apply ImpLRule_I. simpl in H.
            repeat rewrite <- app_assoc in H0. pose (ImpL_inv d H0). destruct p as [d0 d1].
            assert (ImpLRule [((Γ0 ++ x0) ++ Γ3, Δ2 ++ A :: Δ3); ((Γ0 ++ x0) ++ B :: Γ3, Δ2 ++ Δ3)]
            ((Γ0 ++ x0) ++ A → B :: Γ3, Δ2 ++ Δ3)). apply ImpLRule_I. repeat rewrite <- app_assoc in H0.
            repeat rewrite <- app_assoc in H2.
            assert (J3: PSGLS_rules [(Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3); (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3)]
            (Γ0 ++ x0 ++ A → B :: Γ3, Δ2 ++ Δ3)).
            apply PSImpL ; try intro ; try apply f ; try rewrite <- app_assoc ;
            try rewrite <- H6 ; try auto ; try assumption.
            assert (J30: GLS_rules [(Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3); (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3)]
            (Γ0 ++ x0 ++ A → B :: Γ3, Δ2 ++ Δ3)). apply ImpL ; try assumption.
            assert (J5: In (Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3) [(Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3); (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3)]).
            apply in_eq.
            assert (J9: In (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3) [(Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3); (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3)]).
            apply in_cons. apply in_eq.
            pose (RA_mhd_decreases J3 _ J5). pose (RA_mhd_decreases J3 _ J9). repeat rewrite <- app_assoc in SIH. rewrite <- H6 in SIH.
            assert (J6: size_form (Box A0) = size_form (Box A0)). reflexivity.
            assert (J7: mhd (Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3) = mhd (Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3)). reflexivity.
            assert (J8: (Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3) = (Γ0 ++ x0 ++ Γ3, [] ++ Δ2 ++ A :: Δ3)). reflexivity.
            pose (d2:=@SIH (mhd (Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3)) l (Box A0) (Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3)
            Γ0 (x0 ++ Γ3) [] (Δ2 ++ A :: Δ3) J6 J7 J8). simpl in d2. inversion X2. subst. inversion X6. clear X6.
            clear X8. subst. pose (d3:=d2 d0 X5).
            assert (J10: mhd (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3) = mhd (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3)). reflexivity.
            assert (J11: (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3) = (Γ0 ++ x0 ++ B :: Γ3, [] ++ Δ2 ++ Δ3)). reflexivity.
            pose (d4:=@SIH (mhd (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3)) l0 (Box A0) (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3)
            Γ0 (x0 ++ B :: Γ3) [] (Δ2 ++ Δ3) J6 J10 J11). simpl in d4. pose (d5:=d4 d1 X7).
            pose (dlCons d5 DersNilF). pose (dlCons d3 d6).
            pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
            (ps:=[(Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3); (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3)]) (Γ0 ++ x0 ++ A → B :: Γ3, Δ2 ++ Δ3) J30 d7).
            assumption.
        - repeat destruct s. repeat destruct p. subst. rewrite <- app_assoc in D0.
          assert (J2: list_exch_R (Γ2 ++ (A → B :: x) ++ Γ1, Δ0 ++ Box A0 :: Δ1) (Γ2 ++ (A → B :: x) ++ Γ1, Box A0 :: Δ2 ++ Δ3)).
          assert (Δ0 ++ Box A0 :: Δ1 = [] ++ [] ++ Δ0 ++ [Box A0] ++ Δ1). reflexivity. rewrite H0. clear H0.
          assert (Box A0 :: Δ2 ++ Δ3 = [] ++ [Box A0] ++ Δ0 ++ [] ++ Δ1). rewrite H6. reflexivity. rewrite H0. clear H0.
          apply list_exch_RI. pose (d:=GLS_adm_list_exch_R D0 J2).
          assert (ImpLRule [(Γ2 ++ x ++ Γ1, (Box A0 :: Δ2) ++ A :: Δ3); (Γ2 ++ B :: x ++ Γ1, (Box A0 :: Δ2) ++ Δ3)]
          (Γ2 ++ (A → B :: x) ++ Γ1, (Box A0 :: Δ2) ++ Δ3)). apply ImpLRule_I. repeat rewrite <- app_assoc in H0.
          pose (ImpL_inv d H0). destruct p as [d0 d1]. rewrite <- app_assoc.
          assert (ImpLRule [(Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3)]
          (Γ2 ++ (A → B :: x) ++ Γ1, Δ2 ++ Δ3)). apply ImpLRule_I.
          assert (J3: PSGLS_rules [(Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3)]
          (Γ2 ++ (A → B :: x) ++ Γ1, Δ2 ++ Δ3)).
          apply PSImpL ; try intro ; try apply f ; try rewrite <- app_assoc ;
          try rewrite <- H6 ; try auto ; try assumption.
          assert (J30: GLS_rules [(Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3)]
          (Γ2 ++ (A → B :: x) ++ Γ1, Δ2 ++ Δ3)). apply ImpL ; try assumption.
          assert (J5: In (Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3) [(Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3)]).
          apply in_eq.
          assert (J9: In (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3) [(Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3)]).
          apply in_cons. apply in_eq.
          pose (RA_mhd_decreases J3 _ J5). pose (RA_mhd_decreases J3 _ J9). repeat rewrite <- app_assoc in SIH. rewrite <- H6 in SIH.
          assert (J6: size_form (Box A0) = size_form (Box A0)). reflexivity.
          assert (J7: mhd (Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3) = mhd (Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3)). reflexivity.
          assert (J8: (Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3) = ((Γ2 ++ x) ++ Γ1, [] ++ Δ2 ++ A :: Δ3)). rewrite <- app_assoc. reflexivity.
          pose (d2:=@SIH (mhd (Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3)) l (Box A0) (Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3)
          (Γ2 ++ x) Γ1 [] (Δ2 ++ A :: Δ3) J6 J7 J8). simpl in d2. inversion X2. subst. inversion X6. clear X6.
          clear X8. subst. repeat rewrite <- app_assoc in d2. pose (d3:=d2 d0 X5).
          assert (J10: mhd (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3) = mhd (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3)). reflexivity.
          assert (J11: (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3) = ((Γ2 ++ B :: x) ++ Γ1, [] ++ Δ2 ++ Δ3)). rewrite <- app_assoc. reflexivity.
          pose (d4:=@SIH (mhd (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3)) l0 (Box A0) (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3)
          (Γ2 ++ B :: x) Γ1 [] (Δ2 ++ Δ3) J6 J10 J11). simpl in d4. repeat rewrite <- app_assoc in d4. pose (d5:=d4 d1 X7).
          pose (dlCons d5 DersNilF). pose (dlCons d3 d6).
          pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
          (ps:=[(Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3)]) (Γ2 ++ (A → B :: x) ++ Γ1, Δ2 ++ Δ3) J30 d7).
          assumption. }
      (* Right rule is GLR *)
      { inversion X5. subst. inversion X0. subst. clear X8. inversion X2. subst. clear X9.
        pose (univ_gen_ext_splitR _ _ X4). repeat destruct s. repeat destruct p.
        pose (univ_gen_ext_splitR _ _ X6). repeat destruct s. repeat destruct p. subst. inversion u2.
        - subst.
          assert ((XBoxed_list (x ++ x0) ++ [Box A0], [A0]) = ((XBoxed_list (x ++ x0) ++ [Box A0]) ++ [], [] ++ [A0])).
          repeat rewrite <- app_assoc. reflexivity.
          assert (X7': derrec GLS_rules (fun _ : Seq => False) ((XBoxed_list (x ++ x0) ++ [Box A0]) ++ [], [] ++ [A0])).
          rewrite <- H. assumption.
          assert (J1: wkn_L (Box A) ((XBoxed_list (x ++ x0) ++ [Box A0]) ++ [], [] ++ [A0]) ((XBoxed_list (x ++ x0) ++ [Box A0]) ++ (Box A) :: [], [] ++ [A0])).
          apply wkn_LI. assert (J2: derrec_height X7' = derrec_height X7'). reflexivity.
          pose (GLS_wkn_L _ J2 J1). destruct s. clear l0. clear J2. clear X7'. clear J1.
          assert (J3: wkn_R A ((XBoxed_list (x ++ x0) ++ [Box A0]) ++ [Box A], [] ++ [A0]) ((XBoxed_list (x ++ x0) ++ [Box A0]) ++ [Box A], [] ++ A :: [A0])).
          apply wkn_RI. assert (J4: derrec_height x2 = derrec_height x2). reflexivity.
          pose (GLS_wkn_R _ J4 J3). destruct s. clear l0. clear J4. clear J3. clear x2. clear H. simpl in x3.
          rewrite XBox_app_distrib in x3. repeat rewrite <- app_assoc in x3.
          rewrite XBox_app_distrib in X8. repeat rewrite <- app_assoc in X8. simpl in X8.
          assert ((XBoxed_list x1 ++ A0 :: Box A0 :: XBoxed_list l ++ [Box A], [A]) =
          (XBoxed_list x1 ++ (A0 :: [Box A0]) ++ [] ++ XBoxed_list l ++ [Box A], [A])).
          reflexivity. rewrite H in X8. clear H.
          assert (J5: list_exch_L (XBoxed_list x1 ++ [A0; Box A0] ++ [] ++ XBoxed_list l ++ [Box A], [A])
          (XBoxed_list x1 ++ XBoxed_list l ++ [] ++ [A0; Box A0] ++ [Box A], [A])).
          apply list_exch_LI.
          pose (d:=GLS_adm_list_exch_L X8 J5). simpl in d. rewrite app_assoc in d.
          rewrite <- XBox_app_distrib in d. assert (x1 ++ l = x ++ x0).
          apply nobox_gen_ext_injective with (l:=(Γ0 ++ Γ1)) ; try assumption.
          intro. intros. apply H4. apply in_or_app. apply in_app_or in H. destruct H.
          auto. right. apply in_cons. assumption. apply univ_gen_ext_combine ; assumption.
          rewrite H in d. clear J5. clear X8. simpl in x3. rewrite app_assoc in x3.
          rewrite <- XBox_app_distrib in x3.
          assert (J6: size_form A0 < size_form (Box A0)). simpl. lia.
          assert (J7: size_form A0 = size_form A0). reflexivity.
          assert (J8: mhd (XBoxed_list (x ++ x0) ++ [Box A0; Box A], [A]) =
          mhd (XBoxed_list (x ++ x0) ++ [Box A0; Box A], [A])). reflexivity.
          assert (J9: (XBoxed_list (x ++ x0) ++ [Box A0; Box A], [A]) =
          (XBoxed_list (x ++ x0) ++ [Box A0; Box A], [A] ++ [])). rewrite app_nil_r. reflexivity.
          pose (d0:=@PIH (size_form A0) J6 (mhd (XBoxed_list (x ++ x0) ++ [Box A0; Box A], [A]))
          A0 (XBoxed_list (x ++ x0) ++ [Box A0; Box A], [A]) (XBoxed_list (x ++ x0)) (Box A0 :: [Box A])
          [A] [] J7 J8 J9). rewrite app_nil_r in d0. pose (d1:=d0 x3 d).
          assert (GLRRule [(XBoxed_list (x ++ x0) ++ [Box A0], [A0])] (x ++ x0, [Box A0])).
          assert ((x ++ x0, [Box A0]) = (x ++ x0, [] ++ Box A0 :: [])). reflexivity. rewrite H0. clear H0.
          apply GLRRule_I.
          assumption. apply univ_gen_ext_refl.
          assert (GLS_rules [(XBoxed_list (x ++ x0) ++ [Box A0], [A0])] (x ++ x0, [Box A0])).
          apply GLR. assumption.
          pose (dlCons X7 DersNilF).
          pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
          (ps:=[(XBoxed_list (x ++ x0) ++ [Box A0], [A0])]) (x ++ x0, [Box A0]) X10 d2).
          assert ([Box A0] = [Box A0] ++ []). reflexivity. rewrite H0 in d3.
          assert (wkn_R A (x ++ x0, [Box A0] ++ []) (x ++ x0, [Box A0] ++ A :: [])). apply wkn_RI.
          assert (J10: derrec_height d3 = derrec_height d3). reflexivity.
          pose (GLS_wkn_R _ J10 H2). destruct s. clear l0. clear J10. clear H0. clear d3.
          clear d2. clear X10. clear X8. clear J6. clear J8. clear J9.
          assert (J20: derrec_height x2 = derrec_height x2). reflexivity.
          pose (@GLS_XBoxed_list_wkn_L (derrec_height x2) (x ++ x0) [] [] ([Box A0] ++ [A])).
          repeat rewrite app_nil_r in s. repeat rewrite app_nil_l in s. pose (s x2 J20).
          destruct s0. clear l0. clear J20. clear s. clear x2.
          assert (XBoxed_list (x ++ x0) = XBoxed_list (x ++ x0) ++ []). rewrite app_nil_r. reflexivity.
          rewrite H0 in x4. clear H0.
          assert (wkn_L (Box A) (XBoxed_list (x ++ x0) ++ [], [Box A0] ++ [A]) (XBoxed_list (x ++ x0) ++ (Box A) :: [], [Box A0] ++ [A])).
          apply wkn_LI.
          assert (J10: derrec_height x4 = derrec_height x4). reflexivity.
          pose (GLS_wkn_L _ J10 H0). destruct s. clear l0. clear J10. clear x4. clear H0.
          assert (GLRRule [(XBoxed_list (x ++ x0) ++ [Box A], [A])] (Γ0 ++ Γ1, Δ0 ++ Δ1)).
          rewrite <- H5. apply GLRRule_I ; try assumption.
          destruct (dec_init_rules (Γ0 ++ Γ1, Δ2 ++ Box A :: Δ3)).
          + repeat destruct s.
            * apply IdP in i. pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
              (ps:=[]) (Γ0 ++ Γ1, Δ2 ++ Box A :: Δ3) i DersNilF). assumption.
            * inversion i. apply Id_all_form.
            * apply BotL in b. pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
              (ps:=[]) (Γ0 ++ Γ1, Δ2 ++ Box A :: Δ3) b DersNilF). assumption.
          + assert (PSGLS_rules [(XBoxed_list (x ++ x0) ++ [Box A], [A])] (Γ0 ++ Γ1, Δ0 ++ Δ1)).
            apply PSGLR ; try intro ; try apply f ; try rewrite H5 ; try auto ; try assumption.
            assert (J40: GLS_rules [(XBoxed_list (x ++ x0) ++ [Box A], [A])] (Γ0 ++ Γ1, Δ0 ++ Δ1)).
            apply GLR ; try assumption.
            assert (l0: mhd (XBoxed_list (x ++ x0) ++ [Box A], [A]) < mhd (Γ0 ++ Γ1, Δ0 ++ Δ1)).
            assert (J30 : In (XBoxed_list (x ++ x0) ++ [Box A], [A]) [(XBoxed_list (x ++ x0) ++ [Box A], [A])]).
            apply in_eq. pose (RA_mhd_decreases X10 _ J30). assumption.
            assert (J10: size_form (Box A0) = size_form (Box A0)). reflexivity.
            assert (J11: mhd (XBoxed_list (x ++ x0) ++ [Box A], [A]) = mhd (XBoxed_list (x ++ x0) ++ [Box A], [A])). reflexivity.
            assert (J12: (XBoxed_list (x ++ x0) ++ [Box A], [A]) = (XBoxed_list (x ++ x0) ++ [Box A], [] ++ [A]) ). reflexivity.
            pose (d2:=@SIH (mhd (XBoxed_list (x ++ x0) ++ [Box A], [A])) l0 (Box A0) (XBoxed_list (x ++ x0) ++ [Box A], [A])
            (XBoxed_list (x ++ x0)) [Box A] [] [A] J10 J11 J12). simpl in d2. pose (d3:=d2 x2 d1). pose (dlCons d3 DersNilF).
            pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
            (ps:=[(XBoxed_list (x ++ x0) ++ [Box A], [A])]) (Γ0 ++ Γ1, Δ0 ++ Δ1) J40 d4).
            rewrite H5. assumption.
        - exfalso. apply H2. exists A0. reflexivity. }
    + repeat destruct s. repeat destruct p. subst.
      assert (GLRRule [(XBoxed_list BΓ ++ [Box A0], [A0])] (Γ0 ++ Γ1, (Δ0 ++ x0) ++ Box A0 :: Δ3)).
      apply GLRRule_I ; try assumption. repeat rewrite <- app_assoc in X5.
      assert (GLS_rules [(XBoxed_list BΓ ++ [Box A0], [A0])] (Γ0 ++ Γ1, Δ0 ++ x0 ++ Box A0 :: Δ3)).
      apply GLR. assumption.
      pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
      (ps:=[(XBoxed_list BΓ ++ [Box A0], [A0])]) (Γ0 ++ Γ1, Δ0 ++ x0 ++ Box A0 :: Δ3) X6 X0). assumption.
  * repeat destruct s. repeat destruct p. subst. rewrite <- app_assoc.
    assert (GLRRule [(XBoxed_list BΓ ++ [Box A0], [A0])] (Γ0 ++ Γ1, Δ2 ++ (Box A0 :: x) ++ Δ1)).
    apply GLRRule_I ; try assumption.
    assert (GLS_rules [(XBoxed_list BΓ ++ [Box A0], [A0])] (Γ0 ++ Γ1, Δ2 ++ (Box A0 :: x) ++ Δ1)).
    apply GLR. assumption.
    pose (derI (rules:=GLS_rules) (prems:=fun _ : Seq => False)
    (ps:=[(XBoxed_list BΓ ++ [Box A0], [A0])]) (Γ0 ++ Γ1, Δ2 ++ (Box A0 :: x) ++ Δ1) X6 X0). assumption.
Qed.

Theorem GLS_cut_adm : forall A Γ0 Γ1 Δ0 Δ1,
                      (GLS_prv (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)) ->
                      (GLS_prv (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)) ->
                      (GLS_prv (Γ0 ++ Γ1, Δ0 ++ Δ1)).
Proof.
intros.
assert (J1: size_form A = size_form A). reflexivity.
assert (J2: mhd (Γ0 ++ Γ1, Δ0 ++ Δ1) = mhd (Γ0 ++ Γ1, Δ0 ++ Δ1)). reflexivity.
assert (J3: (Γ0 ++ Γ1, Δ0 ++ Δ1) = (Γ0 ++ Γ1, Δ0 ++ Δ1)). reflexivity.
pose (@GLS_cut_adm_main (size_form A) (mhd (Γ0 ++ Γ1, Δ0 ++ Δ1)) A
(Γ0 ++ Γ1, Δ0 ++ Δ1) Γ0 Γ1 Δ0 Δ1 J1 J2 J3). auto.
Qed.


Require Import Stlc.SpecTyping.
Require Import Stlc.SpecEquivalent.
Require Import Stlc.LemmasEvaluation.
Require Import Stlc.LemmasTyping.
Require Import Utlc.SpecEquivalent.
Require Import Utlc.LemmasEvaluation.

Require Import Compiler.Erase.
Require Import Compiler.Compiler.
Require Import Compiler.ProtectConfine.

Require Import UVal.UVal.

Require Import LogRel.PseudoType.
Require Import LogRel.LemmasPseudoType.
Require Import LogRel.LR.
Require Import LogRel.LemmasLR.

Require Import BackTrans.InjectExtract.
Require Import BackTrans.UpgradeDowngrade.
Require Import BackTrans.Emulate.

Require Import Omega.

Lemma equivalencePreservation {t₁ t₂ τ} :
  ⟪ S.empty ⊢ t₁ : τ ⟫ →
  ⟪ S.empty ⊢ t₂ : τ ⟫ →
  ⟪ S.empty ⊢ t₁ ≃ t₂ : τ ⟫ →
  ⟨ 0 ⊢ compile τ t₁ ≃ compile τ t₂ ⟩.
Proof.
  revert t₁ t₂ τ.
  enough (∀ {t₁ t₂ τ},
            ⟪ S.empty ⊢ t₁ : τ ⟫ →
            ⟪ S.empty ⊢ t₂ : τ ⟫ →
            ⟪ S.empty ⊢ t₁ ≃ t₂ : τ ⟫ →
            ∀ {C}, WsPCtx 0 0 C →
                 U.Terminating (U.pctx_app (compile τ t₁) C) → U.Terminating (U.pctx_app (compile τ t₂) C)) as Hltor
      by (intros t₁ t₂ τ ty1 ty2 ceq;
          assert (⟪ S.empty ⊢ t₂ ≃ t₁ : τ ⟫)
            by (apply S.pctx_equiv_symm; assumption);
          split;
          refine (Hltor _ _ _ _ _ _ _ _); assumption).
  intros t₁ t₂ τ ty₁ ty₂ ceq Cu sCu term.

  destruct (U.Terminating_TerminatingN term) as [n termN]; clear term.

  assert (⟪ pempty ⊩ t₁ ⟦ dir_gt , S n ⟧ erase t₁ : embed τ ⟫) as lre₁
      by (change pempty with (embedCtx (repEmulCtx pempty));
          eapply erase_correct;
          cbn; assumption).
  assert (⟪ pempty ⊩ S.app (inject (S (S n)) τ) t₁ ⟦ dir_gt , S n ⟧ U.app (protect τ) (erase t₁) : pEmulDV (S (S n)) precise ⟫) as lrpe₁
      by (eapply inject_works_open;
          eauto using dwp_precise with arith).
  fold (compile τ t₁) in lrpe₁.

  assert (⟪ ⊩ emulate_pctx (S (S n)) Cu ⟦ dir_gt , S n ⟧ Cu :
              pempty , pEmulDV (S (S n)) precise → pempty , pEmulDV (S (S n)) precise ⟫) as lrem₁ by
      (change pempty with (toEmulDV (S (S n)) precise 0);
       eapply emulate_pctx_works; eauto using dwp_precise with arith).

  pose proof (proj2 lrem₁ _ _ lrpe₁) as lrfull₁.

  assert (S.Terminating (S.pctx_app (S.app (inject (S (S n)) τ) t₁)
                                    (emulate_pctx (S (S n)) Cu))) as termS
    by (eapply (adequacy_gt lrfull₁ termN); eauto with arith).

  change (S.app (inject (S (S n)) τ) t₁) with (S.pctx_app t₁ (S.papp₂ (inject (S (S n)) τ) S.phole)) in termS.
  rewrite <- S.pctx_cat_app in termS.

  assert (⟪ ⊢ emulate_pctx (S (S n)) Cu : S.empty, UVal (S (S n)) → S.empty, UVal (S (S n)) ⟫)
    by (change S.empty with (toUVals (S (S n)) 0);
        eapply emulate_pctx_T; assumption).

  assert (S.Terminating (S.pctx_app t₂ (S.pctx_cat
                 (S.papp₂ (inject (S (S n)) τ) S.phole)
                 (emulate_pctx (S (S n)) Cu)))) as termS'
    by (eapply ceq; eauto;
        eapply pctxtyping_cat; crushTyping;
        eauto using injectT, emulate_pctx_T).

  destruct (S.Terminating_TerminatingN termS') as [m termSm']; clear termS'.

  assert (⟪ pempty ⊩ t₂ ⟦ dir_lt , S m ⟧ erase t₂ : embed τ ⟫) as lre₂
      by (change pempty with (embedCtx (repEmulCtx pempty));
          eapply erase_correct;
          cbn; assumption).
  assert (⟪ pempty ⊩ S.app (inject (S (S n)) τ) t₂ ⟦ dir_lt , S m ⟧ U.app (protect τ) (erase t₂) : pEmulDV (S (S n)) imprecise ⟫) as lrpe₂
      by (eapply inject_works_open;
          eauto using dwp_imprecise).
  fold (compile τ t₁) in lrpe₂.

  assert (⟪ ⊩ emulate_pctx (S (S n)) Cu ⟦ dir_lt , S m ⟧ Cu :
              pempty , pEmulDV (S (S n)) imprecise → pempty , pEmulDV (S (S n)) imprecise ⟫) as lrem₂ by
      (change pempty with (toEmulDV (S (S n)) imprecise 0);
       eapply emulate_pctx_works; eauto using dwp_imprecise).

  pose proof (proj2 lrem₂ _ _ lrpe₂) as lrfull₂.
  rewrite S.pctx_cat_app in termSm'.

  eapply (adequacy_lt lrfull₂ termSm'); eauto with arith.
Qed.

Lemma fullAbstraction {t₁ t₂ τ} :
  ⟪ S.empty ⊢ t₁ : τ ⟫ →
  ⟪ S.empty ⊢ t₂ : τ ⟫ →
  ⟪ S.empty ⊢ t₁ ≃ t₂ : τ ⟫ ↔
  ⟨ 0 ⊢ compile τ t₁ ≃ compile τ t₂ ⟩.
Proof.
  intros.
  split;
  eauto using equivalenceReflection, equivalencePreservation.
Qed.

Lemma equivalenceReflectionDF {C₁ C₂ τᵢ τₒ} :
  ⟪ ⊢ C₁ : S.empty , τᵢ → S.empty , τₒ ⟫ ->
  ⟪ ⊢ C₂ : S.empty , τᵢ → S.empty , τₒ ⟫ ->
                                (* (⟨ ⊢ (compile_pctx τᵢ C₁) ≃ (compile_pctx τᵢ C₂) : dom Γᵢ → 0 ⟩). *)
  PCtxEquivalentCtx 0 (compile_pctx τᵢ C₁) (compile_pctx τᵢ C₂) ->
  ⟪ ⊢ C₁ ≃ C₂ : S.empty , τᵢ → τₒ  ⟫.
Proof.
  revert C₁ C₂ τᵢ τₒ.
  enough (forall (C₁ C₂ : Stlc.SpecSyntax.PCtx) (τᵢ τₒ : Ty),
            ⟪ ⊢ C₁ : S.empty, τᵢ → S.empty, τₒ ⟫ ->
            ⟪ ⊢ C₂ : S.empty, τᵢ → S.empty, τₒ ⟫ ->
            PCtxEquivalentCtx 0 (compile_pctx τᵢ C₁) (compile_pctx τᵢ C₂) ->
            forall (t : Tm), ⟪ S.empty ⊢ t : τᵢ ⟫ -> Stlc.SpecEvaluation.Terminating (Stlc.SpecSyntax.pctx_app t C₁) ->
              Stlc.SpecEvaluation.Terminating (Stlc.SpecSyntax.pctx_app t C₂)).
  {
    intros C₁ C₂ τᵢ τₒ tyC₁ tyC₂ seq t tyT.
    split.
    - intros termC₁.
      eapply (H C₁ C₂ τᵢ τₒ tyC₁ tyC₂ seq t tyT termC₁).
    - intros termC₂.
      refine (H C₂ C₁ τᵢ τₒ tyC₂ tyC₁ _ t tyT termC₂).
      eapply U.pctx_equiv_ctx_symm.
      intuition.
  }

  intros C₁ C₂ τᵢ τₒ tyC₁ tyC₂ seq t tyT term.

  destruct (S.Terminating_TerminatingN term) as [n termN]; clear term.
  unfold compile_pctx in seq.

  assert (⟪ ⊩ C₁ ⟦ dir_lt , S n ⟧ erase_pctx C₁ : pempty , embed τᵢ → pempty , embed τₒ ⟫) as lrC₁
  by (change pempty with (embedCtx (repEmulCtx pempty));
      eapply erase_ctx_correct; cbn; assumption).

  assert (⟪ pempty ⊩ t ⟦ dir_lt , S n ⟧ U.app (confine τᵢ) (erase t) : embed τᵢ ⟫) as lrct
  by (eapply confine_transp_open;
      change pempty with (embedCtx S.empty);
      eapply erase_correct;
      assumption).

  pose proof (proj2 lrC₁ _ _ lrct) as lrfull₁.

  assert (U.Terminating (U.pctx_app (U.app (confine τᵢ) (erase t)) (erase_pctx C₁))) as termU₁
  by (eapply (adequacy_lt lrfull₁ termN); eauto with arith).

  assert (U.Terminating (U.pctx_app (U.app (confine τᵢ) (erase t)) (erase_pctx C₂))) as termU₂.
  { specialize (seq (erase t)).
    rewrite ?pctx_cat_app in seq.
    eapply seq.
    change 0 with (dom S.empty).
    eapply (erase_scope _ _ _ tyT).
    cbn. assumption.
  }

  destruct (U.Terminating_TerminatingN termU₂) as [n₂ termUN₂].
  refine (adequacy_gt (n := S n₂) _ termUN₂ _); [|omega].

  assert (⟪ ⊩ C₂ ⟦ dir_gt , S n₂ ⟧ erase_pctx C₂ : pempty , embed τᵢ → pempty , embed τₒ ⟫) as lrC₂
  by (change pempty with (embedCtx (repEmulCtx pempty));
      eapply erase_ctx_correct; cbn; assumption).

  eapply (proj2 lrC₂).
  eapply confine_transp_open.
  change pempty with (embedCtx S.empty).
  eapply erase_correct.
  assumption.
Qed.

Lemma equivalencePreservationDF {C₁ C₂ τᵢ τₒ} :
  ⟪ ⊢ C₁ : S.empty , τᵢ → S.empty , τₒ ⟫ ->
  ⟪ ⊢ C₂ : S.empty , τᵢ → S.empty , τₒ ⟫ ->
                                (* (⟨ ⊢ (compile_pctx τᵢ C₁) ≃ (compile_pctx τᵢ C₂) : dom Γᵢ → 0 ⟩). *)
  ⟪ ⊢ C₁ ≃ C₂ : S.empty , τᵢ → τₒ  ⟫ ->
  PCtxEquivalentCtx 0 (compile_pctx τᵢ C₁) (compile_pctx τᵢ C₂).
Proof.
  revert C₁ C₂ τᵢ τₒ.
  enough (forall (C₁ C₂ : Stlc.SpecSyntax.PCtx) (τᵢ τₒ : Ty),
            ⟪ ⊢ C₁ : S.empty, τᵢ → S.empty, τₒ ⟫ ->
            ⟪ ⊢ C₂ : S.empty, τᵢ → S.empty, τₒ ⟫ ->
            ⟪ ⊢ C₁ ≃ C₂ : S.empty, τᵢ → τₒ ⟫ ->
            forall (t : UTm), wsUTm 0 t ->
                         (pctx_app t (compile_pctx τᵢ C₁))⇓ → (pctx_app t (compile_pctx τᵢ C₂)) ⇓ ).
  {
    intros C₁ C₂ τᵢ τₒ tyC₁ tyC₂ seq t tyT.
    split.
    - intros termC₁.
      eapply (H C₁ C₂ τᵢ τₒ tyC₁ tyC₂ seq t tyT termC₁).
    - intros termC₂.
      refine (H C₂ C₁ τᵢ τₒ tyC₂ tyC₁ _ t tyT termC₂).
      eapply S.pctx_equiv_ctx_symm.
      intuition.
  }

  intros C₁ C₂ τᵢ τₒ tyC₁ tyC₂ seq t tyT term.

  destruct (U.Terminating_TerminatingN term) as [n termN]; clear term.
  unfold compile_pctx in *.
  rewrite ?U.pctx_cat_app in *.
  cbn in *.

  assert (⟪ ⊩ C₁ ⟦ dir_gt , S n ⟧ erase_pctx C₁ : pempty , embed τᵢ → pempty , embed τₒ ⟫) as lrC₁
  by (change pempty with (embedCtx (repEmulCtx pempty));
      eapply erase_ctx_correct; cbn; assumption).

  assert (⟪ pempty ⊩ S.app (extract (S (S n)) τᵢ) (emulate (S (S n)) t) ⟦ dir_gt , S n ⟧ U.app (confine τᵢ) t : embed τᵢ ⟫) as lrct
  by (eapply extract_works_open;
      eauto using dwp_precise with arith;
      change pempty with (toEmulDV (S (S n)) precise 0);
      eapply emulate_works;
      eauto using dwp_precise with arith;
      assumption).

  pose proof (proj2 lrC₁ _ _ lrct) as lrfull₁.

  assert (S.Terminating (S.pctx_app (S.app (extract (S (S n)) τᵢ) (emulate (S (S n)) t)) C₁)) as termS₁
  by (eapply (adequacy_gt lrfull₁ termN); eauto with arith).

  assert (S.Terminating (S.pctx_app (S.app (extract (S (S n)) τᵢ) (emulate (S (S n)) t)) C₂)) as termS₂
  by (eapply seq;
    crushTyping;
    eauto using extractT;
    change S.empty with (toUVals (S (S n)) 0);
    eapply emulate_T;
    assumption).

  destruct (S.Terminating_TerminatingN termS₂) as [n₂ termSN₂].
  refine (adequacy_lt (n := S n₂) _ termSN₂ _); [|omega].

  assert (⟪ ⊩ C₂ ⟦ dir_lt , S n₂ ⟧ erase_pctx C₂ : pempty , embed τᵢ → pempty , embed τₒ ⟫) as lrC₂
  by (change pempty with (embedCtx (repEmulCtx pempty));
      eapply erase_ctx_correct; cbn; assumption).

  eapply lrC₂.
  eapply extract_works_open.
  - eauto using dwp_imprecise with arith.
  - change pempty with (toEmulDV (S (S n)) imprecise 0).
    eapply emulate_works; [|assumption].
    eauto using dwp_imprecise with arith.
Qed.

Lemma fullAbstractionDF {C₁ C₂ : Stlc.SpecSyntax.PCtx} {τᵢ τₒ} :
  ⟪ ⊢ C₁ : S.empty , τᵢ → S.empty , τₒ ⟫ ->
  ⟪ ⊢ C₂ : S.empty , τᵢ → S.empty , τₒ ⟫ ->
  ⟪ ⊢ C₁ ≃ C₂ : S.empty , τᵢ → τₒ  ⟫ ↔
                                (* (⟨ ⊢ (compile_pctx τᵢ C₁) ≃ (compile_pctx τᵢ C₂) : dom Γᵢ → 0 ⟩). *)
   PCtxEquivalentCtx 0 (compile_pctx τᵢ C₁) (compile_pctx τᵢ C₂).
Proof.
  intros.
  split;
  eauto using equivalencePreservationDF, equivalenceReflectionDF.
Qed.

Print Assumptions fullAbstraction.
Print Assumptions fullAbstractionDF.


Require Import Cosa.Lib.Header.
Require Import Cosa.Lib.Relation.
Require Import Cosa.Lib.Predicate.
Require Import Cosa.Lib.MapReduce.
Require Import Cosa.Concrete.ConcreteFragment.
Require Import Cosa.Abstract.Valuation.
Import Coq.Classes.EquivDec.
Import Values.
Import List.ListNotations.
Require Import Coq.Lists.SetoidPermutation.
Require Import Cosa.Nominal.Set.
Require Import Cosa.Nominal.CompcertInstances.

(** The bare graphs consitute the memory model of the shape domain.
    They are to be paired with a numerical domain to make a complete
    abstract domain. *)

(** Basic types *)

(** Types of the nodes of the graph. *)
Definition node : Type := Atom.
Instance node_nominal : Nominal node := perm_nominal.

Definition node_eq_dec := Pos.eq_dec.

Instance node_eq_dec_inst : EquivDec.EqDec node eq.
Proof. exact node_eq_dec. Qed.

Module NodeTree := AtomTree.

(** In this version offsets are concrete [int], however, in more
    fine-grain world, they would be abstract expressions. *)
Definition offs := int.
Instance offs_nominal : Nominal offs := discrete_nominal.

(** Representation of pointers in the abstract graph. *)
Definition off_node := (node * offs)%type.
Hint Unfold off_node : equivariant.

(** Spiwack: I'm really not sure it matters wether valuation are
    finitely supported or not.  Concretely a finitely supported
    valuation is constant except on a finite set of atoms. This is not
    unreasonable to ask, but it may prove harder to achieve than
    expected. And it may not be needed, after all, what really matter
    are sets of valuations. Truth be told: this file seems indifferent
    to whether valuations are finitely supported or not. Up to the
    fact, of course, that some [Nominal] instances would have to be
    changed into [Action]. So we'll see in further files which choice
    works best. *)
Notation valuation := (node -fs-> val).

(** Concrete states *)

(** A graph contretises to a pair of a valuation and a concrete heap
    fragment.  The valuation maps nodes to their addresses or their
    numerical value. *)
Definition conc := (valuation * ConcreteFragment.fragment)%type.
Hint Unfold conc : equivariant.

Instance fragment_nominal : Nominal ConcreteFragment.fragment :=
  Nominal.Set.discrete_nominal
.

Program Instance conc_nominal : Nominal conc := prod_nominal _ _ _ _ .

(** We extend the separating star on concrete heap fragments to
    concrete graph representations. *)
Definition star : conc -> conc -> conc -> Prop := Relation.pair teq ConcreteFragment.star.
Definition estar := extension2 star.

Lemma equivariant_teq (A:Type) `(Action A) : Equivariant teq.
Proof.
  apply equivariant_alt₃.
  intros π x y z. simpl. apply prop_extensionality.
  assert (forall π x y z, teq x y z -> teq (π·x) (π·y) (π·z)) as h.
  { clear. intros π x y z [].
    constructor. }
  split.
  + intros h'. eapply (h (op_p π)) in h'.
    solve_act.
  + eauto.
Qed.
(* Hint EResolve equivariant_teq : equivariant. *)
Hint Extern 0 (Equivariant teq) => eapply equivariant_teq : equivariant.

Lemma equivariant_fragment_star : Equivariant ConcreteFragment.star.
Proof. easy. Qed.
(* Hint EResolve equivariant_fragment_star : equivariant. *)
Hint Extern 0 (Equivariant ConcreteFragment.star) => eapply equivariant_fragment_star : equivariant.

Lemma equivariant_relation_pair
      A `(Action A) B `(Action B) : Equivariant (@Relation.pair A B).
Proof.
  apply equivariant_alt₂. intros π r₁ r₂.
  unfold Relation.pair.
  extensionality x; extensionality y; extensionality z. simpl.
  reflexivity.
Qed.
(* Hint EResolve equivariant_relation_pair : equivariant. *)
Hint Extern 0 (Equivariant Relation.pair) => eapply equivariant_relation_pair : equivariant.

(* arnaud: v'erifier que ce helper est bien n'ecessaire/utile *)
(** Help the proof search when there is [conc] instead of an explicit product. *)
Corollary equivariant_relation_pair_conc :
          @Equivariant (_->_->conc -> conc -> conc -> Prop) _ (@Relation.pair valuation ConcreteFragment.fragment).
Proof. narrow_equivariant. Qed.
(* Hint EResolve equivariant_relation_pair_conc : equivariant. *)
Hint Extern 0 (@Equivariant (_->_->conc->conc->conc->Prop) _ Relation.pair) => eapply equivariant_relation_pair_conc : equivariant.

Lemma equivariant_star : Equivariant star.
Proof. unfold star. narrow_equivariant. Qed.
(* Hint EResolve equivariant_star : equivariant. *)
Hint Extern 0 (Equivariant star) => eapply equivariant_star : equivariant.

Lemma equivariant_extension2 A `(Action A) B `(Action B) C `(Action C) :
  Equivariant (@extension2 A B C).
Proof.
  apply equivariant_alt₁. intros π r.
  extensionality p; extensionality q; extensionality z. unfold extension2. simpl.
  apply prop_extensionality. simplify_act.
  firstorder (simplify_act; firstorder).
Qed.
(* Hint EResolve equivariant_extension2 : equivariant. *)
Hint Extern 0 (Equivariant extension2) => eapply equivariant_extension2 : equivariant.

Corollary equivariant_estar : Equivariant estar.
Proof. narrow_equivariant. Qed.
(* Hint EResolve equivariant_estar : equivariant. *)
Hint Extern 0 (Equivariant estar) => eapply equivariant_estar : equivariant.

Definition empty (s:conc) : Prop := ConcreteFragment.empty (snd s).

Lemma empty_equivariant : Equivariant empty.
Proof. now unfold Equivariant. Qed.
(* Hint EResolve empty_equivariant : equivariant. *)
Hint Extern 0 (Equivariant empty) => eapply empty_equivariant : equivariant.

Lemma empty_spec : empty = Predicate.pair (fun _ => True) ConcreteFragment.empty.
Proof.
  apply Predicate.equiv_eq; intro s.
  unfold empty, Predicate.pair.
  firstorder.
Qed.

Instance star_associative : Associative eq estar.
Proof. unfold estar; typeclasses eauto. Qed.

Instance star_commutative : Commutative eq estar.
Proof. unfold estar; typeclasses eauto. Qed.

Instance star_empty_neutral : LeftNeutral eq estar empty.
Proof. rewrite empty_spec; unfold estar; typeclasses eauto. Qed.

Instance estar_increasing : Proper (Subset==>Subset==>Subset) estar.
Proof. unfold estar; typeclasses eauto. Qed.

Lemma estar_continuous_2 I (x:℘ conc) (f:I->℘ conc):
  estar x (Join (Γ:=[conc]) f) = Join (Γ:=[conc]) (fun i => estar x (f i)).
Proof.
  unfold estar.
  apply extension2_continuous_2.
Qed.

(** Definition of the graph itself *)

(** Abstract representation for a block. The idea is that a node is
    either a numerical value or a block. Numerical values in a block
    will therefore be represented as an extra indirection. In pointers
    pointing to a value node, the offset must be 0.

    In Xisa, blocks have a number of meta data that we shall ignore in
    a first step. These meta data are not crucial for correctness, and
    can be added easily later. *)
Record pt_edge := {
  destination : off_node;
  size : AST.memory_chunk
}.

Program Instance pt_edge_nominal : Nominal pt_edge :=
  nominal_of_iso
    (fun e => (e.(destination),e.(size)))
    (fun e' => {| destination := fst e' ; size := snd e' |})
    _ _
.
Next Obligation.
  (* [x] should not have been introduced. *)
  revert x.
  (* / *)
  intros [].
  easy.
Qed.

Remark equivariant_destination : Equivariant destination.
Proof. now apply equivariant_alt₁. Qed.
(* Hint EResolve equivariant_destination : equivariant. *)
Hint Extern 0 (Equivariant destination) => eapply equivariant_destination : equivariant.

Remark equivariant_size : Equivariant size.
Proof. now apply equivariant_alt₁. Qed.
(* Hint EResolve equivariant_size : equivariant. *)
Hint Extern 0 (Equivariant size) => eapply equivariant_size : equivariant.

Definition block := list (offs*pt_edge).

Instance block_nominal : Nominal block := list_nominal _ _.

Inductive γ_point_to₀ (α:node) (o:offs) (c:AST.memory_chunk) (β:node) (o':offs) (f:fragment) (ν:valuation) : Prop :=
| γ_point_to_offs : forall b i b' i',
    ν α = Vptr b i ->
    snd f = memory_range b (Int.add i o) c ->
    ν β = Vptr b' i' ->
    ConcreteFragment.reads f c b o (Vptr b' (Int.add i' o')) ->
    γ_point_to₀ α o c β o' f ν
| γ_point_to_normal : forall b i,
    ν α = Vptr b i ->
    snd f = memory_range b (Int.add i o) c ->
    o' = Int.zero ->
    ConcreteFragment.reads f c b o (ν β) ->
    γ_point_to₀ α o c β o' f ν
.

Definition γ_point_to α o c β o' : ℘ conc :=
  fun s => γ_point_to₀ α o c β o' (snd s) (fst s)
.

Definition γ_block (α:node) (b:block) : ℘ conc :=
  list_reduce estar empty (
      List.map (fun edge =>
                  γ_point_to α
                             (fst edge)
                             (snd edge).(size)
                             (fst (snd edge).(destination))
                             (snd (snd edge).(destination))
      ) b
  )
.

Section Graph.

  (** Graphs contain both "point to edges" representing individual
      memory cells, and summarised edges which stands for larger
      regions. Summarised edges are instantiated to inductive region
      and inductive segment in [Cosa.Shape.Inductive]. *)

  Context {summary:Type} (γ_summary : summary -> node -> ℘ conc).
  Context {summary_nominal:Nominal summary} (equivariant_γ_summary : Equivariant γ_summary).
  (* Hint EResolve equivariant_γ_summary : equivariant. *)
  Hint Extern 0 (Equivariant γ_summary) => eapply equivariant_γ_summary : equivariant.

  Inductive edge :=
  | Point_to (b:block)
  | Summarized (s:summary)
  .

  Program Instance edge_nominal : Nominal edge :=
    nominal_of_iso
      (fun e =>
         match e return _ with Point_to b => inl b | Summarized s => inr s end)
      (fun e =>
         match e return _ with inl b => Point_to b | inr s => Summarized s end)
      _ _
  .
  Next Obligation.
    (* [x] should not have been introduced *)
    revert x.
    (* / *)
    intros [|]; easy.
  Qed.
  Next Obligation.
    (* [x] should not have been introduced *)
    revert x.
    (* / *)
    intros [|]; easy.
  Qed.

  Definition γ_edge (α:node) (e:edge) :=
    match e with
    | Point_to b => γ_block α b
    | Summarized s => γ_summary s α
    end
  .

  Definition t := NodeTree.t edge.

  Global Instance graph_nominal : Nominal t := Nominal.Set.map_nominal _ _.

  Definition equiv : t -> t -> Prop := AtomTree_Properties.Equal (eqA:=eq) _.

  Global Instance equiv_equivalence : Equivalence equiv.
  Proof.
    unfold equiv.
    apply AtomTree_Properties.Equal_Equivalence.
  Qed.

  Lemma equiv_alt g₁ g₂ : equiv g₁ g₂ <-> (forall α, g₁!α = g₂!α).
  Proof. apply ptree_equal_eq_alt. Qed.

  Definition γ := ptree_map_reduce γ_edge estar empty.

  Lemma γ_equiv g₁ g₂ : equiv g₁ g₂ -> γ g₁ = γ g₂.
  Proof.
    intros h.
    apply ptree_permutation_equiv in h.
    unfold γ.
    rewrite !ptree_map_reduce_spec.
    rewrite h.
    reflexivity.
  Qed.

  Lemma γ_disjoint_union (g₁ g₂:t) :
    ptree_disjoint g₁ g₂ ->
    γ (ptree_union g₁ g₂) = estar (γ g₁) (γ g₂).
  Proof.
    intros g₁_g₂_d.
    unfold γ.
    apply ptree_disjoint_map_reduce; (typeclasses eauto||assumption).
  Qed.

  (** This theorem (following from the continuity of [estar]) can be
      seen as the crux of edge unfolding. It is, however, unused. *)
  Theorem star_disjoint_union I (g₁ g₂:t) (g:I->t) :
    ptree_disjoint g₁ g₂ ->
    γ g₂ ⊆ Join (Γ:=[conc]) (fun i => γ (g i)) ->
    (forall i, ptree_disjoint g₁ (g i)) ->
    γ (ptree_union g₁ g₂) ⊆ Join (Γ:=[conc]) (fun i => γ (ptree_union g₁ (g i))).
  Proof.
    intros g₁_g₂_d g_spec g₁_g_d.
    rewrite γ_disjoint_union; [|assumption].
    rewrite g_spec.
    rewrite estar_continuous_2.
    apply Join_increasing; rewrite sub_cons; intro i.
    rewrite γ_disjoint_union; [|eauto].
    reflexivity.
  Qed.

  Lemma single_out_one_edge (g:t) α :
    forall e, g!α = Some e ->
    γ g = estar (γ (NodeTree.remove α g)) (γ_edge α e).
  Proof.
    intros * h.
    set (g' := NodeTree.remove α g).
    set (gα := NodeTree.set α e (NodeTree.empty _)).
    assert (ptree_disjoint g' gα) as g'_gα_d.
    { unfold ptree_disjoint.
      intros β e₁ e₂ hg' hgα.
      unfold g',gα in hg',hgα.
      CPTree.simplify;congruence. }
    assert (Graph.equiv g (ptree_union g' gα)) as g_g'_gα.
    { unfold Graph.equiv,AtomTree_Properties.Equal.
      intros β.
      generalize (node_eq_dec α β).
      intros [ <- | α_neq_β ].
      + rewrite h.
        unfold ptree_union.
        rewrite NodeTree.gcombine; [|easy].
        unfold g',gα.
        CPTree.simplify.
        reflexivity.
      + unfold ptree_union.
        rewrite NodeTree.gcombine; [|easy].
        unfold g',gα.
        CPTree.simplify.
        now destruct (g!β). }
    transitivity (γ (ptree_union g' gα)).
    { now apply γ_equiv. }
    assert (γ_edge α e = γ gα) as ->.
    { unfold γ; rewrite ptree_map_reduce_spec.
      assert ([(α,e)] = AtomTree.elements gα) as <-.
      { clear.
        apply singleton_eq_norepet.
        { intros [β e']; split.
          - intros h.
            apply NodeTree.elements_complete in h.
            unfold gα in h.
            CPTree.simplify; congruence.
          - intros h; simpl in h.
            rewrite h; clear β e' h.
            apply NodeTree.elements_correct.
            unfold gα.
            CPTree.simplify; congruence. }
        apply ptree_elements_norepet. }
      simpl.
      now rewrite left_neutrality. }
    now apply γ_disjoint_union.
  Qed.

  Corollary single_out_one_edge_set (g:t) α e :
    g!α = None ->
    γ (NodeTree.set α e g) = estar (γ g) (γ_edge α e).
  Proof.
    intros h₁.
    set (g' := (NodeTree.set α e g)).
    rewrite (single_out_one_edge g' α e).
    { f_equal.
      apply γ_equiv,equiv_alt.
      intros β. unfold g'; clear g'.
      CPTree.simplify; congruence. }
    unfold g'; clear g'.
    CPTree.simplify; congruence.
  Qed.

  Theorem star_summarized_edge (g:t) α :
    forall sm, g!α = Some (Summarized sm) ->
    forall s:conc, s ∈ γ g ->
    exists (s₁ s₂:conc),
      s₁ ∈ γ (NodeTree.remove α g) /\ s₂ ∈ γ_summary sm α /\ star s₁ s₂ s.
  Proof.
    intros * h₁ * h₂.
    apply single_out_one_edge in h₁.
    rewrite h₁ in h₂; clear h₁.
    unfold estar,extension2 in h₂.
    destruct h₂ as [ s₁ [ s₂ [ h₁ [ h₂ h₃ ]]]].
    exists s₁; exists s₂.
    decompose_concl; eauto.
  Qed.

  Lemma γ_empty : γ (NodeTree.empty _) = empty.
  Proof.
    unfold γ; rewrite ptree_map_reduce_spec.
    replace (AtomTree.elements (NodeTree.empty edge)) with (@nil (positive*edge)).
    + easy.
    + assert (forall x, ~List.In x (AtomTree.elements (NodeTree.empty edge))) as h.
      { intros [α e] h.
        apply AtomTree.elements_complete in h.
        CPTree.simplify; congruence. }
      destruct (AtomTree.elements (NodeTree.empty edge)) as [ | x l ].
      * reflexivity.
      * specialize (h x); simpl in h.
        contradiction h.
        now left.
  Qed.

  (** The concretisation is equivariant. *)

  (* arnaud: Notation a deplacer *)
  Notation "`⟨ x ⟩" := (exist _ x _).

  Lemma γ_point_to_equivariant : Equivariant γ_point_to.
  Proof.
    rewrite equivariant_alt₁.
    intros π α.
    apply act_float_l. simpl.
    extensionality o;
      extensionality c; extensionality β; extensionality o'; extensionality νf.
    destruct νf as [ν f]. unfold γ_point_to. simpl.
    apply prop_extensionality.
    assert (forall π α o c β o' ν f,
              γ_point_to₀ (π·α) o c (π·β) o' f (π·ν) -> γ_point_to₀ α o c β o' f ν) as h.
    (* arnaud: voir `a utiliser solve_act dans cette sous-preuve *)
    { clear. intros * [ b i b' i' h₁ h₂ h₃ h₄ | b i h₁ h₂ h₃ h₄ ];
        econstructor (solve[
          simpl in *;
          rewrite <- ?perm_comp', ?op_p_spec_l in *|-; simpl in *;
          eassumption]). }
    split.
    + intros h₁.
      eapply h.
      apply_eq h₁.
      * solve_act.
      * reflexivity.
    + intros h₁.
      apply (h (op_p π)).
      (* arnaud: mettre fs_extensionality dans solve_act pour simplifier le reste de la preuve. *)
      apply_eq h₁.
      * simpl.
        now rewrite <- perm_comp', op_p_spec_l; simpl.
      * now rewrite <- perm_comp', op_p_spec_r; simpl.
      * apply fs_extensionality. extensionality δ. simpl.
        now rewrite <- perm_comp', op_p_spec_l; simpl.
  Qed.
  (* Hint EResolve γ_point_to_equivariant : equivariant. *)
  Hint Extern 0 (Equivariant γ_point_to) => eapply γ_point_to_equivariant : equivariant.

  (* arnaud: peut-etre deplacer tout ca *)

  Lemma list_reduce_equivariant A `(Action A) : Equivariant (@list_reduce A).
  Proof.
    rewrite equivariant_alt₁.
    intros π f. extensionality s; extensionality l.
    revert s.
    induction l as [ | x l h ].
    + intros s. simpl.
      solve_act.
    + intros s. unfold list_reduce in *.
      simpl List.fold_left.
      rewrite h. simpl.
      solve_act.
  Qed.
  (* Hint EResolve list_reduce_equivariant : equivariant. *)
  Hint Extern 0 (Equivariant list_reduce) => eapply list_reduce_equivariant : equivariant.

  Program Instance option_action A `(Action A) : Action (option A) := {|
    act π o := match o return _ with Some x => Some (π·x) | None => None end
  |}.
  Next Obligation.
    autounfold.
    intros π₁ π₂ hπ x y <-.
    now destruct x; rewrite ?hπ.
  Qed.
  Next Obligation.
    (* [x] should not have been introduced *)
    revert x.
    (* / *)
    now intros [?|]; rewrite ?act_id.
  Qed.
  Next Obligation.
    (* [x] should not have been introduced *)
    revert x.
    (* / *)
    now intros [?|]; rewrite ?act_comp.
  Qed.

  Lemma map_action_alt_eq A `(Action A) π (m:AtomTree.t A) :
    forall α, (π·m)!α = π·(m!((op_p π)·α)).
  Proof.
    assert (forall o₁ o₂:option A, (forall v, o₁ = Some v <-> o₂ = Some v) -> o₁ = o₂) as rem.
    { clear.
      destruct o₁; destruct o₂; try firstorder congruence.
      (* no idea why the last case isn't solved by [firstorder congruence] *)
      intros h. symmetry. rewrite <- h.
      easy. }
    intros α.
    apply rem. intros v.
    rewrite map_action_alt.
    rewrite <- act_float_r.
    reflexivity.
  Qed.

  Lemma equivariant_map_set A `(Action A) : Equivariant (@AtomTree.set A).
  Proof.
    apply equivariant_alt₃.
    intros π α x m.
    apply AtomTree.unicity. intros β.
    rewrite map_action_alt_eq.
    destruct (Pos.eq_dec (π·α) β) as [ <- | nβ ].
    { simplify_act.
      now AtomTree.simplify. }
    assert (α <> (op_p π)·β) as nβ'.
    { intros ?. apply nβ.
      now apply act_float_r. }
    AtomTree.simplify.
    apply map_action_alt_eq.
  Qed.
  (* Hint EResolve equivariant_map_set : equivariant. *)
  Hint Extern 0 (Equivariant AtomTree.set) => eapply equivariant_map_set : equivariant.

  Lemma ptree_map_reduce_equivariant A `(Action A) B `(Action B)
    (f:node->A->B) (ef:Equivariant f)
    (r:B->B->B) (er:Equivariant r) `(Associative _ eq r) `(Commutative _ eq r)
    (n:B) (en:Equivariant n) `(LeftNeutral _ eq r n) :
    Equivariant (ptree_map_reduce f r n).
  Proof.
    unfold Equivariant, support. intros π _.
    unfold ptree_map_reduce at 2. extensionality m.
    apply AtomTree_Properties.fold_rec.
    + intros m₁ m₂ b h.
      apply AtomTree.unicity in h. rewrite <- h.
      easy.
    + apply en. intros **; AtomSet.fsetdec'.
    + intros m' b α a hk₁ hk₂ h.
      simpl. change (map_action_f A H (op_p π) (CPTree.set α a m')) with ((op_p π)·(CPTree.set α a m')).
      generalize equivariant_map_set. intros hset.
      eapply equivariant_alt₃ in hset. erewrite <- hset.
      rewrite ptree_set_map_reduce; [|typeclasses eauto ..|].
      * eapply equivariant_alt₂ in er. erewrite <- er.
        simpl in h|-*. rewrite h.
        eapply equivariant_alt₂ in ef. erewrite <- ef.
        solve_act.
      * rewrite map_action_alt_eq.
        simplify_act.
        now rewrite hk₁.
  Qed.
  (* Hint EResolve ptree_map_reduce_equivariant : equivariant. *)
  Hint Extern 4 (Equivariant (ptree_map_reduce _ _ _)) => eapply ptree_map_reduce_equivariant : equivariant.

(* arnaud: unused right now
  Lemma act_app_up A `(Action A) B `(Action B) π (f:A->B) (x:A) : (π·f) x = π·(f ((op_p π)·x)).
  Proof.
    reflexivity.
  Qed.

  Lemma act_app_down A `(Action A) B `(Action B) π (f:A->B) (x:A): π·(f x) = (π·f) (π·x).
  Proof.
    simpl.
    solve_act.
  Qed.

  Lemma equivariant_cancel {A} `{Action A} (f:A) :
    Equivariant f -> forall π, π·f = f.
  Proof.
    intros h π. apply h.
    intros **.
    AtomSet.fsetdec'.
  Qed.

  (* Doesn't handle the dependent product case gracefully. *)
  Ltac push_equivariant :=
    erewrite ?act_app_up; (* eliminates β-redexes *)
    erewrite ?act_app_down; (* pushes permutation as deeply as possible *)
    repeat match goal with
    | |- appcontext[?p·?f] =>
         erewrite (equivariant_cancel f);[|solve[narrow_equivariant]]
    end
  .
*)

  (* arnaud: /peut-etre deplacer tout ca *)

  Lemma γ_block_equivariant : Equivariant γ_block.
  Proof.
    unfold γ_block.
    combinatorize.
    narrow_equivariant.
  Qed.
  (* Hint EResolve γ_block_equivariant : equivariant. *)
  Hint Extern 0 (Equivariant γ_block) => eapply γ_block_equivariant : equivariant.

  Lemma γ_edge_equivariant : Equivariant γ_edge.
  Proof.
    apply equivariant_alt₂.
    intros π α [e|e].
    + generalize γ_block_equivariant; intros h.
      eapply equivariant_alt₂ in h.
      eapply h.
    + eapply equivariant_alt₂ in equivariant_γ_summary.
      eapply equivariant_γ_summary.
  Qed.
  (* Hint EResolve γ_edge_equivariant : equivariant. *)
  Hint Extern 0 (Equivariant γ_edge) => eapply γ_edge_equivariant : equivariant.

  Lemma γ_equivariant : Equivariant γ.
  Proof.
    unfold γ.
    typeclasses eauto with equivariant typeclass_instances.
  Qed.

  (* (** The valuation matters only on the node of the graph. *) *)

  (* Definition belongs_to_point_to α (o:offs) (c:AST.memory_chunk) β (o':offs) : ℘ node := *)
  (*   fun δ => δ = α \/ δ = β *)
  (* . *)

  (* (* Lemma valuation_not_fixed_point_to α o chunk β o' f: *) *)
  (* (*   central (belongs_to_point_to α o chunk β o') *) *)
  (* (*           (fun ν => (ν,f) ∈ γ_point_to α o chunk β o'). *) *)
  (* (* Proof. *) *)
  (* (*   unfold central. intros δ γ hδ hγ ν h₁. *) *)
  (* (*   unfold belongs_to_point_to in *. *) *)
  (* (*   destruct h₁; simpl in *. *) *)
  (* (*   + eleft; eauto; simpl. *) *)
  (* (*     * unfold Valuation.swap. *) *)
  (* (*       destruct (α == δ) as [ <- | _ ]. *) *)
  (* (*       { clear -hδ; firstorder. } *) *)
  (* (*       destruct (α == γ) as [ <- | _ ]. *) *)
  (* (*       { clear -hγ; firstorder. } *) *)
  (* (*       easy. *) *)
  (* (*     * unfold Valuation.swap. *) *)
  (* (*       destruct (β == δ) as [ <- | _ ]. *) *)
  (* (*       { clear -hδ; firstorder. } *) *)
  (* (*       destruct (β == γ) as [ <- | _ ]. *) *)
  (* (*       { clear -hγ; firstorder. } *) *)
  (* (*       easy. *) *)
  (* (*   + eright; eauto; simpl. *) *)
  (* (*     * unfold Valuation.swap. *) *)
  (* (*       destruct (α == δ) as [ <- | _ ]. *) *)
  (* (*       { clear -hδ; firstorder. } *) *)
  (* (*       destruct (α == γ) as [ <- | _ ]. *) *)
  (* (*       { clear -hγ; firstorder. } *) *)
  (* (*       easy. *) *)
  (* (*     * replace (Valuation.swap δ γ ν β) with (ν β). *) *)
  (* (*       { easy. } *) *)
  (* (*       unfold Valuation.swap. *) *)
  (* (*       destruct (β == δ) as [ <- | _ ]. *) *)
  (* (*       { clear -hδ; firstorder. } *) *)
  (* (*       destruct (β == γ) as [ <- | _ ]. *) *)
  (* (*       { clear -hγ; firstorder. } *) *)
  (* (*       easy. *) *)
  (* (* Qed. *) *)

  (* Definition belongs_to_block α b : ℘ node := *)
  (*   (fun β => β = α) ∪ (* case where the block is empty *) *)
  (*   list_reduce union ∅ *)
  (*               (List.map  *)
  (*                  (fun oe => *)
  (*                     belongs_to_point_to *)
  (*                       α (fst oe) (snd oe).(size)  *)
  (*                       (fst (snd oe).(destination)) (snd (snd oe).(destination)) *)
  (*                  ) b *)
  (*               ) *)
  (* . *)

  (* (* Lemma valuation_not_fixed_block α b f : *) *)
  (* (*   central (belongs_to_block α b) *) *)
  (* (*           (fun ν => (ν,f) ∈ γ_block α b). *) *)
  (* (* Proof. *) *)
  (* (*   unfold central. intros β δ hβ hδ ν. revert f. *) *)
  (* (*   induction b as [ | p b hb ]; intros f h₁. *) *)
  (* (*   - (* b = [] *) *) *)
  (* (*     unfold γ_block in *; simpl in *. *) *)
  (* (*     unfold empty in *; simpl in *. *) *)
  (* (*     assumption. *) *)
  (* (*   - (* b = p::b *) *) *)
  (* (*     unfold γ_block in h₁ |- *. *) *)
  (* (*     rewrite list_map_cons,(list_reduce_cons eq); [ | typeclasses eauto .. ]. *) *)
  (* (*     rewrite list_map_cons,(list_reduce_cons eq) in h₁; [ | typeclasses eauto .. ]. *) *)
  (* (*     destruct h₁ as [ [ ν₁ f₁ ] [ [ ν₂ f₂ ] [ h₂ [ h₃ [ h₄ h₅ ]]]]]; simpl in h₄,h₅. *) *)
  (* (*     destruct h₄. *) *)
  (* (*     exists (Valuation.swap β δ ν₁,f₁); exists (Valuation.swap β δ ν₁,f₂). *) *)
  (* (*     decompose_concl. *) *)
  (* (*     + apply valuation_not_fixed_point_to. *) *)
  (* (*       * clear -hβ; unfold belongs_to_block in hβ. *) *)
  (* (*         intros h. *) *)
  (* (*         apply hβ. *) *)
  (* (*         right. *) *)
  (* (*         rewrite list_map_cons,(list_reduce_cons eq); [ | typeclasses eauto .. ]. *) *)
  (* (*         now left. *) *)
  (* (*       * clear -hδ; unfold belongs_to_block in hδ. *) *)
  (* (*         intros h. *) *)
  (* (*         apply hδ. *) *)
  (* (*         right. *) *)
  (* (*         rewrite list_map_cons,(list_reduce_cons eq); [ | typeclasses eauto .. ]. *) *)
  (* (*         now left. *) *)
  (* (*       * assumption. *) *)
  (* (*     + apply hb. *) *)
  (* (*       * clear -hβ; unfold belongs_to_block in hβ. *) *)
  (* (*         intros h. *) *)
  (* (*         apply hβ. *) *)
  (* (*         destruct h. *) *)
  (* (*         { now left. } *) *)
  (* (*         right. *) *)
  (* (*         rewrite list_map_cons,(list_reduce_cons eq); [ | typeclasses eauto .. ]. *) *)
  (* (*         now right. *) *)
  (* (*       * clear -hδ; unfold belongs_to_block in hδ. *) *)
  (* (*         intros h. *) *)
  (* (*         apply hδ. *) *)
  (* (*         destruct h. *) *)
  (* (*         { now left. } *) *)
  (* (*         right. *) *)
  (* (*         rewrite list_map_cons,(list_reduce_cons eq); [ | typeclasses eauto .. ]. *) *)
  (* (*         now right. *) *)
  (* (*       * apply h₃. *) *)
  (* (*     + split; simpl. *) *)
  (* (*       { constructor. } *) *)
  (* (*       assumption. *) *)
  (* (* Qed. *) *)

  (* (** spiwack: in a more general setting, summaries should control *)
  (*     some nodes.  It would come as an extra piece of data of type *)
  (*     [summary -> ℘ node], for instance. *) *)
  (* Definition belongs_to_summary α (sm:summary) : ℘ node := *)
  (*   fun δ => δ = α *)
  (* . *)

  (* (* Hypothesis valuation_not_fixed_summary : forall α sm f, *) *)
  (* (*   central (belongs_to_summary α sm) *) *)
  (* (*           (fun ν => (ν,f) ∈ γ_summary sm α). *) *)

  (* Definition belongs_to_edge α e : ℘ node := *)
  (*   match e with *)
  (*   | Point_to b => belongs_to_block α b *)
  (*   | Summarized sm => belongs_to_summary α sm *)
  (*   end *)
  (* . *)

  (* (* Lemma valuation_not_fixed_edge α e f : *) *)
  (* (*   central (belongs_to_edge α e) *) *)
  (* (*           (fun ν => (ν,f) ∈ γ_edge α e). *) *)
  (* (* Proof. *) *)
  (* (*   unfold central. intros β δ hβ hδ ν h₁. *) *)
  (* (*   unfold γ_edge. *) *)
  (* (*   destruct e as [ b | sm ]. *) *)
  (* (*   + (* e = Point_to b *) *) *)
  (* (*     simpl in h₁. *) *)
  (* (*     apply valuation_not_fixed_block; eauto. *) *)
  (* (*   + (* e = Summarized sm *) *) *)
  (* (*     simpl in h₁. *) *)
  (* (*     apply valuation_not_fixed_summary; eauto. *) *)
  (* (* Qed. *) *)

  (* Definition belongs_to_graph (g:t) : ℘ node := *)
  (*   ptree_map_reduce belongs_to_edge union ∅ g *)
  (* . *)

  (* Global Instance belongs_to_graph_equiv : Proper (equiv ==> eq) belongs_to_graph. *)
  (* Proof. *)
  (*   unfold Proper,respectful,belongs_to_graph. *)
  (*   intros g₁ g₂ h. *)
  (*   rewrite !ptree_map_reduce_spec. *)
  (*   apply ptree_permutation_equiv in h. *)
  (*   rewrite h. *)
  (*   reflexivity. *)
  (* Qed. *)
  (* Global Instance belongs_to_graph_equiv' : Proper (equiv ==> eq ==> eq) belongs_to_graph. *)
  (* Proof. *)
  (*   unfold Proper,respectful. *)
  (*   intros g₁ g₂ h₁ α ? <-. *)
  (*   apply equal_f. *)
  (*   now rewrite h₁. *)
  (* Qed. *)

  (* Lemma belongs_to_graph_remove (g:t) α : *)
  (*   forall β,  β ∈ belongs_to_graph (NodeTree.remove α g) -> β ∈ belongs_to_graph g. *)
  (* Proof. *)
  (*   intros *. *)
  (*   destruct (g!α) as [ e | ] eqn:h₁. *)
  (*   + (* g!α = Some e *) *)
  (*     set (g' := NodeTree.remove α g). *)
  (*     assert (equiv g (NodeTree.set α e g')) as h₂. *)
  (*     { apply equiv_alt; intros δ. *)
  (*       unfold g'; clear g'. *)
  (*       CPTree.simplify; congruence. } *)
  (*     intros h₃. *)
  (*     erewrite belongs_to_graph_equiv'; [|eauto..]. *)
  (*     unfold belongs_to_graph in *. *)
  (*     rewrite ptree_set_map_reduce; [|typeclasses eauto..|]. *)
  (*     * now right. *)
  (*     * unfold g' in *; clear g'. *)
  (*       CPTree.simplify; congruence. *)
  (*   + (* g!α = None *) *)
  (*     rewrite belongs_to_graph_equiv'; eauto. *)
  (*     apply equiv_alt; intros δ. *)
  (*     CPTree.simplify; congruence. *)
  (* Qed. *)

  (* (* Theorem valuation_not_fixed (g:t) f : *) *)
  (* (*   central (belongs_to_graph g) *) *)
  (* (*           (fun ν => (ν,f) ∈ γ g). *) *)
  (* (* Proof. *) *)
  (* (*   revert f; unfold γ; unfold ptree_map_reduce. *) *)
  (* (*   apply AtomTree_Properties.fold_rec. *) *)
  (* (*   { intros g₁ g₂ P g₁_g₂ h₂ f α β h₃ h₄ ν' h₅. *) *)
  (* (*     apply equiv_alt in g₁_g₂. *) *)
  (* (*     eapply h₂; clear h₂. *) *)
  (* (*     + intros h; apply h₃. *) *)
  (* (*       now apply belongs_to_graph_equiv in g₁_g₂; rewrite <- g₁_g₂. *) *)
  (* (*     + intros h; apply h₄. *) *)
  (* (*       now apply belongs_to_graph_equiv in g₁_g₂; rewrite <- g₁_g₂. *) *)
  (* (*     + assumption. } *) *)
  (* (*   { intros f α β hα hβ ν h. *) *)
  (* (*     unfold empty; simpl. *) *)
  (* (*     unfold empty in h; simpl in h. *) *)
  (* (*     assumption. } *) *)
  (* (*   intros g' P α e h₁ h₂ h f β δ hβ hδ ν h₃. *) *)
  (* (*   destruct h₃ as [ [ ν₁ f₁ ] [ [ ν₂ f₂ ] [ h₃₁ [ h₃₂ [ h₃₃ h₃₄ ]]]]]; simpl in h₃₃,h₃₄. *) *)
  (* (*   destruct h₃₃. *) *)
  (* (*   exists (Valuation.swap β δ ν₁,f₁); exists (Valuation.swap β δ ν₁,f₂). *) *)
  (* (*   decompose_concl. *) *)
  (* (*   + apply h. *) *)
  (* (*     * clear -h₁ hβ. *) *)
  (* (*       intros h; apply hβ. *) *)
  (* (*       unfold belongs_to_graph. *) *)
  (* (*       rewrite ptree_set_map_reduce; [|typeclasses eauto..|easy]. *) *)
  (* (*       now right. *) *)
  (* (*     * clear -h₁ hδ. *) *)
  (* (*       intros h; apply hδ. *) *)
  (* (*       unfold belongs_to_graph. *) *)
  (* (*       rewrite ptree_set_map_reduce; [|typeclasses eauto..|easy]. *) *)
  (* (*       now right. *) *)
  (* (*     * assumption. *) *)
  (* (*   + apply valuation_not_fixed_edge. *) *)
  (* (*     * clear -h₁ hβ. *) *)
  (* (*       intros h; apply hβ. *) *)
  (* (*       unfold belongs_to_graph. *) *)
  (* (*       rewrite ptree_set_map_reduce; [|typeclasses eauto..|easy]. *) *)
  (* (*       now left. *) *)
  (* (*     * clear -h₁ hδ. *) *)
  (* (*       intros h; apply hδ. *) *)
  (* (*       unfold belongs_to_graph. *) *)
  (* (*       rewrite ptree_set_map_reduce; [|typeclasses eauto..|easy]. *) *)
  (* (*       now left. *) *)
  (* (*     * assumption. *) *)
  (* (*   + constructor; simpl. *) *)
  (* (*     * constructor. *) *)
  (* (*     * assumption. *) *)
  (* (* Qed. *) *)

  (* (* Corollary valuation_not_fixed_iter (g:t) : *) *)
  (* (*   forall (p:permutation), permutation_not_in p (belongs_to_graph g) -> *) *)
  (* (*   forall ν f, (ν,f) ∈ γ g -> (p@ν,f) ∈ γ g. *) *)
  (* (* Proof. *) *)
  (* (*   intros **. *) *)
  (* (*   apply central_permutation with (belongs_to_graph g). *) *)
  (* (*   + apply valuation_not_fixed. *) *)
  (* (*   + assumption. *) *)
  (* (*   + assumption. *) *)
  (* (* Qed. *) *)

  (* Lemma domain_belongs g : *)
  (*   forall α e, g!α = Some e -> *)
  (*   α ∈ belongs_to_graph g. *)
  (* Proof. *)
  (*   unfold belongs_to_graph, belongs_to_graph, ptree_map_reduce. *)
  (*   apply AtomTree_Properties.fold_rec. *)
  (*   { intros g₁ g₂ P h₁ h₂ α e h₃. *)
  (*     apply h₂ with e. *)
  (*     now rewrite h₁. } *)
  (*   { intros ** h. *)
  (*     CPTree.simplify; congruence. } *)
  (*   intros g₁ P α e h₁ h₂ h₃ β e' h₄. *)
  (*   CPTree.simplify. *)
  (*   - right. *)
  (*     destruct e; simpl. *)
  (*     + unfold belongs_to_block. *)
  (*       now left. *)
  (*     + unfold belongs_to_summary. *)
  (*       reflexivity. *)
  (*   - left ; eauto. *)
  (* Qed. *)

End Graph.

Arguments t summary : clear implicits.
(* Hint EResolve @γ_equivariant : equivariant. *)
Hint Extern 0 (Equivariant (γ _)) => eapply @γ_equivariant : equivariant.

(** the concretisation are increasing with respect to the concretisation of summarized
    edges. *)
Instance γ_edge_increasing s :
  Proper (sub (Γ:=[s;node;conc]) ==> eq ==> eq ==> sub (Γ:=[conc])) γ_edge.
Proof.
  unfold Proper, respectful.
  intros γ₁ γ₂ γ₁_sub_γ₂ α ? <- e ? <-.
  unfold γ_edge.
  destruct e as [ b | sm ].
  - (* e = point_to b *)
    reflexivity.
  - (* e = summarized sm *)
    simpl in *.
    eauto.
Qed.

Instance γ_increasing s :
  Proper (sub (Γ:=[s;node;conc]) ==> equiv ==> sub (Γ:=[conc])) γ.
Proof.
  unfold Proper, respectful.
  intros γ₁ γ₂ γ₁_sub_γ₂ g₁ g₂ g₁_eq_g₂.
  eapply γ_equiv in g₁_eq_g₂.
  rewrite <- g₁_eq_g₂; clear g₂ g₁_eq_g₂.
  unfold γ.
  rewrite !ptree_map_reduce_spec.
  apply list_reduce_proper.
  { typeclasses eauto. }
  { typeclasses eauto. }
  { reflexivity. }
  apply list_map_plr; [ typeclasses eauto | | reflexivity ].
  unfold respectful.
  intros e ? <-.
  rewrite γ₁_sub_γ₂.
  reflexivity.
Qed.