Load prototheticv5.

Require Import Coq.Init.Tactics.
Require Import Relation_Definitions.
Require Import Coq.Program.Basics.
Require Export Coq.Classes.RelationClasses.
Require Import Coq.Structures.Equalities.
Require Export Relation_Definitions.
Require Import Relation_Definitions Setoid.
Require Import Coq.Classes.Morphisms.

Module Type Mereology (dolce:DOLCE_root)(proto:Protothetic dolce).
Import dolce.
Import proto.

Set Typeclasses Axioms Are Instances.

(* ====================== ONTOLOGICAL AXIOM  ============================= *)

Parameter epsilon : relation N.

(* no typing on singulars and plurals *)
Notation "A 'ε' b" := (epsilon A b)  (at level 40).

Axiom isEpsilon : forall A a, A ε a ≡≡ ((¬forall B, ¬(B ε A)) ∧
                                        (forall C D, ((C ε A) ∧ (D ε A)) ⊃ (C ε D)) ∧
                                        (forall C, (C ε A) ⊃ (C ε a))).

(************** Meta rules of existential introduction/elimination  ********)

Lemma elim_ex : forall a:N, ¬(forall B, ¬(B ε a)) ⊃ exists B:N, (B ε a).
Proof.
intros a;elimP.
apply (elim_dneg (exists B : N, B ε a)).
elim_def1 T5 (¬(exists B : N, B ε a)).
splitP;[ elimP;elim_def1_in_hyp T5 (forall B : N, ¬B ε a);clear H;
       apply_Lem_in_hyp (not_implies_F (forall B : N, ¬B ε a)) H1;
       apply_Lem_in_goal H1;intro A;elim_def1 T5 (A ε a);splitP;[
             elimP;elim_def1_in_hyp T5 (exists B : N, B ε a);
             apply_Lem_in_hyp (not_implies_F (exists B : N, B ε a)) H2;
             apply_Lem_in_goal H2;exists A;assumption
            | elimP;apply (elim_F (A ε a));assumption ]
    | elimP;apply (elim_F (¬(exists B : N, B ε a)));assumption
].
Qed.

Lemma intro_ex : forall a:N, (exists B:N, (B ε a)) ⊃ ¬(forall B, ¬(B ε a)).
Proof.
intro a;elimP.
elim_def1 T5 (forall B : N, ¬B ε a).
splitP;[ elimP;elim H;intros B H1;specialize (H0 B);apply_def_in_hyp (T5 (B ε a)) H0;
      apply (detachL (B ε a) F) in H2;assumption |
      elimP;apply (elim_F (forall B : N, ¬B ε a));assumption ].
Qed.

(* ==================================== ONTOLOGICAL DEFINITIONS =============================== *)

Parameter exist_at_least      : N->Prop.
Parameter D1                  : forall a, exist_at_least a ≡≡ ¬forall A, ¬(A ε a).                  (* D1 *)

Parameter exist_at_most       : N -> Prop.
Parameter D2                  : forall a:N, exist_at_most a ≡≡ forall B C, B ε a ∧ C ε a ⊃ B ε C.   (* D2 *)

Parameter exist_exactly       : N -> Prop.
Parameter D3                  : forall A, exist_exactly A ≡≡ forall b, A ε b.                       (* D3 *)

Parameter singular_equality   : N -> N -> Prop.
Parameter D4                  : forall A B,  singular_equality A B ≡≡ (A ε B ∧ B ε A).              (* D4 *)

Parameter singular_difference : N -> N -> Prop.
Parameter D5                  : forall A B, singular_difference A B ≡≡ (A ε A ∧ B ε B ∧
                                                                         ¬singular_equality A B).   (* D5 *)

Parameter weak_equality       : N -> N -> Prop.
Parameter D6                  : forall a b,  weak_equality a b ≡≡ forall A, (A ε a ≡≡ A ε b).       (* D6 *)

Parameter strong_equality     : N -> N -> Prop.
Parameter D7                  : forall a b, strong_equality a b ≡≡ ((¬forall G, ¬(G ε a)) ∧
                                                                   forall G, (G ε a) ≡≡ (G ε b)).   (* D7 *)

Parameter weak_inclusion      : N -> N -> Prop.
Parameter D8                  : forall a b, weak_inclusion a b ≡≡ forall A, (A ε a) ⊃ (A ε b).      (* D8 *)

Parameter strong_inclusion    : N -> N -> Prop.
Parameter D9                  : forall a b, strong_inclusion a b ≡≡ (¬forall A, ¬(A ε a)) ∧ (forall C, C ε a ⊃ C ε b).    (* D9 *)

Parameter partial_inclusion   : N -> N -> Prop.
Parameter D10                 : forall a b, partial_inclusion a b ≡≡ ¬forall G, ¬(G ε a ∧ G ε b).   (* D10 *)

Parameter empty               : N.
Parameter D13                 : forall A, A ε empty ≡≡ (A ε A ∧ ¬(A ε A)).                          (* D13 *)

Parameter universal           : N.
Parameter D14                 : forall A, A ε universal ≡≡ (A ε A).                                 (* D14 *)

Parameter distinct            : N -> N.
Parameter D15                 : forall A b, A ε (distinct b) ≡≡ (A ε A ∧ ¬(A ε b)).                 (* D15 *)

Parameter meet                : N -> N -> N.
Parameter D16                 : forall A a b,  A ε (meet a b) ≡≡ (A ε A ∧ A ε a ∧ A ε b).           (* D16 *)

(* =========================== ONTOLOGICAL THEOREMS =============================== *)

Class Antisymmetric  (R:relation N) :=
      antisymmetry : forall a b, R a b ∧ R b a ⊃ singular_equality a b.

Class Reflexive  (R:relation N) :=
      reflexivity : forall A, A ε A ⊃ R A A.

Class Transitive  (R:relation N) :=
      transitivity : forall A B C, R A B ∧ R B C ⊃ R A C.

Class POrder (R:relation N) := {
   por_refl    :> Reflexive R;
   por_antisym :> Antisymmetric R;
   por_trans   :> Transitive R}.

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

Lemma L001 : forall A, (A ε A) ⊃ singular_equality A A.
Proof.
intro A;elimP.
assert (H1:((A ε A) ∧ (A ε A))).
splitP;assumption.
elim_def2 D4 A A;assumption.
Qed.

Lemma L002 : forall P Q:Prop, P ⊃ P ∨ Q.
Proof.
intros P Q;elimP.
apply (intro_disjL P Q).
assumption.
Qed.

Lemma OntoT0 : forall A a, A ε a ⊃ (forall C, (C ε A) ⊃ (C ε A)).
Proof.
intros;elimP.
intro;elimP;assumption.
Qed.

Lemma OntoT1 : forall A a, A ε a ⊃ ¬forall B, ¬(B ε A).
Proof.
intros A a;elimP.
apply_def_in_hyp (isEpsilon A a) H.
decompose_and H0;assumption.
Qed.

Lemma OntoT2 : forall A a, A ε a ⊃ forall C D, ((C ε A) ∧ (D ε A)) ⊃ (C ε D).
Proof.
intros A a;elimP.
apply_def_in_hyp (isEpsilon A a) H.
decompose_and H0;assumption.
Qed.

Lemma OntoT3 : forall A a, A ε a ⊃ (forall C, C ε A ⊃ C ε a).
Proof.
intros A a;elimP.
apply_def_in_hyp (isEpsilon A a) H.
decompose_and H0;assumption.
Qed.

Lemma OntoT4 : forall A a, ((¬forall B, ¬(B ε A)) ∧
                            (forall C D, (C ε A ∧ D ε A ⊃ C ε D)) ∧
                            (forall C, C ε A  ⊃ C ε a)) ⊃  A ε a.
Proof.
intros A a;elimP.
apply_def_in_hyp (isEpsilon A a) H;assumption.
Qed.

(* If A is something, then A is a singular *)

Lemma OntoT5 : forall A b, A ε b ⊃ A ε A.
Proof.
intros A b;elimP.
apply_Lem_in_goal (OntoT4 A A).
splitP;[ apply_Lem_in_hyp (OntoT1 A b) H;assumption |
         apply_Lem_in_goal (OntoT2 A b);assumption |
         apply_Lem_in_goal (OntoT0 A b);assumption ].
Qed.

(* characteristic thesis of the ontology  *)

Lemma OntoT6 : forall a A B, A ε B ∧ B ε a ⊃ B ε A.
Proof.
intros a A B.
elimP.
decompose_and H.
assert (H1:=H).
assert (H2:=H).
apply_Lem_in_hyp (OntoT5 B a) H.
apply_Lem_in_hyp (OntoT1 B a) H1.
apply_Lem2_in_hyp (OntoT2 B a) H2 B A. (* type forall à 2 args *)
elimP_in_hyp H3;[assumption | splitP;assumption ].
Qed.

Lemma OntoT7 : forall A B a, A ε B ∧ B ε a ⊃ A ε a.
Proof.
intros A B a.
elimP.
decompose_and H.
elim_def2_in_hyp isEpsilon B a.
decompose_and H1.
specialize (H1 A).
apply_Lem_in_hyp H1 H0;assumption.
Qed.

(* contradictory name *)

Lemma OntoT8 : forall A, ¬(A ε empty).
Proof.
intro A.
elim_def1 T5 (A ε empty).
splitP;[ elimP;apply_def_in_hyp (D13 A) H;decompose_and H0;
    apply_def_in_hyp (T5 (A ε A)) H0;apply (detachL (A ε A) F) in H2;assumption |
  elimP;apply (elim_F (A ε empty));assumption  ].
Qed.

(* empty name is not a singular *)

Lemma OntoT9 : ¬(empty ε empty).
Proof.
apply (OntoT8 empty).
Qed.

(* it is false that any name is a singular - creativity *)

Lemma OntoT10 : ¬forall A, A ε A.
Proof.
elim_def1 T5 (forall A, A ε A).
splitP;[ elimP;specialize (H empty);intro_lemma_in_hyp OntoT9;
         apply_def_in_hyp (T5 (empty ε empty)) H0;
         apply (detachL (empty ε empty) F) in H1;assumption  |
     elimP;apply (elim_F (forall A : N, A ε A));assumption ].
Qed.

Lemma OntoT12 : forall A b, A ε (distinct b) ⊃ ¬(A ε b).
Proof.
intros A b;elimP.
apply_def_in_hyp (D15 A b) H.
decompose_and H0;assumption.
Qed.

Lemma OntoT14 : forall A, A ε A ⊃ ¬forall b, ¬(A ε b).
Proof.
intros A;elimP.
elim_def1 T5 (forall b : N, ¬A ε b).
splitP;[elimP;specialize (H0 A);apply_def_in_hyp (T5 (A ε A)) H0;
        apply (detachL (A ε A) F) in H1;assumption |
       elimP;apply (elim_F (forall b : N, ¬A ε b));assumption ].
Qed.

Lemma OntoT17 : ¬exist_at_least empty.
Proof.
elim_def1 T5 (exist_at_least empty).
splitP;[ elimP;apply_def_in_hyp (D1 empty) H;
          apply_def_in_hyp (T5 (forall A : N, ¬A ε empty)) H0;
          intro_lemma_in_hyp OntoT8;apply (detachL (forall A : N, ¬A ε empty) F) in H2;
          [ assumption  | assumption ]  |
     elimP;apply (elim_F (exist_at_least empty));assumption ].
Qed.

Lemma OntoT18 : forall A a, A ε a ⊃ weak_inclusion A a.
Proof.
intros A a;elimP.
elim_def2 D8 A a.
intro B;elimP.
apply_Lem_in_goal (OntoT7 B A a).
splitP;assumption.
Qed.

Lemma OntoT21 : forall A B a, A ε B ∧ B ε a ⊃ singular_equality A B.
Proof.
intros A B a;elimP.
assert (H1:=H).
decompose_and H.
apply_Lem_in_hyp (OntoT6 a A B) H1.
elim_def2 D4 A B.
splitP; assumption.
Qed.

Lemma OntoT23 : forall a, weak_equality a a.
Proof.
intro a.
elim_def2 D6 a a.
intro A.
reflexivity.
Qed.

Lemma OntoT24 : forall a b, weak_equality a b ⊃ weak_equality b a.
Proof.
intros a b;elimP.
elim_def2 D6 b a.
intro A.
apply_def1_in_hyp (D6 a b) H A.
symmetry;assumption.
Qed.

Lemma OntoT25 : forall a b c, weak_equality a b ∧ weak_equality b c ⊃ weak_equality a c.
Proof.
intros a b c;elimP.
decompose_and H.
elim_def2 D6 a c.
intro A.
apply_def1_in_hyp (D6 a b) H0 A.
apply_def1_in_hyp (D6 b c) H A.
apply (ProtoTrans (A ε a)(A ε b)(A ε c) H1 H2).
Qed.

Lemma OntoT27 : forall a b, singular_equality a b ⊃ singular_equality b a.
Proof.
intros A B;elimP.
elim_def2 D4 B A.
apply_def_in_hyp (D4 A B) H.
decompose_and H0.
splitP;assumption.
Qed.

Lemma OntoT28 : forall a b c, singular_equality a b ∧ singular_equality b c ⊃ singular_equality a c.
Proof.
intros a b c;elimP.
decompose_and H.
elim_def2 D4 a c.
apply_def_in_hyp (D4 a b) H0.
apply_def_in_hyp (D4 b c) H.
decompose_and H1.
decompose_and H2.
splitP;[ apply_Lem1_in_hyp (OntoT3 b c) H4 a;apply_Lem_in_hyp H5 H3;assumption |
        apply_Lem1_in_hyp (OntoT3 b a) H1 c;apply_Lem_in_hyp H5 H2;assumption ].
Qed.

