(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Compare.
Require Import XRbase.
Require Import XRfunctions.
Require Import XRseries.
Require Import XPartSum.
Require Import XBinomial.
Require Import Omega.
Local Open Scope XR_scope.

(** TT Ak; 0<=k<=N *)
Fixpoint prod_f_R0 (f:nat -> R) (N:nat) : R :=
  match N with
    | O => f O
    | S p => prod_f_R0 f p * f (S p)
  end.

Notation prod_f_SO := (fun An N => prod_f_R0 (fun n => An (S n)) N).

(**********)
Lemma prod_SO_split :
  forall (An:nat -> R) (n k:nat),
    (k < n)%nat ->
    prod_f_R0 An n =
    prod_f_R0 An k * prod_f_R0 (fun l:nat => An (k +1+l)%nat) (n - k -1).
Proof.
Admitted.

(**********)
Lemma prod_SO_pos :
  forall (An:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> R0 <= An n) -> R0 <= prod_f_R0 An N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; apply H; trivial.
  simpl; apply Rmult_le_pos.
  apply HrecN; intros; apply H; apply le_trans with N;
    [ assumption | apply le_n_Sn ].
  apply H; apply le_n.
Qed.

(**********)
Lemma prod_SO_Rle :
  forall (An Bn:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> R0 <= An n <= Bn n) ->
    prod_f_R0 An N <= prod_f_R0 Bn N.
Proof.
  intros; induction  N as [| N HrecN].
  elim  H with O; trivial.
  simpl; apply Rle_trans with (prod_f_R0 An N * Bn (S N)).
  apply Rmult_le_compat_l.
  apply prod_SO_pos; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
    assumption.
  elim (H (S N) (le_n (S N))); intros; assumption.
  do 2 rewrite <- (Rmult_comm (Bn (S N))); apply Rmult_le_compat_l.
  elim (H (S N) (le_n (S N))); intros.
  apply Rle_trans with (An (S N)); assumption.
  apply HrecN; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
    split; assumption.
Qed.

(** Application to factorial *)
Lemma fact_prodSO :
  forall n:nat, INR (fact n) = prod_f_R0 (fun k:nat =>
     (match (eq_nat_dec k 0) with
          | left   _ => R1
          | right _ => INR k
                        end)) n.
Proof.
  intro; induction  n as [| n Hrecn].
  reflexivity.
  simpl; rewrite <- Hrecn.
  case n; auto with real.
  intros; repeat rewrite plus_INR;rewrite mult_INR.
simpl.
rewrite Rmult_plus_distr_l.
rewrite Rmult_1_r.
rewrite Rplus_comm.
rewrite Rmult_comm.
reflexivity.
Qed.

Lemma le_n_2n : forall n:nat, (n <= 2 * n)%nat.
Proof.
  simple induction n.
  replace (2 * 0)%nat with 0%nat; [ apply le_n | ring ].
  intros; replace (2 * S n0)%nat with (S (S (2 * n0))).
  apply le_n_S; apply le_S; assumption.
  replace (S (S (2 * n0))) with (2 * n0 + 2)%nat; [ idtac | ring ].
  replace (S n0) with (n0 + 1)%nat; [ idtac | ring ].
  ring.
Qed.

(** We prove that (N!)^2<=(2N-k)!*k! forall k in [|O;2N|] *)
Lemma RfactN_fact2N_factk :
  forall N k:nat,
    (k <= 2 * N)%nat ->
    Rsqr (INR (fact N)) <= INR (fact (2 * N - k)) * INR (fact k).
Proof.
  assert (forall (n:nat), R0 <= (if eq_nat_dec n 0 then R1 else INR n)).
  intros; case (eq_nat_dec n 0); auto with real.
  assert (forall (n:nat), (0 < n)%nat ->
     (if eq_nat_dec n 0 then R1 else INR n) = INR n).
  intros n; case (eq_nat_dec n 0); auto with real.
  intros; absurd (0 < n)%nat; omega.
  intros; unfold Rsqr; repeat rewrite fact_prodSO.
  cut ((k=N)%nat \/ (k < N)%nat \/ (N < k)%nat).
  intro H2; elim H2; intro H3.
  rewrite H3; replace (2*N-N)%nat with N.
2:{ omega. }
right.
reflexivity.

  case H3; intro; clear H2 H3.
  rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then R1 else INR l) (2 * N - k) N).
  rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply prod_SO_pos; intros; auto.
  replace (2 * N - k - N-1)%nat with (N - k-1)%nat.
  rewrite Rmult_comm; rewrite (prod_SO_split
        (fun l:nat => if eq_nat_dec l 0 then R1 else INR l) N k).
  apply Rmult_le_compat_l.
  apply prod_SO_pos; intros; auto.
  apply prod_SO_Rle; intros; split; auto.
  rewrite H0.
  rewrite H0.
  apply le_INR; omega.
  omega.
  omega.
  assumption.
  omega.
  omega.
  rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat =>
          if eq_nat_dec l 0 then R1 else INR l) k));
    rewrite (prod_SO_split (fun l:nat =>
          if eq_nat_dec l 0 then R1 else INR l) k N).
  rewrite Rmult_assoc; apply Rmult_le_compat_l.
  apply prod_SO_pos; intros; auto.
  rewrite Rmult_comm;
    rewrite (prod_SO_split (fun l:nat =>
          if eq_nat_dec l 0 then R1 else INR l) N (2 * N - k)).
  apply Rmult_le_compat_l.
  apply prod_SO_pos; intros; auto.
  replace (N - (2 * N - k)-1)%nat with (k - N-1)%nat.
  apply prod_SO_Rle; intros; split; auto.
  rewrite H0.
  rewrite H0.
  apply le_INR; omega.
  omega.
  omega.
  omega.
  omega.
  assumption.
  omega.
Qed.

(**********)
Lemma INR_fact_lt_0 : forall n:nat, R0 < INR (fact n).
Proof.
  intro; apply lt_INR_0; apply neq_O_lt; red; intro;
    elim (fact_neq_0 n); symmetry ; assumption.
Qed.

(** We have the following inequality : (C 2N k) <= (C 2N N) forall k in [|O;2N|] *)
Lemma C_maj : forall N k:nat, (k <= 2 * N)%nat -> C (2 * N) k <= C (2 * N) N.
Proof.
  intros; unfold C; unfold Rdiv; apply Rmult_le_compat_l.
  apply pos_INR.
  replace (2 * N - N)%nat with N.
  apply Rmult_le_reg_l with (INR (fact N) * INR (fact N)).
  apply Rmult_lt_0_compat; apply INR_fact_lt_0.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_comm;
    apply Rmult_le_reg_l with (INR (fact k) * INR (fact (2 * N - k))).
  apply Rmult_lt_0_compat; apply INR_fact_lt_0.
  rewrite Rmult_1_r; rewrite <- mult_INR; rewrite <- Rmult_assoc;
    rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l; rewrite mult_INR; rewrite (Rmult_comm (INR (fact k)));
    replace (INR (fact N) * INR (fact N)) with (Rsqr (INR (fact N))).
  apply RfactN_fact2N_factk.
  assumption.
  reflexivity.
  rewrite mult_INR; apply prod_neq_R0; apply INR_fact_neq_0.
  apply prod_neq_R0; apply INR_fact_neq_0.
  omega.
Qed.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype.

