(* This files is for general facts used in the paper *)

Require Import HoTT.
Require Export HoTT.

(*
Lemma lem:pathext
*)
Definition apTransport (A B : Type) (f g : A -> B) (e : f = g) (x y : A) (p : x = y) :
  transport (fun h => h x = h y) e (ap f p) = ap g p :=
match e with
  idpath => 1
end.

(*
Definition def:ap_ext_pt.
 *)
Definition fPath `{Funext} {A B : Type} {f g : A -> B} (e : f = g) (x : A) : f x = g x
  := (path_forall f g)^-1 e x.

Definition fPath_point `{Funext} {A B : Type} {f g : A -> B} (e : f == g) (x : A)
  : fPath (path_forall _ _ e) x = e x := apD10_path_arrow _ _ _ _.

(*
Lemma lem:funTrans
*)
Definition funTransport `{Funext} (A B : Type) (f g : A -> B) (e : f = g) (x y : A) (p : f x = f y) :
  transport (fun h => h x = h y) e p = (fPath e x)^ @ p @ (fPath e y) :=
match e with
  idpath => (concat_p1 p)^ @ (ap (fun q => q @ 1) (concat_1p p))^
end.

Definition apd2
 (A : Type) (Y : A -> Type) (f : forall x : A, Y x) (a b : A) (p q : a = b) (s : p = q) :
  transport (fun r : a = b => r # f a = f b) s (apD f p) = apD f q :=
match p with
| refl => apD (fun r => apD f r) s
end.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj18synthconj1_hyp: forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus lv0 lv1) lv3) ->  (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus lv3 (Succ (plus Zero lv2)))).
Admitted.
QuickChick conj18synthconj1_hyp.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_nom_con_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_nom x1 L1 T1') ->
                  forall T2 T2' Ts, T2 = (t_con T2' Ts) ->
                               subtype T1 T2 = false.
Proof.
  intros; subst.

  unfold subtype, subtype_func;
    simpl;
    rewrite fix_sub_eq_ext;
    simpl;
    fold subtype_func;
    auto.

Qed.


(** Constant pseudofunctor *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.Notations.

Local Open Scope cat.

Section Constant.
  Context (B₁ : bicat)
          {B₂ : bicat}
          (Y : B₂).

  Definition constant_data : psfunctor_data B₁ B₂.
  Proof.
    use make_psfunctor_data.
    - exact (λ _, Y).
    - exact (λ _ _ _, id₁ Y).
    - exact (λ _ _ _ _ _, id₂ (id₁ Y)).
    - exact (λ _, id₂ (id₁ Y)).
    - exact (λ _ _ _ _ _, lunitor (id₁ Y)).
  Defined.

  Definition constant_laws : psfunctor_laws constant_data.
  Proof.
    repeat split.
    - intros a b f g h α β ; cbn.
      rewrite id2_left.
      apply idpath.
    - intros a b f ; cbn.
      rewrite id2_rwhisker, id2_left, id2_right.
      apply idpath.
    - intros a b f ; cbn.
      rewrite lwhisker_id2, id2_left, id2_right, runitor_lunitor_identity.
      apply idpath.
    - intros a b c d f g h ; cbn.
      rewrite id2_right.
      rewrite lunitor_triangle.
      rewrite lunitor_is_lunitor_lwhisker.
      apply idpath.
    - intros a b c f g h α ; cbn.
      rewrite lwhisker_id2, id2_left, id2_right.
      apply idpath.
    - intros a b c f g h α ; cbn.
      rewrite id2_rwhisker, id2_left, id2_right.
      apply idpath.
  Qed.

  Definition constant_invertible_cells
    : invertible_cells constant_data.
  Proof.
    split.
    - intro a ; cbn.
      is_iso.
    - intros a b c f g ; cbn.
      is_iso.
  Defined.

  Definition constant : psfunctor B₁ B₂.
  Proof.
    use make_psfunctor.
    - exact constant_data.
    - exact constant_laws.
    - exact constant_invertible_cells.
  Defined.
End Constant.


Require Import ClassicalFacts Classical_Prop ProofIrrelevanceFacts.

Lemma classical_proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2.
Proof. apply proof_irrelevance_cci. intros. apply Classical_Prop.classic. Qed.

Module PI. Definition proof_irrelevance := classical_proof_irrelevance. End PI.

Module PIT := ProofIrrelevanceTheory(PI).
Export PIT.


Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import PeanoNat.
Require Import Lia.
Require Import Ensembles.

Require Import FO_Bi_Int_Syntax.
Require Import Set_FO_Bi_Int_calcs.
Require Import Set_FO_Bi_Int_logics.
Require Import Set_FO_Bi_Int_extens_interactions.
Require Import Set_FO_wBi_Int_meta_interactions.

Section sMeta.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

Lemma sThm_irrel : forall A B Γ, sFOBIC_rules (Γ, A --> (B --> A)).
Proof.
intros. apply sFOBIC_extens_wFOBIC. apply wThm_irrel.
Qed.

Lemma simp_Id_gen : forall A Γ, sFOBIC_rules (Γ, A --> A).
Proof.
intros. apply sFOBIC_extens_wFOBIC. apply wimp_Id_gen.
Qed.

Lemma scomm_And_obj : forall A B Γ, (sFOBIC_rules (Γ, A ∧ B --> B ∧ A)).
Proof.
intros. apply sFOBIC_extens_wFOBIC. apply comm_And_obj.
Qed.

Lemma sContr_Bot : forall A Γ, sFOBIC_rules (Γ, A ∧ (¬ A) --> (⊥)).
Proof.
intros. apply sFOBIC_extens_wFOBIC. apply wContr_Bot.
Qed.

Lemma sEFQ : forall A Γ, sFOBIC_rules (Γ, (⊥) --> A).
Proof.
intros. apply sFOBIC_extens_wFOBIC. apply wEFQ.
Qed.

Lemma smonotR_Or : forall A B Γ, (sFOBIC_rules (Γ, A --> B)) ->
    (forall C, sFOBIC_rules (Γ, (A ∨ C) --> (B ∨ C))).
Proof.
intros A B Γ D C.
apply MPs with (ps:=[(Γ, (C --> B ∨ C) --> (A ∨ C --> B ∨ C));(Γ,(C --> B ∨ C))]).
2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, (A --> B ∨ C) --> (C --> B ∨ C) --> (A ∨ C --> B ∨ C));(Γ,(A --> B ∨ C))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists A. exists C.
exists (B ∨ C). auto. inversion H1. subst.
apply MPs with (ps:=[(Γ, (B --> B ∨ C) --> (A --> B ∨ C));(Γ,((B --> B ∨ C)))]).
2: apply MPRule_I. intros. inversion H2. subst.
apply MPs with (ps:=[(Γ, (A --> B) --> (B --> B ∨ C) --> (A --> 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 (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 Γ,
    (sFOBIC_rules (Γ, A --> B)) ->
    (forall C, sFOBIC_rules (Γ, (C ∨ A) --> (C ∨ B))).
Proof.
intros A B Γ D C.
apply MPs with (ps:=[(Γ, (A --> C ∨ B) --> ((C ∨ A) --> (C ∨ B)));(Γ,(A --> C ∨ B))]).
2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, (C --> C ∨ B) --> (A --> C ∨ B) --> ((C ∨ A) --> (C ∨ B)));(Γ,(C --> C ∨ B))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists C. exists A.
exists (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 --> C ∨ B) --> (A --> C ∨ B));(Γ,((B --> C ∨ B)))]).
2: apply MPRule_I. intros. inversion H1. subst.
apply MPs with (ps:=[(Γ, (A --> B) --> (B --> C ∨ B) --> (A --> 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 (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 Γ, (sFOBIC_rules (Γ, A ∨ B --> B ∨ A)).
Proof.
intros. apply sFOBIC_extens_wFOBIC. apply comm_Or_obj.
Qed.

Lemma scomm_Or : forall A B Γ,
    (sFOBIC_rules (Γ, A ∨ B)) ->
    (sFOBIC_rules (Γ, B ∨ A)).
Proof.
intros A B Γ D.
apply MPs with (ps:=[(Γ, A ∨ B --> B ∨ A);(Γ, 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 Γ,
    (sFOBIC_rules (Γ, A --> B)) ->
    (forall C, sFOBIC_rules (Γ, (A ∨ C) --> (C ∨ B))).
Proof.
intros A B Γ D C.
apply MPs with (ps:=[(Γ, (C --> C ∨ B) --> (A ∨ C --> C ∨ B));(Γ, C --> C ∨ B)]).
2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, (A --> C ∨ B) --> (C --> C ∨ B) --> (A ∨ C --> C ∨ B));(Γ, A --> C ∨ B)]).
2: apply MPRule_I. intros. inversion H0. subst. apply Axs.
apply AxRule_I. apply RA4_I. exists A. exists C. exists (C ∨ B). auto.
inversion H1. subst.
apply MPs with (ps:=[(Γ, (B --> C ∨ B) --> (A --> C ∨ B));(Γ, B --> C ∨ B)]).
2: apply MPRule_I. intros. inversion H2. subst.
apply MPs with (ps:=[(Γ, (A --> B) --> (B --> C ∨ B) --> (A --> 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 (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 Γ,
    (sFOBIC_rules (Γ, A ∨ (⊥))) ->
    (sFOBIC_rules (Γ, A)).
Proof.
intros A Γ D.
apply MPs with (ps:=[(Γ, (A ∨ ⊥) --> A);(Γ, A ∨ (⊥))]).
2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, (⊥ --> A) --> (A ∨ (⊥) --> A));(Γ, (⊥ --> A))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Γ, (A --> A) --> (⊥ --> A) --> (A ∨ (⊥) --> A));(Γ, A --> A)]).
2: apply MPRule_I. intros. inversion H1. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists A. exists (⊥).
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 Γ,
  (sFOBIC_rules (Γ, (A --< B) --> C) ->
      sFOBIC_rules (Γ, A --> (B ∨ C))) *
  (sFOBIC_rules (Γ, A --> (B ∨ C)) ->
      sFOBIC_rules (Γ, (A --< B) --> C)).
Proof.
intros A B C Γ. split.
- intro D. pose (@smonot_Or2 (A --< B) C Γ D B).
  apply MPs with (ps:=[(Γ, ((A --< B) ∨ B --> B ∨ C) --> (A --> B ∨ C));(Γ,(A --< B) ∨ B --> B ∨ C)]).
  2: apply MPRule_I. intros. inversion H. subst.
  apply MPs with (ps:=[(Γ, (A --> (A --< B) ∨ B) --> ((A --< B) ∨ B --> B ∨ C) --> (A --> B ∨ C));(Γ,(A --> (A --< B) ∨ B))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Axs.
  apply AxRule_I. apply RA1_I. exists A. exists ((A --< B) ∨ B). exists (B ∨ C). auto.
  inversion H1. subst.
  apply MPs with (ps:=[(Γ, (B ∨ (A --< B) --> (A --< B) ∨ B) --> (A --> (A --< B) ∨ B));(Γ,(B ∨ (A --< B) --> (A --< B) ∨ B))]).
  2: apply MPRule_I. intros. inversion H2. subst.
  apply MPs with (ps:=[(Γ, (A --> B ∨ (A --< B)) --> (B ∨ (A --< B) --> (A --< B) ∨ B) --> (A --> (A --< B) ∨ B));(Γ,(A --> B ∨ (A --< B)))]).
  2: apply MPRule_I. intros. inversion H3. subst. apply Axs.
  apply AxRule_I. apply RA1_I. exists A. exists (B ∨ (A --< B)). exists ((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:=[(Γ, ((C ∨ (A --< (B ∨ C))) --> C) --> ((A --< B) --> C));(Γ, (C ∨ (A --< (B ∨ C))) --> C)]).
  2: apply MPRule_I. intros. inversion H. subst.
  apply MPs with (ps:=[(Γ, ((A --< B) --> (C ∨ (A --< (B ∨ C)))) --> ((C ∨ (A --< (B ∨ C))) --> C) --> ((A --< B) --> C));(Γ, (A --< B) --> (C ∨ (A --< (B ∨ C))))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Axs. apply AxRule_I. apply RA1_I.
  exists (A --< B). exists (C ∨ (A --< (B ∨ C))). exists C. auto. inversion H1. subst.
  apply MPs with (ps:=[(Γ, ((C ∨ ((A --< B) --< C)) --> C ∨ (A --< (B ∨ C))) --> ((A --< B) --> C ∨ (A --< (B ∨ C))));(Γ, ((C ∨ ((A --< B) --< C)) --> C ∨ (A --< (B ∨ C))))]).
  2: apply MPRule_I. intros. inversion H2. subst.
  apply MPs with (ps:=[(Γ, ((A --< B) --> (C ∨ ((A --< B) --< C)))--> ((C ∨ ((A --< B) --< C)) --> C ∨ (A --< (B ∨ C))) --> ((A --< B) --> C ∨ (A --< (B ∨ C))));
  (Γ, ((A --< B) --> (C ∨ ((A --< B) --< C))))]).
  2: apply MPRule_I. intros. inversion H3. subst.
  apply Axs. apply AxRule_I. apply RA1_I. exists (A --< B). exists (C ∨ ((A --< B) --< C)).
  exists (C ∨ (A --< (B ∨ C))). auto. inversion H4. subst.
  apply Axs. apply AxRule_I. apply RA11_I. exists (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:=[(Γ, (C ∨ (⊥) --> C) --> (C ∨ (A --< (B ∨ C)) --> C));
  (Γ, (C ∨ (⊥) --> C))]). 2: apply MPRule_I. intros. inversion H1. subst.
  apply MPs with (ps:=[(Γ, (C ∨ (A --< (B ∨ C)) --> C ∨ (⊥)) --> (C ∨ (⊥) --> C) --> (C ∨ (A --< (B ∨ C)) --> C));
  (Γ, (C ∨ (A --< (B ∨ C)) --> C ∨ (⊥)))]). 2: apply MPRule_I. intros. inversion H2. subst.
  apply Axs. apply AxRule_I. apply RA1_I. exists (C ∨ (A --< (B ∨ C))).
  exists (C ∨ (⊥)). exists C. auto. inversion H3. subst. apply smonotL_Or.
  apply MPs with (ps:=[(Γ, (((∞ (A --> B ∨ C)) ∧ (¬ (∞ (A --> B ∨ C)))) --> ⊥) --> ((A --< (B ∨ C)) --> ⊥));
  (Γ, ((∞ (A --> B ∨ C)) ∧ (¬ (∞ (A --> (B ∨ C)))) --> ⊥))]). 2: apply MPRule_I. intros. inversion H4. subst.
  apply MPs with (ps:=[(Γ, ((A --< (B ∨ C)) --> ((∞ (A --> B ∨ C)) ∧ (¬ (∞ (A --> B ∨ C))))) --> (((∞ (A --> B ∨ C)) ∧ (¬ (∞ (A --> B ∨ C)))) --> ⊥) --> ((A --< (B ∨ C)) --> ⊥));
  (Γ, ((A --< (B ∨ C)) --> ((∞ (A --> B ∨ C)) ∧ (¬ (∞ (A --> B ∨ C))))))]). 2: apply MPRule_I. intros. inversion H5. subst.
  apply Axs. apply AxRule_I. apply RA1_I. exists (A --< (B ∨ C)).
  exists ((∞ (A --> B ∨ C)) ∧ (¬ (∞ (A --> B ∨ C)))). exists (⊥). auto. inversion H6.
  subst.
  apply MPs with (ps:=[(Γ, ((A --< (B ∨ C)) --> (¬ (∞ (A --> B ∨ C)))) --> ((A --< (B ∨ C)) --> (∞ (A --> B ∨ C)) ∧ (¬ (∞ (A --> B ∨ C)))));
  (Γ, ((A --< (B ∨ C)) --> (¬ (∞ (A --> B ∨ C)))))]). 2: apply MPRule_I. intros. inversion H7. subst.
  apply MPs with (ps:=[(Γ, ((A --< (B ∨ C)) --> (∞ (A --> B ∨ C))) --> ((A --< (B ∨ C)) --> (¬ (∞ (A --> B ∨ C)))) --> ((A --< (B ∨ C)) --> (∞ (A --> B ∨ C)) ∧ (¬ (∞ (A --> B ∨ C)))));
  (Γ, ((A --< (B ∨ C)) --> (∞ (A --> B ∨ C))))]). 2: apply MPRule_I. intros. inversion H8. subst.
  apply Axs. apply AxRule_I. apply RA7_I. exists (A --< (B ∨ C)).
  exists (∞ (A --> B ∨ C)). exists (¬ (∞ (A --> B ∨ C))). auto. inversion H9. subst.
  apply Axs. apply AxRule_I. apply RA12_I. exists A. exists (B ∨ C).
  auto. inversion H10. inversion H8. inversion H9. subst.
  apply MPs with (ps:=[(Γ, (¬ (∞ (A --> B ∨ C))) --> ((A --< (B ∨ C)) --> ¬ (∞ (A --> B ∨ C))));
  (Γ, (¬ (∞ (A --> B ∨ C))))]). 2: apply MPRule_I. intros. inversion H9. subst.
  apply sThm_irrel. inversion H11. subst. apply DNs with (ps:=[(Γ, A --> 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:=[(Γ, (⊥ --> C) --> (C ∨ (⊥) --> C));(Γ, (⊥ --> C))]).
  2: apply MPRule_I. intros. inversion H3. subst.
  apply MPs with (ps:=[(Γ, (C --> C) --> (⊥ --> C) --> (C ∨ (⊥) --> C));(Γ, (C --> C))]).
  2: apply MPRule_I. intros. inversion H4. subst. apply Axs.
  apply AxRule_I. apply RA4_I. exists C. exists (⊥). 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,
  (sFOBIC_rules ((Empty_set form), (A --< B) --> C) ->
      sFOBIC_rules (Empty_set _, A --> ((B ∨ C)))) *
  (sFOBIC_rules (Empty_set _, A --> ((B ∨ C))) ->
      sFOBIC_rules (Empty_set _, (A --< B) --> C)).
Proof.
intros A B C. apply sdual_residuation_gen.
Qed.

Theorem sFOBIC_Detachment_Theorem : forall s,
           (sFOBIC_rules s) ->
           (forall A B Γ, (fst s = Γ) ->
                          (snd s = A --> B) ->
                          sFOBIC_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 form Γ0 (Singleton form A), A --> B);(Union form Γ0 (Singleton form A), A)]).
  2: apply MPRule_I. intros. inversion H1. subst. apply Ids.
  apply IdRule_I. apply Union_introl ; auto. inversion H2. subst.
  apply Ids. apply IdRule_I. 2: inversion H3. apply Union_intror. apply In_singleton.
(* Axs *)
- intros A B Γ id1 id2. inversion H. subst. simpl in id2. subst. simpl.
  apply MPs with (ps:=[(Union form Γ0 (Singleton form A), A --> B);(Union form Γ0 (Singleton form 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) :: nil)). 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 (A --> B) Γ0 J1 J2).
  assert (sFOBIC_rules (Γ0, A --> B)).
  assert (J02: List.In (Γ0, A0) ((Γ0, A0 --> A --> B) :: (Γ0, A0) :: nil)). apply in_cons. apply in_eq.
  pose (H (Γ0, A0) J02).
  apply MPs with (ps:=[(Γ0, A0 --> A --> B); (Γ0, A0)]) ; auto.
  assert (J3: (forall A1 : form, In _ (fst (Union form Γ0 (Singleton form A0), A --> B)) A1 -> sFOBIC_rules (Γ0, A1))).
  intro. simpl. intro. inversion H3. apply Ids. apply IdRule_I. auto. subst.
  inversion H4. subst. apply H. apply in_cons ; apply in_eq.
  pose (sFOBIC_comp (Union form Γ0 (Singleton form A0), A --> B) s Γ0 J3). simpl in s0.
  apply MPs with (ps:=[(Union form Γ0 (Singleton form A), A --> B);(Union form Γ0 (Singleton form A), A)]). 2: apply MPRule_I.
  intros. inversion H3.
  pose (sFOBIC_monot (Γ0, A --> B) s0 (Union form Γ0 (Singleton form A))). simpl in s1. subst.
  apply s1. intro. intro. apply Union_introl. auto.
  inversion H4. subst. 2: inversion H5. apply Ids. apply IdRule_I. apply Union_intror. apply In_singleton.
(* DNs *)
- intros A B Γ id1 id2. inversion H1. subst. simpl in id2. subst. inversion id2. subst. simpl.
  assert (J01: List.In (Γ0, A0) ((Γ0, A0) :: nil)). apply in_eq. apply H in J01. remember (Union form Γ0 (Singleton form (∞ A0))) as Γ.
  apply MPs with (ps:=[(Γ, ((∞ A0) ∧ (¬ (∞ A0))) --> ⊥); (Γ, (∞ A0) ∧ (¬ (∞ A0)))]).
  2: apply MPRule_I. intros. inversion H2. rewrite <- H3. apply sContr_Bot. inversion H3.
  rewrite <- H4.
  apply MPs with (ps:=[(Γ,(⊤ -->  ((∞ A0) ∧ (¬ (∞ A0)))));(Γ, ⊤)]).
  2: apply MPRule_I. intros. inversion H5. rewrite <- H6.
  apply MPs with (ps:=[(Γ,(⊤ --> (¬ (∞ A0))) -->(⊤ -->  ((∞ A0) ∧ (¬ (∞ A0)))));(Γ, ⊤ --> (¬ (∞ A0)))]).
  2: apply MPRule_I. intros. inversion H7. rewrite <- H8.
  apply MPs with (ps:=[(Γ,(⊤ --> (∞ A0)) --> (⊤ --> (¬ (∞ A0))) --> (⊤ --> ((∞ A0) ∧ (¬ (∞ A0)))));(Γ, ⊤ --> (∞ A0))]).
  2: apply MPRule_I. intros. inversion H9. rewrite <- H10. apply Axs. apply AxRule_I.
  apply RA7_I. exists (⊤). exists (∞ A0). exists (¬ (∞ A0)). auto. inversion H10. 2: inversion H11.
  rewrite <- H11.
  apply MPs with (ps:=[(Γ, ∞ A0 --> ⊤ --> ∞ A0);(Γ, ∞ 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:=[(Γ, ¬ (∞ A0) --> ⊤ --> ¬ (∞ A0));(Γ, ¬ (∞ 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)]). 2: apply DNsRule_I. intros. inversion H13. subst.
  pose (sFOBIC_monot _ J01). simpl in s. pose (s (Union form Γ0 (Singleton _ (∞ A0)))). simpl in s0.
  apply s0. intro ; intro. apply Union_introl ; auto. inversion H14.
  inversion H9. inversion H6. subst. apply sFOBIC_extens_wFOBIC. apply wTop. inversion H7. inversion H4.
(* Gens *)
- intros A B Γ id1 id2. inversion H1. subst. simpl. inversion id2.
(* ECs *)
- intros A B Γ id1 id2. inversion H1. subst. simpl. inversion id2. subst.
  assert (J01: List.In (fun x : form => exists B : form, x = B[↑] /\ In form Γ0 B, A0 --> B[↑]) ((fun x : form => exists B : form, x = B[↑] /\ In form Γ0 B, A0 --> B[↑]) :: nil)). apply in_eq.
  apply H in J01. apply MPs with (ps:=[(Union form Γ0 (Singleton form (∃ A0)), (∃ A0) --> B);(Union form Γ0 (Singleton form (∃ A0)), ∃ A0)]). 2: apply MPRule_I.
  intros. inversion H2. subst. assert (sFOBIC_rules (Γ0, (∃ A0) --> B)).
  apply ECs with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ0 B, A0 --> B[↑])]). 2: apply ECRule_I. intros.
  inversion H3. subst. auto. inversion H4.
  pose (sFOBIC_monot (Γ0, (∃ A0) --> B) H3 (Union form Γ0 (Singleton form (∃ A0)))). simpl in s. apply s.
  intro. intro. apply Union_introl ; auto.
  inversion H3. subst. 2: inversion H4. apply Ids. apply IdRule_I.
  apply Union_intror ; apply In_singleton.
Qed.

Theorem gen_sFOBIC_Detachment_Theorem : forall A B Γ,
  spair_der (Γ, Singleton _ (A --> B)) ->
      spair_der (Union form Γ (Singleton form A),  Singleton _ B).
Proof.
intros A B Γ spair. unfold spair_der. exists [B]. repeat split.
apply NoDup_cons. intro. inversion H. apply NoDup_nil. intros. inversion H ; auto.
subst. simpl. apply In_singleton. inversion H0.
apply MPs with (ps:=[ (Union form Γ (Singleton form A), B --> (B ∨ ⊥)); (Union form Γ (Singleton form A), B)]).
2: apply MPRule_I. intros. inversion H. subst. apply Axs. apply AxRule_I. apply RA2_I.
exists B. exists (⊥). auto. inversion H0. subst. 2: inversion H1.
destruct spair. destruct H1. destruct H2. simpl in H3. destruct x.
apply MPs with (ps:=[(Union form Γ (Singleton form A), ⊥ --> B);(Union form Γ (Singleton form A), ⊥)]).
2: apply MPRule_I. intros. inversion H4. subst. apply sEFQ. inversion H5. subst. 2: inversion H6.
simpl in H3. apply sFOBIC_monot with (Γ1:= Union form Γ (Singleton form A)) in H3. simpl in H3. auto.
simpl. intro. intro. apply Union_introl ; auto.
destruct x. simpl in H3. assert (f=A --> B). pose (H2 f). assert (List.In f (f :: nil)). apply in_eq.
apply i in H4. inversion H4. auto. subst. apply sabsorp_Or1 in H3.
assert (J1: Γ = Γ). reflexivity.
assert (J2: A --> B = A --> B). reflexivity.
pose (sFOBIC_Detachment_Theorem (Γ, A --> B) H3 A B Γ J1 J2). assumption.
exfalso. simpl in H1. inversion H1. apply H6. subst. pose (H2 f).
assert (List.In f (f :: f0 :: x)). apply in_eq. pose (i H4). inversion i0. subst.
pose (H2 f0). assert (List.In f0 (A --> B :: f0 :: x)). apply in_cons. apply in_eq.
pose (i1 H5). inversion i2. subst. apply in_eq.
Qed.

Lemma sDN_to_form : forall A Γ, (sFOBIC_rules (Γ, ¬ (∞ A)--> A)).
Proof.
intros A Γ. apply sFOBIC_extens_wFOBIC. apply wDN_to_form.
Qed.

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

Lemma sExcl_mon : forall A B C,
  (sFOBIC_rules (Empty_set _, A --> B)) ->
  (sFOBIC_rules (Empty_set _, (A --< C) --> (B --< C))).
Proof.
intros. apply sdual_residuation.
apply MPs with (ps:=[(Empty_set _, (B --> C ∨ (B --< C)) --> (A --> C ∨ (B --< C)));
(Empty_set _, (B --> C ∨ (B --< C)))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Empty_set _, (A --> B) --> (B --> C ∨ (B --< C)) --> (A --> C ∨ (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 (C ∨ (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,
  (sFOBIC_rules (Empty_set _, A --> B)) ->
  (sFOBIC_rules (Empty_set _, (C --< B) --> (C --< A))).
Proof.
intros. apply sdual_residuation.
apply MPs with (ps:=[(Empty_set _, (A ∨ (C --< A) --> B ∨ (C --< A)) --> (C --> B ∨ (C --< A)));
(Empty_set _, (A ∨ (C --< A) --> B ∨ (C --< A)))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Empty_set _, (C --> A ∨ (C --< A)) --> (A ∨ (C --< A) --> B ∨ (C --< A)) --> (C --> B ∨ (C --< A)));
(Empty_set _, C --> A ∨ (C --< A))]).
2: apply MPRule_I. intros. inversion H1. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists C. exists (A ∨ (C --< A)).
exists (B ∨ (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 _, ((C --< A) --> B ∨ (C --< A)) --> (A ∨ (C --< A) --> B ∨ (C --< A)));
(Empty_set _, ((C --< A) --> B ∨ (C --< A)))]).
2: apply MPRule_I. intros. inversion H2. subst.
apply MPs with (ps:=[(Empty_set _, (A --> B ∨ (C --< A)) --> ((C --< A) --> B ∨ (C --< A)) --> (A ∨ (C --< A) --> B ∨ (C --< A)));
(Empty_set _, (A --> B ∨ (C --< A)))]).
2: apply MPRule_I. intros. inversion H3. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists A. exists (C --< A).
exists (B ∨ (C --< A)). auto. inversion H4. subst.
apply MPs with (ps:=[(Empty_set _, (B --> B ∨ (C --< A)) --> (A --> B ∨ (C --< A)));
(Empty_set _, (B --> B ∨ (C --< A)))]).
2: apply MPRule_I. intros. inversion H5. subst.
apply MPs with (ps:=[(Empty_set _, (A --> B) --> (B --> B ∨ (C --< A)) --> (A --> B ∨ (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 (B ∨ (C --< A)). auto. inversion H7. subst. assumption. inversion H8.
inversion H6. subst.
apply Axs. apply AxRule_I. apply RA2_I. exists B. exists (C --< A). auto.
inversion H7. inversion H5. inversion H3. subst.
apply Axs. apply AxRule_I. apply RA3_I. exists B. exists (C --< A). auto.
inversion H4. inversion H2.
Qed.

Lemma sOr_Neg : forall A B C Γ,
  (sFOBIC_rules (Γ, A --> (B ∨ C))) ->
  (sFOBIC_rules (Γ, ((¬ B) ∧ A) --> C)).
Proof.
intros.
apply MPs with (ps:=[(Γ, (((¬ B) ∧ (B ∨ C)) --> C) --> ((¬ B) ∧ A --> C));(Γ, (¬ B) ∧ (B ∨ C) --> C)]).
2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Γ, (((¬ B) ∧ A) --> ((¬ B) ∧ (B ∨ C))) --> (((¬ B) ∧ (B ∨ C)) --> C) --> ((¬ B) ∧ A --> C));
(Γ, (((¬ B) ∧ A) --> ((¬ B) ∧ (B ∨ C))))]).
2: apply MPRule_I. intros. inversion H1. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists ((¬ B) ∧ A). exists ((¬ B) ∧ (B ∨ C)).
exists C. auto. inversion H2. subst.
apply MPs with (ps:=[(Γ, ((¬ B) ∧ A --> (B ∨ C)) --> ((¬ B) ∧ A --> (¬ B) ∧ (B ∨ C)));
(Γ, ((¬ B) ∧ A --> (B ∨ C)))]).
2: apply MPRule_I. intros. inversion H3. subst.
apply MPs with (ps:=[(Γ, ((¬ B) ∧ A --> (¬ B)) --> ((¬ B) ∧ A --> (B ∨ C)) --> ((¬ B) ∧ A --> (¬ B) ∧ (B ∨ C)));
(Γ, ((¬ B) ∧ A --> (¬ B)))]).
2: apply MPRule_I. intros. inversion H4. subst.
apply Axs. apply AxRule_I. apply RA7_I. exists ((¬ B) ∧ A). exists (¬ B).
exists (B ∨ C). auto. inversion H5. subst.
apply Axs. apply AxRule_I. apply RA5_I. exists (¬ B). exists A. auto.
inversion H6. inversion H4. subst.
apply MPs with (ps:=[(Γ, (A --> B ∨ C) --> ((¬ B) ∧ A --> B ∨ C));
(Γ, (A --> B ∨ C))]).
2: apply MPRule_I. intros. inversion H5. subst.
apply MPs with (ps:=[(Γ, ((¬ B) ∧ A --> A) --> (A --> B ∨ C) --> ((¬ B) ∧ A --> B ∨ C));
(Γ, ((¬ B) ∧ A --> A))]).
2: apply MPRule_I. intros. inversion H6. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists ((¬ B) ∧ A). exists A.
exists (B ∨ C). auto. inversion H7. subst.
apply Axs. apply AxRule_I. apply RA6_I. exists (¬ B). exists A. auto.
inversion H8. inversion H6. subst. assumption. inversion H7. inversion H5. inversion H3. inversion H1. subst.
apply MPs with (ps:=[(Γ, ((B ∨ C) ∧ (¬ B) --> C) --> ((¬ B) ∧ (B ∨ C) --> C));
(Γ, ((B ∨ C) ∧ (¬ B) --> C))]).
2: apply MPRule_I. intros. inversion H2. subst.
apply MPs with (ps:=[(Γ, ((¬ B) ∧ (B ∨ C) --> (B ∨ C) ∧ (¬ B)) --> ((B ∨ C) ∧ (¬ B) --> C) --> ((¬ B) ∧ (B ∨ C) --> C));
(Γ, (¬ B) ∧ (B ∨ C) --> (B ∨ C) ∧ (¬ B))]).
2: apply MPRule_I. intros. inversion H3. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists ((¬ B) ∧ (B ∨ C)). exists ((B ∨ C) ∧ (¬ B)).
exists C. auto. inversion H4. subst.
apply MPs with (ps:=[(Γ, ((¬ B) ∧ (B ∨ C) --> (¬ B)) --> ((¬ B) ∧ (B ∨ C) --> (B ∨ C) ∧ (¬ B)));
(Γ, ((¬ B) ∧ (B ∨ C) --> (¬ B)))]).
2: apply MPRule_I. intros. inversion H5. subst.
apply MPs with (ps:=[(Γ, ((¬ B) ∧ (B ∨ C) --> (B ∨ C)) --> ((¬ B) ∧ (B ∨ C) --> (¬ B)) --> ((¬ B) ∧ (B ∨ C) --> (B ∨ C) ∧ (¬ B)));
(Γ, ((¬ B) ∧ (B ∨ C) --> (B ∨ C)))]).
2: apply MPRule_I. intros. inversion H6. subst.
apply Axs. apply AxRule_I. apply RA7_I. exists ((¬ B) ∧ (B ∨ C)). exists (B ∨ C).
exists (¬ B). auto. inversion H7. subst.
apply Axs. apply AxRule_I. apply RA6_I. exists (¬ B). exists (B ∨ C).
auto. inversion H8. inversion H6. subst.
apply Axs. apply AxRule_I. apply RA5_I. exists (¬ B). exists (B ∨ C).
auto. inversion H7. inversion H5. inversion H3. subst.
apply MPs with (ps:=[(Γ, ((B ∨ C) --> (¬ B) --> C) --> ((B ∨ C) ∧ (¬ B) --> C));
(Γ, ((B ∨ C) --> (¬ B) --> C))]).
2: apply MPRule_I. intros. inversion H4. subst.
apply Axs. apply AxRule_I. apply RA8_I. exists (B ∨ C). exists (¬ B). exists C.
auto. inversion H5. subst.
apply MPs with (ps:=[(Γ, (C --> ¬ B --> C) --> (B ∨ C --> ¬ B --> C));
(Γ, (C --> ¬ B --> C))]).
2: apply MPRule_I. intros. inversion H6. subst.
apply MPs with (ps:=[(Γ, (B --> ¬ B --> C) --> (C --> ¬ B --> C) --> (B ∨ C --> ¬ B --> C));
(Γ, (B --> ¬ B --> C))]).
2: apply MPRule_I. intros. inversion H7. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists B. exists C.
exists (¬ B --> C). auto. inversion H8. subst.
apply MPs with (ps:=[(Γ, ((B ∧ (¬ B)) --> C) --> (B --> ¬ B --> C));
(Γ, ((B ∧ (¬ B)) --> C))]).
2: apply MPRule_I. intros. inversion H9. subst.
apply Axs. apply AxRule_I. apply RA9_I. exists B. exists (¬ B). exists C.
auto. inversion H10. subst.
apply MPs with (ps:=[(Γ, (⊥ --> C) --> (B ∧ (¬ B) --> C));
(Γ, (⊥ --> C))]).
2: apply MPRule_I. intros. inversion H11. subst.
apply MPs with (ps:=[(Γ, (B ∧ (¬ B) --> ⊥) --> (⊥ --> C) --> (B ∧ (¬ B) --> C));
(Γ, (B ∧ (¬ B) --> ⊥))]).
2: apply MPRule_I. intros. inversion H12. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists (B ∧ (¬ B)). exists (⊥).
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 Γ,
  (sFOBIC_rules (Γ, ((∞ A) --> B))) ->
  (sFOBIC_rules (Γ, (⊤ --< A) --> B)).
Proof.
intros A B Γ D. apply MPs with (ps:=[(Γ, (∞ A --> B) --> ((⊤ --< A) --> B));
(Γ, (∞ A --> B))]). 2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, ((⊤ --< A) --> ∞ A) --> (∞ A --> B) --> (⊤ --< A) --> B);
(Γ, ((⊤ --< A) --> ∞ A))]). 2: apply MPRule_I. intros. inversion H0. subst.
apply Axs. apply AxRule_I.
apply RA1_I. exists (⊤ --< A). exists (∞ 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 Γ,
  (sFOBIC_rules (Γ, (⊤ --< A) --> B)) ->
  (sFOBIC_rules (Γ, ((∞ A) --> B))).
Proof.
intros A B Γ D. apply MPs with (ps:=[(Γ, ((⊤ --< A) --> B) --> ((∞ A) --> B));
(Γ, ((⊤ --< A) --> B))]). 2: apply MPRule_I. intros. inversion H. subst.
apply MPs with (ps:=[(Γ, ((∞ A) --> ⊤ --< A) --> ((⊤ --< A) --> B) --> (∞ A) --> B);
(Γ, ((∞ A) --> ⊤ --< A))]). 2: apply MPRule_I. intros. inversion H0. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists (∞ A). exists (⊤ --< 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 Γ,
  (sFOBIC_rules (Γ, A --> (⊤ --< B))) ->
  (sFOBIC_rules (Γ, A --> (∞ B))).
Proof.
intros. apply MPs with (ps:=[(Γ, ((⊤ --< B) --> ∞ B) --> (A --> ∞ B));
(Γ, ((⊤ --< B) --> ∞ B))]). 2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Γ, (A --> ⊤ --< B) --> ((⊤ --< B) --> ∞ B) --> (A --> ∞ B));
(Γ, (A --> ⊤ --< B))]). 2: apply MPRule_I. intros. inversion H1. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists A. exists (⊤ --< B). exists (∞ 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 Γ,
  (sFOBIC_rules (Γ, A --> ((B ∨ C) ∨ D))) ->
  (sFOBIC_rules (Γ, A --> (B ∨ (C ∨ D)))).
Proof.
intros.
apply MPs with (ps:=[(Γ, ((B ∨ C) ∨ D --> B ∨ (C ∨ D)) --> (A --> B ∨ (C ∨ D)));
(Γ, ((B ∨ C) ∨ D --> B ∨ (C ∨ D)))]). 2: apply MPRule_I. intros. inversion H0. subst.
apply MPs with (ps:=[(Γ, (A --> (B ∨ C) ∨ D) --> ((B ∨ C) ∨ D --> B ∨ (C ∨ D)) --> (A --> B ∨ (C ∨ D)));
(Γ, (A --> (B ∨ C) ∨ D))]). 2: apply MPRule_I. intros. inversion H1. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists A. exists ((B ∨ C) ∨ D).
exists (B ∨ (C ∨ D)). auto. inversion H2. subst.
assumption. inversion H3. inversion H1. subst.
apply MPs with (ps:=[(Γ, (D --> B ∨ (C ∨ D)) --> ((B ∨ C) ∨ D --> B ∨ (C ∨ D)));
(Γ, (D --> B ∨ (C ∨ D)))]). 2: apply MPRule_I. intros. inversion H2. subst.
apply MPs with (ps:=[(Γ, ((B ∨ C) --> B ∨ (C ∨ D)) --> (D --> B ∨ (C ∨ D)) --> ((B ∨ C) ∨ D --> B ∨ (C ∨ D)));
(Γ, ((B ∨ C) --> B ∨ (C ∨ D)))]). 2: apply MPRule_I. intros. inversion H3. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists (B ∨ C).
exists D. exists (B ∨ (C ∨ D)). auto. inversion H4. subst.
apply MPs with (ps:=[(Γ, (C --> B ∨ (C ∨ D)) --> (B ∨ C --> B ∨ (C ∨ D)));
(Γ, C --> B ∨ (C ∨ D))]). 2: apply MPRule_I. intros. inversion H5. subst.
apply MPs with (ps:=[(Γ, (B --> B ∨ (C ∨ D)) --> (C --> B ∨ (C ∨ D)) --> (B ∨ C --> B ∨ (C ∨ D)));
(Γ, B --> B ∨ (C ∨ D))]). 2: apply MPRule_I. intros. inversion H6. subst.
apply Axs. apply AxRule_I. apply RA4_I. exists B. exists C.
exists (B ∨ (C ∨ D)). auto. inversion H7. subst.
apply Axs. apply AxRule_I. apply RA2_I. exists B. exists (C ∨ D). auto. inversion H8.
inversion H6. subst.
apply MPs with (ps:=[(Γ, ((C ∨ D) --> B ∨ (C ∨ D)) --> (C --> B ∨ (C ∨ D)));
(Γ, (C ∨ D) --> B ∨ (C ∨ D))]). 2: apply MPRule_I. intros. inversion H7. subst.
apply MPs with (ps:=[(Γ, (C --> (C ∨ D)) --> ((C ∨ D) --> B ∨ (C ∨ D)) --> (C --> B ∨ (C ∨ D)));
(Γ, (C --> (C ∨ D)))]). 2: apply MPRule_I. intros. inversion H8. subst.
apply Axs. apply AxRule_I. apply RA1_I. exists C. exists (C ∨ D).
exists (B ∨ (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 (C ∨ D). auto. inversion H9. inversion H7. inversion H5. inversion H3. subst.
apply MPs with (ps:=[(Γ, ((C ∨ D) --> B ∨ (C ∨ D)) --> (D --> B ∨ (C ∨ D)));
(Γ, ((C ∨ D) --> B ∨ (C ∨ D)))]). 2: apply MPRule_I. intros. inversion H4. subst.
apply MPs with (ps:=[(Γ, (D --> (C ∨ D)) --> ((C ∨ D) --> B ∨ (C ∨ D)) --> (D --> B ∨ (C ∨ D)));
(Γ, (D --> (C ∨ D)))]). 2: apply MPRule_I. intros. inversion H5. subst. apply Axs. apply AxRule_I. apply RA1_I. exists D. exists (C ∨ D).
exists (B ∨ (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 (C ∨ D). auto.
inversion H6. inversion H4. inversion H2.
Qed.

Lemma sClaim1 : forall A B Γ,
    (sFOBIC_rules (Γ, (¬ (A --< B)) --> ((∞ B) --> (∞ A)))).
Proof.
intros A B Γ. apply sFOBIC_extens_wFOBIC. apply wClaim1.
Qed.

Lemma sDN_dist_imp : forall A B Γ,
    (sFOBIC_rules (Γ, (¬ (∞ (A --> B))) --> ((¬ (∞ A)) --> (¬ (∞ B))))).
Proof.
intros A B Γ. apply sFOBIC_extens_wFOBIC. apply wDN_dist_imp.
Qed.

Lemma DN_dist_up : forall n A, (DN_form n A)[↑] = DN_form n A[↑].
Proof.
induction n.
- intros. simpl ; auto.
- intros. simpl. pose (IHn A). rewrite e. auto.
Qed.

Theorem sFOBIC_Deduction_Theorem : forall s,
           (sFOBIC_rules s) ->
           (forall A B Γ, (fst s = Union _ Γ (Singleton _ A)) ->
                          (snd s = B) ->
                          (exists n, sFOBIC_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. simpl. inversion H1. 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 _ Γ (Singleton _ A), A0 --> B0) ((Union _ Γ (Singleton _ A), A0 --> B0) :: (Union _ Γ (Singleton _ A), A0) :: nil)). apply in_eq.
  assert (J02: List.In (Union _ Γ (Singleton _ A), A0) ((Union _ Γ (Singleton _ A), A0 --> B0) :: (Union _ Γ (Singleton _ A), A0) :: nil)). 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 _ Γ (Singleton _ A), A0 --> B0) J01 A (A0 --> B0) Γ J1 J2).
  destruct e. subst.
  assert (J3: A0 = A0). reflexivity.
  pose (H0 (Union _ Γ (Singleton _ A), A0) J02 A A0 Γ J1 J3). destruct e.
  exists (max x x0).
  apply MPs with (ps:=[(Γ, ((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) ∧ A0 --> B0)]).
  2: apply MPRule_I. intros. inversion H4. subst.
  apply MPs with (ps:=[(Γ, ((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) ∧ A0 --> B0) --> ((DN_form (Init.Nat.max x x0) A) --> B0));(Γ, (DN_form (Init.Nat.max x x0) A) --> (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 ((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) --> (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) --> (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) --> ((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 _ Γ (Singleton _ A), A0) ((Union _ Γ (Singleton _ A), A0) :: nil)). apply in_eq.
  assert (J1: Union _ Γ (Singleton _ A) = Union _ Γ (Singleton _ A)). reflexivity.
  assert (J2: A0 = A0). reflexivity.
  pose (H0 (Union _ Γ (Singleton _ A), A0) J01 A A0 Γ J1 J2). destruct e.
  assert (DNsRule ((Γ, (DN_form x A) --> A0) :: nil) (Γ, ¬ (∞ (DN_form x A --> A0)))).
  apply DNsRule_I.
  assert (J3: (forall prem, List.In prem ((Γ, DN_form x A --> A0) :: nil) ->
  sFOBIC_rules prem)). intros. inversion H4. subst. 2: inversion H5. assumption.
  pose (DNs J3 H3).
  pose (sDN_dist_imp (DN_form x A) A0 Γ). exists (S x). simpl.
  apply MPs with (ps:=[(Γ, ¬ (∞ (DN_form x A --> A0)) --> ¬ (∞ (DN_form x A)) --> ¬ (∞ A0));
  (Γ, ¬ (∞ (DN_form x A --> A0)))]). 2: apply MPRule_I. intros. inversion H4. subst. 2: inversion H5.
  assumption. subst. assumption. inversion H6.
(* Gen *)
- intros A B Γ id1 id2. inversion H1. subst. simpl in id1. subst. simpl.
  assert (J1: sFOBIC_rules (fun x : form => exists B : form, x = B[↑] /\ In form (Union form Γ (Singleton form A)) B, A0)). apply H. apply in_eq.
  assert (exists n : nat, sFOBIC_rules (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, DN_form n (subst_form ↑ A) --> A0)).
  apply H0 with (prem:=(fun x : form => exists B : form, x = B[↑] /\ In form (Union form Γ (Singleton form A)) B, A0)) ; auto. apply in_eq.
  simpl. apply Extensionality_Ensembles. split ; intro ; intro. destruct H2. destruct H2. subst. inversion H3. subst. apply Union_introl.
  exists x0. split ; auto. subst. inversion H2. apply Union_intror. apply In_singleton. destruct H2. destruct H2. destruct H2. subst.
  exists x0. split ; auto. apply Union_introl ; auto. inversion H2. exists A. split ; auto. apply Union_intror ; apply In_singleton.
  destruct H2. exists x.
  apply MPs with (ps:=[(Γ, (∀ ((DN_form x A)[↑] --> A0)) --> (DN_form x A --> (∀ A0)));(Γ, ∀ ((DN_form x A)[↑] --> A0))]). 2: apply MPRule_I.
  intros. inversion H3. subst. apply Axs. apply AxRule_I. apply RA17_I. exists (DN_form x A). exists A0. auto. inversion H4.
  subst. 2: inversion H5. apply Gens with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, (DN_form x A)[↑] --> A0)]). 2: apply GenRule_I.
  intros. inversion H5. 2: inversion H6. subst. auto. simpl. rewrite DN_dist_up. auto.
(* EC *)
- intros A B Γ id1 id2. inversion H1. subst. simpl in id1. subst. simpl.
  assert (J1: sFOBIC_rules (fun x : form => exists B : form, x = B[↑] /\ In form (Union form Γ (Singleton form A)) B, A0 --> B0[↑])). apply H. apply in_eq.
  assert (exists n : nat, sFOBIC_rules (fun x : form => exists B : form, x = B[↑] /\ In form Γ B, DN_form n A[↑] --> A0 --> B0[↑])).
  apply H0 with (prem:=(fun x : form => exists B : form, x = B[↑] /\ In form (Union form Γ (Singleton form A)) B, A0 --> B0[↑])) ; auto. apply in_eq.
  apply Extensionality_Ensembles. split ; intro ; intro. destruct H2. destruct H2. subst. inversion H3. subst. apply Union_introl.
  exists x0. split ; auto. subst. inversion H2. apply Union_intror. apply In_singleton. destruct H2. destruct H2. destruct H2. subst.
  exists x0. split ; auto. apply Union_introl ; auto. inversion H2. exists A. split ; auto. apply Union_intror ; apply In_singleton.
  destruct H2. exists x.
  apply MPs with (ps:=[(Γ, ((DN_form x A ∧ (∃ A0)) --> B0) --> (DN_form x A --> (∃ A0) --> B0));(Γ, (DN_form x A ∧ (∃ A0)) --> B0)]). 2: apply MPRule_I.
  intros. inversion H3. subst. apply Axs. apply AxRule_I. apply RA9_I. exists (DN_form x A). exists (∃ A0). exists B0. auto. inversion H4.
  subst. 2: inversion H5.
  apply MPs with (ps:=[(Γ, (((∃ A0) ∧ DN_form x A) --> B0) --> (((DN_form x A) ∧ (∃ A0)) --> B0));(Γ, (∃ A0) ∧ (DN_form x A) --> B0)]). 2: apply MPRule_I.
  intros. inversion H5. subst.
  apply MPs with (ps:=[(Γ, (((DN_form x A) ∧ (∃ A0)) --> ((∃ A0) ∧ DN_form x A)) --> (((∃ A0) ∧ DN_form x A) --> B0) --> (((DN_form x A) ∧ (∃ A0)) --> B0));(Γ, (DN_form x A ∧ (∃ A0)) --> ((∃ A0) ∧ DN_form x A))]). 2: apply MPRule_I.
  intros. inversion H6. subst. apply Axs. apply AxRule_I. apply RA1_I. exists ((DN_form x A) ∧ (∃ A0)). exists ((∃ A0) ∧ DN_form x A). exists B0.
  auto. inversion H7. 2: inversion H8. subst. apply sFOBIC_extens_wFOBIC. apply comm_And_obj. inversion H6. 2: inversion H7. subst.
  apply MPs with (ps:=[(Γ, ((∃ A0) --> (DN_form x A) --> B0) --> ((∃ A0) ∧ (DN_form x A) --> B0));(Γ, (∃ A0) --> (DN_form x A) --> B0)]). 2: apply MPRule_I.
  intros. inversion H7. subst. apply Axs. apply AxRule_I. apply RA8_I. exists (∃ A0). exists (DN_form x A). exists B0. auto. inversion H8.
  2: inversion H9. subst. apply ECs with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, A0 --> ((DN_form x A) --> B0)[↑])]). 2: apply ECRule_I.
  intros. inversion H9. 2: inversion H10. subst. simpl.
  apply MPs with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, ((A0 ∧ DN_form x A[↑]) --> B0[↑]) --> A0 --> (DN_form x A)[↑] --> B0[↑]);(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, (A0 ∧ DN_form x A[↑]) --> B0[↑])]).
  2: apply MPRule_I. intros. inversion H10. subst. apply Axs. apply AxRule_I. apply RA9_I. exists A0. exists (DN_form x A[↑]). exists B0[↑]. rewrite DN_dist_up. auto.
  inversion H11. subst. 2: inversion H12.
  apply MPs with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, (DN_form x A[↑] ∧ A0 --> B0[↑]) --> (A0 ∧ DN_form x A[↑] --> B0[↑]));(fun x : form => exists B : form, x = B[↑] /\ In form Γ B,  DN_form x A[↑] ∧ A0 --> B0[↑])]).
  2: apply MPRule_I. intros. inversion H12. subst.
  apply MPs with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, ((A0 ∧ DN_form x A[↑] ) --> (DN_form x A[↑] ∧ A0)) --> (DN_form x A[↑] ∧ A0 --> B0[↑]) --> (A0 ∧ DN_form x A[↑] --> B0[↑]));(fun x : form => exists B : form, x = B[↑] /\ In form Γ B,  (A0 ∧ DN_form x A[↑] ) --> (DN_form x A[↑] ∧ A0))]).
  2: apply MPRule_I. intros. inversion H13. subst. apply Axs. apply AxRule_I. apply RA1_I. exists (A0 ∧ DN_form x A[↑]).
  exists (DN_form x A[↑] ∧ A0). exists B0[↑]. auto. inversion H14. 2: inversion H15. subst. apply sFOBIC_extens_wFOBIC. apply comm_And_obj.
  inversion H13. 2: inversion H14. subst.
  apply MPs with (ps:=[(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, (DN_form x A[↑] --> A0 --> B0[↑]) --> (DN_form x A[↑] ∧ A0 --> B0[↑]));(fun x : form => exists B : form, x = B[↑] /\ In form Γ B, DN_form x A[↑] --> A0 --> B0[↑])]).
  2: apply MPRule_I. intros. inversion H14. subst. apply Axs. apply AxRule_I. apply RA8_I. exists (DN_form x A[↑]).
  exists A0. exists B0[↑]. auto. inversion H15. 2: inversion H16. subst. auto.
Qed.

Theorem gen_sFOBIC_Deduction_Theorem : forall A B Γ,
  spair_der (Union _ Γ (Singleton _ A), Singleton _ B) ->
      (exists n, spair_der (Γ, Singleton _ ((DN_form n A) --> B))).
Proof.
intros A B Γ spair. unfold spair_der. simpl. destruct spair.
destruct H. destruct H0. simpl in H1. simpl in H0. destruct x.
- simpl in H1.
  assert (J1: Union form Γ (Singleton form A) = Union form Γ (Singleton form A)). reflexivity.
  assert (J2: ⊥ = ⊥). reflexivity.
  pose (sFOBIC_Deduction_Theorem (Union _ Γ (Singleton _ A), ⊥) H1 A (⊥) Γ 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. inversion H4.
  apply MPs with (ps:=[(Γ, (DN_form x A --> B) --> ((DN_form x A --> B) ∨ (⊥))); (Γ, (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 (⊥). auto. inversion H4. subst.
  apply MPs with (ps:=[(Γ, (⊥ --> B) --> (DN_form x A --> B));(Γ, ⊥ --> B)]).
  2: apply MPRule_I. intros. inversion H5. subst.
  apply MPs with (ps:=[(Γ, (DN_form x A --> ⊥) --> (⊥ --> B) --> (DN_form x A --> B));(Γ, DN_form x A --> ⊥)]).
  2: apply MPRule_I. intros. inversion H6. subst.
  apply Axs. apply AxRule_I. apply RA1_I. exists (DN_form x A). exists (⊥). 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 (f=B). pose (H0 f). assert (List.In f (f :: nil)). apply in_eq.
  apply i in H2. inversion H2 ; auto. subst. apply sabsorp_Or1 in H1.
  assert (J1: Union form Γ (Singleton form A) = Union form Γ (Singleton form A)). reflexivity.
  assert (J2: B = B). reflexivity.
  pose (sFOBIC_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. inversion H4.
  apply MPs with (ps:=[(Γ, (DN_form x A --> B) --> ((DN_form x A --> B) ∨ (⊥))); (Γ, (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 (⊥). auto. inversion H4. subst.
  assumption. inversion H5.
  exfalso. simpl in H0. inversion H. apply H4. subst. pose (H0 f).
  assert (List.In f (f :: f0 :: x)). apply in_eq. pose (i H2). inversion i0. subst.
  pose (H0 f0). assert (List.In f0 (f :: f0 :: x)). apply in_cons. apply in_eq.
  pose (i1 H3). inversion i2. subst. apply in_eq.
Qed.

End sMeta.


(** **********************************************************

Matthew Weaver, 2016

*************************************************************)

(** **********************************************************

Contents:

- Proof that Set / X and Set ^ X are equivalent as categories

************************************************************)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.
Require Import UniMath.CategoryTheory.categories.HSET.Slice.
Require Import UniMath.CategoryTheory.slicecat.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Local Open Scope cat.

Section set_slice_fam_equiv.

  Variable X : hSet.

  Local Definition slice (A : hSet) : category := slice_cat HSET A.

  Local Definition discrete (A : hSet) : discrete_category := discrete_category_hset A.

  Local Definition discrete_has_homsets (A : hSet) :
    has_homsets (discrete_category_hset A) := homset_property _.

  Local Definition fam (A : hSet) : category :=
    functor_category (discrete A) HSET.

  Local Definition make_fam (f : X → hSet) : functor (discrete X) HSET :=
    functor_path_pregroupoid _ (f : X → ob HSET).

  Definition slice_to_fam_fun (a : slice X) : fam X :=
    make_fam (λ x : X, hfiber_hSet (pr2 a) x).

  Local Notation s_to_f := slice_to_fam_fun.

  Definition slice_to_fam_mor_fun {a b : slice X} (f : a --> b) (x : X) :
    (s_to_f a : functor (discrete X) HSET) x --> (s_to_f b : functor (discrete X) HSET) x :=
    λ p, hfibersgftog (pr1 f) (pr2 b) _ (transportf (λ p, hfiber p x) (pr2 f) p).

  Definition is_nat_trans_slice_to_fam_mor {a b : slice X} (f : a --> b) :
    is_nat_trans (s_to_f a : functor (discrete X) HSET)
                 (s_to_f b : functor (discrete X) HSET)
                 (slice_to_fam_mor_fun f)
    := is_nat_trans_discrete_precategory (slice_to_fam_mor_fun f).

  Definition slice_to_fam_mor {a b : slice X} (f : a --> b) : s_to_f a --> s_to_f b :=
    (slice_to_fam_mor_fun f) ,, (is_nat_trans_slice_to_fam_mor f).

  Definition slice_to_fam_data : functor_data (slice X) (fam X) :=
    functor_data_constr _ _ slice_to_fam_fun (@slice_to_fam_mor).

  Lemma is_functor_slice_to_fam : is_functor slice_to_fam_data.
  Proof.
    split; [ intro a | intros a b c f g];
      apply (nat_trans_eq has_homsets_HSET);
      intro x;
      apply funextsec; intro p;
        apply (invmaponpathsincl pr1); simpl;
          try (apply isofhlevelfpr1;
               intro; apply setproperty);
          repeat (unfold hfiber; rewrite transportf_total2; simpl);
          repeat (rewrite transportf_const);
          reflexivity.
  Qed.

  Definition slice_to_fam : functor (slice X) (fam X) :=
    slice_to_fam_data ,, is_functor_slice_to_fam.

  Definition fam_to_slice_fun (f : fam X) : slice X :=
    (total2_hSet (pr1 f)) ,, pr1.

  Local Notation f_to_s := fam_to_slice_fun.

  Definition fam_to_slice_mor {a b : fam X} (f : a --> b) : f_to_s a --> f_to_s b :=
  (λ h, pr1 h ,, (pr1 f) (pr1 h) (pr2 h)) ,, (idpath (pr2 (f_to_s a))).

  Definition fam_to_slice_data : functor_data (fam X) (slice X) :=
    functor_data_constr _ _ fam_to_slice_fun (@fam_to_slice_mor).

  Theorem is_functor_fam_to_slice : is_functor fam_to_slice_data.
  Proof.
    split; [intro f | intros f f' f'' F F'];
      apply eq_mor_slicecat.
    + apply funextsec. intro p. reflexivity.
    + reflexivity.
  Qed.

  Definition fam_to_slice : functor (fam X) (slice X) :=
    fam_to_slice_data ,, is_functor_fam_to_slice.

  Definition slice_counit_fun (f : slice X) :
    (functor_composite_data slice_to_fam_data fam_to_slice_data) f --> (functor_identity_data _) f.
  Proof.
    exists (fun h : (∑ x : X, hfiber (pr2 f) x) => pr1 (pr2 h)).
    simpl.
    apply funextsec.
    intro p.
    exact (!pr2 (pr2 p)).
  Defined.

  Definition is_nat_trans_slice_counit : is_nat_trans _ _ slice_counit_fun.
  Proof.
    intros f f' F.
    apply eq_mor_slicecat.
    unfold slice_counit_fun. simpl.
    unfold compose. simpl.
    apply funextsec. intro p.
    unfold hfiber. rewrite transportf_total2.
    simpl. rewrite transportf_const.
    reflexivity.
  Qed.

  Definition slice_counit : nat_trans (functor_composite slice_to_fam fam_to_slice)
                                      (functor_identity (slice X)) :=
    slice_counit_fun ,, is_nat_trans_slice_counit.

  Definition slice_all_z_iso : forall x : slice X, is_z_isomorphism (slice_counit x).
  Proof.
    intro x.
    apply z_iso_to_slice_precat_z_iso.
    simpl.
    change (fun h : total2 (λ x' : X, hfiber (@pr2 _ (λ a : hSet, forall _ : a, X) x) x')
            => pr1 (pr2 h))
    with (fromcoconusf (pr2 x)).
    exact (hset_equiv_is_z_iso (make_hSet (coconusf (pr2 x)) (isaset_total2_hSet X (λ y, (hfiber_hSet (pr2 x) y)))) _ (weqfromcoconusf (pr2 x))).
  Qed.

  Definition slice_unit := pr1 (nat_trafo_z_iso_if_pointwise_z_iso
                                                            (has_homsets_slice_precat HSET X)
                                                            slice_counit slice_all_z_iso).

  Definition fam_unit_fun_fun (f : fam X) (x : X) :
    (pr1 ((functor_identity_data _) f)) x --> (pr1 ((functor_composite_data fam_to_slice_data slice_to_fam_data) f)) x :=
    λ a, ((x ,, a) ,, idpath x).

  Definition is_nat_trans_fam_unit_fun (f : fam X) :
    is_nat_trans (pr1 ((functor_identity_data _) f))
                 (pr1 ((functor_composite_data fam_to_slice_data slice_to_fam_data) f))
                 (fam_unit_fun_fun f) :=
    is_nat_trans_discrete_precategory (fam_unit_fun_fun f).

  Definition fam_unit_fun (f : fam X) :
    (functor_identity_data _) f --> (functor_composite_data fam_to_slice_data slice_to_fam_data) f :=
    (fam_unit_fun_fun f) ,, (is_nat_trans_fam_unit_fun f).

  Definition is_nat_trans_fam_unit : is_nat_trans _ _ fam_unit_fun.
  Proof.
    intros f f' F.
    apply (nat_trans_eq has_homsets_HSET).
    intro x.
    apply funextsec. intro a.
    apply (invmaponpathsincl pr1).
    + apply isofhlevelfpr1.
      intro.
      apply setproperty.
    + reflexivity.
  Qed.

  Definition fam_unit : nat_trans (functor_identity (fam X))
                                  (functor_composite fam_to_slice slice_to_fam) :=
    fam_unit_fun ,, is_nat_trans_fam_unit.

  Lemma fam_z_iso (F : fam X) : z_iso ((functor_identity (fam X)) F)
                                  ((functor_composite fam_to_slice slice_to_fam) F).
  Proof.
    apply (z_iso_from_nat_z_iso has_homsets_HSET).
    exists ((pr1 fam_unit) F).
    intro x.
    exact (hset_equiv_is_z_iso ((pr1 F) x)
                             (make_hSet (hfiber pr1 x)
                                       (isaset_hfiber pr1 x
                                                      (isaset_total2_hSet X (λ x, (pr1 F) x)) (pr2 X)))
                             (ezweqpr1 (funcomp (pr1 (pr1 F)) pr1) x)).
  Defined.

  Definition fam_all_z_iso (F : fam X) : is_z_isomorphism (fam_unit F) := pr2 (fam_z_iso F).

  Definition fam_counit := pr1 (nat_trafo_z_iso_if_pointwise_z_iso
                                                            (functor_category_has_homsets _ _ has_homsets_HSET)
                                                            fam_unit fam_all_z_iso).

  Lemma slice_fam_form_adj
    : form_adjunction fam_to_slice slice_to_fam fam_unit slice_counit.
  Proof.
    unfold form_adjunction.
    split.
    + intro f.
      apply eq_mor_slicecat.
      apply funextsec. intro x.
      reflexivity.
    + intro F.
      apply (nat_trans_eq has_homsets_HSET).
      intro x.
      apply funextsec.
      intro f.
      apply (invmaponpathsincl pr1).
    - apply isofhlevelfpr1.
      intro.
      apply setproperty.
    - simpl.
      unfold hfiber. rewrite transportf_total2.
      simpl. rewrite transportf_const.
      reflexivity.
  Defined.

  Definition are_adjoints_slice_fam : are_adjoints _ _ :=
    (fam_unit ,, slice_counit) ,, slice_fam_form_adj.

  Definition set_slice_fam_equiv : adj_equivalence_of_cats fam_to_slice :=
    (slice_to_fam ,, are_adjoints_slice_fam) ,, (fam_all_z_iso ,, slice_all_z_iso) .

End set_slice_fam_equiv.


Require Import Definitions.
Require Import Contracts_Subst.
Require Import Coq.Strings.String.
Require Import Contracts_Definition.

Fixpoint relation_Evaluation (rel : contract_Relation) (Ex:Exec) : Relation :=
  match rel with
    |contract_equi => Eff_Equi
    |contract_vis   => Ex-vis
    |contract_so => Ex-so
    |contract_sameobj => Ex-sameobj
    |contract_relation_union R1 R2 => Rel_Union (relation_Evaluation R1 Ex) (relation_Evaluation R2 Ex)
    |contract_relation_intersect R1 R2 => Rel_Intersect (relation_Evaluation R1 Ex)  (relation_Evaluation R2 Ex)
    |contract_relation_closure R1 => (Rel_Closure  (relation_Evaluation R1 Ex))
  end.

Fixpoint Prop_Evaluation (pr:contract_Prop)(Ex:Exec) : Prop:=
  match pr with
    |contract_prop_true => True
    |contract_prop_effeff R1 α β      => (relation_Evaluation R1 Ex) α β
    |contract_prop_conjunction p1 p2  =>  (Prop_Evaluation p1 Ex) /\ (Prop_Evaluation p2 Ex)
    |contract_prop_disjunction p1 p2  =>  (Prop_Evaluation p1 Ex) \/  (Prop_Evaluation p2 Ex)
    |contract_prop_implication p1 p2  =>  (Prop_Evaluation p1 Ex) ->  (Prop_Evaluation p2 Ex)
    |_=> False
  end.

Fixpoint contract_Eval (cont: contract_Contract) (Ex:Exec) (eff : Effect) (n:nat):Prop :=
  match n with
    |O => match cont with
           |contract_free_cons π => Prop_Evaluation (Prop_Subst π eff η'') Ex
           |_=> False
         end

    |S n' => match cont with
              |contract_typed_cons e τ ψ =>  forall ef:Effect,(Ex-A ef) -> contract_Eval (contract_Subst ψ ef e) Ex eff n'
              |contract_untyped_cons e ψ =>  forall ef:Effect,(Ex-A ef) -> contract_Eval (contract_Subst ψ ef e) Ex eff n'
              |_=> False
            end
  end.

Fixpoint contract_free_number (cont:contract_Contract) : nat :=
  match cont with
    |contract_free_cons p => 0
    |contract_untyped_cons e ψ => contract_free_number ψ +1
    |contract_typed_cons e t ψ => contract_free_number ψ +1
  end.


From Hammer Require Import Hammer.

Require Import Bool.
Require Import Arith.
Require Import ZArith.
Require Import NArith.
Require Import Ndec.
From IntMap Require Import Allmaps.
Require Import EqNat.
Require Export Max.

Lemma nat_sum : forall n : nat, n = 0 \/ (exists m : nat, n = S m).
Proof. hammer_hook "bases" "bases.nat_sum".
simple induction n. left. reflexivity. intros. right.
split with n0. reflexivity.
Qed.

Lemma le_n_n : forall n : nat, n <= n.
Proof. hammer_hook "bases" "bases.le_n_n".
simple induction n. trivial.
intros. exact (le_n_S n0 n0 H).
Qed.

Lemma le_l_or_r : forall n m : nat, n <= m \/ m <= n.
Proof. hammer_hook "bases" "bases.le_l_or_r".
intros. cut (n <= m \/ m < n). intros. elim H.
intros. left. assumption.
intros. right. exact (lt_le_weak m n H0).
exact (le_or_lt n m).
Qed.

Lemma plus_n_O : forall n : nat, n + 0 = n.
Proof. hammer_hook "bases" "bases.plus_n_O".
simple induction n. trivial.
intros. simpl in |- *. rewrite H. trivial.
Qed.

Lemma S_plus_l : forall n m : nat, S (n + m) = S n + m.
Proof. hammer_hook "bases" "bases.S_plus_l".
simpl in |- *. trivial.
Qed.

Lemma S_plus_r : forall n m : nat, S (n + m) = n + S m.
Proof. hammer_hook "bases" "bases.S_plus_r".
intros. rewrite (plus_comm n (S m)). rewrite (plus_comm n m).
simpl in |- *. trivial.
Qed.

Lemma max_le_Sr_0 :
forall n m : nat, max n m <= max n (S m) /\ max (S n) m <= max (S n) (S m).
Proof. hammer_hook "bases" "bases.max_le_Sr_0".
simple induction n; simple induction m. simpl in |- *. split. exact (le_n_Sn 0).
exact (le_n_n 1).
intros. split. elim H. intros. intros. simpl in |- *. exact (le_n_Sn (S n0)).
elim H. intros. simpl in |- *. exact (le_n_Sn (S n0)).
split. simpl in |- *. cut (max n0 0 = n0). intros. rewrite H0. trivial.
rewrite max_l; auto with arith.
simpl in |- *. exact (le_n_n (S (S n0))).
intros. elim H0. intros. split. simpl in |- *. elim (H n1). intros.
exact (le_n_S (max n0 n1) (max n0 (S n1)) H3).
cut (max (S (S n0)) (S n1) = S (max (S n0) n1)).
cut (max (S (S n0)) (S (S n1)) = S (max (S n0) (S n1))).
intros. rewrite H3. rewrite H4. elim (H (S n1)).
intros. elim (H n1). intros.
exact (le_n_S (max (S n0) n1) (max (S n0) (S n1)) H8).
simpl in |- *. trivial.
simpl in |- *. trivial.
Qed.

Lemma max_le_Sr : forall n m : nat, max n m <= max n (S m).
Proof. hammer_hook "bases" "bases.max_le_Sr".
intros. elim (max_le_Sr_0 n m). intros. exact H.
Qed.

Lemma plus_O_r : forall n : nat, n + 0 = n.
Proof. hammer_hook "bases" "bases.plus_O_r".
simple induction n. simpl in |- *. trivial.
intros. simpl in |- *. rewrite H. trivial.
Qed.

Lemma plus_O_l : forall n : nat, n + 0 = n.
Proof. hammer_hook "bases" "bases.plus_O_l".
simple induction n. simpl in |- *; trivial.
intros; simpl in |- *. rewrite H. trivial.
Qed.

Lemma le_mult_lS : forall n m : nat, n * m <= S n * m.
Proof. hammer_hook "bases" "bases.le_mult_lS".
simple induction n. simpl in |- *. intro. cut (m + 0 = m). intros.
rewrite H. exact (le_O_n m).
exact (plus_O_r m).
simpl in |- *. intros. exact (le_plus_r m (m + n0 * m)).
Qed.

Lemma le_mult_rS : forall n m : nat, n * m <= n * S m.
Proof. hammer_hook "bases" "bases.le_mult_rS".
intros. cut (n * m = m * n). cut (n * S m = S m * n).
intros. rewrite H. rewrite H0. exact (le_mult_lS m n).
exact (mult_comm n (S m)).
exact (mult_comm n m).
Qed.

Lemma le_disj : forall n m : nat, n <= m -> n = m \/ S n <= m.
Proof. hammer_hook "bases" "bases.le_disj".
intros. cut (m <= n \/ n < m). intro. elim H0; intros.
left. exact (le_antisym n m H H1).
right. exact (lt_le_S n m H1).
exact (le_or_lt m n).
Qed.

Lemma le_mult_l : forall n m p : nat, n <= m -> n * p <= m * p.
Proof. hammer_hook "bases" "bases.le_mult_l".
intro. simple induction m. intros. cut (n = 0). intro. rewrite H0; trivial.
symmetry  in |- *. exact (le_n_O_eq n H).
induction  n as [| n Hrecn]. intros. simpl in |- *. exact (le_O_n (p + n * p)).
intros. simpl in |- *. cut (n = n0 \/ S n <= n0). intro. cut (n * p <= n0 * p).
intro. elim H1; intros. cut (p <= p). intros.
exact (plus_le_compat p p (n * p) (n0 * p) H4 H2).
exact (le_n_n p).
cut (n * p <= S n * p). cut (S n * p <= n0 * p).
intros. apply (le_trans (p + n * p) (p + S n * p) (p + n0 * p)).
exact (plus_le_compat p p (n * p) (S n * p) (le_n_n p) H5).
exact (plus_le_compat p p (S n * p) (n0 * p) (le_n_n p) H4).
exact (H p H3).
exact (le_mult_lS n p).
elim H1; intros. rewrite H2. exact (le_n_n (n0 * p)).
cut (n * p <= S n * p). intro.
cut (S n * p <= n0 * p). intro.
exact (le_trans (n * p) (S n * p) (n0 * p) H3 H4).
exact (H p H2). exact (le_mult_lS n p).
cut (n <= n0). intro. exact (le_disj n n0 H1).
exact (le_S_n n n0 H0).
Qed.

Lemma le_mult_r : forall n m p : nat, n <= m -> p * n <= p * m.
Proof. hammer_hook "bases" "bases.le_mult_r".
intros. cut (p * n = n * p). intros. cut (p * m = m * p).
intros. rewrite H0. rewrite H1. exact (le_mult_l n m p H).
exact (mult_comm p m).
exact (mult_comm p n).
Qed.

Lemma le_mult_mult : forall n m p q : nat, n <= m -> p <= q -> n * p <= m * q.
Proof. hammer_hook "bases" "bases.le_mult_mult".
intros. cut (n * p <= n * q). intro.
cut (n * q <= m * q). intro.
exact (le_trans (n * p) (n * q) (m * q) H1 H2).
exact (le_mult_l n m q H).
exact (le_mult_r p q n H0).
Qed.

Lemma Sn_eq_Sm_n_eq_m : forall n m : nat, S n = S m -> n = m.
Proof. hammer_hook "bases" "bases.Sn_eq_Sm_n_eq_m".
simple induction n. simple induction m. intros. reflexivity. intros.
inversion H0. simple induction m. intros. inversion H0. intros.
inversion H1. reflexivity.
Qed.

Lemma bool_dec_eq : forall a b : bool, {a = b} + {a <> b}.
Proof. hammer_hook "bases" "bases.bool_dec_eq".
intros. case a. case b. left. trivial.
right. exact diff_true_false.
case b. right. exact diff_false_true.
left. trivial.
Qed.

Lemma bool_is_false_or_true : forall a : bool, a = false \/ a = true.
Proof. hammer_hook "bases" "bases.bool_is_false_or_true".
simple induction a. right. trivial.
left. trivial.
Qed.

Lemma bool_is_true_or_false : forall a : bool, a = true \/ a = false.
Proof. hammer_hook "bases" "bases.bool_is_true_or_false".
simple induction a. left. trivial.
right. trivial.
Qed.

Lemma in_M0_false :
forall (A : Set) (a : A), ~ (exists e : ad, MapGet A (M0 A) e = Some a).
Proof. hammer_hook "bases" "bases.in_M0_false".
intros. intro. elim H. intros. inversion H0.
Qed.

Lemma in_M1_id :
forall (A : Set) (a : A) (x : ad) (e : A),
(exists c : ad, MapGet A (M1 A x e) c = Some a) -> a = e.
Proof. hammer_hook "bases" "bases.in_M1_id".
intros. elim H. intros. cut (x = x0). intro. rewrite H1 in H0.
cut (MapGet A (M1 A x0 e) x0 = Some e). intros.
cut (Some e = Some a). intro. inversion H3. trivial.
transitivity (MapGet A (M1 A x0 e) x0).
symmetry  in |- *. assumption.
assumption.
exact (M1_semantics_1 A x0 e).
cut (N.eqb x x0 = false \/ N.eqb x x0 = true). intro. elim H1; intros.
cut (MapGet A (M1 A x e) x0 = None). intro. cut (Some a = None).
intro. inversion H4. transitivity (MapGet A (M1 A x e) x0). symmetry  in |- *.
assumption.
assumption.
exact (M1_semantics_2 A x x0 e H2).
exact (Neqb_complete x x0 H2).
elim (bool_dec_eq (N.eqb x x0) true). intros. right. assumption.
intro y. left. exact (not_true_is_false (N.eqb x x0) y).
Qed.

Lemma in_M2_disj :
forall (A : Set) (a : A) (m0 m1 : Map A),
(exists c : ad, MapGet A (M2 A m0 m1) c = Some a) ->
(exists c : ad, MapGet A m0 c = Some a) \/
(exists c : ad, MapGet A m1 c = Some a).
Proof. hammer_hook "bases" "bases.in_M2_disj".
intros. elim H. simple induction x. simpl in |- *. intro. left. split with N0.
assumption.
simple induction p. intros. right. simpl in H1. split with (Npos p0).
assumption.
intros. left. simpl in H1. split with (Npos p0). assumption.
intros. right. simpl in H0. split with N0. assumption.
Qed.

Lemma aux_Neqb_1_0 : forall p : positive, Pos.eqb p p = true.
Proof. hammer_hook "bases" "bases.aux_Neqb_1_0".
simple induction p. simpl in |- *. intros. trivial. simpl in |- *. intros.
trivial. trivial.
Qed.

Lemma aux_Neqb_1_1 : forall p p0 : positive, Pos.eqb p p0 = true -> p = p0.
Proof. hammer_hook "bases" "bases.aux_Neqb_1_1".
simple induction p. intro. intro. simple induction p1. intros. simpl in H1.
cut (p0 = p2). intro. rewrite H2. trivial. exact (H p2 H1).
intros. simpl in H1. inversion H1. intros. inversion H0.
intro. intro. simple induction p1. intros. inversion H1.
intros. cut (p0 = p2). intros. rewrite H2. trivial.
simpl in H1. exact (H p2 H1). intros. inversion H0.
simple induction p0. intros. inversion H0. intros. inversion H0.
intros. trivial.
Qed.

Lemma aux_Neqb_trans :
forall a b c : ad, N.eqb a b = true -> N.eqb b c = true -> N.eqb a c = true.
Proof. hammer_hook "bases" "bases.aux_Neqb_trans".
intros. rewrite <- (Neqb_complete b c H0). trivial.
Qed.

Lemma indprinciple_nat_gen :
forall P : nat -> Prop,
(forall n : nat, (forall m : nat, m < n -> P m) -> P n) ->
forall n m : nat, m <= n -> P m.
Proof. hammer_hook "bases" "bases.indprinciple_nat_gen".
intro. intro. simple induction n. intros. apply (H m). intros. elim (lt_n_O m0 (lt_le_trans m0 m 0 H1 H0)). intros. elim (le_lt_or_eq m (S n0) H1). intros.
exact (H0 m (lt_n_Sm_le m n0 H2)). intro. rewrite H2. apply (H (S n0)). intros.
exact (H0 m0 (lt_n_Sm_le m0 n0 H3)).
Qed.

Lemma beq_nat_complete : forall n m : nat, beq_nat n m = true -> n = m.
Proof. hammer_hook "bases" "bases.beq_nat_complete".
simple induction n. simple induction m. intros. reflexivity. intros.
inversion H0. simple induction m. intros. inversion H0. intros.
simpl in H1. rewrite (H _ H1). reflexivity.
Qed.

Lemma beq_nat_correct : forall n : nat, beq_nat n n = true.
Proof. hammer_hook "bases" "bases.beq_nat_correct".
simple induction n. reflexivity. intros. simpl in |- *. exact H.
Qed.


Require Import String Program.Equality Lia.

Set Asymmetric Patterns.

Open Scope string.

Fixpoint S_In a s :=
  match s with
    | EmptyString => False
    | String a' s' => a' = a \/ S_In a s'
  end.

Theorem S_in_eq : forall a (l:string), S_In a (String a l).
Proof.
  simpl; intuition auto.
Qed.

Theorem S_in_cons : forall a b (l:string), S_In b l -> S_In b (String a l).
Proof.
  induction l; simpl in *; intuition auto.
Qed.

Theorem S_not_in_cons x a (l : string):
  ~ S_In x (String a l) <-> x<>a /\ ~ S_In x l.
Proof.
  induction l; simpl in *; intuition auto.
Qed.

Theorem S_in_nil : forall a, ~ S_In a EmptyString.
Proof.
  intuition auto.
Qed.

Theorem S_in_split : forall x (l: string), S_In x l -> exists l1 l2,
                                                        l = (l1 ++ String x l2).
Proof.
  induction l; simpl in *; intros; subst; intuition auto.
  - subst.
    exists EmptyString, l; reflexivity.
  - destruct H as [l1 [l2 leq]]; subst; simpl.
    exists (String a l1), l2; reflexivity.
Qed.

Lemma S_in_inv : forall a b (l: string), S_In b (String a l) -> a = b \/ S_In b l.
Proof.
  induction l; simpl in *; intuition auto.
Qed.

Theorem S_in_dec :
  forall a (l: string), {S_In a l} + {~ S_In a l}.
Proof.
  induction l; simpl in *; intuition auto.
  destruct (Ascii.ascii_dec a0 a); subst; intuition auto.
Qed.

Theorem S_app_cons_not_nil : forall (x y: string) a, EmptyString <> (x ++ String a y).
Proof.
  induction x; simpl in *; intuition auto; try discriminate.
Qed.

Theorem S_app_nil_l : forall (l: string), (EmptyString ++ l) = l.
Proof.
  reflexivity.
Qed.

Theorem S_app_nil_r : forall l: string, (l ++ EmptyString) = l.
Proof.
  induction l; intuition auto.
  rewrite <- IHl at 2; reflexivity.
Qed.

Theorem S_app_assoc : forall l m n:string, (l ++ m ++ n = (l ++ m) ++ n).
Proof.
  induction l; intuition auto; simpl in *.
  f_equal; apply IHl.
Qed.

Theorem S_app_comm_cons : forall (x y: string) a, String a (x ++ y) = (String a x) ++ y.
Proof.
  induction x; intuition auto.
Qed.

Theorem S_app_eq_nil : forall l l':string, l ++ l' = EmptyString ->
                                         l = EmptyString /\ l' = EmptyString.
Proof.
  induction l; intuition auto; try discriminate.
Qed.

Theorem S_app_eq_unit :
  forall (x y: string) a,
    x ++ y = String a EmptyString -> x = EmptyString /\
                                     y = String a EmptyString \/ x = String a EmptyString /\
                                     y = EmptyString.
Proof.
  induction x; intuition auto.
  inversion H; subst; clear H.
  apply S_app_eq_nil in H2; destruct H2; subst; simpl; intuition auto.
Qed.

Lemma S_app_inj_tail :
  forall (x y:string) a b, x ++ String a EmptyString = y ++ String b EmptyString ->
                           x = y /\ a = b.
Proof.
  induction x; simpl in *; destruct y; intuition auto; simpl in *.
  - inversion H; intuition auto.
  - inversion H.
    apply eq_sym in H2.
    apply S_app_eq_nil in H2; destruct H2; discriminate.
  - inversion H.
    apply eq_sym in H2.
    apply S_app_eq_nil in H2; destruct H2; discriminate.
  - inversion H; subst.
    apply S_app_eq_nil in H2. destruct H2; discriminate.
  - inversion H; subst.
    apply S_app_eq_nil in H2. destruct H2; discriminate.
  - f_equal; inversion H; subst; auto.
    apply IHx in H2; destruct H2; auto.
  - inversion H; subst.
    apply IHx in H2; destruct H2; auto.
Qed.

Lemma S_app_length : forall l l' : string, length (l++l') = length l + length l'.
Proof.
  induction l; destruct l'; intuition auto; simpl in *; f_equal; intuition auto; try apply IHl.
Qed.

Lemma S_in_app_or : forall (l m:string) a, S_In a (l ++ m) -> S_In a l \/ S_In a m.
Proof.
  induction l; destruct m; intuition auto; simpl in *.
  - left; rewrite S_app_nil_r in H; intuition auto.
  - intuition auto.
    apply IHl in H0; simpl in *.
    intuition auto.
Qed.

Lemma S_in_or_app : forall (l m: string) a, S_In a l \/ S_In a m -> S_In a (l ++ m).
Proof.
  induction l; destruct m; simpl in *; intuition auto; subst.
  - right; apply IHl; right; simpl in *; left; reflexivity.
  - right; apply IHl; right; simpl in *; right; auto.
Qed.

Lemma S_in_app_iff : forall l l' a, S_In a (l++l') <-> S_In a l \/ S_In a l'.
Proof.
  intros; constructor; intros.
  - apply S_in_app_or; auto.
  - apply S_in_or_app; auto.
Qed.

Lemma S_app_inv_head:
  forall l l1 l2 : string, l ++ l1 = l ++ l2 -> l1 = l2.
Proof.
  induction l; simpl in *; intuition auto; inversion H.
  apply IHl; auto.
Qed.

Lemma S_app_inv_tail:
  forall l l1 l2 : string, l1 ++ l = l2 ++ l -> l1 = l2.
Proof.
  intros l l1.
  generalize l; clear l.
  induction l1; destruct l2; simpl in *; intuition auto.
  match goal with
    | H: ?p = ?q |- _ => assert (sth: length p = length q) by (f_equal; auto); simpl in sth
  end.
  simpl in sth; rewrite S_app_length in sth.
  exfalso; lia.
  match goal with
    | H: ?p = ?q |- _ => assert (sth: length p = length q) by (f_equal; auto); simpl in sth
  end.
  rewrite S_app_length in sth; exfalso; lia.
  inversion H; subst; clear H.
  f_equal; eapply IHl1; eauto.
Qed.

#[global] Hint Resolve S_app_assoc: datatypes v62.
#[global] Hint Resolve S_app_comm_cons S_app_cons_not_nil: datatypes v62.
#[global] Hint Immediate S_app_eq_nil: datatypes v62.
#[global] Hint Resolve S_app_eq_unit S_app_inj_tail: datatypes v62.
#[global] Hint Resolve S_in_eq S_in_cons S_in_inv S_in_nil S_in_app_or S_in_or_app: datatypes v62.

Fixpoint S_nth (n:nat) (l:string) default {struct l} :=
  match n, l with
    | O, String x l' => x
    | O, other => default
    | S m, EmptyString => default
    | S m, String x t => S_nth m t default
  end.

Fixpoint S_nth_ok (n:nat) (l: string) (default: Ascii.ascii) {struct l} : bool :=
  match n, l with
    | O, String x l' => true
    | O, other => false
    | S m, EmptyString => false
    | S m, String x t => S_nth_ok m t default
  end.

Lemma S_nth_in_or_default :
  forall (n:nat) (l: string) d, {S_In (S_nth n l d) l} + {S_nth n l d = d}.
Proof.
  induction n, l; simpl in *; auto; intros.
  specialize (IHn l d).
  destruct IHn; intuition auto.
Qed.

Lemma nth_S_cons :
    forall (n:nat) (l: string) d a,
      S_In (S_nth n l d) l -> S_In (S_nth (S n) (String a l) d) (String a l).
Proof.
  induction n, l; simpl in *; auto; intros.
Qed.

Definition S_nth_error l (n: nat) := get n l.

Definition S_nth_default default (l:string) (n:nat) : Ascii.ascii :=
  match get n l with
    | Some x => x
    | None => default
  end.

Lemma S_nth_default_eq :
  forall n l d, S_nth_default d l n = S_nth n l d.
Proof.
  induction n, l; simpl in *; auto; intros.
  apply IHn.
Qed.

Section RelatingIndex.
  Lemma substring_empty:
    forall s, substring 0 0 s = ""%string.
  Proof. induction s; simpl; intros; auto. Qed.

  Lemma index_not_in a l:
    index 0 (String a EmptyString) l = None <-> ~ S_In a l.
  Proof.
    induction l; simpl in *; intuition auto; subst;
    rewrite (proj2 (prefix_correct "" l) (substring_empty l)) in *.
    - destruct (Ascii.ascii_dec a a); intuition auto; try discriminate.
    - destruct (Ascii.ascii_dec a a0); intuition auto; try discriminate.
      case_eq (index 0 (String a "") l); intros.
      + rewrite H2 in H1.
        discriminate.
      + apply H; auto.
    - destruct (Ascii.ascii_dec a a0); intuition auto; try discriminate; subst; intuition auto.
      rewrite H1; reflexivity.
  Qed.
End RelatingIndex.

Lemma S_nth_In :
  forall (n:nat) l d, n < length l -> S_In (S_nth n l d) l.
Proof.
  induction n, l; simpl in *; intuition auto; try lia.
  assert (sth: n < length l) by lia.
  apply IHn with (d := d) in sth; auto.
Qed.

Lemma S_In_nth l x d : S_In x l ->
                       exists n, n < length l /\ S_nth n l d = x.
Proof.
  induction l; simpl in *; subst; intuition auto; intros.
  - exists 0; constructor; try lia; auto.
  - destruct H as [n [nlt eq]].
    exists (S n); constructor; try lia; auto.
Qed.

Lemma S_nth_overflow : forall l n d, length l <= n -> S_nth n l d = d.
Proof.
  induction l, n; intuition auto; simpl in *.
  - exfalso; lia.
  - assert (sth: length l <= n) by lia.
    apply IHl; auto.
Qed.

Lemma S_nth_indep :
  forall l n d d', n < length l -> S_nth n l d = S_nth n l d'.
Proof.
  induction l, n; intuition auto; simpl in *.
  - exfalso; lia.
  - exfalso; lia.
  - assert (sth: n < length l) by lia; apply IHl; auto.
Qed.

Lemma S_app_nth1 :
  forall l l' d n, n < length l -> S_nth n (l++l') d = S_nth n l d.
Proof.
  induction l, n; intuition auto; simpl in *.
  - exfalso; lia.
  - exfalso; lia.
  - assert (sth: n < length l) by lia; apply IHl; auto.
Qed.

Lemma S_app_nth2 :
  forall l l' d n, n >= length l -> S_nth n (l++l') d = S_nth (n-length l) l' d.
Proof.
  induction l, n; intuition auto; simpl in *.
  - exfalso; lia.
  - assert (sth: n >= length l) by lia; apply IHl; auto.
Qed.

Lemma S_nth_split l :
  forall n d,
    n < length l ->
    exists l1, exists l2, l = l1 ++ String (S_nth n l d) l2 /\ length l1 = n.
Proof.
  induction l; destruct n; simpl in *; intuition auto; subst; try discriminate; try lia.
  - exists "", l; constructor; auto.
  - assert (sth: n < length l) by lia.
    specialize (IHl _ d sth).
    destruct IHl as [l1 [l2 [? ?]]].
    exists (String a l1), l2; constructor; f_equal; simpl in *; f_equal; auto.
Qed.

Lemma S_nth_error_In l n x : S_nth_error l n = Some x -> S_In x l.
Proof.
  generalize n x; clear n x.
  induction l; destruct n; intuition auto; simpl in *; try discriminate.
  - inversion H; intuition auto.
  - right; apply IHl with (n := n); auto.
Qed.

Lemma S_In_nth_error l : forall x, S_In x l -> exists n, S_nth_error l n = Some x.
Proof.
  induction l; simpl in *; intuition auto; subst.
  - exists 0; reflexivity.
  - destruct (IHl x H0) as [n rest].
    exists (S n); auto.
Qed.

Lemma S_nth_error_None l : forall n, S_nth_error l n = None <-> length l <= n.
Proof.
  induction l; destruct n; simpl in *; intuition auto; subst; try lia; try discriminate.
  apply IHl in H; lia.
  apply IHl; lia.
Qed.

Lemma S_nth_error_Some l : forall n, S_nth_error l n <> None <-> n < length l.
Proof.
  induction l; destruct n; simpl in *; intuition auto; subst; try lia; try discriminate.
  apply IHl in H; lia.
  generalize H0; clear H0.
  apply IHl; lia.
Qed.

Lemma S_nth_error_split l : forall n a,
                            S_nth_error l n = Some a ->
                            exists l1, exists l2, l = l1 ++ String a l2 /\ length l1 = n.
Proof.
  induction l; destruct n; simpl in *; intuition auto; subst; try discriminate; try lia.
  - inversion H; clear H; subst.
    exists ""; simpl.
    repeat econstructor; eauto.
  - apply IHl in H.
    destruct H as [l1 [l2 [? ?]]].
    exists (String a l1), l2; simpl in *.
    constructor; f_equal; auto.
Qed.

Lemma S_nth_error_app1 l : forall l' n, n < length l ->
                                        S_nth_error (l++l') n = S_nth_error l n.
Proof.
  induction l; destruct l', n; simpl in *; intuition auto; subst; try discriminate; try lia;
  apply IHl; lia.
Qed.

Lemma S_nth_error_app2 l : forall l' n, length l <= n ->
                                        S_nth_error (l++l') n = S_nth_error l' (n-length l).
Proof.
  induction l; destruct l', n; simpl in *; intuition auto; subst; try discriminate; try lia;
  apply IHl; lia.
Qed.

Close Scope string.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import Bool String Lists.List.
Import ListNotations.
Import BoolNotations.
Open Scope string.
Open Scope list.

From Utils Require Export Base Booleans Nats Props Eqb Default
  Lists Options Pairs NamedList.

(****************
Definitions
*****************)

Inductive len_eq {A} {B} : list A -> list B -> Type :=
| len_eq_nil : len_eq [] []
| len_eq_cons : forall a a' l l',
    len_eq l l' -> len_eq (a::l) (a'::l').

(*TODO: move to standard library? *)
Lemma string_of_list_ascii_length l
  : String.length (string_of_list_ascii l) = List.length l.
Proof.
  induction l;
    basic_goal_prep;
    basic_utils_crush.
Qed.

(*TODO: redefine as skipn?*)
(* Reduce size of language terms for smaller goals *)
Fixpoint nth_tail {A} (n: nat) (l : list A) : list A :=
  match n,l with
  | 0,_ => l
  | S_,[]=> []
  | S n', _::l'=> nth_tail n' l'
  end.

Arguments nth_tail : simpl never.

Lemma nth_tail_nil A n : @nth_tail A n [] = [].
Proof.
  destruct n; simpl; reflexivity.
Qed.
#[export] Hint Rewrite nth_tail_nil : utils.

Lemma nth_tail_S_cons A n (e:A) l : nth_tail (S n) (e::l) = nth_tail n l.
Proof.
  reflexivity.
Qed.
#[export] Hint Rewrite nth_tail_S_cons : utils.

Lemma as_nth_tail: forall (A : Type) (l : list A), l = nth_tail 0 l.
Proof.
  intros; unfold nth_tail; reflexivity.
Qed.

Lemma nth_tail_to_cons A l n (x:A)
  : nth_error l n = Some x ->
    nth_tail n l = x::(nth_tail (S n) l).
Proof.
  revert l; induction n; destruct l;
    basic_goal_prep; basic_utils_crush.
Qed.

Lemma nth_tail_equals_cons_res A n l l' (x:A)
  : nth_tail n l = x :: l' -> l' = nth_tail (S n) l.
Proof.
  revert l l'; induction n; destruct l;
    basic_goal_prep; basic_utils_crush.
  cbv in H; inversion H; subst.
  reflexivity.
Qed.

Lemma nth_error_nil A n : @nth_error A [] n = None.
Proof.
  destruct n; simpl; auto.
Qed.
#[export] Hint Rewrite nth_error_nil : utils.

Module SumboolNotations.
  Notation "SB! e" :=
    (if e then left _ else right _)
      (at level 90).
  Notation "e1 'SB&' e2" :=
    (Sumbool.sumbool_and _ _ _ _ e1 e2)
      (at level 58, left associativity).
End SumboolNotations.
Import SumboolNotations.

(*TODO: move to Pairs.v *)
Definition pair_eq_dec {A B}
           (A_eq_dec : forall s1 s2 : A, {s1 = s2} + {s1 <> s2})
           (B_eq_dec : forall s1 s2 : B, {s1 = s2} + {s1 <> s2})
           (p1 p2 : A*B)
  : {p1 = p2} + {~p1 = p2}.
  refine (match p1, p2 with
          | (a1,b1),(a2,b2) =>
            SB! (A_eq_dec a1 a2) SB& (B_eq_dec b1 b2)
          end); basic_utils_crush.
Defined.

Fixpoint incl_dec {A} (eq_dec : forall s1 s2 : A, {s1 = s2} + {s1 <> s2})
         (l1 l2 : list A) {struct l1} : {incl l1 l2} + {~ incl l1 l2}.
  refine(match l1 with
         | [] => left _
         | a::l1' =>
           SB! (in_dec eq_dec a l2) SB& (incl_dec _ _ l1' l2)
         end); basic_utils_firstorder_crush.
Defined.


Require Import Containers.Sets Containers.SetProperties.

Generalizable All Variables.

Section WithOT.
  Context `{A_OT : OrderedType A}.

  Fixpoint diagProd_aux (l : list A) (acc : set (A * A)) :=
    match l with
      | nil => acc
      | a::q =>
        diagProd_aux q
        (fold_left (fun acc b => {(a,b); acc}) q acc)
    end.
  Definition diagProd (S : set A) :=
    diagProd_aux (elements S) {}.

  Lemma rowProd_inv :
    forall (a : A) (l : list A) (acc : set (A * A)) (t u : A),
      In (t, u) (fold_left (fun acc b => add (a, b) acc) l acc)
      <-> In (t, u) acc \/ (t === a /\ InA _eq u l).
  Proof.
    intros a; intro l; pattern l; apply rev_ind; clear l; intros; simpl in *.
    intuition. inversion H1.
    rewrite fold_left_app; simpl.
    split; intro Hin.
    destruct (eq_dec t a) as [e|n].
    destruct (eq_dec u x) as [e'|n'].
    right; split;
      [| rewrite <- InA_rev; auto; rewrite rev_unit; constructor]; auto.
    assert (~ ((a, x) === (t, u))).
    intros abs; inversion abs; subst; intuition.
    assert (Hin' := add_3 H0 Hin); rewrite H in Hin'; destruct Hin'.
    left; assumption.
    right; split; [auto |
      rewrite <- InA_rev; auto; rewrite rev_unit; constructor 2;
        rewrite InA_rev; auto; tauto].
    assert (~ ((a, x) === (t, u))).
    intros abs; inversion abs; subst; intuition.
    assert (Hin' := add_3 H0 Hin); rewrite H in Hin'; destruct Hin'.
    left; assumption. right; intuition.
    destruct Hin as [Hin|Hin].
    apply add_2; rewrite H; left; exact Hin.
    destruct Hin as [H1 H2]; rewrite <- InA_rev in H2; auto;
      rewrite rev_unit in H2.
    inversion H2; subst; [apply add_1 | apply add_2].
    constructor; auto.
    rewrite H; right; rewrite <- InA_rev; auto; split; assumption.
  Qed.

  Lemma diagProd_aux_inv :
    forall l acc, sort _lt l -> forall t u,
      In (t,u) (diagProd_aux l acc)
      <->
      In (t,u) acc \/
      (t <<< u /\ InA _eq t l /\ InA _eq u l).
  Proof.
    intro l; induction l.
    intros; simpl in *; intuition. inversion H1.
    intros acc Hsort u u'; simpl; inversion Hsort; subst.
    rewrite (IHl (fold_left (fun (acc0 : set (A * A)) (b : A) =>
      add (a, b) acc0) l acc)); auto.
    rewrite (InfA_alt (eqA := _eq)) in H2; auto.
    split; intros [Hin|Hin].
    rewrite (rowProd_inv a l acc u u') in Hin; destruct Hin.
    left; assumption. right; intuition.
    rewrite H0; apply H2; intuition.
    right; intuition.
    left; rewrite rowProd_inv; left; assumption.
    destruct Hin as [Hin1 [Hin2 Hin3]].
    inversion Hin2; subst.
    left; rewrite rowProd_inv; right; split; auto.
    inversion Hin3; subst; auto.
    rewrite H0 in Hin1; rewrite H3 in Hin1;
      contradiction (lt_not_eq Hin1 (reflexivity a)).
    right; inversion Hin3; subst.
    contradiction (@lt_not_eq _ _ _ _ _ a a); [|reflexivity].
    transitivity u.
    apply H2; intuition.
    rewrite H3 in Hin1; exact Hin1.
    intuition.
  Qed.

  Corollary diagProd_iff :
    forall s t u, In (t,u) (diagProd s) <-> (In t s /\ In u s /\ t <<< u).
  Proof.
    intros s t u; unfold diagProd; rewrite diagProd_aux_inv.
    intuition; contradiction (empty_1 H0).
    exact (elements_3 s).
  Qed.

  Instance diagProd_m : Proper (_eq ==> _eq) diagProd.
  Proof.
    repeat intro; destruct a; rewrite 2diagProd_iff.
    rewrite H; reflexivity.
  Qed.
  Instance diagProd_subset_m : Proper (Subset ==> Subset) diagProd.
  Proof.
    repeat intro; destruct a; rewrite diagProd_iff in *.
    rewrite H in H0; auto.
  Qed.
End WithOT.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.

(* Hack so that Why3 does not override the notation below.

(* Why3 assumption *)
Definition divides (d:Z) (n:Z): Prop := exists q:Z, (n = (q * d)%Z).

*)

Require Import Znumtheory.
Notation divides := Zdivide (only parsing).

(* Why3 goal *)
Lemma divides_refl : forall (n:Z), (divides n n).
Proof.
exact Zdivide_refl.
Qed.

(* Why3 goal *)
Lemma divides_1_n : forall (n:Z), (divides 1%Z n).
Proof.
exact Zone_divide.
Qed.

(* Why3 goal *)
Lemma divides_0 : forall (n:Z), (divides n 0%Z).
Proof.
exact Zdivide_0.
Qed.

(* Why3 goal *)
Lemma divides_left : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides
  (c * a)%Z (c * b)%Z).
Proof.
exact Zmult_divide_compat_l.
Qed.

(* Why3 goal *)
Lemma divides_right : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides
  (a * c)%Z (b * c)%Z).
Proof.
exact Zmult_divide_compat_r.
Qed.

(* Why3 goal *)
Lemma divides_oppr : forall (a:Z) (b:Z), (divides a b) -> (divides a (-b)%Z).
Proof.
exact Zdivide_opp_r.
Qed.

(* Why3 goal *)
Lemma divides_oppl : forall (a:Z) (b:Z), (divides a b) -> (divides (-a)%Z b).
Proof.
exact Zdivide_opp_l.
Qed.

(* Why3 goal *)
Lemma divides_oppr_rev : forall (a:Z) (b:Z), (divides (-a)%Z b) -> (divides a
  b).
Proof.
exact Zdivide_opp_l_rev.
Qed.

(* Why3 goal *)
Lemma divides_oppl_rev : forall (a:Z) (b:Z), (divides a (-b)%Z) -> (divides a
  b).
Proof.
exact Zdivide_opp_r_rev.
Qed.

(* Why3 goal *)
Lemma divides_plusr : forall (a:Z) (b:Z) (c:Z), (divides a b) -> ((divides a
  c) -> (divides a (b + c)%Z)).
Proof.
exact Zdivide_plus_r.
Qed.

(* Why3 goal *)
Lemma divides_minusr : forall (a:Z) (b:Z) (c:Z), (divides a b) -> ((divides a
  c) -> (divides a (b - c)%Z)).
Proof.
exact Zdivide_minus_l.
Qed.

(* Why3 goal *)
Lemma divides_multl : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides a
  (c * b)%Z).
