Require Import coqutil.Decidable.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Map.Solver.
Require Import coqutil.Datatypes.PropSet.
Require Import coqutil.Tactics.destr.

Section WithParams. Local Set Default Proof Using "All".
  Import Interface.map.
  Context {var: Type}. (* variable name (key) *)
  Context {var_eqb: var -> var -> bool}.
  Context {var_eqb_spec: EqDecider var_eqb}.
  Context {val: Type}. (* value *)

  Context {stateMap: map.map var val}.
  Context {stateMapSpecs: map.ok stateMap}.
  Notation state := (@map.rep var val).
  Local Hint Mode map.map - - : typeclass_instances.

  Ltac t := map_solver stateMapSpecs.

  Lemma extends_refl: forall s, extends s s.
  Proof. t. Qed.

  Lemma extends_trans: forall s1 s2 s3,
      extends s1 s2 ->
      extends s2 s3 ->
      extends s1 s3.
  Proof. t. Qed.

  Lemma only_differ_union_l: forall s1 s2 r1 r2,
    only_differ s1 r1 s2 ->
    only_differ s1 (union r1 r2) s2.
  Proof. t. Qed.

  Lemma only_differ_union_r: forall s1 s2 r1 r2,
    only_differ s1 r2 s2 ->
    only_differ s1 (union r1 r2) s2.
  Proof. t. Qed.

  Lemma only_differ_one: forall s x v,
    only_differ s (singleton_set x) (put s x v).
  Proof. t. Qed.

  Lemma only_differ_refl: forall s1 r,
    only_differ s1 r s1.
  Proof. t. Qed.

  Lemma only_differ_sym: forall s1 s2 r,
    only_differ s1 r s2 ->
    only_differ s2 r s1.
  Proof. t. Qed.

  Lemma only_differ_trans: forall s1 s2 s3 r,
    only_differ s1 r s2 ->
    only_differ s2 r s3 ->
    only_differ s1 r s3.
  Proof. t. Qed.

  Lemma only_differ_put_r: forall m1 m2 k (v : val) s,
      k \in s ->
      map.only_differ m1 s m2 ->
      map.only_differ m1 s (map.put m2 k v).
  Proof. t. Qed.

  Lemma only_differ_trans_l: forall (s1 s2 s3 : stateMap) (r1 r2 : var -> Prop),
      map.only_differ s1 r1 s2 ->
      subset r1 r2 ->
      map.only_differ s2 r2 s3 ->
      map.only_differ s1 r2 s3.
  Proof. t. Qed.

  Lemma only_differ_trans_r: forall (s1 s2 s3 : stateMap) (r1 r2 : var -> Prop),
      map.only_differ s2 r1 s3 ->
      subset r1 r2 ->
      map.only_differ s1 r2 s2 ->
      map.only_differ s1 r2 s3.
  Proof. t. Qed.

  Lemma undef_on_shrink: forall st (vs1 vs2: var -> Prop),
    undef_on st vs1 ->
    subset vs2 vs1 ->
    undef_on st vs2.
  Proof. t. Qed.

  Lemma only_differ_subset: forall (s1 s2 : stateMap) (r1 r2 : var -> Prop),
      map.only_differ s1 r1 s2 ->
      subset r1 r2 ->
      map.only_differ s1 r2 s2.
  Proof. t. Qed.

  Lemma extends_if_only_differ_in_undef: forall s1 s2 s vs,
    extends s1 s ->
    undef_on s vs ->
    only_differ s1 vs s2 ->
    extends s2 s.
  Proof. t. Qed.

  Lemma extends_if_only_differ_is_undef: forall s1 s2 vs,
    undef_on s1 vs ->
    only_differ s1 vs s2 ->
    extends s2 s1.
  Proof. t. Qed.

  Lemma extends_put_same: forall s1 s2 x v,
    extends s2 s1 ->
    extends (put s2 x v) (put s1 x v).
  Proof. t. Qed.

  Lemma only_differ_get_unchanged: forall s1 s2 x v d,
    get s1 x = v ->
    only_differ s1 d s2 ->
    ~ elem_of x d ->
    get s2 x = v.
  Proof. t. Qed.

  Lemma only_differ_put: forall s (d: set var) x v,
    elem_of x d ->
    only_differ s d (put s x v).
  Proof. t. Qed.

  Lemma only_differ_to_agree_on: forall (l1 l2: state) (A D: set var),
      map.only_differ l1 D l2 ->
      PropSet.disjoint A D ->
      map.agree_on A l1 l2.
  Proof. t. Qed.

  Lemma extends_putmany: forall m1 m2 m3,
      map.extends m1 m2 ->
      map.extends m1 m3 ->
      map.extends m1 (map.putmany m2 m3).
  Proof. t. Qed.

  Lemma putmany_r_extends: forall m1 m2 m3,
      map.extends m2 m3 ->
      map.extends (map.putmany m1 m2) m3.
  Proof. t. Qed.

  Lemma invert_extends_disjoint_putmany: forall m1 m2 m3,
      map.disjoint m2 m3 ->
      map.extends m1 (map.putmany m2 m3) ->
      map.extends m1 m2 /\ map.extends m1 m3.
  Proof.
    unfold map.extends, map.disjoint. intros.
    split; intros; specialize (H0 x); rewrite map.get_putmany_dec in H0.
    - destr (map.get m3 x). 2: eauto. exfalso. eauto.
    - destr (map.get m3 x). 1: eauto. discriminate.
  Qed.

  Lemma put_extends_l: forall m1 m2 k v,
      map.get m2 k = None ->
      map.extends m1 m2 ->
      map.extends (map.put m1 k v) m2.
  Proof. t. Qed.

  Lemma remove_put_same: forall m k v,
      map.remove (map.put m k v) k = map.remove m k.
  Proof.
    intros. apply map.map_ext. intros. rewrite ?map.get_remove_dec, map.get_put_dec.
    destr (var_eqb k k0); reflexivity.
  Qed.

  Lemma remove_comm: forall m k1 k2,
      map.remove (map.remove m k1) k2 = map.remove (map.remove m k2) k1.
  Proof.
    intros. apply map.map_ext. intros. rewrite ?map.get_remove_dec.
    destr (var_eqb k1 k); destr (var_eqb k2 k); reflexivity.
  Qed.

  Lemma remove_extends: forall m1 m2 k,
      map.extends m1 m2 ->
      map.get m2 k = None ->
      map.extends (map.remove m1 k) m2.
  Proof. t. Qed.

  Lemma extends_remove: forall m1 m2 k,
      map.extends m1 m2 ->
      map.extends m1 (map.remove m2 k).
  Proof. t. Qed.

  Lemma get_Some_remove: forall m k1 k2 v,
      map.get (map.remove m k1) k2 = Some v ->
      map.get m k2 = Some v.
  Proof. t. Qed.

  Lemma get_putmany_none: forall m1 m2 k,
      map.get m1 k = None ->
      map.get m2 k = None ->
      map.get (map.putmany m1 m2) k = None.
  Proof. t. Qed.

  Lemma get_put_diff_eq_l: forall m k v k' (r: option val),
      k <> k' ->
      map.get m k = r ->
      map.get (map.put m k' v) k = r.
  Proof using stateMapSpecs. intros. rewrite map.get_put_diff; eassumption. Qed.

  Lemma weaken_forall_keys: forall (P1 P2: var -> Prop) (m: state),
      (forall k, P1 k -> P2 k) ->
      forall_keys P1 m -> forall_keys P2 m.
  Proof. unfold forall_keys. intros. eauto. Qed.

  Lemma get_None_in_forall_keys: forall m k P,
      forall_keys P m ->
      ~ P k ->
      map.get m k = None.
  Proof.
    unfold forall_keys. intros. destr (map.get m k). 2: reflexivity.
    exfalso. eauto.
  Qed.

  Lemma invert_forall_keys_putmany: forall m1 m2 P,
      forall_keys P (map.putmany m1 m2) ->
      forall_keys P m1 /\ forall_keys P m2.
  Proof.
    unfold forall_keys. intros.
    split; intros;
      specialize (H k); rewrite map.get_putmany_dec in H;
        destr (map.get m2 k); eauto; discriminate.
  Qed.

  Lemma only_differ_remove: forall m1 m2 s k,
      map.only_differ m1 s m2 ->
      map.only_differ (map.remove m1 k) (diff s (singleton_set k)) (map.remove m2 k).
  Proof. t. Qed.

  Lemma putmany_l_extends: forall m1 m2 m3,
      map.extends m1 m3 ->
      map.disjoint m1 m2 ->
      map.extends (map.putmany m1 m2) m3.
  Proof.
    unfold map.extends, map.disjoint. intros. rewrite map.get_putmany_dec.
    specialize (H _ _ H1).
    destr (map.get m2 x).
    - exfalso. eauto.
    - exact H.
  Qed.

End WithParams.


Require Import Coq.Sets.Ensembles Bedrock.Platform.AutoSep.

Require Import Bedrock.Platform.Malloc Bedrock.Platform.Facade.examples.FiatADTs Bedrock.Platform.Facade.examples.FiniteSetF.

Module Type ADT.
  Parameter lset : Ensemble W -> W -> HProp.
  Parameter lset' : Ensemble W -> nat -> W -> HProp.

  Axiom lset_fwd : forall s c, lset s c ===> [| c <> 0 |] * [| freeable c 2 |]
    * Ex p, Ex junk, (c ==*> p, junk) * Ex n, lset' s n p.
  Axiom lset_bwd : forall s (c : W), ([| c <> 0 |] * [| freeable c 2 |]
    * Ex p, Ex junk, (c ==*> p, junk) * Ex n, lset' s n p) ===> lset s c.

  Axiom lset'_empty_fwd : forall s n (c : W), c = 0
    -> lset' s n c
    ===> [| n = O |] * [| s === %0 |].

  Axiom lset'_empty_bwd : forall s n (c : W), c = 0
    -> [| n = O |] * [| s === %0 |] ===> lset' s n c.

  Axiom lset'_nonempty_fwd : forall s n (c : W), c <> 0
    -> lset' s n c
    ===> Ex n', [| n = S n' |] * [| freeable c 2 |] * Ex x, [| s %has x |] * Ex p', (c ==*> x, p')
        * lset' (s %- x) n' p'.

  Axiom lset'_nonempty_bwd : forall s n (c : W), c <> 0
    -> (Ex n', [| n = S n' |] * [| freeable c 2 |] * Ex x, [| s %has x |] * Ex p', (c ==*> x, p')
        * lset' (s %- x) n' p') ===> lset' s n c.

  Axiom lset'_monotone : forall n s s' p, s === s'
    -> lset' s n p ===> lset' s' n p.
End ADT.

Module Adt : ADT.
  Open Scope Sep_scope.

  Fixpoint lset' (s : Ensemble W) (n : nat) (p : W) : HProp :=
    match n with
      | O => [| p = 0 |] * [| s === %0 |]
      | S n' => [| p <> 0 |] * [| freeable p 2 |]
        * Ex x, [| s %has x |] * Ex p', (p ==*> x, p')
        * lset' (s %- x) n' p'
    end.

  Definition lset (s : Ensemble W) (c : W) : HProp :=
    [| c <> 0 |] * [| freeable c 2 |]
    * Ex p, Ex junk, (c ==*> p, junk) * Ex n, lset' s n p.

  Theorem lset_fwd : forall s c, lset s c ===> [| c <> 0 |] * [| freeable c 2 |]
    * Ex p, Ex junk, (c ==*> p, junk) * Ex n, lset' s n p.
    unfold lset; sepLemma.
  Qed.

  Theorem lset_bwd : forall s (c : W), ([| c <> 0 |] * [| freeable c 2 |]
    * Ex p, Ex junk, (c ==*> p, junk) * Ex n, lset' s n p) ===> lset s c.
    unfold lset; sepLemma.
  Qed.

  Theorem lset'_empty_fwd : forall s n (c : W), c = 0
    -> lset' s n c
    ===> [| n = O |] * [| s === %0 |].
    destruct n; sepLemma.
  Qed.

  Theorem lset'_empty_bwd : forall s n (c : W), c = 0
    -> [| n = O |] * [| s === %0 |] ===> lset' s n c.
    destruct n; sepLemma.
  Qed.

  Theorem lset'_nonempty_fwd : forall s n (c : W), c <> 0
    -> lset' s n c
    ===> Ex n', [| n = S n' |] * [| freeable c 2 |] * Ex x, [| s %has x |] * Ex p', (c ==*> x, p')
        * lset' (s %- x) n' p'.
    destruct n; sepLemma.
  Qed.

  Theorem lset'_nonempty_bwd : forall s n (c : W), c <> 0
    -> (Ex n', [| n = S n' |] * [| freeable c 2 |] * Ex x, [| s %has x |] * Ex p', (c ==*> x, p')
        * lset' (s %- x) n' p') ===> lset' s n c.
    destruct n; sepLemma.
    injection H0; sepLemma.
  Qed.

  Theorem lset'_monotone : forall n s s' p, s === s'
    -> lset' s n p ===> lset' s' n p.
    induction n; sepLemma.
    split; do 2 intro.
    apply (proj2 H) in H0.
    apply (proj1 H1) in H0.
    auto.
    destruct H0.
    rewrite has_eq in *.
    apply H; auto.
    apply IHn.
    split; do 2 intro.
    destruct H3.
    split; auto.
    apply H; auto.
    destruct H3.
    split; auto.
    apply H; auto.
  Qed.
End Adt.

Import Adt.
Export Adt.

(* Hm... to avoid stack overflow, need to rebind these! *)
Definition lset'_empty_fwd : forall s n (c : W), c = 0
  -> lset' s n c
  ===> [| n = O |] * [| s === %0 |] := lset'_empty_fwd.

Definition lset'_empty_bwd : forall s n (c : W), c = 0
  -> [| n = O |] * [| s === %0 |] ===> lset' s n c := lset'_empty_bwd.

Definition hints : TacPackage.
  prepare (lset_fwd, lset'_empty_fwd, lset'_nonempty_fwd)
  (lset_bwd, lset'_empty_bwd, lset'_nonempty_bwd).
Defined.

Definition newS := newS lset 8.
Definition deleteS := deleteS lset 7.
Definition memS := memS lset 1.
Definition addS := addS lset 9.
Definition removeS := removeS lset 7.
Definition sizeS := sizeS lset 1.