(******************************************************************************)
(* The four colors, with color sum (xor) and comparison:                      *)
(*       color == the finite type of colors, with values Color0 - Color3.     *)
(* palette c0 c1 c2 c3 c == cI when c = colorI; Notation for match c with ... *)
(*     cbit0 c == the lower bit of color c (= true for Color1 and Color3).    *)
(*     cbit1 c == the higher bit of color c (= true for Color2 and Color3).   *)
(* ccons b1 b0 == the Color 2b1 + b0.                                         *)
(*    c1 +c c2 == the bitwise sum of colors c1 and c2.                        *)
(*   edge_perm == a finite type enumerating permutations of nonzero colors.   *)
(*                EpermIJK denotes the permutation mapping Color1 to ColorI,  *)
(*                Color2 to ColorJ, Color3 to ColorK, e.g., Eperm132 swaps    *)
(*                Color2 and Color3, while Eperm123 is the identity.          *)
(*     permc g == coercion of g : edge_perm to a color -> color function.     *)
(* inv_eperm g == the edge_perm inverse of g.                                 *)
(*  edge_rot c == the even edge_perm mapping c to Color1, if c != Color0.     *)
(*      colseq := seq color (a perimeter / edge perimeter coloring).          *)
(* count_cbit1 s == the number of times cbit1 is set in s : colseq.           *)
(* head_color s == the first color in s : colseq, defaulting to Color0.       *)
(*      trace s == the trace (edge coloring) corresponding to a perimeter     *)
(*                 coloring s : colseq; the i'th color in trace s is the      *)
(*                 bitwise sum of colors i and i+1[mod size s] in s.          *)
(*    urtrace s == the right-rotated trace of s (= rotr 1 (trace s)).         *)
(*     ptrace s == the partial trace of s: trace s less its last color, which *)
(*                 is redundant as it is the sum of the other ones.           *)
(*       sumt t == the bitwise sum of all colors in t.                        *)
(*     ctrace t == completes a partial trace t by computing the last color.   *)
(* untrace c0 t == the coloring with head_color c0 and trace t.               *)
(* proper_trace t <=> t does not start with Color0: a trace obtained from a   *)
(*                 proper coloring (one which does not contain identical      *)
(*                 adjacent colors) cannot contain Color0 at all; so we use   *)
(*                 [:: Color0] to signal failure of some trace operations.    *)
(*    permt g t == map g : edge_perm over t : colseq.                         *)
(*      ttail t == the seminormalised tail of a trace t, obtained by mapping  *)
(*                 edge_rot c over behead t, when c = head_color t is not     *)
(*                 Color0, otherwise ttail fails, returning [:: Color0].      *)
(*  even_tail t <=> Color2 appears before Color3 in t.                        *)
(*  even_trace t <=> if t is proper, there is an even permutation of edge     *)
(*                 colors of t where colors appear in the 1, 2, 3 order.      *)
(*  even_perm t == a permutation of Color2-3 that maps t to an even trace.    *)
(*     etrace t == a Color2-3 permutation of t that is even.                  *)
(*      etail t == the normalised, even tail of t: colors appear in order in  *)
(*                 Color1 :: etail t which is an edge color permutation of t. *)
(*    eptrace s == the standardized tail of the partial trace of s.           *)
(*              := etail (ptrace s).                                          *)
(******************************************************************************)

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

Inductive color : predArgType := Color0 | Color1 | Color2 | Color3.

Notation palette c0 c1 c2 c3 := (fun c =>
  match c with Color0 => c0 | Color1 => c1 | Color2 => c2 | Color3 => c3 end).

(* Color comparison and sum; sum is used to compute traces, so it is taken as *)
(* primitive.                                                                 *)

Definition addc : color -> color -> color :=
  palette id (palette Color1 Color0 Color3 Color2)
             (palette Color2 Color3 Color0 Color1)
             (palette Color3 Color2 Color1 Color0).

Notation "c1 '+c' c2" := (addc c1 c2) (at level 50).

Definition eqc (c c' : color) : bool :=
  if c +c c' is Color0 then true else false.

(* Properties of equality, and canonical dataSet.                             *)

Lemma eqcP : Equality.axiom eqc.
Proof. by do 2!case; constructor. Qed.

Canonical color_eqMixin := EqMixin eqcP.
Canonical color_eqType := EqType color color_eqMixin.

Arguments eqcP {c1 c2} : rename.

Lemma eqcE : eqc = eq_op.
Proof. by []. Qed.

(* Algebraic properties of addc. *)

Lemma addcA : associative addc. Proof. by do 3!case. Qed.
Lemma addcC : commutative addc. Proof. by do 2!case. Qed.
Lemma add0c : left_id Color0 addc. Proof. by case. Qed.
Lemma addc0 : right_id Color0 addc. Proof. by case. Qed.
Lemma addcc : self_inverse Color0 addc. Proof. by case. Qed.
Lemma addKc : left_loop id addc. Proof. by do 2!case. Qed.
Lemma addcK : right_loop id addc. Proof. by do 2!case. Qed.
Lemma addcI c : injective (addc c). Proof. exact: can_inj (addKc c). Qed.

Lemma addc_eq0 c1 c2 : (c1 +c c2 == Color0) = (c1 == c2).
Proof. by case: c1; case: c2. Qed.

Arguments addcI c [c1 c2] : rename.

(* Colors as bit vectors *)

Definition cbit0 := palette false true false true.

Definition cbit1 := palette false false true true.

Definition ccons b1 b0 := match b1, b0 with
  | false, false => Color0
  | false, true => Color1
  | true, false => Color2
  | true, true => Color3
  end.

(* Bit properties. *)

Lemma ccons_cbits c : ccons (cbit1 c) (cbit0 c) = c.
Proof. by case: c. Qed.

Lemma cbit1_ccons b1 b0 : cbit1 (ccons b1 b0) = b1.
Proof. by case: b1; case: b0. Qed.

Lemma cbit0_ccons b1 b0 : cbit0 (ccons b1 b0) = b0.
Proof. by case: b1; case: b0. Qed.

Lemma cbit1_addc c1 c2 : cbit1 (c1 +c c2) = cbit1 c1 (+) cbit1 c2.
Proof. by case: c1; case: c2. Qed.

Lemma cbit0_addc c1 c2 : cbit0 (c1 +c c2) = cbit0 c1 (+) cbit0 c2.
Proof. by case: c1; case: c2. Qed.

(* The six "edge" permutations that leave Color0 unchanged. *)

Inductive edge_perm : Set :=
  | Eperm123 : edge_perm
  | Eperm132 : edge_perm
  | Eperm213 : edge_perm
  | Eperm231 : edge_perm
  | Eperm312 : edge_perm
  | Eperm321 : edge_perm.

Definition permc g :=
  match g with
  | Eperm123 => fun c => c
  | Eperm132 => palette Color0 Color1 Color3 Color2
  | Eperm213 => palette Color0 Color2 Color1 Color3
  | Eperm231 => palette Color0 Color2 Color3 Color1
  | Eperm312 => palette Color0 Color3 Color1 Color2
  | Eperm321 => palette Color0 Color3 Color2 Color1
  end.

Coercion permc : edge_perm >-> Funclass.

Definition inv_eperm g :=
  match g with
  | Eperm312 => Eperm231
  | Eperm231 => Eperm312
  | _ => g
  end.

Lemma inv_epermK : involutive inv_eperm.
Proof. by case. Qed.

Lemma inv_permc (g : edge_perm) : cancel g (inv_eperm g).
Proof. by case: g => [] []. Qed.

Lemma permc_inv g : cancel (inv_eperm g) g.
Proof. by case: g => [] []. Qed.

Lemma permc_inj (g : edge_perm) : injective g.
Proof. exact (can_inj (inv_permc g)). Qed.

Lemma permc_addc (g : edge_perm) c1 c2 : g (c1 +c c2) = g c1 +c g c2.
Proof. by case: g; case: c1; case: c2. Qed.

Lemma permc0 (g : edge_perm) : g Color0 = Color0.
Proof. by case: g. Qed.

Lemma color_inj_permc f :
  injective f -> f Color0 = Color0 -> {g : edge_perm | f =1 g}.
Proof.
move/inj_eq=> injf f0; have Ef0 := injf Color0; rewrite f0 in Ef0.
case f1: (f Color1) (Ef0 Color1) (injf Color1) => // _ Ef1;
case f2: (f Color2) (Ef0 Color2) (Ef1 Color2) {injf}(injf Color2) => // _ _ Ef2;
   [ exists Eperm123 | exists Eperm132 | exists Eperm213
   | exists Eperm231 | exists Eperm312 | exists Eperm321] => [] [] //;
 by case: (f Color3) (Ef0 Color3) (Ef1 Color3) (Ef2 Color3).
Qed.

Lemma other_colors c :
  c != Color0 -> pred4 Color0 c (Eperm312 c) (Eperm231 c) =i color.
Proof. by case: c => // _ []. Qed.

(******************************************************************************)
(*   Basic operations on edge traces = pairwise sums of the list of colors on *)
(* a configuration perimeter. Many of these operations use permutations of    *)
(* the non-zero colors, so we introduce an explicit enumeration of these six  *)
(* permutations. A ``proper'' trace, one that begins with a non-zero color,   *)
(* has a ``normal'' tail, obtained by applying the rotation that sends the    *)
(* first color to Color1 to the rest of the trace. A trace is even if Color3  *)
(* does not occur before Color2 in its tail. To cut our work in half, we only *)
(* consider even traces in our algorithm, as the match relation is invariant  *)
(* under swapping Color2 and Color3. The coloring function outputs directly   *)
(* the even trace tail of colorings, so we prove here that this is invariant  *)
(* under permutations of the coloring.                                        *)
(*   Allowing Color0 in traces allows us to carry fewer side conditions in    *)
(* our lemmas, and gives us a convenient ``bad'' value as well.               *)
(*   Finally, we define a completion operation that adds the last ``cyclic''  *)
(* sum to a trace, and prove its basic properties. These will be used with    *)
(* the ``canonical'' match relation.                                          *)
(******************************************************************************)

(* Boolean correctness predicate *)

Definition colseq : predArgType := seq color.
Canonical colseq_eqType := [eqType of colseq].

Definition head_color : colseq -> color := head Color0.

Definition proper_trace et := head_color et != Color0.

(******************************************************************************)
(* Conversion from color lists to traces is done in two steps: compute the    *)
(* pairwise sum to get a partial (linear) trace, then append the last color,  *)
(* which can be computed as the sum of the partial trace, to get a full       *)
(* (cyclic) trace. The trace computation inverse just computes partial sums.  *)
(******************************************************************************)

Definition ptrace (lc : colseq) : colseq :=
  if lc is c :: lc' then pairmap addc c lc' else [::].

Definition permt (g : edge_perm) : colseq -> colseq := map g.

Definition sumt : colseq -> color := foldr addc Color0.

Definition ctrace (et : colseq) : colseq := rcons et (sumt et).

Definition trace (lc : colseq) : colseq :=
  if lc is _ :: _ then ctrace (ptrace lc) else [::].

Definition urtrace (lc : colseq) : colseq := pairmap addc (last Color0 lc) lc.

Definition untrace c0 (et : colseq) : colseq :=
  scanl addc c0 (belast Color0 et).

(* Trace normalization. *)

Definition edge_rot := palette Eperm123 Eperm123 Eperm312 Eperm231.

Definition ttail (et : colseq) : colseq :=
  if proper_trace et then
    if et is c :: et' then permt (edge_rot c) et' else [::]
  else [:: Color0].

Definition even_tail : colseq -> bool :=
  foldr (fun c b => palette b b true false c) true.

Definition even_trace et := even_tail (ttail et).

Definition etrace_perm et := if even_trace et then Eperm123 else Eperm132.

Definition etrace et := permt (etrace_perm et) et.

Definition etail et := permt (etrace_perm et) (ttail et).

Definition eptrace lc := etail (ptrace lc).

(* Counting cbit1, used to validate the initial tree construction.  *)

Definition count_cbit1 : colseq -> nat := foldr (fun c n => cbit1 c + n) 0.

(* Lemmas for edge permutations : the standard iso lemmas, and commutation    *)
(* with addc (proved by brute force).                                         *)

(* Trace permutation. *)

Lemma permt_id et : permt Eperm123 et = et.
Proof. exact: map_id. Qed.

Lemma etrace_id et : permt Eperm132 (permt Eperm132 et) = et.
Proof. exact: (mapK (inv_permc Eperm132)). Qed.

Lemma permc_eq0 (g : edge_perm) c : (g c == Color0) = (c == Color0).
Proof. by case: g; case: c. Qed.

Lemma memc0_permt g et : (Color0 \in permt g et) = (Color0 \in et).
Proof.
by elim: et => [|e et IHet] //=; rewrite !inE IHet !(eq_sym Color0) permc_eq0.
Qed.

Lemma proper_permt g et : proper_trace (permt g et) = proper_trace et.
Proof. by case: g; case: et => // [[]]. Qed.

Lemma memc0_ttail et :
  (Color0 \in ttail et) = ~~ proper_trace et || (Color0 \in et).
Proof. by case: et => [|[] et]; rewrite /ttail //= memc0_permt. Qed.

(* Even and tail permutations. *)

Lemma even_etail et : even_tail (etail et).
Proof.
rewrite /etail /etrace_perm; case: ifP; first by rewrite permt_id.
by rewrite /even_trace; elim: (ttail et) => [|[]].
Qed.

Lemma ttail_etrace et : ttail (etrace et) = etail et.
Proof.
rewrite /etail /etrace /etrace_perm /ttail proper_permt.
case: (even_trace et); first by rewrite !permt_id.
by case: et => [|[] ?] //=; rewrite -2![permt _ _]map_comp; apply: eq_map; case.
Qed.

Lemma even_etrace et : even_trace (etrace et).
Proof. by rewrite /even_trace ttail_etrace even_etail. Qed.

Lemma compose_permt g g' et : {h | permt h et = permt g (permt g' et)}.
Proof.
have inj_gg': injective (g \o g') by apply: inj_comp; apply: permc_inj.
have [|h Dh] := color_inj_permc inj_gg'; first by rewrite /= !permc0.
by rewrite -[permt g _]map_comp; exists h; apply/esym/eq_map.
Qed.

Lemma etail_perm et : proper_trace et -> {g | permt g et = Color1 :: etail et}.
Proof.
rewrite -ttail_etrace /ttail /etrace; move: (etrace_perm et) => h.
rewrite -(proper_permt h) => et_ok; rewrite et_ok.
case Dhet: (permt h et) => //= [e het'] in et_ok *.
have [g Dget] := (compose_permt (edge_rot e) h et); exists g.
by rewrite {}Dget {}Dhet; case: e in et_ok *.
Qed.

