Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem qreva_append : forall (x y : lst), (qreva x y) = (append (rev x) y).
Proof.
   induction x; induction y; simpl; try reflexivity.
   { rewrite IHx.
   rewrite <- append_assoc.
   f_equal. }
   { rewrite IHx.
   rewrite append_nil.
   reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst), eq (rev x) (qreva x Nil).
Proof.
   intros.
   rewrite qreva_append.
   lfind. Admitted.


Require Import List.
Export ListNotations.

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

Require Import FO_BiInt_Syntax.
Require Import FO_BiInt_GHC.
Require Import FO_BiInt_logics.
Require Import FO_BiInt_extens_interactions.
Require Import FOwBIH_meta_interactions.

Section sMeta.

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

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

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

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

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

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

Lemma smonotR_Or : forall A B Γ, (FOsBIH_rules (Γ, A --> B)) ->
    (forall C, FOsBIH_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 Γ,
    (FOsBIH_rules (Γ, A --> B)) ->
    (forall C, FOsBIH_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 Γ, (FOsBIH_rules (Γ, A ∨ B --> B ∨ A)).
Proof.
intros. apply FOsBIH_extens_FOwBIH. apply comm_Or_obj.
Qed.

Lemma scomm_Or : forall A B Γ,
    (FOsBIH_rules (Γ, A ∨ B)) ->
    (FOsBIH_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 Γ,
    (FOsBIH_rules (Γ, A --> B)) ->
    (forall C, FOsBIH_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 Γ,
    (FOsBIH_rules (Γ, A ∨ (⊥))) ->
    (FOsBIH_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 Γ,
  (FOsBIH_rules (Γ, (A --< B) --> C) ->
      FOsBIH_rules (Γ, A --> (B ∨ C))) *
  (FOsBIH_rules (Γ, A --> (B ∨ C)) ->
      FOsBIH_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,
  (FOsBIH_rules ((Empty_set form), (A --< B) --> C) ->
      FOsBIH_rules (Empty_set _, A --> ((B ∨ C)))) *
  (FOsBIH_rules (Empty_set _, A --> ((B ∨ C))) ->
      FOsBIH_rules (Empty_set _, (A --< B) --> C)).
Proof.
intros A B C. apply sdual_residuation_gen.
Qed.

Theorem FOsBIH_Detachment_Theorem : forall s,
           (FOsBIH_rules s) ->
           (forall A B Γ, (fst s = Γ) ->
                          (snd s = A --> B) ->
                          FOsBIH_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 (FOsBIH_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 -> FOsBIH_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 (FOsBIH_comp (Union form Γ0 (Singleton form A0), A --> B) f Γ0 J3). simpl in f0.
  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 (FOsBIH_monot (Γ0, A --> B) f0 (Union form Γ0 (Singleton form A))). simpl in f1. subst.
  apply f1. 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 (FOsBIH_monot _ J01). simpl in f. pose (f (Union form Γ0 (Singleton _ (∞ A0)))). simpl in f0.
  apply f0. intro ; intro. apply Union_introl ; auto. inversion H14.
  inversion H9. inversion H6. subst. apply FOsBIH_extens_FOwBIH. 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 (FOsBIH_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 (FOsBIH_monot (Γ0, (∃ A0) --> B) H3 (Union form Γ0 (Singleton form (∃ A0)))). simpl in f. apply f.
  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_FOsBIH_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 FOsBIH_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 (FOsBIH_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 Γ, (FOsBIH_rules (Γ, ¬ (∞ A)--> A)).
Proof.
intros A Γ. apply FOsBIH_extens_FOwBIH. apply wDN_to_form.
Qed.

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

Lemma sExcl_mon : forall A B C,
  (FOsBIH_rules (Empty_set _, A --> B)) ->
  (FOsBIH_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,
  (FOsBIH_rules (Empty_set _, A --> B)) ->
  (FOsBIH_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 Γ,
  (FOsBIH_rules (Γ, A --> (B ∨ C))) ->
  (FOsBIH_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 Γ,
  (FOsBIH_rules (Γ, ((∞ A) --> B))) ->
  (FOsBIH_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 Γ,
  (FOsBIH_rules (Γ, (⊤ --< A) --> B)) ->
  (FOsBIH_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 Γ,
  (FOsBIH_rules (Γ, A --> (⊤ --< B))) ->
  (FOsBIH_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 Γ,
  (FOsBIH_rules (Γ, A --> ((B ∨ C) ∨ D))) ->
  (FOsBIH_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 Γ,
    (FOsBIH_rules (Γ, (¬ (A --< B)) --> ((∞ B) --> (∞ A)))).
Proof.
intros A B Γ. apply FOsBIH_extens_FOwBIH. apply wClaim1.
Qed.

Lemma sDN_dist_imp : forall A B Γ,
    (FOsBIH_rules (Γ, (¬ (∞ (A --> B))) --> ((¬ (∞ A)) --> (¬ (∞ B))))).
Proof.
intros A B Γ. apply FOsBIH_extens_FOwBIH. 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 FOsBIH_Deduction_Theorem : forall s,
           (FOsBIH_rules s) ->
           (forall A B Γ, (fst s = Union _ Γ (Singleton _ A)) ->
                          (snd s = B) ->
                          (exists n, FOsBIH_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) ->
  FOsBIH_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: FOsBIH_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, FOsBIH_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: FOsBIH_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, FOsBIH_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 FOsBIH_extens_FOwBIH. 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 FOsBIH_extens_FOwBIH. 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_FOsBIH_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 (FOsBIH_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 (FOsBIH_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.

Lemma Closure_DN_strong : forall Γ A, FOsBIH_rules (Γ, A) -> forall n, FOsBIH_rules (Γ, DN_form n A).
Proof.
intros. induction n.
- simpl. auto.
- simpl. apply DNs with (ps:=[(Γ, DN_form n A)]).
  2: apply DNsRule_I. intros. inversion H0. subst. 2: inversion H1.
  auto.
Qed.

Theorem gen_FOsBIH_Double_Negated_Detachment_Theorem : forall A B Γ,
  (exists n, spair_der (Γ, Singleton _ ((DN_form n A) --> B))) ->
      spair_der (Union _ Γ (Singleton _ (A)), Singleton _ (B)).
Proof.
intros A B Γ spair. unfold spair_der. simpl. destruct spair.
destruct H. destruct H. destruct H0. simpl in H1. simpl in H0.
assert (x0 = [] \/ x0 = [DN_form x A --> B]).
{ destruct x0 ; subst ; simpl. auto. destruct x0 ; subst ; simpl ; auto. right. pose (H0 f).
  destruct i ; auto. simpl ; auto. exfalso. inversion H. inversion H5.
  apply H4. simpl. left. subst. pose (H0 f). destruct i ; auto. simpl ; auto.
  pose (H0 f0). destruct i ; auto. simpl ; auto. }
destruct H2.
- subst. simpl in H1. exists []. repeat split ; auto. intros. inversion H2. simpl.
  apply FOsBIH_monot with (Γ1:=Union _ Γ (Singleton _ A)) in H1 ; auto.
  intro. simpl. intros. apply Union_introl. auto.
- subst. simpl in H1. exists [B]. repeat split ; auto. apply NoDup_cons ; auto. apply NoDup_nil.
  intros. inversion H2. subst. apply In_singleton. inversion H3. simpl.
  apply sabsorp_Or1 in H1.
  apply MPs with (ps:=[(Union _ Γ (Singleton _ A), B --> (B ∨ ⊥));(Union _ Γ (Singleton _ A), B)]).
  2: apply MPRule_I. intros. inversion H2. subst. apply Axs. apply AxRule_I. apply RA2_I. exists B.
  exists ⊥. auto. inversion H3 ; subst. 2: inversion H4.
  apply MPs with (ps:=[(Union _ Γ (Singleton _ A), DN_form x A --> B);(Union _ Γ (Singleton _ A), DN_form x A)]).
  2: apply MPRule_I. intros. inversion H4. subst.
  apply FOsBIH_monot with (Γ1:=Union _ Γ (Singleton _ A)) in H1 ; auto.
  intro. intros. apply Union_introl ; auto. inversion H5. subst. 2: inversion H6.
  apply Closure_DN_strong. apply Ids. apply IdRule_I. apply Union_intror. apply In_singleton.
Qed.

End sMeta.


(*
 * An encoding of the untyped lambda calculus with numbers.
 *
 * Authors:
 *   Arjun Guha <arjun@cs.brown.edu>
 *   Benjamin Lerner <blerner@cs.brown.edu>
 *)
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.Le.
Require Import Coq.Arith.Lt.
Require Import Coq.Structures.Orders.
Require Import Coq.Arith.NatOrderedType.
Require Import Coq.MSets.MSetList.
Require Import Omega.
Set Implicit Arguments.

Module Type ATOM.

  Parameter atom : Set.
  Declare Module Atom_as_OT : UsualOrderedType with Definition t := atom.

End ATOM.

Module LC (Import Atom : ATOM).

Module Atoms := Coq.MSets.MSetList.Make (Atom.Atom_as_OT).

Definition atom := Atom.atom. (* free variables *)

Section Definitions.

Inductive exp : Set :=
  | exp_bvar : nat -> exp (* bound variables as de Brujin indices *)
  | exp_abs  : exp -> exp
  | exp_app  : exp -> exp -> exp
  | exp_err  : exp
  | exp_label : atom -> exp -> exp
  | exp_break : atom -> exp -> exp.

(* open_rec is the analogue of substitution for de Brujin indices.
  open_rec k u e replaces index k with u in e. *)
Fixpoint open_rec (k : nat) (u : exp) (e : exp) { struct e } := match e with
  | exp_bvar n    => if beq_nat k n then u else e
  | exp_abs  e    => exp_abs (open_rec (S k) u e)
  | exp_app e1 e2 => exp_app (open_rec k u e1) (open_rec k u e2)
  | exp_err       => e
  | exp_label x e => exp_label x (open_rec k u e)
  | exp_break x e => exp_break x (open_rec k u e)
end.

Definition open e u := open_rec 0 u e.

(* locally closed : all de Brujin indices are bound *)
Inductive lc' : nat -> exp -> Prop :=
  | lc_bvar : forall k n, k < n -> lc' n (exp_bvar k)
  | lc_abs  : forall n e,
      lc' (S n) e -> lc' n (exp_abs e)
  | lc_app  : forall n e1 e2, lc' n e1 -> lc' n e2 -> lc' n (exp_app e1 e2)
  | lc_err   : forall n, lc' n exp_err
  | lc_label : forall n x e, lc' n e -> lc' n (exp_label x e)
  | lc_break : forall n x e, lc' n e -> lc' n (exp_break x e).

Definition lc e := lc' 0 e.

Inductive val : exp -> Prop :=
  | val_abs : forall e, lc (exp_abs e) -> val (exp_abs e).

Inductive E : Set :=
  | E_hole  : E
  | E_app_1 : E -> exp -> E
  | E_app_2 : forall (v : exp), val v -> E -> E
  | E_label : atom -> E -> E
  | E_break : atom -> E -> E.

Inductive pot_redex : exp -> Prop :=
  | redex_app  : forall e1 e2, val e1 -> val e2 -> pot_redex (exp_app e1 e2)
  | redex_err  : pot_redex exp_err
  | redex_label : forall x v, val v -> pot_redex (exp_label x v)
  | redex_break : forall x v, val v -> pot_redex (exp_break x v).

Inductive decompose : exp -> E -> exp -> Prop :=
  | cxt_hole : forall e,
      pot_redex e ->
      decompose e E_hole e
  | cxt_app_1 : forall E e1 e2 e',
      decompose e1 E e' ->
      decompose (exp_app e1 e2) (E_app_1 E e2) e'
  | cxt_app_2 : forall E v e (p : val v) e',
      decompose e E e' ->
      decompose (exp_app v e) (E_app_2 p E) e'
  | cxt_break : forall x e E ae,
      decompose e E ae ->
      decompose (exp_break x e) (E_break x E) ae
  | cxt_label : forall x e E ae,
      decompose e E ae ->
      decompose (exp_label x e) (E_label x E) ae.

Inductive decompose1 : exp -> E -> exp -> Prop :=
  | cxt1_hole : forall e,
      pot_redex e ->
      decompose1 e E_hole e
  | cxt1_app_1 : forall e1 e2,
      decompose1 (exp_app e1 e2) (E_app_1 E_hole e2) e1
  | cxt1_app_2 : forall v e (p : val v),
      decompose1 (exp_app v e) (E_app_2 p E_hole) e
  | cxt1_break : forall x e,
      decompose1 (exp_break x e) (E_break x E_hole) e.

Fixpoint plug (e : exp) (cxt : E) := match cxt with
  | E_hole => e
  | E_app_1 cxt e2 => exp_app (plug e cxt) e2
  | E_app_2 v pf cxt => exp_app v (plug e cxt)
  | E_label x cxt => exp_label x (plug e cxt)
  | E_break x cxt => exp_break x (plug e cxt)
end.

Inductive contract :  exp -> exp -> Prop :=
  | contract_app  : forall e v,
      val v -> contract (exp_app (exp_abs e) v) (open e v)
  | contract_label : forall x v,
      val v -> contract (exp_label x v) v
  | contract_break_bubble : forall x v E e,
    decompose1 e E (exp_break x v) ->
    contract e (exp_break x v)
  | contract_break_match : forall x v,
    contract (exp_label x (exp_break x v)) v
  | contract_break_mismatch : forall x y v,
    x <> y ->
    contract (exp_label x (exp_break y v)) (exp_break y v).

Inductive step : exp -> exp -> Prop :=
  (* Slightly strange: exp_err -> exp_err -> exp_err -> ... *)
  | step_err : forall e E,
    lc e ->
    decompose e E exp_err ->
    step e exp_err
  | step_contract : forall e E ae e',
    lc e ->
    decompose e E ae ->
    contract ae e' ->
    step e (plug e' E).

End Definitions.

Hint Constructors decompose E val exp pot_redex exp val pot_redex lc' contract
                  step decompose1.
Hint Unfold open lc.

Lemma decompose_pot_redex : forall e E ae,
  decompose e E ae -> pot_redex ae.
Proof with auto. intros. induction H... Qed.

Lemma plug_ok : forall e E e',
  decompose e E e' -> plug e' E = e.
Proof.
intros.
induction H; simpl; try (auto || rewrite -> IHdecompose; auto).
Qed.

Ltac destruct_decomp e := match goal with
  |  [ H : exists E : E, exists ae : exp, decompose e E ae |- _ ] =>
       destruct H as [E [ae H]]
  | _ => fail
end.

Lemma decompose_lc : forall E e ae,
  lc e ->
  decompose e E ae ->
  lc ae.
Proof. intros. induction H0; inversion H; eauto. Qed.

Lemma decompose1_lc : forall E e ae,
  lc e ->
  decompose1 e E ae ->
  lc ae.
Proof. intros. induction H0; try (inversion H; eauto). Qed.

Ltac solve_decomp' := match goal with
  | [ H1 : lc' 0 ?e,
      IHe : val ?e \/
            (exists E' : E, exists ae : exp, decompose ?e E' ae)
      |- val ?exp \/ (exists E0 : E, exists ae : exp, decompose ?exp E0 ae) ]
    => (destruct IHe; right; eauto; destruct_decomp e; eauto)
  | [ |- _] => fail "solve_decomp'"
end.

Lemma ZZ : 0 = 0. reflexivity. Qed.

Ltac solve_decomp := match goal with
  | [ IH : 0 = 0 -> _ |- _ ]
    => (let Hidiot := fresh "x" in remember (IH ZZ) as Hidiot; solve_decomp')
  | [ |- _ ] => fail "flasd"
end.

Lemma decomp : forall e,
  lc e -> val e \/
          (exists E, exists ae, decompose e E ae).
Proof with eauto.
intros.
unfold lc in H.
remember 0.
induction H; intros; subst; try solve_decomp...
inversion H.
destruct IHlc'1. auto. right...  destruct IHlc'2. auto. eauto.
destruct_decomp e2. exists (E_app_2 H1 E)...
destruct_decomp e1. right. exists (E_app_1 E e2)...
Qed.

Hint Resolve decompose_lc decompose1_lc.

Lemma progress : forall e,
  lc e ->
  val e \/ (exists e', step e e').
Proof with eauto.
intros.
remember H as HLC.
clear HeqHLC.
apply decomp in H.
destruct H...
destruct_decomp e...
right.
assert (pot_redex ae). apply decompose_pot_redex in H...
inversion H0; subst;
  first [ inversion H1; subst; first [destruct b; eauto | eauto]
    | eauto ].
Qed.

Ltac solve_lc_plug := match goal with
  | [ IHdecompose : lc' 0 ?e -> lc' 0 (plug ?e' ?E),
      H : lc' 0 ?e
      |- context [plug ?e' ?E] ]
    => (apply IHdecompose in H; auto)
end.

Lemma lc_plug : forall E ae e e',
  lc e ->
  lc e' ->
  decompose e E ae ->
  lc (plug e' E).
Proof.
intros.
induction H1; first [ inversion H; subst; simpl; unfold lc in *; solve_lc_plug | auto ].
Qed.

Hint Resolve lc_plug.

Lemma lc_val : forall v,
  val v -> lc' 0 v.
Proof with auto.
intros. inversion H... Qed.

Lemma lc_active : forall e,
  pot_redex e -> lc e.
Proof. intros. unfold lc. inversion H; auto using lc_val. Qed.

Hint Resolve lc_active.

Lemma lc_ascend : forall k k' e, k' >= k -> lc' k e -> lc' k' e.
Proof with auto.
intros.
generalize dependent k'.
induction H0...
intros. apply lc_bvar. omega.
intros. apply lc_abs. apply IHlc'. omega.
Qed.

Lemma lc_open : forall k e u,
  lc' (S k) e ->
  lc' 0 u ->
  lc' k (open_rec k u e).
Proof with auto.
intros.
generalize dependent k.
induction e; intros.
simpl...
simpl.
assert (k >= n \/ k < n). apply le_or_lt.
destruct H1.
assert ({ k = n } + { k <> n }). decide equality.
destruct H2.
assert (beq_nat k n = true). rewrite -> beq_nat_true_iff...
rewrite -> H2.  assert (k >= 0). omega.
  apply lc_ascend with (k := 0) (k' := k)...
assert (beq_nat k n = false).  rewrite -> beq_nat_false_iff...
rewrite -> H2.
assert (n < k). omega. auto...
(* k < n *)
assert (beq_nat k n = false).  rewrite -> beq_nat_false_iff... omega.
rewrite -> H2. apply lc_bvar.
clear H2.
inversion H; subst.
assert False. omega.
inversion H2.
(* abs *)
simpl.
apply lc_abs.
inversion H; subst.
apply (IHe (S k) H3).
(* app *)
simpl; inversion H; subst;  eauto.
simpl; inversion H; subst;  eauto.
simpl; inversion H; subst;  eauto.
simpl; inversion H; subst;  eauto.
Qed.

Lemma lc_contract : forall ae e,
  lc ae ->
  contract ae e ->
  lc e.
Proof with auto.
intros.
destruct H0...
(* app *)
unfold lc in *.
inversion H; subst.
unfold open.
inversion H4; subst.
apply lc_open. exact H3. exact H5.
(* break *)
apply lc_val...
(* break *)
apply decompose1_lc with (E := E0) (e := e)...
inversion H; inversion H2; subst...
inversion H...
Qed.

Lemma preservation : forall e1 e2,
  lc e1 ->
  step e1 e2 ->
  lc e2.
Proof with auto.
intros.
unfold lc in *.
destruct H0. auto.
assert (pot_redex ae). apply decompose_pot_redex with (e := e) (E := E0)...
apply lc_active in H3.
apply lc_contract in H2...
apply lc_plug with (ae := ae) (e := e)...
Qed.

End LC.


Require Import init.

Require Import set.
Require Import ring_ideal.
Require Import unordered_list.

Require Export exterior_construct.
Require Import module_category.
Require Import algebra_category.
Require Import category_initterm.
Require Import tensor_algebra.

(* begin hide *)
Section ExteriorCategory.

(* end hide *)
Context {F : CRingObj} (V : ModuleObj F).

Record to_ext := make_to_ext {
    to_ext_algebra : AlgebraObj F;
    to_ext_homo : ModuleObjHomomorphism V (algebra_module to_ext_algebra);
    to_ext_alternating : ∀ v, (@zero _ (algebra_zero to_ext_algebra)) =
        @mult _ (algebra_mult to_ext_algebra) (to_ext_homo v) (to_ext_homo v);
}.

Definition to_ext_set (f g : to_ext)
    (h : cat_morphism (ALGEBRA F)
                      (to_ext_algebra f)
                      (to_ext_algebra g))
    := ∀ x, h (to_ext_homo f x) = to_ext_homo g x.

Definition to_ext_compose {F G H : to_ext}
    (f : set_type (to_ext_set G H)) (g : set_type (to_ext_set F G))
    := [f|] ∘ [g|].

Lemma to_ext_set_compose_in {F' G H : to_ext} :
        ∀ (f : set_type (to_ext_set G H)) g,
        to_ext_set F' H (to_ext_compose f g).
    intros [f f_eq] [g g_eq].
    unfold to_ext_set in *.
    unfold to_ext_compose; cbn.
    intros x.
    rewrite g_eq.
    apply f_eq.
Qed.

Lemma to_ext_set_id_in : ∀ f : to_ext, to_ext_set f f 𝟙.
    intros f.
    unfold to_ext_set.
    intros x.
    cbn.
    reflexivity.
Qed.

Program Instance TO_EXT : Category := {
    cat_U := to_ext;
    cat_morphism f g := set_type (to_ext_set f g);
    cat_compose {F G H} f g := [_|to_ext_set_compose_in f g];
    cat_id f := [_|to_ext_set_id_in f];
}.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_assoc (ALGEBRA F)).
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_lid (ALGEBRA F)).
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_rid (ALGEBRA F)).
Qed.

Definition vector_to_ext_homo := make_module_homomorphism
    F
    V
    (algebra_module (exterior_algebra V))
    (vector_to_ext V)
    (vector_to_ext_plus V)
    (vector_to_ext_scalar V).

Definition ext_to_ext := make_to_ext
    (exterior_algebra V)
    vector_to_ext_homo
    (ext_alternating V).

Theorem exterior_universal : @initial TO_EXT ext_to_ext.
    pose (UP := cring_plus F).
    pose (UZ := cring_zero F).
    pose (UN := cring_neg F).
    pose (UPC := cring_plus_comm F).
    pose (UPZ := cring_plus_lid F).
    pose (UPN := cring_plus_linv F).
    pose (UO := cring_one F).
    pose (TP := algebra_plus (tensor_algebra V)).
    pose (TZ := algebra_zero (tensor_algebra V)).
    pose (TN := algebra_neg (tensor_algebra V)).
    pose (TO := algebra_one (tensor_algebra V)).
    pose (TPA := algebra_plus_assoc (tensor_algebra V)).
    pose (TPC := algebra_plus_comm (tensor_algebra V)).
    pose (TPZ := algebra_plus_lid (tensor_algebra V)).
    pose (TPN := algebra_plus_linv (tensor_algebra V)).
    pose (TL := algebra_ldist (tensor_algebra V)).
    pose (TR := algebra_rdist (tensor_algebra V)).
    pose (TMA := algebra_mult_assoc (tensor_algebra V)).
    pose (TML := algebra_mult_lid (tensor_algebra V)).
    pose (TMR := algebra_mult_rid (tensor_algebra V)).
    pose (TSMO := algebra_scalar_id (tensor_algebra V)).
    pose (TSMR := algebra_scalar_rdist (tensor_algebra V)).
    pose (EP := ext_plus V).
    pose (ES := ext_scalar V).
    pose (EM := ext_mult V).
    pose (EO := ext_one V).
    unfold ext_to_ext, initial; cbn.
    intros [A f f_alt].
    unfold to_ext_set; cbn.
    pose (AP := algebra_plus A).
    pose (AZ := algebra_zero A).
    pose (AN := algebra_neg A).
    pose (APA := algebra_plus_assoc A).
    pose (APC := algebra_plus_comm A).
    pose (APZ := algebra_plus_lid A).
    pose (APN := algebra_plus_linv A).
    pose (ASM := algebra_scalar A).
    pose (ASMO := algebra_scalar_id A).
    pose (ASMR := algebra_scalar_rdist A).
    pose (AM := algebra_mult A).
    pose (AO := algebra_one A).
    pose (AL := algebra_ldist A).
    pose (AR := algebra_rdist A).
    apply singleton_ex; [>split|].
    -   apply ex_set_type.
        pose proof (tensor_algebra_universal V (make_to_algebra V A f)) as g_ex.
        apply ex_singleton in g_ex as [g g_eq]; cbn in *.
        unfold to_algebra_set in g_eq; cbn in g_eq.
        change (to_algebra_algebra V (to_tensor_algebra V))
            with (tensor_algebra V) in g.
        change (module_homo_f (to_algebra_homo V (to_tensor_algebra V)))
            with (@vector_to_tensor F V) in g_eq.
        assert (∀ a b, eq_equal (ideal_equiv (ext_ideal V)) a b →
            g a = g b) as g_wd.
        {
            intros a b eq.
            destruct eq as [l l_eq].
            rewrite <- plus_0_anb_a_b.
            rewrite <- (algebra_homo_neg g).
            rewrite <- (algebra_homo_plus _ _ g).
            unfold algebra_V, TN in l_eq.
            rewrite l_eq; clear l_eq.
            induction l as [|v l] using ulist_induction.
            {
                rewrite ulist_image_end, ulist_sum_end.
                symmetry; apply algebra_homo_zero.
            }
            rewrite ulist_image_add, ulist_sum_add.
            rewrite (algebra_homo_plus _ _ g).
            rewrite <- IHl; clear l IHl.
            rewrite plus_rid.
            destruct v as [[v1 v2] [v3 [v v3_eq]]]; cbn.
            rewrite v3_eq.
            do 3 rewrite (algebra_homo_mult _ _ g).
            rewrite g_eq.
            rewrite <- f_alt.
            rewrite mult_ranni, mult_lanni.
            reflexivity.
        }
        pose (h := unary_op g_wd).
        change (equiv_type (ideal_equiv (ext_ideal V))) with (ext V) in h.
        assert (h_plus : ∀ u v, h (u + v) = h u + h v).
        {
            intros u v.
            equiv_get_value u v.
            unfold plus at 1, h; equiv_simpl.
            apply algebra_homo_plus.
        }
        assert (h_scalar : ∀ a v, h (a · v) = a · h v).
        {
            intros a v.
            equiv_get_value v.
            unfold scalar_mult at 1, h; equiv_simpl.
            apply algebra_homo_scalar.
        }
        assert (h_mult : ∀ u v, h (u * v) = h u * h v).
        {
            intros u v.
            equiv_get_value u v.
            unfold mult at 1, h; equiv_simpl.
            apply algebra_homo_mult.
        }
        assert (h_one : h 1 = 1).
        {
            unfold one at 1, h; equiv_simpl.
            apply algebra_homo_one.
        }
        exists (make_algebra_homomorphism F (exterior_algebra V) A h
            h_plus h_scalar h_mult h_one).
        cbn.
        intros x.
        unfold h, vector_to_ext, tensor_to_ext; equiv_simpl.
        apply g_eq.
    -   intros [g g_eq] [h h_eq].
        apply set_type_eq; cbn.
        apply algebra_homomorphism_eq.
        intros x.
        pose proof (ext_sum V x) as [l l_eq]; subst x.
        induction l using ulist_induction.
        {
            rewrite ulist_image_end, ulist_sum_end.
            replace (algebra_homo_f g 0) with 0;
                [>|symmetry; apply (algebra_homo_zero g)].
            symmetry; apply (algebra_homo_zero h).
        }
        rewrite ulist_image_add, ulist_sum_add.
        do 2 rewrite algebra_homo_plus.
        rewrite IHl; clear IHl.
        apply rplus; clear l.
        destruct a as [α l]; cbn.
        do 2 rewrite algebra_homo_scalar.
        apply f_equal; clear α.
        induction l.
        {
            cbn.
            change (tensor_to_ext V 1) with (@one _ EO).
            do 2 rewrite algebra_homo_one.
            reflexivity.
        }
        cbn.
        do 2 rewrite algebra_homo_mult.
        rewrite IHl; clear IHl.
        apply rmult; clear l.
        rewrite g_eq, h_eq.
        reflexivity.
Qed.
(* begin hide *)

End ExteriorCategory.
(* end hide *)


Require Import AutoSep Malloc.

(** Theory of sets, with tactics and hints *)

Definition set := W -> Prop.

Definition mem (w : W) (s : set) := s w.
Infix "%in" := mem (at level 70, no associativity).

Definition empty : set := fun _ => False.

Definition equiv (s1 s2 : set) := forall w, s1 w <-> s2 w.
Infix "%=" := equiv (at level 70, no associativity).

Definition add (s : set) (w : W) : set := fun w' => w' = w \/ s w'.
Infix "%+" := add (at level 50, left associativity).

Definition del (s : set) (w : W) : set := fun w' => w' <> w /\ s w'.
Infix "%-" := del (at level 50, left associativity).

Definition less (s : set) (w : W) : set := fun w' => w' < w /\ s w'.
Definition greater (s : set) (w : W) : set := fun w' => w' > w /\ s w'.
Infix "%<" := less (at level 40, left associativity).
Infix "%>" := greater (at level 40, left associativity).

Ltac sets := subst;
  repeat match goal with
           | [ H : _ %= _ |- _ ] => generalize dependent H
           | [ H : _ %in _ |- _ ] => generalize dependent H
           | [ H : ~ _ %in _ |- _ ] => generalize dependent H
           | [ H : _ < _ |- _ ] => generalize dependent H
           | [ H : _ <= _ |- _ ] => generalize dependent H
           | [ H : @eq W _ _ |- _ ] => generalize dependent H
           | [ H : not (@eq W _ _) |- _ ] => generalize dependent H
           | [ H : @eq (word _) _ _ |- _ ] => generalize dependent H
           | [ H : not (@eq (word _) _ _) |- _ ] => generalize dependent H
           | [ H : _ \is _ |- _ ] => generalize dependent H
         end; clear;
  unfold equiv, empty, mem, add, del, less, greater, propToWord, IF_then_else; intros;
    try match goal with
          | [ |- context[?s ?w] ] =>
            match type of s with
              | set => repeat match goal with
                                | [ H : forall x : W, _ |- _ ] => specialize (H w)
                              end
            end
        end; intuition; subst;
    try match goal with
          | [ |- ~(_ = _) ] => intro; try subst
        end;
    try (nomega || (elimtype False; nomega)).

Hint Extern 5 (_ %= _) => sets.
Hint Extern 5 (_ %in _) => sets.
Hint Extern 5 (~ _ %in _) => sets.
Hint Extern 5 (_ <-> _) => sets.

Lemma wlt_trans : forall a b c : W, a < b -> b < c -> a < c.
  intros; nomega.
Qed.

Hint Extern 1 (_ < _) => eapply wlt_trans; eassumption.

(** * The finite set ADT *)

Section adt.
  Variable P : set -> W -> HProp.
  (* Abstract predicate for the data structure *)

  Variable res : nat.
  (* How many reserved stack slots? *)

  Definition initS : spec := SPEC reserving res
    PRE[_] mallocHeap
    POST[R] P empty R * mallocHeap.

  Definition lookupS : spec := SPEC("s", "k") reserving res
    Al s,
    PRE[V] P s (V "s") * mallocHeap
    POST[R] [| (V "k" %in s) \is R |] * P s (V "s") * mallocHeap.

  Definition addS : spec := SPEC("s", "k") reserving res
    Al s,
    PRE[V] P s (V "s") * mallocHeap
    POST[_] P (s %+ V "k") (V "s") * mallocHeap.

  Definition removeS : spec := SPEC("s", "k") reserving res
    Al s,
    PRE[V] P s (V "s") * mallocHeap
    POST[_] P (s %- V "k") (V "s") * mallocHeap.
End adt.


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

Require Import XRbase.
Require Import XRfunctions.
Require Import XSeqSeries.
Require Import XRtrigo1.
Require Import XR_sqrt.
Local Open Scope XR_scope.

(** * Distance *)

Definition dist_euc (x0 y0 x1 y1:R) : R :=
  sqrt (Rsqr (x0 - x1) + Rsqr (y0 - y1)).

Lemma distance_refl : forall x0 y0:R, dist_euc x0 y0 x0 y0 = R0.
Proof.
  intros x0 y0; unfold dist_euc; apply Rsqr_inj;
    [ apply sqrt_positivity; apply Rplus_le_le_0_compat;
      [ apply Rle_0_sqr | apply Rle_0_sqr ]
      | right; reflexivity
      | rewrite Rsqr_0; rewrite Rsqr_sqrt;
        [ unfold Rsqr; idtac
          | apply Rplus_le_le_0_compat; [ apply Rle_0_sqr | apply Rle_0_sqr ] ] ].
unfold Rminus.
repeat rewrite Rplus_opp_r.
rewrite Rmult_0_r.
rewrite Rplus_0_r.
reflexivity.
Qed.

Lemma distance_symm :
  forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0.
Proof.
  intros x0 y0 x1 y1; unfold dist_euc; apply Rsqr_inj;
    [ apply sqrt_positivity; apply Rplus_le_le_0_compat
      | apply sqrt_positivity; apply Rplus_le_le_0_compat
      | repeat rewrite Rsqr_sqrt;
        [ unfold Rsqr; idtac
          | apply Rplus_le_le_0_compat
          | apply Rplus_le_le_0_compat ] ]; try apply Rle_0_sqr.
fold (Rsqr (x0-x1)).
fold (Rsqr (y0-y1)).
fold (Rsqr (x1-x0)).
fold (Rsqr (y1-y0)).
Search (Rsqr (_ - _)).
rewrite (Rsqr_neg_minus).
apply Rplus_eq_compat_l.
rewrite (Rsqr_neg_minus).
reflexivity.
Qed.

Lemma law_cosines :
  forall x0 y0 x1 y1 x2 y2 ac:R,
    let a := dist_euc x1 y1 x0 y0 in
      let b := dist_euc x2 y2 x0 y0 in
        let c := dist_euc x2 y2 x1 y1 in
          a * c * cos ac = (x0 - x1) * (x2 - x1) + (y0 - y1) * (y2 - y1) ->
          Rsqr b = Rsqr c + Rsqr a - R2 * (a * c * cos ac).
Proof.
  unfold dist_euc; intros; repeat rewrite Rsqr_sqrt;
    [ rewrite H; unfold Rsqr; idtac
      | apply Rplus_le_le_0_compat
      | apply Rplus_le_le_0_compat
      | apply Rplus_le_le_0_compat ]; try apply Rle_0_sqr.

rewrite double.
unfold Rminus.
repeat rewrite Rmult_plus_distr_l.
repeat rewrite Rmult_plus_distr_r.
repeat rewrite <- Ropp_mult_distr_l.
repeat rewrite <- Ropp_mult_distr_r.
repeat rewrite Ropp_involutive.
repeat rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
repeat rewrite <- Rplus_assoc.
repeat rewrite Ropp_plus_distr.
repeat rewrite Ropp_involutive.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
symmetry.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
symmetry.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
symmetry.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
rewrite Rmult_comm.
repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
rewrite Rmult_comm.
rewrite <- Rplus_0_r.
repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
rewrite (Rplus_comm _ (- (x1*x2))).
repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l.
rewrite (Rplus_comm _ (- (x0*x1))).
repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l.
rewrite (Rplus_comm _ (x1*x1)).
repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l.
rewrite (Rplus_comm _ (- (y1*y2))).
repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l.
rewrite (Rplus_comm _ (- (y0*y1))).
repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l.
rewrite (Rplus_comm _ (y1*y1)).
repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l.
rewrite (Rplus_comm _ (x1*x2)).
repeat rewrite <- Rplus_assoc. rewrite Rmult_comm. rewrite Rplus_opp_r. rewrite Rplus_0_l.
rewrite (Rplus_comm _ (- (x1*x1))).
repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l.
rewrite (Rplus_comm _ (y1*y2)).
repeat rewrite <- Rplus_assoc. rewrite Rmult_comm. rewrite Rplus_opp_r. rewrite Rplus_0_l.
rewrite (Rplus_comm _ (- (y1*y1))).
repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l.
rewrite (Rplus_comm _ (x0*x1)).
repeat rewrite <- Rplus_assoc. rewrite Rmult_comm. rewrite Rplus_opp_r. rewrite Rplus_0_l.
rewrite Rmult_comm. rewrite Rplus_opp_l.
reflexivity.
Qed.

Lemma triangle :
  forall x0 y0 x1 y1 x2 y2:R,
    dist_euc x0 y0 x1 y1 <= dist_euc x0 y0 x2 y2 + dist_euc x2 y2 x1 y1.
Proof.
  intros; unfold dist_euc; apply Rsqr_incr_0;
    [ rewrite Rsqr_plus; repeat rewrite Rsqr_sqrt;
      [ replace (Rsqr (x0 - x1)) with
        (Rsqr (x0 - x2) + Rsqr (x2 - x1) + R2 * (x0 - x2) * (x2 - x1));
        [ replace (Rsqr (y0 - y1)) with
          (Rsqr (y0 - y2) + Rsqr (y2 - y1) + R2 * (y0 - y2) * (y2 - y1));
          [ apply Rplus_le_reg_l with
            (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
              Rsqr (y2 - y1));
            replace
            (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
              Rsqr (y2 - y1) +
              (Rsqr (x0 - x2) + Rsqr (x2 - x1) + R2 * (x0 - x2) * (x2 - x1) +
                (Rsqr (y0 - y2) + Rsqr (y2 - y1) + R2 * (y0 - y2) * (y2 - y1))))
            with (R2 * ((x0 - x2) * (x2 - x1) + (y0 - y2) * (y2 - y1)));
              [ replace
                (- Rsqr (x0 - x2) - Rsqr (x2 - x1) - Rsqr (y0 - y2) -
                  Rsqr (y2 - y1) +
                  (Rsqr (x0 - x2) + Rsqr (y0 - y2) +
                    (Rsqr (x2 - x1) + Rsqr (y2 - y1)) +
                    R2 * sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) *
                    sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1)))) with
                (R2 *
                  (sqrt (Rsqr (x0 - x2) + Rsqr (y0 - y2)) *
                    sqrt (Rsqr (x2 - x1) + Rsqr (y2 - y1))));
                [ (*apply Rmult_le_compat_l;
                  [ left; cut (0%nat <> 2%nat);
                    [ intros; generalize (lt_INR_0 2 (neq_O_lt 2 H));
                      intro H0; assumption
                      | discriminate ]
                    | apply sqrt_cauchy ] *) idtac
                  | idtac ]
                | idtac ]
            | idtac ]
          | idtac ]
        | apply Rplus_le_le_0_compat; apply Rle_0_sqr
        | apply Rplus_le_le_0_compat; apply Rle_0_sqr
        | apply Rplus_le_le_0_compat; apply Rle_0_sqr ]
      | apply sqrt_positivity; apply Rplus_le_le_0_compat; apply Rle_0_sqr
      | apply Rplus_le_le_0_compat; apply sqrt_positivity;
        apply Rplus_le_le_0_compat; apply Rle_0_sqr ].
{
  change (IZR 2) with R2.
  assert (sc:=sqrt_cauchy).
  specialize (sc (x0 - x2)).
  specialize (sc (y0 - y2)).
  specialize (sc (x2 - x1)).
  specialize (sc (y2 - y1)).
  pose (a := x0 - x2). fold a. fold a in sc.
  pose (b := y0 - y2). fold b. fold b in sc.
  pose (c := x2 - x1). fold c. fold c in sc.
  pose (d := y2 - y1). fold d. fold d in sc.
  unfold Rminus.
  repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (Rsqr a)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r, Rplus_0_l.
  rewrite (Rplus_comm _ (Rsqr c)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r, Rplus_0_l.
  rewrite (Rplus_comm _ (Rsqr b)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r, Rplus_0_l.
  rewrite (Rplus_comm _ (Rsqr d)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r, Rplus_0_l.
  repeat rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  left. exact Rlt_0_2.
  exact sc.
}
{
  symmetry.
  unfold Rminus.
  repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (Rsqr (x0 + - x2))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (Rsqr (x2 + - x1))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (Rsqr (y0 + - y2))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite Rplus_opp_l. rewrite Rplus_0_l.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  reflexivity.
}
{
  symmetry.
  unfold Rminus.
  repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (Rsqr (x0 + - x2))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (Rsqr (x2 + - x1))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (Rsqr (y0 + - y2))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (Rsqr (y2 + - y1))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  repeat rewrite Rmult_assoc.
  rewrite <- Rmult_plus_distr_l.
  apply Rmult_eq_compat_l.
  reflexivity.
}
{
  rewrite double.
  unfold Rminus.
  unfold Rsqr.
  repeat rewrite Rmult_plus_distr_l.
  repeat rewrite Rmult_plus_distr_r.
  repeat rewrite <- Ropp_mult_distr_l.
  repeat rewrite <- Ropp_mult_distr_r.
  repeat rewrite Ropp_involutive.
  repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (y1*y1)).
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  apply Rplus_eq_compat_r.
  rewrite (Rplus_comm _ (-(y0*y1))).
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  apply Rplus_eq_compat_r.
  rewrite (Rplus_comm _ (-(y1*y0))).
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  apply Rplus_eq_compat_r.
  rewrite <- Rplus_0_l.
  rewrite (Rplus_comm _ (-(y0*y1))).
  repeat rewrite Rplus_assoc;rewrite Rplus_comm;repeat rewrite <- Rplus_assoc.
  rewrite (Rmult_comm y0 y1).
  apply Rplus_eq_compat_r.
  rewrite (Rplus_comm _ (y0*y2)).
  repeat rewrite <- Rplus_assoc. rewrite Rmult_comm. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (y2*y0)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (-(y2*y2))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (-(y2*y2))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (y2*y1)).
  repeat rewrite <- Rplus_assoc. rewrite Rmult_comm. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite Rplus_opp_l. reflexivity.
}
{
  unfold Rsqr.
  unfold Rminus.
  repeat rewrite Rmult_plus_distr_l.
  repeat rewrite Rmult_plus_distr_r.
  repeat rewrite <- Ropp_mult_distr_l.
  repeat rewrite <- Ropp_mult_distr_r.
  repeat rewrite Ropp_involutive.
  repeat rewrite double.
  repeat rewrite <- Ropp_mult_distr_l.
  repeat rewrite Ropp_involutive.
  repeat rewrite <- Rplus_assoc.
  repeat rewrite Rmult_plus_distr_r.
  repeat rewrite Ropp_plus_distr.
  repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (x0*x2)).
  repeat rewrite <- Rplus_assoc. rewrite Rmult_comm. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (x2*x0)).
  repeat rewrite <- Rplus_assoc. rewrite Rmult_comm. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (-(x2*x2))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (-(x2*x2))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (x2*x1)).
  repeat rewrite <- Rplus_assoc. rewrite Rmult_comm. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite (Rplus_comm _ (x1*x2)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_0_l.
  rewrite Rplus_comm.
  rewrite Rmult_comm.
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  rewrite Rplus_comm.
  reflexivity.
}
Qed.

(******************************************************************)
(** *                       Translation                           *)
(******************************************************************)

Definition xt (x tx:R) : R := x + tx.
Definition yt (y ty:R) : R := y + ty.

Lemma translation_0 : forall x y:R, xt x R0 = x /\ yt y R0 = y.
Proof.
  intros x y; split; [ unfold xt | unfold yt ].
  rewrite Rplus_0_r;reflexivity.
  rewrite Rplus_0_r;reflexivity.
Qed.

Lemma isometric_translation :
  forall x1 x2 y1 y2 tx ty:R,
    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
    Rsqr (xt x1 tx - xt x2 tx) + Rsqr (yt y1 ty - yt y2 ty).
Proof.
  intros; unfold Rsqr, xt, yt.
  unfold Rminus.
  repeat rewrite Ropp_plus_distr.
  repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ tx).
  repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (-tx)).
  repeat rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l, Rplus_0_l.
  rewrite (Rplus_comm _ ty).
  repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (-ty)).
  repeat rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l, Rplus_0_l.
  reflexivity.
Qed.

(******************************************************************)
(** *                         Rotation                            *)
(******************************************************************)

Definition xr (x y theta:R) : R := x * cos theta + y * sin theta.
Definition yr (x y theta:R) : R := - x * sin theta + y * cos theta.

Lemma rotation_0 : forall x y:R, xr x y R0 = x /\ yr x y R0 = y.
Proof.
  intros x y; unfold xr, yr; split; rewrite cos_0; rewrite sin_0.
  rewrite Rmult_0_r, Rmult_1_r, Rplus_0_r. reflexivity.
  rewrite Rmult_0_r, Rmult_1_r, Rplus_0_l. reflexivity.
Qed.

Lemma rotation_PI2 :
  forall x y:R, xr x y (PI / R2) = y /\ yr x y (PI / R2) = - x.
Proof.
  intros x y; unfold xr, yr; split; rewrite cos_PI2; rewrite sin_PI2.
  rewrite Rmult_0_r, Rmult_1_r, Rplus_0_l. reflexivity.
  rewrite Rmult_0_r, Rmult_1_r, Rplus_0_r. reflexivity.
Qed.

Lemma isometric_rotation_0 :
  forall x1 y1 x2 y2 theta:R,
    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
    Rsqr (xr x1 y1 theta - xr x2 y2 theta) +
    Rsqr (yr x1 y1 theta - yr x2 y2 theta).
Proof.
  intros; unfold xr, yr;
    replace
    (x1 * cos theta + y1 * sin theta - (x2 * cos theta + y2 * sin theta)) with
    (cos theta * (x1 - x2) + sin theta * (y1 - y2));
    [ replace
      (- x1 * sin theta + y1 * cos theta - (- x2 * sin theta + y2 * cos theta))
      with (cos theta * (y1 - y2) + sin theta * (x2 - x1));
        [ repeat rewrite Rsqr_plus; repeat rewrite Rsqr_mult; repeat rewrite cos2
          (*
          ring_simplify; replace (x2 - x1) with (- (x1 - x2));
          [ rewrite <- Rsqr_neg; ring | ring ] *)
          | idtac ]
      | idtac ].
{
  unfold Rminus.
  unfold Rsqr.
  repeat rewrite Rmult_plus_distr_l.
  repeat rewrite Rmult_plus_distr_r.
  change (IZR 2) with R2.
  unfold R2.
  repeat rewrite Rmult_plus_distr_l.
  repeat rewrite Rmult_plus_distr_r.
  repeat rewrite <- Ropp_mult_distr_l.
  repeat rewrite <- Ropp_mult_distr_r.
  repeat rewrite Ropp_involutive.
  repeat rewrite Rmult_1_l.
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  repeat rewrite <- Ropp_mult_distr_l.
  repeat rewrite Ropp_involutive.
  set (st := sin theta).
  set (ct := cos theta).
  symmetry.
  repeat rewrite <- Rmult_assoc.
  rewrite (Rplus_comm _ (-(x1*x2))).
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (x2*x2)).
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (y1*y1)).
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (-(y2*y1))).
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (-(y1*y2))).
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  rewrite <- Rplus_0_r.
  rewrite (Rplus_comm _ (y2*y2)).
  repeat rewrite Rplus_assoc;apply Rplus_eq_compat_l;repeat rewrite <- Rplus_assoc.
  rewrite (Rplus_comm _ (st*st*x1*x1)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r, Rplus_0_l.
  rewrite (Rplus_comm _ (-(st*st*x2*x1))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l, Rplus_0_l.
  rewrite (Rplus_comm _ (-(st*st*x1*x2))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l, Rplus_0_l.
  rewrite (Rplus_comm _ (st*st*x2*x2)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r, Rplus_0_l.
  rewrite (Rplus_comm _ (-(st*st*y1*y1))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l, Rplus_0_l.
  rewrite (Rplus_comm _ (st*st*y2*y1)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r, Rplus_0_l.
  rewrite (Rplus_comm _ (st*st*y1*y2)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r, Rplus_0_l.
  rewrite (Rplus_comm _ (-(st*st*y2*y2))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l, Rplus_0_l.
  rewrite (Rplus_comm _ (-(ct*y1*st*x1))).
  repeat rewrite <- Rplus_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm y1); repeat rewrite <- Rmult_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm st); repeat rewrite <- Rmult_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm y1); repeat rewrite <- Rmult_assoc.
  rewrite Rplus_opp_l, Rplus_0_l.
  rewrite (Rplus_comm _ (-(ct*x1*st*y1))).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_l, Rplus_0_l.
  rewrite (Rplus_comm _ (ct*y1*st*x2)).
  repeat rewrite <- Rplus_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm y1); repeat rewrite <- Rmult_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm st); repeat rewrite <- Rmult_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm y1); repeat rewrite <- Rmult_assoc.
  rewrite Rplus_opp_r, Rplus_0_l.
  rewrite (Rplus_comm _ (ct*x2*st*y1)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r, Rplus_0_l.
  rewrite (Rplus_comm _ (ct*y2*st*x1)).
  repeat rewrite <- Rplus_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm y2); repeat rewrite <- Rmult_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm st); repeat rewrite <- Rmult_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm y2); repeat rewrite <- Rmult_assoc.
  rewrite Rplus_opp_r, Rplus_0_l.
  rewrite (Rplus_comm _ (ct*x1*st*y2)).
  repeat rewrite <- Rplus_assoc. rewrite Rplus_opp_r, Rplus_0_l.
  rewrite (Rplus_comm _ (-(ct*y2*st*x2))).
  repeat rewrite <- Rplus_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm y2); repeat rewrite <- Rmult_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm st); repeat rewrite <- Rmult_assoc.
    repeat rewrite Rmult_assoc; rewrite (Rmult_comm y2); repeat rewrite <- Rmult_assoc.
  rewrite Rplus_opp_l, Rplus_0_l.
  rewrite Rplus_opp_r.
  reflexivity.
}
{
  unfold Rminus.
  rewrite Ropp_plus_distr.
  repeat rewrite <- Ropp_mult_distr_l.
  rewrite Ropp_involutive.
  repeat rewrite Rmult_plus_distr_l.
  repeat rewrite <- Ropp_mult_distr_r.
  rewrite (Rmult_comm _ y1).
  rewrite (Rmult_comm _ y2).
  rewrite (Rmult_comm _ x2).
  rewrite (Rmult_comm _ x1).
  rewrite Rplus_comm.
  repeat rewrite <- Rplus_assoc; apply Rplus_eq_compat_r.
  repeat rewrite <- Rplus_assoc; rewrite Rplus_comm.
  repeat rewrite <- Rplus_assoc; rewrite Rplus_comm.
  repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
  reflexivity.
}
{
  unfold Rminus.
  rewrite Ropp_plus_distr.
  repeat rewrite Rmult_plus_distr_l.
  repeat rewrite <- Ropp_mult_distr_r.
  rewrite (Rmult_comm _ y1).
  rewrite (Rmult_comm _ y2).
  rewrite (Rmult_comm _ x2).
  rewrite (Rmult_comm _ x1).
  repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
  repeat rewrite <- Rplus_assoc; apply Rplus_eq_compat_r.
  rewrite Rplus_comm.
  reflexivity.
}
Qed.

Lemma isometric_rotation :
  forall x1 y1 x2 y2 theta:R,
    dist_euc x1 y1 x2 y2 =
    dist_euc (xr x1 y1 theta) (yr x1 y1 theta) (xr x2 y2 theta)
    (yr x2 y2 theta).
Proof.
  unfold dist_euc; intros; apply Rsqr_inj;
    [ apply sqrt_positivity; apply Rplus_le_le_0_compat
      | apply sqrt_positivity; apply Rplus_le_le_0_compat
      | repeat rewrite Rsqr_sqrt;
        [ apply isometric_rotation_0
          | apply Rplus_le_le_0_compat
          | apply Rplus_le_le_0_compat ] ]; apply Rle_0_sqr.
Qed.

(******************************************************************)
(** *                       Similarity                            *)
(******************************************************************)

Lemma isometric_rot_trans :
  forall x1 y1 x2 y2 tx ty theta:R,
    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
    Rsqr (xr (xt x1 tx) (yt y1 ty) theta - xr (xt x2 tx) (yt y2 ty) theta) +
    Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta).
Proof.
  intros; rewrite <- isometric_rotation_0; apply isometric_translation.
Qed.

Lemma isometric_trans_rot :
  forall x1 y1 x2 y2 tx ty theta:R,
    Rsqr (x1 - x2) + Rsqr (y1 - y2) =
    Rsqr (xt (xr x1 y1 theta) tx - xt (xr x2 y2 theta) tx) +
    Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty).
Proof.
  intros; rewrite <- isometric_translation; apply isometric_rotation_0.
Qed.