Proof.
intros a b c.
apply Zdivide_mult_r.
Qed.

(* Why3 goal *)
Lemma divides_multr : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides a
  (b * c)%Z).
Proof.
exact Zdivide_mult_l.
Qed.

(* Why3 goal *)
Lemma divides_factorl : forall (a:Z) (b:Z), (divides a (b * a)%Z).
Proof.
exact Zdivide_factor_l.
Qed.

(* Why3 goal *)
Lemma divides_factorr : forall (a:Z) (b:Z), (divides a (a * b)%Z).
Proof.
exact Zdivide_factor_r.
Qed.

(* Why3 goal *)
Lemma divides_n_1 : forall (n:Z), (divides n 1%Z) -> ((n = 1%Z) \/
  (n = (-1%Z)%Z)).
Proof.
exact Zdivide_1.
Qed.

(* Why3 goal *)
Lemma divides_antisym : forall (a:Z) (b:Z), (divides a b) -> ((divides b
  a) -> ((a = b) \/ (a = (-b)%Z))).
Proof.
exact Zdivide_antisym.
Qed.

(* Why3 goal *)
Lemma divides_trans : forall (a:Z) (b:Z) (c:Z), (divides a b) -> ((divides b
  c) -> (divides a c)).
Proof.
exact Zdivide_trans.
Qed.