Lemma etail_permt g et : etail (permt g et) = etail et.
Proof.
case et_ok: (proper_trace et); last first.
  by rewrite /etail /ttail proper_permt et_ok /= 2!permc0.
have get_ok: proper_trace (permt g et) by rewrite proper_permt.
have{et_ok get_ok} [[h Dhet] [h']] := (etail_perm et_ok, etail_perm get_ok).
have [g' <-{h'} Dg'et] := compose_permt h' g et.
have [g'' Eg''] := compose_permt g' (inv_eperm h) (permt h et).
rewrite {4}/permt (mapK (inv_permc h)) {g'}Dg'et {h}Dhet /= in Eg''.
case: Eg'' (even_etail et) (even_etail (permt g et)) => g''1 <-.
case: g'' g''1 => // _; first by rewrite permt_id.
by elim: {et}(etail et) => [|[] et IHet] //= *; rewrite IHet.
Qed.

(* Perimeter-trace equations. *)

Lemma ptrace_addc c (lc : colseq) : ptrace (map (addc c) lc) = ptrace lc.
Proof.
rewrite /ptrace; case: lc => //= c' lc; elim: lc c' => //= c'' lc IHlc c'.
by rewrite (addcC c) -addcA addKc IHlc.
Qed.

Lemma ptrace_permt g lc : ptrace (permt g lc) = permt g (ptrace lc).
Proof.
rewrite /ptrace; case: lc => //= c lc; elim: lc c => //= c' lc IHlc c.
by rewrite IHlc permc_addc.
Qed.

Lemma eptrace_inj lc f : injective f -> eptrace (map f lc) = eptrace lc.
Proof.
move=> injf; rewrite /eptrace -(ptrace_addc (f Color0)) -map_comp.
have injf': injective (addc (f Color0) \o f) := inj_comp (addcI _) injf.
have [|g /eq_map->] := color_inj_permc injf'; first by rewrite /= addcc.
by rewrite ptrace_permt etail_permt.
Qed.

(* Properties of the trace completion. *)

Lemma sumt_ctrace et : sumt (ctrace et) = Color0.
Proof.
rewrite /ctrace -(add0c (sumt et)).
elim: et Color0 => [|e et IHet] c /=; first by rewrite 2!addc0.
by rewrite addcA IHet (addcC c e) addKc.
Qed.

Lemma memc0_ctrace et :
  (Color0 \in ctrace et) = (sumt et == Color0) || (Color0 \in et).
Proof. by rewrite mem_rcons eq_sym. Qed.

Lemma proper_ctrace et : proper_trace (ctrace et) = proper_trace et.
Proof. by case: et => [|[]]. Qed.

Lemma sumt_permt g et : sumt (permt g et) = g (sumt et).
Proof. by elim: et => /= [|e et ->]; rewrite (permc0, permc_addc). Qed.

Lemma ctrace_permt g et : ctrace (permt g et) = permt g (ctrace et).
Proof. by rewrite /ctrace sumt_permt -map_rcons. Qed.

Lemma even_ctrace et : even_trace (ctrace et) = even_trace et.
Proof.
case: et => // e et; rewrite /ctrace /even_trace /ttail /proper_trace /=.
case: ifP => //= _; move Dg: (edge_rot e) => g.
have{Dg}: cbit1 (g e) = false by rewrite -Dg; case e.
elim: et e => [|e' et IHet] e /= ge1; first by rewrite addc0; case: (g e) ge1.
by case Dge': (g e'); rewrite //= addcA IHet // permc_addc cbit1_addc ge1 Dge'.
Qed.

Lemma ctrace_inj : injective ctrace.
Proof.
move=> et0 et0'; rewrite /ctrace; move: {-2}et0 {-2}et0'.
by elim=> [|c et IHet] [|c' et'] //; [case et' | case et | case=> -> /IHet->].
Qed.

(* Properties of the full (cyclic) trace. *)

Lemma trace_permt g lc : trace (permt g lc) = permt g (trace lc).
Proof. by case: lc => // c lc; rewrite /trace -ctrace_permt -ptrace_permt. Qed.

Lemma size_trace lc : size (trace lc) = size lc.
Proof.
by case: lc => // *; rewrite /trace /ctrace /ptrace /= size_rcons size_pairmap.
Qed.

Lemma trace_untrace c0 et : sumt et = Color0 -> trace (untrace c0 et) = et.
Proof.
case: et => // e1 et sum_et; rewrite /untrace /= /ptrace /= (scanlK addKc).
rewrite /ctrace lastI -[last e1 et]add0c -{}sum_et; congr (rcons _ _).
by elim: et e1 => [|e2 et IHet] e1 /=; rewrite -addcA ?addcc ?IHet.
Qed.

Lemma sumt_trace lc : sumt (trace lc) = Color0.
Proof. by case: lc => // c lc; rewrite sumt_ctrace. Qed.

Lemma untrace_trace c0 lc : untrace c0 (trace (c0 :: lc)) = c0 :: lc.
Proof. by rewrite /untrace /ctrace belast_rcons /= addc0 (pairmapK addKc). Qed.

Lemma trace_addc c lc : trace (map (addc c) lc) = trace lc.
Proof.
by case: lc => //= c0 lc; rewrite [pairmap _ _ _](ptrace_addc _ (_ :: _)).
Qed.

Lemma trace_cons c lc : trace (c :: lc) = pairmap addc c (rcons lc c).
Proof.
rewrite /trace /ptrace /ctrace /= -[sumt _](addKc c).
elim: lc {-2 6}c => [|c2 lc IHlc] c1 /=; first by rewrite addc0 addcC.
by rewrite -!addcA addKc IHlc.
Qed.

Lemma trace_rcons c (lc : colseq) :
  trace (rcons lc c) = if trace (c :: lc) is e :: et then rcons et e else lc.
Proof.
case: lc => // c1 lc; rewrite rcons_cons !trace_cons /=.
by elim: lc {1 3}c1 => //= c3 lc IHlc c2; rewrite IHlc.
Qed.

Lemma urtrace_trace (lc : colseq) : urtrace (rot 1 lc) = trace lc.
Proof.
case: lc => [|c1 [|c2 lc]]; rewrite /urtrace /rot //= ?addcc // last_cat /=.
rewrite /ctrace /= cats1 -addcA; congr (_ :: _).
elim: lc c2 => [|c3 lc IHlc] c2 /=; first by rewrite addc0 addcC.
by rewrite -addcA addKc -IHlc.
Qed.

Lemma urtrace_rot (lc : colseq) : urtrace (rot 1 lc) = rot 1 (urtrace lc).
Proof.
case: lc => [|c1 [|c2 lc]]; rewrite /urtrace /rot //= last_cat /= !cats1.
by congr (_ :: _); elim: lc c2 => //= c3 lc IHlc c2; rewrite IHlc.
Qed.

Lemma trace_rot n (lc : colseq) : trace (rot n lc) = rot n (trace lc).
Proof.
elim: n => [|n IHn]; first by rewrite !rot0.
have [le_le_c | lt_n_le] := leqP (size lc) n.
  by rewrite !rot_oversize ?size_trace // ltnW.
by rewrite -add1n !rotD ?size_trace // -IHn -!urtrace_trace -urtrace_rot.
Qed.

Lemma trace_rev (lc : colseq) : trace (rev lc) = rot 1 (rev (trace lc)).
Proof.
case: lc => // c0 lc; rewrite -!urtrace_trace !urtrace_rot; congr (rot 1 _).
elim/last_ind: lc => // lc c /(congr1 behead).
case/lastP: lc => [|lc c']; first by rewrite /urtrace /= (addcC c).
rewrite -!rcons_cons !rev_rcons -2!rot1_cons !urtrace_rot -urtrace_rot.
do 2!rewrite /urtrace /= ?rot1_cons /=; rewrite !rev_rcons /= => <-.
by rewrite rev_cons cats1 !last_rcons !(addcC c).
Qed.


Require Import List.
Export ListNotations.

Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import Prop_Bi_Int_calcs.
Require Import Prop_Bi_Int_logics.
Require Import Prop_Bi_Int_extens_interactions.
Require Import Prop_wBi_Int_meta_interactions.

Lemma sThm_irrel : forall A B Γ, sBIC_rules (Γ, A → (B → A)).
Proof.
intros. apply sBIC_extens_wBIC. apply wThm_irrel.
Qed.

Lemma simp_Id_gen : forall A Γ, sBIC_rules (Γ, A → A).
Proof.
intros. apply sBIC_extens_wBIC. apply wimp_Id_gen.
Qed.

Lemma scomm_And_obj : forall A B Γ, (sBIC_rules (Γ, And A B → And B A)).
Proof.
intros. apply sBIC_extens_wBIC. apply comm_And_obj.
Qed.

Lemma sContr_Bot : forall A Γ, sBIC_rules (Γ, And A (Neg A) → (Bot V)).
Proof.
intros. apply sBIC_extens_wBIC. apply wContr_Bot.
Qed.

Lemma sEFQ : forall A Γ, sBIC_rules (Γ, (Bot V) → A).
Proof.
intros. apply sBIC_extens_wBIC. apply wEFQ.
Qed.

Lemma smonotR_Or : forall A B Γ, (sBIC_rules (Γ, A → B)) ->
    (forall C, sBIC_rules (Γ, (Or A C) → (Or B C))).
Proof.
intros A B Γ D C.
apply MPs with (ps:=[(Γ, (C → Or B C) → (Or A C → Or B C));(Γ,(C → Or B C))]).
2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, (A → Or B C) → (C → Or B C) → (Or A C → Or B C));(Γ,(A → Or B C))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists A. exists C.
exists (Or B C). auto. inversion H1. subst.
apply MPs with (ps:=[(Γ, (B → Or B C) → (A → Or B C));(Γ,((B → Or B C)))]).
2: apply MPRule_I. intros. inversion H2. subst.
apply MPs with (ps:=[(Γ, (A → B) → (B → Or B C) → (A → Or B C));(Γ,(A → B))]).
2: apply MPRule_I. intros. inversion H3. subst. apply Axs.
apply AxRule_I. apply RA1_I. exists A. exists B. exists (Or B C). auto.
inversion H4. subst. assumption. inversion H5. inversion H3. subst. apply Axs.
apply AxRule_I. apply RA2_I. exists B. exists C.
auto. inversion H4. inversion H2. inversion H0. subst.
apply Axs. apply AxRule_I. apply RA3_I.
exists B. exists C. auto. inversion H1.
Qed.

Lemma smonotL_Or : forall A B Γ,
    (sBIC_rules (Γ, A → B)) ->
    (forall C, sBIC_rules (Γ, (Or C A) → (Or C B))).
Proof.
intros A B Γ D C.
apply MPs with (ps:=[(Γ, (A → Or C B) → ((Or C A) → (Or C B)));(Γ,(A → Or C B))]).
2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, (C → Or C B) → (A → Or C B) → ((Or C A) → (Or C B)));(Γ,(C → Or C B))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists C. exists A.
exists (Or C B). auto. inversion H1. subst. apply Axs.
apply AxRule_I. apply RA2_I. exists C. exists B.
auto. inversion H2. inversion H0. subst.
apply MPs with (ps:=[(Γ, (B → Or C B) → (A → Or C B));(Γ,((B → Or C B)))]).
2: apply MPRule_I. intros. inversion H1. subst.
apply MPs with (ps:=[(Γ, (A → B) → (B → Or C B) → (A → Or C B));(Γ,(A → B))]).
2: apply MPRule_I. intros. inversion H2. subst. apply Axs.
apply AxRule_I. apply RA1_I. exists A. exists B. exists (Or C B). auto.
inversion H3. subst. assumption. inversion H4. inversion H2. subst. apply Axs.
apply AxRule_I. apply RA3_I. exists C. exists B.
auto. inversion H3. inversion H1.
Qed.

Lemma scomm_Or_obj : forall A B Γ, (sBIC_rules (Γ, Or A B → Or B A)).
Proof.
intros. apply sBIC_extens_wBIC. apply comm_Or_obj.
Qed.

Lemma scomm_Or : forall A B Γ,
    (sBIC_rules (Γ, Or A B)) ->
    (sBIC_rules (Γ, Or B A)).
Proof.
intros A B Γ D.
apply MPs with (ps:=[(Γ, Or A B → Or B A);(Γ, Or A B)]).
2: apply MPRule_I. intros. inversion H. subst.
apply scomm_Or_obj. inversion H0. subst. assumption.
inversion H1.
Qed.

Lemma smonot_Or2 : forall A B Γ,
    (sBIC_rules (Γ, A → B)) ->
    (forall C, sBIC_rules (Γ, (Or A C) → (Or C B))).
Proof.
intros A B Γ D C.
apply MPs with (ps:=[(Γ, (C → Or C B) → (Or A C → Or C B));(Γ, C → Or C B)]).
2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, (A → Or C B) → (C → Or C B) → (Or A C → Or C B));(Γ, A → Or C B)]).
2: apply MPRule_I. intros. inversion H0. subst. apply Axs.
apply AxRule_I. apply RA4_I. exists A. exists C. exists (Or C B). auto.
inversion H1. subst.
apply MPs with (ps:=[(Γ, (B → Or C B) → (A → Or C B));(Γ, B → Or C B)]).
2: apply MPRule_I. intros. inversion H2. subst.
apply MPs with (ps:=[(Γ, (A → B) → (B → Or C B) → (A → Or C B));(Γ, A → B)]).
2: apply MPRule_I. intros. inversion H3. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists A. exists B. exists (Or C B).
auto. inversion H4. subst. assumption. inversion H5. inversion H3. subst.
apply Axs. apply AxRule_I. apply RA3_I. exists C. exists B. auto.
inversion H4. inversion H2. inversion H0. subst. apply Axs. apply AxRule_I.
apply RA2_I. exists C. exists B. auto. inversion H1.
Qed.