Definition cardinal_plus (s : Ensemble W) (R acc : W) :=
  exists n, cardinal _ s n /\ R = natToWord _ n ^+ acc.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS], "malloc"!"free" @ [freeS] ]]
  bmodule "ListSet" {{
    bfunction "new"("extra_stack", "x") [newS]
      "x" <-- Call "malloc"!"malloc"(0, 2)
      [PRE[_, R] R =?> 2 * [| R <> 0 |] * [| freeable R 2 |] * mallocHeap 0
       POST[R'] lset %0 R' * mallocHeap 0];;

      "x" *<- 0;;
      Return "x"
    end

    with bfunction "delete"("extra_stack", "self", "ls") [deleteS]
      "ls" <-* "self";;

      Call "malloc"!"free"(0, "self", 2)
      [Al s, Al n,
        PRE[V] lset' s n (V "ls") * mallocHeap 0
        POST[R] [| R = $0 |] * mallocHeap 0];;

      [Al s, Al n,
        PRE[V] lset' s n (V "ls") * mallocHeap 0
        POST[R] [| R = $0 |] * mallocHeap 0]
      While ("ls" <> 0) {
        "self" <-* "ls"+4;;
        Call "malloc"!"free"(0, "ls", 2)
        [Al s, Al n,
          PRE[V] lset' s n (V "self") * mallocHeap 0
          POST[R] [| R = $0 |] * mallocHeap 0];;

        "ls" <- "self"
      };;

      Return 0
    end

    with bfunction "mem"("extra_stack", "self", "n", "tmp") [memS]
      "self" <-* "self";;

      [Al s, Al n,
        PRE[V] lset' s n (V "self")
        POST[R] lset' s n (V "self") * [| s %has V "n" \is R |] ]
      While ("self" <> 0) {
        "tmp" <-* "self";;

        If ("tmp" = "n") {
          Return 1
        } else {
          "self" <-* "self"+4
        }
      };;

      Return 0
    end

    with bfunction "add"("extra_stack", "self", "n", "tmp") [addS]
      "tmp" <-- Call "ListSet"!"mem"("extra_stack", "self", "n")
      [Al s,
        PRE[V, R] [| s %has V "n" \is R |] * lset s (V "self") * mallocHeap 0
        POST[R'] [| R' = $0 |] * lset (s %+ V "n") (V "self") * mallocHeap 0];;

      If ("tmp" = 1) {
        Return 0
      } else {
        "tmp" <-- Call "malloc"!"malloc"(0, 2)
        [Al s,
          PRE[V, R] R =?> 2 * [| R <> 0 |] * [| freeable R 2 |]
            * [| ~s %has V "n" |] * lset s (V "self")
          POST[R'] [| R' = $0 |] * lset (s %+ V "n") (V "self")];;

        "tmp" *<- "n";;
        "n" <-* "self";;
        "tmp"+4 *<- "n";;
        "self" *<- "tmp";;
        Return 0
      }
    end

    with bfunction "remove"("extra_stack", "self", "n", "tmp") [removeS]
      "tmp" <-* "self";;

      [Al s, Al n,
        PRE[V] V "self" =*> V "tmp" * lset' s n (V "tmp") * mallocHeap 0
        POST[R] [| R = $0 |] * Ex p, Ex n', V "self" =*> p * lset' (s %- V "n") n' p * mallocHeap 0 ]
      While ("tmp" <> 0) {
        "tmp" <-* "tmp";;

        If ("tmp" = "n") {
          "tmp" <-* "self";;
          "n" <-* "tmp"+4;;
          "self" *<- "n";;

          Call "malloc"!"free"(0, "tmp", 2)
          [PRE[_] Emp
           POST[R] [| R = $0 |] ];;

          Return 0
        } else {
          "tmp" <-* "self";;
          "self" <- "tmp"+4;;
          "tmp" <-* "self"
        }
      };;

      Return 0
    end

    with bfunction "size"("extra_stack", "self", "acc") [sizeS]
      "self" <-* "self";;
      "acc" <- 0;;

      [Al s, Al n,
        PRE[V] lset' s n (V "self")
        POST[R] lset' s n (V "self") * [| cardinal_plus s R (V "acc") |] ]
      While ("self" <> 0) {
        "acc" <- "acc" + 1;;
        "self" <-* "self"+4
      };;

      Return "acc"
    end
  }}.

Local Hint Extern 1 (@eq W _ _) => words.

Theorem Singleton_bwd : forall A x y,
  Singleton A x y -> x = y.
  destruct 1; auto.
Qed.

Local Hint Immediate Singleton_bwd.

Ltac sets' := try rewrite has_eq in *;
  unfold propToWord, IF_then_else, add, sub, Ensembles.Add, Subtract, Setminus,
  Same_set, Included, Ensembles.In in *;
  intuition eauto.

Theorem Union_fwd : forall A x y z,
  x z \/ y z
  -> Union A x y z.
Proof.
  intuition; solve [ constructor; auto | constructor 2; auto ].
Qed.

Ltac sets :=
  repeat match goal with
           | [ H : _ === _ |- _ ] => generalize dependent H
           | [ H : _ %has _ |- _ ] => generalize dependent H
           | [ H : ~(_ %has _) |- _ ] => generalize dependent H
           | [ H : _ %has _ \is _ |- _ ] => generalize dependent H
           | [ H : @eq W _ _ |- _ ] => generalize dependent H
           | [ H : not (@eq W _ _) |- _ ] => generalize dependent H
         end; clear; intros;
  sets'; repeat (match goal with
                   | [ H0 : ?X = natToW 0, H1 : ?X = natToW 1 |- _ ] => rewrite H0 in H1; discriminate
                   | [ H : Empty_set _ _ |- _ ] => destruct H
                   | [ H : Singleton _ _ _ |- _ ] => destruct H
                   | [ |- Singleton _ _ _] => constructor
                   | [ H : Union _ _ _ _ |- _ ] => destruct H
                   | [ |- Union _ _ _ _] => apply Union_fwd
                 end; sets').

Theorem empty_bwd : forall x, %0 x -> False.
  destruct 1.
Qed.

Local Hint Resolve empty_bwd.

Lemma cardinal_plus_O : forall s w, cardinal_plus s w 0
  -> cardinal_is s w.
  destruct 1; intuition; eexists; eauto.
Qed.

Local Hint Immediate cardinal_plus_O.

Fixpoint nuke (ls : list W) (w : W) : list W :=
  match ls with
    | nil => nil
    | w' :: ls' =>
      if weq w' w then ls' else w' :: nuke ls' w
  end.

Lemma nuke_ok : forall w ls s,
  EnsembleListEquivalence (s %- w) ls
  -> s %has w
  -> EnsembleListEquivalence s (w :: ls).
  intros.
  destruct H.
  split.
  constructor; auto.
  intro.
  apply H1 in H2.
  destruct H2.
  apply H3.
  constructor.

  simpl; intuition.
  destruct (weq w x); auto.
  right; apply H1.
  constructor; auto.
  subst; sets.
  apply H1 in H3.
  destruct H3; auto.
Qed.

Lemma cardinal_plus_minus : forall s w r acc,
  cardinal_plus (s %- w) r (acc ^+ natToW 1)
  -> s %has w
  -> cardinal_plus s r acc.
  destruct 1; intuition subst.
  destruct H1; intuition subst.
  eexists; split.
  hnf; eauto using nuke_ok.
  simpl.
  rewrite natToWord_S.
  rewrite <- plus_n_O.
  words.
Qed.

Local Hint Immediate cardinal_plus_minus.

Lemma cardinal_is_bottom : forall r acc s,
  r = acc
  -> s === %0
  -> cardinal_plus s r acc.
Proof.
  intros; subst.
  exists 0; intuition.
  exists nil; intuition.
  split; intuition.
  constructor.
  apply H0 in H.
  destruct H.
Qed.

Local Hint Immediate cardinal_is_bottom.

Theorem ok : moduleOk m.
  vcgen; abstract (sep hints; eauto; try apply lset'_monotone; sets).
Qed.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Tactics.
From nbits Require Import NBits.

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

(* ===== bit_blast_const ===== *)

Definition bit_blast_const g (bs : bits) : generator * cnf * word :=
  (g, [::], map lit_of_bool bs).

Definition mk_env_const E g (bs : bits) : env * generator * cnf * word :=
  (E, g, [::], map lit_of_bool bs).

Lemma bit_blast_const_size_ss ls g g' (cs: cnf) (lrs: seq literal):
    bit_blast_const g ls = (g', cs, lrs) ->
    size ls = size lrs.
Proof.
  rewrite /bit_blast_const/=. case => _ _ <-. by rewrite size_map.
Qed.

Lemma bit_blast_const_correct g bs E g' cs ls :
  bit_blast_const g bs = (g', cs, ls) -> interp_cnf E (add_prelude cs) ->
  enc_bits E ls bs.
Proof.
  rewrite /bit_blast_const. case=> _ <- <- Hpre. apply: enc_bits_lit_of_bool.
  exact: (add_prelude_enc_bit_tt Hpre).
Qed.

Lemma mk_env_const_is_bit_blast_const E g bs E' g' cs ls :
  mk_env_const E g bs = (E', g', cs, ls) -> bit_blast_const g bs = (g', cs, ls).
Proof. rewrite /mk_env_const /bit_blast_const. by case=> _ <- <- <-. Qed.

Lemma mk_env_const_sat E g bs E' g' cs lrs :
  mk_env_const E g bs = (E', g', cs, lrs) -> interp_cnf E' cs.
Proof. by case=> <- _ <- _. Qed.

Lemma mk_env_const_preserve E g bs E' g' cs lrs :
  mk_env_const E g bs = (E', g', cs, lrs) -> env_preserve E E' g.
Proof. case=> <- _ _ _. exact: env_preserve_refl. Qed.

Lemma mk_env_const_newer_gen E g bs E' g' cs lrs :
  mk_env_const E g bs = (E', g', cs, lrs) -> (g <=? g')%positive.
Proof. case=> _ <- _ _. exact: Pos.leb_refl. Qed.

Lemma mk_env_const_newer_res E g bs E' g' cs lrs :
  mk_env_const E g bs = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_lits g' lrs.
Proof.
  case=> _ <- _ <- Htt {E E' g' cs lrs}. exact: (newer_than_lits_lit_of_bool _ Htt).
Qed.

Lemma mk_env_const_newer_cnf E g bs E' g' cs lrs :
  mk_env_const E g bs = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_cnf g' cs.
Proof. by case => _ <- <- _. Qed.


From SSL_Iris Require Import core.
From iris.heap_lang Require Import lang notation proofmode.
From iris_string_ident Require Import ltac2_string_ident.

Section common.
Context `{!heapG Σ}.

(*** Least fixpoint definition ***)
Canonical Structure listO := leibnizO (list Z).

Definition sll' (f : loc * list Z -> iProp Σ) (arg : loc * list Z) : iProp Σ :=
  let (x, s) := arg in
  (⌜x = null_loc /\ s = []⌝ ∨ (∃ v1 s1 (next : loc), ⌜~ (x = null_loc) ∧ (s = ([v1] ++ s1))⌝ ∗ ⌜True⌝ ∗ x ↦ #v1 ∗ (x +ₗ 1) ↦ #next ∗ f (next, s1)))%I.

Global Instance sll'_mono : fixpoint.BiMonoPred sll'.
Proof.
  constructor.
  - iIntros (??) "#H".
    iIntros ([x s]) "[A | B]"; first by iLeft.
    rewrite/sll'. iRight.
    iDestruct "B" as (v1 s1 next) "(? & ? & ? & ? & ?)".
    iExists v1, s1, next.
    iFrame. by iApply "H".
  - intros f Hf n [x1 s1] [x2 s2].
    intros [?%leibniz_equiv ?%leibniz_equiv].
    simpl in H0. simpl in H1.
    by subst.
Qed.

Definition sll_ := fixpoint.bi_least_fixpoint sll'.

Lemma cons_0_open  (x: loc) (s: (list Z)) :
  x = null_loc → sll_ (x, s) ⊣⊢ ⌜(x = null_loc) ∧ (s = [])⌝.
Proof.
  intros Eq. iSplit.
  - iIntros "P".
    unfold sll_. rewrite (fixpoint.least_fixpoint_unfold sll' (x, s)).
    rewrite Eq.
    iDestruct "P" as "[#P | P]".
    by iFrame "P".
    by iDestruct "P" as (v s1 nxt) "((% & %) & (? & ? & ? & ?))".
  - iIntros "[%%]".
    unfold sll_. rewrite (fixpoint.least_fixpoint_unfold sll' (x, s)). simpl.
    iLeft. done.
Qed.

Lemma cons_1_open  (x: loc) (s: (list Z)) :
  ~ (x = null_loc) → sll_ (x, s) ⊣⊢
     (∃ (v : Z) (s1 : (list Z)) (nxt : loc), ⌜~ (x = null_loc) ∧ (s = ([v] ++ s1))⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #nxt ∗ sll_ (nxt, s1)).
Proof.
  intros Eq. iSplit.
  - iIntros "P".
    unfold sll_. rewrite (fixpoint.least_fixpoint_unfold sll' (x, s)).
    iDestruct "P" as "[#P | P]".
    + by iDestruct "P" as "(% & %)".
    + iDestruct "P" as (v s1 nxt) "((% & %) & (? & ? & ? & ?))".
    iExists v, s1, nxt. iFrame. eauto.
  - iDestruct 1 as (v s1 nxt) "((% & %) & (? & ? & ? & ?))".
    unfold sll_. rewrite (fixpoint.least_fixpoint_unfold sll' (x, s)). simpl.
    iRight. by iExists v, s1, nxt; iFrame.
Qed.

(*** Cardinality definition ***)

Inductive sll_card : Set :=
    | sll_card_0 : sll_card
    | sll_card_1 : sll_card -> sll_card.

Fixpoint sll (x: loc) (s: (list Z)) (self_card: sll_card) { struct self_card } : iProp Σ := match self_card with
    | sll_card_0  => ⌜(x = null_loc) ∧ (s = [])⌝
    | sll_card_1 _alpha_522 => ∃ (v : Z) (s1 : (list Z)) (nxt : loc), ⌜~ (x = null_loc) ∧ (s = ([v] ++ s1))⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #nxt ∗ (sll nxt s1 _alpha_522)
end.

Global Opaque sll.

Lemma sll_card_0_learn (x: loc) (s: (list Z)) self_card:
sll x s self_card  ⊢ sll x s self_card ∗ ⌜(x = null_loc) -> self_card = sll_card_0⌝.
Proof.
Transparent sll.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (v s1 nxt) "((% & %) & (? & ? & ? & ?))".
   iSplitL.
   iExists v, s1, nxt. iFrame. eauto.
   eauto.
Global Opaque sll.
Qed.

Lemma sll_card_1_learn (x: loc) (s: (list Z)) self_card:
sll x s self_card  ⊢ sll x s self_card ∗ ⌜~ (x = null_loc) -> ∃ _alpha_522, self_card = (sll_card_1 _alpha_522)⌝.
Proof.
Transparent sll.
destruct self_card; iIntros "P".
- iDestruct "P" as  "(% & %)".
   iSplitL.
    iFrame. eauto.
   eauto.
- iDestruct "P" as (v s1 nxt) "((% & %) & (? & ? & ? & ?))".
   iSplitL.
   iExists v, s1, nxt. iFrame. eauto.
   eauto.
Global Opaque sll.
Qed.

Lemma sll_card_0_open  (x: loc) (s: (list Z)) :
sll x s (sll_card_0 ) = (⌜(x = null_loc) ∧ (s = [])⌝)%I.
Proof. auto. Qed.

Lemma sll_card_1_open (_alpha_522 : sll_card) (x: loc) (s: (list Z)) :
sll x s (sll_card_1 _alpha_522) = (∃ (v : Z) (s1 : (list Z)) (nxt : loc), ⌜~ (x = null_loc) ∧ (s = ([v] ++ s1))⌝ ∗ ⌜True⌝ ∗ x ↦ #v ∗ (x +ₗ 1) ↦ #nxt ∗ (sll nxt s1 _alpha_522))%I.
Proof. auto. Qed.

End common.


From Coq Require Import OrderedType.
From Coq Require Import MSetInterface.
From Coq Require Import MSetFacts.
From Coq Require Import MSetRBT.
From mathcomp Require Import all_ssreflect.
From chip Require Import ordtype close_dfs.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Type OrdType.
Parameter T : ordType.
End OrdType.

Module OrdTypeUsualOrderedType (Import OT : OrdType) <: UsualOrderedType.

Definition t : Type := T.
Definition eq := @eq T.
Definition eq_equiv := @eq_equivalence T.

Definition lt : t -> t -> Prop := @ord T.

Lemma lt_strorder : StrictOrder (@ord T).
Proof.
split; first by move => x Hi; rewrite irr in Hi.
by move => x y z; apply: trans.
Qed.

Lemma lt_compat : Proper (eq ==> eq ==> iff) (@ord T).
Proof.
move => x1 y1 Hxy1 x2 y2 Hxy2.
by rewrite Hxy1 Hxy2.
Qed.

Definition compare x y :=
 if x == y then Eq else if @ord T x y then Lt else Gt.

Lemma compare_spec x y : CompSpec eq (@ord T) x y (compare x y).
Proof.
rewrite /compare.
case: ifP; first by move/eqP => Heq; apply CompEq.
move/negP/negP/eqP => Heq.
case: ifP => Hxy; first by apply CompLt.
move/negP: Hxy => Hxy.
apply CompGt.
case/orP: (ord_total x y) => //.
case/orP => //.
by move/eqP.
Qed.

Definition eq_dec (x y  : t) : {x = y}+{x <> y}.
  refine
    (match x == y as exy return (_ = exy -> _) with
     | true => fun H => left _
     | false => fun H => right _
     end (refl_equal _)).
- by move/eqP: H.
- by move/negP/negP/eqP: H.
Defined.

End OrdTypeUsualOrderedType.

Module Type FinType.
Parameter T : finType.
End FinType.

Module Type FinOrdType (Import FT : FinType).
Parameter ordT : rel T.
Parameter irr_ordT : irreflexive ordT.
Parameter trans_ordT : transitive ordT.
Parameter total_ordT : forall x y, x != y -> ordT x y || ordT y x.
End FinOrdType.

Module Type FinUsualOrderedType (FT : FinType) <: UsualOrderedType.
Definition t : Type := FT.T.
Definition eq := @eq t.
Definition eq_equiv := @eq_equivalence t.
Parameter Inline lt : t -> t -> Prop.
Parameter lt_strorder : StrictOrder lt.
Parameter lt_compat : Proper (eq ==> eq ==> iff) lt.
Parameter compare : t -> t -> comparison.
Parameter compare_spec : forall t1 t2, CompSpec eq lt t1 t2 (compare t1 t2).
Parameter eq_dec : forall x y : t, {x = y} + { x <> y }.
End FinUsualOrderedType.

Module FinOrdUsualOrderedType (FT : FinType) (FOT : FinOrdType FT) <: FinUsualOrderedType FT.

Module OT.
Definition T : ordType := OrdType FT.T (OrdMixin FOT.irr_ordT FOT.trans_ordT FOT.total_ordT).
End OT.

Module OTUOT := OrdTypeUsualOrderedType OT.

Definition t : Type := FT.T.
Definition eq := @eq t.
Definition eq_equiv := @eq_equivalence t.
Definition lt := OTUOT.lt.
Definition lt_strorder := OTUOT.lt_strorder.
Definition lt_compat := OTUOT.lt_compat.
Definition compare := OTUOT.compare.
Definition compare_spec := OTUOT.compare_spec.
Definition eq_dec := OTUOT.eq_dec.

End FinOrdUsualOrderedType.

Module DFS (Import FT : FinType) (FUOT : FinUsualOrderedType FT) (MS : MSetInterface.S with Module E := FUOT).

Module MSF := Facts MS.

Fixpoint sdfs g n s x :=
  if MS.mem x s then s else
  if n is n'.+1 then foldl (sdfs g n') (MS.add x s) (g x) else s.

Lemma subset_sdfs : forall (g : T -> seq T) n (s : seq T) x ms,
  MS.mem x ms ->
  MS.mem x (foldl (sdfs g n) ms s).
Proof.
move => g n s x ms Hx.
have ->: s = rev (rev s) by rewrite revK.
rewrite foldl_rev.
generalize (rev s) => s'.
move: n s' x ms Hx {s}.
elim => [|n IHn].
- elim => //=.
  move => x s IH y ms Hy.
  by case: ifP => Hm; apply: IH.
- elim => //=.
  move => x s IH y ms Hy.
  case: ifP => Hm; first by apply: IH.
  have ->: g x = rev (rev (g x)) by rewrite revK.
  rewrite foldl_rev.
  apply: IHn.
  apply/MSF.mem_1.
  apply/MSF.add_2.
  apply/MSF.mem_2.
  exact: IH.
Qed.

Lemma dfs_sdfs_in : forall (g : T -> seq T) n (s : seq T) (ms : MS.t) x z,
 (forall y, y \in s = MS.mem y ms) ->
 x \in dfs g n s z = MS.mem x (sdfs g n ms z).
Proof.
move => g.
elim => //=; first by move => s ms x Hy; case: ifP; case: ifP.
move => n IH s ms x z Hy.
case: ifP; case: ifP => //= Hx Hs.
- by apply/idP/idP => Hxy; move/negP: Hx; case; rewrite -Hy.
- by apply/idP/idP => Hxy; move/negP: Hs; case; rewrite Hy.
- suff Hy': forall y, (y \in z :: s) = MS.mem y (MS.add z ms).
    move: Hy'.
    set s' := z :: s.
    set ms' := MS.add z ms.
    set s0 := g z.
    move: s0 s' ms'.
    elim => //=.
    move => z0 s0 IH' s' ms' Hs'.
    by erewrite IH'; eauto.
  move => y.
  rewrite in_cons.
  apply/orP.
  case: ifP => Hm.
  * move/MSF.mem_2: Hm.
    move/MSF.add_3 => Hzy.
    case Hyz: (y == z); first by left.
    right.
    rewrite Hy.
    apply/MSF.mem_1.
    apply Hzy.
    move => Hyz'.
    by move/negP/negP/eqP: Hyz; case.
  * move => Hyz; case: Hyz.
    + move/eqP => Hyz.
      move/negP: Hm.
      case.
      by apply/MSF.mem_1/MSF.add_1.
    + move => Hyz.
      move/negP: Hm.
      case.
      apply/MSF.mem_1/MSF.add_2/MSF.mem_2.
      by rewrite -Hy.
Qed.

Definition srclosure g :=
 foldr (fun x s => sdfs g #|T| s x) MS.empty.

Definition srclosure' g :=
 foldl (sdfs g #|T|) MS.empty.

Lemma rclosure_srclosure : forall g s x,
  x \in rclosure g s = MS.mem x (srclosure g s).
Proof.
move => g.
elim => //=; last by move => x s IH y; apply: dfs_sdfs_in.
move => x.
rewrite in_nil.
apply/idP/idP => //.
move/MSF.mem_2.
by move/MSF.empty_1.
Qed.

Lemma in_foldr_mem : forall g s0 n x,
 x \in foldr (fun x s => dfs g n s x) [::] s0 =
 MS.mem x (foldr (fun x s => sdfs g n s x) MS.empty s0).
Proof.
move => g.
elim => //=; last by move => x s IH n y; erewrite dfs_sdfs_in; eauto.
move => n x.
rewrite in_nil.
case Hm: (MS.mem x MS.empty) => //.
move/MSF.mem_2: Hm.
by move/MSF.empty_1.
Qed.

Lemma srclosure_srclosure' : forall g s x,
 MS.mem x (srclosure g s) = MS.mem x (srclosure' g s).
Proof.
move => g s x.
apply/idP/idP.
- have {2} ->: s = rev (rev s) by rewrite revK.
  rewrite /srclosure /srclosure' foldl_rev.
  rewrite -(in_foldr_mem g s) -(in_foldr_mem g (rev s)) (@closure_eqi _ _ s (rev s)) // => y.
  by move: (has_rev (pred1 y) s); rewrite 2!has_pred1.
- have {1} ->: s = rev (rev s) by rewrite revK.
  rewrite /srclosure' /srclosure foldl_rev.
  rewrite -(in_foldr_mem g s) -(in_foldr_mem g (rev s)) (@closure_eqi _ _ (rev s) s) // => y.
  by move: (has_rev (pred1 y) s); rewrite 2!has_pred1.
Qed.

Lemma rclosure'_srclosure' : forall g s x,
  x \in rclosure' g s = MS.mem x (srclosure' g s).
Proof.
move => g s x.
by rewrite -srclosure_srclosure' -rclosure_srclosure rclosure_rclosure'_i.
Qed.

Definition elts_srclosure g s :=
 MS.elements (srclosure g s).

Definition elts_srclosure' g s :=
 MS.elements (srclosure' g s).

Lemma elements_in_mem : forall s x,
  x \in MS.elements s = MS.mem x s.
Proof.
move => s x.
apply/idP/idP; last first.
- move/MSF.mem_2/MSF.elements_1.
  move/InA_alt => [y [Hx Hy]].
  rewrite Hx; move: Hy.
  set e := MS.elements _.
  elim: e => //=.
  move => z e IH.
  case; first by move =>->; rewrite in_cons; apply: predU1l.
  by rewrite in_cons => Hy; apply predU1r; apply: IH.
- move => Hm.
  apply/MSF.mem_1/MSF.elements_2/InA_alt.
  exists x; split => //; move: Hm.
  set e := MS.elements _.
  elim: e => //.
  move => y e IH.
  rewrite in_cons.
  move/orP; case; first by move/eqP; left.
  move => Hx.
  by right; apply: IH.
Qed.

Lemma elts_srclosureP g (modified : seq T) x :
 reflect
   (exists2 v, v \in modified & connect g v x)
   (x \in elts_srclosure (rgraph g) modified).
Proof.
apply: (iffP idP).
- rewrite elements_in_mem -rclosure_srclosure.
  by move/rclosureP.
- move/rclosureP.
  rewrite rclosure_srclosure.
  by rewrite elements_in_mem.
Qed.

Lemma elts_srclosurePg g (modified : seq T) x :
 reflect
   (exists2 v, v \in modified & connect (grel g) v x)
   (x \in elts_srclosure g modified).
Proof.
apply: (iffP idP).
- rewrite elements_in_mem -rclosure_srclosure.
  by move/rclosurePg.
- move/rclosurePg.
  rewrite rclosure_srclosure.
  by rewrite elements_in_mem.
Qed.

Lemma elts_srclosure'P g (modified : seq T) x :
 reflect
   (exists2 v, v \in modified & connect g v x)
   (x \in elts_srclosure' (rgraph g) modified).
Proof.
apply: (iffP idP).
- rewrite elements_in_mem -rclosure'_srclosure' -rclosure_rclosure'_i.
  by move/rclosureP.
- move/rclosureP.
  rewrite rclosure_srclosure.
  by rewrite srclosure_srclosure' elements_in_mem.
Qed.

Lemma elts_srclosure'Pg g (modified : seq T) x :
  reflect
    (exists2 v, v \in modified & connect (grel g) v x)
    (x \in elts_srclosure' g modified).
Proof.
apply: (iffP idP).
- rewrite elements_in_mem -rclosure'_srclosure' -rclosure_rclosure'_i.
  by move/rclosurePg.
- move/rclosurePg.
  rewrite rclosure_srclosure.
  by rewrite srclosure_srclosure' elements_in_mem.
Qed.

Lemma elts_srclosure_uniq : forall g s,
 uniq (elts_srclosure g s).
Proof.
move => g s.
rewrite /elts_srclosure.
have Hs := MS.elements_spec2w (srclosure g s).
move: Hs.
set e := MS.elements _.
elim: e => //=.
move => x e IH Hn.
inversion Hn; subst.
apply/andP.
split; last by apply: IH.
apply/negP => Hx.
case: H1.
apply/InA_alt.
exists x; split => //.
elim: e Hx {IH Hn H2} => //=.
move => y e IH.
rewrite in_cons.
move/orP; case; first by move/eqP =>->; left.
move => Hx.
by right; apply: IH.
Qed.

Lemma elts_srclosure'_uniq : forall g s,
  uniq (elts_srclosure' g s).
Proof.
move => g s.
rewrite /elts_srclosure' /srclosure'.
have ->: s = rev (rev s) by rewrite revK.
rewrite foldl_rev.
exact: elts_srclosure_uniq.
Qed.

Lemma rclosed_elts_srclosure : forall g s,
  rclosed g (elts_srclosure (rgraph g) s).
Proof.
move => g s.
move => x y Hg.
rewrite 2!elements_in_mem -2!rclosure_srclosure.
exact: rclosed_rclosure.
Qed.

Lemma rclosed_elts_srclosure' : forall g s,
  rclosed g (elts_srclosure' (rgraph g) s).
Proof.
move => g s.
move => x y Hg.
rewrite 2!elements_in_mem -2!rclosure'_srclosure'.
exact: rclosed_rclosure'.
Qed.

End DFS.

Module Type OrdinalFinType <: FinType.
Parameter n : nat.
Definition T : finType := [finType of 'I_n].
End OrdinalFinType.

Module OrdinalFinOrdType (Import OFT : OrdinalFinType) <: FinOrdType OFT.
Definition ordT : rel T := fun x y => ltn x y.
Definition irr_ordT : irreflexive ordT := irr_ltn_nat.
Definition trans_ordT : transitive ordT := trans_ltn_nat.
Definition total_ordT : forall x y, x != y -> ordT x y || ordT y x := semiconn_ltn_nat.
End OrdinalFinOrdType.

(* Instantiation test *)

Module OFT5 <: OrdinalFinType. Definition n := 5. Definition T := [finType of 'I_5]. End OFT5.
Module OFOT5 <: FinOrdType OFT5 := OrdinalFinOrdType OFT5.
Module FUOT5 <: FinUsualOrderedType OFT5 := FinOrdUsualOrderedType OFT5 OFOT5.
Module RBSet5 <: MSetInterface.S := MSetRBT.Make FUOT5.
Module RBDFS5 := DFS OFT5 FUOT5 RBSet5.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Why can't I induct on K and keep d connected?

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Require Export FormalSyntax.
Require Export VarLemmas.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafety.
Require Export ContextExtensionRelation.

Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.

Require Export AlphaConversion.
Require Export GetLemmasRelation.

(* Works perfectly ! d is connected. *)
Lemma K_d_induction_test_1:
  forall (d : Delta) (tau : Tau) (k : Kappa),
         K d tau k ->
         K d tau k.
Proof.
  intros d tau k Kder.
  K_ind_cases (induction Kder) Case.
  Case "K d cint B".
   constructor.
   constructor.
   assumption.
   admit.
Admitted.

Lemma K_d_induction_test_2:
  forall (d : Delta) (tau : Tau) (k : Kappa) (alpha : TVar),
         K d tau k ->
         K ([(alpha,k)] ++ d) tau k.
Proof.
  intros d tau k alpha Kder.
  K_ind_cases (induction Kder) Case.
  Case "K d cint B".
   admit.
   Case "K d (tv_t alpha) B".
   admit.
   Case "K d (ptype (tv_t alpha)) B".
   admit.
   (* Still connected. *)
Admitted.

(* This is connected. *)
Lemma K_d_induction_test_3:
  forall (d : Delta) (tau : Tau) (k : Kappa) (alpha : TVar),
         K d tau k ->
         AK d tau k .
Proof.
  intros d tau k alpha Kder.
  K_ind_cases (induction Kder) Case.
  Case "K d cint B".
   admit.
  Case "K d (tv_t alpha) B".
   admit.
  Case "K d (ptype (tv_t alpha)) B".
    admit.
Admitted.

(* This is connected. *)
Lemma K_d_induction_test_4:
  forall (d : Delta) (tau : Tau) (k : Kappa) (alpha : TVar),
         K d tau k ->
         K d (subst_Tau tau tau alpha) k.
Proof.
  intros d tau k alpha Kder.
  K_ind_cases (induction Kder) Case.
  Case "K d cint B".
   admit.
  Case "K d (tv_t alpha) B".
   admit.
  Case "K d (ptype (tv_t alpha)) B".
    admit.
Admitted.

(* Disconnected! yeah. *)
Lemma K_d_induction_test_5:
  forall (d : Delta) (tau : Tau) (k : Kappa) (alpha : TVar),
    K ([(alpha,k)] ++ d) tau k ->
    K d tau k.
Proof.
  intros d tau k alpha Kder.
  K_ind_cases (induction Kder) Case.
  Case "K d cint B".
   admit.
  Case "K d (tv_t alpha) B".
   admit.
  Case "K d (ptype (tv_t alpha)) B".
   admit.
Admitted.

(* OK so the induction principle or induction does not handle a deconstructed
 d in the inductive base. *)

(* Let's try equational connectivity. WORKS! But wrong theorem statement!*)
Lemma K_d_induction_test_6:
  forall (d : Delta) (tau : Tau) (k : Kappa) (alpha : TVar),
      K d tau k ->
      forall (d' : Delta),
        d = ([(alpha,k)] ++ d') ->
        K d tau k.
Proof.
   intros d tau k alpha Kder.
  K_ind_cases (induction Kder) Case.
  Case "K d cint B".
   admit.
  Case "K d (tv_t alpha) B".
   intros.
   admit.
  Case "K d (ptype (tv_t alpha)) B".
   admit.
Admitted.

(* Let's try equational connectivity. WORKS! *)
(* Looks good, time to try it in the real theorem. *)
Lemma K_d_induction_test_7:
  forall (d : Delta) (tau : Tau) (k : Kappa) (alpha : TVar),
      K d tau k ->
      forall (d' : Delta),
        d = ([(alpha,k)] ++ d') ->
        K d' tau k.
Proof.
  intros d tau k alpha Kder.
  K_ind_cases (induction Kder) Case.
  Case "K d cint B".
   admit.
  Case "K d (tv_t alpha) B".
   intros.
   admit.
  Case "K d (ptype (tv_t alpha)) B".
   admit.
  admit.

Admitted.

(* Nope I get broken induction hyptotheses! Something is
 wrong in K induction or getD if you ask me.

*)

Inductive K' : Delta -> Tau -> Kappa -> Prop :=
(*
 | K_int   : forall (d : Delta),
                  K' d cint B
*)

 | K_B     : forall (d : Delta) (alpha : TVar),
               getD d alpha = Some B ->
               K' d (tv_t alpha) B

 | K_star_A  : forall (d : Delta) (alpha : TVar),
                 getD d alpha = Some A ->
                 K'  d (ptype (tv_t alpha)) B.

(*
(* Take out the A/B loop and see what happens, still disconnected. *)
 | K_B_A     : forall (d : Delta) (tau : Tau),
                  K'  d tau B ->
                  K'  d tau A

 | K_cross   : forall (d : Delta) (t0 t1 : Tau),
                    K' d t0 A ->
                    K' d t1 A ->
                    K' d (cross t0 t1) A

 | K_arrow   : forall (d : Delta) (t0 t1 : Tau),
                    K' d t0 A ->
                    K' d t1 A ->
                    K' d (arrow t0 t1) A

 | K_ptype    :  forall (d : Delta) (tau : Tau),
                    K' d tau A ->
                    K' d (ptype tau) B

 | K_utype  : forall (d : Delta) (alpha : TVar) (k : Kappa) (tau : Tau),
                   WFD ([(alpha, k)] ++ d) ->
                   getD d alpha = None ->
                   K' ([(alpha, k)] ++ d) tau A ->
                   K' d (utype alpha k tau) A

 | K_etype  : forall (d : Delta) (alpha : TVar) (k : Kappa) (tau : Tau) (p : Phi),
                   WFD ([(alpha, k)] ++ d) ->
                   getD d alpha = None ->
                   K' ([(alpha, k)] ++ d) tau A ->
                   K' d (etype p alpha k tau) A.
*)

Inductive AK' : Delta -> Tau -> Kappa -> Prop :=

 | AK_AK_K  : forall (d : Delta) (tau : Tau) (k : Kappa),
                   K'  d tau k ->
                   AK' d tau k

 | AK_A     : forall (d : Delta) (alpha : TVar),
                getD d alpha = Some A ->
                AK' d (tv_t alpha) A.

Lemma A_6_Substitution_1:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      AK' d tau k ->
      forall (alpha : TVar) (k' : Kappa) (tau' : Tau),
        K' ([(alpha,k)] ++ d) tau' k' ->
        K' d (subst_Tau tau' tau alpha) k'.
Proof.
  intros d tau k AK alpha k' tau' Kder.
  induction Kder.
  Case "K d cint B".
   admit.
  Case "K d (tv_t alpha) B".
   admit. (* Disconnected starting right here. *)
Qed.

Lemma A_6_Substitution_1_extendedby:
  forall (d d' : Delta) (t' : Tau) (k' : Kappa) (alpha : TVar) (k : Kappa),
    ExtendedByD d d' ->
    getD d' alpha = Some k ->
    getD d alpha = None ->
    K d' t' k' ->
    forall (t : Tau),
      AK d t k ->
      K d (subst_Tau t' t alpha) k'.
Proof.
  intros d d' t' k' alpha k ext getd'alphasomek getdalphanone Kder.
  K_ind_cases(induction Kder) Case.
  Case "K d cint B".
   intros.
   simpl.
   constructor.
  Case "K d (tv_t alpha) B".
   intros.
   simpl.
   case_eq (beq_tvar alpha alpha0).
    SCase "beq_tvar alpha alpha0 = true".
     intros.
     admit.
    SCase "beq_tvar alpha alpha0 = false".
     intros.
     (* Still looks false. *)
     admit.
  Case "K d (ptype (tv_t alpha)) B".
   intros.
   simpl.
   case_eq (beq_tvar alpha alpha0).
    SCase "beq_tvar alpha alpha0 = true".
     intros.
     apply beq_tvar_eq in H1.
     rewrite H1 in *.
     apply K_ptype.
     inversion H0; try assumption.
     admit.
     crush.
     admit.
    SCase "beq_tvar alpha0 alpha = false".
     intros.
     apply K_ptype.
     admit.
  Case "K d tau A".
   intros.
   apply K_B_A.
   admit.
  Case "K d (cross t0 t1) A".
   intros.
   pose proof H as H'.
(*
   apply IHKder1 with (alpha:= alpha) in H; try assumption.
   apply IHKder2 with (alpha:= alpha) in H'; try assumption.
   simpl.
   apply K_cross; try assumption.
  Case "K d (arrow t0 t1) A".
   intros.
   pose proof H as H'.
   apply IHKder1 with (alpha:= alpha) in H; try assumption.
   apply IHKder2 with (alpha:= alpha) in H'; try assumption.
   simpl.
   apply K_arrow; try assumption.
  Case "K d (ptype tau) B".
   intros.
   apply IHKder with (alpha:= alpha) in H; try assumption.
   simpl.
   apply K_ptype; try assumption.
  Case "K d (utype alpha k tau) A".
    intros.
    apply IHKder with (alpha0:= alpha) in H1; try assumption.
    simpl.
    case_eq (beq_tvar alpha0 alpha).
    SCase "beq_tvar alpha0 alpha = true".
     intros.
     AdmitAlphaConversion.
    SCase "beq_tvar alpha0 alpha = false".
     intros.
     apply K_utype; try assumption.
     admit.
     (* WFD ([(alpha, k)] ++ d)-> ExtendedByD d0 d -> WFD ([(alpha, k)] ++ d0) *)
     admit.
     (* WFD ([(alpha, k)] ++ d) -> ExtendedByD d0 d -> getD d0 alpha = None. *)
     admit.
     (* WFD ([(alpha, k)] ++ d) -> ExtendedByD d0 d -> ExtendedByD d0 ([(alpha, k)] ++ d) *)
     admit.
     admit. (* getD ([(alpha, k)] ++ d) alpha = Some k0 why? *)
     admit.
  Case "K d (etype p alpha k tau) A)".
   admit.
*)
Admitted.

(* Doubtful this will do anything as I need an induction that wraps at
 every constructor or I must induct again on K. *)
Inductive K2 : TVar -> Kappa -> Delta -> Tau -> Kappa -> Prop :=
  | K2_wrap :
      forall (alpha : TVar) (k : Kappa) (d : Delta) (t : Tau) (k' : Kappa),
        K ([(alpha,k)] ++ d) t k' ->
        K2 alpha k d t k'.

Lemma A_6_Substitution_1_wrapping_judgement:
  forall (d : Delta) (t' : Tau) (k' : Kappa) (alpha : TVar) (k : Kappa),
    K2 alpha k d  t' k' ->
    forall (t : Tau),
      AK d t k ->
      K d (subst_Tau t' t alpha) k'.
Proof.
  intros d t' k' alpha k K2Der.
  induction K2Der.
  intros.
  induction H.
 Case "K d cint B".
  admit.
 Case "K d (tv_t alpha) B".
 admit. (* Fail. *)
 Case "K d (ptype (tv_t alpha)) B".
  admit.
 Case "K d tau A".
  admit.
 Case "K d (cross t0 t1) A".
  admit.
 Case "K d (arrow t0 t1) A".
  admit.
 Case "K d (ptype tau) B".
  admit.
 Case "K d (utype alpha k tau) A".
  admit.
 Case "K d (etype p alpha k tau) A)".
  admit.
Qed.


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_exch.
Require Import wKS_wkn.
Require Import wKS_remove_list.
Require Import wKS_dec.
Require Import Lia.

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

Lemma remove_rest_gen_ext : forall l A, rest_gen_ext [A] (remove eq_dec_form A l) l.
Proof.
induction l ; intros.
- simpl. apply univ_gen_ext_nil.
- simpl. destruct (eq_dec_form A a).
  * subst. apply univ_gen_ext_extra. apply InT_eq. apply IHl.
  * apply univ_gen_ext_cons. apply IHl.
Qed.

Theorem derrec_height_False_ge_1 : forall s, forall (D : wKS_prv s), 1 <= derrec_height D.
Proof.
intros s D.
induction D.
- destruct p.
- simpl. lia.
Qed.

Lemma rest_nobox_gen_ext_trans : forall (A B : MPropF) l0 l1 l2, ((In (Imp A B) l0) -> False) ->
                                                    (nobox_gen_ext l0 l1) ->
                                                    (rest_gen_ext [Imp A B] l2 l1) ->
                                                    (nobox_gen_ext l0 l2).
Proof.
intros A B l0 l1 l2 H1 H2. generalize dependent l2.
induction H2.
- intros. inversion X. apply univ_gen_ext_nil.
- intros. inversion X.
  * subst. apply univ_gen_ext_cons. apply IHuniv_gen_ext. intro. apply H1.
    apply in_cons. assumption. assumption.
  * subst. inversion H3. subst. exfalso. apply H1. apply in_eq.
    inversion H0.
- intros. inversion X.
  * subst. apply univ_gen_ext_extra. assumption. apply IHuniv_gen_ext ; assumption.
  * subst. apply IHuniv_gen_ext ; assumption.
Qed.

(* We prove the height-preserving invertibility of ImpR and ImpL below. *)

Theorem ImpR_ImpL_hpinv : forall (k : nat) concl
        (D0 : wKS_prv concl),
        k = (derrec_height D0) ->
          ((forall prem, ((ImpRRule [prem] concl) ->
          existsT2 (D1 : wKS_prv prem),
          derrec_height D1 <= k))) *
          ((forall prem1 prem2, ((ImpLRule [prem1; prem2] concl) ->
          existsT2 (D1 : wKS_prv prem1)
                   (D2 : wKS_prv prem2),
          (derrec_height D1 <= k) * (derrec_height D2 <= k)))).
Proof.
assert (DersNilF: dersrec (wKS_rules) (fun _ : Seq => False) []).
apply dersrec_nil.
(* Setting up the strong induction on the height. *)
pose (strong_inductionT (fun (x:nat) => forall (concl : Seq)
  (D0 : derrec (wKS_rules) (fun _ : Seq => False) concl),
x = derrec_height D0 ->
((forall prem, ((ImpRRule [prem] concl) ->
          existsT2 (D1 : wKS_prv prem),
          derrec_height D1 <= x))) *
          ((forall prem1 prem2, ((ImpLRule [prem1; prem2] concl) ->
          existsT2 (D1 : wKS_prv prem1)
                   (D2 : wKS_prv prem2),
          (derrec_height D1 <= x) * (derrec_height D2 <= x)))))).
apply p. intros n IH. clear p.
(* Now we do the actual proof-theoretical work. *)
intros s D0. remember D0 as D0'. destruct D0.
(* D0 is a leaf *)
- destruct f.
(* D0 is ends with an application of rule *)
- intros hei. split.
{ intros prem RA. inversion RA. subst.
  inversion w ; subst.
  (* IdP *)
  * inversion H. subst. assert (InT # P (Γ0 ++ Γ1)).
    rewrite <- H2. apply InT_or_app. right. apply InT_eq. assert (InT # P (Γ0 ++ A :: Γ1)).
    apply InT_app_or in H0. destruct H0. apply InT_or_app. auto. apply InT_or_app. right.
    apply InT_cons. assumption. apply InT_split in H1. destruct H1. destruct s. rewrite e.
    assert (InT # P (Δ0 ++ B :: Δ1)). assert (InT # P (Δ2 ++ # P :: Δ3)).
    apply InT_or_app. right. apply InT_eq. rewrite H3 in H1. apply InT_app_or in H1.
    destruct H1. apply InT_or_app. auto. inversion i. inversion H4. apply InT_or_app. right.
    apply InT_cons. assumption. apply InT_split in H1. destruct H1. destruct s.
    rewrite e0. assert (IdPRule [] (x ++ # P :: x0, x1 ++ # P :: x2)).
    apply IdPRule_I. apply IdP in H1.
    pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
    (ps:=[]) (x ++ # P :: x0, x1 ++ # P :: x2) H1 DersNilF). exists d0.
    simpl. rewrite dersrec_height_nil. lia. reflexivity.
  (* BotL *)
  * inversion H. subst. assert (InT (Bot) (Γ0 ++ Γ1)).
    rewrite <- H2. apply InT_or_app. right. apply InT_eq. assert (InT (Bot) (Γ0 ++ A :: Γ1)).
    apply InT_app_or in H0. destruct H0. apply InT_or_app. auto. apply InT_or_app. right.
    apply InT_cons. assumption. apply InT_split in H1. destruct H1. destruct s. rewrite e.
    assert (BotLRule [] (x ++ Bot :: x0, Δ0 ++ B :: Δ1)).
    apply BotLRule_I. apply BotL in H1.
    pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
    (ps:=[]) (x ++ Bot :: x0, Δ0 ++ B :: Δ1) H1 DersNilF). exists d0.
    simpl. rewrite dersrec_height_nil. lia. reflexivity.
  (* ImpR *)
  * inversion H. subst. apply app2_find_hole in H3. destruct H3. repeat destruct s ; destruct p ; subst.
    + inversion e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
      assert (J1: list_exch_L (Γ2 ++ A0 :: Γ3, Δ2 ++ B0 :: Δ3) (A0 :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3)).
      assert (Γ2 ++ A0 :: Γ3 = [] ++ [] ++ Γ2 ++ [A0] ++ Γ3). reflexivity.
      rewrite H0. clear H0.
      assert (A0 :: Γ0 ++ Γ1 = [] ++ [A0] ++ Γ2 ++ [] ++ Γ3). simpl. rewrite H2. reflexivity.
      rewrite H0. clear H0. apply list_exch_LI.
      assert (J20: derrec_height x0 = derrec_height x0). reflexivity.
      pose (wKS_hpadm_list_exch_L0 x0 J20 J1). destruct s.
      assert (J2: list_exch_L (A0 :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3) (Γ0 ++ A0 :: Γ1, Δ2 ++ B0 :: Δ3)).
      assert ((A0 :: Γ0 ++ Γ1, Δ2 ++ B0 :: Δ3) = ([] ++ [A0] ++ Γ0 ++ [] ++ Γ1, Δ2 ++ B0 :: Δ3)).
      reflexivity. assert ((Γ0 ++ A0 :: Γ1, Δ2 ++ B0 :: Δ3) = ([] ++ [] ++ Γ0 ++ [A0] ++ Γ1, Δ2 ++ B0 :: Δ3)).
      reflexivity. rewrite H1. rewrite H0. clear H1. clear H0. apply list_exch_LI.
      assert (J21: derrec_height x1 = derrec_height x1). reflexivity.
      pose (wKS_hpadm_list_exch_L0 x1 J21 J2). destruct s. exists x2.
      simpl. lia.
    + destruct x.
      { simpl in e0. inversion e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
        assert (J1: list_exch_L (Γ2 ++ A :: Γ3, Δ2 ++ B :: Δ1) (A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ1)).
        assert (Γ2 ++ A :: Γ3 = [] ++ [] ++ Γ2 ++ [A] ++ Γ3). reflexivity.
        rewrite H0. clear H0.
        assert (A :: Γ0 ++ Γ1 = [] ++ [A] ++ Γ2 ++ [] ++ Γ3). simpl. rewrite H2. reflexivity.
        rewrite H0. clear H0. apply list_exch_LI.
        assert (J20: derrec_height x = derrec_height x). reflexivity.
        pose (wKS_hpadm_list_exch_L0 x J20 J1). destruct s.
        assert (J2: list_exch_L (A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ1) (Γ0 ++ A :: Γ1, (Δ2 ++ []) ++ B :: Δ1)).
        assert ((A :: Γ0 ++ Γ1, Δ2 ++ B :: Δ1) = ([] ++ [A] ++ Γ0 ++ [] ++ Γ1, Δ2 ++ B :: Δ1)).
        reflexivity. assert ((Γ0 ++ A :: Γ1, (Δ2 ++ []) ++ B :: Δ1) = ([] ++ [] ++ Γ0 ++ [A] ++ Γ1, Δ2 ++ B :: Δ1)).
        rewrite app_nil_r. reflexivity. rewrite H1. rewrite H0. clear H1. clear H0. apply list_exch_LI.
        assert (J21: derrec_height x0 = derrec_height x0). reflexivity.
        pose (wKS_hpadm_list_exch_L0 x0 J21 J2). destruct s. exists x1.
        simpl. lia. }
      { inversion e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
        assert (J1: list_exch_L (Γ2 ++ A0 :: Γ3, Δ2 ++ B0 :: x ++ A --> B :: Δ1) (A0 :: Γ0 ++ Γ1, Δ2 ++ B0 :: x ++ A --> B :: Δ1)).
        assert (Γ2 ++ A0 :: Γ3 = [] ++ [] ++ Γ2 ++ [A0] ++ Γ3). reflexivity.
        rewrite H0. clear H0.
        assert (A0 :: Γ0 ++ Γ1 = [] ++ [A0] ++ Γ2 ++ [] ++ Γ3). simpl. rewrite H2. reflexivity.
        rewrite H0. clear H0. apply list_exch_LI.
        assert (J20: derrec_height x0 = derrec_height x0). reflexivity.
        pose (wKS_hpadm_list_exch_L0 x0 J20 J1). destruct s. simpl in IH. simpl.
        assert (J2: derrec_height x1 < S (dersrec_height d)). lia.
        assert (J3: derrec_height x1 = derrec_height x1). reflexivity.
        assert (J4: ImpRRule [(A0 :: Γ0 ++ A :: Γ1, Δ2 ++ B0 :: x ++ B :: Δ1)] (A0 :: Γ0 ++ Γ1, Δ2 ++ B0 :: x ++ A --> B :: Δ1)).
        assert (A0 :: Γ0 ++ A :: Γ1 = (A0 :: Γ0) ++ A :: Γ1). reflexivity. rewrite H0. clear H0.
        assert (A0 :: Γ0 ++ Γ1 = (A0 :: Γ0) ++ Γ1). reflexivity. rewrite H0. clear H0.
        assert (Δ2 ++ B0 :: x ++ B :: Δ1 = (Δ2 ++ B0 :: x) ++ B :: Δ1). repeat rewrite <- app_assoc.
        reflexivity. rewrite H0. clear H0.
        assert (Δ2 ++ B0 :: x ++ A --> B :: Δ1 = (Δ2 ++ B0 :: x) ++ A --> B :: Δ1). repeat rewrite <- app_assoc.
        reflexivity. rewrite H0. clear H0. apply ImpRRule_I.
        pose (IH _ J2 _ _ J3). destruct p. pose (s _ J4). clear s0. destruct s1. clear s.
        assert (existsT2 (x3 : derrec wKS_rules (fun _ : Seq => False)
        (Γ0 ++ A :: Γ1, (Δ2 ++ A0 --> B0 :: x) ++ B :: Δ1)), derrec_height x3 <= S (dersrec_height d)).
        assert (ImpRRule [(A0 :: Γ0 ++ A :: Γ1, Δ2 ++ B0 :: x ++ B :: Δ1)] (Γ0 ++ A :: Γ1, (Δ2 ++ A0 --> B0 :: x) ++ B :: Δ1)).
        assert (A0 :: Γ0 ++ A :: Γ1 = [] ++ A0 :: Γ0 ++ A :: Γ1). reflexivity. rewrite H0. clear H0.
        assert (Γ0 ++ A :: Γ1 = [] ++ Γ0 ++ A :: Γ1). reflexivity. rewrite H0. clear H0. repeat rewrite <- app_assoc.
        apply ImpRRule_I. apply ImpR in H0 ; try intro ; try apply f0 ; try auto ; try assumption.
        pose (dlCons x2 DersNilF).
        pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(A0 :: Γ0 ++ A :: Γ1, Δ2 ++ B0 :: x ++ B :: Δ1)]) (Γ0 ++ A :: Γ1, (Δ2 ++ A0 --> B0 :: x) ++ B :: Δ1) H0 d0).
        exists d1. simpl. rewrite dersrec_height_nil. lia. reflexivity.
        destruct X. exists x3. lia. }
    + destruct x.
      { simpl in e0. inversion e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
        assert (J1: list_exch_L (Γ2 ++ A0 :: Γ3, (Δ0 ++ []) ++ B0 :: Δ3) (A0 :: Γ0 ++ Γ1, Δ0 ++ B0 :: Δ3)).
        rewrite app_nil_r.
        assert (Γ2 ++ A0 :: Γ3 = [] ++ [] ++ Γ2 ++ [A0] ++ Γ3). reflexivity.
        rewrite H0. clear H0.
        assert (A0 :: Γ0 ++ Γ1 = [] ++ [A0] ++ Γ2 ++ [] ++ Γ3). simpl. rewrite H2. reflexivity.
        rewrite H0. clear H0. apply list_exch_LI.
        assert (J20: derrec_height x = derrec_height x). reflexivity.
        pose (wKS_hpadm_list_exch_L0 x J20 J1). destruct s.
        assert (J2: list_exch_L (A0 :: Γ0 ++ Γ1, Δ0 ++ B0 :: Δ3) (Γ0 ++ A0 :: Γ1, Δ0 ++ B0 :: Δ3)).
        assert ((A0 :: Γ0 ++ Γ1, Δ0 ++ B0 :: Δ3) = ([] ++ [A0] ++ Γ0 ++ [] ++ Γ1, Δ0 ++ B0 :: Δ3)).
        reflexivity. assert ((Γ0 ++ A0 :: Γ1, Δ0 ++ B0 :: Δ3) = ([] ++ [] ++ Γ0 ++ [A0] ++ Γ1, Δ0 ++ B0 :: Δ3)).
        reflexivity. rewrite H1. rewrite H0. clear H1. clear H0. apply list_exch_LI.
        assert (J21: derrec_height x0 = derrec_height x0). reflexivity.
        pose (wKS_hpadm_list_exch_L0 x0 J21 J2). destruct s. exists x1.
        simpl. lia. }
      { inversion e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s. simpl.
        assert (J1: list_exch_L (Γ2 ++ A0 :: Γ3, (Δ0 ++ A --> B :: x) ++ B0 :: Δ3) (A0 :: Γ0 ++ Γ1, Δ0 ++ A --> B :: x ++ B0 :: Δ3)).
        repeat rewrite <- app_assoc.
        assert (Γ2 ++ A0 :: Γ3 = [] ++ [] ++ Γ2 ++ [A0] ++ Γ3). reflexivity.
        rewrite H0. clear H0.
        assert (A0 :: Γ0 ++ Γ1 = [] ++ [A0] ++ Γ2 ++ [] ++ Γ3). simpl. rewrite H2. reflexivity.
        rewrite H0. clear H0. apply list_exch_LI.
        assert (J20: derrec_height x0 = derrec_height x0). reflexivity.
        pose (wKS_hpadm_list_exch_L0 x0 J20 J1). destruct s. simpl in IH. simpl.
        assert (J2: derrec_height x1 < S (dersrec_height d)). lia.
        assert (J3: derrec_height x1 = derrec_height x1). reflexivity.
        assert (J4: ImpRRule [(A0 :: Γ0 ++ A :: Γ1, Δ0 ++ B :: x ++ B0 :: Δ3)] (A0 :: Γ0 ++ Γ1, Δ0 ++ A --> B :: x ++ B0 :: Δ3)).
        assert (A0 :: Γ0 ++ A :: Γ1 = (A0 :: Γ0) ++ A :: Γ1). reflexivity. rewrite H0. clear H0.
        assert (A0 :: Γ0 ++ Γ1 = (A0 :: Γ0) ++ Γ1). reflexivity. rewrite H0. clear H0.
        apply ImpRRule_I.
        pose (IH _ J2 _ _ J3). destruct p. pose (s _ J4). clear s0. destruct s1. clear s.
        assert (ImpRRule [(A0 :: Γ0 ++ A :: Γ1, Δ0 ++ B :: x ++ B0 :: Δ3)] (Γ0 ++ A :: Γ1, Δ0 ++ B :: x ++ A0 --> B0 :: Δ3)).
        assert (A0 :: Γ0 ++ A :: Γ1 = [] ++ A0 :: Γ0 ++ A :: Γ1). reflexivity. rewrite H0. clear H0.
        assert (Γ0 ++ A :: Γ1 = [] ++ Γ0 ++ A :: Γ1). reflexivity. rewrite H0. clear H0. repeat rewrite <- app_assoc.
        assert (Δ0 ++ B :: x ++ B0 :: Δ3 = (Δ0 ++ B :: x) ++ B0 :: Δ3). rewrite <- app_assoc. reflexivity.
        rewrite H0. clear H0.
        assert (Δ0 ++ B :: x ++ A0 --> B0 :: Δ3 = (Δ0 ++ B :: x) ++ A0 --> B0 :: Δ3). rewrite <- app_assoc. reflexivity.
        rewrite H0. clear H0.
        apply ImpRRule_I. apply ImpR in H0 ; try intro ; try apply f0 ; try auto ; try assumption.
        pose (dlCons x2 DersNilF).
        pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(A0 :: Γ0 ++ A :: Γ1, Δ0 ++ B :: x ++ B0 :: Δ3)]) (Γ0 ++ A :: Γ1, Δ0 ++ B :: x ++ A0 --> B0 :: Δ3) H0 d0).
        exists d1. simpl. rewrite dersrec_height_nil. lia. reflexivity. }
  (* ImpL *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl.
    assert (J1: ImpRRule [(A :: Γ2 ++ B0 :: Γ3, Δ0 ++ B :: Δ1)] (Γ2 ++ B0 :: Γ3, Δ2 ++ Δ3)).
    rewrite H3. assert (A :: Γ2 ++ B0 :: Γ3 = [] ++ A :: Γ2 ++ B0 :: Γ3). reflexivity.
    rewrite H0. clear H0. assert (Γ2 ++ B0 :: Γ3 = [] ++ Γ2 ++ B0 :: Γ3). reflexivity.
    rewrite H0. clear H0. apply ImpRRule_I. simpl in IH.
    assert (J2: derrec_height x0 < S (dersrec_height d)). lia.
    assert (J3: derrec_height x0 = derrec_height x0). reflexivity.
    pose (IH _ J2 _ _ J3). destruct p. clear s0. pose (s _ J1). destruct s0. clear s.
    assert (J7: list_exch_R (Γ2 ++ Γ3, Δ2 ++ A0 :: Δ3) (Γ2 ++ Γ3, A0 :: Δ0 ++ A --> B :: Δ1)).
    rewrite <- H3. assert (Δ2 ++ A0 :: Δ3 = [] ++ [] ++ Δ2 ++ [A0] ++ Δ3). reflexivity.
    rewrite H0. clear H0. assert (A0 :: Δ2 ++ Δ3 = [] ++ [A0] ++ Δ2 ++ [] ++ Δ3). reflexivity.
    rewrite H0. clear H0. apply list_exch_RI.
    assert (J8: derrec_height x = derrec_height x). reflexivity.
    pose (wKS_hpadm_list_exch_R0 x J8 J7). destruct s.
    assert (J4: ImpRRule [(A :: Γ2 ++ Γ3, A0 :: Δ0 ++ B :: Δ1)] (Γ2 ++ Γ3, A0 :: Δ0 ++ A --> B :: Δ1)).
    assert (A :: Γ2 ++ Γ3 = [] ++ A :: Γ2 ++ Γ3). reflexivity.
    rewrite H0. clear H0. assert ((Γ2 ++ Γ3, A0 :: Δ0 ++ A --> B :: Δ1) = ([] ++ Γ2 ++ Γ3, A0 :: Δ0 ++ A --> B :: Δ1)). reflexivity.
    rewrite H0. clear H0. assert (A0 :: Δ0 ++ B :: Δ1 = (A0 :: Δ0) ++ B :: Δ1). reflexivity.
    rewrite H0. clear H0. assert (A0 :: Δ0 ++ A --> B :: Δ1 = (A0 :: Δ0) ++ A --> B :: Δ1). reflexivity.
    rewrite H0. clear H0. apply ImpRRule_I. simpl in IH.
    assert (J5: derrec_height x2 < S (dersrec_height d)). lia.
    assert (J6: derrec_height x2 = derrec_height x2). reflexivity.
    pose (IH _ J5 _ _ J6). destruct p. clear s0. pose (s _ J4). destruct s0. clear s.
    assert (ImpLRule [(A :: Γ2 ++ Γ3, A0 :: Δ0 ++ B :: Δ1); (A :: Γ2 ++ B0 :: Γ3, Δ0 ++ B :: Δ1)]
    (A :: Γ2 ++ A0 --> B0 :: Γ3, Δ0 ++ B :: Δ1)).
    assert (A :: Γ2 ++ Γ3 = (A :: Γ2) ++ Γ3). reflexivity. rewrite H0. clear H0.
    assert (A :: Γ2 ++ B0 :: Γ3 = (A :: Γ2) ++ B0 :: Γ3). reflexivity. rewrite H0. clear H0.
    assert (A :: Γ2 ++ A0 --> B0 :: Γ3 = (A :: Γ2) ++ A0 --> B0 :: Γ3). reflexivity. rewrite H0. clear H0.
    assert (Δ0 ++ B :: Δ1 = [] ++ Δ0 ++ B :: Δ1). reflexivity. rewrite H0. clear H0.
    assert (A0 :: [] ++ Δ0 ++ B :: Δ1 = [] ++ A0 :: Δ0 ++ B :: Δ1). reflexivity. rewrite H0. clear H0.
    apply ImpLRule_I. pose (dlCons x1 DersNilF). pose (dlCons x3 d0).
    apply ImpL in H0.
    pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
    (ps:=[(A :: Γ2 ++ Γ3, A0 :: Δ0 ++ B :: Δ1); (A :: Γ2 ++ B0 :: Γ3, Δ0 ++ B :: Δ1)])
    (A :: Γ2 ++ A0 --> B0 :: Γ3, Δ0 ++ B :: Δ1) H0 d1).
    assert (J40: list_exch_L (A :: Γ2 ++ A0 --> B0 :: Γ3, Δ0 ++ B :: Δ1) (Γ0 ++ A :: Γ1, Δ0 ++ B :: Δ1)).
    rewrite H2. assert (A :: Γ0 ++ Γ1 = [] ++ [A] ++ Γ0 ++ [] ++ Γ1). reflexivity. rewrite H1. clear H1.
    assert (Γ0 ++ A :: Γ1 = [] ++ [] ++ Γ0 ++ [A] ++ Γ1). reflexivity. rewrite H1. clear H1.
    apply list_exch_LI.
    assert (J41: derrec_height d2 = derrec_height d2). reflexivity.
    pose (wKS_hpadm_list_exch_L0 d2 J41 J40). destruct s. exists x4. simpl in J41.
    simpl in l2. rewrite dersrec_height_nil in l2. lia. reflexivity.
  (* wKR *)
  * inversion X. subst.
    assert (wKRRule [(unboxed_list BΓ , [A0])] (Γ0 ++ Γ1, Δ0 ++ Δ1)).
    assert (In (Box A0) (Δ0 ++ Δ1)).
    assert (InT (Box A0) (Δ2 ++ Box A0 :: Δ3)). apply InT_or_app. right. apply InT_eq.
    rewrite H2 in H. apply InT_app_or in H. apply in_or_app. destruct H. apply InT_In in i. auto.
    inversion i. inversion H0. apply InT_In in H0. auto.
    apply in_splitT in H. destruct H. destruct s. rewrite e. apply wKRRule_I ; try assumption.
    simpl. simpl in IH.
    apply wKR in X1.
    assert (dersrec_height d = dersrec_height d). reflexivity.
    pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
    (ps:=[(unboxed_list BΓ, [A0])]) (Γ0 ++ Γ1, Δ0 ++ Δ1) X1 d).
    assert (J1: wkn_L A (Γ0 ++ Γ1, Δ0 ++ Δ1) (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)).
    apply wkn_LI.
    assert (J2: derrec_height d0 = derrec_height d0). reflexivity.
    pose (wKS_wkn_L d0 J2 J1). destruct s.
    assert (J3: wkn_R B (Γ0 ++ A :: Γ1, Δ0 ++ Δ1) (Γ0 ++ A :: Γ1, Δ0 ++ B :: Δ1)).
    apply wkn_RI.
    assert (J4: derrec_height x = derrec_height x). reflexivity.
    pose (wKS_wkn_R x J4 J3). destruct s. exists x0.
    pose (Nat.le_trans _ _ _ l0 l). simpl in l1. assumption. }
{ intros prem1 prem2 RA. inversion RA. subst.
  inversion w ; subst.
  (* IdP *)
  * inversion H. subst. assert (InT # P (Γ0 ++ Γ1)). assert (InT # P (Γ2 ++ # P :: Γ3)).
    apply InT_or_app. right. apply InT_eq. rewrite H2 in H0. apply InT_or_app.
    apply InT_app_or in H0. destruct H0. auto. inversion i. inversion H1.
    auto. assert (InT # P (Γ0 ++ B :: Γ1)).
    apply InT_app_or in H0. apply InT_or_app. destruct H0. auto. right. apply InT_cons.
    assumption. apply InT_split in H1. destruct H1. destruct s. apply InT_split in H0. destruct H0.
    destruct s. rewrite e0. rewrite e. assert (In # P (Δ0 ++ A :: Δ1)). assert (In # P (Δ0 ++ Δ1)).
    rewrite <- H3. apply in_or_app. right. apply in_eq. apply in_app_or in H0. apply in_or_app.
    destruct H0. auto. right. apply in_cons. assumption. apply in_splitT in H0. destruct H0.
    destruct s. rewrite e1.
    assert (IdPRule [] (x1 ++ # P :: x2, x3 ++ # P :: x4)).
    apply IdPRule_I. apply IdP in H0.
    pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
    (ps:=[]) (x1 ++ # P :: x2, x3 ++ # P :: x4) H0 DersNilF). exists d0.
    assert (IdPRule [] (x ++ # P :: x0, Δ0 ++ Δ1)). rewrite <- H3.
    apply IdPRule_I. apply IdP in H1.
    pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
    (ps:=[]) (x ++ # P :: x0, Δ0 ++ Δ1) H1 DersNilF). exists d1.
    simpl. rewrite dersrec_height_nil. split ; lia. reflexivity.
  (* BotL *)
  * inversion H. subst. assert (InT (Bot) (Γ0 ++ Γ1)). assert (InT (Bot) (Γ2 ++ (Bot) :: Γ3)).
    apply InT_or_app. right. apply InT_eq. rewrite H2 in H0. apply InT_app_or in H0.
    apply InT_or_app. destruct H0. auto. inversion i. inversion H1. auto. assert (InT (Bot) (Γ0 ++ B :: Γ1)).
    apply InT_app_or in H0. apply InT_or_app. destruct H0. auto. right. apply InT_cons.
    assumption. apply InT_split in H0. destruct H0. destruct s. apply InT_split in H1. destruct H1.
    destruct s. rewrite e0. rewrite e.
    assert (BotLRule [] (x ++ Bot :: x0, Δ0 ++ A :: Δ1)).
    apply BotLRule_I. apply BotL in H0.
    pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
    (ps:=[]) (x ++ Bot :: x0, Δ0 ++ A :: Δ1) H0 DersNilF). exists d0.
    assert (BotLRule [] (x1 ++ Bot :: x2, Δ0 ++ Δ1)).
    apply BotLRule_I. apply BotL in H1.
    pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
    (ps:=[]) (x1 ++ Bot :: x2, Δ0 ++ Δ1) H1 DersNilF). exists d1.
    simpl. rewrite dersrec_height_nil. split ; lia. reflexivity.
  (* ImpR *)
  * inversion H. subst. simpl in IH.
    assert (J0: (dersrec_height d) = (dersrec_height d)). reflexivity.
    pose (dersrec_derrec_height d J0). destruct s.
    apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
    + assert (ImpLRule [(Γ2 ++ A0 :: Γ1, A :: Δ2 ++ B0 :: Δ3) ; (Γ2 ++ A0 :: B :: Γ1, Δ2 ++ B0 :: Δ3)]
      (Γ2 ++ A0 :: A --> B :: Γ1, Δ2 ++ B0 :: Δ3)). assert (Γ2 ++ A0 :: Γ1 = (Γ2 ++ [A0]) ++ Γ1).
      rewrite <- app_assoc. reflexivity. rewrite H0. clear H0.
      assert (Γ2 ++ A0 :: B :: Γ1 = (Γ2 ++ [A0]) ++ B :: Γ1). rewrite <- app_assoc. reflexivity.
      rewrite H0. clear H0. assert (Γ2 ++ A0 :: A --> B :: Γ1 = (Γ2 ++ [A0]) ++ A --> B :: Γ1). rewrite <- app_assoc. reflexivity.
      rewrite H0. clear H0. assert (Δ2 ++ B0 :: Δ3 = [] ++ Δ2 ++ B0 :: Δ3).
      reflexivity. rewrite H0. clear H0. assert (A :: [] ++ Δ2 ++ B0 :: Δ3 = [] ++ A :: Δ2 ++ B0 :: Δ3).
      reflexivity. rewrite H0. clear H0. apply ImpLRule_I.
      assert (J1: derrec_height x  < S (dersrec_height d)). lia.
      assert (J2: derrec_height x = derrec_height x). reflexivity.
      pose (IH (derrec_height x) J1 _ x J2). destruct p. clear s.
      pose (s0 _ _ H0). repeat destruct s. clear s0. destruct p.
      assert (ImpRRule [(Γ2 ++ A0 :: Γ1, A :: Δ2 ++ B0 :: Δ3)] (Γ2 ++ Γ1, A :: Δ0 ++ Δ1)).
      rewrite <- H3. assert (A :: Δ2 ++ B0 :: Δ3 = (A :: Δ2) ++ B0 :: Δ3). reflexivity.
      rewrite H1. clear H1. assert (A :: Δ2 ++ A0 --> B0 :: Δ3 = (A :: Δ2) ++ A0 --> B0 :: Δ3). reflexivity.
      rewrite H1. clear H1. apply ImpRRule_I.
      assert (existsT2 (x3: derrec wKS_rules (fun _ : Seq => False)
      (Γ2 ++ Γ1, A :: Δ0 ++ Δ1)), derrec_height x3 <= S (dersrec_height d)).
      apply ImpR in H1.
      pose (dlCons x1 DersNilF). pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ2 ++ A0 :: Γ1, A :: Δ2 ++ B0 :: Δ3)]) (Γ2 ++ Γ1, A :: Δ0 ++ Δ1) H1 d0).
      exists d1. simpl. rewrite dersrec_height_nil. lia. reflexivity.
      destruct X.
      assert (J3: derrec_height x3 = derrec_height x3). reflexivity.
      assert (J4: list_exch_R (Γ2 ++ Γ1, A :: Δ0 ++ Δ1) (Γ2 ++ Γ1, Δ0 ++ A :: Δ1)).
      assert (A :: Δ0 ++ Δ1 = [] ++ [A] ++ Δ0 ++ [] ++ Δ1). reflexivity. rewrite H2. clear H2.
      assert (Δ0 ++ A :: Δ1 = [] ++ [] ++ Δ0 ++ [A] ++ Δ1). reflexivity. rewrite H2. clear H2.
      apply list_exch_RI. pose (wKS_hpadm_list_exch_R0 x3 J3 J4). destruct s. exists x4.
      assert (ImpRRule [(Γ2 ++ A0 :: B :: Γ1, Δ2 ++ B0 :: Δ3)] (Γ2 ++ B :: Γ1, Δ0 ++ Δ1)).
      rewrite <- H3. apply ImpRRule_I.
      assert (existsT2 (x3: derrec wKS_rules (fun _ : Seq => False)
      (Γ2 ++ B :: Γ1, Δ0 ++ Δ1)), derrec_height x3 <= S (dersrec_height d)).
      apply ImpR in H2.
      pose (dlCons x2 DersNilF). pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ2 ++ A0 :: B :: Γ1, Δ2 ++ B0 :: Δ3)]) (Γ2 ++ B :: Γ1, Δ0 ++ Δ1) H2 d0).
      exists d1. simpl. rewrite dersrec_height_nil. lia. reflexivity.
      destruct X. exists x5. simpl. split. lia. lia.
    + assert (ImpLRule [(Γ2 ++ A0 :: x0 ++ Γ1, A :: Δ2 ++ B0 :: Δ3) ; (Γ2 ++ A0 :: x0 ++ B :: Γ1, Δ2 ++ B0 :: Δ3)]
      (Γ2 ++ A0 :: x0 ++ A --> B :: Γ1, Δ2 ++ B0 :: Δ3)). assert (Γ2 ++ A0 :: x0 ++ Γ1 = (Γ2 ++ A0 :: x0) ++ Γ1).
      rewrite <- app_assoc. reflexivity. rewrite H0. clear H0.
      assert (Γ2 ++ A0 :: x0 ++ B :: Γ1 = (Γ2 ++ A0 :: x0) ++ B :: Γ1). rewrite <- app_assoc. reflexivity.
      rewrite H0. clear H0. assert (Γ2 ++ A0 :: x0 ++ A --> B :: Γ1 = (Γ2 ++ A0 :: x0) ++ A --> B :: Γ1). rewrite <- app_assoc. reflexivity.
      rewrite H0. clear H0. assert (Δ2 ++ B0 :: Δ3 = [] ++ Δ2 ++ B0 :: Δ3).
      reflexivity. rewrite H0. clear H0. assert (A :: [] ++ Δ2 ++ B0 :: Δ3 = [] ++ A :: Δ2 ++ B0 :: Δ3).
      reflexivity. rewrite H0. clear H0. apply ImpLRule_I.
      assert (J1: derrec_height x  < S (dersrec_height d)). lia.
      assert (J2: derrec_height x = derrec_height x). reflexivity.
      pose (IH (derrec_height x) J1 _ x J2). destruct p. clear s.
      pose (s0 _ _ H0). repeat destruct s. clear s0. destruct p.
      assert (ImpRRule [(Γ2 ++ A0 :: x0 ++ Γ1, A :: Δ2 ++ B0 :: Δ3)] ((Γ2 ++ x0) ++ Γ1, A :: Δ0 ++ Δ1)).
      rewrite <- H3. assert (A :: Δ2 ++ B0 :: Δ3 = (A :: Δ2) ++ B0 :: Δ3). reflexivity.
      rewrite H1. clear H1. assert (A :: Δ2 ++ A0 --> B0 :: Δ3 = (A :: Δ2) ++ A0 --> B0 :: Δ3). reflexivity.
      rewrite H1. clear H1. rewrite <- app_assoc. apply ImpRRule_I.
      assert (existsT2 (x3: derrec wKS_rules (fun _ : Seq => False)
      ((Γ2 ++ x0) ++ Γ1, A :: Δ0 ++ Δ1)), derrec_height x3 <= S (dersrec_height d)).
      apply ImpR in H1.
      pose (dlCons x1 DersNilF). pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ2 ++ A0 :: x0 ++ Γ1, A :: Δ2 ++ B0 :: Δ3)]) ((Γ2 ++ x0) ++ Γ1, A :: Δ0 ++ Δ1) H1 d0).
      exists d1. simpl. rewrite dersrec_height_nil. lia. reflexivity.
      destruct X.
      assert (J3: derrec_height x3 = derrec_height x3). reflexivity.
      assert (J4: list_exch_R ((Γ2 ++ x0) ++ Γ1, A :: Δ0 ++ Δ1) ((Γ2 ++ x0) ++ Γ1, Δ0 ++ A :: Δ1)).
      assert (A :: Δ0 ++ Δ1 = [] ++ [A] ++ Δ0 ++ [] ++ Δ1). reflexivity. rewrite H2. clear H2.
      assert (Δ0 ++ A :: Δ1 = [] ++ [] ++ Δ0 ++ [A] ++ Δ1). reflexivity. rewrite H2. clear H2.
      apply list_exch_RI. pose (wKS_hpadm_list_exch_R0 x3 J3 J4). destruct s. exists x4.
      assert (ImpRRule [(Γ2 ++ A0 :: x0 ++ B :: Γ1, Δ2 ++ B0 :: Δ3)] ((Γ2 ++ x0) ++ B :: Γ1, Δ0 ++ Δ1)).
      rewrite <- H3. rewrite <- app_assoc. apply ImpRRule_I.
      assert (existsT2 (x3: derrec wKS_rules (fun _ : Seq => False)
      ((Γ2 ++ x0) ++ B :: Γ1, Δ0 ++ Δ1)), derrec_height x3 <= S (dersrec_height d)).
      apply ImpR in H2.
      pose (dlCons x2 DersNilF). pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ2 ++ A0 :: x0 ++ B :: Γ1, Δ2 ++ B0 :: Δ3)]) ((Γ2 ++ x0) ++ B :: Γ1, Δ0 ++ Δ1) H2 d0).
      exists d1. simpl. rewrite dersrec_height_nil. lia. reflexivity.
      destruct X. exists x5. simpl. split. lia. lia.
    + destruct x0.
      { simpl in e1. subst. assert (ImpLRule [(Γ0 ++ A0 :: Γ1, A :: Δ2 ++ B0 :: Δ3) ; (Γ0 ++ A0 :: B :: Γ1, Δ2 ++ B0 :: Δ3)]
        ((Γ0 ++ []) ++ A0 :: A --> B :: Γ1, Δ2 ++ B0 :: Δ3)). rewrite app_nil_r. assert (Γ0 ++ A0 :: Γ1 = (Γ0 ++ [A0]) ++ Γ1).
        rewrite <- app_assoc. reflexivity. rewrite H0. clear H0.
        assert (Γ0 ++ A0 :: B :: Γ1 = (Γ0 ++ [A0]) ++ B :: Γ1). rewrite <- app_assoc. reflexivity.
        rewrite H0. clear H0. assert (Γ0 ++ A0 :: A --> B :: Γ1 = (Γ0 ++ [A0]) ++ A --> B :: Γ1). rewrite <- app_assoc. reflexivity.
        rewrite H0. clear H0. assert (Δ2 ++ B0 :: Δ3 = [] ++ Δ2 ++ B0 :: Δ3).
        reflexivity. rewrite H0. clear H0. assert (A :: [] ++ Δ2 ++ B0 :: Δ3 = [] ++ A :: Δ2 ++ B0 :: Δ3).
        reflexivity. rewrite H0. clear H0. apply ImpLRule_I.
        assert (J1: derrec_height x  < S (dersrec_height d)). lia.
        assert (J2: derrec_height x = derrec_height x). reflexivity.
        pose (IH (derrec_height x) J1 _ x J2). destruct p. clear s.
        pose (s0 _ _ H0). repeat destruct s. clear s0. destruct p.
        assert (ImpRRule [(Γ0 ++ A0 :: Γ1, A :: Δ2 ++ B0 :: Δ3)] (Γ0 ++ Γ1, A :: Δ0 ++ Δ1)).
        rewrite <- H3. assert (A :: Δ2 ++ B0 :: Δ3 = (A :: Δ2) ++ B0 :: Δ3). reflexivity.
        rewrite H1. clear H1. assert (A :: Δ2 ++ A0 --> B0 :: Δ3 = (A :: Δ2) ++ A0 --> B0 :: Δ3). reflexivity.
        rewrite H1. clear H1. apply ImpRRule_I.
        assert (existsT2 (x3: derrec wKS_rules (fun _ : Seq => False)
        (Γ0 ++ Γ1, A :: Δ0 ++ Δ1)), derrec_height x3 <= S (dersrec_height d)).
        apply ImpR in H1.
        pose (dlCons x0 DersNilF). pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ0 ++ A0 :: Γ1, A :: Δ2 ++ B0 :: Δ3)]) (Γ0 ++ Γ1, A :: Δ0 ++ Δ1) H1 d0).
        exists d1. simpl. rewrite dersrec_height_nil. lia. reflexivity.
        destruct X.
        assert (J3: derrec_height x2 = derrec_height x2). reflexivity.
        assert (J4: list_exch_R (Γ0 ++ Γ1, A :: Δ0 ++ Δ1) (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)).
        assert (A :: Δ0 ++ Δ1 = [] ++ [A] ++ Δ0 ++ [] ++ Δ1). reflexivity. rewrite H2. clear H2.
        assert (Δ0 ++ A :: Δ1 = [] ++ [] ++ Δ0 ++ [A] ++ Δ1). reflexivity. rewrite H2. clear H2.
        apply list_exch_RI. pose (wKS_hpadm_list_exch_R0 x2 J3 J4). destruct s. exists x3.
        assert (ImpRRule [(Γ0 ++ A0 :: B :: Γ1, Δ2 ++ B0 :: Δ3)] (Γ0 ++ B :: Γ1, Δ0 ++ Δ1)).
        rewrite <- H3. apply ImpRRule_I.
        assert (existsT2 (x3: derrec wKS_rules (fun _ : Seq => False)
        (Γ0 ++ B :: Γ1, Δ0 ++ Δ1)), derrec_height x3 <= S (dersrec_height d)).
        apply ImpR in H2.
        pose (dlCons x1 DersNilF). pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ0 ++ A0 :: B :: Γ1, Δ2 ++ B0 :: Δ3)]) (Γ0 ++ B :: Γ1, Δ0 ++ Δ1) H2 d0).
        exists d1. simpl. rewrite dersrec_height_nil. lia. reflexivity.
        destruct X. exists x4. simpl. split. lia. lia. }
        { inversion e1. subst. assert (ImpLRule [(Γ0 ++ x0 ++ A0 :: Γ3, A :: Δ2 ++ B0 :: Δ3) ; (Γ0 ++ B :: x0 ++ A0 :: Γ3, Δ2 ++ B0 :: Δ3)]
          ((Γ0 ++ A --> B :: x0) ++ A0 :: Γ3, Δ2 ++ B0 :: Δ3)). rewrite <- app_assoc.
          assert (Δ2 ++ B0 :: Δ3 = [] ++ Δ2 ++ B0 :: Δ3). reflexivity. rewrite H0. clear H0.
          assert (A :: [] ++ Δ2 ++ B0 :: Δ3 = [] ++ A :: Δ2 ++ B0 :: Δ3). reflexivity. rewrite H0.
          clear H0. apply ImpLRule_I.
          assert (J1: derrec_height x  < S (dersrec_height d)). lia.
          assert (J2: derrec_height x = derrec_height x). reflexivity.
          pose (IH (derrec_height x) J1 _ x J2). destruct p. clear s.
          pose (s0 _ _ H0). repeat destruct s. clear s0. destruct p.
          assert (ImpRRule [(Γ0 ++ x0 ++ A0 :: Γ3, A :: Δ2 ++ B0 :: Δ3)] (Γ0 ++ x0 ++ Γ3, A :: Δ0 ++ Δ1)).
          rewrite <- H3. assert (A :: Δ2 ++ B0 :: Δ3 = (A :: Δ2) ++ B0 :: Δ3). reflexivity.
          rewrite H1. clear H1. assert (A :: Δ2 ++ A0 --> B0 :: Δ3 = (A :: Δ2) ++ A0 --> B0 :: Δ3). reflexivity.
          rewrite H1. clear H1. assert (Γ0 ++ x0 ++ A0 :: Γ3 = (Γ0 ++ x0) ++ A0 :: Γ3). rewrite <- app_assoc.
          reflexivity. rewrite H1. clear H1. assert (Γ0 ++ x0 ++ Γ3 = (Γ0 ++ x0) ++ Γ3). rewrite <- app_assoc.
          reflexivity. rewrite H1. clear H1. apply ImpRRule_I.
          assert (existsT2 (x3: derrec wKS_rules (fun _ : Seq => False)
          (Γ0 ++ x0 ++ Γ3, A :: Δ0 ++ Δ1)), derrec_height x3 <= S (dersrec_height d)).
          apply ImpR in H1.
          pose (dlCons x1 DersNilF). pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
          (ps:=[(Γ0 ++ x0 ++ A0 :: Γ3, A :: Δ2 ++ B0 :: Δ3)]) (Γ0 ++ x0 ++ Γ3, A :: Δ0 ++ Δ1) H1 d0).
          exists d1. simpl. rewrite dersrec_height_nil. lia. reflexivity.
          destruct X.
          assert (J3: derrec_height x3 = derrec_height x3). reflexivity.
          assert (J4: list_exch_R (Γ0 ++ x0 ++ Γ3, A :: Δ0 ++ Δ1) (Γ0 ++ x0 ++ Γ3, Δ0 ++ A :: Δ1)).
          assert (A :: Δ0 ++ Δ1 = [] ++ [A] ++ Δ0 ++ [] ++ Δ1). reflexivity. rewrite H2. clear H2.
          assert (Δ0 ++ A :: Δ1 = [] ++ [] ++ Δ0 ++ [A] ++ Δ1). reflexivity. rewrite H2. clear H2.
          apply list_exch_RI. pose (wKS_hpadm_list_exch_R0 x3 J3 J4). destruct s. exists x4.
          assert (ImpRRule [(Γ0 ++ B :: x0 ++ A0 :: Γ3, Δ2 ++ B0 :: Δ3)] (Γ0 ++ B :: x0 ++ Γ3, Δ0 ++ Δ1)).
          rewrite <- H3. assert (Γ0 ++ B :: x0 ++ A0 :: Γ3 = (Γ0 ++ B :: x0) ++ A0 :: Γ3). rewrite <- app_assoc.
          reflexivity. rewrite H2. clear H2. assert (Γ0 ++ B :: x0 ++ Γ3 = (Γ0 ++ B :: x0) ++ Γ3). rewrite <- app_assoc.
          reflexivity. rewrite H2. clear H2. apply ImpRRule_I.
          assert (existsT2 (x3: derrec wKS_rules (fun _ : Seq => False)
          (Γ0 ++ B :: x0 ++ Γ3, Δ0 ++ Δ1)), derrec_height x3 <= S (dersrec_height d)).
          apply ImpR in H2.
          pose (dlCons x2 DersNilF). pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
          (ps:=[(Γ0 ++ B :: x0 ++ A0 :: Γ3, Δ2 ++ B0 :: Δ3)]) (Γ0 ++ B :: x0 ++ Γ3, Δ0 ++ Δ1) H2 d0).
          exists d1. simpl. rewrite dersrec_height_nil. lia. reflexivity.
          destruct X. exists x5. simpl. split. lia. lia. }
  (* ImpL *)
  * inversion H. subst.
    apply app2_find_hole in H2. destruct H2. repeat destruct s ; destruct p ; subst.
    + inversion e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
      assert (J1: list_exch_R (Γ2 ++ Γ3, Δ2 ++ A0 :: Δ3) (Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1)).
      assert (Δ2 ++ A0 :: Δ3 = [] ++ [] ++ Δ2 ++ [A0] ++ Δ3). reflexivity.
      rewrite H0. clear H0.
      assert (A0 :: Δ0 ++ Δ1 = [] ++ [A0] ++ Δ2 ++ [] ++ Δ3). simpl. rewrite H3. reflexivity.
      rewrite H0. clear H0. apply list_exch_RI.
      assert (J20: derrec_height x0 = derrec_height x0). reflexivity.
      pose (wKS_hpadm_list_exch_R0 x0 J20 J1). destruct s.
      assert (J2: list_exch_R (Γ2 ++ Γ3, A0 :: Δ0 ++ Δ1) (Γ2 ++ Γ3, Δ0 ++ A0 :: Δ1)).
      assert (A0 :: Δ0 ++ Δ1 = [] ++ [A0] ++ Δ0 ++ [] ++ Δ1).
      reflexivity. assert (Δ0 ++ A0 :: Δ1 = [] ++ [] ++ Δ0 ++ [A0] ++ Δ1).
      reflexivity. rewrite H1. rewrite H0. clear H1. clear H0. apply list_exch_RI.
      assert (J21: derrec_height x2 = derrec_height x2). reflexivity.
      pose (wKS_hpadm_list_exch_R0 x2 J21 J2). destruct s. exists x3.
      assert (existsT2 (x4: derrec wKS_rules (fun _ : Seq => False) (Γ2 ++ B0 :: Γ3, Δ0 ++ Δ1)),
      derrec_height x4 = derrec_height x1). rewrite <- H3. exists x1. reflexivity. destruct X. exists x4. split.
       simpl. lia. simpl. lia.
    + destruct x.
      { simpl in e0. inversion e0. simpl. rewrite app_nil_r. subst.
        assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
        assert (J1: list_exch_R (Γ2 ++ Γ1, Δ2 ++ A :: Δ3) (Γ2 ++ Γ1, A :: Δ0 ++ Δ1)).
        assert (Δ2 ++ A :: Δ3 = [] ++ [] ++ Δ2 ++ [A] ++ Δ3). reflexivity.
        rewrite H0. clear H0.
        assert (A :: Δ0 ++ Δ1 = [] ++ [A] ++ Δ2 ++ [] ++ Δ3). simpl. rewrite H3. reflexivity.
        rewrite H0. clear H0. apply list_exch_RI.
        assert (J20: derrec_height x = derrec_height x). reflexivity.
        pose (wKS_hpadm_list_exch_R0 x J20 J1). destruct s.
        assert (J2: list_exch_R (Γ2 ++ Γ1, A :: Δ0 ++ Δ1) (Γ2 ++ Γ1, Δ0 ++ A :: Δ1)).
        assert (A :: Δ0 ++ Δ1 = [] ++ [A] ++ Δ0 ++ [] ++ Δ1).
        reflexivity. assert (Δ0 ++ A :: Δ1 = [] ++ [] ++ Δ0 ++ [A] ++ Δ1).
        reflexivity. rewrite H1. rewrite H0. clear H1. clear H0. apply list_exch_RI.
        assert (J21: derrec_height x1 = derrec_height x1). reflexivity.
        pose (wKS_hpadm_list_exch_R0 x1 J21 J2). destruct s. exists x2.
        assert (existsT2 (x3: derrec wKS_rules (fun _ : Seq => False) (Γ2 ++ B :: Γ1, Δ0 ++ Δ1)),
        derrec_height x3 = derrec_height x0). rewrite <- H3. exists x0. reflexivity. destruct X. exists x3. split.
        simpl. lia. simpl. lia. }
      { inversion e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
        assert (J1: list_exch_R (Γ2 ++ x ++ A --> B :: Γ1, Δ2 ++ A0 :: Δ3) (Γ2 ++ x ++ A --> B :: Γ1, A0 :: Δ0 ++ Δ1)).
        assert (Δ2 ++ A0 :: Δ3 = [] ++ [] ++ Δ2 ++ [A0] ++ Δ3). reflexivity.
        rewrite H0. clear H0.
        assert (A0 :: Δ0 ++ Δ1 = [] ++ [A0] ++ Δ2 ++ [] ++ Δ3). simpl. rewrite H3. reflexivity.
        rewrite H0. clear H0. apply list_exch_RI.
        assert (J20: derrec_height x0 = derrec_height x0). reflexivity.
        pose (wKS_hpadm_list_exch_R0 x0 J20 J1). destruct s. simpl in IH. simpl.
        assert (J2: derrec_height x2 < S (dersrec_height d)). lia.
        assert (J3: derrec_height x2 = derrec_height x2). reflexivity.
        assert (J4: ImpLRule [(Γ2 ++ x ++ Γ1, A0 :: Δ0 ++ A :: Δ1); (Γ2 ++ x ++ B :: Γ1, A0 :: Δ0 ++ Δ1)]
        (Γ2 ++ x ++ A --> B :: Γ1, A0 :: Δ0 ++ Δ1)).
        assert (A0 :: Δ0 ++ A :: Δ1 = (A0 :: Δ0) ++ A :: Δ1). reflexivity. rewrite H0. clear H0.
        assert (A0 :: Δ0 ++ Δ1 = (A0 :: Δ0) ++ Δ1). reflexivity. rewrite H0. clear H0.
        assert (Γ2 ++ x ++ B :: Γ1 = (Γ2 ++ x) ++ B :: Γ1). repeat rewrite <- app_assoc.
        reflexivity. rewrite H0. clear H0.
        assert (Γ2 ++ x ++ A --> B :: Γ1 = (Γ2 ++ x) ++ A --> B :: Γ1). repeat rewrite <- app_assoc.
        reflexivity. rewrite H0. clear H0.
        assert (Γ2 ++ x ++ Γ1 = (Γ2 ++ x) ++ Γ1). repeat rewrite <- app_assoc.
        reflexivity. rewrite H0. clear H0. apply ImpLRule_I.
        pose (IH _ J2 _ _ J3). destruct p. pose (s0 _ _ J4). clear s. destruct s1. clear s0. destruct s.
        destruct p.
        assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
        assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
        assert (J7: ImpLRule [(Γ2 ++ B0 :: x ++ Γ1, Δ0 ++ A :: Δ1); (Γ2 ++ B0 :: x ++ B :: Γ1, Δ0 ++ Δ1)]
        (Γ2 ++ B0 :: x ++ A --> B :: Γ1, Δ2 ++ Δ3)). rewrite H3.
        assert (Γ2 ++ B0 :: x ++ Γ1 = (Γ2 ++ B0 :: x) ++ Γ1). rewrite <- app_assoc. reflexivity.
        rewrite H0. clear H0.
        assert (Γ2 ++ B0 :: x ++ B :: Γ1 = (Γ2 ++ B0 :: x) ++ B :: Γ1). rewrite <- app_assoc.
        reflexivity. rewrite H0. clear H0.
        assert (Γ2 ++ B0 :: x ++ A --> B :: Γ1 = (Γ2 ++ B0 :: x) ++ A --> B :: Γ1). repeat rewrite <- app_assoc.
        reflexivity. rewrite H0. clear H0. apply ImpLRule_I.
        pose (IH _ J5 _ _ J6). destruct p. pose (s0 _ _ J7). clear s. destruct s1. clear s0. destruct s.
        destruct p.
        assert (existsT2 (x7 : derrec wKS_rules (fun _ : Seq => False)
        ((Γ2 ++ A0 --> B0 :: x) ++ Γ1, Δ0 ++ A :: Δ1)), derrec_height x7 <= S (dersrec_height d)).
        assert (ImpLRule [(Γ2 ++ x ++ Γ1, A0 :: Δ0 ++ A :: Δ1); (Γ2 ++ B0 :: x ++ Γ1, Δ0 ++ A :: Δ1)]
        ((Γ2 ++ A0 --> B0 :: x) ++ Γ1, Δ0 ++ A :: Δ1)). rewrite <- app_assoc.
        assert (A0 :: Δ0 ++ A :: Δ1 = [] ++ A0 :: Δ0 ++ A :: Δ1). reflexivity. rewrite H0. clear H0.
        assert (Δ0 ++ A :: Δ1 = [] ++ Δ0 ++ A :: Δ1). reflexivity. rewrite H0. clear H0. repeat rewrite <- app_assoc.
        apply ImpLRule_I. apply ImpL in H0.
        pose (dlCons x5 DersNilF). pose (dlCons x3 d0).
        pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ2 ++ x ++ Γ1, A0 :: Δ0 ++ A :: Δ1); (Γ2 ++ B0 :: x ++ Γ1, Δ0 ++ A :: Δ1)])
        ((Γ2 ++ A0 --> B0 :: x) ++ Γ1, Δ0 ++ A :: Δ1) H0 d1).
        exists d2. simpl. rewrite dersrec_height_nil. lia. reflexivity.
        destruct X. exists x7.
        assert (existsT2 (x8 : derrec wKS_rules (fun _ : Seq => False)
        ((Γ2 ++ A0 --> B0 :: x) ++ B :: Γ1, Δ0 ++ Δ1)), derrec_height x8 <= S (dersrec_height d)).
        assert (ImpLRule [(Γ2 ++ x ++ B :: Γ1, A0 :: Δ0 ++ Δ1); (Γ2 ++ B0 :: x ++ B :: Γ1, Δ0 ++ Δ1)]
        ((Γ2 ++ A0 --> B0 :: x) ++ B :: Γ1, Δ0 ++ Δ1)). rewrite <- app_assoc.
        assert (Δ0 ++ Δ1 = [] ++ Δ0 ++ Δ1). reflexivity. rewrite H0. clear H0.
        assert (A0 :: [] ++ Δ0 ++ Δ1 = [] ++ A0 :: Δ0 ++ Δ1). reflexivity. rewrite H0. clear H0.
        apply ImpLRule_I. apply ImpL in H0.
        pose (dlCons x6 DersNilF). pose (dlCons x4 d0).
        pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ2 ++ x ++ B :: Γ1, A0 :: Δ0 ++ Δ1); (Γ2 ++ B0 :: x ++ B :: Γ1, Δ0 ++ Δ1)])
        ((Γ2 ++ A0 --> B0 :: x) ++ B :: Γ1, Δ0 ++ Δ1) H0 d1).
        exists d2. simpl. rewrite dersrec_height_nil. lia. reflexivity.
        destruct X. exists x8. split. lia. lia. }
    + destruct x.
      { simpl in e0. inversion e0. simpl. subst.
        assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
        assert (J1: list_exch_R ((Γ0 ++ []) ++ Γ3, Δ2 ++ A0 :: Δ3) (Γ0 ++ Γ3, A0 :: Δ0 ++ Δ1)).
        rewrite app_nil_r.
        assert (Δ2 ++ A0 :: Δ3 = [] ++ [] ++ Δ2 ++ [A0] ++ Δ3). reflexivity.
        rewrite H0. clear H0.
        assert (A0 :: Δ0 ++ Δ1 = [] ++ [A0] ++ Δ2 ++ [] ++ Δ3). simpl. rewrite H3. reflexivity.
        rewrite H0. clear H0. apply list_exch_RI.
        assert (J20: derrec_height x = derrec_height x). reflexivity.
        pose (wKS_hpadm_list_exch_R0 x J20 J1). destruct s.
        assert (J2: list_exch_R (Γ0 ++ Γ3, A0 :: Δ0 ++ Δ1) (Γ0 ++ Γ3, Δ0 ++ A0 :: Δ1)).
        assert (A0 :: Δ0 ++ Δ1 = [] ++ [A0] ++ Δ0 ++ [] ++ Δ1).
        reflexivity. assert (Δ0 ++ A0 :: Δ1 = [] ++ [] ++ Δ0 ++ [A0] ++ Δ1).
        reflexivity. rewrite H1. rewrite H0. clear H1. clear H0. apply list_exch_RI.
        assert (J21: derrec_height x1 = derrec_height x1). reflexivity.
        pose (wKS_hpadm_list_exch_R0 x1 J21 J2). destruct s. exists x2.
        assert (existsT2 (x3: derrec wKS_rules (fun _ : Seq => False) (Γ0 ++ B0 :: Γ3, Δ0 ++ Δ1)),
        derrec_height x3 = derrec_height x0). rewrite <- H3.
        assert (Γ0 ++ B0 :: Γ3 = (Γ0 ++ []) ++ B0 :: Γ3). rewrite app_nil_r. reflexivity.
        rewrite H0. exists x0. reflexivity. destruct X. exists x3. split.
        simpl. lia. simpl. lia. }
      { inversion e0. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
        pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
        assert (J1: list_exch_R ((Γ0 ++ A --> B :: x) ++ Γ3, Δ2 ++ A0 :: Δ3) (Γ0 ++ A --> B :: x ++ Γ3, A0 :: Δ0 ++ Δ1)).
        assert (Δ2 ++ A0 :: Δ3 = [] ++ [] ++ Δ2 ++ [A0] ++ Δ3). reflexivity.
        rewrite H0. clear H0. rewrite <- app_assoc.
        assert (A0 :: Δ0 ++ Δ1 = [] ++ [A0] ++ Δ2 ++ [] ++ Δ3). simpl. rewrite H3. reflexivity.
        rewrite H0. clear H0. apply list_exch_RI.
        assert (J20: derrec_height x0 = derrec_height x0). reflexivity.
        pose (wKS_hpadm_list_exch_R0 x0 J20 J1). destruct s. simpl in IH. simpl.
        assert (J2: derrec_height x2 < S (dersrec_height d)). lia.
        assert (J3: derrec_height x2 = derrec_height x2). reflexivity.
        assert (J4: ImpLRule [(Γ0 ++ x ++ Γ3, A0 :: Δ0 ++ A :: Δ1); (Γ0 ++ B :: x ++ Γ3, A0 :: Δ0 ++ Δ1)]
        (Γ0 ++ A --> B :: x ++ Γ3, A0 :: Δ0 ++ Δ1)).
        assert (A0 :: Δ0 ++ A :: Δ1 = (A0 :: Δ0) ++ A :: Δ1). reflexivity. rewrite H0. clear H0.
        assert (A0 :: Δ0 ++ Δ1 = (A0 :: Δ0) ++ Δ1). reflexivity. rewrite H0. clear H0.
        apply ImpLRule_I.
        pose (IH _ J2 _ _ J3). destruct p. pose (s0 _ _ J4). clear s. destruct s1. clear s0. destruct s.
        destruct p.
        assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
        assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
        assert (J7: ImpLRule [(Γ0 ++ x ++ B0 :: Γ3, Δ0 ++ A :: Δ1); (Γ0 ++ B :: x ++ B0 :: Γ3, Δ0 ++ Δ1)]
        ((Γ0 ++ A --> B :: x) ++ B0 :: Γ3, Δ2 ++ Δ3)). rewrite H3. rewrite <- app_assoc.
        apply ImpLRule_I.  pose (IH _ J5 _ _ J6). destruct p. pose (s0 _ _ J7). clear s.
        destruct s1. clear s0. destruct s. destruct p.
        assert (existsT2 (x7 : derrec wKS_rules (fun _ : Seq => False)
        (Γ0 ++ x ++ A0 --> B0 :: Γ3, Δ0 ++ A :: Δ1)), derrec_height x7 <= S (dersrec_height d)).
        assert (ImpLRule [(Γ0 ++ x ++ Γ3, A0 :: Δ0 ++ A :: Δ1); (Γ0 ++ x ++ B0 :: Γ3, Δ0 ++ A :: Δ1)]
        (Γ0 ++ x ++ A0 --> B0 :: Γ3, Δ0 ++ A :: Δ1)).
        assert (A0 :: Δ0 ++ A :: Δ1 = [] ++ A0 :: Δ0 ++ A :: Δ1). reflexivity. rewrite H0. clear H0.
        assert (Δ0 ++ A :: Δ1 = [] ++ Δ0 ++ A :: Δ1). reflexivity. rewrite H0. clear H0.
        assert (Γ0 ++ x ++ Γ3 = (Γ0 ++ x) ++ Γ3). rewrite <- app_assoc. reflexivity. rewrite H0. clear H0.
        assert (Γ0 ++ x ++ B0 :: Γ3 = (Γ0 ++ x) ++ B0 :: Γ3). rewrite <- app_assoc. reflexivity. rewrite H0. clear H0.
        assert (Γ0 ++ x ++ A0 --> B0 :: Γ3 = (Γ0 ++ x) ++ A0 --> B0 :: Γ3). rewrite <- app_assoc. reflexivity. rewrite H0. clear H0.
        apply ImpLRule_I. apply ImpL in H0.
        pose (dlCons x5 DersNilF). pose (dlCons x3 d0).
        pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ0 ++ x ++ Γ3, A0 :: Δ0 ++ A :: Δ1); (Γ0 ++ x ++ B0 :: Γ3, Δ0 ++ A :: Δ1)])
        (Γ0 ++ x ++ A0 --> B0 :: Γ3, Δ0 ++ A :: Δ1) H0 d1).
        exists d2. simpl. rewrite dersrec_height_nil. lia. reflexivity.
        destruct X. exists x7.
        assert (existsT2 (x8 : derrec wKS_rules (fun _ : Seq => False)
        (Γ0 ++ B :: x ++ A0 --> B0 :: Γ3, Δ0 ++ Δ1)), derrec_height x8 <= S (dersrec_height d)).
        assert (ImpLRule [(Γ0 ++ B :: x ++ Γ3, A0 :: Δ0 ++ Δ1); (Γ0 ++ B :: x ++ B0 :: Γ3, Δ0 ++ Δ1)]
        (Γ0 ++ B :: x ++ A0 --> B0 :: Γ3, Δ0 ++ Δ1)).
        assert (Δ0 ++ Δ1 = [] ++ Δ0 ++ Δ1). reflexivity. rewrite H0. clear H0.
        assert (A0 :: [] ++ Δ0 ++ Δ1 = [] ++ A0 :: Δ0 ++ Δ1). reflexivity. rewrite H0. clear H0.
        assert (Γ0 ++ B :: x ++ Γ3 = (Γ0 ++ B :: x) ++ Γ3). rewrite <- app_assoc. reflexivity. rewrite H0. clear H0.
        assert (Γ0 ++ B :: x ++ B0 :: Γ3 = (Γ0 ++ B :: x) ++ B0 :: Γ3). rewrite <- app_assoc. reflexivity. rewrite H0. clear H0.
        assert (Γ0 ++ B :: x ++ A0 --> B0 :: Γ3 = (Γ0 ++ B :: x) ++ A0 --> B0 :: Γ3). rewrite <- app_assoc. reflexivity. rewrite H0. clear H0.
        apply ImpLRule_I. apply ImpL in H0.
        pose (dlCons x6 DersNilF). pose (dlCons x4 d0).
        pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
        (ps:=[(Γ0 ++ B :: x ++ Γ3, A0 :: Δ0 ++ Δ1); (Γ0 ++ B :: x ++ B0 :: Γ3, Δ0 ++ Δ1)])
        (Γ0 ++ B :: x ++ A0 --> B0 :: Γ3, Δ0 ++ Δ1) H0 d1).
        exists d2. simpl. rewrite dersrec_height_nil. lia. reflexivity.
        destruct X. exists x8. split. lia. lia. }
  (* wKR *)
  * inversion X. subst. pose (univ_gen_ext_splitR _ _ X0). repeat destruct s. repeat destruct p. subst.
    assert (J0: dersrec_height d = dersrec_height d). reflexivity.
    pose (dersrec_derrec_height d J0). destruct s.
    assert (wKRRule [(unboxed_list (x ++ x0), [A0])] (Γ0 ++ Γ1, Δ0 ++ Δ1)).
    rewrite <- H2. apply wKRRule_I ; try assumption. apply univ_gen_ext_combine.
    assumption. apply univ_gen_ext_not_In_delete with (a:=A --> B). intro.
    assert (In (A --> B) (x ++ x0)). apply in_or_app. auto. apply H1 in H0. destruct H0.
    inversion H0. assumption.
    assert (existsT2 (D : derrec wKS_rules (fun _ : Seq => False) (Γ0 ++ Γ1, Δ0 ++ Δ1)),
    derrec_height D <= S (dersrec_height d)).
    apply wKR in X1.
    pose (derI (rules:=wKS_rules) (prems:=fun _ : Seq => False)
    (ps:=[(unboxed_list (x ++ x0), [A0])]) (Γ0 ++ Γ1, Δ0 ++ Δ1) X1 d).
    exists d0. simpl. lia.
    destruct X2.
    assert (J1: derrec_height x2 = derrec_height x2). reflexivity.
    assert (J2: wkn_L B (Γ0 ++ Γ1, Δ0 ++ Δ1) (Γ0 ++ B :: Γ1, Δ0 ++ Δ1)). apply wkn_LI.
    pose (wKS_wkn_L x2 J1 J2). destruct s.
    assert (J3: wkn_R A (Γ0 ++ Γ1, Δ0 ++ Δ1) (Γ0 ++ Γ1, Δ0 ++ A :: Δ1)). apply wkn_RI.
    pose (wKS_wkn_R x2 J1 J3). destruct s. exists x4. exists x3. simpl.
    split ; lia. }
Qed.

Theorem ImpR_inv : forall concl prem, (wKS_prv concl) ->
                                      (ImpRRule [prem] concl) ->
                                      (wKS_prv prem).
Proof.
intros.
assert (J1: derrec_height X = derrec_height X). reflexivity.
pose (ImpR_ImpL_hpinv X J1). destruct p. pose (s _ H). destruct s1. assumption.
Qed.

Theorem ImpL_inv : forall concl prem1 prem2, (wKS_prv concl) ->
                                      (ImpLRule [prem1;prem2] concl) ->
                                      (wKS_prv prem1) *
                                      (wKS_prv prem2).
Proof.
intros.
assert (J1: derrec_height X = derrec_height X). reflexivity.
pose (ImpR_ImpL_hpinv X J1). destruct p. pose (s0 _ _ H). repeat destruct s1. auto.
Qed.