(* $Id: Intervals.v,v 1.21 2003/03/13 12:06:25 lcf Exp $ *)

Require Export RealLists.

Section Intervals.
(* Tex_Prose
\chapter{Intervals}
In this section we define (compact) intervals of the real line and some useful functions to work with them.

\section{Definitions}

We start by defining the compact interval $[a,b]$ as being the set of points less or equal than $b$ and greater or equal than $a$.  We require $a$ to be less or equal to $b$, as we want to work only in nonempty intervals.
*)

(* Begin_Tex_Verb *)
Definition compact [a,b:IR][Hab:a[<=]b] :=
  [x:IR]{a[<=]x}*{x[<=]b}.
(* End_Tex_Verb *)

(* Tex_Prose
\begin{convention} Let \verb!a,b:IR! and \verb!Hab:a[<=]b!.
\end{convention}

As expected, both $a$ and $b$ are members of $[a,b]$.  Also they are members of the interval $[\min(a,b),\max(a,b)]$.
*)

Variables a,b:IR.
Hypothesis Hab:a[<=]b.

(* Begin_Tex_Verb *)
Lemma compact_inc_lft : (compact a b Hab a).
(* End_Tex_Verb *)
Intros; Split; [Apply leEq_reflexive | Auto].
Qed.

(* Begin_Tex_Verb *)
Lemma compact_inc_rht : (compact a b Hab b).
(* End_Tex_Verb *)
Intros; Split; [Auto | Apply leEq_reflexive].
Qed.

(* Begin_Tex_Verb *)
Lemma compact_Min_lft :
  (Hab':?)(compact (Min a b) (Max a b) Hab' a).
(* End_Tex_Verb *)
Split; [Apply Min_leEq_lft | Apply lft_leEq_Max].
Qed.

(* Begin_Tex_Verb *)
Lemma compact_Min_rht :
  (Hab':?)(compact (Min a b) (Max a b) Hab' b).
(* End_Tex_Verb *)
Split; [Apply Min_leEq_rht | Apply rht_leEq_Max].
Qed.

(* Tex_Prose
As we will be interested in taking functions with domain in a compact interval, we want this predicate to be well defined.
*)

(* Begin_Tex_Verb *)
Lemma compact_wd : (pred_well_def IR (compact a b Hab)).
(* End_Tex_Verb *)
Intros; Red; Intros.
Inversion_clear H; Split.
Apply leEq_wdr with x; Assumption.
Apply leEq_wdl with x; Assumption.
Qed.

(* Tex_Prose
Also, it will sometimes be necessary to rewrite the endpoints of an interval.
*)