(*===============================================================*)
(********************* Setoids  *******************)
(*===============================================================*)

(* allow to define appropriate structures for use of N_rewrite, the last argument must be
 the variable that is involved in the  weak_equality a ≡≡≡ b *)

Parameter eq_N       : N -> N -> Prop.
Parameter def_eq_N   : forall a b,  eq_N a b ≡≡ forall A, (A ε a ≡≡ A ε b).

(*****  Extensionality of type Protothetic: examples  ******)
Structure Morphism_NS  : Type := {
  F1       :> N->Prop ;
  compatN  : forall (a b:N), eq_N a b ≡≡ (F1 a ≡≡ (F1 b))}.

Add Parametric Morphism  (M : Morphism_NS) :
            (@F1 M) with signature (@eq_N ==> @eqP) as extensional_propN.
Proof.
intros a b H.
assert (H1:(eq_N a b ≡≡ (M a ≡≡ (M b)))).
apply (compatN M).
apply (detachL (eq_N a b)(M a ≡≡ M b)) in H1;assumption.
Qed.

(*******  Extensionality of type Ontologic:  morphism with different relation structures *************)

Parameter star      : (N->N)-> Prop.
Parameter D27       : forall alpha:N->N,  star alpha ≡≡ ¬ forall A a, ¬(A ε (alpha a)).

Parameter eq_NN     : (N->N)->(N->N)->Prop.
Parameter def_eq_NN : forall (alpha beta:N->N), eq_NN alpha beta ≡≡ forall A a:N, (A ε (alpha a) ≡≡ (A ε (beta a))).

Structure Morphism_NNS  : Type := {
  F2       :> (N->N)->Prop ;
  compatNN  : forall (alpha beta:N->N), (eq_NN alpha beta ≡≡ (F2 alpha ≡≡ (F2 beta)))}.

Add Parametric Morphism  (M : Morphism_NNS) :
            (@F2 M) with signature (@eq_NN ==> @eqP ) as extensional_prop2.
Proof.
intros a b H.
assert (H1:(eq_NN a b ≡≡ (M a ≡≡ (M b)))).
apply (compatNN M).
apply (detachL (eq_NN a b)(M a ≡≡ M b)) in H1;assumption.
Qed.

Definition Psi (E1:N->N->Prop)(E2:N)(E3:N->N)(E4:N) := E1 E2 (E3 E4).
Definition Psi' (E1:N->N->Prop)(E3:N->N)(E4:N->N)(E5:N)(E2:N) := E1 E2 (E3 (E4 E5)).
Definition Psi'' (E1:N->N->Prop)(E3:N->N)(E5:N)(E2:N) := E1 E2 (E3 E5).

Structure Morphism_N_N : Type := {
        phi        :> N->N;
        compat_N_1 : forall (a b A: N), eq_N a b ≡≡ (epsilon A (phi a) ≡≡ epsilon A (phi b));
        compat_N_2 : forall (A B a: N), eq_N A B ≡≡ (epsilon A (phi (phi a)) ≡≡ epsilon B (phi (phi a)));
        compat_N_3 : forall (A B a: N), eq_N A B ≡≡ (epsilon A (phi a) ≡≡ epsilon B (phi a))}.

Add Parametric Morphism (M : Morphism_N_N) :
           (Psi epsilon _ (@phi M)) with signature (@eq_N ==> @eqP) as extensional_N_1.
Proof.
   intros a b H1.
   assert (H2:(eq_N a b ≡≡ (Psi epsilon universal M a ≡≡ Psi epsilon universal M b))).
   apply (compat_N_1 M) with (a:=a)(b:=b).
   apply (detachL (eq_N a b)(Psi epsilon universal M a ≡≡ Psi epsilon universal M b)) in H2;assumption.
Qed.