(* Why3 goal *)
Lemma divides_bounds : forall (a:Z) (b:Z), (divides a b) -> ((~ (b = 0%Z)) ->
  ((ZArith.BinInt.Z.abs a) <= (ZArith.BinInt.Z.abs b))%Z).
Proof.
exact Zdivide_bounds.
Qed.

Import EuclideanDivision.

(* Why3 goal *)
Lemma mod_divides_euclidean : forall (a:Z) (b:Z), (~ (b = 0%Z)) ->
  (((int.EuclideanDivision.mod1 a b) = 0%Z) -> (divides b a)).
Proof.
intros a b Zb H.
exists (div a b).
rewrite (Div_mod a b Zb) at 1.
rewrite H.
ring.
Qed.

(* Why3 goal *)
Lemma divides_mod_euclidean : forall (a:Z) (b:Z), (~ (b = 0%Z)) -> ((divides
  b a) -> ((int.EuclideanDivision.mod1 a b) = 0%Z)).
Proof.
intros a b Zb H.
assert (Zmod a b = Z0).
now apply Zdivide_mod.
unfold mod1, div.
rewrite H0.
case Z_le_dec ; intros H1.
rewrite (Z_div_exact_full_2 a b Zb H0) at 1.
apply Zminus_diag.
now elim H1.
Qed.

