(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

Require Import FSets FMaps Arith Min Compare_dec NArith Nnat Pnat Ndec.
Import Morphisms.

Set Implicit Arguments.
Unset Standard Proposition Elimination Names.
Open Scope N_scope.

Module Type S.

  Declare Module E : OrderedType.
  Definition elt := E.t.

  Parameter t : Type. (** the abstract type of sets *)

  Parameter empty : t.
  (** The empty set. *)

  Parameter multi : elt -> t -> N.
  (** [multi t s] gives the multiplicity of [t] in the multiset [s]. *)

  Parameter update : elt -> N -> t -> t.
  (** [update x m s] returns a multiset identical to [s], except that
    multiplicity of [x] is now [m] *)

  Parameter union : t -> t -> t.

  Parameter inter : t -> t -> t.

  Parameter diff : t -> t -> t.

  Parameter equal : t -> t -> bool.

  Parameter subset : t -> t -> bool.

  Parameter fold : forall A : Type, (elt -> positive -> A -> A) -> t -> A -> A.
  (** [fold] encounters only elements with non-null multiplicity *)

  Parameter elements : t -> list (elt * positive).
  (** [elements] returns the list of elements with non-null multiplicity *)

  (** Logical predicates *)
  Definition Equal s s' := forall a : elt, multi a s = multi a s'.
  Definition Subset s s' := forall a : elt, multi a s <= multi a s'.
  Definition Empty s := forall a : elt, multi a s = 0.

  Notation "s [=] t" := (Equal s t) (at level 70, no associativity).
  Notation "s [<=] t" := (Subset s t) (at level 70, no associativity).

  Section Spec.

  Variable s s' s'' : t.
  Variable x y : elt.
  Variable n : N.
  Variable p : positive.

  (** Specification of [equal] *)
  Parameter equal_1 : s[=]s' -> equal s s' = true.
  Parameter equal_2 : equal s s' = true ->s[=]s'.

  (** Specification of [subset] *)
  Parameter subset_1 : s[<=]s' -> subset s s' = true.
  Parameter subset_2 : subset s s' = true -> s[<=]s'.

  (** Specification of [empty] *)
  Parameter empty_1 : Empty empty.

  (** Specification of [update] *)
  Parameter update_1 : E.eq x y -> multi y (update x n s) = n.
  Parameter update_2 : ~E.eq x y -> multi y (update x n s) = multi y s.

  (** Specification of [union] *)
  Parameter union_1 : multi x (union s s') = multi x s + multi x s'.

  (** Specification of [inter] *)
  Parameter inter_1 : multi x (inter s s') = Nmin (multi x s) (multi x s').

  (** Specification of [diff] *)
  Parameter diff_1 : multi x (diff s s') = multi x s - multi x s'.

  (** Specification of [fold] *)
  Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> positive -> A -> A),
      fold f s i = fold_left (fun a p => f (fst p) (snd p) a) (elements s) i.

  Definition eq_pair (p p':elt*positive) :=
    E.eq (fst p) (fst p') /\ (snd p) = (snd p').

  Definition lt_pair (p p':elt*positive) := E.lt (fst p) (fst p').

  (** Specification of [elements] *)
  Parameter elements_1 : multi x s = Npos p -> InA eq_pair (x,p) (elements s).
  Parameter elements_2 : InA eq_pair (x,p) (elements s) -> multi x s = Npos p.
  Parameter elements_3 : sort lt_pair (elements s).

  End Spec.

End S.

Module Multi (X:OrderedType)(M:FMapInterface.S with Module E:=X)
 <: S with Module E:=X.

 Module E := X.

 Definition elt:=E.t.

 Definition t := M.t positive.
 Definition empty := M.empty positive.
 Definition multi x t := match M.find x t with
  | None => 0
  | Some p => Npos p
 end.

 Definition update x n s := match n with
  | N0 => M.remove x s
  | Npos p => M.add x p s
 end.

 Definition union := M.map2
   (fun o o' =>
      match o,o' with
        | None, None => None
        | None, Some p => Some p
        | Some p, None => Some p
        | Some p, Some p' => Some (Pplus p p')
      end).

 Definition inter := M.map2
   (fun o o' =>
      match o,o' with
        | Some p, Some p' => Some (Pmin p p')
        | _, _ => None
      end).

 Definition diff := M.map2
   (fun o o' =>
      match o,o' with
        | None, _ => None
        | Some p, None => Some p
        | Some p, Some p' => match Pcompare p p' Eq with
            | Lt | Eq => None
            | Gt => Some (Pminus p p')
          end
      end).

 Definition fold := @M.fold positive.

 Definition elements := @M.elements positive.

 Definition equal := M.equal Peqb.

 Definition subset s s' := equal (diff s s') empty.

 Definition Equal s s' := forall a : elt, multi a s = multi a s'.
 Definition Subset s s' := forall a : elt, multi a s <= multi a s'.
 Definition Empty s := forall a : elt, multi a s = 0.

 Notation "s [=] t" := (Equal s t) (at level 70, no associativity).
 Notation "s [<=] t" := (Subset s t) (at level 70, no associativity).

  Module F := FMapFacts.Facts(M).

  Section Spec.

  Variable s s' s'' : t.
  Variable x y : elt.
  Variable n : N.
  Variable p : positive.

  (** Specification of [empty] *)
  Lemma empty_1 : Empty empty.
  Proof.
  unfold Empty, empty, multi; intros.
  rewrite F.empty_o; auto.
  Qed.

  (** Specification of [update] *)
  Lemma update_1 : E.eq x y -> multi y (update x n s) = n.
  Proof.
  unfold update, multi; intros.
  destruct n.
  rewrite F.remove_eq_o; auto.
  rewrite F.add_eq_o; auto.
  Qed.

  Lemma update_2 : ~E.eq x y -> multi y (update x n s) = multi y s.
  Proof.
  unfold update, multi; intros.
  destruct n.
  rewrite F.remove_neq_o; auto.
  rewrite F.add_neq_o; auto.
  Qed.

  (** Specification of [union] *)
  Lemma union_1 : multi x (union s s') = multi x s + multi x s'.
  Proof.
  unfold union, multi; intros.
  rewrite F.map2_1bis; auto.
  destruct (M.find x s); destruct (M.find x s'); auto.
  Qed.

  (** Specification of [inter] *)
  Lemma inter_1 : multi x (inter s s') = Nmin (multi x s) (multi x s').
  Proof.
  unfold inter, multi; intros.
  rewrite F.map2_1bis; auto.
  destruct (M.find x s); destruct (M.find x s'); auto.
  unfold Nmin, Pmin, Nle.
  simpl.
  destruct (Pos.compare p0 p1); auto.
  Qed.

  (** Specification of [diff] *)
  Lemma diff_1 : multi x (diff s s') = multi x s - multi x s'.
  Proof.
  unfold diff, multi; intros.
  rewrite F.map2_1bis; auto.
  destruct (M.find x s); destruct (M.find x s'); auto.
  simpl.
  case_eq (Pcompare p0 p1 Eq); intro H.
  apply Pcompare_Eq_eq in H. rewrite H. now rewrite Pminus_mask_diag.
  now rewrite (Pminus_mask_Lt p0 p1 H).
  pose proof (Pminus_mask_Gt p0 p1 H) as H1. unfold Pminus.
  destruct H1 as [h [H1 _]]; now rewrite H1.
  Qed.

  (** Specification of [fold] *)
  Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> positive -> A -> A),
      fold f s i = fold_left (fun a p => f (fst p) (snd p) a) (elements s) i.
  Proof.
  intros; unfold fold, elements.
  apply M.fold_1.
  Qed.

  Definition eq_pair (p p':elt*positive) :=
    E.eq (fst p) (fst p') /\ (snd p) = (snd p').

  Definition lt_pair (p p':elt*positive) := E.lt (fst p) (fst p').

  (** Specification of [elements] *)
  Lemma elements_1 : multi x s = Npos p -> InA eq_pair (x,p) (elements s).
  Proof.
  unfold multi, elements; intros.
  apply (@M.elements_1 positive).
  apply M.find_2.
  destruct (M.find x s); congruence || discriminate.
  Qed.

  Lemma elements_2 : InA eq_pair (x,p) (elements s) -> multi x s = Npos p.
  Proof.
  unfold multi, elements; intros.
  assert (H0:=@M.elements_2 positive _ _ _ H).
  rewrite F.find_mapsto_iff in H0; rewrite H0; auto.
  Qed.

  Lemma elements_3 : sort lt_pair (elements s).
  Proof.
  apply (@M.elements_3 positive).
  Qed.

  (** Specification of [equal] *)
  Lemma equal_1 : s[=]s' -> equal s s' = true.
  Proof.
  unfold equal, Equal, multi; intros.
  apply M.equal_1.
  unfold M.Equivb, Cmp; intros.
  split; intros.
  generalize (H k); clear H; intros H.
  unfold M.In.
  split; intros (e,He); exists e; rewrite F.find_mapsto_iff in *.
   rewrite He in H; simpl in *.
   destruct (M.find k s'); auto; discriminate || congruence.
   rewrite He in H; simpl in *.
   destruct (M.find k s); auto; discriminate || congruence.
  rewrite F.find_mapsto_iff in *.
  generalize (H k); clear H.
  rewrite H0; rewrite H1; simpl.
  inversion 1; subst; apply Peqb_correct.
  Qed.

  Lemma equal_2 : equal s s' = true ->s[=]s'.
  Proof.
  unfold equal, Equal, multi; intros.
  generalize (M.equal_2 H); clear H; intros H.
  destruct H.
  unfold Cmp in *.
  case_eq (M.find a s); case_eq (M.find a s'); simpl; intros; auto.
  assert (H3:=H0 a p1 p0).
  do 2 rewrite F.find_mapsto_iff in H3.
  f_equal.
  apply Peqb_complete; auto.
  assert (M.In a s) by (exists p0; apply M.find_2; auto).
  rewrite H in H3.
  destruct H3; rewrite F.find_mapsto_iff in H3; congruence.
  assert (M.In a s') by (exists p0; apply M.find_2; auto).
  rewrite <- H in H3.
  destruct H3; rewrite F.find_mapsto_iff in H3; congruence.
  Qed.

  End Spec.

  (** Specification of [subset] *)
  Lemma subset_1 : forall s s', s[<=]s' -> subset s s' = true.
  Proof.
  unfold subset, Subset; intros.
  apply equal_1.
  red; intros.
  rewrite diff_1.
  rewrite empty_1.
  apply <- Nminus_N0_Nle; auto.
  Qed.

  Lemma subset_2 : forall s s', subset s s' = true -> s[<=]s'.
  Proof.
  unfold subset, Subset; intros.
  assert (H0:=equal_2 H a).
  rewrite diff_1 in H0.
  rewrite empty_1 in H0.
  apply -> Nminus_N0_Nle; auto.
  Qed.

End Multi.

(* Example : A multiset on elements in type N *)

Module Ma := FMapList.Make N_as_OT.
Module Mu := Multi N_as_OT Ma.

Definition mens1 := Mu.update 2 7 (Mu.update 3 5 (Mu.empty)).
Definition mens2 := Mu.update 1 4 (Mu.update 3 6 (Mu.empty)).

Eval compute in Mu.elements (Mu.union mens1 mens2).

(* Example: total multiplicity *)

Definition fmu := fun (_:Ma.key) p s => (Npos p) + s.

Definition total_multi s := Mu.fold fmu s 0.

Module Import NP := FMapFacts.Properties Ma.
Import NP.F.
Module Import NP' := FMapFacts.OrdProperties Ma.

Lemma fmu_compat : Proper (eq==>eq==>eq==>eq) fmu.
Proof.
 repeat red; intros; subst; auto.
Qed.

Lemma fmu_transp : transpose_neqkey eq fmu.
Proof.
 red; intros.
 unfold fmu; do 2 rewrite Nplus_assoc; f_equal; apply Nplus_comm; auto.
Qed.
Hint Resolve fmu_compat fmu_transp.

Lemma total_multi_union:
 forall s s', total_multi (Mu.union s s') = total_multi s + total_multi s'.
Proof.
unfold total_multi, Mu.fold.
induction s using map_induction; intros.
rewrite elements_Empty in H.
rewrite (@fold_Equal _ (Mu.union s s') s' _ (@eq N)); auto.
rewrite (Ma.fold_1 s); rewrite H; auto.
 red; intros; unfold Mu.union; rewrite map2_1bis; auto.
 rewrite (elements_o s); rewrite H; simpl.
 destruct (Ma.find y s'); auto.

replace (Ma.fold fmu s2 0) with (fmu x e (Ma.fold fmu s1 0))
 by (symmetry; apply fold_Add; auto).
unfold fmu at 2; simpl @snd.
rewrite <- Nplus_assoc.
rewrite <- IHs1.
case_eq (Ma.find x s'); intros.
(* x may appear in s' hence in (Mu.union s1 s'). In this case we introduce
   artificially (Ma.remove x (Mu.union s1 s')) and reason in two steps. *)
set (u:=Ma.remove x (Mu.union s1 s')).
replace (Ma.fold fmu (Mu.union s2 s') 0) with (fmu x (Pplus e p) (Ma.fold fmu u 0));
 [ | symmetry; apply fold_Add; auto ].
replace (Ma.fold fmu (Mu.union s1 s') 0) with (fmu x p (Ma.fold fmu u 0));
 [ | symmetry; apply fold_Add; auto ].
unfold fmu at 1 3; rewrite Nplus_assoc; f_equal.
unfold u; apply Ma.remove_1; auto.
unfold u, Mu.union; red; intros; rewrite add_o; rewrite remove_o.
rewrite map2_1bis; auto.
(* destruct (eq_dec x y); auto. ----> Not_found *)
destruct (P.F.eq_dec x y); auto.
compute in e0; subst; rewrite H1; auto.
rewrite not_find_mapsto_iff in H; rewrite H; auto.
unfold u; apply Ma.remove_1; auto.
unfold u, Mu.union; red; intros; rewrite add_o; rewrite remove_o.
do 2 (rewrite map2_1bis; auto).
rewrite H0; rewrite add_o.
destruct (P.F.eq_dec x y); auto.
compute in e0; subst; rewrite H1; auto.
(* simple situation where x isn't in s' *)
change (Nplus (Npos e)) with (fmu x e).
apply fold_Add; auto.
rewrite not_find_mapsto_iff; rewrite not_find_mapsto_iff in H.
unfold Mu.union; rewrite map2_1bis; auto; rewrite H1; rewrite H; auto.
red; intros; unfold Mu.union; rewrite add_o.
do 2 (rewrite map2_1bis; auto).
rewrite H0; rewrite add_o.
destruct (P.F.eq_dec x y); auto.
compute in e0; subst; rewrite H1; auto.
Qed.

Lemma total_multi_update: forall s x n,
 total_multi (Mu.update x n s) + Mu.multi x s  = total_multi s + n.
Proof.
unfold total_multi, Mu.fold.
induction s using map_induction; intros.

rewrite elements_Empty in H.
unfold Mu.multi.
rewrite elements_o; rewrite H; simpl.
unfold Mu.update; destruct n.
do 2 rewrite Nplus_0_r.
apply fold_Equal with (eqA:=@eq _); auto.
 red; intros; rewrite remove_o; rewrite elements_o; rewrite H; simpl.
 destruct (P.F.eq_dec x y); auto.
rewrite Nplus_0_r; rewrite Nplus_comm.
change (Nplus (Npos p)) with (fmu x p).
apply fold_Add with (eqA:=@eq _); auto.
 rewrite not_find_mapsto_iff; rewrite elements_o; rewrite H; auto.
 red; auto.

rename x0 into y; rename H into A1; rename H0 into A2.
replace (Ma.fold fmu s2 0) with (fmu x e (Ma.fold fmu s1 0))
 by (symmetry; apply fold_Add; auto).
unfold fmu at 2; rewrite <- Nplus_assoc.
rewrite <- (IHs1 y n); clear IHs1; rewrite Nplus_assoc.
destruct (P.F.eq_dec x y) as [E|E].
(* x=y *)
compute in E; subst y.
replace (Mu.multi x s2) with (Npos e).
replace (Mu.multi x s1) with 0.
rewrite Nplus_0_r; rewrite Nplus_comm; f_equal.
apply fold_Equal with (eqA:=@eq _); eauto.
red; intros; unfold Mu.update; destruct n.
do 2 rewrite remove_o; rewrite A2; rewrite add_o.
destruct (P.F.eq_dec x y); auto.
do 2 rewrite add_o; rewrite A2; rewrite add_o.
destruct (P.F.eq_dec x y); auto.
unfold Mu.multi; rewrite not_find_mapsto_iff in A1; rewrite A1; auto.
unfold Mu.multi.
rewrite A2; rewrite add_o.
destruct (P.F.eq_dec x x) as [_|H]; [ auto | elim H; ME.order ].
(* x<>y *)
replace (Mu.multi y s2) with (Mu.multi y s1).
f_equal.
change (Nplus (Npos e)) with (fmu x e).
apply fold_Add; auto.
rewrite not_find_mapsto_iff; rewrite not_find_mapsto_iff in A1.
assert (y<>x) by (contradict E; auto).
generalize (Mu.update_2 s1 n H).
unfold Mu.multi; rewrite A1.
destruct (Ma.find x (Mu.update y n s1)); intros; discriminate || auto.
red; intros; rewrite add_o.
unfold Mu.update; destruct n;
 rewrite ?remove_o, ?add_o, A2, ?remove_o, ?add_o;
 destruct P.F.eq_dec; destruct P.F.eq_dec; auto; congruence.
unfold Mu.multi; rewrite A2, add_o.
destruct (P.F.eq_dec x y) as [H|_]; [ elim E; auto | auto ].
Qed.


Require Export TopologicalSpaces.
Require Import WeakTopology.

Section Subspace.

Variable X:TopologicalSpace.
Variable A:Ensemble X.

Definition SubspaceTopology : TopologicalSpace :=
  WeakTopology1 (proj1_sig (P:=fun x:X => In A x)).

Definition subspace_inc :
  SubspaceTopology -> X :=
  proj1_sig (P:=fun x:X => In A x).

Lemma subspace_inc_continuous:
  @continuous SubspaceTopology X (@proj1_sig _ _).
Proof.
apply weak_topology1_makes_continuous_func.
Qed.

Lemma subspace_continuous_char (Y : TopologicalSpace)
      (f : Y -> SubspaceTopology) :
  continuous f <->
  continuous (compose subspace_inc f).
Proof.
  apply weak_topology1_continuous_char.
Qed.

Lemma subspace_open_char: forall U:Ensemble {x: X | In A x},
  @open SubspaceTopology U <-> exists V:Ensemble X,
  open V /\ U = inverse_image subspace_inc V.
Proof.
apply weak_topology1_topology.
Qed.

Lemma subspace_closed_char: forall U:Ensemble {x: X | In A x},
  @closed SubspaceTopology U <-> exists V:Ensemble X,
  closed V /\ U = inverse_image subspace_inc V.
Proof.
apply weak_topology1_topology_closed.
Qed.

Lemma subspace_closure U :
  closure U = inverse_image subspace_inc (closure (Im U subspace_inc)).
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - constructor.
    apply continuous_closure.
    { apply subspace_inc_continuous. }
    apply Im_def.
    assumption.
  - destruct H.
    unfold closure in H.
    constructor. intros.
    destruct H0. destruct H0.
    rewrite subspace_closed_char in H0.
    destruct H0 as [V []].
    subst. constructor.
    destruct H.
    apply H. repeat split; try assumption.
    intros ? ?. inversion H2; subst; clear H2.
    apply H1. assumption.
Qed.

End Subspace.

Arguments SubspaceTopology {X}.
Arguments subspace_inc {X}.

(* Every set is dense in its closure. *)
Lemma dense_in_closure {X:TopologicalSpace} (A : Ensemble X) :
  dense (inverse_image (subspace_inc (closure A)) A).
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  { constructor. }
  destruct x.
  rewrite subspace_closure.
  constructor. simpl.
  rewrite inverse_image_image_surjective_locally.
  { assumption. }
  intros.
  unshelve eexists (exist _ y _).
  2: { reflexivity. }
  apply closure_inflationary.
  assumption.
Qed.

(* If the subspace [F] is closed in [X], then its [subspace_inc] is a
   closed map. *)
Lemma subspace_inc_takes_closed_to_closed
  (X : TopologicalSpace) (F:Ensemble X) :
  closed F ->
  forall G:Ensemble (SubspaceTopology F),
  closed G -> closed (Im G (subspace_inc F)).
Proof.
intros.
red in H0.
rewrite subspace_open_char in H0.
destruct H0 as [U []].
replace (Im G (subspace_inc F)) with
  (Intersection F (Complement U)).
{ apply closed_intersection2; trivial.
  red. now rewrite Complement_Complement. }
apply Extensionality_Ensembles; split; red; intros.
- destruct H2.
  exists (exist _ x H2); trivial.
  apply NNPP. intro.
  change (In (Complement G) (exist (In F) x H2)) in H4.
  rewrite H1 in H4.
  now destruct H4.
- destruct H2 as [[y]].
  subst y0.
  constructor; trivial.
  intro.
  absurd (In (Complement G) (exist _ y i)).
  + now intro.
  + now rewrite H1.
Qed.


Require Import Arith. (* arith database for tactics *)

Theorem example_for_intuition:
  forall n p q : nat, n <= p \/ n <= q -> n <= p \/ n <= S q.
Proof.
  intros n p q. intuition. (* auto with arith. will also work *)
Qed.

(* intuition = intuition auto with * *)


Inductive listn : nat -> Set :=
  | niln : listn 0
  | consn : forall n : nat, nat -> listn n -> listn (S n).

Inductive empty : forall n : nat, listn n -> Prop :=
    intro_empty : empty 0 niln.

Parameter
  inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l).

Type
  (fun (n : nat) (l : listn n) =>
   match l in (listn n) return (empty n l \/ ~ empty n l) with
   | niln => or_introl (~ empty 0 niln) intro_empty
   | consn n O y as b => or_intror (empty (S n) b) (inv_empty n 0 y)
   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
   end).

Type
  (fun (n : nat) (l : listn n) =>
   match l in (listn n) return (empty n l \/ ~ empty n l) with
   | niln => or_introl (~ empty 0 niln) intro_empty
   | consn n O y => or_intror (empty (S n) (consn n 0 y)) (inv_empty n 0 y)
   | consn n a y => or_intror (empty (S n) (consn n a y)) (inv_empty n a y)
   end).

Type
  (fun (n : nat) (l : listn n) =>
   match l in (listn n) return (empty n l \/ ~ empty n l) with
   | niln => or_introl (~ empty 0 niln) intro_empty
   | consn O a y as b => or_intror (empty 1 b) (inv_empty 0 a y)
   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
   end).


Require Export XR_INR.
Require Export XR_IZR.

Local Open Scope R_scope.

Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z.of_nat n).
Proof.
  intro n.
  induction n as [ | n hin ].
  {
    simpl.
    reflexivity.
  }
  {
    simpl.
    rewrite SuccNat2Pos.id_succ.
    reflexivity.
  }
Qed.


Require Import Utf8.
Require Import Coq.Program.Basics Setoid RelationClasses ProofIrrelevance FunctionalExtensionality.

(* Note : Remember to use eq_rect for equality between morphisms
  if necessary *)
Import EqNotations.

(* identity is unique, not sure if composition is, so I'll leave it as a parameter *)

Class Category
  (obj : Type)
  (hom : obj -> obj -> Type)
  (comp : forall {A B C} (f : hom B C) (g : hom A B), hom A C) := {
  cid : forall A, hom A A;

  idLeft: forall {A B} (f: hom A B), comp (cid B) f = f;
  idRight: forall {A B} (f : hom B A), comp f (cid B) = f;
  compAssoc: forall {A B C D} (f : hom A B) (g : hom B C) (h : hom C D),
    comp h (comp g f) = comp (comp h g) f
}.

Generalizable Variables obj hom comp.

Definition homOp `{Category} := hom.
Definition compOp `{Category obj hom comp} := comp.

Notation "a --> b" := (homOp a b).
Notation "1" := (cid _).
Notation "f '•' g" := (compOp _ _ _ f g) (at level 50).

(*** Dualization *)
Instance Dual `(Category obj hom comp) : Category obj (fun A B => B --> A)
  (fun {A B C} f g => comp _ _ _ g f):= {}.
Proof.
  - intros. apply 1.
  - intros A B f. simpl. apply idRight.
  - intros A B f. apply idLeft.
  - intros A B C D f g h. simpl. rewrite compAssoc. reflexivity.
Defined.

(* If we don't remove this typclass instance search might not terminate *)
Remove Hints Dual : typeclass_instances.

Notation "C ¯" := (Dual C) (at level 20, left associativity).

(** EXAMPLES **)

Instance Category_Set : Category Type (fun A B => A -> B)
  (fun A B C f g => compose f g) := {}.
  - intros. apply X.
  - intros. reflexivity.
  - intros. reflexivity.
  - intros. unfold compose. reflexivity.
Defined.

Class Poset {A : Type} (R : relation A) := {
  Poset_Reflexive :> Reflexive R;
  Poset_Transitive :> Transitive R;
  Poset_Antisymmetric :> Antisymmetric A eq R;
}.

Instance Category_Poset (A : Type) (lt : relation A) (P : Poset lt) : Category A
  (fun (a1 a2 : A) => lt a1 a2)
  (fun (a1 a2 a3 : A) p1 p2 => @transitivity A lt (Poset_Transitive) a1 a2 a3 p2 p1)
  := {}.
  - apply reflexivity.
  - intros; apply proof_irrelevance.
  - intros; apply proof_irrelevance.
  - intros; apply proof_irrelevance.
Defined.


Require Export GeoCoq.Elements.OriginalProofs.lemma_betweennotequal.
Require Export GeoCoq.Elements.OriginalProofs.lemma_localextension.
Require Export GeoCoq.Elements.OriginalProofs.lemma_congruencesymmetric.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_betweennesspreserved :
   forall A B C a b c,
   Cong A B a b -> Cong A C a c -> Cong B C b c -> BetS A B C ->
   BetS a b c.
Proof.
intros.
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (neq a b) by (conclude axiom_nocollapse).
assert (neq B C) by (forward_using lemma_betweennotequal).
assert (neq b c) by (conclude axiom_nocollapse).
let Tf:=fresh in
assert (Tf:exists d, (BetS a b d /\ Cong b d b c)) by (conclude lemma_localextension);destruct Tf as [d];spliter.
assert (Cong b c b d) by (conclude lemma_congruencesymmetric).
assert (Cong b c B C) by (conclude lemma_congruencesymmetric).
assert (Cong b d B C) by (conclude cn_congruencetransitive).
assert (Cong B C b d) by (conclude lemma_congruencesymmetric).
assert (Cong C C c d) by (conclude axiom_5_line).
assert (Cong c d C C) by (conclude lemma_congruencesymmetric).
assert (~ neq c d).
 {
 intro.
 assert (neq C C) by (conclude axiom_nocollapse).
 assert (eq C C) by (conclude cn_equalityreflexive).
 contradict.
 }
assert (BetS a b c) by (conclude cn_equalitysub).
close.
Qed.

End Euclid.