Add Parametric Morphism (M : Morphism_N_N) :
            (Psi' epsilon (@phi M)(@phi M) _ ) with signature (@eq_N ==> @eqP) as extensional_N_2.
Proof.
   intros A B H1.
   assert (H2:(eq_N A B ≡≡ (Psi' epsilon M M universal A ≡≡ Psi' epsilon M M universal B))).
   apply (compat_N_2 M) with (A:=A)(B:=B).
   apply (detachL (eq_N A B)(Psi' epsilon M M universal A ≡≡ Psi' epsilon M M universal B)) in H2;assumption.
Qed.

Add Parametric Morphism (M : Morphism_N_N) :
            (Psi'' epsilon (@phi M) _) with signature (@eq_N ==> @eqP) as extensional_N_3.
Proof.
   intros A B H1.
   assert (H2:(eq_N A B ≡≡ (Psi'' epsilon M universal A ≡≡ Psi'' epsilon M universal B))).
   apply (compat_N_3 M) with (A:=A)(B:=B).
   apply (detachL (eq_N A B)(Psi'' epsilon M universal A ≡≡ Psi'' epsilon M universal B)) in H2;assumption.
Qed.

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

Lemma OntoT29 : forall A B, (singular_equality A B ⊃ weak_equality A B).
Proof.
intros A B;elimP.
apply_def_in_hyp (D4 A B) H.
decompose_and H0.
elim_def2 D6 A B.
intro C.
splitP;[elimP;apply_Lem_in_goal (OntoT7 C A B);splitP;assumption |
        elimP;apply_Lem_in_goal (OntoT7 C B A);splitP;assumption ].
Qed.

Lemma OntoT30 : forall A B, (singular_equality A B ⊃ eq_N A B).
Proof.
intros A B;elimP.
apply_def_in_hyp (D4 A B) H.
decompose_and H0.
elim_def2 def_eq_N A B.
intro C;splitP;[
    elimP;apply_Lem_in_goal (OntoT7 C A B);splitP;assumption |
    elimP;apply_Lem_in_goal (OntoT7 C B A);splitP;assumption ].
Qed.

(* ====================== MEREOLOGICAL DEFINITIONS & AXIOMS ============================= *)

Parameter pt       : Morphism_N_N.
Parameter el       : Morphism_N_N.
Parameter Kl       : Morphism_N_N.
Parameter coll     : N -> N.
Parameter subcoll  : N -> N.
Parameter ext      : N -> N.
Parameter compl    : N -> N -> N.
Parameter ov       : N -> N.
Parameter union    : N -> N -> N.
Parameter discrete : N -> Prop.
Parameter U        : N.

Axiom asymmetric_Part        : forall A B, A ε pt B ⊃ B ε (distinct (pt A)).        (*A1*)
Axiom transitive_Part        : forall A B C, A ε pt B ∧ B ε pt C ⊃ A ε pt C.        (*A2*)

Parameter MD1                : forall A B, A ε el B ≡≡ (A ε A ∧ (singular_equality A B ∨ A ε pt B)).

Parameter MD2                : forall A a, A ε Kl a ≡≡ (A ε A ∧
                                                    (¬forall B, ¬(B ε a)) ∧
                                                     (forall B, (B ε a ⊃ B ε el A)) ∧
                                       (forall B, B ε el A ⊃ ¬forall C D, ¬((C ε a) ∧ (D ε el C) ∧ (D ε el B)))).

Axiom klass_uniqueness       : forall A B a, (A ε Kl a ∧ B ε Kl a) ⊃ singular_equality A B.
Axiom klass_existence        : forall A a, A ε a ⊃ ¬forall B, ¬(B ε Kl a).

(* P is a collection of a *)
Parameter MD3                : forall P a, P ε coll a ≡≡ (P ε P ∧ forall Q, Q ε el P ⊃ ¬forall C D,
                                                   ¬(C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q)).

(* P is a sub-collection of Q *)
Parameter MD4                : forall P Q, P ε subcoll Q ≡≡ (P ε P ∧ forall C, (C ε el P ⊃ C ε el Q)).

(* P is a external to Q *)
Parameter MD5                : forall P Q, P ε ext Q ≡≡ (P ε P ∧ forall C, ¬(C ε el P ∧ C ε el Q)).

(* P is a complement of Q relative to collection R *)
Parameter MD6                : forall P Q R, P ε compl Q R ≡≡ (P ε P ∧ Q ε subcoll R ∧ P ε (Kl (meet (el R)(ext Q)))).

(* P and Q overlap *)
Parameter MD7                : forall P Q, P ε ov Q ≡≡ (P ε P ∧ ¬forall C, ¬(C ε el P ∧ C ε el Q)).

(* The a's are discrete  *)
Parameter MD8                : forall a, discrete a ≡≡ forall P Q, (P ε a ∧ Q ε a) ⊃ singular_equality P Q ∨ P ε ext Q. (*MD8*)

(* A is the universe *)
Parameter MD9                : forall A, A ε U ≡≡ (A ε Kl universal).

(* A belongs to the union of a and b *)
Parameter MD10               : forall A a b, A ε (union a b) ≡≡ (A ε A ∧ (A ε a ∨ A ε b)).

(* =========================== Eliminations for complex existentials  ========================== *)

Lemma elim_ex2 : forall a B:N, ¬(forall C D, ¬(C ε a ∧ D ε el C ∧ D ε el B)) ⊃
                                         exists C D, (C ε a ∧ D ε el C ∧ D ε el B).
Proof.
intros a B;elimP.
apply (elim_dneg (exists C D : N, (C ε a ∧ D ε el C ∧ D ε el B))).
elim_def1 T5 (¬(exists C D : N, (C ε a ∧ D ε el C ∧ D ε el B))).
splitP;[ elimP;elim_def1_in_hyp T5 (forall C D : N, ¬(C ε a ∧ D ε el C ∧ D ε el B));
        clear H;apply_Lem_in_hyp (not_implies_F (forall C D : N, ¬(C ε a ∧ D ε el C ∧ D ε el B))) H1;
        apply_Lem_in_goal H1;intros C D;elim_def1 T5 (C ε a ∧ D ε el C ∧ D ε el B);
        splitP;[elimP;elim_def1_in_hyp T5 (exists C D : N, (C ε a ∧ D ε el C ∧ D ε el B));
              apply_Lem_in_hyp (not_implies_F (exists C D : N, (C ε a ∧ D ε el C ∧ D ε el B))) H2;
              apply_Lem_in_goal H2;exists C;exists D;assumption
         |
              elimP;apply (elim_F (C ε a ∧ D ε el C ∧ D ε el B));assumption  ]
|
   elimP;apply (elim_F (¬(exists C D : N, (C ε a ∧ D ε el C ∧ D ε el B))));
   assumption ].
Qed.

Lemma intro_ex2 : forall a B:N, (exists C D, (C ε a ∧ D ε el C ∧ D ε el B)) ⊃
                                 ¬(forall C D, ¬(C ε a ∧ D ε el C ∧ D ε el B)).

Proof.
intros a B;elimP.
elim_def1 T5 (forall C D, ¬(C ε a ∧ D ε el C ∧ D ε el B)).
splitP;[ elimP;elim H;intros C H1;elim H1;intros D H2;clear H1;
    specialize (H0 C D);apply_def_in_hyp (T5 (C ε a ∧ D ε el C ∧ D ε el B)) H0;
      apply (detachL (C ε a ∧ D ε el C ∧ D ε el B) F) in H1;assumption  |
     elimP;apply (elim_F (forall C D : N, ¬(C ε a ∧ D ε el C ∧ D ε el B)));assumption
 ].
Qed.

Lemma intro_ex_coll1 : forall a A:N, (exists C:N, (C ε a ∧ C ε el A)) ⊃ ¬(forall C, ¬(C ε a ∧ C ε el A)).
Proof.
intros a A;elimP.
elim_def1 T5 (forall C : N, ¬(C ε a ∧ C ε el A)).
splitP;[ elimP;elim H;intros C H1;specialize (H0 C);apply_def_in_hyp (T5 (C ε a ∧ C ε el A)) H0;
      apply (detachL (C ε a ∧ C ε el A) F) in H2;assumption |
      elimP;apply (elim_F (forall C : N, ¬(C ε a ∧ C ε el A)));assumption ].
Qed.

Lemma intro_ex_3 : forall A B:N, (exists a:N, (B ε (Kl a) ∧ A ε a)) ⊃ ¬(forall a, ¬(B ε (Kl a) ∧ A ε a)).
Proof.
intros A B;elimP.
elim_def1 T5 (forall a : N, ¬(B ε (Kl a) ∧ A ε a)).
splitP;[ elimP;elim H;intros a H1;specialize (H0 a);apply_def_in_hyp (T5 (B ε (Kl a) ∧ A ε a)) H0;
      apply (detachL (B ε (Kl a) ∧ A ε a) F) in H2;assumption |
      elimP;apply (elim_F (forall a : N, ¬(B ε (Kl a) ∧ A ε a)));assumption ].
Qed.

Lemma elim_ex_3 : forall A B:N, ¬(forall a, ¬(B ε Kl a ∧ A ε a)) ⊃ exists a:N, (B ε Kl a ∧ A ε a).
Proof.
intros A B;elimP.
apply (elim_dneg (exists a : N, (B ε Kl a ∧ A ε a))).
elim_def1 T5 (¬(exists a : N, (B ε Kl a ∧ A ε a))).
splitP;[ elimP;elim_def1_in_hyp T5 (forall a : N, ¬(B ε Kl a ∧ A ε a));clear H;
       apply_Lem_in_hyp (not_implies_F (forall a : N, ¬(B ε Kl a ∧ A ε a))) H1;
       apply_Lem_in_goal H1;intro a;elim_def1 T5 (B ε Kl a ∧ A ε a);splitP;[
             elimP;elim_def1_in_hyp T5 (exists a : N, (B ε Kl a ∧ A ε a));
             apply_Lem_in_hyp (not_implies_F (exists a : N, (B ε Kl a ∧ A ε a))) H2;
             apply_Lem_in_goal H2;exists a;assumption
            | elimP;apply (elim_F (B ε Kl a ∧ A ε a));assumption ]
    | elimP;apply (elim_F (¬(exists a : N, (B ε Kl a ∧ A ε a))));assumption
].
Qed.

Lemma elim_ex_coll2 : forall a P Q:N, ¬(forall C D, ¬(C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q)) ⊃
                                         exists C D, (C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q).
Proof.
intros a P Q;elimP.
apply (elim_dneg (exists C D : N, (C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q))).
elim_def1 T5 (¬(exists C D : N, (C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q))).
splitP;[ elimP;elim_def1_in_hyp T5 (forall C D : N, ¬(C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q));
        clear H;apply_Lem_in_hyp (not_implies_F (forall C D : N, ¬(C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q))) H1;
        apply_Lem_in_goal H1;intros C D;elim_def1 T5 (C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q);
        splitP;[elimP;elim_def1_in_hyp T5 (exists C D : N, (C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q));
              apply_Lem_in_hyp (not_implies_F (exists C D : N, (C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q))) H2;
              apply_Lem_in_goal H2;exists C;exists D;assumption
         |
              elimP;apply (elim_F (C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q));assumption  ]
|
   elimP;apply (elim_F (¬(exists C D : N, (C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q))));
   assumption ].
Qed.

Lemma intro_ex_coll2 : forall a P Q:N, (exists C D, (C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q)) ⊃
                                 ¬(forall C D, ¬(C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q)).
Proof.
intros a P Q;elimP.
elim_def1 T5 (forall C D, ¬(C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q)).
splitP;[ elimP;elim H;intros C H1;elim H1;intros D H2;clear H1;
    specialize (H0 C D);apply_def_in_hyp (T5 (C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q)) H0;
      apply (detachL (C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q) F) in H1;assumption  |
     elimP;apply (elim_F (forall C D : N, ¬(C ε a ∧ C ε el P ∧ D ε el C ∧ D ε el Q)));assumption
 ].
Qed.

(* =========================== MEREOLOGICAL THEOREMS ========================== *)

Lemma MereoT0 : forall A B, A ε pt B ⊃ B ε B.
Proof.
intros A B;elimP.
apply_Lem_in_hyp (asymmetric_Part A B) H.
apply_def_in_hyp (D15 B (pt A)) H.
decompose_and H0;assumption.
Qed.

Lemma MereoT1 : forall a A, A ε Kl a ⊃ A ε A.
Proof.
intros a A;elimP.
apply_def_in_hyp (MD2 A a) H.
decompose_and H0.
assumption.
Qed.

Lemma MereoT2 : forall a A, A ε Kl a ⊃ ¬forall B, ¬(B ε a).
Proof.
intros a A;elimP.
apply_def_in_hyp (MD2 A a) H.
decompose_and H0.
assumption.
Qed.

Lemma MereoT3 : forall A a, A ε Kl a ⊃ forall B, B ε a ⊃ B ε el A.
Proof.
intros A a;elimP.
apply_def_in_hyp (MD2 A a) H.
decompose_and H0.
assumption.
Qed.

Lemma MereoT4 : forall A B a, A ε Kl a ⊃ (B ε el A ⊃ ¬forall C D, ¬(C ε a ∧ D ε el C ∧ D ε el B)).
Proof.
intros A B a;elimP.
apply_def_in_hyp (MD2 A a) H.
decompose_and H0.
specialize (H0 B).
assumption.
Qed.

Lemma MereoT5 : forall A, ¬(A ε pt A).
Proof.
intro A.
elim_def1 T5 (A ε pt A).
splitP;[ elimP;assert (H1:=H);apply_Lem_in_hyp (asymmetric_Part A A) H;
         apply_def_in_hyp (D15 A (pt A)) H;
         decompose_and H0; apply_def_in_hyp (T5 (A ε pt A)) H0;
         apply (detachL (A ε (pt A)) F) in H3;assumption |
        elimP;apply (elim_F (A ε pt A));assumption ].
Qed.

Lemma MereoT6 : forall A a, A ε a ⊃ A ε el A.
Proof.
intros A a;elimP.
elim_def2 MD1 A A.
apply_Lem_in_hyp (OntoT5 A a) H.
splitP;[ assumption |
  apply (intro_disjL (singular_equality A A)(A ε pt A));apply_Lem_in_goal (L001 A);assumption ].
Qed.

Lemma MereoT7 : forall A, A ε A ⊃ A ε el A.
Proof.
intro A;elimP.
apply_Lem_in_goal (MereoT6 A A);assumption.
Qed.

Lemma MereoT8 : forall A a, A ε Kl a ⊃  A ε el A.
Proof.
intros A a;elimP.
apply_Lem_in_goal (MereoT6 A (Kl a));assumption.
Qed.

Lemma MereoT9 : forall A B, A ε el B ⊃ B ε B.
Proof.
intros A B;elimP.
assert (H' := H).
apply_Lem_in_hyp (OntoT5 A (el B)) H'.
apply_def_in_hyp (MD1 A B) H.
decompose_and H0.
elim_or_in_hyp H0;[ apply_def_in_hyp (D4 A B) H2;decompose_and H3;
                    apply_Lem_in_hyp (OntoT5 B A) H3;assumption |
        apply_Lem_in_hyp (asymmetric_Part A B) H2;apply_Lem_in_hyp (OntoT5 B (distinct (pt A))) H2;assumption ].
Qed.

Lemma MereoT10 : forall A a, A ε a ⊃  A ε Kl A.
Proof.
intros A a;elimP.
elim_def2 MD2 A A.
assert (H5:=H);apply_Lem_in_hyp (OntoT5 A a) H5.
splitP; [ assumption |
         apply_Lem_in_hyp (OntoT1 A a) H;assumption |
         intro B;elimP;elim_def2 MD1 B A;splitP;[ apply_Lem_in_hyp (OntoT5 B A) H0;assumption |
             apply (intro_disjL (singular_equality B A)(B ε pt A));elim_def2 D4 B A;splitP;[assumption |
             apply_Lem_in_goal (OntoT6 a B A);splitP;assumption ]]|
         intro B;elimP;elim_def1 T5 (forall C D : N, ¬(C ε A ∧ D ε el C ∧ D ε el B));
         apply (def_eqP (forall C D : N, ¬(C ε A ∧ D ε el C ∧ D ε el B)) F);[
             elimP;specialize (H1 A B);apply_def_in_hyp (T5 (A ε A ∧ B ε el A ∧ B ε el B)) H1;
             assert (H3:(A ε A ∧ B ε el A ∧ B ε el B));splitP;[ assumption | assumption |
             apply_Lem_in_hyp (MereoT6 B (el A)) H0;assumption |
         apply (detachL (A ε A ∧ B ε el A ∧ B ε el B) F) in H2;assumption ] |
         elimP;apply (elim_F (forall C D : N, ¬(C ε A ∧ D ε el C ∧ D ε el B)));assumption ]].
Qed.

Lemma MereoT11 : forall A, A ε A ⊃ A ε Kl A.
Proof.
intro A.
apply (MereoT10 A A).
Qed.

Lemma MereoT12 : forall A, A ε A ≡≡ (A ε Kl A).
Proof.
intro A.
splitP; [apply MereoT11 | apply MereoT1].
Qed.

Lemma MereoT13 : forall A a, A ε a ⊃ Kl a ε Kl a.
Proof.
intros A a;elimP.
apply_Lem_in_hyp (klass_existence A a) H.
assert (H0:forall B:N, B ε Kl a ⊃ B ε Kl a);[
    intro B;elimP;assumption  |
    assert (H1:forall A B a, (A ε Kl a ∧ B ε Kl a) ⊃ singular_equality A B);
    [ apply klass_uniqueness  |
      elim_def2 isEpsilon (Kl a) (Kl a);splitP;[
             assumption |
             intros C D;specialize (H1 C D a);elimP;apply_Lem_in_hyp H1 H2;
                      apply_def_in_hyp (D4 C D) H2;decompose_and H3;assumption  |
             assumption ]
 ] ].
Qed.

Lemma MereoT15 : forall B C, (B ε C ∧ C ε B) ⊃ weak_equality B C.
Proof.
intros B C;elimP.
decompose_and H.
elim_def2 D6 B C;intro A;splitP;[
   elimP;apply_Lem_in_goal (OntoT7 A B C);splitP;assumption |
   elimP;apply_Lem_in_goal (OntoT7 A C B);splitP;assumption].
Qed.

Lemma MereoT16 : forall (A B C:N)(Phi:Morphism_N_N), (A ε Phi B)
                                         ∧ singular_equality B C ⊃ (A ε Phi C).
Proof.
intros A B C Phi;elimP.
decompose_and H.
apply_Lem_in_hyp (OntoT30 B C) H.
apply_def_in_hyp ((compat_N_1 Phi) B C A) H.
apply (detachL (A ε Phi B)(A ε Phi C)) in H1;assumption.
Qed.

Lemma MereoT17 : forall A B C, (A ε pt B ∧ singular_equality B C) ⊃ A ε pt C.
Proof.
intros A B C.
apply (MereoT16 A B C pt).
Qed.

Lemma MereoT18 : forall A B C, (A ε el B ∧ singular_equality B C) ⊃ A ε el C.
Proof.
intros A B C.
apply (MereoT16 A B C el).
Qed.

Lemma MereoT19 : forall A B C, A ε pt B ∧ singular_equality A C ⊃ C ε pt B.
Proof.
intros A B C;elimP.
decompose_and H.
apply_def_in_hyp (D4 A C) H.
decompose_and H1.
apply_Lem_in_goal (OntoT7 C A (pt B)).
splitP; assumption.
Qed.

(* Lemma MereoT20 : forall A B C, A ε el B /\ B ε el C -> A ε el C. --> Lemma Transitive_Element_of *)

Lemma MereoT20 : forall A B C, A ε el B ∧ B ε el C ⊃ A ε el C.
Proof.
intros A B C;elimP.
decompose_and H.
elim_def2 MD1 A C;splitP;[ apply_Lem_in_hyp (OntoT5 A (el B)) H0;assumption |
  apply_def_in_hyp (MD1 A B) H0;decompose_and H1;clear H2;
  apply_def_in_hyp (MD1 B C) H;decompose_and H2;clear H3;
  elim_or_in_hyp H1;[ elim_or_in_hyp H2;[
      assert_and_hyp H3 H4;apply_Lem_in_hyp (OntoT28 A B C) H5;
      apply (intro_disjL (singular_equality A C)(A ε pt C)) in H5 |
      apply_Lem_in_hyp (OntoT27 A B) H3;assert_and_hyp H4 H3;
      apply_Lem_in_hyp (MereoT19 B C A) H5;
      apply (intro_disjR (singular_equality A C)(A ε pt C)) in H5  ] |
   elim_or_in_hyp H2;[ assert_and_hyp H3 H4;apply_Lem_in_hyp (MereoT17 A B C) H5;
   apply (intro_disjR (singular_equality A C)(A ε pt C)) in H5  |
      assert_and_hyp H3 H4;apply_Lem_in_hyp (transitive_Part A B C) H5;
      apply (intro_disjR (singular_equality A C)(A ε pt C)) in H5 ] ]
   ];assumption.
Qed.

(* Lemma MereoT21 : forall A, A ε A -> A ε el A.  --> Lemma Reflexive_Element_of Cf. MereoT7 *)

Lemma MereoT22 : forall A a, A ε a ⊃ A ε el (Kl a).
Proof.
intros A a;elimP.
intro_lemma_in_hyp (MereoT3 (Kl a) a).
assert (H1:=H).
apply_Lem_in_hyp (MereoT13 A a) H.
apply_Lem1_in_hyp H0 H A.
apply_Lem_in_goal H2;assumption.
Qed.

Lemma MereoT23 : forall A B a, (A ε Kl B ∧ B ε a) ⊃ singular_equality A B.
Proof.
intros A B a;elimP.
decompose_and H.
apply_Lem_in_hyp (OntoT5 B a) H.
apply_Lem_in_hyp (MereoT11 B) H.
apply_Lem_in_goal (klass_uniqueness A B B);splitP;assumption.
Qed.

Lemma MereoT24 : forall A a, A ε Kl a ⊃ singular_equality A (Kl a).
Proof.
intros A a;elimP.
assert (H1:=H).
apply_Lem_in_hyp (MereoT2 a A) H.
apply_Lem_in_hyp (elim_ex a) H.
elim_for_some H B.
apply_Lem_in_hyp (MereoT13 B a) H.
assert (H2:((A ε Kl a) ∧ (Kl a ε Kl a))).
splitP;assumption.
apply_Lem_in_hyp (OntoT21 A (Kl a)(Kl a)) H2.
assumption.
Qed.

Lemma MereoT25 : forall a, exist_at_least a ≡≡ exist_at_least (Kl a).
Proof.
intro a.
splitP;[ elimP;apply_def_in_hyp (D1 a) H;clear H;
         apply_Lem_in_hyp (elim_ex a) H0;elim_for_some H0 A;
         apply_Lem_in_hyp (klass_existence A a) H0;
         elim_def1 D1 (Kl a);assumption  |
         elimP;elim_def1_in_hyp D1 (Kl a);clear H;
         apply_Lem_in_hyp (elim_ex (Kl a)) H0;elim_for_some H0 A;
         apply_Lem_in_hyp (MereoT2 a A) H0;
          elim_def1 D1 a;assumption
].
Qed.

(* Theorems 26 and 27 show that in mereology, the class of a and the class of the class of a
 stand for the same object, which is in contrast with set theory *)

Lemma MereoT26 : forall A a, A ε Kl a ⊃ A ε Kl (Kl a).
Proof.
intros A a;elimP.
assert (H1:=H).
apply_Lem_in_hyp (klass_existence A (Kl a)) H.
apply_Lem_in_hyp (elim_ex (Kl(Kl a))) H.
elim_for_some H B.
apply_Lem_in_hyp (MereoT24 A a) H1.
apply_Lem_in_hyp (OntoT27 A (Kl a)) H1.
assert (H3 :B ε Kl (Kl a) ∧ singular_equality (Kl a) A).
splitP;assumption.
apply_Lem_in_hyp (MereoT16 B (Kl a) A Kl) H3.
apply_def_in_hyp (D4 (Kl a) A) H1.
decompose_and H0.
assert_and_hyp H3 H0.
apply_Lem_in_hyp (MereoT23 B A (Kl a)) H4.
apply_Lem_in_hyp (OntoT30 B A) H4.
apply_def_in_hyp ((compat_N_2 Kl) B A a) H4.
apply (detachL (B ε Kl (Kl a))(A ε Kl (Kl a))) in H5;assumption.
Qed.

Lemma MereoT27 : forall A a, A ε (Kl (Kl a)) ⊃ A ε Kl a.
Proof.
intros A a;elimP.
assert (H1:=H).
assert (H2:=H).
apply_Lem_in_hyp (MereoT6 A (Kl(Kl a))) H.
apply_Lem_in_hyp (MereoT4 A A (Kl a)) H1.
apply_Lem_in_hyp H1 H.
apply_Lem_in_hyp (elim_ex2 (Kl a) A) H.
elim_for_some2 H C D.
decompose_and H0;assert (H4:=H3);assert (H9:=H3);apply_Lem_in_hyp (MereoT24 C a) H3;
apply_Lem_in_hyp (OntoT27 C (Kl a)) H3;assert_and_hyp H2 H3;
apply_Lem_in_hyp (MereoT16 A (Kl a) C Kl) H5;
apply_Lem_in_hyp (OntoT5 C (Kl a)) H4;assert_and_hyp H5 H4;
apply_Lem_in_hyp (MereoT23 A C C) H6;
apply_Lem_in_hyp (OntoT30 A C) H6;apply_def_in_hyp ((compat_N_3 Kl) A C a) H6;
apply (detachR (A ε Kl a)(C ε Kl a)) in H7;assumption.
Qed.

Lemma MereoT27' : forall A a, A ε Kl (Kl a) ≡≡ (A ε Kl a).
Proof.
intros A a.
splitP;[ apply MereoT27 | apply MereoT26].
Qed.

Lemma MereoT28 : ¬forall A a, A ε Kl a.
Proof.
elim_def1 T5 (forall A a : N, A ε Kl a).
splitP;[ elimP;specialize (H empty empty);apply_Lem_in_hyp (OntoT5 empty (Kl empty)) H;
         intro_lemma_in_hyp OntoT9;apply_def_in_hyp (T5 (empty ε empty)) H0;
         apply (detachL (empty ε empty) F) in H1;assumption  |
         elimP;apply (elim_F (forall A a : N, A ε Kl a));assumption
 ].
Qed.

(* The class generated by the empty name does not exist *)
Lemma MereoT29 : forall A, ¬(A ε Kl empty).
Proof.
intro A.
elim_def1 T5 (A ε Kl empty).
splitP;[ elimP;apply_Lem_in_hyp (MereoT2 empty A) H;apply_def_in_hyp (D1 empty) H;
         intro_lemma_in_hyp OntoT17;apply_def_in_hyp (T5 (exist_at_least empty)) H1;
          apply (detachL (exist_at_least empty) F) in H2;assumption
       | elimP;apply (elim_F (A ε Kl empty));assumption ].
Qed.

(* identical classes do not yield identical plurals a and b *)

Theorem MereoT30 : forall a b, ((¬forall F, ¬(F ε a)) ∧ (¬forall G, ¬(G ε b)) ∧ weak_equality (el (Kl a))(el (Kl b))) ⊃ forall B, (B ε Kl a ⊃ B ε Kl b).
Proof.
intros a b;elimP.
decompose_and H.
intro B;elimP.
assert (G0:(forall A, A ε el B ⊃ ¬forall C D, ¬(C ε b ∧ D ε el C ∧ D ε el A)));[
    intro A;elimP;apply_Lem_in_hyp (MereoT24 B a) H2;
    assert (G1:(A ε el B ∧ singular_equality B (Kl a)));splitP;[
      assumption |
      assumption |
      apply_Lem_in_hyp (MereoT18 A B (Kl a)) G1;
      apply_def1_in_hyp (D6 (el(Kl a))(el (Kl b))) H A;
      apply (detachL (A ε el (Kl a))(A ε el (Kl b))) in H4;[
         apply_Lem_in_hyp (elim_ex b) H0;elim_for_some H0 E;
         apply_Lem_in_hyp (MereoT13 E b) H0;apply_Lem_in_hyp (MereoT4 (Kl b) A b) H0;
         assert (H5:=H4);apply_Lem_in_hyp H0 H4;assumption |
         assumption ]
        ]|
     apply_Lem_in_hyp (elim_ex b) H0;elim_for_some H0 E;assert (H3:=H0);
     apply_Lem_in_hyp (MereoT13 E b) H0;assert (H4:(forall F, F ε b ⊃ F ε el B));[
        intro F;elimP;apply_Lem1_in_hyp (MereoT3 (Kl b) b) H0 F;assert (H6:=H4);
        apply_Lem_in_hyp H5 H4; apply_def1_in_hyp (D6 (el(Kl a))(el (Kl b))) H F;
        apply (detachR (F ε el (Kl a))(F ε el (Kl b))) in H7;[
            assert (G1:=H2);apply_Lem_in_hyp (MereoT24 B a) H2;
            apply_Lem_in_hyp (OntoT27 B (Kl a)) H2;assert (H8: F ε el(Kl a) ∧ singular_equality (Kl a)B);
            splitP;[
                assumption |
                assumption |
                apply_Lem_in_hyp (MereoT16 F (Kl a) B (el)) H8;assumption ] |
            assumption ] |
        elim_def2 MD2 B b;splitP;[
            apply_Lem_in_hyp (OntoT5 B (Kl a)) H2;assumption |
            apply_Lem_in_goal (intro_ex b);exists E;assumption |
            assumption |
            assumption ]]].
Qed.

Lemma MereoT31 : forall A B,  A ε el B ∧ B ε el A ⊃ singular_equality A B.
Proof.
intros A B;elimP.
decompose_and H.
apply_def_in_hyp (MD1 A B) H0;decompose_and H1.
apply_def_in_hyp (MD1 B A) H;decompose_and H3.
elim_or_in_hyp H1;[ assumption |
   elim_or_in_hyp H3;[ apply_Lem_in_hyp (OntoT27 B A) H6;assumption |
     apply_Lem_in_hyp (asymmetric_Part A B) H5;apply_def_in_hyp (D15 B (pt A)) H5;
     decompose_and H7;apply_def_in_hyp (T5 (B ε pt A)) H7;
     apply (detachL (B ε pt A) F) in H9;[ apply (elim_F (singular_equality A B));assumption
      | assumption ] ] ].
Qed.

Lemma MereoT34 : forall A B C a, A ε Kl a ∧ A ε el B ∧ C ε a ⊃ C ε el B.
Proof.
intros A B C a;elimP.
decompose_and H.
apply_Lem1_in_hyp (MereoT3 A a) H1 C.
apply_Lem_in_hyp H2 H.
assert_and_hyp H H0;apply_Lem_in_hyp (MereoT20 C A B) H3;assumption.
Qed.

Lemma MereoT35 : forall A, A ε A ⊃ A ε Kl (el A).
Proof.
intro P;elimP.
assert (H1:=H).
apply_Lem_in_hyp (MereoT7 P) H.
assert (H2:(¬(forall Q, ¬(Q ε (el P)))));[
         apply_Lem_in_goal (intro_ex (el P));exists P;assumption |
         assert (H20:= H2);apply_Lem_in_hyp (elim_ex (el P)) H2;elim H2;intros Q H3;
         assert (H4:=H3);apply_Lem_in_hyp (OntoT5 Q (el P)) H4;
         assert (H5:=H4);apply_Lem_in_hyp (MereoT7 Q) H5;
         elim_def2 MD2 P (el P);splitP;[ assumption |
                                           assumption |
                                           intro B;elimP;assumption |
                                           intro B;elimP;apply_Lem_in_goal (intro_ex2 (el P) B);
                                           exists P;exists B;splitP;[
                                                    assumption |
                                                    assumption |
                                                    apply_Lem_in_goal (MereoT6 B (el P));assumption
 ]]].
Qed.

Lemma MereoT36 : forall A B, A ε el B ⊃ B ε Kl (el B).
Proof.
intros P Q;elimP.
apply_def_in_hyp (MD1 P Q) H.
decompose_and H0.
elim_or_in_hyp H0;[
         apply_def_in_hyp (D4 P Q) H2;decompose_and H3;apply_Lem_in_hyp (OntoT5 Q P) H3;
         apply_Lem_in_hyp (MereoT35 Q) H3;assumption  |
         apply_Lem_in_hyp (asymmetric_Part P Q) H2;apply_def_in_hyp (D15 Q (pt P)) H2;
         decompose_and H3;apply_Lem_in_hyp (MereoT35 Q) H4;assumption
  ].
Qed.

Lemma MereoT40 : forall A B, (A ε el B) ≡≡ ¬forall a, ¬(B ε (Kl a) ∧ A ε a).
Proof.
intros A B.
splitP; [ elimP;apply_Lem_in_goal (intro_ex_3 A B);exists (el B);
          splitP;[ apply_Lem_in_hyp (MereoT36 A B) H;assumption |
                  assumption  ] |
         elimP;apply_Lem_in_hyp (elim_ex_3 A B) H;elim_for_some H a;
         decompose_and H;intro_lemma_in_hyp (MereoT3 B a);
         apply (elim_impl (B ε Kl a)((forall B0 : N, B0 ε a ⊃ B0 ε el B))) with (B0:=A) in H1;
         apply_Lem_in_hyp H1 H;assumption
].
Qed.

Lemma XIV : forall A a, A ε (Kl a) ⊃ A ε (coll a).
Proof.
intros A a;elimP.
apply_def_in_hyp (MD2 A a) H.
decompose_and H0.
clear H1 H2.
elim_def2 MD3 A a.
splitP;[
      assumption |
      intro B;elimP;specialize (H0 B);apply_Lem_in_hyp H0 H1;apply_Lem_in_hyp (elim_ex2 a B) H1;
      elim_for_some2 H1 C D;apply_Lem_in_goal (intro_ex_coll2 a A B);exists C, D;
      decompose_and H2;splitP;[
          assumption |
          apply_Lem1_in_hyp (MereoT3 A a) H C;apply_Lem_in_hyp H5 H4;assumption |
          assumption |
          assumption
  ] ].
Qed.

Lemma MereoT42 : forall A B, B ε subcoll A ⊃ B ε el A.
Proof.
intros A B;elimP.
apply_def_in_hyp (MD4 B A) H.
decompose_and H0.
specialize (H0 B).
apply_Lem_in_goal H0.
apply_Lem_in_goal (MereoT6 B B);assumption.
Qed.

Lemma MereoT43 : forall A B, B ε el A ⊃ B ε subcoll A.
Proof.
intros A B;elimP.
elim_def2 MD4 B A.
splitP;[ apply_Lem_in_hyp (OntoT5 B (el A)) H;assumption  |
     intro C;elimP;apply_Lem_in_goal (MereoT20 C B A);splitP;assumption
].
Qed.

Lemma MereoT44 : forall A B, (B ε el A) ≡≡ (B ε subcoll A).
Proof.
intros A B;splitP;[ apply (MereoT43 A B) | apply (MereoT42 A B) ].
Qed.

Lemma Transitive_subcoll : forall A B C, (A ε subcoll B ∧ B ε subcoll C) ⊃ A ε subcoll C.
Proof.
intros A B C;elimP.
decompose_and H.
apply_def_in_hyp (MereoT44 C B) H.
apply_def_in_hyp (MereoT44 B A) H0.
apply_Lem_in_goal (MereoT43 C A).
apply_Lem_in_goal (MereoT20 A B C);splitP;assumption.
Qed.

(********************* De Morgan  ****************************)

(* if A is element of B, then the extension of elements of A is included into
   the extension of elements of B *)

Lemma MereoT45 : forall A B, A ε el B ⊃ weak_inclusion (el A) (el B). (* TM19 *)
Proof.
intros A B;elimP.
elim_def2 D8 (el A) (el B).
intro C;elimP.
apply_Lem_in_goal (MereoT20 C A B).
splitP;assumption.
Qed.

Lemma MereoT46 : forall A a, A ε a ⊃ forall B, (B ε (el A) ⊃ B ε (el (Kl a))). (* TM24 *)
Proof.
intros A a;elimP.
intro B;elimP.
apply_Lem_in_hyp (MereoT22 A a) H.
apply_Lem_in_goal (MereoT20 B A (Kl a)).
splitP;assumption.
Qed.

Lemma MereoT47 : forall a b, strong_inclusion a b ⊃ forall C, (C ε a ⊃ forall D, (D ε (el C) ⊃
                                                                    D ε (el (Kl b)))). (* TM25 *)
Proof.
intros a b;elimP.
apply_def_in_hyp (D9 a b) H.
intro C;elimP;intro D;elimP.
decomposeR_and H0.
specialize (H0 C).
apply_Lem_in_hyp H0 H1.
apply_Lem1_in_hyp (MereoT46 C b) H1 D.
apply_Lem_in_goal H3;assumption.
Qed.

Lemma MereoT48 : forall A a, A ε (coll a) ⊃ ¬forall B, ¬(B ε a). (* TM29 *)
Proof.
intros A a;elimP.
apply_Lem_in_goal (intro_ex a).
apply_def_in_hyp (MD3 A a) H.
decompose_and H0.
apply_Lem_in_hyp (MereoT7 A) H1.
specialize (H0 A).
apply_Lem_in_hyp H0 H1.
apply_Lem_in_hyp (elim_ex_coll2 a A A) H1;elim_for_some2 H1 B C.
decompose_and H2;exists B;assumption.
Qed.

Lemma MereoT49 : forall A a, A ε a ⊃ A ε (coll a). (* TM30 *)
Proof.
intros A a;elimP.
elim_def2 MD3 A a.
splitP;[
    apply_Lem_in_hyp (OntoT5 A a) H;assumption |
    intro B;elimP;apply_Lem_in_goal (intro_ex_coll2 a A B);exists A, B;splitP;[
            assumption |
            apply_Lem_in_hyp (MereoT6 A a) H;assumption |
            assumption |
            apply_Lem_in_hyp (OntoT5 B (el A)) H0;apply_Lem_in_hyp (MereoT7 B) H0;
            assumption
]].
Qed.

Lemma MereoT50 : forall A a, A ε (Kl (coll a)) ⊃ forall B, B ε (el A) ⊃
                                           ¬forall C D, ¬(C ε a ∧ D ε (el C) ∧ D ε (el B)). (* TM31 *)
Proof.
intros A a;elimP;intro B;elimP.
apply_Lem_in_hyp (MereoT4 A B (coll a)) H.
apply_Lem_in_hyp H H0;clear H.
apply_Lem_in_hyp (elim_ex2 (coll a) B) H0.
elim_for_some2 H0 C D.
decompose_and H.
apply_def_in_hyp (MD3 C a) H1;decompose_and H2.
specialize (H2 D).
apply_Lem_in_hyp H2 H0;clear H2.
apply_Lem_in_hyp (elim_ex_coll2 a C D) H0.
elim_for_some2 H0 E G.
decompose_and H2.
assert (H6:(G ε el D ∧ D ε el B));[
   splitP;assumption |
   apply_Lem_in_hyp (MereoT20 G D B) H6;apply_Lem_in_goal (intro_ex2 a B);
   exists E, G;splitP;assumption
].
Qed.

Lemma MereoT51 : forall A a, A ε (Kl (coll a)) ⊃ (A ε (Kl a)). (* TM32 *)
Proof.
intros A a;elimP.
elim_def2 MD2 A a.
splitP;[
      apply_Lem_in_hyp (MereoT1 (coll a) A) H;assumption |
      apply_Lem_in_hyp(MereoT2 (coll a) A) H;apply_Lem_in_hyp (elim_ex (coll a)) H;
      elim_for_some H B;apply_Lem_in_hyp (MereoT48 B a) H;assumption |
      intro B;elimP;apply_Lem_in_hyp (MereoT49 B a) H0;apply_Lem1_in_hyp (MereoT3 A (coll a)) H B;
      apply_Lem_in_hyp H1 H0;assumption |
      intro B;elimP;apply_Lem1_in_hyp (MereoT50 A a) H B;apply_Lem_in_hyp H1 H0;assumption
].
Qed.

Lemma MereoT52 : forall A a, A ε (Kl a) ⊃ (A ε (Kl (coll a))). (* TM33 *)
Proof.
intros A a;elimP.
assert (H1:=H).
apply_Lem_in_hyp (XIV A a) H.
apply_Lem_in_hyp (klass_existence A (coll a)) H.
apply_Lem_in_hyp (elim_ex (Kl (coll a))) H.
elim_for_some H B.
assert (H10:=H).
apply_Lem_in_hyp (MereoT51 B a) H.
assert (H2:(A ε Kl a ∧ B ε Kl a));[
     splitP;assumption |
     apply_Lem_in_hyp (klass_uniqueness A B a) H2;apply_def_in_hyp (D4 A B) H2;
     decompose_and H0;assert (H4:(A ε B ∧ (B ε Kl (coll a))));[
            splitP;assumption |
            apply_Lem_in_hyp (OntoT7 A B (Kl (coll a))) H4;assumption
]].
Qed.

Lemma MereoT53 : forall A a, A ε (coll a) ⊃ (A ε el (Kl a)). (* TM34 *)
Proof.
intros A a;elimP.
assert (H10:=H).
apply_Lem_in_hyp (MereoT48 A a) H.
apply_Lem_in_hyp (elim_ex a) H.
elim_for_some H B.
apply_Lem_in_hyp (klass_existence B a) H.
apply_Lem_in_hyp (elim_ex (Kl a)) H.
elim_for_some H C.
assert (H1:=H).
apply_Lem_in_hyp (MereoT52 C a) H.
apply_Lem1_in_hyp (MereoT3 C (coll a)) H A.
apply_Lem_in_hyp (MereoT24 C a) H1.
apply_Lem_in_hyp H0 H10.
apply_Lem_in_goal (MereoT18 A C (Kl a));splitP;assumption.
Qed.

Lemma MereoT54 : forall a b A, (weak_inclusion a b ∧ A ε Kl a) ⊃ (A ε coll b). (* TM35 *)
Proof.
intros a b A;elimP.
decompose_and H.
assert (H1:=H).
apply_Lem_in_hyp (XIV A a) H.
elim_def2 MD3 A b.
splitP;[
    apply_Lem_in_goal (MereoT1 a A);assumption |
    intro B;elimP;apply_def_in_hyp (MD3 A a) H;decompose_and H3;specialize (H3 B);
    apply_Lem_in_hyp H3 H2;clear H3;apply_Lem_in_hyp (elim_ex_coll2 a A B) H2;
    elim_for_some2 H2 C D;decompose_and H3;apply_Lem_in_goal (intro_ex_coll2 b A B);
    exists C, D;apply_def1_in_hyp (D8 a b) H0 C;apply_Lem_in_hyp H7 H6;splitP;
    assumption
].
Qed.

Lemma MereoT55 : forall a b, strong_inclusion a b  ⊃ (Kl a) ε el (Kl b). (* TM36 *)
Proof.
intros a b;elimP.
apply_def_in_hyp (D9 a b) H.
decompose_and H0.
apply_Lem_in_hyp (elim_ex a) H1.
elim_for_some H1 B.
apply_Lem_in_hyp (klass_existence B a) H1.
apply_Lem_in_hyp (elim_ex (Kl a)) H1.
elim_for_some H1 C.
apply_def_in_hyp (D8 a b) H0.
assert (H3:(weak_inclusion a b ∧ C ε Kl a));[
     splitP;assumption |
     apply_Lem_in_hyp (MereoT54 a b C) H3;apply_Lem_in_hyp (MereoT53 C b) H3;
     apply_Lem_in_hyp (MereoT24 C a) H1;apply_def_in_hyp (D4 C (Kl a)) H1;decompose_and H4;
     apply_Lem_in_goal (OntoT7 (Kl a) C (el (Kl b)));splitP;assumption
].
Qed.

Lemma MereoT56 : forall a b, strong_inclusion a b ⊃ strong_inclusion (el (Kl a)) (el (Kl b)). (* TM37 *)
Proof.
intros a b;elimP.
apply_def_in_hyp (D9 a b) H.
apply_Lem_in_hyp (MereoT55 a b) H.
elim_def2 D9 (el (Kl a)) (el (Kl b)).
decompose_and H0.
apply_Lem_in_hyp (elim_ex a) H1.
elim_for_some H1 B.
splitP;[
   apply_Lem_in_goal (intro_ex (el (Kl a)));apply_Lem_in_hyp (MereoT22 B a) H1;
   exists B;assumption |
   intro C;elimP;apply_Lem_in_goal (MereoT20 C (Kl a) (Kl b));splitP;assumption
].
Qed.

Lemma XI : forall a b P Q, P ε coll a ∧ a ε b ∧ Q ε el P ⊃ ¬forall C D, ¬(C ε b ∧ C ε el P ∧ D ε el C ∧ D ε el Q).
Proof.
intros a b P Q;elimP.
apply_Lem_in_goal (intro_ex_coll2 b P Q).
decompose_and H.
apply_def_in_hyp (MD3 P a) H1.
decompose_and H2;specialize (H2 Q).
apply_Lem_in_hyp H2 H.
apply_Lem_in_hyp (elim_ex_coll2 a P Q) H;elim_for_some2 H C D;
exists C, D;decompose_and H4;splitP;[
                 apply_Lem_in_goal (OntoT7 C a b);splitP;assumption |
                 assumption|
                 assumption|
                 assumption].
Qed.

Lemma XII : forall a b P, P ε coll a ∧ a ε b ⊃ P ε coll b.
Proof.
intros a b A;elimP.
decompose_and H.
apply_def_in_hyp (MD3  A a) H0.
decompose_and H1.
elim_def2 MD3 A b.
splitP;[ assumption |
       intro Q;elimP;specialize (H1 Q);apply_Lem_in_hyp H1 H3;
       apply_Lem_in_goal (intro_ex_coll2 b A Q);apply_Lem_in_hyp (elim_ex_coll2 a A Q) H3;
       elim_for_some2 H3 C D;decompose_and H4;exists C, D;splitP;[
                          apply_Lem_in_goal (OntoT7 C a b);splitP;assumption |
                          assumption |
                          assumption |
                          assumption
]].
Qed.

Lemma XIII :  forall a P, P ε coll a ⊃ ¬forall C, ¬(C ε a ∧ C ε el P).
Proof.
intros a A;elimP.
apply_Lem_in_goal (intro_ex_coll1 a A).
apply_def_in_hyp (MD3 A a) H.
decompose_and H0.
apply_Lem_in_hyp (MereoT7 A) H1.
specialize (H0 A).
apply_Lem_in_hyp H0 H1.
apply_Lem_in_hyp (elim_ex_coll2 a A A) H1;elim_for_some2 H1 C D.
decompose_and H2;exists C;splitP;assumption.
Qed.

End Mereology.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* An efficiency predicate that characterizes of non-uniform PPT turing machines.  *)

Require Import fcf.Crypto.
Set Implicit Arguments.

Definition CostModel := forall (A B : Type), (A -> B) -> nat -> Prop.

Local Open Scope nat_scope.

Class constant_cost_relation(cost : CostModel) :={

  constant_cost_const :
  forall (A B : Type)(b : B),
    cost _ _ (fun (_ : A) => b) 0;

  constant_cost_pair_args :
  forall (A B C : Type)
    (f : A -> B -> C) c,
    cost _ _ (fun p => f (fst p) (snd p)) c ->
    exists c1 c2,
    cost _ _ f c1 /\ (forall a, cost _ _ (f a) c2) /\ c1 + c2 <= c;

  constant_cost_unpair_args :
  forall (A B C : Type)
    (f : (A * B) -> C) c,
    cost _ _ f c ->
    cost _ _ (fun a b => f (a, b)) 0 /\
    (forall a, cost _ _ (fun b => f (a, b)) c);

  constant_cost_compose :
  forall (A B C : Type)
    (f1 : A -> B)(f2 : A -> B -> C) c1 c2 c3,
    cost _ _ f1 c1 ->
    cost _ _ f2 c2 ->
    (forall a, cost _ _ (f2 a) c3) ->
    cost _ _ (fun a => f2 a (f1 a)) (c1 + c2 + c3);

  constant_cost_bind :
    forall (Z : Type)(A B : Set)(f1 : Z -> Comp A) (f2 : Z -> A -> Comp B) c1 c2 c3,
      cost _ _ f1 c1 ->
      cost _ _ f2 c2 ->
      (forall z, cost _ _ (f2 z) c3) ->
      cost _ _ (fun a => Bind (f1 a) (f2 a)) (c1 + c2 + c3);

  constant_cost_ret :
    forall (A : Set)(eqd : eq_dec A),
      cost _ _ (@Ret A eqd) 0;

  constant_cost_le :
    forall A B (f : A -> B) c1 c2,
      cost _ _ f c1 ->
      c1 <= c2 ->
      cost _ _ f c2;

  constant_cost_fst :
    forall (A B : Type),
      cost _ _ (@fst A B) 0;

  constant_cost_snd :
    forall (A B : Type),
      cost _ _ (@snd A B) 0;

  constant_cost_pair_1 :
    forall (A B : Type),
      cost _ _ (@pair A B) 0;

  constant_cost_pair_2 :
    forall (A B : Type) a,
      cost _ _ (@pair A B a) 0;

  constant_cost_pair :
    forall (A B : Type),
      cost _ _ (fun p => @pair A B (fst p) (snd p)) 0;

  constant_cost_eqb_bool :
    cost _ _ (fun p => @eqb bool _ (fst p) (snd p)) 1;

  constant_cost_bvxor :
    forall eta,
      cost _ _ (fun p => BVxor eta (fst p) (snd p)) eta;

  constant_cost_firstn :
    forall k (A : Type),
      cost _ _ (@firstn A k) k;

  constant_cost_skipn :
    forall k (A : Type),
      cost _ _ (@skipn A k) k;

  constant_cost_tl :
    forall (A : Type),
      cost _ _ (@tl A) 1;

  constant_cost_hd :
    forall (A : Type)(a : A),
      cost _ _ (hd a) 1;

  constant_cost_if_bool_f :
    forall (A B : Type)(f1 : A -> bool)(f2 f3 : A -> B) c1 c2 c3,
      cost _ _ f1 c1 ->
      cost _ _ f2 c2 ->
      cost _ _ f3 c3 ->
      cost _ _ (fun a => if (f1 a) then (f2 a) else (f3 a)) (c1 + c2 + c3)

}.

Section constant_cost_theory.
  Context `(constant_cost_relation).

  Theorem constant_cost_pair_args_weak :
    forall (A B C : Type)
      (f : A -> B -> C) c,
      cost (fun p => f (fst p) (snd p)) c ->
      cost f c.

    intuition.

    apply constant_cost_pair_args in H0.
    destruct H0.
    destruct H0.
    intuition.
    eapply constant_cost_le.
    eauto.
    omega.

  Qed.

  Theorem constant_cost_compose_unary :
  forall (A B C: Type)
    (f1 : A -> B)(f2 : B ->C) c1 c2,
    cost f1 c1 ->
    cost f2 c2 ->
    cost (fun a => f2 (f1 a)) (c1 + c2).

    intuition.
    eapply constant_cost_le.
    eapply (constant_cost_compose f1 _ ).
    eauto.
    eapply constant_cost_const.
    intuition.
    eauto.
    omega.

  Qed.

  Theorem constant_cost_compose_binary :
  forall (A B C D: Type)
    (f1 : A -> B)(f2 : A ->C)(f3 : B -> C -> D) c1 c2 c3 c4,
    cost f1 c1 ->
    cost f2 c2 ->
    cost f3 c3 ->
    (forall b, cost (f3 b) c4) ->
    cost (fun a => f3 (f1 a) (f2 a)) (c1 + c2 + c3 + c4).

    intuition.
    eapply constant_cost_le.
    eapply (constant_cost_compose f2 (fun a x => f3 (f1 a) x)).
    eauto.
    eapply (constant_cost_compose f1 (fun a y x => f3 y x)).
    eauto.
    eapply constant_cost_const.
    intuition.
    eauto.

    intuition.
    omega.

  Qed.

  Theorem constant_cost_compose_binary_const_r :
  forall (A B C D: Type)
    (f1 : A -> B)(c : C)(f3 : B -> C -> D) c1 c2,
    cost f1 c1 ->
    cost (fun x => f3 x c) c2 ->
    cost (fun a => f3 (f1 a) c) (c1 + c2).

    intuition.
    eapply constant_cost_le.
    eapply (constant_cost_compose f1 (fun _ x => f3 x c)).
    eauto.
    eapply constant_cost_const.
    intuition.
    eauto.
    omega.
  Qed.

  Theorem constant_cost_compose_binary_const_l :
  forall (A B C D: Type)
    (b : B)(f2 : A -> C)(f3 : B -> C -> D) c1 c2,
    cost f2 c1 ->
    cost (f3 b) c2 ->
    cost (fun a => f3 b (f2 a)) (c1 + c2).

    intuition.
    eapply constant_cost_le.
    eapply (constant_cost_compose f2 (fun _ x => f3 b x)).
    eauto.
    eapply constant_cost_const.
    intuition.
    eauto.
    omega.

  Qed.

  Theorem constant_cost_bind_const1 :
      forall (A  : Type)(B C: Set)
        (f1 : Comp B)(f2 : A -> B -> Comp C) c1 c2,
        cost f2 c1 ->
        (forall a, cost (f2 a) c2) ->
        cost (fun a => Bind f1 (f2 a)) (c1 + c2).

      intuition.
      eapply constant_cost_le.
      eapply constant_cost_bind; eauto.
      eapply constant_cost_const.
      omega.
    Qed.

    Theorem constant_cost_bind_const1_pair :
      forall (A  : Type)(B C: Set)
        (f1 : Comp B)(f2 : A -> B -> Comp C) c,
        cost (fun p => f2 (fst p) (snd p)) c ->
        cost (fun a => Bind f1 (f2 a)) c.

      intuition.
      apply constant_cost_pair_args in H0.
      destruct H0.
      destruct H0.
      intuition.
      eapply constant_cost_le.
      eapply constant_cost_bind; eauto.
      eapply constant_cost_const.
      omega.
    Qed.

    Theorem constant_cost_bind_const2 :
      forall (A  : Type)(B C: Set)
        (f1 : A -> (Comp B))(f2 : B -> Comp C) c1 c2,
        cost f1 c1 ->
        cost f2 c2 ->
        cost (fun a => Bind (f1 a) f2) (c1 + c2).

      intuition.
      eapply constant_cost_le.
      eapply constant_cost_bind; eauto.
      eapply constant_cost_const.
      omega.
    Qed.

    Theorem constant_cost_bind_pair :
      forall (A  : Type)(B C: Set)
        (f1 : A -> Comp B)(f2 : A -> B -> Comp C) c1 c2,
        cost f1 c1 ->
        cost (fun p => f2 (fst p) (snd p)) c2 ->
        cost (fun a => Bind (f1 a) (f2 a)) (c1 + c2).

      intuition.
      apply constant_cost_pair_args in H1.
      destruct H1.
      destruct H1.
      intuition.
      eapply constant_cost_le.
      eapply constant_cost_bind; eauto.
      omega.
    Qed.

    Theorem constant_cost_compose_binary_pair :
      forall (A B C D: Type)
        (f1 : A -> B)(f2 : A ->C)(f3 : B -> C -> D) c1 c2 c3,
        cost f1 c1 ->
        cost f2 c2 ->
        cost (fun p => f3 (fst p) (snd p)) c3 ->
        cost (fun a => f3 (f1 a) (f2 a)) (c1 + c2 + c3).

      intuition.
      apply constant_cost_pair_args in H2.
      destruct H2.
      destruct H2.
      intuition.
      eapply constant_cost_le.
      eapply (constant_cost_compose f2 (fun a x => f3 (f1 a) x)).
      eauto.
      eapply (constant_cost_compose f1 (fun a y x => f3 y x)).
      eauto.
      eapply constant_cost_const.
      intuition.
      eauto.

      intuition.
      omega.

    Qed.

End constant_cost_theory.

Require Import fcf.Asymptotic.

Definition poly_time_nonuniform(cost : CostModel)(A B : nat -> Type)(f : forall n, (A n) -> (B n)) :=
  exists x, polynomial x /\
  forall n,
    (exists c, (cost _ _ (f n)) c /\ c <= x n).


Require Import Undecidability.PCP.PCP.
Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

From Undecidability.PCP.Reductions Require
  SR_to_MPCP MPCP_to_MPCPb MPCP_to_PCP PCP_to_PCPb PCPb_iff_iPCPb PCPb_iff_dPCPb.

From Undecidability Require Import TM.SBTM_undec.

Require Undecidability.StringRewriting.SR_undec.

(* ** PCP is undecidable *)

(* The modified Post correspondence problem is undecidable. *)
Lemma MPCP_undec : undecidable MPCP.
Proof.
  apply (undecidability_from_reducibility SR_undec.SR_undec).
  exact SR_to_MPCP.reduction.
Qed.

Check MPCP_undec.

(* The modified Post correspondence problem restricted to binary strings is undecidable. *)
Lemma MPCPb_undec : undecidable MPCPb.
Proof.
  apply (undecidability_from_reducibility MPCP_undec).
  exact MPCP_to_MPCPb.reduction.
Qed.

Check MPCPb_undec.

(* The Post correspondence problem is undecidable. *)
Lemma PCP_undec : undecidable PCP.
Proof.
  apply (undecidability_from_reducibility MPCP_undec).
  exact MPCP_to_PCP.reduction.
Qed.

(* The Post correspondence problem is undecidable. *)
Lemma PCP_compl_undec : undecidable (complement PCP).
Proof.
  apply (undecidability_from_reducibility complement_SBTM_HALT_undec).
  apply reduces_complement.
  eapply reduces_transitive. 2: exact MPCP_to_PCP.reduction.
  eapply reduces_transitive. 2: exact SR_to_MPCP.reduction.
  exact SBTM_HALT_to_SR.reduction.
Qed.

Check PCP_undec.

(* The Post correspondence problem restricted to binary strings is undecidable. *)
Lemma PCPb_undec : undecidable PCPb.
Proof.
  apply (undecidability_from_reducibility PCP_undec).
  exact PCP_to_PCPb.reduction.
Qed.

(* The Post correspondence problem restricted to binary strings is undecidable. *)
Lemma PCPb_compl_undec : undecidable (complement PCPb).
Proof.
  apply (undecidability_from_reducibility complement_SBTM_HALT_undec).
  apply reduces_complement.
  eapply reduces_transitive. 2: exact PCP_to_PCPb.reduction.
  eapply reduces_transitive. 2: exact MPCP_to_PCP.reduction.
  eapply reduces_transitive. 2: exact SR_to_MPCP.reduction.
  exact SBTM_HALT_to_SR.reduction.
Qed.

Check PCPb_undec.

(* The Post correspondence problem restricted to binary strings is undecidable. *)
Lemma iPCPb_undec : undecidable iPCPb.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists id. exact PCPb_iff_iPCPb.PCPb_iff_iPCPb.
Qed.

Check iPCPb_undec.

(* The Post correspondence problem restricted to binary strings is undecidable. *)
Lemma dPCPb_undec : undecidable dPCPb.
Proof.
  apply (undecidability_from_reducibility PCPb_undec).
  exists id. exact PCPb_iff_dPCPb.PCPb_iff_dPCPb.
Qed.

Check dPCPb_undec.


Require Import NArith.
Require Import Arith.
Require Import Bool.
Require Import List.
Import ListNotations.
Require Import Misc.
Require Import SpaceSearch.CpdtTactics.

Section Bag.
  Variable A : Type.

  Definition bag := A -> Type.

  Definition elem a (b:bag) := b a.

End Bag.

Arguments elem {_} _ _.


Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms Coq.Classes.RelationClasses Coq.Program.Basics Coq.omega.Omega.
Require Import x86proved.charge.csetoid.

Set Implicit Arguments.
Unset Strict Implicit.

Section FunEq.
  Context A `{eT: type A}.

  Global Instance FunEquiv {T} : Equiv (T -> A) := {
    equiv P Q := forall a, P a === Q a
  }.

  Global Instance FunType T : type (T -> A).
  Proof. firstorder. Qed.
End FunEq.

(* Separation algebras *)
Section SepAlgSect.
  Class SepAlgOps T `{eT : type T}:= {
    sa_unit : T;
    (* sa_mul s1 s2 s if s = s1*s2 *)
    sa_mul : T -> T -> T -> Prop
  }.

  Class SepAlg T `{SAOps: SepAlgOps T} : Type := {
    sa_mul_eqL a b c d : sa_mul a b c -> c === d -> sa_mul a b d;
    sa_mul_eqR a b c d : sa_mul a b c -> sa_mul a b d -> c === d;
    sa_mon a b c   : a === b -> sa_mul a c === sa_mul b c;
    sa_mulC a b        : sa_mul a b === sa_mul b a;
    sa_mulA a b c      : forall bc abc, sa_mul a bc abc -> sa_mul b c bc ->
                                        exists ac, sa_mul b ac abc /\ sa_mul a c ac;
    sa_unitI a         : sa_mul a sa_unit a
  }.

End SepAlgSect.

Implicit Arguments SepAlgOps [[e] [eT]].
Implicit Arguments SepAlg [[e] [eT] [SAOps]].

Section SepAlgCompat.
  Context A `{SA: SepAlg A}.

  Definition compat (a b : A) := exists s, sa_mul a b s.
  Definition subheap (a b : A) := exists c, sa_mul a c b.

  Lemma sa_mulC2 a b c : sa_mul a b c <-> sa_mul b a c.
  Proof.
    apply sa_mulC.
  Qed.

End SepAlgCompat.

Module SepAlgNotations.
Notation "a '·' b" := (sa_mul a b) (at level 50, left associativity) : sa_scope.
Notation "a '·' b |-> c" := (sa_mul a b c) (at level 52, no associativity) : sa_scope.
Notation "^" := sa_unit : sa_scope.
Notation "a # b" := (compat a b) (at level 70, no associativity) : sa_scope.
Notation "a <= b" := (subheap a b) (at level 70, no associativity) : sa_scope.
End SepAlgNotations.

Instance sa_mul_equiv_proper T `{SAP : SepAlg T} :
  Proper (equiv ==> equiv ==> equiv ==> equiv) sa_mul.
Proof.
  intros x y Heqxy t u Heqtu s v Heqsv.
  transitivity (sa_mul y t s); [apply sa_mon; assumption|].
  etransitivity; [apply sa_mulC| etransitivity; [|apply sa_mulC]].
  etransitivity; [apply sa_mon; eassumption|].
  split; intros; (eapply sa_mul_eqL; [eassumption|firstorder]).
Qed.

Import SepAlgNotations.

Delimit Scope sa_scope with sa.

Instance subheap_preo A `{sa : SepAlg A} : PreOrder (@subheap A e eT SAOps).
Proof.
  split.
  + intros s; eexists; apply sa_unitI.
  + intros s0 s1 s2 [s10 HEq1] [s21 HEq2].
    pose proof (sa_mulA).
    apply sa_mulC in HEq2.
    specialize (H _ _ _ _ _ HEq2 HEq1).
    destruct H as [s3 [HEqs2 HEqs3]].
    exists s3; assumption.
Qed.

Instance compat_symm Σ `{sa : SepAlg Σ} : Symmetric (compat (A := Σ)).
Proof.
  intros s s0 [s1 Hs]; exists s1; apply sa_mulC; assumption.
Qed.

Section Properties.
  Context Σ `{sa : SepAlg Σ}.
  Open Scope sa_scope.

  Global Instance sa_subheap_equiv_proper :
    Proper (equiv ==> equiv ==> iff) (subheap (A := Σ)).
  Proof.
    intros x y Heqxy t u Heqtu; split; [intros [s Heqxst] | intros [s Heqysu]]; exists s.
    + rewrite <- Heqxy, <- Heqtu; assumption.
    + rewrite Heqxy, Heqtu; assumption.
  Qed.

  Global Instance sa_compat_equiv_proper :
    Proper (equiv ==> equiv ==> iff) (compat (A := Σ)).
  Proof.
    intros x y Heqxy t u Heqtu; split; [intros [s Heqxst] | intros [s Heqysu]]; exists s.
    + rewrite <- Heqxy, <- Heqtu; assumption.
    + rewrite Heqxy, Heqtu; assumption.
  Qed.

  Lemma compat_subheap {r t : Σ} (s : Σ) (Hsr: r <= s) (Hst: s # t) : r # t.
  Proof.
    destruct Hsr as [sr Hsr]; destruct Hst as [st Hst].
    apply sa_mulC in Hst.
    apply sa_mulC in Hsr.
    pose proof sa_mulA.
    specialize (H _ _ _ _ _ Hst Hsr).
    destruct H as [u [Hst2 Hu]].
    exists u. apply sa_mulC; assumption.
  Qed.

  Close Scope sa_scope.

End Properties.

Implicit Arguments compat_subheap [[Σ] [e] [eT] [sa] [r] [t] [SAOps]].


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat fintype bigop finset.
From mathcomp
Require Import binomial fingroup morphism automorphism quotient gfunctor.

(******************************************************************************)
(*   This files contains the proofs of several key properties of commutators, *)
(* including the Hall-Witt identity and the Three Subgroup Lemma.             *)
(*   The definition and notation for both pointwise and set wise commutators  *)
(* ([~x, y, ...] and [~: A, B ,...], respectively) are given in fingroup.v    *)
(* This file defines the derived group series:                                *)
(*           G^`(0) ==  G                                                     *)
(*       G^`(n.+1) == [~: G^`(n), G^`(n)]                                     *)
(* as several classical results involve the (first) derived group G^`(1),     *)
(* such as the equivalence H <| G /\ G / H abelian <-> G^`(1) \subset H.      *)
(* The connection between the derived series and solvable groups will only be *)
(* established in nilpotent.v, however.                                       *)
(******************************************************************************)

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

Import GroupScope.

Definition derived_at_rec n (gT : finGroupType) (A : {set gT}) :=
  iter n (fun B => [~: B, B]) A.

(* Note: 'nosimpl' MUST be used outside of a section -- the end of section   *)
(* "cooking" destroys it.                                                    *)
Definition derived_at := nosimpl derived_at_rec.

Arguments derived_at _%N _ _%g.
Notation "G ^` ( n )" := (derived_at n G) : group_scope.

Section DerivedBasics.

Variables gT : finGroupType.
Implicit Type A : {set gT}.
Implicit Types G : {group gT}.

Lemma derg0 A : A^`(0) = A. Proof. by []. Qed.
Lemma derg1 A : A^`(1) = [~: A, A]. Proof. by []. Qed.
Lemma dergSn n A : A^`(n.+1) = [~: A^`(n), A^`(n)]. Proof. by []. Qed.

Lemma der_group_set G n : group_set G^`(n).
Proof. by case: n => [|n]; apply: groupP. Qed.

Canonical derived_at_group G n := Group (der_group_set G n).

End DerivedBasics.

Notation "G ^` ( n )" := (derived_at_group G n) : Group_scope.

Section Basic_commutator_properties.

Variable gT : finGroupType.
Implicit Types x y z : gT.

Lemma conjg_mulR x y : x ^ y = x * [~ x, y].
Proof. by rewrite mulKVg. Qed.

Lemma conjg_Rmul x y : x ^ y = [~ y, x^-1] * x.
Proof. by rewrite commgEr invgK mulgKV. Qed.

Lemma commMgJ x y z : [~ x * y, z] = [~ x, z] ^ y * [~ y, z].
Proof. by rewrite !commgEr conjgM mulgA -conjMg mulgK. Qed.

Lemma commgMJ x y z : [~ x, y * z] = [~ x, z] * [~ x, y] ^ z.
Proof. by rewrite !commgEl conjgM -mulgA -conjMg mulKVg. Qed.

Lemma commMgR x y z : [~ x * y, z] = [~ x, z] * [~ x, z, y] * [~ y, z].
Proof. by rewrite commMgJ conjg_mulR. Qed.

Lemma commgMR x y z : [~ x, y * z] = [~ x, z] * [~ x, y] * [~ x, y, z].
Proof. by rewrite commgMJ conjg_mulR mulgA. Qed.

Lemma Hall_Witt_identity x y z :
  [~ x, y^-1, z] ^ y * [~ y, z^-1, x] ^ z * [~ z, x^-1, y] ^ x = 1.
Proof. (* gsimpl *)
pose a x y z : gT := x * z * y ^ x.
suffices{x y z} hw_aux x y z: [~ x, y^-1, z] ^ y = (a x y z)^-1 * (a y z x).
  by rewrite !hw_aux 2!mulgA !mulgK mulVg.
by rewrite commgEr conjMg -conjgM -conjg_Rmul 2!invMg conjgE !mulgA.
Qed.

(* the following properties are useful for studying p-groups of class 2 *)

Section LeftComm.

Variables (i : nat) (x y : gT).
Hypothesis cxz : commute x [~ x, y].

Lemma commVg : [~ x^-1, y] = [~ x, y]^-1.
Proof.
apply/eqP; rewrite commgEl eq_sym eq_invg_mul invgK mulgA -cxz.
by rewrite -conjg_mulR -conjMg mulgV conj1g.
Qed.

Lemma commXg : [~ x ^+ i, y] = [~ x, y] ^+ i.
Proof.
elim: i => [|i' IHi]; first exact: comm1g.
by rewrite !expgS commMgJ /conjg commuteX // mulKg IHi.
Qed.

End LeftComm.

Section RightComm.

Variables (i : nat) (x y : gT).
Hypothesis cyz : commute y [~ x, y].
Let cyz' := commuteV cyz.

Lemma commgV : [~ x, y^-1] = [~ x, y]^-1.
Proof. by rewrite -invg_comm commVg -(invg_comm x y) ?invgK. Qed.

Lemma commgX : [~ x, y ^+ i] = [~ x, y] ^+ i.
Proof. by rewrite -invg_comm commXg -(invg_comm x y) ?expgVn ?invgK. Qed.

End RightComm.

Section LeftRightComm.

Variables (i j : nat) (x y : gT).
Hypotheses (cxz : commute x [~ x, y]) (cyz : commute y [~ x, y]).

Lemma commXXg : [~ x ^+ i, y ^+ j] = [~ x, y] ^+ (i * j).
Proof. by rewrite expgM commgX commXg //; apply: commuteX. Qed.

Lemma expMg_Rmul : (y * x) ^+ i = y ^+ i * x ^+ i * [~ x, y] ^+ 'C(i, 2).
Proof.
rewrite -triangular_sum; symmetry.
elim: i => [|k IHk] /=; first by rewrite big_geq ?mulg1.
rewrite big_nat_recr //= addnC expgD !expgS -{}IHk !mulgA; congr (_ * _).
by rewrite -!mulgA commuteX2 // -commgX // [mulg y]lock 3!mulgA -commgC.
Qed.

End LeftRightComm.

End Basic_commutator_properties.

(***** Set theoretic commutators *****)
Section Commutator_properties.

Variable gT : finGroupType.
Implicit Type (rT : finGroupType) (A B C : {set gT}) (D G H K : {group gT}).

Lemma commG1 A : [~: A, 1] = 1.
Proof. by apply/commG1P; rewrite centsC sub1G. Qed.

Lemma comm1G A : [~: 1, A] = 1.
Proof. by rewrite commGC commG1. Qed.

Lemma commg_sub A B : [~: A, B] \subset A <*> B.
Proof. by rewrite comm_subG // (joing_subl, joing_subr). Qed.

Lemma commg_norml G A : G \subset 'N([~: G, A]).
Proof.
apply/subsetP=> x Gx; rewrite inE -genJ gen_subG.
apply/subsetP=> _ /imsetP[_ /imset2P[y z Gy Az ->] ->].
by rewrite -(mulgK [~ x, z] (_ ^ x)) -commMgJ !(mem_commg, groupMl, groupV).
Qed.

Lemma commg_normr G A : G \subset 'N([~: A, G]).
Proof. by rewrite commGC commg_norml. Qed.

Lemma commg_norm G H : G <*> H \subset 'N([~: G, H]).
Proof. by rewrite join_subG ?commg_norml ?commg_normr. Qed.

Lemma commg_normal G H : [~: G, H] <| G <*> H.
Proof. by rewrite /(_ <| _) commg_sub commg_norm. Qed.

Lemma normsRl A G B : A \subset G -> A \subset 'N([~: G, B]).
Proof. by move=> sAG; apply: subset_trans (commg_norml G B). Qed.

Lemma normsRr A G B : A \subset G -> A \subset 'N([~: B, G]).
Proof. by move=> sAG; apply: subset_trans (commg_normr G B). Qed.

Lemma commg_subr G H : ([~: G, H] \subset H) = (G \subset 'N(H)).
Proof.
rewrite gen_subG; apply/subsetP/subsetP=> [sRH x Gx | nGH xy].
  rewrite inE; apply/subsetP=> _ /imsetP[y Ky ->].
  by rewrite conjg_Rmul groupMr // sRH // mem_imset2 ?groupV.
case/imset2P=> x y Gx Hy ->{xy}.
by rewrite commgEr groupMr // memJ_norm (groupV, nGH).
Qed.

Lemma commg_subl G H : ([~: G, H] \subset G) = (H \subset 'N(G)).
Proof. by rewrite commGC commg_subr. Qed.

Lemma commg_subI A B G H :
  A \subset 'N_G(H) -> B \subset 'N_H(G) -> [~: A, B] \subset G :&: H.
Proof.
rewrite !subsetI -(gen_subG _ 'N(G)) -(gen_subG _ 'N(H)).
rewrite -commg_subr -commg_subl; case/andP=> sAG sRH; case/andP=> sBH sRG.
by rewrite (subset_trans _ sRG) ?(subset_trans _ sRH) ?commgSS ?subset_gen.
Qed.

Lemma quotient_cents2 A B K :
    A \subset 'N(K) -> B \subset 'N(K) ->
  (A / K \subset 'C(B / K)) = ([~: A, B] \subset K).
Proof.
move=> nKA nKB.
by rewrite (sameP commG1P trivgP) /= -quotientR // quotient_sub1 // comm_subG.
Qed.

Lemma quotient_cents2r A B K :
  [~: A, B] \subset K -> (A / K) \subset 'C(B / K).
Proof.
move=> sABK; rewrite -2![_ / _]morphimIdom -!quotientE.
by rewrite quotient_cents2 ?subsetIl ?(subset_trans _ sABK) ?commgSS ?subsetIr.
Qed.

Lemma sub_der1_norm G H : G^`(1) \subset H -> H \subset G -> G \subset 'N(H).
Proof.
by move=> sG'H sHG; rewrite -commg_subr (subset_trans _ sG'H) ?commgS.
Qed.

Lemma sub_der1_normal G H : G^`(1) \subset H -> H \subset G -> H <| G.
Proof. by move=> sG'H sHG; rewrite /(H <| G) sHG sub_der1_norm. Qed.

Lemma sub_der1_abelian G H : G^`(1) \subset H -> abelian (G / H).
Proof. by move=> sG'H; apply: quotient_cents2r. Qed.

Lemma der1_min G H : G \subset 'N(H) -> abelian (G / H) -> G^`(1) \subset H.
Proof. by move=> nHG abGH; rewrite -quotient_cents2. Qed.

Lemma der_abelian n G : abelian (G^`(n) / G^`(n.+1)).
Proof. by rewrite sub_der1_abelian // der_subS. Qed.

Lemma commg_normSl G H K : G \subset 'N(H) -> [~: G, H] \subset 'N([~: K, H]).
Proof. by move=> nHG; rewrite normsRr // commg_subr. Qed.

Lemma commg_normSr G H K : G \subset 'N(H) -> [~: H, G] \subset 'N([~: H, K]).
Proof. by move=> nHG; rewrite !(commGC H) commg_normSl. Qed.

Lemma commMGr G H K : [~: G, K] * [~: H, K] \subset [~: G * H , K].
Proof. by rewrite mul_subG ?commSg ?(mulG_subl, mulG_subr). Qed.

Lemma commMG G H K :
  H \subset 'N([~: G, K]) -> [~: G * H , K] = [~: G, K] * [~: H, K].
Proof.
move=> nRH; apply/eqP; rewrite eqEsubset commMGr andbT.
have nRHK: [~: H, K] \subset 'N([~: G, K]) by rewrite comm_subG ?commg_normr.
have defM := norm_joinEr nRHK; rewrite -defM gen_subG /=.
apply/subsetP=> _ /imset2P[_ z /imset2P[x y Gx Hy ->] Kz ->].
by rewrite commMgJ {}defM mem_mulg ?memJ_norm ?mem_commg // (subsetP nRH).
Qed.

Lemma comm3G1P A B C :
  reflect {in A & B & C, forall h k l, [~ h, k, l] = 1} ([~: A, B, C] :==: 1).
Proof.
have R_C := sameP trivgP commG1P.
rewrite -subG1 R_C gen_subG -{}R_C gen_subG.
apply: (iffP subsetP) => [cABC x y z Ax By Cz | cABC xyz].
  by apply/set1P; rewrite cABC // !mem_imset2.
by case/imset2P=> _ z /imset2P[x y Ax By ->] Cz ->; rewrite cABC.
Qed.

Lemma three_subgroup G H K :
  [~: G, H, K] :=: 1 -> [~: H, K, G] :=: 1-> [~: K, G, H] :=: 1.
Proof.
move/eqP/comm3G1P=> cGHK /eqP/comm3G1P cHKG.
apply/eqP/comm3G1P=> x y z Kx Gy Hz; symmetry.
rewrite -(conj1g y) -(Hall_Witt_identity y^-1 z x) invgK.
by rewrite cGHK ?groupV // cHKG ?groupV // !conj1g !mul1g conjgKV.
Qed.

Lemma der1_joing_cycles (x y : gT) :
  let XY := <[x]> <*> <[y]> in let xy := [~ x, y] in
  xy \in 'C(XY) -> XY^`(1) = <[xy]>.
Proof.
rewrite joing_idl joing_idr /= -sub_cent1 => /norms_gen nRxy.
apply/eqP; rewrite eqEsubset cycle_subG mem_commg ?mem_gen ?set21 ?set22 //.
rewrite der1_min // quotient_gen -1?gen_subG // quotientU abelian_gen.
rewrite /abelian subUset centU !subsetI andbC centsC -andbA -!abelianE.
rewrite !quotient_abelian ?(abelianS (subset_gen _) (cycle_abelian _)) //=.
by rewrite andbb quotient_cents2r ?genS // /commg_set imset2_set1l imset_set1.
Qed.

Lemma commgAC G x y z : x \in G -> y \in G -> z \in G ->
  commute y z -> abelian [~: [set x], G] -> [~ x, y, z] = [~ x, z, y].
Proof.
move=> Gx Gy Gz cyz /centsP cRxG; pose cx' u := [~ x^-1, u].
have xR3 u v: [~ x, u, v] = x^-1 * (cx' u * cx' v) * x ^ (u * v).
  rewrite mulgA -conjg_mulR conjVg [cx' v]commgEl mulgA -invMg.
  by rewrite -mulgA conjgM -conjMg -!commgEl.
suffices RxGcx' u: u \in G -> cx' u \in [~: [set x], G].
  by rewrite !xR3 {}cyz; congr (_ * _ * _); rewrite cRxG ?RxGcx'.
move=> Gu; suffices/groupMl <-: [~ x, u] ^ x^-1 \in [~: [set x], G].
  by rewrite -commMgJ mulgV comm1g group1.
by rewrite memJ_norm ?mem_commg ?set11 // groupV (subsetP (commg_normr _ _)).
Qed.

(* Aschbacher, exercise 3.6 (used in proofs of Aschbacher 24.7 and B & G 1.10 *)
Lemma comm_norm_cent_cent H G K :
    H \subset 'N(G) -> H \subset 'C(K) -> G \subset 'N(K) ->
  [~: G, H] \subset 'C(K).
Proof.
move=> nGH /centsP cKH nKG; rewrite commGC gen_subG centsC.
apply/centsP=> x Kx _ /imset2P[y z Hy Gz ->]; red.
rewrite mulgA -[x * _]cKH ?groupV // -!mulgA; congr (_ * _).
rewrite (mulgA x) (conjgC x) (conjgCV z) 3!mulgA; congr (_ * _).
by rewrite -2!mulgA (cKH y) // -mem_conjg (normsP nKG).
Qed.

Lemma charR H K G : H \char G -> K \char G -> [~: H, K] \char G.
Proof.
case/charP=> sHG chH /charP[sKG chK]; apply/charP.
by split=> [|f infj Gf]; [rewrite comm_subG | rewrite morphimR // chH // chK].
Qed.

Lemma der_char n G : G^`(n) \char G.
Proof. by elim: n => [|n IHn]; rewrite ?char_refl // dergSn charR. Qed.

Lemma der_sub n G : G^`(n) \subset G.
Proof. by rewrite char_sub ?der_char. Qed.

Lemma der_norm n G : G \subset 'N(G^`(n)).
Proof. by rewrite char_norm ?der_char. Qed.

Lemma der_normal n G : G^`(n) <| G.
Proof. by rewrite char_normal ?der_char. Qed.

Lemma der_subS n G : G^`(n.+1) \subset G^`(n).
Proof. by rewrite comm_subG. Qed.

Lemma der_normalS n G : G^`(n.+1) <| G^`(n).
Proof. by rewrite sub_der1_normal // der_subS. Qed.

Lemma morphim_der rT D (f : {morphism D >-> rT}) n G :
   G \subset D -> f @* G^`(n) = (f @* G)^`(n).
Proof.
move=> sGD; elim: n => // n IHn.
by rewrite !dergSn -IHn morphimR ?(subset_trans (der_sub n G)).
Qed.

Lemma dergS n G H : G \subset H -> G^`(n) \subset H^`(n).
Proof. by move=> sGH; elim: n => // n IHn; apply: commgSS. Qed.

Lemma quotient_der n G H : G \subset 'N(H) -> G^`(n) / H = (G / H)^`(n).
Proof. exact: morphim_der. Qed.

Lemma derJ G n x : (G :^ x)^`(n) = G^`(n) :^ x.
Proof. by elim: n => //= n IHn; rewrite !dergSn IHn -conjsRg. Qed.

Lemma derG1P G : reflect (G^`(1) = 1) (abelian G).
Proof. exact: commG1P. Qed.

End Commutator_properties.

Arguments derG1P [gT G].

Lemma der_cont n : GFunctor.continuous (derived_at n).
Proof. by move=> aT rT G f; rewrite morphim_der. Qed.

Canonical der_igFun n := [igFun by der_sub^~ n & der_cont n].
Canonical der_gFun n := [gFun by der_cont n].
Canonical der_mgFun n := [mgFun by dergS^~ n].

Lemma isog_der (aT rT : finGroupType) n (G : {group aT}) (H : {group rT}) :
  G \isog H -> G^`(n) \isog H^`(n).
Proof. exact: gFisog. Qed.


From solutions Require Export sem_typed sem_type_formers types.

(** * Interpretation of syntactic types *)
(** We use semantic type formers to define the interpretation [⟦ τ ⟧ : sem_ty]
of syntactic types [τ : ty]. The interpretation is defined recursively on the
structure of syntactic types. To account for type variables (that appear freely
in [τ]), we need to keep track of their corresponding semantic types. We
represent these semantic types as a list, since de use De Bruijn indices for
type variables. *)
Reserved Notation "⟦ τ ⟧".
Fixpoint interp `{!heapG Σ} (τ : ty) (ρ : list (sem_ty Σ)) : sem_ty Σ :=
  match τ return _ with
  | TVar x => default () (ρ !! x) (* dummy in case [x ∉ ρ] *)
  | TUnit => ()
  | TBool => sem_ty_bool
  | TInt => sem_ty_int
  | TProd τ1 τ2 => ⟦ τ1 ⟧ ρ * ⟦ τ2 ⟧ ρ
  | TSum τ1 τ2 => ⟦ τ1 ⟧ ρ + ⟦ τ2 ⟧ ρ
  | TArr τ1 τ2 => ⟦ τ1 ⟧ ρ → ⟦ τ2 ⟧ ρ
  | TForall τ => ∀ X, ⟦ τ ⟧ (X :: ρ)
  | TExist τ => ∃ X, ⟦ τ ⟧ (X :: ρ)
  | TRef τ => ref (⟦ τ ⟧ ρ)
  | TRec τ => μ X, ⟦ τ ⟧ (X :: ρ)
  end%sem_ty
where "⟦ τ ⟧" := (interp τ).
Instance: Params (@interp) 2 := {}.

(** We now lift the interpretation of types to typing contexts. This is done in
a pointwise fashion using the [<$> : (A → B) → gmap K A → gmap K B] operator. *)
Definition interp_env `{!heapG Σ} (Γ : gmap string ty)
  (ρ : list (sem_ty Σ)) : gmap string (sem_ty Σ) := flip interp ρ <$> Γ.
Instance: Params (@interp_env) 3 := {}.

(** Below we prove several useful lemmas about [interp] and [interp_env],
including important lemmas about the effect that lifting (de Bruijn indices)
and substitution in type level variables have on the interpretation of syntactic
types and typing contexts. *)
Section interp_properties.
  Context `{!heapG Σ}.
  Implicit Types Γ : gmap string ty.
  Implicit Types τ : ty.
  Implicit Types ρ : list (sem_ty Σ).
  Implicit Types i n j : nat.

  Global Instance interp_ne τ : NonExpansive ⟦ τ ⟧.
  Proof. induction τ; solve_proper. Qed.
  Global Instance interp_proper τ : Proper ((≡) ==> (≡)) ⟦ τ ⟧.
  Proof. apply ne_proper, _. Qed.

  Lemma interp_env_empty ρ : interp_env (∅ : gmap string ty) ρ = ∅.
  Proof. by rewrite /interp_env fmap_empty. Qed.
  Lemma lookup_interp_env Γ x τ ρ :
    Γ !! x = Some τ → interp_env Γ ρ !! x = Some (⟦ τ ⟧ ρ).
  Proof. intros Hx. by rewrite /interp_env lookup_fmap Hx. Qed.
  Lemma interp_env_binder_insert Γ x τ ρ :
    interp_env (binder_insert x τ Γ) ρ
    = binder_insert x (⟦ τ ⟧ ρ) (interp_env Γ ρ).
  Proof. destruct x as [|x]=> //=. by rewrite /interp_env fmap_insert. Qed.

  Lemma interp_ty_lift n τ ρ :
    n ≤ length ρ →
    ⟦ ty_lift n τ ⟧ ρ ≡ ⟦ τ ⟧ (delete n ρ).
  Proof.
    (** We use [elim:] instead of [induction] so we can properly name the
    generated variables and hypotheses. *)
    revert n ρ. elim: τ; simpl; try (intros; done || f_equiv/=; by auto).
    - intros x n ρ ?. repeat case_decide; simplify_eq/=; try lia.
      + by rewrite lookup_delete_lt.
      + by rewrite lookup_delete_ge; last lia.
    - intros τ IH n ρ ?. f_equiv=> A /=. naive_solver auto with lia.
    - intros τ IH n ρ ?. f_equiv=> A /=. naive_solver auto with lia.
    - intros τ IH n ρ ?. f_equiv=> A /=. naive_solver auto with lia.
  Qed.
  Lemma interp_ty_lift_0 τ A ρ : ⟦ ty_lift 0 τ ⟧ (A :: ρ) ≡ ⟦ τ ⟧ ρ.
  Proof. apply interp_ty_lift; simpl; lia. Qed.

  Lemma interp_env_ty_lift n Γ ρ :
    n ≤ length ρ →
    interp_env (ty_lift n <$> Γ) ρ ≡ interp_env Γ (delete n ρ).
  Proof.
    intros. rewrite /interp_env -map_fmap_compose.
    apply map_fmap_equiv_ext=> x A _ /=. by rewrite interp_ty_lift.
  Qed.
  Lemma interp_env_ty_lift_0 Γ A ρ :
    interp_env (ty_lift 0 <$> Γ) (A :: ρ) ≡ interp_env Γ ρ.
  Proof. apply interp_env_ty_lift; simpl; lia. Qed.

  Lemma interp_ty_subst i τ τ' ρ :
    i ≤ length ρ →
    ⟦ ty_subst i τ' τ ⟧ ρ ≡ ⟦ τ ⟧ (take i ρ ++ ⟦ τ' ⟧ ρ :: drop i ρ).
  Proof.
    (** We use [elim:] instead of [induction] so we can properly name the
    generated variables and hypotheses. *)
    revert i τ' ρ. elim: τ; simpl; try (intros; done || f_equiv/=; by auto).
    - intros x i τ' ρ ?. repeat case_decide; simplify_eq/=; try lia.
      + rewrite lookup_app_l; last (rewrite take_length; lia).
        by rewrite lookup_take; last lia.
      + by rewrite list_lookup_middle; last (rewrite take_length; lia).
      + rewrite lookup_app_r; last (rewrite take_length; lia).
        rewrite take_length lookup_cons_ne_0; last lia.
        rewrite lookup_drop. do 2 f_equiv; lia.
    - intros τ IH i τ' ρ ?. f_equiv=> A /=. rewrite IH /=; last lia.
      by rewrite interp_ty_lift; last lia.
    - intros τ IH i τ' ρ ?. f_equiv=> A /=. rewrite IH /=; last lia.
      by rewrite interp_ty_lift; last lia.
    - intros τ IH i τ' ρ ?. f_equiv=> A /=. rewrite IH /=; last lia.
      by rewrite interp_ty_lift; last lia.
  Qed.
  Lemma interp_ty_subst_0 τ τ' ρ :
    ⟦ ty_subst 0 τ' τ ⟧ ρ ≡ ⟦ τ ⟧ (⟦ τ' ⟧ ρ :: ρ).
  Proof. apply interp_ty_subst; simpl; lia. Qed.
End interp_properties.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".
*)
Set Implicit Arguments.
Require Export BooleanEqualityDef.
Require Export BooleanEqualitySetDef.

(* TODO a variables version of this. *)

Module BooleanEqualitySetFun(BE' : BooleanEquality) <: BooleanEqualitySet.
  Module BE := BE'.
  Module BESet := Ops(BE).
  Include BESet.
  Definition eq := BE.eq.
  Definition eq_equiv := BE.eq_equiv.
  Definition eq_dec := BE.eq_dec.
  Definition eqb := BE.eqb.
  Definition eqb_eq := BE.eqb_eq.
  Definition eqb_refl := BE.eqb_refl.
  Definition eqb_sym := BE.eqb_sym.
  Definition eqb_trans := BE.eqb_trans.
  Definition eq_trans := BE.eq_trans.
  Definition eqb_to_eq := BE.eqb_to_eq.
  Definition eqb_to_neq := BE.eqb_to_neq.
  Definition eqb_iff_eq := BE.eqb_iff_eq.
  Definition eqb_iff_neq := BE.eqb_iff_neq.
  Hint Resolve eqb.
  Hint Resolve eqb_refl.
  Hint Rewrite eqb_refl.
  Hint Immediate eqb_sym.
  Hint Resolve eqb_trans.
  Hint Resolve eq_trans.
  Hint Resolve eqb_to_eq.
  Hint Resolve eqb_to_neq.
  Hint Resolve eqb_iff_eq.
  Hint Resolve eqb_iff_neq.
End BooleanEqualitySetFun.