Lemma sabsorp_Or1 : forall A Γ,
    (sBIC_rules (Γ, Or A (Bot V))) ->
    (sBIC_rules (Γ, A)).
Proof.
intros A Γ D.
apply MPs with (ps:=[(Γ, Imp (Or A (Bot V)) A);(Γ, Or A (Bot V))]).
2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, (Bot V → A) → (Or A (Bot V) → A));(Γ, (Bot V → A))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Γ, (A → A) → (Bot V → A) → (Or A (Bot V) → A));(Γ, A → A)]).
2: apply MPRule_I. intros. inversion H1. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists A. exists (Bot V).
exists A. auto. inversion H2. subst. apply simp_Id_gen.
inversion H3. inversion H1. subst. apply sEFQ. inversion H2.
inversion H0. subst. assumption. inversion H1.
Qed.

Theorem sdual_residuation_gen : forall A B C Γ,
  (sBIC_rules (Γ, (Excl A B) → C) ->
      sBIC_rules (Γ, A → (Or B C))) *
  (sBIC_rules (Γ, A → (Or B C)) ->
      sBIC_rules (Γ, (Excl A B) → C)).
Proof.
intros A B C Γ. split.
- intro D. pose (@smonot_Or2 (Excl A B) C Γ D B).
  apply MPs with (ps:=[(Γ, (Or (Excl A B) B → Or B C) → (A → Or B C));(Γ,Or (Excl A B) B → Or B C)]).
  2: apply MPRule_I. intros. inversion H. subst.
  apply MPs with (ps:=[(Γ, (A → Or (Excl A B) B) → (Or (Excl A B) B → Or B C) → (A → Or B C));(Γ,(A → Or (Excl A B) B))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Axs.
  apply AxRule_I. apply RA1_I. exists A. exists (Or (Excl A B) B). exists (Or B C). auto.
  inversion H1. subst.
  apply MPs with (ps:=[(Γ, (Or B (Excl A B) → Or (Excl A B) B) → (A → Or (Excl A B) B));(Γ,(Or B (Excl A B) → Or (Excl A B) B))]).
  2: apply MPRule_I. intros. inversion H2. subst.
  apply MPs with (ps:=[(Γ, (A → Or B (Excl A B)) → (Or B (Excl A B) → Or (Excl A B) B) → (A → Or (Excl A B) B));(Γ,(A → Or B (Excl A B)))]).
  2: apply MPRule_I. intros. inversion H3. subst. apply Axs.
  apply AxRule_I. apply RA1_I. exists A. exists (Or B (Excl A B)). exists (Or (Excl A B) B).
  auto. inversion H4. subst.
  apply Axs. apply AxRule_I. apply RA11_I. exists A. exists B. auto. inversion H5.
  inversion H3. subst. apply scomm_Or_obj. inversion H4. inversion H2.
  inversion H0. subst. assumption. inversion H1.
- intro D. apply MPs with (ps:=[(Γ, ((Or C (Excl A (Or B C))) → C) → (Excl A B → C));(Γ, (Or C (Excl A (Or B C))) → C)]).
  2: apply MPRule_I. intros. inversion H. subst.
  apply MPs with (ps:=[(Γ, (Excl A B → (Or C (Excl A (Or B C)))) → ((Or C (Excl A (Or B C))) → C) → (Excl A B → C));(Γ, Excl A B → (Or C (Excl A (Or B C))))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Axs. apply AxRule_I. apply RA1_I.
  exists (Excl A B). exists (Or C (Excl A (Or B C))). exists C. auto. inversion H1. subst.
  apply MPs with (ps:=[(Γ, ((Or C (Excl (Excl A B) C)) → Or C (Excl A (Or B C))) → (Excl A B → Or C (Excl A (Or B C))));(Γ, ((Or C (Excl (Excl A B) C)) → Or C (Excl A (Or B C))))]).
  2: apply MPRule_I. intros. inversion H2. subst.
  apply MPs with (ps:=[(Γ, (Excl A B → (Or C (Excl (Excl A B) C)))→ ((Or C (Excl (Excl A B) C)) → Or C (Excl A (Or B C))) → (Excl A B → Or C (Excl A (Or B C))));
  (Γ, (Excl A B → (Or C (Excl (Excl A B) C))))]).
  2: apply MPRule_I. intros. inversion H3. subst.
  apply Axs. apply AxRule_I. apply RA1_I. exists (Excl A B). exists (Or C (Excl (Excl A B) C)).
  exists (Or C (Excl A (Or B C))). auto. inversion H4. subst.
  apply Axs. apply AxRule_I. apply RA11_I. exists (Excl A B). exists C. auto. inversion H5.
  inversion H3. subst. apply smonotL_Or. apply Axs. apply AxRule_I. apply RA13_I.
  exists A. exists B. exists C. auto. inversion H4. inversion H2. inversion H0. subst.
  apply MPs with (ps:=[(Γ, (Or C (Bot _) → C) → (Or C (Excl A (Or B C)) → C));
  (Γ, (Or C (Bot _) → C))]). 2: apply MPRule_I. intros. inversion H1. subst.
  apply MPs with (ps:=[(Γ, (Or C (Excl A (Or B C)) → Or C (Bot _)) → (Or C (Bot _) → C) → (Or C (Excl A (Or B C)) → C));
  (Γ, (Or C (Excl A (Or B C)) → Or C (Bot _)))]). 2: apply MPRule_I. intros. inversion H2. subst.
  apply Axs. apply AxRule_I. apply RA1_I. exists (Or C (Excl A (Or B C))).
  exists (Or C (Bot V)). exists C. auto. inversion H3. subst. apply smonotL_Or.
  apply MPs with (ps:=[(Γ, ((And (wNeg (A → Or B C)) (Neg (wNeg (A → Or B C)))) → Bot V) → (Excl A (Or B C) → Bot V));
  (Γ, ((And (wNeg (A → Or B C)) (Neg (wNeg (A → Or B C)))) → Bot V))]). 2: apply MPRule_I. intros. inversion H4. subst.
  apply MPs with (ps:=[(Γ, (Excl A (Or B C) → (And (wNeg (A → Or B C)) (Neg (wNeg (A → Or B C))))) → ((And (wNeg (A → Or B C)) (Neg (wNeg (A → Or B C)))) → Bot V) → (Excl A (Or B C) → Bot V));
  (Γ, (Excl A (Or B C) → (And (wNeg (A → Or B C)) (Neg (wNeg (A → Or B C))))))]). 2: apply MPRule_I. intros. inversion H5. subst.
  apply Axs. apply AxRule_I. apply RA1_I. exists (Excl A (Or B C)).
  exists (And (wNeg (A → Or B C)) (Neg (wNeg (A → Or B C)))). exists (Bot V). auto. inversion H6.
  subst.
  apply MPs with (ps:=[(Γ, (Excl A (Or B C) → (Neg (wNeg (A → Or B C)))) → (Excl A (Or B C) → And (wNeg (A → Or B C)) (Neg (wNeg (A → Or B C)))));
  (Γ, (Excl A (Or B C) → (Neg (wNeg (A → Or B C)))))]). 2: apply MPRule_I. intros. inversion H7. subst.
  apply MPs with (ps:=[(Γ, (Excl A (Or B C) → (wNeg (A → Or B C))) → (Excl A (Or B C) → (Neg (wNeg (A → Or B C)))) → (Excl A (Or B C) → And (wNeg (A → Or B C)) (Neg (wNeg (A → Or B C)))));
  (Γ, (Excl A (Or B C) → (wNeg (A → Or B C))))]). 2: apply MPRule_I. intros. inversion H8. subst.
  apply Axs. apply AxRule_I. apply RA7_I. exists (Excl A (Or B C)).
  exists (wNeg (A → Or B C)). exists (Neg (wNeg (A → Or B C))). auto. inversion H9. subst.
  apply Axs. apply AxRule_I. apply RA12_I. exists A. exists (Or B C).
  auto. inversion H10. inversion H8. inversion H9. subst.
  apply MPs with (ps:=[(Γ, (Neg (wNeg (A → Or B C))) → (Excl A (Or B C) → Neg (wNeg (A → Or B C))));
  (Γ, (Neg (wNeg (A → Or B C))))]). 2: apply MPRule_I. intros. inversion H9. subst.
  apply sThm_irrel. inversion H11. subst. apply DNs with (ps:=[(Γ, A → Or B C)]).
  2: apply DNsRule_I. intros. inversion H12. subst. assumption. inversion H13. inversion H12.
  inversion H9. inversion H7. inversion H5. subst. apply sContr_Bot. inversion H6.
  inversion H4. inversion H2. subst.
  apply MPs with (ps:=[(Γ, (Bot V → C) → (Or C (Bot V) → C));(Γ, (Bot V → C))]).
  2: apply MPRule_I. intros. inversion H3. subst.
  apply MPs with (ps:=[(Γ, (C → C) → (Bot V → C) → (Or C (Bot V) → C));(Γ, (C → C))]).
  2: apply MPRule_I. intros. inversion H4. subst. apply Axs.
  apply AxRule_I. apply RA4_I. exists C. exists (Bot V). exists C. auto.
  inversion H5. subst. apply simp_Id_gen. inversion H6. inversion H4. subst. apply sEFQ.
  inversion H5. inversion H3. inversion H1.
Qed.

Theorem sdual_residuation : forall A B C,
  (sBIC_rules (Empty_set _, (Excl A B) → C) ->
      sBIC_rules (Empty_set _, A → (Or B C))) *
  (sBIC_rules (Empty_set _, A → (Or B C)) ->
      sBIC_rules (Empty_set _, (Excl A B) → C)).
Proof.
intros. apply sdual_residuation_gen with (Γ:=Empty_set _).
Qed.

Theorem spair_dual_residuation_gen : forall A B C Γ,
  (spair_derrec (Γ, Singleton _ ((Excl A B) → C)) ->
      spair_derrec (Γ, Singleton _ (A → (Or B C)))) *
  (spair_derrec (Γ, Singleton _ (A → (Or B C))) ->
      spair_derrec (Γ, Singleton _ ((Excl A B) → C))).
Proof.
intros A B C Γ. split.
- intro. exists [(A → Or B C)]. repeat split.
  * apply NoDup_cons. intro. inversion H0. apply NoDup_nil.
  * intros. inversion H0. subst. simpl. inversion H0. subst. apply In_singleton. inversion H1. inversion H1.
  * destruct H. destruct H. destruct H0. pose (sdual_residuation_gen A B C Γ). destruct p. clear s0. simpl.
    simpl in s. simpl in H1. simpl in H0. destruct x.
    + simpl in H1. apply MPs with (ps:=[(Γ, Bot V → Or (A → Or B C) (Bot V));(Γ, Bot V)]).
      2: apply MPRule_I. intros. inversion H2. subst. apply Axs.
      apply AxRule_I. apply RA3_I. exists (A → Or B C). exists (Bot V). auto.
      inversion H3. subst. assumption. inversion H4.
    + assert (x=nil). inversion H. subst. assert (b = (Excl A B → C)). pose (H0 b).
      assert (List.In b (b :: x)). apply in_eq. apply s0 in H2. inversion H2. reflexivity.
      subst. destruct x. reflexivity. exfalso. apply H4. pose (H0 b).
      assert (List.In b (Excl A B → C :: b :: x)). apply in_cons. apply in_eq.
      apply s0 in H2. inversion H2. subst. apply in_eq. subst. simpl in H1. assert (b= Excl A B → C).
      pose (H0 b). assert (List.In b [b]). apply in_eq. apply s0 in H2. inversion H2. auto.
      subst. apply sabsorp_Or1 in H1. apply s in H1.
      apply MPs with (ps:=[(Γ, (A → Or B C) → (Or (A → Or B C) (Bot V)));(Γ, (A → Or B C))]).
      2: apply MPRule_I. intros. inversion H2. subst. apply Axs. apply AxRule_I. apply RA2_I.
      exists (A → Or B C). exists (Bot V). auto. inversion H3. subst. assumption. inversion H4.
- intro. exists [(Excl A B → C)]. repeat split.
  * apply NoDup_cons. intro. inversion H0. apply NoDup_nil.
  * intros. inversion H0. subst. simpl. inversion H0. subst. apply In_singleton. inversion H1. inversion H1.
  * destruct H. destruct H. destruct H0. pose (sdual_residuation_gen A B C Γ). destruct p. clear s. simpl.
    simpl in H1. simpl in s0. simpl in H0. destruct x.
    + simpl in H1. apply MPs with (ps:=[(Γ, Bot V → Or (Excl A B → C) (Bot V));(Γ, Bot V)]).
      2: apply MPRule_I. intros. inversion H2. subst. apply Axs.
      apply AxRule_I. apply RA3_I. exists (Excl A B → C). exists (Bot V). auto.
      inversion H3. subst. assumption. inversion H4.
    + assert (x=nil). inversion H. subst. assert (b = (A → Or B C)). pose (H0 b).
      assert (List.In b (b :: x)). apply in_eq. apply s in H2. inversion H2. reflexivity.
      subst. destruct x. reflexivity. exfalso. apply H4. pose (H0 b).
      assert (List.In b (A → Or B C :: b :: x)). apply in_cons. apply in_eq.
      apply s in H2. inversion H2. subst. apply in_eq. subst. simpl in H1. assert (b= A → Or B C).
      pose (H0 b). assert (List.In b [b]). apply in_eq. apply s in H2. inversion H2. auto.
      subst. apply sabsorp_Or1 in H1. apply s0 in H1.
      apply MPs with (ps:=[(Γ, (Excl A B → C) → (Or (Excl A B → C) (Bot V)));(Γ, (Excl A B → C))]).
      2: apply MPRule_I. intros. inversion H2. subst. apply Axs. apply AxRule_I. apply RA2_I.
      exists (Excl A B → C). exists (Bot V). auto. inversion H3. subst. assumption. inversion H4.
Qed.

Theorem sBIC_Detachment_Theorem : forall s,
           (sBIC_rules s) ->
           (forall A B Γ, (fst s = Γ) ->
                          (snd s = A → B) ->
                          sBIC_rules (Union _ Γ (Singleton _ (A)), B)).
Proof.
intros s D. induction D.
(* Ids *)
* intros A B Γ id1 id2. inversion H. subst. simpl in id2. subst.
  simpl. apply MPs with (ps:=[(Union _ Γ0 (Singleton _ A), Imp A B);(Union _ Γ0 (Singleton _ A), A)]).
  2: apply MPRule_I. intros. inversion H1. subst. apply Ids.
  apply IdRule_I. apply Union_introl. assumption. inversion H2. subst.
  apply Ids. apply IdRule_I. apply Union_intror. apply In_singleton. inversion H3.
(* Axs *)
* intros A B Γ id1 id2. inversion H. subst. simpl in id2. subst. simpl.
  apply MPs with (ps:=[(Union _ Γ0 (Singleton _ A), Imp A B);(Union _ Γ0 (Singleton _ A), A)]).
  2: apply MPRule_I. intros. inversion H1. subst. apply Axs.
  apply AxRule_I. assumption. inversion H2. subst. apply Ids. apply IdRule_I.
  apply Union_intror. apply In_singleton. inversion H3.
(* MPs *)
* intros A B Γ id1 id2. inversion H1. subst. simpl in id2. subst. simpl.
  assert (J01: List.In (Γ0, A0 → A → B) [(Γ0, A0 → A → B); (Γ0, A0)]). apply in_eq.
  assert (J02: List.In (Γ0, A0) [(Γ0, A0 → A → B); (Γ0, A0)]). apply in_cons. apply in_eq.
  assert (J1: Γ0 = Γ0). reflexivity.
  assert (J2: A0 → A → B = A0 → A → B). reflexivity.
  pose (H0 (Γ0, A0 → A → B) J01 A0 (Imp A B) Γ0 J1 J2).
  assert (sBIC_rules (Γ0, A → B)).
  assert (J3: (forall A1 : BPropF V, fst (Union _ Γ0 (Singleton _ A0), A → B) A1 ->
  sBIC_rules (Γ0, A1))).
  intro. simpl. intro. inversion H2. subst. apply Ids.
  apply IdRule_I. assumption. subst. inversion H3. subst.
  apply H. apply in_cons. apply in_eq.
  pose (sBIC_comp (Union _ Γ0 (Singleton _ A0), A → B) s Γ0 J3). simpl in s0. assumption.
  apply MPs with (ps:=[(Union _ Γ0 (Singleton _ A), (Imp A B));(Union _ Γ0 (Singleton _ A), A)]).
  2: apply MPRule_I. intros. inversion H3. subst.
  apply MPs with (ps:=[(Union _ Γ0 (Singleton _ A), Imp A0 (Imp A B));(Union _ Γ0 (Singleton _ A), A0)]).
  2: apply MPRule_I. intros. inversion H4. subst.
  assert (J4: Included _ (fst (Γ0, A0 → A → B)) (Union _ Γ0 (Singleton _ A))).
  simpl. intro. intro. apply Union_introl. assumption.
  pose (H _ J01).
  pose (sBIC_monot (Γ0, A0 → A → B) s0 (Union _ Γ0 (Singleton _ A)) J4). assumption.
  inversion H5. subst. pose (H _ J02).
  assert (J4: Included _ (fst (Γ0, A0 → A → B)) (Union _ Γ0 (Singleton _ A))).
  simpl. intro. intro. apply Union_introl. assumption.
  pose (sBIC_monot (Γ0, A0) s0 (Union _ Γ0 (Singleton _ A)) J4). simpl in s1.
  assumption. inversion H6. inversion H4. subst. apply Ids. apply IdRule_I. apply Union_intror. apply In_singleton.
  inversion H5.
(* DNs *)
* intros A B Γ id1 id2. inversion H1. subst. simpl in id2. subst. inversion id2. subst. simpl.
  remember (Union (BPropF V) Γ0 (Singleton (BPropF V)  (wNeg A0))) as Γ.
  assert (J01: List.In (Γ0, A0) [(Γ0, A0)]). apply in_eq. apply H in J01.
  apply MPs with (ps:=[(Γ, (And (wNeg A0) (Neg (wNeg A0))) → Bot _); (Γ, And (wNeg A0) (Neg (wNeg A0)))]).
  2: apply MPRule_I. intros. inversion H2. rewrite <- H3. apply sContr_Bot. inversion H3.
  rewrite <- H4.
  apply MPs with (ps:=[(Γ,(Top V →  (And (wNeg A0) (Neg (wNeg A0)))));(Γ, Top V)]).
  2: apply MPRule_I. intros. inversion H5. rewrite <- H6.
  apply MPs with (ps:=[(Γ,(Top V → (Neg (wNeg A0))) →(Top V →  (And (wNeg A0) (Neg (wNeg A0)))));(Γ, Top V → (Neg (wNeg A0)))]).
  2: apply MPRule_I. intros. inversion H7. rewrite <- H8.
  apply MPs with (ps:=[(Γ,(Top V → (wNeg A0)) → (Top V → (Neg (wNeg A0))) → (Top V → (And (wNeg A0) (Neg (wNeg A0)))));(Γ, Top V → (wNeg A0))]).
  2: apply MPRule_I. intros. inversion H9. rewrite <- H10. apply Axs. apply AxRule_I.
  apply RA7_I. exists (Top V). exists (wNeg A0). exists (Neg (wNeg A0)). auto. inversion H10. 2: inversion H11.
  rewrite <- H11.
  apply MPs with (ps:=[(Γ, wNeg A0 → Top V → wNeg A0);(Γ, wNeg A0)]). intros. 2: apply MPRule_I.
  inversion H12. rewrite <- H13. apply sThm_irrel. inversion H13. 2: inversion H14. rewrite <- H14.
  apply Ids. apply IdRule_I. subst. apply Union_intror. apply In_singleton.
  inversion H8. rewrite <- H9.
  apply MPs with (ps:=[(Γ, Neg (wNeg A0) → Top V → Neg (wNeg A0));(Γ, Neg (wNeg A0))]). intros. 2: apply MPRule_I.
  inversion H10. rewrite <- H11. apply sThm_irrel. inversion H11. 2: inversion H12. rewrite <- H12.
  apply DNs with (ps:=[(Γ, A0)]). intros. 2: apply DNsRule_I. inversion H13. subst.
  pose (sBIC_monot _ J01). apply s. simpl. intro. intros. apply Union_introl. auto. inversion H14.
  inversion H9. inversion H6. subst. apply sBIC_extens_wBIC. apply wTop. inversion H7. inversion H4.
Qed.

Theorem gen_sBIC_Detachment_Theorem : forall A B Γ,
  spair_derrec (Γ, Singleton _ (A → B)) ->
      spair_derrec (Union _ Γ (Singleton _ (A)), Singleton _ (B)).
Proof.
intros A B Γ spair. unfold spair_derrec. exists [B]. repeat split.
apply NoDup_cons. intro. inversion H. apply NoDup_nil. intros. inversion H.
subst. simpl. apply In_singleton. inversion H0. simpl.
apply MPs with (ps:=[ (Union _ Γ (Singleton _ A), Imp B (Or B (Bot V))); (Union _ Γ (Singleton _ A), B)]).
2: apply MPRule_I. intros. inversion H. subst. apply Axs. apply AxRule_I.
apply RA2_I. exists B. exists (Bot V). auto. inversion H0. subst.
destruct spair. destruct H1. destruct H2. simpl in H3. simpl in H2. destruct x.
apply MPs with (ps:=[(Union _ Γ (Singleton _ A), Imp (Bot V) B);(Union _ Γ (Singleton _ A), (Bot V))]).
2: apply MPRule_I. intros. inversion H4. subst. apply sEFQ. inversion H5.
assert (J1: Included _ (fst (Γ, Bot V)) (Union _ Γ (Singleton _ A))). intro. intro. apply Union_introl.
assumption.
pose (sBIC_monot (Γ , Bot V) H3 (Union _ Γ (Singleton _ A)) J1). simpl in s. subst. assumption.
inversion H6.
destruct x. simpl in H3. assert (b=A → B). pose (H2 b). assert (List.In b [b]). apply in_eq.
apply s in H4. inversion H4. reflexivity. subst. apply sabsorp_Or1 in H3.
assert (J1: Γ = Γ). reflexivity.
assert (J2: A → B = A → B). reflexivity.
pose (sBIC_Detachment_Theorem (Γ, A → B) H3 A B Γ J1 J2). assumption.
exfalso. simpl in H3. inversion H1. apply H6. subst. pose (H2 b).
assert (List.In b (b :: b0 :: x)). apply in_eq. pose (s H4). inversion s0. subst.
pose (H2 b0). assert (List.In b0 (A → B :: b0 :: x)). apply in_cons. apply in_eq.
pose (s1 H5). inversion s2. subst. apply in_eq. inversion H1.
Qed.

Lemma sDN_to_form : forall A Γ, (sBIC_rules (Γ, Neg (wNeg A)→ A)).
Proof.
intros A Γ. apply sBIC_extens_wBIC. apply wDN_to_form.
Qed.

Lemma sT_for_DN : forall A n m Γ, (le m n) -> (sBIC_rules (Γ, (DN_form n A) → (DN_form m A))).
Proof.
intros. apply sBIC_extens_wBIC. apply wT_for_DN. assumption.
Qed.

Lemma sExcl_mon : forall A B C,
  (sBIC_rules (Empty_set _, A → B)) ->
  (sBIC_rules (Empty_set _, (Excl A C) → (Excl B C))).
Proof.
intros. apply sdual_residuation.
apply MPs with (ps:=[(Empty_set _, (B → Or C (Excl B C)) → (A → Or C (Excl B C)));
(Empty_set _, (B → Or C (Excl B C)))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Empty_set _, (A → B) → (B → Or C (Excl B C)) → (A → Or C (Excl B C)));
(Empty_set _, (A → B))]).
2: apply MPRule_I. intros. inversion H1. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists A. exists B.
exists (Or C (Excl B C)). auto. inversion H2. subst. assumption. inversion H3.
inversion H1. subst.
apply Axs. apply AxRule_I. apply RA11_I. exists B. exists C. auto. inversion H2.
Qed.

Lemma smon_Excl : forall A B C,
  (sBIC_rules (Empty_set _, A → B)) ->
  (sBIC_rules (Empty_set _, (Excl C B) → (Excl C A))).
Proof.
intros. apply sdual_residuation.
apply MPs with (ps:=[(Empty_set _, (Or A (Excl C A) → Or B (Excl C A)) → (C → Or B (Excl C A)));
(Empty_set _, (Or A (Excl C A) → Or B (Excl C A)))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Empty_set _, (C → Or A (Excl C A)) → (Or A (Excl C A) → Or B (Excl C A)) → (C → Or B (Excl C A)));
(Empty_set _, C → Or A (Excl C A))]).
2: apply MPRule_I. intros. inversion H1. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists C. exists (Or A (Excl C A)).
exists (Or B (Excl C A)). auto. inversion H2. subst.
apply Axs. apply AxRule_I. apply RA11_I. exists C. exists A.
auto. inversion H3. inversion H1. subst.
apply MPs with (ps:=[(Empty_set _, ((Excl C A) → Or B (Excl C A)) → (Or A (Excl C A) → Or B (Excl C A)));
(Empty_set _, ((Excl C A) → Or B (Excl C A)))]).
2: apply MPRule_I. intros. inversion H2. subst.
apply MPs with (ps:=[(Empty_set _, (A → Or B (Excl C A)) → ((Excl C A) → Or B (Excl C A)) → (Or A (Excl C A) → Or B (Excl C A)));
(Empty_set _, (A → Or B (Excl C A)))]).
2: apply MPRule_I. intros. inversion H3. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists A. exists (Excl C A).
exists (Or B (Excl C A)). auto. inversion H4. subst.
apply MPs with (ps:=[(Empty_set _, (B → Or B (Excl C A)) → (A → Or B (Excl C A)));
(Empty_set _, (B → Or B (Excl C A)))]).
2: apply MPRule_I. intros. inversion H5. subst.
apply MPs with (ps:=[(Empty_set _, (A → B) → (B → Or B (Excl C A)) → (A → Or B (Excl C A)));
(Empty_set _, (A → B))]).
2: apply MPRule_I. intros. inversion H6. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists A. exists B.
exists (Or B (Excl C A)). auto. inversion H7. subst. assumption. inversion H8.
inversion H6. subst.
apply Axs. apply AxRule_I. apply RA2_I. exists B. exists (Excl C A). auto.
inversion H7. inversion H5. inversion H3. subst.
apply Axs. apply AxRule_I. apply RA3_I. exists B. exists (Excl C A). auto.
inversion H4. inversion H2.
Qed.

Lemma sOr_Neg : forall A B C Γ,
  (sBIC_rules (Γ, A → (Or B C))) ->
  (sBIC_rules (Γ, (And (Neg B) A) → C)).
Proof.
intros.
apply MPs with (ps:=[(Γ, ((And (Neg B) (Or B C)) → C) → (And (Neg B) A → C));(Γ, And (Neg B) (Or B C) → C)]).
2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Γ, ((And (Neg B) A) → (And (Neg B) (Or B C))) → ((And (Neg B) (Or B C)) → C) → (And (Neg B) A → C));
(Γ, ((And (Neg B) A) → (And (Neg B) (Or B C))))]).
2: apply MPRule_I. intros. inversion H1. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists (And (Neg B) A). exists (And (Neg B) (Or B C)).
exists C. auto. inversion H2. subst.
apply MPs with (ps:=[(Γ, (And (Neg B) A → (Or B C)) → (And (Neg B) A → And (Neg B) (Or B C)));
(Γ, (And (Neg B) A → (Or B C)))]).
2: apply MPRule_I. intros. inversion H3. subst.
apply MPs with (ps:=[(Γ, (And (Neg B) A → (Neg B)) → (And (Neg B) A → (Or B C)) → (And (Neg B) A → And (Neg B) (Or B C)));
(Γ, (And (Neg B) A → (Neg B)))]).
2: apply MPRule_I. intros. inversion H4. subst.
apply Axs. apply AxRule_I. apply RA7_I. exists (And (Neg B) A). exists (Neg B).
exists (Or B C). auto. inversion H5. subst.
apply Axs. apply AxRule_I. apply RA5_I. exists (Neg B). exists A. auto.
inversion H6. inversion H4. subst.
apply MPs with (ps:=[(Γ, (A → Or B C) → (And (Neg B) A → Or B C));
(Γ, (A → Or B C))]).
2: apply MPRule_I. intros. inversion H5. subst.
apply MPs with (ps:=[(Γ, (And (Neg B) A → A) → (A → Or B C) → (And (Neg B) A → Or B C));
(Γ, (And (Neg B) A → A))]).
2: apply MPRule_I. intros. inversion H6. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists (And (Neg B) A). exists A.
exists (Or B C). auto. inversion H7. subst.
apply Axs. apply AxRule_I. apply RA6_I. exists (Neg B). exists A. auto.
inversion H8. inversion H6. subst. assumption. inversion H7. inversion H5. inversion H3. inversion H1. subst.
apply MPs with (ps:=[(Γ, (And (Or B C) (Neg B) → C) → (And (Neg B) (Or B C) → C));
(Γ, (And (Or B C) (Neg B) → C))]).
2: apply MPRule_I. intros. inversion H2. subst.
apply MPs with (ps:=[(Γ, (And (Neg B) (Or B C) → And (Or B C) (Neg B)) → (And (Or B C) (Neg B) → C) → (And (Neg B) (Or B C) → C));
(Γ, And (Neg B) (Or B C) → And (Or B C) (Neg B))]).
2: apply MPRule_I. intros. inversion H3. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists (And (Neg B) (Or B C)). exists (And (Or B C) (Neg B)).
exists C. auto. inversion H4. subst.
apply MPs with (ps:=[(Γ, (And (Neg B) (Or B C) → (Neg B)) → (And (Neg B) (Or B C) → And (Or B C) (Neg B)));
(Γ, (And (Neg B) (Or B C) → (Neg B)))]).
2: apply MPRule_I. intros. inversion H5. subst.
apply MPs with (ps:=[(Γ, (And (Neg B) (Or B C) → (Or B C)) → (And (Neg B) (Or B C) → (Neg B)) → (And (Neg B) (Or B C) → And (Or B C) (Neg B)));
(Γ, (And (Neg B) (Or B C) → (Or B C)))]).
2: apply MPRule_I. intros. inversion H6. subst.
apply Axs. apply AxRule_I. apply RA7_I. exists (And (Neg B) (Or B C)). exists (Or B C).
exists (Neg B). auto. inversion H7. subst.
apply Axs. apply AxRule_I. apply RA6_I. exists (Neg B). exists (Or B C).
auto. inversion H8. inversion H6. subst.
apply Axs. apply AxRule_I. apply RA5_I. exists (Neg B). exists (Or B C).
auto. inversion H7. inversion H5. inversion H3. subst.
apply MPs with (ps:=[(Γ, ((Or B C) → (Neg B) → C) → (And (Or B C) (Neg B) → C));
(Γ, ((Or B C) → (Neg B) → C))]).
2: apply MPRule_I. intros. inversion H4. subst.
apply Axs. apply AxRule_I. apply RA8_I. exists (Or B C). exists (Neg B). exists C.
auto. inversion H5. subst.
apply MPs with (ps:=[(Γ, (C → Neg B → C) → (Or B C → Neg B → C));
(Γ, (C → Neg B → C))]).
2: apply MPRule_I. intros. inversion H6. subst.
apply MPs with (ps:=[(Γ, (B → Neg B → C) → (C → Neg B → C) → (Or B C → Neg B → C));
(Γ, (B → Neg B → C))]).
2: apply MPRule_I. intros. inversion H7. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists B. exists C.
exists (Neg B → C). auto. inversion H8. subst.
apply MPs with (ps:=[(Γ, ((And B (Neg B)) → C) → (B → Neg B → C));
(Γ, ((And B (Neg B)) → C))]).
2: apply MPRule_I. intros. inversion H9. subst.
apply Axs. apply AxRule_I. apply RA9_I. exists B. exists (Neg B). exists C.
auto. inversion H10. subst.
apply MPs with (ps:=[(Γ, (Bot V → C) → (And B (Neg B) → C));
(Γ, (Bot V → C))]).
2: apply MPRule_I. intros. inversion H11. subst.
apply MPs with (ps:=[(Γ, (And B (Neg B) → Bot V) → (Bot V → C) → (And B (Neg B) → C));
(Γ, (And B (Neg B) → Bot V))]).
2: apply MPRule_I. intros. inversion H12. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists (And B (Neg B)). exists (Bot V).
exists (C). auto. inversion H13. subst. apply sContr_Bot. inversion H14. inversion H12. subst.
apply sEFQ. inversion H13. inversion H11. inversion H9. inversion H7. subst.
apply sThm_irrel. inversion H8. inversion H6. inversion H4. inversion H2.
Qed.

