Require Import K_Syntax.
Require Import wKS_calc.
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 wKS_list_lems.
Require Import dd_fc.
Require Import PeanoNat.
Require Import strong_inductionT.
Require Import wKS_termination_measure.
Require Import wKS_termination.
Require Import wKS_exch.
Require Import wKS_ctr.
Require Import wKS_wkn.
Require Import wKS_remove_list.
Require Import wKS_dec.
Require Import wKS_inv_ImpR_ImpL.
Require Import Lia.

Theorem wKS_cut_adm_main : forall n k A s Γ0 Γ1 Δ0 Δ1,
                      (n = size A) ->
                      (k = mhd s) ->
                      (s = (Γ0 ++ Γ1, Δ0 ++ Δ1)) ->
                      (wKS_prv (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)) ->
                      (wKS_prv (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)) ->
                      (wKS_prv s).
Proof.
(* The proof is by induction on, first, size 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 A ->
                      (k = mhd s) ->
                      (s = (Γ0 ++ Γ1, Δ0 ++ Δ1)) ->
                      ((wKS_prv (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)) ->
                      (wKS_prv (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)) ->
                      (wKS_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 A ->
                      (x = mhd s) ->
                      (s = (Γ0 ++ Γ1, Δ0 ++ Δ1)) ->
                      ((wKS_prv (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)) ->
                      (wKS_prv (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)) ->
                      (wKS_prv s)))).
apply d. clear d. intros k SIH.

(* Now we do the actual proof-theoretical work. *)
assert (DersNilF: dersrec wKS_rules (fun _ : Seq => False) []).
apply dersrec_nil.
assert (DersNilT: dersrec wKS_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:=wKS_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:=wKS_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:=wKS_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 (Bot) (Γ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 ++ (Bot :: x0) ++ Γ1, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
        pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
        (ps:=[]) (x ++ (Bot :: 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) ++ Bot :: x0, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
          pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
          (ps:=[]) ((Γ0 ++ x) ++ Bot :: 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 (@wKS_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 (@wKS_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 (wKS_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 (@wKS_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 (@wKS_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 (wKS_adm_list_exch_L x1 J5). rewrite H7. assumption. }
    (* Right rule is wKR *)
    { 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 (@wKS_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 (@wKS_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 (wKS_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:=wKS_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:=wKS_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 ++ Bot :: Γ3, Δ0 ++ Δ1)).
  apply BotLRule_I. apply BotL in H.
  pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
  (ps:=[]) (Γ2 ++ Bot :: Γ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:=wKS_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:=wKS_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 (Bot) (Γ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 ++ (Bot :: x0) ++ Γ1, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
          pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
          (ps:=[]) (x ++ (Bot :: 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) ++ Bot :: x0, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
            pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
            (ps:=[]) ((Γ0 ++ x) ++ Bot :: 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:=wKS_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: wKS_rules [(A :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3)] (Γ0 ++ Γ1, Δ2 ++ A --> B0 :: Δ3)).
        apply ImpR ; try intro ; try apply f ; try rewrite <- H7 ; try auto ; try assumption.
        assert (J31: wKS_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 (A0 --> B) = size (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:=wKS_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:=wKS_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:=wKS_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:=wKS_adm_list_exch_R d J2).
            assert (J3: size A0 < size (A0 --> B)). simpl. lia.
            assert (J4: size A0 = size 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 (wKS_wkn_R X5 J8 J7). destruct s. rewrite <- H2 in d0. pose (d2:=d1 x d0).
            assert (J9: size B < size (A0 --> B)). simpl. lia.
            assert (J10: size B = size 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:=wKS_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:=wKS_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:=wKS_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: wKS_rules [(Γ0 ++ x0 ++ Γ5, Δ2 ++ A :: Δ3); (Γ0 ++ x0 ++ B0 :: Γ5, Δ2 ++ Δ3)] (Γ0 ++ x0 ++ A --> B0 :: Γ5, Δ2 ++ Δ3)).
            apply ImpL ; 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 (A0 --> B) = size (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 (A0 --> B) = size (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:=wKS_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:=wKS_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: wKS_rules [(Γ4 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ4 ++ B0 :: x ++ Γ1, Δ2 ++ Δ3)] (Γ4 ++ A --> B0 :: x ++ Γ1, Δ2 ++ Δ3)).
          apply ImpL ; 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 (A0 --> B) = size (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 (A0 --> B) = size (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:=wKS_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 wKR *)
      { inversion X3. subst. rewrite H2.
        assert (wKRRule [(unboxed_list BΓ, [A])] (Γ0 ++ Γ1, Δ2 ++ Box A :: Δ3)).
        apply wKRRule_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 wKR in X5.
        pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(unboxed_list BΓ, [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:=wKS_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 (wKS_rules [(Γ2 ++ A0 :: Γ3, Δ0 ++ x0 ++ B :: Δ3)] (Γ2 ++ Γ3, Δ0 ++ x0 ++ A0 --> B :: Δ3)).
      apply ImpR ; try intro ; try apply f ; try rewrite <- H2 ; try rewrite <- app_assoc ; try auto ; try assumption.
      assert (wKS_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 A = size 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:=wKS_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:=wKS_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 (wKS_rules [(Γ2 ++ A0 :: Γ3, Δ2 ++ (B :: x) ++ Δ1)] (Γ2 ++ Γ3, Δ2 ++ (A0 --> B :: x) ++ Δ1)).
    apply ImpR ; try intro ; try apply f ; try repeat rewrite <- app_assoc ; try rewrite <- H2 ; try auto ; try assumption.
    assert (wKS_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 A = size 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:=wKS_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:=wKS_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:=wKS_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 (wKS_rules [(Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1); (Γ2 ++ B :: Γ3, Δ0 ++ Δ1)] (Γ2 ++ A0 --> B :: Γ3, Δ0 ++ Δ1)).
  apply ImpL ; try intro ; try apply f ; try rewrite <- H2 ; try rewrite <- app_assoc ; try auto ; try assumption.
  assert (wKS_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 A = size 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 A = size 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:=wKS_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 wKR *)
- 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:=wKS_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:=wKS_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 (Bot) (Γ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 ++ (Bot :: x0) ++ Γ1, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
          pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
          (ps:=[]) (x ++ (Bot :: 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) ++ Bot :: x0, Δ0 ++ Δ1)). apply BotLRule_I. apply BotL in H0.
            pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
            (ps:=[]) ((Γ0 ++ x) ++ Bot :: 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:=wKS_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: wKS_rules [(A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ3)] (Γ0 ++ Γ1, Δ2 ++ A --> B :: Δ3)).
        apply ImpR ; try intro ; try apply f ; try rewrite <- H6 ; try auto ; try assumption.
        assert (J31: wKS_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 (Box A0) = size (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:=wKS_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:=wKS_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:=wKS_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: wKS_rules [(Γ0 ++ x0 ++ Γ3, Δ2 ++ A :: Δ3); (Γ0 ++ x0 ++ B :: Γ3, Δ2 ++ Δ3)]
            (Γ0 ++ x0 ++ A --> B :: Γ3, Δ2 ++ Δ3)).
            apply ImpL ; try intro ; try apply f ; try rewrite <- app_assoc ;
            try rewrite <- H6 ; try auto ; try assumption.
            assert (J30: wKS_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 (Box A0) = size (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:=wKS_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:=wKS_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: wKS_rules [(Γ2 ++ x ++ Γ1, Δ2 ++ A :: Δ3); (Γ2 ++ B :: x ++ Γ1, Δ2 ++ Δ3)]
          (Γ2 ++ (A --> B :: x) ++ Γ1, Δ2 ++ Δ3)).
          apply ImpL ; try intro ; try apply f ; try rewrite <- app_assoc ;
          try rewrite <- H6 ; try auto ; try assumption.
          assert (J30: wKS_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 (Box A0) = size (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:=wKS_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 wKR *)
      { 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 (wkn_R A (unboxed_list (x ++ x0), [] ++ [A0]) (unboxed_list (x ++ x0), [] ++ A :: [A0])).
          apply wkn_RI. assert (J10: derrec_height X7 = derrec_height X7). reflexivity.
          pose (wKS_wkn_R _ J10 H). destruct s. clear J10. clear H. clear l0.
          rewrite unbox_app_distrib in X8. simpl in X8.
          assert (J5: list_exch_L (unboxed_list x1 ++ [A0] ++ [] ++ unboxed_list l ++ [], [A])
          (unboxed_list x1 ++ unboxed_list l ++ [] ++ [A0] ++ [], [A])).
          apply list_exch_LI.
          assert (J20: unboxed_list x1 ++ A0 :: unboxed_list l =
          unboxed_list x1 ++ [A0] ++ [] ++ unboxed_list l ++ []). simpl. rewrite <- app_nil_end ; auto.
          rewrite J20 in X8. clear J20.
          pose (d:=wKS_adm_list_exch_L X8 J5). simpl 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 app_assoc in d. rewrite <- unbox_app_distrib in d.
          rewrite H in d. clear J5. clear X8.
          assert (unboxed_list (x ++ x0) = unboxed_list (x ++ x0) ++ []). rewrite <- app_nil_end.
          auto. rewrite H0 in x2. clear H0.
          assert (J6: size A0 < size (Box A0)). simpl. lia.
          assert (J7: size A0 = size A0). reflexivity.
          assert (J8: mhd (unboxed_list (x ++ x0), [A]) =
          mhd (unboxed_list (x ++ x0), [A])). reflexivity.
          assert (J9: (unboxed_list (x ++ x0) , [A]) =
          (unboxed_list (x ++ x0) ++ [], [A] ++ [])). rewrite app_nil_r. reflexivity.
          pose (d0:=@PIH (size A0) J6 (mhd (unboxed_list (x ++ x0), [A]))
          A0 (unboxed_list (x ++ x0), [A]) (unboxed_list (x ++ x0)) []
          [A] [] J7 J8 J9). repeat rewrite app_nil_r in d0. simpl in x2. rewrite app_nil_r in x2. pose (d1:=d0 x2 d).
          assert (wKRRule [(unboxed_list (x ++ x0), [A])] (Γ0 ++ Γ1, Δ2 ++ Box A :: Δ3)).
          apply wKRRule_I.
          assumption. apply univ_gen_ext_combine ; auto.
          assert (wKS_rules [(unboxed_list (x ++ x0), [A])] (Γ0 ++ Γ1, Δ2 ++ Box A :: Δ3)).
          apply wKR. assumption.
          pose (dlCons d1 DersNilF).
          pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
          (ps:=[(unboxed_list (x ++ x0), [A])]) (Γ0 ++ Γ1, Δ2 ++ Box A :: Δ3) X10 d2). auto.
        - exfalso. apply H2. exists A0. reflexivity. }
    + repeat destruct s. repeat destruct p. subst.
      assert (wKRRule [(unboxed_list BΓ, [A0])] (Γ0 ++ Γ1, (Δ0 ++ x0) ++ Box A0 :: Δ3)).
      apply wKRRule_I ; try assumption. repeat rewrite <- app_assoc in X5.
      assert (wKS_rules [(unboxed_list BΓ , [A0])] (Γ0 ++ Γ1, Δ0 ++ x0 ++ Box A0 :: Δ3)).
      apply wKR. assumption.
      pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
      (ps:=[(unboxed_list BΓ, [A0])]) (Γ0 ++ Γ1, Δ0 ++ x0 ++ Box A0 :: Δ3) X6 X0). assumption.
  * repeat destruct s. repeat destruct p. subst. rewrite <- app_assoc.
    assert (wKRRule [(unboxed_list BΓ, [A0])] (Γ0 ++ Γ1, Δ2 ++ (Box A0 :: x) ++ Δ1)).
    apply wKRRule_I ; try assumption.
    assert (wKS_rules [(unboxed_list BΓ, [A0])] (Γ0 ++ Γ1, Δ2 ++ (Box A0 :: x) ++ Δ1)).
    apply wKR. assumption.
    pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
    (ps:=[(unboxed_list BΓ, [A0])]) (Γ0 ++ Γ1, Δ2 ++ (Box A0 :: x) ++ Δ1) X6 X0). assumption.
Qed.

Theorem wKS_cut_adm : forall A Γ0 Γ1 Δ0 Δ1,
                      (wKS_prv (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)) ->
                      (wKS_prv (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)) ->
                      (wKS_prv (Γ0 ++ Γ1, Δ0 ++ Δ1)).
Proof.
intros.
assert (J1: size A = size 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 (@wKS_cut_adm_main (size A) (mhd (Γ0 ++ Γ1, Δ0 ++ Δ1)) A
(Γ0 ++ Γ1, Δ0 ++ Δ1) Γ0 Γ1 Δ0 Δ1 J1 J2 J3). auto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C O X P U V Yaux Y : Universe, ((wd_ U V /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ P O /\ (wd_ O X /\ (wd_ P X /\ (wd_ O Yaux /\ (wd_ O Y /\ (wd_ O Yaux /\ (col_ O Yaux Y /\ col_ O X Y))))))))))) -> col_ Yaux O X)).
Proof.
  time tac.
Qed.

End FOFProblem.


(**************************************************************************)
(*   Mechanised Framework for Local Interactions & Distributed Algorithms *)
(*   T. Balabonski, P. Courtieu, L. Rieg, X. Urbain                       *)
(*   PACTOLE project                                                      *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence.    *)
(*                                                                        *)
(**************************************************************************)

(**************************************************************************)
(**  Mechanised Framework for Local Interactions & Distributed Algorithms
     T. Balabonski, P. Courtieu, L. Rieg, X. Urbain
     PACTOLE project

     This file is distributed under the terms of the CeCILL-C licence.
                                                                          *)
(**************************************************************************)

Set Implicit Arguments.
Require Import Utf8.
Require Import SetoidDec.
Require Import Reals Psatz.
Require Import Pactole.Setting.
Require Import Pactole.Spaces.RealMetricSpace.
Require Import Pactole.Spaces.Similarity.
Require Pactole.Models.Rigid.
Require Pactole.Models.Flexible.

Section RigidFlexibleEquivalence.

Context `{Observation}.
Context {VS : RealVectorSpace location}.
Context {RMS : RealMetricSpace location}. (* for dist *)
Instance Frame : frame_choice (similarity location) := Similarity.FrameChoiceSimilarity.
Context {Tinactive : Type}.
Context `{inactive_choice Tinactive}.
Context {Ina : inactive_function Tinactive}.

(** Flexible demons. *)
Context (Tflex : Type) (delta : R).
Context `{update_choice Tflex}.
Instance FRobot : robot_choice (path location) := { robot_choice_Setoid := path_Setoid location }.
Context {FlexUpdateFun : update_function (path location) (similarity location) Tflex}.
Context `{@Flexible.FlexibleChoice Tflex _}.

Context (Flex : Flexible.FlexibleSetting delta).
Notation flex_da := (@demonic_action _ _ _ _ (path location) (similarity location) Tflex _ _ _).
Notation flex_demon := (@demon _ _ _ _ (path location) (similarity location) Tflex _ _ _).

(** Rigid demons. *)
Context (Trigid : Type).
Context `{update_choice Trigid}.
Instance RRobot : robot_choice location := { robot_choice_Setoid := location_Setoid }.
Context {RigidUpdateFun : update_function location (similarity location) Trigid}.

Context (Rigid : Rigid.RigidSetting).
Notation rigid_da := (@demonic_action _ _ _ _ location (similarity location) Trigid _ _ _).
Notation rigid_demon := (@demon _ _ _ _ location (similarity location) Trigid _ _ _).

(** **  Characterization of flexible demons that act rigidly  **)

(** A flexible choice is rigid if its [move_ratio] is 1. *)
Definition is_rigid choice := Flexible.move_ratio choice == ratio_1.
Definition is_rigid_da (fda : flex_da) :=
  forall config g target, is_rigid (choose_update fda config g target).
Definition is_rigid_demon : flex_demon -> Prop := Stream.forever (Stream.instant is_rigid_da).

Global Instance is_rigid_compat : Proper (equiv ==> iff) is_rigid.
Proof using . intros ? ? Heq. unfold is_rigid. now rewrite Heq. Qed.

Global Instance is_rigid_da_compat : Proper (equiv ==> iff) is_rigid_da.
Proof using . intros ? ? Heq. unfold is_rigid_da. now setoid_rewrite Heq. Qed.

Global Instance is_rigid_demon_compat : Proper (equiv ==> iff) is_rigid_demon.
Proof using . intros ? ? Heq. unfold is_rigid_demon. now rewrite Heq. Qed.

Lemma is_rigid_da_update : forall da : flex_da, is_rigid_da da ->
  forall config g target frame,
  get_location (update config g frame target (choose_update da config g target))
  == target ratio_1.
Proof using Flex.
intros da Hda config g target frame.
destruct (Flexible.ratio_spec config g frame target (choose_update da config g target))
  as [| [Hdist _]]; trivial; [].
specialize (Hda config g target). unfold is_rigid in Hda. rewrite <- Hda. apply Hdist.
Qed.

(** **  Conversions between [demonic_choice]s  **)

(** We assume a way to convert demon choices back and forth. *)
Variable R2F_choice : Trigid -> Tflex.
Variable F2R_choice : Tflex -> Trigid.
Context (F2R_choice_compat : Proper (equiv ==> equiv) F2R_choice).
Context (R2F_choice_compat : Proper (equiv ==> equiv) R2F_choice).
Hypothesis R2F2R_choice : forall choice, F2R_choice (R2F_choice choice) == choice.
Hypothesis F2R2F_choice : forall choice,
  is_rigid choice -> R2F_choice (F2R_choice choice) == choice.
Hypothesis R2F_choice_rigid : forall choice, is_rigid (R2F_choice choice).

(** **  Conversions between [demonic_action]s  **)

Definition R2F_da (rda : rigid_da) : flex_da.
simple refine {|
  activate := rda.(activate);
  relocate_byz := rda.(relocate_byz);
  change_frame := rda.(change_frame);
  choose_update := fun config g target => R2F_choice (rda.(choose_update) config g _);
  choose_inactive := rda.(choose_inactive) |}.
Proof.
+ apply (target ratio_1). (* FIXME: why do we have to go through a "_" in the refine? *)
+ apply precondition_satisfied.
+ apply precondition_satisfied_inv.
+ abstract (repeat intro; apply R2F_choice_compat; now f_equiv).
Defined.

Definition F2R_da (fda : flex_da) : rigid_da.
simple refine {|
  activate := fda.(activate);
  relocate_byz := fda.(relocate_byz);
  change_frame := fda.(change_frame);
  choose_update := fun config g target =>
    F2R_choice (fda.(choose_update) config g (local_straight_path target));
  choose_inactive := fda.(choose_inactive) |}; autoclass.
Proof.
+ apply precondition_satisfied.
+ apply precondition_satisfied_inv.
+ repeat intro. apply F2R_choice_compat.
  f_equiv; trivial; [].
  now apply local_straight_path_compat.
Defined.

Lemma R2F2R_da : forall rda : rigid_da, F2R_da (R2F_da rda) == rda.
Proof using R2F2R_choice.
intro rda. repeat split; try reflexivity; [].
repeat intro. simpl. rewrite mul_1. apply R2F2R_choice.
Qed.

Lemma F2R2F_da : forall fda : flex_da, is_rigid_da fda -> R2F_da (F2R_da fda) == fda.
Proof.
intros fda Hrigid. repeat split; try reflexivity; [].
intros config g target. simpl. rewrite F2R2F_choice; auto; []. f_equiv.
intro r.
(* the demon should only depend on the final target, not the path *)
Abort.

Lemma R2F_da_is_rigid : forall rda, is_rigid_da (R2F_da rda).
Proof using R2F_choice_rigid. intro. hnf. intros. simpl. apply R2F_choice_rigid. Qed.

(** **  Conversions between [demon]s  **)

Definition F2R_demon : flex_demon -> rigid_demon := Stream.map F2R_da.
Definition R2F_demon : rigid_demon -> flex_demon := Stream.map R2F_da.

Lemma R2F2R_demon : forall d, F2R_demon (R2F_demon d) == d.
Proof using R2F2R_choice. coinduction Hcorec. apply R2F2R_da. Qed.

Lemma F2R2F_demon : forall d, is_rigid_demon d -> R2F_demon (F2R_demon d) == d.
Proof.
coinduction Hcorec; match goal with H : is_rigid_demon _ |- _ => destruct H end.
- (* now apply F2R2F_da. *) admit.
- assumption.
Abort.

(** **  Conversions between [robogram]s  **)

Notation flex_robogram := (@robogram _ _ _ _ _ (path location) _).
Notation rigid_robogram := (@robogram _ _ _ _ _ location _).

Instance pgm_R2F_compat : forall r : rigid_robogram,
  Proper (equiv ==> equiv) (fun s => local_straight_path (r s)).
Proof using . intros r s1 s2 Hs. now rewrite Hs. Qed.

Instance pgm_F2R_compat : forall r : flex_robogram,
  Proper (equiv ==> equiv) (fun s => r s ratio_1).
Proof using . intros r s1 s2 Hs. now rewrite Hs. Qed.

Definition R2F_robogram (r : rigid_robogram) : flex_robogram := {|
  pgm := fun s => local_straight_path (r s) |}.

Definition F2R_robogram (r : flex_robogram) : rigid_robogram := {| pgm := fun s => r s ratio_1 |}.

Lemma R2F2R_robogram : forall r : rigid_robogram, F2R_robogram (R2F_robogram r) == r.
Proof using . intros r s. simpl. now rewrite mul_1. Qed.

(** We don't have equality of paths,
    only of the target point as rigid robograms use straight paths. *)
Lemma F2R2F_robogram : forall r : flex_robogram,
  forall s, R2F_robogram (F2R_robogram r) s ratio_1 == r s ratio_1.
Proof using . intros r s. simpl. now rewrite mul_1. Qed.

(** **  Equivalence between [round]s  **)

(** If the location part of the update is the same, then the rest is also the same. *)
Hypothesis update_only_location :
  forall g config frame target1 target2 (choice1 : Tflex) (choice2 : Trigid),
  get_location (update config g frame target1 choice1)
  == get_location (update config g frame target2 choice2) ->
  update config g frame target1 choice1 == update config g frame target2 choice2.

Lemma R2F_round : forall (r : robogram) (rda : rigid_da),
  forall config, round (R2F_robogram r) (R2F_da rda) config == round r rda config.
Proof using Flex R2F_choice_rigid Rigid update_only_location.
intros r rda config id. unfold round.
simpl activate. simpl change_frame. simpl precondition_satisfied. simpl choose_inactive.
repeat destruct_match; try reflexivity ; [].
remember (lift (existT precondition
                       (Bijection.section (frame_choice_bijection (change_frame rda config g)))
                       (precondition_satisfied rda config g))) as sim.
apply lift_compat; try (now intros x y Hxy; simpl; now rewrite Hxy); [].
apply update_only_location.
rewrite Rigid.rigid_update, is_rigid_da_update.
- simpl. now rewrite mul_1.
- apply R2F_da_is_rigid.
Qed.

Lemma F2R_round : forall (r : robogram) (fda : flex_da), is_rigid_da fda ->
  forall config, round (F2R_robogram r) (F2R_da fda) config == round r fda config.
Proof using Flex Rigid update_only_location.
intros r fda Hrigid config id. unfold round.
simpl activate. simpl change_frame. simpl precondition_satisfied. simpl choose_inactive.
repeat destruct_match; try reflexivity; [].
remember (lift (existT precondition
                       (Bijection.section (frame_choice_bijection (change_frame fda config g)))
                       (precondition_satisfied fda config g))) as sim.
apply lift_compat; try (now intros x y Hxy; simpl; now rewrite Hxy); [].
symmetry. apply update_only_location.
rewrite Rigid.rigid_update, is_rigid_da_update.
- reflexivity.
- assumption.
Qed.

(** **  Equivalence between [execution]s  **)

(** A rigid demon can be turned into a flexible one (that satifties the [rigid] predicate). *)
Theorem R2F_preserves_eq : forall r config1 config2 (rd : rigid_demon),
  config1 == config2 -> execute r rd config1 == execute (R2F_robogram r) (R2F_demon rd) config2.
Proof using Flex R2F_choice_rigid Rigid update_only_location.
intro r. cofix next_exec. intros conf1 conf2 d Heq.
constructor; trivial; []. rewrite 2 execute_tail. simpl.
apply next_exec. rewrite R2F_round. now apply round_compat.
Qed.

Corollary R2F : forall r config (d : rigid_demon),
  execute r d config == execute (R2F_robogram r) (R2F_demon d) config.
Proof using Flex R2F_choice_rigid Rigid update_only_location. intros. now apply R2F_preserves_eq. Qed.

(** A flexible demon that satisfies the [rigid] predicate can be turned into a rigid one. *)
Theorem F2R_preserves_eq : forall r config1 config2 (d : flex_demon), is_rigid_demon d ->
  config1 == config2 -> execute r d config1 == execute (F2R_robogram r) (F2R_demon d) config2.
Proof using Flex Rigid update_only_location.
intro r. cofix next_exec. intros conf1 conf2 fd Hfd Heq.
constructor; trivial; []. rewrite 2 execute_tail. simpl.
destruct Hfd. apply next_exec; trivial; [].
rewrite F2R_round; trivial; []. now apply round_compat.
Qed.

Corollary Flex_Rigid : forall r config (d : flex_demon), is_rigid_demon d ->
  execute r d config == execute (F2R_robogram r) (F2R_demon d) config.
Proof using Flex Rigid update_only_location. intros. now apply F2R_preserves_eq. Qed.

End RigidFlexibleEquivalence.
(* Do not leave this here, because it makes "make vos" fail.
 It is done in Rigidflexibleequivalence_Assumptions.v instead *)
(* Print Assumptions Flex_Rigid. *)


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__congruenceflip.
Require Export lemma__diagonalsbisect.
Require Export lemma__inequalitysymmetric.
Require Export logic.
Definition lemma__trapezoiddiagonals : forall A B C D E, (euclidean__defs.PG A B C D) -> ((euclidean__axioms.BetS A E D) -> (exists X, (euclidean__axioms.BetS B X D) /\ (euclidean__axioms.BetS C X E))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro H.
intro H0.
assert (* Cut *) (euclidean__defs.Par A B C D) as H1.
- destruct H as [H1 H2].
exact H1.
- assert (* Cut *) (euclidean__defs.Par A D B C) as H2.
-- destruct H as [H2 H3].
exact H3.
-- assert (* Cut *) (~(euclidean__defs.Meet A B C D)) as H3.
--- assert (exists U V u v X, (euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.Col A D U) /\ ((euclidean__axioms.Col A D V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B C u) /\ ((euclidean__axioms.Col B C v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A D B C)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H3 by exact H2.
assert (exists U V u v X, (euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.Col A D U) /\ ((euclidean__axioms.Col A D V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B C u) /\ ((euclidean__axioms.Col B C v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A D B C)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp by exact H3.
destruct __TmpHyp as [x H4].
destruct H4 as [x0 H5].
destruct H5 as [x1 H6].
destruct H6 as [x2 H7].
destruct H7 as [x3 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H29 by exact H1.
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp0 by exact H29.
destruct __TmpHyp0 as [x4 H30].
destruct H30 as [x5 H31].
destruct H31 as [x6 H32].
destruct H32 as [x7 H33].
destruct H33 as [x8 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
exact H51.
--- assert (* Cut *) (euclidean__axioms.neq A B) as H4.
---- assert (exists U V u v X, (euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.Col A D U) /\ ((euclidean__axioms.Col A D V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B C u) /\ ((euclidean__axioms.Col B C v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A D B C)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H4 by exact H2.
assert (exists U V u v X, (euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.Col A D U) /\ ((euclidean__axioms.Col A D V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B C u) /\ ((euclidean__axioms.Col B C v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A D B C)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp by exact H4.
destruct __TmpHyp as [x H5].
destruct H5 as [x0 H6].
destruct H6 as [x1 H7].
destruct H7 as [x2 H8].
destruct H8 as [x3 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H30 by exact H1.
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp0 by exact H30.
destruct __TmpHyp0 as [x4 H31].
destruct H31 as [x5 H32].
destruct H32 as [x6 H33].
destruct H33 as [x7 H34].
destruct H34 as [x8 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
exact H36.
---- assert (* Cut *) (euclidean__axioms.neq C D) as H5.
----- assert (exists U V u v X, (euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.Col A D U) /\ ((euclidean__axioms.Col A D V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B C u) /\ ((euclidean__axioms.Col B C v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A D B C)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H5 by exact H2.
assert (exists U V u v X, (euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.Col A D U) /\ ((euclidean__axioms.Col A D V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B C u) /\ ((euclidean__axioms.Col B C v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A D B C)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp by exact H5.
destruct __TmpHyp as [x H6].
destruct H6 as [x0 H7].
destruct H7 as [x1 H8].
destruct H8 as [x2 H9].
destruct H9 as [x3 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H31 by exact H1.
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp0 by exact H31.
destruct __TmpHyp0 as [x4 H32].
destruct H32 as [x5 H33].
destruct H33 as [x6 H34].
destruct H34 as [x7 H35].
destruct H35 as [x8 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
exact H39.
----- assert (* Cut *) (exists M, (euclidean__defs.Midpoint A M C) /\ (euclidean__defs.Midpoint B M D)) as H6.
------ apply (@lemma__diagonalsbisect.lemma__diagonalsbisect A B C D H).
------ destruct H6 as [M H7].
destruct H7 as [H8 H9].
assert (* Cut *) (euclidean__axioms.BetS A M C) as H10.
------- destruct H9 as [H10 H11].
destruct H8 as [H12 H13].
exact H12.
------- assert (* Cut *) (euclidean__axioms.Cong A M M C) as H11.
-------- destruct H9 as [H11 H12].
destruct H8 as [H13 H14].
exact H14.
-------- assert (* Cut *) (euclidean__axioms.BetS B M D) as H12.
--------- destruct H9 as [H12 H13].
destruct H8 as [H14 H15].
exact H12.
--------- assert (* Cut *) (euclidean__axioms.Cong B M M D) as H13.
---------- destruct H9 as [H13 H14].
destruct H8 as [H15 H16].
exact H14.
---------- assert (* Cut *) (euclidean__axioms.Cong B M D M) as H14.
----------- assert (* Cut *) ((euclidean__axioms.Cong M B D M) /\ ((euclidean__axioms.Cong M B M D) /\ (euclidean__axioms.Cong B M D M))) as H14.
------------ apply (@lemma__congruenceflip.lemma__congruenceflip B M M D H13).
------------ destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H18.
----------- assert (* Cut *) (B = B) as H15.
------------ apply (@logic.eq__refl Point B).
------------ assert (* Cut *) (~(euclidean__axioms.Col B D C)) as H16.
------------- intro H16.
assert (* Cut *) (euclidean__axioms.Col C D B) as H17.
-------------- assert (* Cut *) ((euclidean__axioms.Col D B C) /\ ((euclidean__axioms.Col D C B) /\ ((euclidean__axioms.Col C B D) /\ ((euclidean__axioms.Col B C D) /\ (euclidean__axioms.Col C D B))))) as H17.
--------------- apply (@lemma__collinearorder.lemma__collinearorder B D C H16).
--------------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H25.
-------------- assert (* Cut *) (euclidean__axioms.Col A B B) as H18.
--------------- right.
right.
left.
exact H15.
--------------- assert (* Cut *) (euclidean__defs.Meet A B C D) as H19.
---------------- exists B.
split.
----------------- exact H4.
----------------- split.
------------------ exact H5.
------------------ split.
------------------- exact H18.
------------------- exact H17.
---------------- apply (@H3 H19).
------------- assert (* Cut *) (euclidean__axioms.Cong M A M C) as H17.
-------------- assert (* Cut *) ((euclidean__axioms.Cong M A C M) /\ ((euclidean__axioms.Cong M A M C) /\ (euclidean__axioms.Cong A M C M))) as H17.
--------------- apply (@lemma__congruenceflip.lemma__congruenceflip A M M C H11).
--------------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
exact H20.
-------------- assert (* Cut *) (exists P, (euclidean__axioms.BetS B E P) /\ (euclidean__axioms.BetS C D P)) as H18.
--------------- apply (@euclidean__axioms.postulate__Euclid5 E B D A C M H10 H12 H0 H14 H17).
----------------apply (@euclidean__tactics.nCol__notCol B D C H16).

--------------- destruct H18 as [P H19].
destruct H19 as [H20 H21].
assert (* Cut *) (~(euclidean__axioms.Col B P C)) as H22.
---------------- intro H22.
assert (* Cut *) (euclidean__axioms.Col P C B) as H23.
----------------- assert (* Cut *) ((euclidean__axioms.Col P B C) /\ ((euclidean__axioms.Col P C B) /\ ((euclidean__axioms.Col C B P) /\ ((euclidean__axioms.Col B C P) /\ (euclidean__axioms.Col C P B))))) as H23.
------------------ apply (@lemma__collinearorder.lemma__collinearorder B P C H22).
------------------ destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
exact H26.
----------------- assert (* Cut *) (euclidean__axioms.Col C D P) as H24.
------------------ right.
right.
right.
right.
left.
exact H21.
------------------ assert (* Cut *) (euclidean__axioms.Col P C D) as H25.
------------------- assert (* Cut *) ((euclidean__axioms.Col D C P) /\ ((euclidean__axioms.Col D P C) /\ ((euclidean__axioms.Col P C D) /\ ((euclidean__axioms.Col C P D) /\ (euclidean__axioms.Col P D C))))) as H25.
-------------------- apply (@lemma__collinearorder.lemma__collinearorder C D P H24).
-------------------- destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
exact H30.
------------------- assert (* Cut *) (euclidean__axioms.neq C P) as H26.
-------------------- assert (* Cut *) ((euclidean__axioms.neq D P) /\ ((euclidean__axioms.neq C D) /\ (euclidean__axioms.neq C P))) as H26.
--------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C D P H21).
--------------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
exact H30.
-------------------- assert (* Cut *) (euclidean__axioms.neq P C) as H27.
--------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C P H26).
--------------------- assert (* Cut *) (euclidean__axioms.Col C B D) as H28.
---------------------- apply (@euclidean__tactics.not__nCol__Col C B D).
-----------------------intro H28.
apply (@euclidean__tactics.Col__nCol__False C B D H28).
------------------------apply (@lemma__collinear4.lemma__collinear4 P C B D H23 H25 H27).

---------------------- assert (* Cut *) (euclidean__axioms.Col C D B) as H29.
----------------------- assert (* Cut *) ((euclidean__axioms.Col B C D) /\ ((euclidean__axioms.Col B D C) /\ ((euclidean__axioms.Col D C B) /\ ((euclidean__axioms.Col C D B) /\ (euclidean__axioms.Col D B C))))) as H29.
------------------------ apply (@lemma__collinearorder.lemma__collinearorder C B D H28).
------------------------ destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
exact H36.
----------------------- assert (* Cut *) (euclidean__axioms.Col A B B) as H30.
------------------------ right.
right.
left.
exact H15.
------------------------ assert (* Cut *) (euclidean__defs.Meet A B C D) as H31.
------------------------- exists B.
split.
-------------------------- exact H4.
-------------------------- split.
--------------------------- exact H5.
--------------------------- split.
---------------------------- exact H30.
---------------------------- exact H29.
------------------------- apply (@H3 H31).
---------------- assert (* Cut *) (exists H', (euclidean__axioms.BetS B H' D) /\ (euclidean__axioms.BetS C H' E)) as H23.
----------------- apply (@euclidean__axioms.postulate__Pasch__inner B C P E D H20 H21).
------------------apply (@euclidean__tactics.nCol__notCol B P C H22).

----------------- destruct H23 as [H' H24].
destruct H24 as [H25 H26].
exists H'.
split.
------------------ exact H25.
------------------ exact H26.
Qed.


From iris.algebra Require Import frac_auth.
From iris.base_logic.lib Require Export own.
From iris.proofmode Require Import tactics.

Section frac_auth_mnat.
  Context `{inG Σ (frac_authR mnatUR)}.

  Lemma frac_auth_mnat_valid (m n : mnat) (q : frac): ✓ (●! m ⋅ ◯!{q} n) → (n ≤ m)%nat.
  Proof.
     intros ?. by apply mnat_included, (frac_auth_included_total (A:=mnatUR) q).
  Qed.

  Lemma frac_auth_mnat_local_update (m n : mnat) (q : frac) :
    (●! m ⋅ ◯!{q} n) ~~> (●! (S m) ⋅ ◯!{q} (S m)).
  Proof.
    apply (frac_auth_update (A:=mnatUR)), (mnat_local_update m n (S m)). lia.
  Qed.

  Lemma frac_auth_mnat_own_update γ (m n : mnat) (q : frac) :
    own (A:=frac_authR mnatUR) γ (●! m) -∗
    own (A:=frac_authR mnatUR) γ (◯!{q} n) -∗
    |==> own (A:=frac_authR mnatUR) γ (●! (S m : mnat)) ∗
         own (A:=frac_authR mnatUR) γ (◯!{q} (S m : mnat)).
  Proof.
    iIntros "Ha Hc". iCombine "Ha" "Hc" as "H".
    rewrite -own_op.
    iApply (own_update with "H").
    apply frac_auth_mnat_local_update.
  Qed.

End frac_auth_mnat.

Section frac_auth_nat.
  Context `{inG Σ (frac_authR natUR)}.

  Lemma frac_auth_nat_valid (m n : nat) (q : frac): ✓ (●! m ⋅ ◯!{q} n) → (n ≤ m)%nat.
  Proof.
     intros ?. by apply nat_included, (frac_auth_included_total (A:=natUR) q).
  Qed.

  Lemma frac_auth_nat_local_update (m n o : nat) (q : frac) :
    (●! m ⋅ ◯!{q} n) ~~> (●! (m + o) ⋅ ◯!{q} (n + o)).
  Proof.
    apply (frac_auth_update (A:=natUR)), (nat_local_update m n (m + o) (n + o)). lia.
  Qed.

  Lemma frac_auth_nat_own_update γ (m n o : nat) (q : frac) :
    own (A:=frac_authR natUR) γ (●! m) -∗
    own (A:=frac_authR natUR) γ (◯!{q} n) -∗
    |==> own (A:=frac_authR natUR) γ (●! (m + o : nat)) ∗
         own (A:=frac_authR natUR) γ (◯!{q} (n + o : nat)).
  Proof.
    iIntros "Ha Hc". iCombine "Ha" "Hc" as "H".
    rewrite -own_op.
    iApply (own_update with "H").
    apply frac_auth_nat_local_update.
  Qed.

End frac_auth_nat.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Section RewriteClass.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {sepconAX: SepconAxiomatization L Gamma}
        {wandAX: WandAxiomatization L Gamma}.

Instance sepcon_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) sepcon.
Proof.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  apply sepcon_mono; auto.
Qed.

Instance wand_proper_impp: Proper ((fun x y => |-- impp x y) --> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) wand.
Proof.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  unfold Basics.flip in H.
  apply wand_mono; auto.
Qed.

Context {pL: PropositionalLanguage L}
        {ipAX: IntuitionisticPropositionalLogic L Gamma}.

Instance sepcon_proper_iffp: Proper ((fun x y => |-- iffp x y) ==> (fun x y => |-- iffp x y) ==> (fun x y => |-- iffp x y)) sepcon.
Proof.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  apply solve_andp_intros.
  + apply sepcon_mono.
    - rewrite H; apply provable_impp_refl.
    - rewrite H0; apply provable_impp_refl.
  + apply sepcon_mono.
    - rewrite H; apply provable_impp_refl.
    - rewrite H0; apply provable_impp_refl.
Qed.

Instance wand_proper_iffp: Proper ((fun x y => |-- iffp x y) ==> (fun x y => |-- iffp x y) ==> (fun x y => |-- iffp x y)) wand.
Proof.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  apply solve_andp_intros.
  + apply wand_mono.
    - rewrite H; apply provable_impp_refl.
    - rewrite H0; apply provable_impp_refl.
  + apply wand_mono.
    - rewrite H; apply provable_impp_refl.
    - rewrite H0; apply provable_impp_refl.
Qed.

End RewriteClass.

Existing Instances sepcon_proper_impp wand_proper_impp sepcon_proper_iffp wand_proper_iffp.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** * triplet

Pierre Letouzey & Laurent Thery

Definition of triplets
*)

From Coq Require Export Bool.
From Stalmarck Require Export rZ.
From Coq Require Export List.
From Stalmarck Require Export normalize.
From Stalmarck Require Export sTactic.

(** Lifting of f from rNat-> bool to rZ -> bool compatible with rZComp *)
Definition rZEval (f : rNat -> bool) (r : rZ) : bool :=
  match r with
  | rZPlus n => f n
  | rZMinus n => negb (f n)
  end.

(** A triplet is an operation plus 3 rZ
   a = b /\ c are coded as (Triplet rAnd a b c) *)
Inductive triplet : Set :=
    Triplet : rBoolOp -> rZ -> rZ -> rZ -> triplet.

(** Equality on triplets is decidable *)
Definition rBoolOpDec : forall a b : rBoolOp, {a = b} + {a <> b}.
intros a b; case a; case b; auto with stalmarck; right; red in |- *; intros; discriminate.
Defined.

(** Equality is decidable *)
Definition tripletDec : forall t1 t2 : triplet, {t1 = t2} + {t1 <> t2}.
intros t1 t2; case t1; case t2.
intros r r0 r1 r2 r3 r4 r5 r6; case (rBoolOpDec r3 r);
 [ idtac | intros H; right; Contradict H; inversion H ];
 auto with stalmarck.
intros H1; case (rZDec r4 r0);
 [ idtac | intros H; right; Contradict H; inversion H ];
 auto with stalmarck.
intros H2; case (rZDec r5 r1);
 [ idtac | intros H; right; Contradict H; inversion H ];
 auto with stalmarck.
intros H3; case (rZDec r6 r2);
 [ idtac | intros H; right; Contradict H; inversion H ];
 auto with stalmarck.
intros H4; left; rewrite H1; rewrite H2; rewrite H3; rewrite H4; auto with stalmarck.
Defined.

(** Evaluation tEval(a=b/\c)=(f(a)=f(b)/\f(b)) *)
Definition tEval (f : rNat -> bool) (t : triplet) : bool :=
  match t with
  | Triplet n v1 v2 v3 =>
      eqb (rZEval f v1) (rBoolOpFun n (rZEval f v2) (rZEval f v3))
  end.

(** f realizes a list of triplets if its evaluates all the triplets to true *)
Definition realizeTriplets (f : rNat -> bool) (L : list triplet) : Prop :=
  forall t : triplet, In t L -> tEval f t = true.

Theorem realizeTripletNil : forall f : rNat -> bool, realizeTriplets f nil.
Proof.
intros f; red in |- *.
intros t H'; inversion H'.
Qed.
#[export] Hint Resolve realizeTripletNil : stalmarck.

Theorem realizeTripletCons :
 forall (f : rNat -> bool) (t : triplet) (L : list triplet),
 tEval f t = true -> realizeTriplets f L -> realizeTriplets f (t :: L).
Proof.
intros f t L H' H'0; red in |- *; simpl in |- *.
intros t0 H'1; elim H'1; intros H'2; auto with stalmarck; rewrite <- H'2; auto with stalmarck.
Qed.

#[export] Hint Resolve realizeTripletCons : stalmarck.

Theorem realizeTripletIncl :
 forall (f : rNat -> bool) (L1 L2 : list triplet),
 realizeTriplets f L1 -> incl L2 L1 -> realizeTriplets f L2.
Proof.
intros f L1 L2 H'0 H'1; red in |- *; auto with stalmarck.
Qed.

#[export] Hint Resolve realizeTripletIncl : stalmarck.

(** An equation is valid if every f that realizes f and f(rZrue)=true
   then f(a)=f(b) *)
Definition validEquation (L : list triplet) (a b : rZ) : Prop :=
  forall f : rNat -> bool,
  realizeTriplets f L -> f zero = true -> rZEval f a = rZEval f b.

(** What is the maximal variable of a triplet *)
Definition maxVarTriplet (t : triplet) :=
  match t with
  | Triplet n v1 v2 v3 => rmax (rmax (valRz v1) (valRz v2)) (valRz v3)
  end.

(** Iteration to compute the max of a list of triplets *)
Fixpoint maxVarTriplets (l : list triplet) : rNat :=
  match l with
  | nil => zero
  | t :: q => rmax (maxVarTriplet t) (maxVarTriplets q)
  end.

(** Check if a variable is in a triplet *)
Definition inTriplet (a : rZ) (t : triplet) :=
  match t with
  | Triplet n v1 v2 v3 => eqRz a v1 \/ eqRz a v2 \/ eqRz a v3
  end.

Definition inTripletDec :
  forall (a : rZ) (t : triplet), {inTriplet a t} + {~ inTriplet a t}.
intros a t; case t; simpl in |- *; intros b v1 v2 v3; unfold eqRz in |- *.
case (rNatDec (valRz a) (valRz v1)); auto with stalmarck;
 case (rNatDec (valRz a) (valRz v2)); auto with stalmarck;
 case (rNatDec (valRz a) (valRz v3)); auto with stalmarck.
intros H' H'0 H'1; right; red in |- *; intros H'2; Elimc H'2; intros H'2;
 [ idtac | Elimc H'2; intros H'2 ]; auto with stalmarck.
Qed.

(** Check if a variable is in a list of triplets*)
Fixpoint inTriplets (v : rZ) (l : list triplet) {struct l} : Prop :=
  match l with
  | nil => eqRz v (rZPlus zero)
  | t :: q => inTriplet v t \/ inTriplets v q
  end.

Definition inTripletsDec :
  forall (a : rZ) (L : list triplet), {inTriplets a L} + {~ inTriplets a L}.
intros a L; elim L; simpl in |- *; auto with stalmarck.
unfold eqRz in |- *; apply rNatDec; auto with stalmarck.
intros a0 l H'; case H'; auto with stalmarck.
case (inTripletDec a a0); auto with stalmarck.
intros H'0 H'1; right; red in |- *; intros H'2; elim H'2; auto with stalmarck.
Qed.

Theorem inTripletsTrue : forall L : list triplet, inTriplets rZTrue L.
Proof.
intros L; elim L; simpl in |- *; auto with stalmarck.
Qed.

Theorem inTripletsFalse : forall L : list triplet, inTriplets rZFalse L.
Proof.
intros L; elim L; simpl in |- *; auto with stalmarck.
Qed.

Theorem inTripletsComp :
 forall (L : list triplet) (v : rZ),
 inTriplets v L -> inTriplets (rZComp v) L.
Proof.
intros L; elim L; simpl in |- *; auto with stalmarck.
unfold eqRz in |- *; auto with stalmarck.
intros v H'; rewrite <- H'; case v; auto with stalmarck.
intros a; case a; simpl in |- *; auto with stalmarck.
unfold eqRz in |- *; auto with stalmarck.
intros H' r r0 r1 l H'0 v H'1; Elimc H'1; intros H'1;
 [ Elimc H'1; intros H'1;
    [ rewrite <- H'1 | Elimc H'1; intros H'1; rewrite <- H'1 ]
 | idtac ]; auto with stalmarck; case v; auto with stalmarck.
Qed.

Theorem inTripletsCompInv :
 forall (L : list triplet) (v : rZ),
 inTriplets (rZComp v) L -> inTriplets v L.
Proof.
intros L v H'; rewrite (rZCompInvol v).
apply inTripletsComp; auto with stalmarck.
Qed.

Theorem inTripletsIn :
 forall (t : triplet) (L : list triplet) (v : rZ),
 inTriplet v t -> In t L -> inTriplets v L.
Proof.
intros t L; elim L; simpl in |- *; auto with stalmarck.
intros v H' H'0; elim H'0; auto with stalmarck.
intros a l H' v H'0 H'1; elim H'1; intros H'2; auto with stalmarck; rewrite H'2; auto with stalmarck.
Qed.

(** Compute the list of all signed variable in the list of triplets *)
Fixpoint varTriplets (L : list triplet) : list rZ :=
  match L with
  | nil => rZTrue :: nil
  | Triplet _ p q r :: L' => p :: q :: r :: varTriplets L'
  end.

Lemma varTripletTrue : forall L : list triplet, In rZTrue (varTriplets L).
Proof.
simple induction L; simpl in |- *; auto with stalmarck.
intros t L' HR; case t; simpl in |- *; auto with stalmarck.
Qed.

Lemma varTripletTriplet1 :
 forall (p q r : rZ) (b : rBoolOp) (L : list triplet),
 In (Triplet b p q r) L -> In p (varTriplets L).
Proof.
simple induction L; simpl in |- *; auto with stalmarck.
intros t L' HR Ht; elim Ht; intros Ht1; [ rewrite Ht1 | case t ];
 simpl in |- *; auto with stalmarck.
Qed.

Lemma varTripletTriplet2 :
 forall (p q r : rZ) (b : rBoolOp) (L : list triplet),
 In (Triplet b p q r) L -> In q (varTriplets L).
Proof.
simple induction L; simpl in |- *; auto with stalmarck.
intros t L' HR Ht; elim Ht; intros Ht1; [ rewrite Ht1 | case t ];
 simpl in |- *; auto with stalmarck.
Qed.

Lemma varTripletsTriplet3 :
 forall (p q r : rZ) (b : rBoolOp) (L : list triplet),
 In (Triplet b p q r) L -> In r (varTriplets L).
Proof.
simple induction L; simpl in |- *; auto with stalmarck.
intros t L' HR Ht; elim Ht; intros Ht1; [ rewrite Ht1 | case t ];
 simpl in |- *; auto with stalmarck.
Qed.

Lemma eqRzElim : forall a b : rZ, eqRz a b -> a = b \/ a = rZComp b.
Proof.
intros a b; case a; case b; unfold eqRz in |- *; simpl in |- *;
 intros r r0 H'; rewrite H'; auto with stalmarck.
Qed.

Lemma inTripletsVarTriplet :
 forall (L : list triplet) (a : rZ),
 inTriplets a L -> In a (varTriplets L) \/ In (rZComp a) (varTriplets L).
Proof.
intros L; elim L; simpl in |- *; auto with stalmarck.
intros a H'; case (eqRzElim _ _ H'); intros H'1; rewrite H'1; auto with stalmarck.
intros a; case a; auto with stalmarck.
intros r r0 r1 r2 l H' a0 H'0; Elimc H'0; intros H'0; auto with stalmarck.
simpl in H'0; Casec H'0; intros H'0; [ idtac | Casec H'0; intros H'0 ];
 case (eqRzElim _ _ H'0); intros H'1; rewrite H'1;
 simpl in |- *; auto with stalmarck.
elim (H' _ H'0); auto with datatypes stalmarck.
Qed.


(* File reduced by coq-bug-finder from original input, then from 7421 lines to 6082 lines, then from 5860 lines to 5369 lines, then from 5300 lines to 165 lines, then from 111 lines to 38 lines *)
Set Implicit Arguments.
Record PreCategory :=
  { object :> Type;
    morphism : object -> object -> Type;
    identity : forall x, morphism x x }.
Bind Scope category_scope with PreCategory.
Local Notation "1" := (identity _ _) : morphism_scope.
Local Open Scope morphism_scope.
Definition prod (C D : PreCategory) : PreCategory
  := @Build_PreCategory
       (C * D)%type
       (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)
       (fun x => (identity _ (fst x), identity _ (snd x))).
Local Infix "*" := prod : category_scope.
Module NonPrim.
  Record Functor (C D : PreCategory) :=
    { object_of :> C -> D;
      morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d);
      identity_of : forall x, morphism_of _ _ (identity _ x) = identity _ (object_of x) }.
  Notation "F '_1' m" := (morphism_of F _ _ m) (at level 10, no associativity) : morphism_scope.
  Goal forall C1 C2 D (F : Functor (C1 * C2) D) x, F _1 (1, 1) = identity _ (F x).
  Proof.
    intros.
    rewrite identity_of.
    reflexivity.
  Qed.
End NonPrim.
Module Prim.
  Set Primitive Projections.
  Record Functor (C D : PreCategory) :=
    { object_of :> C -> D;
      morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d);
      identity_of : forall x, morphism_of _ _ (identity _ x) = identity _ (object_of x) }.
  Notation "F '_1' m" := (morphism_of F _ _ m) (at level 10, no associativity) : morphism_scope.
  Goal forall C1 C2 D (F : Functor (C1 * C2) D) x, F _1 (1, 1) = identity _ (F x).
  Proof.
    intros.
    rewrite identity_of. (* Toplevel input, characters 0-20:
Error:
Found no subterm matching "morphism_of ?192 ?193 ?193 (identity ?190 ?193)" in the current goal. *)
    reflexivity.
  Qed.
End Prim.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.model.groups.QSposgroup.
Require Import CoRN.algebra.CAbGroups.

(**
** Example of an abelian group: $\langle$#⟨#[Qpos],$(x,y) \mapsto xy/2$ #(x,y) ↦ xy/2#$\rangle$#⟩#
The positive rational numbers form with the operation  $(x,y) \mapsto xy/2$  #(x,y) ↦ xy/2# an abelian group.
*)

Lemma Qpos_multdiv2_is_CAbGroup : is_CAbGroup Qpos_multdiv2_as_CGroup.
Proof.
 intros x y.
 simpl.
 QposRing.
Qed.

Definition Qpos_multdiv2_as_CAbGroup := Build_CAbGroup
 Qpos_multdiv2_as_CGroup Qpos_multdiv2_is_CAbGroup.


Require Import McExamples.Tauto.LtacDemo.

Module Automation := LtacDemo.

Goal Automation.Demo.goal NNN.
  unfold Automation.Demo.goal.
  Automation.Demo.prep.
  Time Automation.Demo.run.
Time Qed.