(* Begin_Tex_Verb *)
Lemma compact_wd' : (a',b':IR)(Hab':?)(x:IR)(a[=]a')->(b[=]b')->
  (compact a b Hab x)->(compact a' b' Hab' x).
(* End_Tex_Verb *)
Intros.
Inversion_clear H1; Split.
Apply leEq_wdl with a; Auto.
Apply leEq_wdr with b; Auto.
Qed.

(* Tex_Prose
As we identify subsets with predicates, inclusion is simply implication.
*)

(* Begin_Tex_Verb *)
Definition included [P,Q:IR->CProp] : CProp := (x:IR)(P x)->(Q x).
(* End_Tex_Verb *)

(* Tex_Prose
Finally, we define a restriction operator that takes a function $F$ and a well defined predicate $P$ included in the domain of $F$ and returns the restriction $F|_P$.
*)

(* Begin_Tex_Verb *)
Definition Frestr [F:PartIR][P:IR->CProp][HP:(pred_well_def IR P)]
  [H:(included P (Pred F))] : PartIR.
(* End_Tex_Verb *)
Intros.
Apply Build_PartFunct with P [x:IR][Hx:(P x)](Part F x (H x Hx)).
Assumption.
Intros; Exact (pfstrx ?????? H0).
Defined.

End Intervals.

(* Tex_Prose
\begin{notation}
\item the first two arguments of \verb!compact! are left implicit by writing {\tt\hypertarget{Syntactic_36}{Compact}};
\item {\tt\hypertarget{Syntactic_38}{FRestr}} stands for \verb!(Frestr ?? (compact_wd ???))!.
\end{notation}
*)

Syntactic Definition Compact := (compact ??).
Implicits Frestr [1 2].
Syntactic Definition FRestr := (Frestr (compact_wd ???)).

Section More_Intervals.

(* Tex_Prose
\section{Inclusion}

We now turn our attention to the properties of the inclusion relation.  We show it to be reflexive and transitive, and to work as expected with conjunction and extension.  The second property is a generalization of the reflexivity when the same compact interval is characterized in two different ways.
*)

(* Begin_Tex_Verb *)
Lemma included_refl : (P:IR->CProp)(included P P).
(* End_Tex_Verb *)
Intro.
Red; Intros.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma included_refl' : (a,b,Hab,Hab':?)
  (included (compact a b Hab) (compact a b Hab')).
(* End_Tex_Verb *)
Intros.
Red; Intros.
Inversion_clear H; Split; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma included_trans : (P,Q,R:?)
  (included P Q)->(included Q R)->(included P R).
(* End_Tex_Verb *)
Intros.
Red; Intros.
Apply H0; Apply H; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma included_conj : (P,Q,R:IR->CProp)
  (included P Q)->(included P R)->(included P (Conj Q R)).
(* End_Tex_Verb *)
Intros.
Red; Red in H H0.
Intros; Red.
Split.
Apply H; Assumption.
Apply H0; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma included_conj' : (P,Q:IR->CProp)
  (included (Conj P Q) P).
(* End_Tex_Verb *)
Intros.
Exact (prj1 ? P Q).
Qed.

(* Begin_Tex_Verb *)
Lemma included_conj'' : (P,Q:IR->CProp)
  (included (Conj P Q) Q).
(* End_Tex_Verb *)
Intros.
Exact (prj2 ? P Q).
Qed.

(* Begin_Tex_Verb *)
Lemma included_conj_lft : (P,Q,R:IR->CProp)
  (included R (Conj P Q))->(included R P).
(* End_Tex_Verb *)
Intros.
Red; Red in H.
Unfold conjP in H.
Intros.
Elim (H x).
Intros; Trivial.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma included_conj_rht : (P,Q,R:IR->CProp)
  (included R (Conj P Q))->(included R Q).
(* End_Tex_Verb *)
Intros.
Red; Red in H.
Unfold conjP in H.
Intros.
Elim (H x).
Intros; Trivial.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma included_extend : (P,R:IR->CProp;Q:(x:IR)(P x)->CProp)
  (included R (extend P Q))->(included R P).
(* End_Tex_Verb *)
Intros.
Red; Red in H.
Unfold extend in H.
Intros.
Elim (H x).
2: Assumption.
Intros.
Tauto.
Qed.

(* Tex_Prose
We also prove some inclusions of compact intervals.
*)

(* Begin_Tex_Verb *)
Lemma compact_map1 : (a,b:IR)(Hab,Hab':?)
  (included
    (compact (Min a b) (Max a b) Hab')
    (compact a b Hab)).
(* End_Tex_Verb *)
Intros.
Red; Intros x H.
Red; Red in H.
Inversion_clear H.
Split.
EApply leEq_wdl; [Apply H0 | Apply leEq_imp_Min_is_lft; Auto].
EApply leEq_wdr; [Apply H1 | Apply leEq_imp_Max_is_rht; Auto].
Defined.

(* Begin_Tex_Verb *)
Lemma compact_map2 : (a,b:IR)(Hab,Hab':?)
  (included
    (compact a b Hab)
    (compact (Min a b) (Max a b) Hab')).
(* End_Tex_Verb *)
Intros.
Red; Intros x H.
Red; Red in H.
Inversion_clear H.
Split.
EApply leEq_transitive; [Apply Min_leEq_lft | Apply H0].
EApply leEq_transitive; [Apply H1 | Apply rht_leEq_Max].
Defined.

(* Begin_Tex_Verb *)
Lemma compact_map3 : (a,b,e:IR)(Hab,Hab':?)(Zero[<]e)->
  (included (compact a b[-]e Hab') (compact a b Hab)).
(* End_Tex_Verb *)
Intros; Red.
Intros; Inversion_clear H0; Split.
Auto.
EApply leEq_transitive.
Apply H2.
Apply shift_minus_leEq.
Apply shift_leEq_plus'.
Step (Zero::IR); Apply less_leEq; Assumption.
Qed.

End More_Intervals.

Section Totally_Bounded.

(* Tex_Prose
\section{Totally Bounded}

Sets that are totally bounded will play an important role in what is to come.  The definition (equivalent to the classical one) states that $P$ is totally bounded iff \[\forall_{\varepsilon>0}\exists_{x_1,\ldots,x_n}\forall_{y\in P}\exists_{1\leq i\leq n}|y-x_i|<\varepsilon\]

Notice the use of lists for quantification.
*)

(* Begin_Tex_Verb *)
Definition totally_bounded [P:IR->CProp] : CProp :=
  {x:IR & (P x)}*
  (e:IR)(Zero[<]e)->
    {l:(list IR) &
      ((x:IR)(member x l)->(P x)) & (x:IR)(P x)->
        {y:IR & (member y l) | (AbsSmall e x[-]y)}}.
(* End_Tex_Verb *)

(* Tex_Prose
This definition is classically, but not constructively, equivalent to the definition of compact; the next result, classically equivalent to the Heine-Borel theorem, justifies that we take the definition of totally bounded to be the relevant one and that we defined compacts as we did.
*)

(* Begin_Tex_Verb *)
Lemma compact_is_totally_bounded :
   (a,b,Hab:?)(totally_bounded (compact a b Hab)).
(* End_Tex_Verb *)
Intros; Split.
Exists a.
Apply compact_inc_lft.
Cut (n:nat)(a,b,e:IR)(Hab:a[<=]b)(He:Zero[<]e)
  ((b[-]a)[/]e[//](pos_ap_zero ?? He)[<=](nring n))->
    ((le (2) n)->(((nring n)[-]Two)[<=](b[-]a)[/]e[//](pos_ap_zero ?? He)))->
    {l:(list IR) & ((x:IR)(member x l)->(compact a b Hab x)) & (x:IR)(compact a b Hab x)->{y:IR & (member y l) | (AbsIR x[-]y)[<=]e}}.
Intros H e He.
Elim (str_Archimedes (b[-]a)[/]?[//](pos_ap_zero ?? (pos_div_two ?? He))).
Intros n Hn.
Inversion_clear Hn.
Elim (H n a b ? Hab (pos_div_two ?? He)).
Intros l Hl' Hl.
2: Assumption.
2: Assumption.
Exists l.
Assumption.
Intros x Hx; Elim (Hl x Hx).
Intros y Hy Hy'.
Exists y.
Assumption.
Apply AbsIR_imp_AbsSmall.
Apply leEq_transitive with e[/]TwoNZ.
Assumption.
Apply less_leEq; Apply pos_div_two'; Assumption.
Apply shift_leEq_div; [Apply pos_div_two; Assumption | Apply shift_leEq_minus].
RStep a; Assumption.
Clear Hab a b; Intro n; Induction n.
Intros.
Exists (cons a (nil ?)).
Intros.
Inversion H1.
Elim H2.
Apply compact_wd with a; Algebra.
Apply compact_inc_lft.
Intros.
Exists a.
Right; Algebra.
Apply leEq_wdl with (Zero::IR).
Apply less_leEq; Auto.
Step (AbsIR Zero).
Apply AbsIR_wd.
Apply leEq_imp_eq.
Apply shift_leEq_minus; Step a; Elim H1; Auto.
Apply shift_minus_leEq.
Apply leEq_transitive with b.
Elim H1; Auto.
Apply shift_leEq_plus.
Apply mult_cancel_leEq with One[/]?[//](pos_ap_zero ?? He).
Apply recip_resp_pos; Auto.
Stepr (Zero::IR).
RStep (b[-]a)[/]?[//](pos_ap_zero ?? He); Auto.
Clear Hrecn; Induction n.
Intros.
Exists (cons a (nil IR)).
Intros.
Inversion_clear H1.
Elim H2.
Apply compact_wd with a; [Apply compact_inc_lft | Algebra].
Intros x Hx; Inversion_clear Hx.
Exists a.
Simpl; Right; Algebra.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
Apply leEq_transitive with b[-]a.
Apply minus_resp_leEq; Assumption.
RStepr e[*](nring (1)); EApply shift_leEq_mult'; [Assumption | Apply H].
Apply shift_leEq_minus; Step a.
Assumption.
Clear Hrecn; Induction n.
Intros.
LetTac enz:=(pos_ap_zero ?? He).
Exists (cons (a[+]b)[/]TwoNZ (nil IR)).
Intros.
Inversion_clear H1.
Inversion_clear H2.
Apply compact_wd with (a[+]b)[/]TwoNZ; [Split | Algebra].
Step a[+]Zero; Apply shift_plus_leEq'.
Apply mult_cancel_leEq with (Two::IR).
Apply pos_two.
Step (Zero::IR).
RStepr b[-]a.
Apply shift_leEq_minus; Step a; Auto.
Stepr b[+]Zero; Apply shift_leEq_plus'.
Apply mult_cancel_leEq with (Two::IR).
Apply pos_two.
Stepr (Zero::IR).
RStep a[-]b.
Apply shift_minus_leEq; Stepr b; Auto.
Intros.
Exists (a[+]b)[/]TwoNZ.
Right; Algebra.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply Abs_Max.
Apply shift_minus_leEq; Apply Max_leEq; Apply shift_leEq_plus'; Apply leEq_Min.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
Step (Zero::IR); Apply less_leEq; Auto.
Apply shift_minus_leEq.
Apply leEq_transitive with b.
Elim H1; Auto.
Apply shift_leEq_plus'.
Apply mult_cancel_leEq with (Two::IR).
Apply pos_two.
Apply shift_leEq_mult' with enz.
Auto.
RStep (b[-]a)[/]e[//]enz; Auto.
Apply leEq_transitive with a.
2: Elim H1; Auto.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
Apply mult_cancel_leEq with (Two::IR).
Apply pos_two.
Apply shift_leEq_mult' with enz.
Auto.
RStep (b[-]a)[/]e[//]enz; Auto.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
Step (Zero::IR); Apply less_leEq; Auto.

Intros.
LetTac b':=b[-]e.
Cut a[<=]b'; Intros.
Elim (Hrecn a b' e H1 He).
Intros l Hl' Hl.
Exists (cons b' l).
Intros.
Unfold b' in H1; Apply compact_map3 with e:=e Hab':=H1 b:=b.
Assumption.
Simpl in H2; Inversion_clear H2.
Apply Hl'; Assumption.
Apply compact_wd with b'; [Apply compact_inc_rht | Algebra].
Intros.
Cut (x[<]b')+((b'[-]e)[<]x); Intros.
Inversion_clear H3.
Cut (compact a b' H1 x); Intros.
Elim (Hl x H3).
Intros y Hy Hy'.
Exists y.
Left; Assumption.
Auto.
Inversion_clear H2; Split.
Assumption.
Apply less_leEq; Auto.
Exists b'.
Right; Algebra.
Simpl; Unfold ABSIR.
Apply Max_leEq.
Apply shift_minus_leEq; Unfold b'.
RStepr b.
Elim H2; Auto.
RStep b'[-]x; Apply shift_minus_leEq; Apply shift_leEq_plus'; Apply less_leEq; Assumption.
Cut ((b'[-]e)[<]x)+(x[<]b'); [Tauto | Apply cotrans_less_unfolded].
Apply shift_minus_less; Apply shift_less_plus'; Step (Zero::IR); Assumption.

Unfold b'.
RStep (b[-]a)[/]e[//](pos_ap_zero ?? He)[-]One.
Apply shift_minus_leEq.
Stepr (!nring IR (S (S (S n)))); Auto.

Intro.
Unfold b'.
RStepr (b[-]a)[/]e[//](pos_ap_zero ?? He)[-]One.
Apply shift_leEq_minus.
RStep ((!nring IR (S (S n)))[+]One)[-]Two.
Auto with arith.

Unfold b'.
Apply shift_leEq_minus; Apply shift_plus_leEq'.
Step One[*]e; Apply shift_mult_leEq with (pos_ap_zero ?? He).
Auto.
Apply leEq_transitive with (!nring IR (S (S (S n))))[-]Two.
Apply shift_leEq_minus; RStep (Three::IR); Apply nring_leEq; Auto with arith.
Auto with arith.
Qed.

(* Tex_Prose
Suprema and infima will be needed throughout; we define them here both for arbitrary subsets of \RR\ and for images of functions.
*)

(* Begin_Tex_Verb *)
Definition set_glb_IR [P:IR->CProp][a:IR] : CProp :=
  {(x:IR)(P x)->(a[<=]x)}*
  ((e:IR)((Zero[<]e)->{x:IR & (P x) & ((x[-]a)[<]e)})).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition set_lub_IR [P:IR->CProp][a:IR] : CProp :=
  {(x:IR)(P x)->(x[<=]a)}*
  ((e:IR)((Zero[<]e)->{x:IR & (P x) & ((a[-]x)[<]e)})).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition fun_glb_IR [F:PartIR][a:IR] : CProp :=
  {(x:IR)(Hx:(Pred F x))(a[<=](Part F x Hx))}*
  ((e:IR)((Zero[<]e)->{x:IR &
    {Hx:(Pred F x) & (Part F x Hx)[-]a[<]e}})).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition fun_lub_IR [F:PartIR][a:IR] : CProp :=
  {(x:IR)(Hx:(Pred F x))(Part F x Hx)[<=]a}*
  ((e:IR)((Zero[<]e)->{x:IR &
    {Hx:(Pred F x) & (a[-](Part F x Hx))[<]e}})).
(* End_Tex_Verb *)

Local aux_seq_lub [P:IR->CProp][H:(totally_bounded P)] :
  (k:nat)(Build_SubCSetoid IR [x:IR](P x)*{(y:IR)(P y)->(y[-]x)[<=]Two[*](one_div_succ k)}).
Intros P H; Elim H; Clear H; Intros non_empty H k.
Elim (H (one_div_succ k) (one_div_succ_pos IR k)).
Intros l Hl' Hl; Clear H.
Cut {y:IR & (member y l) | (((maxlist l)[-](one_div_succ k))[<=]y)}.
Intro; Inversion_clear H.
2: Apply maxlist_leEq_eps.
2: Inversion_clear non_empty.
2: Elim (Hl x).
2: Intros.
2: Exists x0.
2: Tauto.
2: Assumption.
2: Apply one_div_succ_pos.
Exists x; Split.
Apply Hl'; Assumption.
Intros y Hy.
Elim (Hl y Hy).
Intros z Hz Hz'.
RStep (y[-]z)[+](z[-]x).
RStepr (!one_div_succ IR k)[+](one_div_succ k).
Apply plus_resp_leEq_both.
Apply leEq_transitive with (AbsIR y[-]z).
Apply leEq_AbsIR.
Apply AbsSmall_imp_AbsIR; Assumption.
Apply shift_minus_leEq.
Apply leEq_transitive with (maxlist l).
Apply maxlist_greater; Assumption.
Apply shift_leEq_plus'.
Assumption.
Qed.

Local aux_seq_lub_prop : (P:IR->CProp)(H:(totally_bounded P))((k:nat)(P (scs_elem ?? (aux_seq_lub P H k))))*{(k:nat)(y:IR)(P y)->(y[-](scs_elem ?? (aux_seq_lub P H k)))[<=]Two[*](one_div_succ k)}.
Intros; Cut (k:nat)(P (scs_elem ?? (aux_seq_lub P H k)))*{(y:IR)(P y)->(y[-](scs_elem ?? (aux_seq_lub P H k)))[<=]Two[*](one_div_succ k)}.
Intro.
Split; Intro; Elim (H0 k); Intros.
Assumption.
Apply b; Assumption.
Intro; Apply scs_prf.
Qed.

(* Tex_Prose
The following are probably the most important results in this section.
*)

(* Begin_Tex_Verb *)
Lemma totally_bounded_has_lub :
  (P:IR->CProp)(totally_bounded P)->{z:IR & set_lub_IR P z}.
(* End_Tex_Verb *)
Intros P tot_bnd.
Red in tot_bnd.
Elim tot_bnd; Intros non_empty H.
Cut {sequence : (nat->IR) & ((k:nat)(P (sequence k))) | (k:nat)(x:IR)(P x)->(x[-](sequence k))[<=]Two[*](one_div_succ k)}.
Intros.
Elim H0.
Intros seq Hseq Hseq'.
Cut (Cauchy_prop seq).
Intro.
LetTac seq1 := (Build_CauchySeq IR seq H1).
Exists (Lim seq1).
Split; Intros.
Apply shift_leEq_rht.
Step [--](Zero::IR); RStepr [--](x[-](Lim seq1)).
Apply inv_resp_leEq.
LetTac seq2 := (Cauchy_const x).
Apply leEq_wdl with (Lim seq2)[-](Lim seq1).
2: Apply cg_minus_wd; [Unfold seq2; Apply eq_symmetric_unfolded; Apply Lim_const | Algebra].
Apply leEq_wdl with (Lim (Build_CauchySeq IR [n:nat](seq2 n)[-](seq1 n) (Cauchy_minus seq2 seq1))).
Apply leEq_transitive with (Lim twice_inv_seq).
Apply Lim_leEq_Lim; Intro; Simpl.
Apply Hseq'; Assumption.
Apply eq_imp_leEq.
Apply eq_symmetric_unfolded; Apply Limits_unique.
Red; Fold (SeqLimit twice_inv_seq Zero).
Apply twice_inv_seq_Lim.
Apply Lim_minus.
Cut (Cauchy_Lim_prop2 seq (Lim seq1)).
Intro H4; Red in H4.
Elim (H4 e[/]TwoNZ (pos_div_two ?? H2)); Clear H4.
Intros n Hn.
Exists (seq n).
Apply Hseq.
Apply leEq_less_trans with (AbsIR (Lim seq1)[-](seq n)).
Apply leEq_AbsIR.
Apply leEq_less_trans with e[/]TwoNZ.
Apply AbsSmall_imp_AbsIR.
Apply AbsSmall_minus; Simpl; Apply Hn.
Apply le_n.
Apply pos_div_two'; Auto.
Cut (Cauchy_Lim_prop2 seq1 (Lim seq1)); Intros.
Red; Red in H3.
Intros eps Heps; Elim (H3 eps Heps); Clear H3; Intros.
Exists x.
Intros m Hm; Elim (p m Hm); Clear p.
Intros.
Stepr (seq1 m)[-](Lim seq1).
Apply AbsIR_eq_AbsSmall; Assumption.
Red; Fold (SeqLimit seq1 (Lim seq1)).
Apply ax_Lim.
Apply crl_proof.
Red; Intros.
Elim (Archimedes One[/]e[//](pos_ap_zero ?? H1)).
Intros n Hn.
Exists (S (mult (2) n)); Intros.
Cut Zero[<](!nring IR n); Intros.
Apply AbsIR_eq_AbsSmall.
Apply leEq_transitive with [--](One[/](nring n)[//](pos_ap_zero ?? H3)).
Apply inv_resp_leEq.
Apply shift_div_leEq.
Assumption.
EApply shift_leEq_mult'; [Assumption | Apply Hn].
RStepr [--]((seq (S (mult (2) n)))[-](seq m)); Apply inv_resp_leEq.
Apply leEq_transitive with Two[*](!one_div_succ IR m).
Auto.
Apply leEq_transitive with (!one_div_succ IR n).
Unfold one_div_succ.
Unfold Snring.
RStep One[/]((nring (S m))[/]TwoNZ)[//](div_resp_ap_zero_rev ???? (nring_ap_zero IR (S m) (sym_not_eq nat (0) (S m) (O_S m)))).
Apply recip_resp_leEq.
Apply pos_nring_S.
Apply shift_leEq_div.
Apply pos_two.
Simpl; Fold (Two::IR).
RStep (Two[*](!nring IR n))[+]One[+]One.
Apply plus_resp_leEq.
Apply leEq_wdl with (!nring IR (S (mult (2) n))).
Apply nring_leEq; Assumption.
Step_final (!nring IR (mult (2) n))[+]One.
Unfold one_div_succ; Unfold Snring; Apply recip_resp_leEq.
Assumption.
Simpl; Apply less_leEq; Apply less_plusOne.
Apply leEq_transitive with Two[*](!one_div_succ IR (S (mult (2) n))).
Auto.
Apply less_leEq.
Apply less_leEq_trans with One[/](nring n)[//](pos_ap_zero ?? H3).
Step (!one_div_succ IR (S (mult (2) n)))[*]Two.
Unfold one_div_succ; Unfold Snring.
Apply shift_mult_less with (two_ap_zero IR).
Apply pos_two.
RStepr One[/](Two[*](nring n))[//](mult_resp_ap_zero ??? (two_ap_zero IR) (pos_ap_zero ?? H3)).
Apply recip_resp_less.
Step (Zero::IR)[*]Zero; Apply mult_resp_less_both; Try Apply leEq_reflexive; [Apply pos_two | Assumption].
Apply less_wdr with (Two[*](!nring IR n))[+]One[+]One.
Apply less_transitive_unfolded with (Two[*](!nring IR n))[+]One; Apply less_plusOne.
Step_rht (!nring IR (S (mult (2) n)))[+]One.
Step_final (!nring IR (mult (2) n))[+]One[+]One.
RStepr One[/](One[/]e[//](pos_ap_zero ?? H1))[//](div_resp_ap_zero_rev ???? (one_ap_zero IR)).
Apply recip_resp_leEq; [Apply recip_resp_pos; Assumption | Assumption].
EApply less_leEq_trans.
2: Apply Hn.
Apply recip_resp_pos; Assumption.
Elim (aux_seq_lub_prop P tot_bnd).
Exists [k:nat](scs_elem ?? (aux_seq_lub P tot_bnd k)); Auto.
Qed.

Local aux_seq_glb [P:IR->CProp][H:(totally_bounded P)] : (k:nat)(Build_SubCSetoid IR [x:IR](P x)*{(y:IR)(P y)->(x[-]y)[<=]Two[*](one_div_succ k)}).
Intros P H; Elim H; Clear H; Intros non_empty H k.
Elim (H (one_div_succ k) (one_div_succ_pos IR k)).
Intros l Hl' Hl; Clear H.
Cut {y:IR & (member y l) | y[<=]((minlist l)[+](one_div_succ k))}.
Intro; Inversion_clear H.
2: Apply minlist_leEq_eps.
2: Inversion_clear non_empty.
2: Elim (Hl x).
2: Intros.
2: Exists x0.
2: Tauto.
2: Assumption.
2: Apply one_div_succ_pos.
Exists x; Split.
Apply Hl'; Assumption.
Intros y Hy.
Elim (Hl y Hy).
Intros z Hz Hz'.
RStep (x[-]z)[+](z[-]y).
RStepr (!one_div_succ IR k)[+](one_div_succ k).
Apply plus_resp_leEq_both.
Apply shift_minus_leEq.
Apply shift_leEq_plus'.
Apply leEq_transitive with (minlist l).
Apply shift_minus_leEq.
Assumption.
Apply minlist_smaller; Assumption.
Apply leEq_transitive with (AbsIR y[-]z).
RStep [--](y[-]z); Apply inv_leEq_AbsIR.
Apply AbsSmall_imp_AbsIR; Assumption.
Qed.

Local aux_seq_glb_prop : (P:IR->CProp)(H:(totally_bounded P))((k:nat)(P (scs_elem ?? (aux_seq_glb P H k))))*{(k:nat)(y:IR)(P y)->((scs_elem ?? (aux_seq_glb P H k))[-]y)[<=]Two[*](one_div_succ k)}.
Intros; Cut (k:nat)(P (scs_elem ?? (aux_seq_glb P H k)))*{(y:IR)(P y)->((scs_elem ?? (aux_seq_glb P H k))[-]y)[<=]Two[*](one_div_succ k)}.
Intro.
Split; Intro; Elim (H0 k); Intros.
Assumption.
Apply b; Assumption.
Intro; Apply scs_prf.
Qed.

(* Begin_Tex_Verb *)
Lemma totally_bounded_has_glb :
  (P:IR->CProp)(totally_bounded P)->{z:IR & set_glb_IR P z}.
(* End_Tex_Verb *)
Intros P tot_bnd.
Red in tot_bnd.
Elim tot_bnd; Intros non_empty H.
Cut {sequence : (nat->IR) & ((k:nat)(P (sequence k))) | (k:nat)(x:IR)(P x)->((sequence k)[-]x)[<=]Two[*](one_div_succ k)}.
Intros.
Elim H0.
Clear H0; Intros seq H0 H1.
Cut (Cauchy_prop seq).
Intro.
LetTac seq1 := (Build_CauchySeq IR seq H2).
Exists (Lim seq1).
Split; Intros.
Apply shift_leEq_rht.
Step [--](Zero::IR); RStepr [--]((Lim seq1)[-]x).
Apply inv_resp_leEq.
LetTac seq2 := (Cauchy_const x).
Apply leEq_wdl with (Lim seq1)[-](Lim seq2).
2: Apply cg_minus_wd; [Algebra | Unfold seq2; Apply eq_symmetric_unfolded; Apply Lim_const].
Apply leEq_wdl with (Lim (Build_CauchySeq IR [n:nat](seq1 n)[-](seq2 n) (Cauchy_minus seq1 seq2))).
Apply leEq_transitive with (Lim twice_inv_seq).
Apply Lim_leEq_Lim; Intro.
Simpl.
Apply H1; Assumption.
Apply eq_imp_leEq.
Apply eq_symmetric_unfolded; Apply Limits_unique.
Red; Fold (SeqLimit twice_inv_seq Zero).
Apply twice_inv_seq_Lim.
Apply Lim_minus.
Cut (Cauchy_Lim_prop2 seq (Lim seq1)).
Intro; Red in H4.
Elim (H4 e[/]TwoNZ (pos_div_two ?? H3)); Clear H4.
Intros n Hn.
Exists (seq n).
Apply H0.
Apply leEq_less_trans with (AbsIR (Lim seq1)[-](seq n)).
RStep [--]((Lim seq1)[-](seq n)).
Apply inv_leEq_AbsIR.
Apply leEq_less_trans with e[/]TwoNZ.
Apply AbsSmall_imp_AbsIR.
Apply AbsSmall_minus; Simpl; Apply Hn.
Apply le_n.
Apply pos_div_two'; Auto.
Cut (Cauchy_Lim_prop2 seq1 (Lim seq1)); Intros.
Red; Red in H4.
Intros eps Heps; Elim (H4 eps Heps); Clear H4; Intros.
Exists x.
Intros m Hm; Elim (p m Hm); Clear p.
Intros.
Stepr (seq1 m)[-](Lim seq1).
Apply AbsIR_eq_AbsSmall; Assumption.
Red; Fold (SeqLimit seq1 (Lim seq1)).
Apply ax_Lim.
Apply crl_proof.
Red; Intros.
Elim (Archimedes One[/]e[//](pos_ap_zero ?? H2)).
Intros n Hn.
Exists (S (mult (2) n)); Intros.
Cut Zero[<](!nring IR n); Intros.
Apply AbsIR_eq_AbsSmall.
Apply leEq_transitive with [--](One[/](nring n)[//](pos_ap_zero ?? H4)).
Apply inv_resp_leEq.
Apply shift_div_leEq.
Assumption.
EApply shift_leEq_mult'; [Assumption | Apply Hn].
Apply less_leEq.
RStepr [--]((seq (S (mult (2) n)))[-](seq m)); Apply inv_resp_less.
Apply leEq_less_trans with Two[*](!one_div_succ IR (S (mult (2) n))).
Apply H1; Apply H0.
Step (!one_div_succ IR (S (mult (2) n)))[*]Two.
Unfold one_div_succ; Unfold Snring.
Apply shift_mult_less with (two_ap_zero IR).
Apply pos_two.
RStepr One[/](Two[*](nring n))[//](mult_resp_ap_zero ??? (two_ap_zero IR) (pos_ap_zero ?? H4)).
Apply recip_resp_less.
Step (Zero::IR)[*]Zero; Apply mult_resp_less_both; Try Apply leEq_reflexive; [Apply pos_two | Assumption].
Apply less_wdr with (Two[*](!nring IR n))[+]One[+]One.
Apply less_transitive_unfolded with (Two[*](!nring IR n))[+]One; Apply less_plusOne.
Step_rht (!nring IR (S (mult (2) n)))[+]One.
Step_final (!nring IR (mult (2) n))[+]One[+]One.
Apply leEq_transitive with Two[*](!one_div_succ IR m).
Apply H1; Apply H0.
Apply leEq_transitive with (!one_div_succ IR n).
Unfold one_div_succ.
Unfold Snring.
RStep One[/]((!nring IR (S m))[/]TwoNZ)[//](div_resp_ap_zero_rev ???? (nring_ap_zero IR (S m) (sym_not_eq nat (0) (S m) (O_S m)))).
Apply recip_resp_leEq.
Apply pos_nring_S.
Apply shift_leEq_div.
Apply pos_two.
Simpl; Fold (Two::IR).
RStep (Two[*](!nring IR n))[+]One[+]One.
Apply plus_resp_leEq.
Apply leEq_wdl with (!nring IR (S (mult (2) n))).
Apply nring_leEq; Assumption.
Step_final (!nring IR (mult (2) n))[+]One.
Unfold one_div_succ; Unfold Snring.
RStepr One[/](One[/]e[//](pos_ap_zero ?? H2))[//](div_resp_ap_zero_rev ???? (one_ap_zero IR)).
Apply recip_resp_leEq.
Apply recip_resp_pos; Assumption.
Apply leEq_transitive with (!nring IR n); [Assumption | Simpl; Apply less_leEq; Apply less_plusOne].
EApply less_leEq_trans.
2: Apply Hn.
Apply recip_resp_pos; Assumption.
Elim (aux_seq_glb_prop P tot_bnd).
Exists [k:nat](scs_elem ?? (aux_seq_glb P tot_bnd k)); Auto.
Qed.

End Totally_Bounded.

Section Compact.

(* Tex_Prose
\section{Compact}

In this section we dwell a bit farther into the definition of compact and explore some of its properties.

The following characterization of inclusion can be very useful:
*)

(* Begin_Tex_Verb *)
Lemma included_compact : (a,b,c,d:IR)(Hab,Hcd:?)
  (compact a b Hab c)->(compact a b Hab d)->
  (included (compact c d Hcd) (compact a b Hab)).
(* End_Tex_Verb *)
Repeat Intro.
Inversion_clear H.
Inversion_clear H0.
Inversion_clear H1.
Split.
Apply leEq_transitive with c; Auto.
Apply leEq_transitive with d; Auto.
Qed.

(* Tex_Prose
At several points in our future development of a theory we will need to partition a compact interval in subintervals of length smaller than some predefined value $\varepsilon$\footnote{Although this seems a consequence of every compact interval being totally bounded, it is in fact a stronger property.}.  In this section we perform that construction (requiring the endpoints of the interval to be distinct) and prove some of its good properties.

\begin{convention} Let \verb!a,b:IR!, \verb!Hab:a[<=]b! and denote by \verb!I! the compact interval $[a,b]$.  Also assume that $a<b$, and let \verb!e! be a positive real number.
\end{convention}
*)

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(compact a b Hab).

Hypothesis Hab':a[<]b.

Variable e:IR.
Hypothesis He:(Zero[<]e).

(* Tex_Prose
We start by finding a natural number $n$ such that \[\frac{b-a}n<\varepsilon\]
*)

(* Begin_Tex_Verb *)
Definition compact_nat :=
  (proj1_sig ?? (Archimedes (b[-]a)[/]?[//](pos_ap_zero ?? He))).
(* End_Tex_Verb *)

(* Tex_Prose
Obviously such an $n$ must be greater than zero.
*)

(* Begin_Tex_Verb *)
Lemma pos_compact_nat : (Zero[<](!nring IR compact_nat)).
(* End_Tex_Verb *)
Apply less_leEq_trans with ((b[-]a)[/]e[//](pos_ap_zero ?? He)).
RStepr (b[-]a)[*](One[/]e[//](pos_ap_zero ?? He)).
Apply mult_resp_pos.
Apply shift_less_minus; Step a; Assumption.
Apply recip_resp_pos; Assumption.
Unfold compact_nat; Apply proj2_sig.
Qed.

(* Tex_Prose
We now define a sequence on $n$ points in $[a,b]$ by \[x_i=\min(a,b)+i\times\frac{b-a}n\] and prove that all of its points are really in that interval.
*)

(* Begin_Tex_Verb *)
Definition compact_part [i:nat] : (le i compact_nat)->IR.
(* End_Tex_Verb *)
Intros.
Apply a[+](nring i)[*]((b[-]a)[/]?[//](pos_ap_zero ?? pos_compact_nat)).
Defined.

(* Begin_Tex_Verb *)
Lemma compact_part_hyp : (i:nat)(Hi:(le i compact_nat))
  (compact a b Hab (compact_part i Hi)).
(* End_Tex_Verb *)
Intros; Unfold compact_part.
Split.
Step a[+]Zero; Apply plus_resp_leEq_lft.
Step (Zero::IR)[*]Zero; Apply mult_resp_leEq_both; Try Apply leEq_reflexive.
Apply nring_nonneg.
Apply shift_leEq_div.
Apply pos_compact_nat.
Apply shift_leEq_minus; RStep a; Apply less_leEq; Assumption.
RStepr a[+](nring compact_nat)[*]((b[-]a)[/]?[//](pos_ap_zero ?? pos_compact_nat)).
Apply plus_resp_leEq_lft.
Apply mult_resp_leEq_rht; Try Apply nring_nonneg.
Apply nring_leEq; Assumption.
Apply shift_leEq_div.
Apply pos_compact_nat.
Apply shift_leEq_minus; RStep a; Apply less_leEq; Assumption.
Qed.

(* Tex_Prose
This sequence is strictly increasing and each two consecutive points are apart by less than $\varepsilon$.
*)

(* Begin_Tex_Verb *)
Lemma compact_less : (i:nat)
  (H1:(le i compact_nat))(H2:(le (S i) compact_nat))
  (Zero[<](compact_part ? H2)[-](compact_part ? H1)).
(* End_Tex_Verb *)
Intros.
Apply shift_less_minus; Step (compact_part ? H1).
Unfold compact_part.
Apply plus_resp_less_lft.
Apply mult_resp_less.
Simpl; Apply less_plusOne.
Apply div_resp_pos.
Apply pos_compact_nat.
Apply shift_less_minus; Step a; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma compact_leEq : (i:nat)
  (H1:(le i compact_nat))(H2:(le (S i) compact_nat))
  (compact_part ? H2)[-](compact_part ? H1)[<=]e.
(* End_Tex_Verb *)
Intros.
Unfold compact_part; Simpl.
RStep (b[-]a)[/]?[//](pos_ap_zero ?? pos_compact_nat).
Apply shift_div_leEq.
Apply pos_compact_nat.
Apply shift_leEq_mult' with (pos_ap_zero ?? He).
Assumption.
Exact (proj2_sig ?? (Archimedes ?)).
Qed.

(* Tex_Prose
When we proceed to integration, this lemma will also be useful:
*)

(* Begin_Tex_Verb *)
Lemma compact_partition_lemma : (n:nat)(Hn:~(O=n))
  (i:nat)(H:(le i n))(Compact Hab
    a[+](nring i)[*]((b[-]a)[/]?[//](nring_ap_zero' ? n Hn))).
(* End_Tex_Verb *)
Intros; Split.
Apply shift_leEq_plus'.
Step (Zero::IR).
Apply mult_resp_nonneg.
Apply nring_nonneg.
Apply shift_leEq_div.
Apply nring_pos; Apply neq_O_lt; Auto.
Apply shift_leEq_minus.
RStep a; Assumption.
Apply shift_plus_leEq'.
RStepr (nring n)[*]((b[-]a)[/]?[//](nring_ap_zero' ?? Hn)).
Step Zero[+](nring i)[*]((b[-]a)[/]?[//](nring_ap_zero' ?? Hn)).
Apply shift_plus_leEq.
RStepr ((nring n)[-](nring i))[*]((b[-]a)[/]?[//](nring_ap_zero' ?? Hn)).
Apply mult_resp_nonneg.
Apply shift_leEq_minus.
Step (!nring IR i).
Apply nring_leEq; Assumption.
Apply shift_leEq_div.
Apply nring_pos; Apply neq_O_lt; Auto.
Apply shift_leEq_minus.
RStep a; Assumption.
Qed.

(* Tex_Prose
The next lemma provides an upper bound for the distance between two points in an interval:
*)

(* Begin_Tex_Verb *)
Lemma compact_elements :
  (x,y:IR)(Compact Hab x)->(Compact Hab y)->
  (AbsIR x[-]y)[<=](AbsIR b[-]a).
(* End_Tex_Verb *)
Clear Hab' He e.
Do 2 Intro; Intros Hx Hy.
Apply leEq_wdr with b[-]a.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
2: Apply shift_leEq_minus; Step a; Auto.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply Abs_Max.
Inversion_clear Hx.
Inversion_clear Hy.
Unfold cg_minus; Apply plus_resp_leEq_both.
Apply Max_leEq; Auto.
Apply inv_resp_leEq.
Apply leEq_Min; Auto.
Qed.

Opaque Min Max.

(* Tex_Prose
The following is a variation on the previous lemma:
*)

(* Begin_Tex_Verb *)
Lemma compact_elements' : (c,d,Hcd:?)(x,y:IR)
  (Compact Hab x)->(compact c d Hcd y)->
  (AbsIR x[-]y)[<=](AbsIR (Max b d)[-](Min a c)).
(* End_Tex_Verb *)
Do 5 Intro; Intros Hx Hy.
EApply leEq_transitive.
2: Apply leEq_AbsIR.
Inversion_clear Hx.
Inversion_clear Hy.
Simpl; Unfold ABSIR; Apply Max_leEq.
Unfold cg_minus; Apply plus_resp_leEq_both.
Apply leEq_transitive with b; Auto; Apply lft_leEq_Max.
Apply inv_resp_leEq; Apply leEq_transitive with c; Auto; Apply Min_leEq_rht.
RStep y[-]x.
Unfold cg_minus; Apply plus_resp_leEq_both.
Apply leEq_transitive with d; Auto; Apply rht_leEq_Max.
Apply inv_resp_leEq; Apply leEq_transitive with a; Auto; Apply Min_leEq_lft.
Qed.

(* Tex_Prose
The following lemma is a bit more specific: it shows that we can also estimate the distance from the \emph{center} of a compact interval to any of its points.
*)

(* Begin_Tex_Verb *)
Lemma compact_bnd_AbsIR : (x,y,d,H:?)
  (compact x[-]d x[+]d H y)->
  (AbsIR x[-]y)[<=]d.
(* End_Tex_Verb *)
Intros.
Inversion_clear H0.
Simpl; Unfold ABSIR.
Apply Max_leEq.
Apply shift_minus_leEq; Apply shift_leEq_plus'; Auto.
RStep y[-]x.
Apply shift_minus_leEq.
Stepr x[+]d; Auto.
Qed.

(* Tex_Prose
Finally, two more useful lemmas to prove inclusion of compact intervals.  They will be necessary for the definition and proof of the elementary properties of the integral.
*)

(* Begin_Tex_Verb *)
Lemma included2_compact : (x,y:IR)(Hxy:?)
  (Compact Hab x)->(Compact Hab y)->
  (included (compact (Min x y) (Max x y) Hxy) (Compact Hab)).
(* End_Tex_Verb *)
Intros.
Inversion_clear H.
Inversion_clear H0.
Apply included_compact; Split.
Apply leEq_Min; Auto.
Apply leEq_transitive with y.
Apply Min_leEq_rht.
Auto.
Apply leEq_transitive with y.
Auto.
Apply rht_leEq_Max.
Apply Max_leEq; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma included3_compact : (x,y,z:IR)(Hxyz:?)
  (Compact Hab x)->(Compact Hab y)->(Compact Hab z)->
  (included
    (compact (Min (Min x y) z) (Max (Max x y) z) Hxyz)
    (Compact Hab)).
(* End_Tex_Verb *)
Intros.
Inversion_clear H.
Inversion_clear H0.
Inversion_clear H1.
Apply included_compact; Split.
Repeat Apply leEq_Min; Auto.
Apply leEq_transitive with z.
Apply Min_leEq_rht.
Auto.
Apply leEq_transitive with z.
Auto.
Apply rht_leEq_Max.
Repeat Apply Max_leEq; Auto.
Qed.

End Compact.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Require Import Classical.

Coq < Section Exercise_04.

Coq < Goal forall m n o:Prop, (m -> n) /\ (m -> o) -> (m -> (n /\ o)).
1 subgoal

  ============================
   forall m n o : Prop, (m -> n) /\ (m -> o) -> m -> n /\ o

Unnamed_thm < intros.
1 subgoal

  m : Prop
  n : Prop
  o : Prop
  H : (m -> n) /\ (m -> o)
  H0 : m
  ============================
   n /\ o

Unnamed_thm < apply conj.
2 subgoals

  m : Prop
  n : Prop
  o : Prop
  H : (m -> n) /\ (m -> o)
  H0 : m
  ============================
   n

subgoal 2 is:
 o

Unnamed_thm < elim H.
2 subgoals

  m : Prop
  n : Prop
  o : Prop
  H : (m -> n) /\ (m -> o)
  H0 : m
  ============================
   (m -> n) -> (m -> o) -> n

subgoal 2 is:
 o

Unnamed_thm < intro.
2 subgoals

  m : Prop
  n : Prop
  o : Prop
  H : (m -> n) /\ (m -> o)
  H0 : m
  H1 : m -> n
  ============================
   (m -> o) -> n

subgoal 2 is:
 o

Unnamed_thm < intro.
2 subgoals

  m : Prop
  n : Prop
  o : Prop
  H : (m -> n) /\ (m -> o)
  H0 : m
  H1 : m -> n
  H2 : m -> o
  ============================
   n

subgoal 2 is:
 o

Unnamed_thm < apply H1.
2 subgoals

  m : Prop
  n : Prop
  o : Prop
  H : (m -> n) /\ (m -> o)
  H0 : m
  H1 : m -> n
  H2 : m -> o
  ============================
   m

subgoal 2 is:
 o

Unnamed_thm < exact H0.
1 subgoal

  m : Prop
  n : Prop
  o : Prop
  H : (m -> n) /\ (m -> o)
  H0 : m
  ============================
   o

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
apply conj.
 elim H.
 intro.
 intro.
 apply H1.
 exact H0.

 tauto.

Unnamed_thm is defined

Coq <

*)

Require Import Classical.
Section Exercise_04.
Goal forall m n o:Prop, (m -> n) /\ (m -> o) -> (m -> (n /\ o)).
intros.
apply conj.
 elim H.
 intro.
 intro.
 apply H1.
 exact H0.
 tauto.
 Qed.


Require Import GeoCoq.Axioms.tarski_axioms.
Require Import GeoCoq.Axioms.gupta_inspired_variant_axioms.
Require Import GeoCoq.Tarski_dev.Ch05_bet_le.

Section Gupta_inspired_variant_of_Tarski_neutral_dimensionless_to_Tarski_neutral_dimensionless.

Context `{ITnEQD:Gupta_inspired_variant_of_Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma g2_1 : forall A B, CongG A B A B.
Proof.
intros A B.
apply cong_inner_transitivityG with B A;
apply cong_pseudo_reflexivityG; auto.
Qed.

Lemma g2_2 : forall A B C D,
  CongG A B C D -> CongG C D A B.
Proof.
intros A B C D HCong.
apply cong_inner_transitivityG with C D; auto; apply g2_1.
Qed.

Lemma cong_inner_transitivityT : forall A B C D E F,
  CongG A B C D -> CongG A B E F -> CongG C D E F.
Proof.
intros A B C D E F HCong1 HCong2.
apply cong_inner_transitivityG with A B; apply g2_2; auto.
Qed.

Lemma g2_3 : forall A B C D,
  CongG A B C D -> CongG B A C D.
Proof.
Proof.
intros A B C D HCong.
apply cong_inner_transitivityT with A B; auto.
apply cong_pseudo_reflexivityG.
Qed.

Lemma g2_4 : forall A B C D,
  CongG A B C D -> CongG A B D C.
Proof. intros A B C D HCong; apply g2_2; apply g2_3; apply g2_2; auto. Qed.

Lemma g2_5 : forall A B C D,
  CongG A B C D -> (A = B <-> C = D).
Proof.
intros A B C D HCong.
split; intro H; rewrite H in HCong;
[apply g2_2 in HCong|]; apply cong_identityG in HCong; auto.
Qed.

Lemma g2_6 : forall A B,
  BetG A B B /\ CongG B B A A.
Proof.
intros A B; destruct (segment_constructionG A B A A) as [C [HBet HCong]].
assert (B = C) by (apply g2_5 with A A; auto).
rewrite H in *; auto.
Qed.

Lemma g2_7 : forall A B C A' B' C',
  CongG A B A' B' -> CongG B C B' C' ->
  BetG A B C -> BetG A' B' C' ->
  CongG A C A' C'.
Proof.
intros A B C A' B' C' HCong1 HCong2 HBet1 HBet2.
elim (point_equality_decidabilityG A B); intro HDiff1; [rewrite HDiff1 in *; clear HDiff1|].

  {
  assert (HEq : A' = B') by (apply g2_5 with B B; try apply g2_2; auto).
  rewrite HEq; auto.
  }

  {
  elim (g2_6 A' A); intro HBet3; intro HCong3.
  apply g2_3; apply g2_4; apply five_segmentG with A A' B B'; auto.
  apply g2_3; apply g2_4; auto.
  }
Qed.

Lemma g2_8 : forall A B C D,
  BetG A B C -> BetG A B D -> CongG B C B D -> A <> B -> C = D.
Proof.
intros A B C D HBet1 HBet2 HCong HDiff.
assert (HEq : CongG C C C D).
  {
  apply five_segmentG with A A B B; auto; try apply g2_1.
  apply g2_7 with B B; auto; apply g2_1.
  }
apply g2_5 with C C; auto; apply g2_2; auto.
Qed.

Lemma g2_9 : forall A B C, BetG A B A -> BetG C A B.
Proof.
intros A B C HBet.
apply bet_inner_transitivityG with A; auto; apply g2_6.
Qed.

Lemma g2_10 : forall A B C, BetG A B A -> BetG C B A.
Proof. intros A B C HBet; do 2 apply g2_9; auto. Qed.

Lemma g2_11 : forall A B C,
  BetG A B A -> A <> B ->
  exists D, BetG C D C /\ BetG D C D /\ C <> D.
Proof.
intros A B C HBet1 HDiff1.
destruct (segment_constructionG C C A B) as [D [HBet2 HCong1]].
assert (HDiff2 : C <> D)
  by (intro; apply g2_5 in HCong1; apply HDiff1; apply HCong1; auto).
destruct (segment_constructionG C D B A) as [E [HBet3 HCong2]].
assert (HCong3 : CongG C E A A) by (apply g2_7 with D B; auto).
assert (HEq : C = E) by (apply g2_5 in HCong3; apply HCong3; auto).
rewrite HEq in *; clear HEq; exists D; do 2 (split; auto); apply g2_9; auto.
Qed.

Lemma g2_12 : forall A B C, BetG A B A -> BetG A B C.
Proof. intros A B C HBet; apply bet_symmetryG; apply g2_10; auto. Qed.

Lemma g2_13 : forall A B C, BetG A B A -> A <> B -> BetG C B C.
Proof.
intros A B C HBet1 HDiff.
destruct (segment_constructionG C B B C) as [D [HBet2 HCong1]].
assert (HEq : C = D) by (apply g2_8 with A B; try apply g2_2; try apply g2_12; auto).
rewrite HEq in *; auto.
Qed.

Lemma g2_14 : forall A B C D, BetG A B A -> A <> B -> BetG C D C /\ BetG D C D.
Proof.
intros A B C D HBet1 HDiff1.
split.

  {
  destruct (g2_11 A B D) as [E [HBet2 [HBet3 HDiff2]]]; auto.
  apply g2_13 with E; auto.
  }

  {
  destruct (g2_11 A B C) as [E [HBet2 [HBet3 HDiff2]]]; auto.
  apply g2_13 with E; auto.
  }
Qed.

Lemma g2_15 : forall A B C D E, BetG A B A -> A <> B -> BetG C D E.
Proof.
intros A B C D E HBet HDiff.
apply g2_9. destruct (g2_14 A B D E) as [HBet1 HBet2]; auto.
Qed.

Lemma g2_16 : forall A B C D E, ~ BetG C D E -> BetG A B A -> A = B.
Proof.
intros A B C D E HNBet HBet.
elim (point_equality_decidabilityG A B); intro HDiff; auto.
exfalso; apply HNBet; apply g2_15 with A B; auto.
Qed.

Lemma between_identityT : forall A B, BetG A B A -> A = B.
Proof.
intros A B; apply g2_16 with GPA GPB GPC; intro HNBet; apply lower_dimG; left; auto.
Qed.

Lemma cong_trivial_identityT : forall A B, CongG A A B B.
Proof. intros A B; destruct (g2_6 B A); auto. Qed.

Lemma l2_11T : forall A B C A' B' C',
  BetG A B C -> BetG A' B' C' ->
  CongG A B A' B' -> CongG B C B' C' ->
  CongG A C A' C'.
Proof.
intros A B C A' B' C' HBet1 HBet2 HCong1 HCong2.
elim (point_equality_decidabilityG A B); intro HDiff; [rewrite HDiff in *; clear HDiff|].

  {
  assert (HEq : A' = B') by (apply g2_5 with B B; try apply g2_2; auto).
  rewrite HEq in *; auto.
  }

  {
  apply g2_3; apply g2_4; apply five_segmentG with A A' B B'; auto;
  try apply cong_trivial_identityT; apply g2_3; apply g2_4; auto.
  }
Qed.

Lemma construction_uniquenessT : forall Q A B C X Y,
  Q <> A -> BetG Q A X -> CongG A X B C -> BetG Q A Y -> CongG A Y B C -> X = Y.
Proof.
intros Q A B C X Y HDiff HBet1 HCong1 HBet2 HCong2.
assert (HCong3 : CongG A X A Y) by (apply cong_inner_transitivityG with B C; auto).
assert (HCong4 : CongG Q X Q Y) by (apply l2_11T with A A; auto; apply g2_1).
assert (HCong5 : CongG X X X Y)
  by (apply five_segmentG with Q Q A A; auto; apply g2_1).
apply g2_5 with X X; try apply g2_2; auto.
Qed.

Lemma between_trivialT : forall A B, BetG A B B.
Proof. intros A B; destruct (g2_6 A B); auto. Qed.

Lemma bet_decG : forall A B C, BetG A B C \/ ~ BetG A B C.
Proof.
intros A B C.
destruct (segment_constructionG A B B C) as [D [HBet1 HCong]].
elim (point_equality_decidabilityG C D); intro HDiff1; [rewrite HDiff1 in *; auto|].
elim (point_equality_decidabilityG A B); intro HDiff2;
[rewrite HDiff2 in *; left; apply bet_symmetryG; apply between_trivialT|].
right; intro HBet2; apply HDiff1; apply construction_uniquenessT with A B B C;
auto; apply g2_1.
Qed.

Definition ColG A B C := BetG A B C \/ BetG B C A \/ BetG C A B.

Lemma col_decG : forall A B C, ColG A B C \/ ~ ColG A B C.
Proof.
intros A B C; unfold ColG; induction (bet_decG A B C); induction (bet_decG B C A);
induction (bet_decG C A B); tauto.
Qed.

Lemma inner_paschT : forall A B C P Q,
  BetG A P C -> BetG B Q C ->
  exists x, BetG P x B /\ BetG Q x A.
Proof.
intros A B C P Q HBet1 HBet2.
elim (point_equality_decidabilityG A P); intro HDiff1;
[rewrite HDiff1 in *; exists P; split;
 [apply bet_symmetryG|]; apply between_trivialT|].
elim (point_equality_decidabilityG P C); intro HDiff2;
[rewrite HDiff2 in *; exists Q; split; apply bet_symmetryG;
 try apply between_trivialT; auto|].
elim (point_equality_decidabilityG B Q); intro HDiff3;
[rewrite HDiff3 in *; exists Q; split;
 [|apply bet_symmetryG]; apply between_trivialT|].
elim (point_equality_decidabilityG Q C); intro HDiff4;
[rewrite HDiff4 in *; exists P; split; apply bet_symmetryG;
 try apply between_trivialT; auto|].
elim (col_decG A B C); intro HCol; [|apply inner_paschG with C; auto].
do 2 (try (elim HCol; clear HCol; intro HCol)); rename HCol into HBet3.

  {
  exists B; split; [apply between_trivialT|].
  apply bet_symmetryG; apply bet_inner_transitivityG with C; auto.
  }

  {
  exists C; split.

    {
    apply bet_symmetryG; apply bet_inner_transitivityG with A;
    auto; apply bet_symmetryG; auto.
    }

    {
    apply bet_symmetryG; apply bet_inner_transitivityG with B;
    apply bet_symmetryG; auto.
    }
  }

  {
  exists A; split; [|apply between_trivialT].
  apply bet_symmetryG; apply bet_inner_transitivityG with C;
  auto; apply bet_symmetryG; auto.
  }
Qed.

Global Instance GI_to_T : Tarski_neutral_dimensionless.
Proof.
exact
(Build_Tarski_neutral_dimensionless TpointG BetG CongG
   cong_pseudo_reflexivityG cong_inner_transitivityT cong_identityG
   segment_constructionG five_segmentG
   between_identityT inner_paschT
   GPA GPB GPC
   lower_dimG).
Defined.

Global Instance GI_to_T_PED :
  Tarski_neutral_dimensionless_with_decidable_point_equality GI_to_T.
Proof. split; exact point_equality_decidabilityG. Defined.

End Gupta_inspired_variant_of_Tarski_neutral_dimensionless_to_Tarski_neutral_dimensionless.

Section Gupta_inspired_variant_of_Tarski_2D_to_Tarski_2D.

Context `{IT2D:Gupta_inspired_variant_of_Tarski_2D}.

Lemma upper_dimT : forall A B C P Q,
  P <> Q -> CongG A P A Q -> CongG B P B Q -> CongG C P C Q ->
  (BetG A B C \/ BetG B C A \/ BetG C A B).
Proof.
intros A B C P Q HPQ HCong1 HCong2 HCong3.
elim (point_equality_decidabilityG A B); intro HAB; try (rewrite HAB in *; clear HAB);
elim (point_equality_decidabilityG A C); intro HAC; try (rewrite HAC in *; clear HAC);
elim (point_equality_decidabilityG B C); intro HBC; try (rewrite HBC in *; clear HBC).

  {
  left; apply between_trivialT.
  }

  {
  right; right; apply between_trivialT.
  }

  {
  left; apply between_trivialT.
  }

  {
  right; right; apply between_trivialT.
  }

  {
  left; apply between_trivialT.
  }

  {
  right; left; apply between_trivialT.
  }

  {
  left; apply between_trivialT.
  }

  {
  apply upper_dimG with P Q; auto.
  }
Qed.

Global Instance GI2D_to_T2D : Tarski_2D GI_to_T_PED.
Proof. split; exact upper_dimT. Defined.

End Gupta_inspired_variant_of_Tarski_2D_to_Tarski_2D.

Section Gupta_inspired_variant_of_Tarski_euclidean_to_Tarski_euclidean.

Context `{ITE:Gupta_inspired_variant_of_Tarski_euclidean}.

Lemma euclidT : forall A B C D T,
  Bet A D T -> Bet B D C -> A <> D ->
  exists X, exists Y, Bet A B X /\ Bet A C Y /\ Bet X T Y.
Proof.
assert (H := GI_to_T_PED).
intros A B C D T HBet1 HBet2 HDiff1.
elim (eq_dec_points B D); intro HDiff2;
[treat_equalities; exists T, C; Between|].
elim (eq_dec_points D C); intro HDiff3;
[treat_equalities; exists B, T; Between|].
elim (col_dec A B C); intro HCol; [|apply euclidG with D; auto].
clear HDiff2; clear HDiff3.
do 2 (try (elim HCol; clear HCol; intro HCol)); rename HCol into HBet3.

  {
  elim (eq_dec_points A B); intro HDiff2;
  [treat_equalities; exists T; exists C; Between|].
  elim (l5_2 A B C T); eBetween; intro HBet4.

    {
    elim (eq_dec_points B C); intro HDiff3;
    [treat_equalities; exists T; exists T; Between|].
    exists B; exists T; do 2 (split; Between); eBetween.
    }

    {
    elim (eq_dec_points B T); intro HDiff3;
    [treat_equalities; exists B; exists C; Between|].
    exists B; exists C; Between.
    }
  }

  {
  elim (eq_dec_points A C); intro HDiff2;
  [treat_equalities; exists B; exists T; Between|].
  elim (l5_2 A C B T); eBetween; intro HBet4.

    {
    elim (eq_dec_points B C); intro HDiff3;
    [treat_equalities; exists T; exists T; Between|].
    exists T; exists C; repeat (split; Between); eBetween.
    }

    {
    exists B; exists C; Between.
    }
  }

  {
  elim (l5_3 B A D C); Between; intro HBet4.

    {
    elim (eq_dec_points A B); intro HDiff2;
    [treat_equalities; exists T; exists C; Between|].
    elim (l5_2 B A C T); eBetween; intro HBet5.

      {
      exists B; exists T; Between.
      }

      {
      exists B; exists C; do 2 (split; Between).
      apply outer_transitivity_between2 with A; eBetween.
      intro; treat_equalities; intuition.
      }
    }

    {
    elim (l5_2 A D B T); Between; intro HBet5.

      {
      elim (eq_dec_points B D); intro HDiff2;
      [treat_equalities; exists T; exists C; Between|].
      exists T; exists C; do 2 (try split; Between); eBetween.
      }

      {
      exists B; exists C; do 2 (split; Between).
      apply outer_transitivity_between with A; eBetween;
      try (intro; treat_equalities; intuition).
      }
    }
  }
Qed.

Global Instance GI_euclidean_to_T_euclidean :
  Tarski_euclidean GI_to_T_PED.
Proof. split; exact euclidT. Defined.

End Gupta_inspired_variant_of_Tarski_euclidean_to_Tarski_euclidean.


(* Require part *)
Require Import ssreflect eqtype ssrbool.

(* some magic settings *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Checking *)

Check True.
Check False.
Check 3.
Check (3+4).
Check (3=5).
Check (3,4).
Check ((3=5)/\True).
Check nat -> Prop.
Check (3,3=5): nat * Prop.
Check (fun x:nat => x = 3).
Check (forall x:nat, x < 3 \/(exists y:nat, x = y + 3)).

Locate "_ && _".

About and.

Check (and True False).

Section simple_proofs.
(* Using only move apply  by *)

Variables P Q R S : Prop.

Lemma id_P : P -> P. Proof. done. Qed.

 Lemma id_PP : (P -> P) -> P -> P. Proof. done. Qed.

Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  move=> Hpq Hqr Hp.
  by apply/Hqr/Hpq.
Qed.

Lemma imp_perm : (P -> Q -> R) -> Q -> P -> R.
Proof.
  move=> Hpqr Hq Hp.
  by apply/Hpqr.
Qed.

Lemma ignore_Q : (P -> R) -> P -> Q -> R.
Proof.
  move=> Hpr Hp Hq.
  by apply/Hpr.
Qed.

Lemma delta_imp : (P -> P -> Q) -> P -> Q.
Proof.
  move=> Hppq Hp.
  by apply: Hppq.
Qed.

Lemma delta_impR : (P -> Q) -> P -> P -> Q.
Proof.
  move=> Hpq Hp1 Hp2.
  by apply: Hpq.
Qed.

Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> S) -> P -> S.
Proof.
  move=> Hpq Hpr Hqrs Hp.
  apply: Hqrs.
  - by apply: Hpq.
  - by apply: Hpr.
Qed.

Lemma weak_peirce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
  move=> H.
  apply: (H) => H0.
  apply: H0 => H1.
  by apply: H.
Qed.

Check diamond.
End simple_proofs.

Check diamond.

Section haveex.

Variables P Q R T : Prop.
Hypothesis H : P -> Q.
Hypothesis H0 : Q -> R.
Hypothesis H1 : (P -> R) -> T -> Q.
Hypothesis H2 : (P -> R) -> T.

Lemma Q0 : Q.
Proof.
  apply: H1.
  move=> Hp.
  apply: H0.
  by apply: H.
  apply: H2 => Hp.
  apply: H0.
  by apply: H.
Qed.

Lemma Q1 : Q.
Proof.
  have Hp: (P -> R) by move=> p; apply H0; apply H.
  have Ht: T by apply: H2.
  by apply H1.
Qed.

 Print Q0.

 Print Q1.

End haveex.

(* Using also case rewrite *)

Section boolex.

(*                  a && b == the boolean conjunction of a and b.             *)
(*                  a || b == then boolean disjunction of a and b.            *)
(*                 a ==> b == the boolean implication of b by a.              *)
(*                    ~~ a == the boolean negation of a.                      *)
(*                 a (+) b == the boolean exclusive or (or sum) of a and b.   *)

Theorem bool_xor_not_eq :
forall b1 b2,  (b1 (+) b2) = ~~(b1 == b2).
Proof.
  move=> b1 b2. case: b1.
    by case: b2.
  by case: b2.
Qed.

Theorem bool_not_and :
 forall b1 b2:bool,
   ~~ (b1 && b2) = ~~ b1 || ~~ b2.
Proof.
  by case.
Qed.

Theorem bool_not_not (b:bool): ~~ (~~ b) = b.
Proof.
  by case: b.
Qed.

Theorem bool_ex_middle : forall b:bool,  b || (~~ b) = true.
Proof.
  by case.
Qed.

Theorem bool_eq_reflect : forall b1 b2:bool, (b1 == b2) = true -> b1 = b2.
Proof.
  by move=> b1 b2; case b1; case b2.
Qed.

Theorem bool_eq_reflect2 : forall b1 b2:bool, b1 = b2 ->  (b1 == b2) = true.
Proof.
  by move => b1 b2 E; rewrite E eqxx.
Qed.

Theorem bool_not_or :
 forall b1 b2:bool,
   ~~ ( b1 || b2) =  (~~ b1) && (~~ b2).
Proof.
  by case; case.
Qed.

Theorem bool_distr :
 forall b1 b2 b3:bool,
    (b1 && b3) ||(b2 && b3) =  (b1 || b2) && b3.
Proof.
  by case; case; case.
Qed.

End boolex.

(* Mixing Prop and bool *)
(* Set Printing Coercions. *)
Section bool_prop.

Check (forall (a b : bool), a -> b).
Notation "x 'is_true'" := (is_true x) (at level 8).
Check (forall (a b : bool), a is_true ->  b is_true).
Lemma Andb_idl (a b : bool) : (b is_true -> a is_true ) -> a && b = b.
Proof.
  case: a; case: b; rewrite //=.
  by move=> H; rewrite H.
Qed.

Lemma Andb_idr (a b :bool) : (a is_true-> b is_true) -> a && b = a.
Proof.
  case: a; case: b; rewrite //=.
  by move=> H; rewrite H.
Qed.

Lemma Andb_id2l (a b c : bool) : (a -> b = c) -> a && b = a && c.
Proof.
  case: a; case: b; case: c; rewrite //=.
  by move=> H; rewrite H.
  by move=> H; rewrite H.
Qed.

End bool_prop.

Section more_prop.

Lemma and_imp_dist : forall A B C D:Prop,
                     (A -> B) /\ (C -> D) -> A /\ C -> B /\ D.
Proof.
  move=> A B C D H.
  case: H => Hab Hcd Hac.
  case: Hac => Ha Hc.
  split.
    by apply Hab.
  exact: Hcd.
Qed.

Lemma not_contrad : forall A : Prop, ~(A /\ ~A).
Proof.
  move=> A.
  move=> H.
  case: H => Ha Hna.
  done.
Qed.

Lemma or_and_not : forall A B : Prop, (A \/ B) /\ ~A -> B.
Proof.
  move=> A B H.
  case: H => Haob Hna.
  by case: Haob.
Qed.

Lemma or_imp_dist : forall A B C D:Prop,
                     (A -> B) \/ (C -> D) -> A /\ C -> B \/ D.
Proof.
  move=> A B C D H.
  case: H => H1 Hac.
    case: Hac => Ha Hc.
    left.
    by apply H1.
  right.
  case: Hac => Ha Hc.
  by apply: H1.
Qed.

  Section more_prop.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Bool.
Require Export fifo.

Unset Standard Proposition Elimination Names.

Section REDUCE.

Variable E : Set.

Variable f : E -> Z.

Fixpoint reduce (q : queue E) : Z :=
  match q with
  | empty => 0%Z
  | input d q' => (reduce q' + f d)%Z
  end.

Hypothesis positive_function : forall a : E, (f a > 0)%Z.

Lemma sum_positive :
 forall a b : Z, (a >= 0)%Z -> (b > 0)%Z -> (a + b >= 0)%Z.
Proof.
 intros a b H H0.
 omega.
Qed.

Lemma reduce_nil : reduce (empty E) = 0%Z.
Proof.
 simpl in |- *.
 trivial.
Qed.

Lemma reduce_null_fun :
 forall q : queue E, (forall d : E, f d = 0%Z) -> reduce q = 0%Z.
Proof.
  intro; elim q.
  intro; apply reduce_nil.
  intros; simpl in |- *.
  rewrite H.
  rewrite H0.
  auto.
  auto.
Qed.

Lemma reduce_positive : forall q : queue E, (reduce q >= 0)%Z.
Proof.
  intros q.
  elim q.
  simpl in |- *.
  omega.
  intros d q0 H.
  simpl in |- *.
  apply sum_positive.
  auto.
  exact (positive_function d).
Qed.

(* We prove the following general lemma.
   Then, we instantiate it to
    - q1=nil: this case corresponds to adding an element in
              a queue.
    - q2=nil: this case corresponds to removing an element
              from a queue. *)

Lemma reduce_append :
 forall (q1 : queue E) (d : E) (q2 : queue E),
 reduce (append E q1 (input E d q2)) = (reduce (append E q1 q2) + f d)%Z.

Proof.
  intro q1.
  elim q1.
  intros d q2.
  rewrite append_nil1.
  auto.

  intros d q H d0 q2.
  rewrite <- input_append.
  simpl in |- *.
  rewrite H.
  omega.
Qed.

(* And now two instantiations *)

Lemma reduce_append_nil1 :
 forall (d : E) (q2 : queue E), reduce (input E d q2) = (reduce q2 + f d)%Z.
Proof.
  intros d q2.
  rewrite <- (append_nil1 E (input E d q2)).
  pattern q2 at 2 in |- *.
  rewrite <- (append_nil1 E q2).
  apply reduce_append.
Qed.

Lemma reduce_append_nil2 :
 forall (q1 : queue E) (d : E),
 reduce (append E q1 (input E d (empty E))) = (reduce q1 + f d)%Z.
Proof.
  intros q1 d.
  pattern q1 at 2 in |- *.
  rewrite <- (append_nil2 E q1).
  apply reduce_append.
Qed.

Lemma reduce_append_nil2_symmetric :
 forall (q1 : queue E) (d : E),
 reduce q1 = (reduce (append E q1 (input E d (empty E))) - f d)%Z.
Proof.
  intros q1 d.
  rewrite (reduce_append_nil2 q1 d).
  omega.
Qed.

End REDUCE.

Section DISJOINT.

Variable E : Set.

(* functional or *)
Definition fun_or (pred1 pred2 : E -> bool) (a : E) := pred1 a || pred2 a.

(* functional sum *)
Definition fun_sum (f1 f2 : E -> Z) (a : E) := (f1 a + f2 a)%Z.

Definition fun_minus (f1 f2 : E -> Z) (a : E) := (f1 a - f2 a)%Z.

Variable f : E -> Z.

Lemma disjoint_reduce :
 forall (f1 f2 : E -> Z) (q : queue E),
 reduce E (fun_sum f1 f2) q = (reduce E f1 q + reduce E f2 q)%Z.
Proof.
  simple induction q.
  simpl in |- *.
  auto.

  intros d q0 H.
  simpl in |- *.
  rewrite H.
  unfold fun_sum in |- *.
  omega.
Qed.

Lemma disjoint_reduce3 :
 forall (f1 f2 : E -> Z) (q : queue E),
 reduce E (fun_minus f1 f2) q = (reduce E f1 q - reduce E f2 q)%Z.
Proof.
  simple induction q.
  simpl in |- *; auto.
  intros d q0 H.
  simpl in |- *.
  rewrite H.
  unfold fun_minus in |- *.
  omega.
Qed.

Lemma reduce_simpl :
 forall (f1 f2 : E -> Z) (q : queue E),
 (forall d : E, f1 d = f2 d) -> reduce E f1 q = reduce E f2 q.
Proof.
  simple induction q.
  simpl in |- *; auto.
  intros d q0 H H0.
  simpl in |- *.
  rewrite H.
  rewrite H0.
  auto.
  auto.
Qed.

End DISJOINT.

Section REDUCE_MORE.

Variable data : Set.
Hypothesis eq_data_dec : eq_dec data.

Variable f : data -> Z.

Lemma reduce_first_out :
 forall (q : queue data) (m : data),
 first data q = value data m ->
 reduce data f (first_out data q) = (reduce data f q - f m)%Z.

Proof.
  intros q m H.
  rewrite (reduce_append_nil2_symmetric data f (first_out data q) m).
  rewrite (append_first_out2 data m q).
  auto.
  auto.
Qed.

End REDUCE_MORE.

Section reduce_pos.

Variable E : Set.

Variable f : E -> Z.
Hypothesis positive_function : forall a : E, (f a >= 0)%Z.

Lemma reduce_positive_or_null : forall q : queue E, (reduce E f q >= 0)%Z.
Proof.
  intros q.
  elim q.
  simpl in |- *.
  omega.

  intros d q0 H.
  simpl in |- *.
  generalize (positive_function d).
  intro H0.
  omega.
Qed.

End reduce_pos.

Section reduce_strictly_pos.

Variable E : Set.

Variable f : E -> Z.
Hypothesis positive_function : forall a : E, (f a >= 0)%Z.

Hypothesis eq_E_dec : eq_dec E.

Lemma reduce_in_queue_strictly_positive :
 forall (x : E) (q : queue E),
 (f x > 0)%Z -> In_queue E x q -> (reduce E f q > 0)%Z.
Proof.
  simple induction q; simpl in |- *.
  intuition.

  intro d.
  case (eq_E_dec d x); intro.
  rewrite e; intros.
  generalize (reduce_positive_or_null E f positive_function q0); intro.
  clear H.
  omega.

  intros q0 H H0 H1.
  elim H1; intro.
  elim n; auto.

  generalize (positive_function d); intro.
  generalize (H H0 H2); intro.
  omega.
Qed.
End reduce_strictly_pos.

Section reduce_in_q_null.
Variable E : Set.

Variable f : E -> Z.

Hypothesis eq_E_dec : eq_dec E.

Lemma reduce_in_queue_null :
 forall q : queue E,
 (forall x : E, In_queue E x q -> f x = 0%Z) -> reduce E f q = 0%Z.
Proof.
  simple induction q; simpl in |- *.
  auto.

  intros d q0 H H0.
  rewrite H0.
  rewrite H.
  auto.
  intros x H1.
  apply H0.
  right; auto.
  left; auto.
Qed.

End reduce_in_q_null.


(* Exercise 20a *)

Require Import BenB.

Variables A B C D : Prop.

(* Double negation with an extra negation *)

Theorem exercise_020a : ~~~A -> ~A.
Proof.
imp_i first.
neg_e' (~A) second.
hyp second.
neg_i (~~A) third.
hyp first.
hyp second.
Qed.


Require Import Basics.
Require Import Types.
Require Import Diagrams.Graph.
Require Import Diagrams.Diagram.
Require Import Colimits.Colimit.
Require Import Colimits.Colimit_Sigma.
Require Import Diagrams.Graph.

(** * Colimit of product by a constant type *)

(** Given a diagram [D], one of his colimits [Q] and a type [A], one can consider the diagram of the products of the types of [D] and [A]. Then, a colimit of such a diagram is [A * Q]. *)

(** This is the constant case of the file [Colimit_Sigma] and we reuse its results. *)

Section ColimitProd.

  Context `{Funext} {G : Graph} (D : Diagram G) (A : Type).

  Definition prod_diagram : Diagram G.
  Proof.
    serapply Build_Diagram.
    - exact (fun i => A * (D i)).
    - simpl; intros i j f x.
      exact (fst x, D _f f (snd x)).
  Defined.

  Definition diagram_equiv_prod_sigma
    : sigma_diagram (fun _ : A => D) ~d~ prod_diagram.
  Proof.
    unshelve econstructor.
    - serapply Build_DiagramMap; cbn.
      + intro i; apply equiv_sigma_prod0.
      + reflexivity.
    - intro i; cbn.
      apply equiv_sigma_prod0.
  Defined.

  Lemma iscolimit_prod {Q : Type} (HQ : IsColimit D Q)
  : IsColimit prod_diagram (A * Q).
  Proof.
    eapply iscolimit_postcompose_equiv.
    - apply equiv_sigma_prod0.
    - eapply iscolimit_precompose_equiv.
      + symmetry; apply diagram_equiv_prod_sigma.
      + by apply iscolimit_sigma.
  Defined.

End ColimitProd.


Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Reals.Raxioms.
Require Import Coq.Reals.Rfunctions.
Require Import Coq.Lists.List.

Local Open Scope R.

Parameter floor : R -> R.

Axiom floor_correct : forall R1 R2, floor R1 = R2 ->
                              R2 <= R1 /\ exists (n : Z), (IZR n) = R2 /\ (forall n2, (IZR n2 < R1) -> (n2 <= n)%Z).

Definition decimal_only_positive (r : R) : R :=
 r - floor r.

Definition get_positions (speeds : list nat) (time : R) :=
  map (fun x=> decimal_only_positive ((INR x) * time)) speeds.

Definition is_lonely (i : nat) (positions : list R) : Prop :=
  forall i2, i <> i2  -> (i < length positions)%nat -> (i2 < length positions)%nat ->
        (R_dist (nth_default R0 positions i) (nth_default R0 positions i2) >= ( 1 / (INR (length positions)))).

Definition the_conjecture :=
  forall (speeds : list nat) (runner : nat),
    (runner < length speeds)%nat ->
    NoDup speeds ->
    exists (time : R), is_lonely runner (get_positions speeds time).


(* Exercise 120 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_120 : ~~(A /\ B) -> ~~B.
Proof.
imp_i a1.
neg_i (B) a2.
hyp a2.
con_e2 A.
neg_e' (~(A /\ B)) a3.
hyp a1.
hyp a3.
Qed.


Require Export Imp.

(* First we define syntax of the language *)

(* We could reuse aexp and bexp defined for Imp. *)

(* Redefine commands here. To distinguish them
   from Imp commands, we call them scom *)
(* You need to change it into an inductive definition *)
Inductive scom : Type :=
  | CSkip : scom
  | CAss : id -> aexp -> scom
  | CSeq : scom -> scom -> scom
  | CIf : bexp -> scom -> scom -> scom
  | CWhile : bexp -> scom -> scom
  | CMut : aexp -> aexp ->scom
  | CLook : id -> aexp -> scom
  | CCons : id -> aexp -> aexp -> scom
  | CDisp : aexp -> scom.

(* Program states, which is called sstate *)
Definition store := id -> nat.

(* if heap maps a natural number (address) to
   None, we say the address is not a valid address,
   or it is not in the domain of the heap *)
Definition heap := nat -> option nat.

(* Define an empty heap, which contains no memory cells *)
Definition emp_heap : heap := fun _ => None.

Definition in_dom (l: nat) (h: heap) : Prop :=
  exists n, h l = Some n.

Definition not_in_dom (l: nat) (h: heap) : Prop :=
  h l = None.

Theorem in_not_in_dec :
  forall l h, {in_dom l h} + {not_in_dom l h}.
  unfold in_dom, not_in_dom.
  intros; destruct (h l).
  left. exists n. reflexivity.
  right. reflexivity.
Qed.

(* h1 and h2 have disjoint domain *)
Definition disjoint (h1 h2: heap) : Prop :=
  forall l, ~(in_dom l h1 /\ in_dom l h2).

(* union of two heaps *)
Definition h_union (h1 h2: heap) : heap :=
  fun l =>
    if (in_not_in_dec l h1) then h1 l else h2 l.

(* h1 is a subset of h2 *)
Definition h_subset (h1 h2: heap) : Prop :=
  forall l n, h1 l = Some n -> h2 l = Some n.

Definition h_eq (h1 h2: heap) : Prop :=
  forall l, h1 l = h2 l.

(* store update *)
Definition st_update (s: store) (x: id) (n: nat) : store :=
  fun x' => if eq_id_dec x x' then n else s x'.

(* heap update *)
Definition h_update (h: heap) (l: nat) (n: nat) : heap :=
  fun l' => if eq_nat_dec l l' then Some n else h l'.

Definition sstate := (store * heap) %type.

Definition ss (st:sstate) := @fst _ _ st.
Definition sh (st:sstate) := @snd _ _ st.
(* since program may abort, we extend our state
   definition to add a special state Abt *)
Inductive ext_state : Type :=
  St:  sstate -> ext_state    (* normal state *)
| Abt: ext_state.             (* abort *)

(* Next we define the operational semantics *)

(* big-step semantics. You should change it into
   an inductive definition *)
Inductive big_step:
   scom * sstate -> ext_state -> Prop :=
| E_Skip : forall st, big_step (CSkip, st) (St st)
| E_Ass  : forall st x e s h n,
             s = ss st ->
             h = sh st ->
             n = aeval s e ->
             big_step (CAss x e, st)
                      (St (st_update s x n, h))
| E_Seq  : forall st st' st'' c1 c2,
             big_step (c1, st) (St st'') ->
             big_step (c2, st'') (St st') ->
             big_step (CSeq c1 c2, st) (St st')
| E_IfTrue : forall st st' b c1 c2 s,
               s = ss st ->
               beval s b = true ->
               big_step (c1, st) (St st') ->
               big_step (CIf b c1 c2, st) (St st')
| E_IfFalse : forall st st' b c1 c2 s,
                s = ss st ->
                beval s b = false ->
                big_step (c2, st) (St st') ->
                big_step (CIf b c1 c2, st) (St st')
| E_WhileEnd : forall st b c s,
                 s = ss st ->
                 beval s b = false ->
                 big_step (CWhile b c, st) (St st)
| E_WhileLoop : forall st st'' st' b c s,
                  s = ss st ->
                  beval s b = true ->
                  big_step (c, st) (St st'') ->
                  big_step (CWhile b c, st'') (St st') ->
                  big_step (CWhile b c, st) (St st')
| E_MutOk : forall st e1 e2 s h l n,
              s = ss st ->
              h = sh st ->
              l = (aeval s e1) ->
              n = (aeval s e2) ->
              in_dom l h ->
              big_step (CMut e1 e2, st)
                       (St (s, (h_update h l n)))
| E_MutAbt : forall st e1 e2 s h l n,
               s = ss st ->
               h = sh st ->
               l = (aeval s e1) ->
               n = (aeval s e2) ->
               not_in_dom l h ->
               big_step (CMut e1 e2, st) Abt
| E_LookOk : forall st x e s h l n,
               s = ss st ->
               h = sh st ->
               l = (aeval s e) ->
               in_dom l h ->
               h l = Some n ->
               big_step (CLook x e, st)
                        (St (st_update s x n, h))
| E_LookAbt : forall st x e s h l,
                s = ss st ->
                h = sh st ->
                l = (aeval s e) ->
                not_in_dom l h ->
                big_step (CLook x e, st) Abt
| E_Cons : forall st x e1 e2 s h l n1 n2,
             s = ss st ->
             h = sh st ->
             not_in_dom l h ->
             not_in_dom (l+1) h ->
             n1 = (aeval s e1) ->
             n2 = (aeval s e2) ->
             big_step (CCons x e1 e2, st)
                      (St (s,
                           h_update (h_update h l n1) (l+1) n2))
| E_DispOk : forall st e s h l,
               s = ss st ->
               h = sh st ->
               l = (aeval s e) ->
               in_dom l h ->
               big_step (CDisp e, st)
                        (St (s,
                             fun l' =>
                               if eq_nat_dec l l' then None else h l'))
| E_DispAbt : forall st e s h l,
                s = ss st ->
                h = sh st ->
                l = (aeval s e) ->
                not_in_dom l h ->
                big_step (CDisp e, st) Abt.

(* small-step semantics. Should be inductive too *)
Inductive small_step:
   scom * ext_state -> scom * ext_state -> Prop :=
| ES_Abt : forall c, small_step (c, Abt) (CSkip, Abt)
| ES_Skip : forall st, small_step (CSkip, St st) (CSkip, St st)
| ES_Ass  : forall st x e s h n,
              s = ss st ->
              h = sh st ->
              n = aeval s e ->
              small_step (CAss x e, St st)
                         (CSkip, St (st_update s x n, h))
| ES_SeqS  : forall st c2,
               small_step (CSeq CSkip c2, St st) (c2, St st)
| ES_Seq   : forall st st' c1 c1' c2,
               small_step (c1, St st) (c1', St st') ->
               small_step (CSeq c1 c2, St st) (CSeq c1' c2, St st')
| ES_IfTrue : forall st b c1 c2 s,
               s = ss st ->
               beval s b = true ->
               small_step (CIf b c1 c2, St st) (c1, St st)
| ES_IfFalse : forall st b c1 c2 s,
                s = ss st ->
                beval s b = false ->
                small_step (CIf b c1 c2, St st) (c2, St st)
| ES_WhileEnd : forall st b c s,
                 s = ss st ->
                 beval s b = false ->
                 small_step (CWhile b c, St st) (CSkip, St st)
| ES_WhileLoop : forall st b c s,
                  s = ss st ->
                  beval s b = true ->
                  small_step (CWhile b c, St st) (CSeq c (CWhile b c), St st)
| ES_MutOk : forall st e1 e2 s h l n,
              s = ss st ->
              h = sh st ->
              l = (aeval s e1) ->
              n = (aeval s e2) ->
              in_dom l h ->
              small_step (CMut e1 e2, St st)
                         (CSkip, St (s, (h_update h l n)))
| ES_MutAbt : forall st e1 e2 s h l n,
               s = ss st ->
               h = sh st ->
               l = (aeval s e1) ->
               n = (aeval s e2) ->
               not_in_dom l h ->
               small_step (CMut e1 e2, St st) (CMut e1 e2, Abt)
| ES_LookOk : forall st x e s h l n,
               s = ss st ->
               h = sh st ->
               l = (aeval s e) ->
               in_dom l h ->
               h l = Some n ->
               small_step (CLook x e, St st)
                          (CSkip, St (st_update s x n, h))
| ES_LookAbt : forall st x e s h l,
                s = ss st ->
                h = sh st ->
                l = (aeval s e) ->
                not_in_dom l h ->
                small_step (CLook x e, St st) (CLook x e, Abt)
| ES_Cons : forall st x e1 e2 s h l n1 n2,
             s = ss st ->
             h = sh st ->
             not_in_dom l h ->
             not_in_dom (l+1) h ->
             n1 = (aeval s e1) ->
             n2 = (aeval s e2) ->
             small_step (CCons x e1 e2, St st)
                        (CSkip, St (s,
                                    h_update (h_update h l n1) (l+1) n2))
| ES_DispOk : forall st e s h l,
               s = ss st ->
               h = sh st ->
               l = (aeval s e) ->
               in_dom l h ->
               small_step (CDisp e, St st)
                          (CSkip, St (s,
                                      fun l' =>
                                        if eq_nat_dec l l' then None else h l'))
| ES_DispAbt : forall st e s h l,
                s = ss st ->
                h = sh st ->
                l = (aeval s e) ->
                not_in_dom l h ->
                small_step (CDisp e, St st) (CDisp e, Abt).

(** Assertions **)
Definition sass := sstate -> Prop.

(* define semantics of assertion emp *)
Definition emp : sass :=
  fun st => match st with (s, h) => h_eq h emp_heap end.

Definition sig_heap (l: nat) (n: nat) : heap :=
  fun l' => if eq_nat_dec l l' then Some n else None.

(* assertion l |-> n *)
Definition pto (l: nat) (n: nat) : sass :=
  fun st => match st with (s, h) => h_eq h (sig_heap l n) end.
Notation "l '|->' n" := (pto l n) (at level 60).

(* p * q *)
Definition star (p q : sass) : sass :=
  fun st =>
    match st with (s, h) =>
                  exists h1, exists h2,
                               disjoint h1 h2 /\
                               h_eq h (h_union h1 h2) /\
                               p (s, h1) /\ q (s, h2)
    end.
Notation "p '**' q" := (star p q) (at level 70).

(* p --* q *)
Definition simp (p q: sass) : sass :=
  fun st =>
    match st with (s, h) =>
                  forall h',
                    disjoint h h' ->
                    p (s, h') ->
                    q (s, h_union h h')
    end.
Notation "p '--*' q" := (simp p q) (at level 80).

Definition pure (p: sass) : Prop :=
  forall s h h', p (s, h) <-> p (s, h').

Definition precise (p: sass) : Prop :=
  forall s h h' h'', h_subset h' h ->
                     h_subset h'' h ->
                     p (s, h') -> p (s, h'') ->
                     h_eq h' h''.

Definition intuitionistic (p: sass) : Prop :=
  forall s h h', h_subset h h' -> p (s, h) -> p (s, h').


Require Import XR_Rabs.
Require Import XR_Rcase_abs.
Require Import XR_Rle.
Require Import XR_Ropp_0.
Require Import XR_Rle_trans.
Require Import XR_Ropp_le_contravar.

Local Open Scope R_scope.

Lemma Rle_abs : forall x:R, x <= Rabs x.
Proof.
  intro x.
  unfold Rabs.
  destruct (Rcase_abs x) as [ h | h].
  {
    apply Rle_trans with R0.
    {
      left.
      exact h.
    }
    {
      rewrite <- Ropp_0.
      apply Ropp_le_contravar.
      left.
      exact h.
    }
  }
  {
    right.
    reflexivity.
  }
Qed.


Require Import List Bool ZArith Psatz String.
Import ListNotations.
Open Scope Z_scope.
Open Scope string_scope.
Opaque Z.mul.
Require Import Tactics.

(** * Un langage d'expressions *)

(** Le langage Imp est un langage impératif minimaliste. Les valeurs manipulées
dans ce langage sont des entiers [val := Z] et les variables sont
représentées par un identifiant (naturel). *)

Definition var := string.
Definition val := Z.
Definition var_eq := string_dec.

(** ** Les expressions, conditions et instructions *)
(** Les expressions [expr] peuvent être des constantes [Const n], des variables
[Var n], ou bien des opérations binaires ([Add], [Mul], [Sub] sur d'autres
expressions). *)

Inductive binop : Set :=
| Badd
| Bmul
| Bsub.

Inductive expr : Set :=
| Const (n: Z)
| Var (v: var)
| Binop (b: binop) (e1 e2: expr).

Definition envt := var -> val.

(** On définit un environnement par défaut [default_env] qui associe à toute
variable la valeur [0]. *)

Definition default_envt : envt := fun _ => 0.

(** [update_env e x z] crée un nouvel environnement à partir de [e] en associant
la valeur [z] à la variable [x]. *)

Definition update_env (e: envt) (x: var) (z: Z) :=
  fun y => if var_eq x y then z else e y.

Definition lookup_env (e: envt) (x: var) :=
  e x.

Lemma var_eq_true:
  forall {A: Type} (a b: A) v,
    (if var_eq v v then a else b) = a.
Proof.
  intros.
  destruct (var_eq v v); congruence.
Qed.

Lemma var_eq_false:
  forall {A: Type} (a b: A) v v' (neq: v <> v'),
    (if var_eq v v' then a else b) = b.
Proof.
  intros.
  destruct (var_eq v v'); try congruence.
Qed.

Lemma lookup_update_same:
  forall (e: envt) x z,
    lookup_env (update_env e x z) x = z.
Proof.
  unfold lookup_env, update_env. simpl. intros.
  rewrite var_eq_true. auto.
Qed.

Lemma lookup_update_other:
  forall (e: envt) x y z,
    x <> y ->
    lookup_env (update_env e x z) y = lookup_env e y.
Proof.
  unfold lookup_env, update_env. simpl. intros.
  rewrite var_eq_false; auto.
Qed.

Lemma lookup_update_eq:
  forall (e: envt) x y z,
    lookup_env (update_env e x z) y = if var_eq x y then z else lookup_env e y.
Proof.
  intros.
  destr.
  subst. apply lookup_update_same.
  apply lookup_update_other. auto.
Qed.

(** La fonction d'évaluation des expressions [eval_expr] évalue récursivement en
suivant la structure des expressions. *)

Definition eval_binop (b: binop) (z1 z2 : Z) : Z :=
  match b with
  | Badd =>  (z1 + z2)
  | Bmul =>  (z1 * z2)
  | Bsub =>  (z1 - z2)
  end.

Fixpoint eval_expr (env: envt) (e: expr) : Z :=
  match e with
  | Const n => n
  | Var v => lookup_env env v
  | Binop b e1 e2 => eval_binop b (eval_expr env e1) (eval_expr env e2)
  end.

Inductive cond : Set :=
| Eq (e1 e2: expr)
| Lt (e1 e2: expr)
| And (c1 c2: cond)
| Or (c1 c2: cond)
| Not (c: cond).

Fixpoint eval_cond (env: envt) (c: cond) : bool :=
  match c with
  | Eq e1 e2 => Z.eqb (eval_expr env e1) (eval_expr env e2)
  | Lt e1 e2 => Z.ltb (eval_expr env e1) (eval_expr env e2)
  | And c1 c2 => eval_cond env c1 && eval_cond env c2
  | Or c1 c2 => eval_cond env c1 || eval_cond env c2
  | Not c => negb (eval_cond env c)
  end.

(* On étend le type des instructions du langage While avec une instruction
[Output e] qui affiche la valeur de [e]. *)

Inductive stmt  :=
| Skip
| Assign (v: var) (e: expr)
| Seq (s1 s2: stmt)
| If (c: cond) (s1 s2: stmt)
| While (c: cond) (s: stmt)
| Output (e: expr)
.

(* La sémantique à grands pas est adaptée pour inclure une trace de type [list
Z] : la liste des entiers que l'on a affichés durant l'exécution du programme.
 *)

Inductive bigstep : envt -> stmt -> envt -> list Z -> Prop :=
| bigstep_skip: forall e, bigstep e Skip e []
| bigstep_assign: forall x e env, bigstep env (Assign x e) (update_env env x (eval_expr env e)) []
| bigstep_seq: forall env1 env2 env3 i1 i2 t1 t2,
    bigstep env1 i1 env2 t1 ->
    bigstep env2 i2 env3 t2 ->
    bigstep env1 (Seq i1 i2) env3 (t1 ++ t2)
| bigstep_if_true:
    forall env c i1 i2 env' t,
      eval_cond env c = true ->
      bigstep env i1 env' t ->
      bigstep env (If c i1 i2) env' t
| bigstep_if_false:
    forall env c i1 i2 env' t,
      eval_cond env c = false ->
      bigstep env i2 env' t ->
      bigstep env (If c i1 i2) env' t
| bigstep_while_true:
    forall env c i env' env'' t1 t2,
      eval_cond env c = true ->
      bigstep env i env' t1 ->
      bigstep env' (While c i) env'' t2 ->
      bigstep env (While c i) env'' (t1 ++ t2)
| bigstep_while_false:
    forall env c i,
      eval_cond env c = false ->
      bigstep env (While c i) env []
| bigstep_output:
    forall env e,
      bigstep env (Output e) env [eval_expr env e].