Lemma swNeg_Top : forall A B Γ,
  (sBIC_rules (Γ, ((wNeg A) → B))) ->
  (sBIC_rules (Γ, (Excl (Top _) A) → B)).
Proof.
intros A B Γ D. apply MPs with (ps:=[(Γ, (wNeg A → B) → (Excl (Top V) A → B));
(Γ, (wNeg A → B))]). 2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, (Excl (Top V) A → wNeg A) → (wNeg A → B) → Excl (Top V) A → B);
(Γ, (Excl (Top V) A → wNeg A))]). 2: apply MPRule_I. intros. inversion H0. subst.
apply Axs. apply AxRule_I.
apply RA1_I. exists (Excl (Top V) A). exists (wNeg A). exists B. auto.
inversion H1. subst. apply simp_Id_gen.
inversion H2. inversion H0. subst. auto. inversion H1.
Qed.

Lemma sTop_wNeg : forall A B Γ,
  (sBIC_rules (Γ, (Excl (Top _) A) → B)) ->
  (sBIC_rules (Γ, ((wNeg A) → B))).
Proof.
intros A B Γ D. apply MPs with (ps:=[(Γ, (Excl (Top V) A → B) → (wNeg A → B));
(Γ, (Excl (Top V) A → B))]). 2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, (wNeg A → Excl (Top V) A) → (Excl (Top V) A → B) → wNeg A → B);
(Γ, (wNeg A → Excl (Top V) A))]). 2: apply MPRule_I. intros. inversion H0. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists (wNeg A). exists (Excl (Top V) A). exists B. auto.
inversion H1. subst. apply simp_Id_gen.
inversion H2. inversion H0. subst. assumption. inversion H1.
Qed.