(* Why3 goal *)
Lemma mod_divides_computer : forall (a:Z) (b:Z), (~ (b = 0%Z)) ->
  (((ZArith.BinInt.Z.rem a b) = 0%Z) -> (divides b a)).
Proof.
intros a b Zb H.
exists (Z.quot a b).
rewrite Zmult_comm.
now apply Zquot.Z_quot_exact_full.
Qed.

(* Why3 goal *)
Lemma divides_mod_computer : forall (a:Z) (b:Z), (~ (b = 0%Z)) -> ((divides b
  a) -> ((ZArith.BinInt.Z.rem a b) = 0%Z)).
Proof.
intros a b Zb (q,H).
rewrite H.
apply Zquot.Z_rem_mult.
Qed.

(* Why3 goal *)
Lemma even_divides : forall (a:Z), (number.Parity.even a) <-> (divides 2%Z
  a).
Proof.
split ;
  intros (q,H) ; exists q ; now rewrite Zmult_comm.
Qed.

(* Why3 goal *)
Lemma odd_divides : forall (a:Z), (number.Parity.odd a) <-> ~ (divides 2%Z
  a).
Proof.
split.
intros H.
contradict H.
apply Parity.even_not_odd.
now apply <- even_divides.
intros H.
destruct (Parity.even_or_odd a).
elim H.
now apply -> even_divides.
exact H0.
Qed.


(************************************************************************)
(*         *   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)         *)
(************************************************************************)

(** The library REALS is divided in 6 parts :
   - Rbase: basic lemmas on R
            equalities and inequalities
            Ring and Field are instantiated on R
   - Rfunctions: some useful functions (Rabsolu, Rmin, Rmax, fact...)
   - SeqSeries: theory of sequences and series
   - Rtrigo: theory of trigonometric functions
   - Ranalysis: some topology and general results of real analysis (mean value theorem, intermediate value theorem,...)
   - Integration: Newton and Riemann' integrals

  Tactics are:
  - DiscrR: for goals like ``?1<>0``
  - Sup: for goals like ``?1<?2``
  - RCompute: for equalities with constants like ``10*10==100``
  - Reg: for goals like (continuity_pt ?1 ?2) or (derivable_pt ?1 ?2) *)

Require Export Rbase.
Require Export Rfunctions.
Require Export SeqSeries.
Require Export Rtrigo.
Require Export Ranalysis.
Require Export Integration.
Require Import Fourier.