Lemma Top_wNeg_cons : forall A B Γ,
  (sBIC_rules (Γ, A → (Excl (Top _) B))) ->
  (sBIC_rules (Γ, A → (wNeg B))).
Proof.
intros. apply MPs with (ps:=[(Γ, (Excl (Top V) B → wNeg B) → (A → wNeg B));
(Γ, (Excl (Top V) B → wNeg B))]). 2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Γ, (A → Excl (Top V) B) → (Excl (Top V) B → wNeg B) → (A → wNeg B));
(Γ, (A → Excl (Top V) B))]). 2: apply MPRule_I. intros. inversion H1. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists A. exists (Excl (Top V) B). exists (wNeg B). auto.
inversion H2. subst. assumption. inversion H3. inversion H1. subst. 2: inversion H2.
apply simp_Id_gen.
Qed.

Lemma sOr_imp_assoc : forall A B C D Γ,
  (sBIC_rules (Γ, A → (Or (Or B C) D))) ->
  (sBIC_rules (Γ, A → (Or B (Or C D)))).
Proof.
intros.
apply MPs with (ps:=[(Γ, (Or (Or B C) D → Or B (Or C D)) → (A → Or B (Or C D)));
(Γ, (Or (Or B C) D → Or B (Or C D)))]). 2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Γ, (A → Or (Or B C) D) → (Or (Or B C) D → Or B (Or C D)) → (A → Or B (Or C D)));
(Γ, (A → Or (Or B C) D))]). 2: apply MPRule_I. intros. inversion H1. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists A. exists (Or (Or B C) D).
exists (Or B (Or C D)). auto. inversion H2. subst.
assumption. inversion H3. inversion H1. subst.
apply MPs with (ps:=[(Γ, (D → Or B (Or C D)) → (Or (Or B C) D → Or B (Or C D)));
(Γ, (D → Or B (Or C D)))]). 2: apply MPRule_I. intros. inversion H2. subst.
apply MPs with (ps:=[(Γ, ((Or B C) → Or B (Or C D)) → (D → Or B (Or C D)) → (Or (Or B C) D → Or B (Or C D)));
(Γ, ((Or B C) → Or B (Or C D)))]). 2: apply MPRule_I. intros. inversion H3. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists (Or B C).
exists D. exists (Or B (Or C D)). auto. inversion H4. subst.
apply MPs with (ps:=[(Γ, (C → Or B (Or C D)) → (Or B C → Or B (Or C D)));
(Γ, C → Or B (Or C D))]). 2: apply MPRule_I. intros. inversion H5. subst.
apply MPs with (ps:=[(Γ, (B → Or B (Or C D)) → (C → Or B (Or C D)) → (Or B C → Or B (Or C D)));
(Γ, B → Or B (Or C D))]). 2: apply MPRule_I. intros. inversion H6. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists B. exists C.
exists (Or B (Or C D)). auto. inversion H7. subst.
apply Axs. apply AxRule_I. apply RA2_I. exists B. exists (Or C D). auto. inversion H8.
inversion H6. subst.
apply MPs with (ps:=[(Γ, ((Or C D) → Or B (Or C D)) → (C → Or B (Or C D)));
(Γ, (Or C D) → Or B (Or C D))]). 2: apply MPRule_I. intros. inversion H7. subst.
apply MPs with (ps:=[(Γ, (C → (Or C D)) → ((Or C D) → Or B (Or C D)) → (C → Or B (Or C D)));
(Γ, (C → (Or C D)))]). 2: apply MPRule_I. intros. inversion H8. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists C. exists (Or C D).
exists (Or B (Or C D)). auto. inversion H9. subst.
apply Axs. apply AxRule_I. apply RA2_I. exists C. exists D. auto. inversion H10.
inversion H8. subst. apply Axs. apply AxRule_I.
apply RA3_I. exists B. exists (Or C D). auto. inversion H9. inversion H7. inversion H5. inversion H3. subst.
apply MPs with (ps:=[(Γ, ((Or C D) → Or B (Or C D)) → (D → Or B (Or C D)));
(Γ, ((Or C D) → Or B (Or C D)))]). 2: apply MPRule_I. intros. inversion H4. subst.
apply MPs with (ps:=[(Γ, (D → (Or C D)) → ((Or C D) → Or B (Or C D)) → (D → Or B (Or C D)));
(Γ, (D → (Or C D)))]). 2: apply MPRule_I. intros. inversion H5. subst. apply Axs. apply AxRule_I. apply RA1_I. exists D. exists (Or C D).
exists (Or B (Or C D)). auto. inversion H6. subst.
apply Axs. apply AxRule_I. apply RA3_I. exists C. exists D. auto. inversion H7.
inversion H5. subst.
apply Axs. apply AxRule_I. apply RA3_I. exists B. exists (Or C D). auto.
inversion H6. inversion H4. inversion H2.
Qed.

Lemma sClaim1 : forall A B Γ,
    (sBIC_rules (Γ, (Neg (Excl A B)) → ((wNeg B) → (wNeg A)))).
Proof.
intros A B Γ. apply sBIC_extens_wBIC. apply wClaim1.
Qed.

Lemma sDN_dist_imp : forall A B Γ,
    (sBIC_rules (Γ, (Neg (wNeg (A → B))) → ((Neg (wNeg A)) → (Neg (wNeg B))))).
Proof.
intros A B Γ. apply sBIC_extens_wBIC. apply wDN_dist_imp.
Qed.

Theorem sBIC_Deduction_Theorem : forall s,
           (sBIC_rules s) ->
           (forall A B Γ, (fst s = Union _ Γ (Singleton _ (A))) ->
                          (snd s = B) ->
                          (exists n, sBIC_rules (Γ, (DN_form n A) → B))).
Proof.
intros s D. induction D.
(* Ids *)
- intros A B Γ id1 id2. inversion H. subst. simpl in id1. subst. simpl. exists 0. inversion H0.
  + subst. apply MPs with (ps:=[(Γ, A0 → A → A0);(Γ, A0)]). 2: apply MPRule_I. intros. inversion H2. subst.
    apply sThm_irrel. inversion H3. subst.
    apply Ids. apply IdRule_I. assumption. inversion H4.
  + subst. inversion H1. subst. apply simp_Id_gen.
(* Axs *)
- intros A B Γ id1 id2. inversion H. subst. simpl in id1. subst. simpl. exists 0.
  apply MPs with (ps:=[(Γ, A0 → A → A0);(Γ, A0)]). 2: apply MPRule_I. intros. inversion H1. subst.
  apply sThm_irrel. inversion H2. subst.
  apply Axs. apply AxRule_I. assumption. inversion H3.
(* MPs *)
- intros A B Γ id1 id2. inversion H1. subst. simpl in id1. subst. simpl.
  assert (J01: List.In (Union (BPropF V) Γ (Singleton (BPropF V) A), A0 → B0) [(Union (BPropF V) Γ (Singleton (BPropF V) A), A0 → B0); (Union (BPropF V) Γ (Singleton (BPropF V) A), A0)]).
  apply in_eq.
  assert (J02: List.In (Union (BPropF V) Γ (Singleton (BPropF V) A), A0) [(Union (BPropF V) Γ (Singleton (BPropF V) A), A0 → B0); (Union (BPropF V) Γ (Singleton (BPropF V) A), A0)]).
  apply in_cons. apply in_eq.
  assert (J1: Union _ Γ (Singleton _ A) = Union _ Γ (Singleton _ A)). reflexivity.
  assert (J2: A0 → B0 = A0 → B0). reflexivity.
  pose (H0 (Union (BPropF V) Γ (Singleton (BPropF V) A), A0 → B0) J01 A (Imp A0 B0) Γ J1 J2).
  destruct e. subst.
  assert (J3: A0 = A0). reflexivity.
  pose (H0 (Union (BPropF V) Γ (Singleton (BPropF V) A), A0) J02 A A0 Γ J1 J3). destruct e.
  exists (max x x0).
  apply MPs with (ps:=[(Γ, (And (DN_form (Init.Nat.max x x0) A) A0 → B0) → ((DN_form (Init.Nat.max x x0) A) → B0));(Γ, And (DN_form (Init.Nat.max x x0) A) A0 → B0)]).
  2: apply MPRule_I. intros. inversion H4. subst.
  apply MPs with (ps:=[(Γ, ((DN_form (Init.Nat.max x x0) A) → And (DN_form (Init.Nat.max x x0) A) A0) → (And (DN_form (Init.Nat.max x x0) A) A0 → B0) → ((DN_form (Init.Nat.max x x0) A) → B0));(Γ, (DN_form (Init.Nat.max x x0) A) → And (DN_form (Init.Nat.max x x0) A) A0)]).
  2: apply MPRule_I. intros. inversion H5. subst. apply Axs.
  apply AxRule_I. apply RA1_I. exists (DN_form (Init.Nat.max x x0) A). exists (And (DN_form (Init.Nat.max x x0) A) A0). exists B0. auto.
  inversion H6. subst.
  apply MPs with (ps:=[(Γ, ((DN_form (Init.Nat.max x x0) A) → A0) → ((DN_form (Init.Nat.max x x0) A) → And (DN_form (Init.Nat.max x x0) A) A0));(Γ, (DN_form (Init.Nat.max x x0) A) → A0)]).
  2: apply MPRule_I. intros. inversion H7. subst.
  apply MPs with (ps:=[(Γ, ((DN_form (Init.Nat.max x x0) A) → (DN_form (Init.Nat.max x x0) A)) → ((DN_form (Init.Nat.max x x0) A) → A0) → ((DN_form (Init.Nat.max x x0) A) → And (DN_form (Init.Nat.max x x0) A) A0));
  (Γ, (DN_form (Init.Nat.max x x0) A) → (DN_form (Init.Nat.max x x0) A))]).
  2: apply MPRule_I. intros. inversion H8. subst. apply Axs.
  apply AxRule_I. apply RA7_I. exists (DN_form (Init.Nat.max x x0) A). exists (DN_form (Init.Nat.max x x0) A). exists A0. auto.
  inversion H9. subst. apply simp_Id_gen. inversion H10. inversion H8. subst. 2: inversion H9.
  apply MPs with (ps:=[(Γ, (DN_form x0 A → A0) → (DN_form (Init.Nat.max x x0) A → A0));
  (Γ, DN_form x0 A → A0)]).
  2: apply MPRule_I. intros. inversion H9. subst.
  apply MPs with (ps:=[(Γ, (DN_form (Init.Nat.max x x0) A → DN_form x0 A) → (DN_form x0 A → A0) → (DN_form (Init.Nat.max x x0) A → A0));
  (Γ, DN_form (Init.Nat.max x x0) A → DN_form x0 A)]).
  2: apply MPRule_I. intros. inversion H10. subst. apply Axs.
  apply AxRule_I. apply RA1_I. exists (DN_form (Init.Nat.max x x0) A). exists (DN_form x0 A).
  exists A0. auto. inversion H11. subst. apply sT_for_DN. lia. inversion H12.
  inversion H10. subst. assumption. inversion H11. inversion H7. inversion H5. subst.
  apply MPs with (ps:=[(Γ, (DN_form (Init.Nat.max x x0) A → A0 → B0) → (And (DN_form (Init.Nat.max x x0) A) A0 → B0));
  (Γ, (DN_form (Init.Nat.max x x0) A → A0 → B0))]). 2: apply MPRule_I.
  intros. inversion H6. subst. apply Axs. apply AxRule_I.
  apply RA8_I. exists (DN_form (Init.Nat.max x x0) A). exists A0. exists B0.
  auto. subst. inversion H7. subst.
  apply MPs with (ps:=[(Γ, (DN_form x A → A0 → B0) → (DN_form (Init.Nat.max x x0) A → A0 → B0));
  (Γ, DN_form x A → A0 → B0)]). 2: apply MPRule_I. intros. inversion H8. subst.
  apply MPs with (ps:=[(Γ, (DN_form (Init.Nat.max x x0) A → DN_form x A) → (DN_form x A → A0 → B0) → (DN_form (Init.Nat.max x x0) A → A0 → B0));
  (Γ, DN_form (Init.Nat.max x x0) A → DN_form x A)]). 2: apply MPRule_I. intros. inversion H9. subst.
  apply Axs. apply AxRule_I. apply RA1_I. exists (DN_form (Init.Nat.max x x0) A).
  exists (DN_form x A). exists (A0 → B0). auto. subst. inversion H10. subst.
  apply sT_for_DN. lia. inversion H11. inversion H9. subst. assumption.
  inversion H10. inversion H8. inversion H6.
(* DNs *)
- intros A B Γ id1 id2. inversion H1. subst. simpl in id1. subst. simpl.
  assert (J01: List.In (Union (BPropF V) Γ (Singleton (BPropF V) A), A0) [(Union (BPropF V) Γ (Singleton (BPropF V) A), A0)]).
  apply in_eq.
  assert (J1: Union _ Γ (Singleton _ A) = Union _ Γ (Singleton _ A)). reflexivity.
  assert (J2: A0 = A0). reflexivity.
  pose (H0 (Union (BPropF V) Γ (Singleton (BPropF V) A), A0) J01 A A0 Γ J1 J2). destruct e.
  assert (DNsRule [(Γ, DN_form x A → A0)] (Γ, Neg (wNeg (DN_form x A → A0)))).
  apply DNsRule_I.
  assert (J3: (forall prem : Ensemble (BPropF V) * BPropF V, List.In prem [(Γ, DN_form x A → A0)] ->
  sBIC_rules prem)). intros. inversion H4. subst. 2: inversion H5. assumption.
  pose (@DNs (Γ, Neg (wNeg (DN_form x A → A0))) [(Γ, DN_form x A → A0)] J3 H3).
  pose (sDN_dist_imp (DN_form x A) A0 Γ). exists (S x). simpl.
  apply MPs with (ps:=[(Γ, Neg (wNeg (DN_form x A → A0)) → Neg (wNeg (DN_form x A)) → Neg (wNeg A0));
  (Γ, Neg (wNeg (DN_form x A → A0)))]). 2: apply MPRule_I. intros. inversion H4. subst. 2: inversion H5.
  assumption. subst. assumption. inversion H6.
Qed.

Theorem gen_sBIC_Deduction_Theorem : forall A B Γ,
  spair_derrec (Union _ Γ (Singleton _ (A)), Singleton _ (B)) ->
      (exists n, spair_derrec (Γ, Singleton _ ((DN_form n A) → B))).
Proof.
intros A B Γ spair. unfold spair_derrec. simpl. destruct spair.
destruct H. destruct H0. simpl in H1. simpl in H0. destruct x.
- simpl in H1.
  assert (J1: Union _ Γ (Singleton _ A) = Union _ Γ (Singleton _ A)). reflexivity.
  assert (J2: Bot V = Bot V). reflexivity.
  pose (sBIC_Deduction_Theorem (Union _ Γ (Singleton _ A), Bot V) H1 A (Bot V) Γ J1 J2).
  destruct e. exists x. exists [(DN_form x A → B)]. repeat split. apply NoDup_cons.
  auto. apply NoDup_nil. intros. inversion H3. subst. apply In_singleton.
  subst. inversion H4. simpl.
  apply MPs with (ps:=[(Γ, Imp (DN_form x A → B) (Or (DN_form x A → B) (Bot V))); (Γ, (DN_form x A → B))]).
  2: apply MPRule_I. intros. inversion H3. subst. apply Axs. apply AxRule_I. apply RA2_I.
  exists (DN_form x A → B). exists (Bot V). auto. inversion H4. subst.
  apply MPs with (ps:=[(Γ, (Bot V → B) → (DN_form x A → B));(Γ, Bot V → B)]).
  2: apply MPRule_I. intros. inversion H5. subst.
  apply MPs with (ps:=[(Γ, (DN_form x A → Bot V) → (Bot V → B) → (DN_form x A → B));(Γ, DN_form x A → Bot V)]).
  2: apply MPRule_I. intros. inversion H6. subst.
  apply Axs. apply AxRule_I. apply RA1_I. exists (DN_form x A). exists (Bot V). exists B.
  auto. inversion H7. subst. assumption. inversion H8. inversion H6. subst. apply sEFQ. inversion H7. inversion H5.
- simpl in H1. destruct x. simpl in H1. assert (b=B). pose (H0 b). assert (List.In b [b]). apply in_eq.
  apply s in H2. inversion H2. reflexivity. subst. apply sabsorp_Or1 in H1.
  assert (J1: Union _ Γ (Singleton _ A) = Union _ Γ (Singleton _ A)). reflexivity.
  assert (J2: B = B). reflexivity.
  pose (sBIC_Deduction_Theorem (Union _ Γ (Singleton _ A), B) H1 A B Γ J1 J2). destruct e.
  exists x. exists [(DN_form x A → B)]. repeat split. apply NoDup_cons.
  auto. apply NoDup_nil. intros. inversion H3. subst. apply In_singleton.
  subst. inversion H4. simpl.
  apply MPs with (ps:=[(Γ, Imp (DN_form x A → B) (Or (DN_form x A → B) (Bot V))); (Γ, (DN_form x A → B))]).
  2: apply MPRule_I. intros. inversion H3. subst. apply Axs. apply AxRule_I. apply RA2_I.
  exists (DN_form x A → B). exists (Bot V). auto. inversion H4. subst.
  assumption. inversion H5.
  exfalso. simpl in H0. inversion H. apply H4. subst. pose (H0 b).
  assert (List.In b (b :: b0 :: x)). apply in_eq. pose (s H2). inversion s0. subst.
  pose (H0 b0). assert (List.In b0 (b :: b0 :: x)). apply in_cons. apply in_eq.
  pose (s1 H3). inversion s2. subst. apply in_eq.
Qed.