From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable ltA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable deftriangle_1 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_2 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable defcollinear_3 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_4 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_5 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_6 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_7 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_8 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_9 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_inequalitysymmetric_10 : (forall A B : Universe, (A <> B -> B <> A)).
Variable proposition_10_11 : (forall A B : Universe, (exists X : Universe, (A <> B -> (betS_ A X B /\ cong_ X A X B)))).
Variable lemma_extension_12 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable lemma_betweennotequal_13 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_collinearorder_14 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_collinear4_15 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable proposition_15_16 : (forall A B C D E : Universe, ((betS_ A E B /\ (betS_ C E D /\ ~(col_ A E C))) -> (congA_ A E C D E B /\ congA_ C E B A E D))).
Variable lemma_ABCequalsCBA_17 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_equalanglestransitive_18 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_doublereverse_19 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).
Variable lemma_congruenceflip_20 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable proposition_04_21 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ congA_ B A C Xb Xa Xc)) -> (cong_ B C Xb Xc /\ (congA_ A B C Xa Xb Xc /\ congA_ A C B Xa Xc Xb)))).
Variable lemma_ray4_1_22 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_23 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_24 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_angledistinct_25 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> (A <> B /\ (B <> C /\ (A <> C /\ (Xa <> Xb /\ (Xb <> Xc /\ Xa <> Xc))))))).
Variable lemma_equalanglesreflexive_26 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C A B C)).
Variable lemma_equalangleshelper_27 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable axiom_betweennesssymmetry_28 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable postulate_Pasch_inner_29 : (forall A B C P Q : Universe, (exists X : Universe, ((betS_ A P C /\ (betS_ B Q C /\ ~(col_ A C B))) -> (betS_ A X Q /\ betS_ B X P)))).
Variable lemma_ray5_30 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable defanglelessthan_31 : (forall A B C D E F : Universe, (exists U X V : Universe, (ltA_ A B C D E F -> (betS_ U X V /\ (out_ E D U /\ (out_ E F V /\ congA_ A B C D E X)))))).
Variable defanglelessthan2_32 : (forall A B C D E F U X V : Universe, ((betS_ U X V /\ (out_ E D U /\ (out_ E F V /\ congA_ A B C D E X))) -> ltA_ A B C D E F)).
Variable lemma_equalanglesNC_33 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> ~(col_ Xa Xb Xc))).
Variable lemma_angleorderrespectscongruence_34 : (forall A B C D E F P Q R : Universe, ((ltA_ A B C D E F /\ congA_ P Q R D E F) -> ltA_ A B C P Q R)).
Variable lemma_equalanglessymmetric_35 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_angleorderrespectscongruence2_36 : (forall A B C D E F Xa Xb Xc : Universe, ((ltA_ A B C D E F /\ congA_ Xa Xb Xc A B C) -> ltA_ Xa Xb Xc D E F)).

Theorem proposition_16_37 : (forall A B C D : Universe, ((triangle_ A B C /\ betS_ B C D) -> (ltA_ B A C A C D /\ ltA_ C B A A C D))).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import FP.Data.Ascii.
Require Import FP.Data.AsciiRelations.
Require Import FP.Data.Bool.
Require Import FP.Data.Function.
Require Import FP.Data.List.
Require Import FP.Data.ListStructures.
Require Import FP.Data.N.
Require Import FP.Data.NRelations.
Require Import FP.Structures.Convertible.
Require Import FP.Structures.EqDec.
Require Import FP.Structures.Functor.
Require Import FP.Structures.Functor.
Require Import FP.Structures.Monoid.
Require Import FP.Structures.Ord.
Require Import FP.Structures.Show.

Import MonoidNotation.
Import BoolNotation.
Import FunctionNotation.
Import ListNotation.
Import OrdNotation.
Import CharNotation.
Import NNotation.

Instance ascii_N_Convertible : Convertible ascii N :=
  { convert := Ascii.N_of_ascii }.
Instance N_ascii_Convertible : Convertible N ascii :=
  { convert := Ascii.ascii_of_N }.

Section predicates.
  Definition is_alpha (c:ascii) : bool :=
    let n := convert_to N c in
    65 <=! n <=! 90 || 97 <=! n <=! 122.

  Definition is_numeric (c:ascii) : bool :=
    let n := convert_to N c in
    48 <=! n <=! 57.

  Definition is_whitespace : ascii -> bool :=
    foldl orf (const false) $ fmap eq_dec $
      [ space ; newline ; tab ; carriage_return ].
End predicates.

Section Show.
  Section ascii_show.
    Variable (R:Type) (SR:ShowResult R).

    Definition ascii_show (c:ascii) : R :=
         raw_char "'"%char
      ** raw_char c
      ** raw_char "'"%char.
  End ascii_show.

  Global Instance ascii_Show : Show ascii := { show := ascii_show }.
End Show.


(** * The univalent category of algebras over a signature. *)
(** Gianluca Amato,  Marco Maggesi, Cosimo Perini Brogi 2019-2021 *)
(**
We use display categories to define the category of algebras and prove its univalence.
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.Univalence.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.SIP.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.limits.initial.

Require Import UniMath.Algebra.Universal.TermAlgebras.

Section Algebras.

  Local Open Scope sorted_scope.

  Context (σ : signature).

  Definition shSet_precategory_ob_mor : precategory_ob_mor.
  Proof.
    use make_precategory_ob_mor.
    - exact (shSet (sorts σ)).
    - intros F G. exact (F s→ G).
  Defined.

  Definition shSet_precategory_data : precategory_data.
  Proof.
    use make_precategory_data.
    - exact shSet_precategory_ob_mor.
    - intro C. simpl. apply idsfun.
    - simpl. intros F G H. intros f g. exact (g s∘ f).
  Defined.

  Definition is_precategory_shSet_precategory_data : is_precategory shSet_precategory_data.
  Proof.
    repeat split.
  Defined.

  Definition shSet_precategory : precategory.
  Proof.
    use make_precategory.
    - apply shSet_precategory_data.
    - apply is_precategory_shSet_precategory_data.
  Defined.

  Definition has_homsets_shSet_precategory : has_homsets shSet_precategory.
  Proof.
    intros F G. simpl.
    use isaset_set_sfun_space.
  Defined.

  Definition shSet_category : category := (shSet_precategory ,, has_homsets_shSet_precategory).

  Definition algebras_disp : disp_cat shSet_category.
  Proof.
    use disp_cat_from_SIP_data. simpl.
    - intro A. exact (∏ nm: names σ, A⋆ (arity nm) → A (sort nm)).
    - simpl. intros A B asA asB f. exact (@ishom σ (make_algebra A asA) (make_algebra B asB) f).
    - simpl. intros A B asA asB f opA opB.
      apply isapropishom.
    - cbn. intros A asA. apply ishomid.
    - cbn. intros A B C opA opB opC. intros f g ishomf ishomg.
      exact (ishomcomp (make_hom ishomf) (make_hom ishomg)).
  Defined.

  Lemma is_univalent_algebras_disp : is_univalent_disp algebras_disp.
  Proof.
    use is_univalent_disp_from_SIP_data.
    - intro A. cbn. use impred_isaset. intro nm. cbn.
      use isaset_set_fun_space.
    - cbn. intros A op1 op2 ishomid1 _. use funextsec. intro nm. use funextfun. intro vec.
      unfold ishom in *. cbn in *. set (H1:= ishomid1 nm vec).
      rewrite staridfun in H1. apply H1.
  Qed.

  Local Open Scope cat.

  (**
  Here follows the proof that [shSet_category] is univalent. The proof is obtained by
  following the example of the proof of univalence of the functor category.
  *)

  Lemma shSet_iso_fiber {A B : shSet_category} (i : z_iso A B): ∏ s, @z_iso HSET (A s) (B s).
  Proof.
    intro s.
    induction i as [i [i' [p q]]].
    simpl in *.
    use make_z_iso.
    - exact (i s).
    - exact (i' s).
    - split.
      + exact (eqtohomot p s).
      + exact (eqtohomot q s).
  Defined.

  Definition shSet_eq_from_shSet_z_iso (F G : shSet_category) (i : z_iso F G) : F = G.
  Proof.
    apply funextsec.
    intro s.
    apply (isotoid HSET is_univalent_HSET).
    apply shSet_iso_fiber.
    assumption.
  Defined.

  Lemma idtoiso_shSet_category_compute_pointwise {F G : shSet_category} (p : F = G) (s: sorts σ)
    : shSet_iso_fiber (idtoiso p) s = idtoiso(C:=HSET) (toforallpaths (λ _ , hSet) F G p s).
  Proof.
    induction p.
    apply z_iso_eq. apply idpath.
  Qed.

  Lemma shSet_eq_from_shSet_z_iso_idtoiso  (F G : shSet_category) (p : F = G)
    : shSet_eq_from_shSet_z_iso F G (idtoiso p) = p.
  Proof.
    unfold shSet_eq_from_shSet_z_iso.
    apply (invmaponpathsweq (weqtoforallpaths _ _ _ )).
    simpl (pr1weq (weqtoforallpaths (λ _ : sorts σ, hSet) F G)).
    rewrite (toforallpaths_funextsec).
    apply funextsec.
    intro a.
    rewrite idtoiso_shSet_category_compute_pointwise.
    rewrite isotoid_idtoiso.
    apply idpath.
  Defined.

  Lemma idtoiso_shSet_eq_from_shSet_z_iso (F G : shSet_category) (i : z_iso F G)
    : idtoiso (shSet_eq_from_shSet_z_iso F G i) = i.
  Proof.
    apply z_iso_eq.
    apply funextsec.
    intro s.
    unfold shSet_eq_from_shSet_z_iso.
    assert (H' := idtoiso_shSet_category_compute_pointwise (shSet_eq_from_shSet_z_iso F G i) s).
    simpl in *.
    assert (H2 := maponpaths (@pr1 _ _ ) H').
    simpl in H2.
    etrans.
    { apply H2. }
    intermediate_path (pr1 (idtoiso (isotoid HSET is_univalent_HSET (shSet_iso_fiber i s)))).
    - apply maponpaths.
      apply maponpaths.
      unfold shSet_eq_from_shSet_z_iso.
      rewrite toforallpaths_funextsec.
      apply idpath.
    - rewrite idtoiso_isotoid.
      apply idpath.
  Qed.

  Definition is_univalent_shSet_category : is_univalent shSet_category.
  Proof.
    intros F G.
    apply (isweq_iso _ (shSet_eq_from_shSet_z_iso F G)).
    - apply shSet_eq_from_shSet_z_iso_idtoiso.
    - apply idtoiso_shSet_eq_from_shSet_z_iso.
  Defined.

  Definition category_algebras : category := total_category algebras_disp.

  Lemma is_univalent_category_algebras : is_univalent category_algebras.
  Proof.
    exact (@is_univalent_total_category shSet_category algebras_disp is_univalent_shSet_category is_univalent_algebras_disp).
  Qed.

  Lemma isinitial_termalgebra : Initial (category_algebras).
  Proof.
    exact (term_algebra σ ,, iscontrhomsfromgterm).
  Defined.

End Algebras.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e256m4294968273_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(** * Lin_trafos.v *)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export mult_by_scalars.
Require Export sums.

(** - Linear transformations (very initial stuff only) *)

Variable F : field.
Variable V W : vectorspace F.

Record lin_trafo_on (T : Map V W) : Type :=
  {preserve_plus : forall x y : V, T (x +' y) =' T x +' T y in _;
   preserve_mX : forall (c : F) (x : V), T (c mX x) =' c mX T x in _}.

(** %\tocdef{lin\_trafo}% *)
Record lin_trafo : Type :=
  {lin_trafo_map :> Map V W; lin_trafo_on_def : lin_trafo_on lin_trafo_map}.

Fact zerovec_preserving : forall T : lin_trafo, T (zero V) =' (zero W) in _.
intro.
destruct T.
rename lin_trafo_map0 into T.
destruct lin_trafo_on_def0.
simpl in |- *.
apply Trans with (T ((zero V) +' (min (zero V)))); auto with algebra.
apply Trans with (T (zero V) +' T (min (zero V))); auto with algebra.
apply Trans with (T (zero V) +' (min T (zero V))); auto with algebra.
apply SGROUP_comp; auto with algebra.
apply Trans with (T (min one mX (zero V))); auto with algebra.
apply Trans with (T ((min one) mX (zero V))); auto with algebra.
apply Trans with (min one mX T (zero V)); auto with algebra.
apply Trans with ((min one) mX T (zero V)); auto with algebra.
Qed.

Hint Resolve zerovec_preserving: algebra.

Fact lin_trafo_equation :
 forall T : Map V W,
 lin_trafo_on T ->
 forall (a : F) (x y : V), T (a mX x +' y) =' a mX T x +' T y in _.
intros T H a x y.
destruct H.
apply Trans with (T (a mX x) +' T y); auto with algebra.
Qed.

Hint Resolve lin_trafo_equation: algebra.

Fact lin_trafo_equation' :
 forall T : Map V W,
 (forall (a : F) (x y : V), T (a mX x +' y) =' a mX T x +' T y in _) ->
 lin_trafo_on T.
intros.
constructor.
intros.
apply Trans with (one mX T x +' T y); auto with algebra.
apply Trans with (T (one mX x +' y)); auto with algebra.
intros.
apply Trans with (c mX T x +' (zero W)); auto with algebra.
apply Trans with (c mX T x +' T (zero V)); auto with algebra.
apply Trans with (T (c mX x +' (zero V))); auto with algebra.
apply SGROUP_comp; auto with algebra.
apply Trans with (T ((min one) mX (zero V) +' (zero V))); auto with algebra.
apply Ap_comp; auto with algebra.
apply Trans with ((min one mX (zero V)) +' (zero V)); auto with algebra.
apply Trans with ((min (zero V)) +' (zero V)); auto with algebra.
apply Trans with ((min one) mX T (zero V) +' T (zero V)); auto with algebra.
apply Trans with ((min one mX T (zero V)) +' T (zero V)); auto with algebra.
apply Trans with ((min T (zero V)) +' T (zero V)); auto with algebra.
Qed.

Hint Resolve lin_trafo_equation': algebra.

Fact lin_trafo_of_lin_comb :
 forall T : Map V W,
 lin_trafo_on T ->
 forall (n : Nat) (a : seq n F) (v : seq n V),
 T (sum (mult_by_scalars a v)) =' sum (mult_by_scalars a (comp_map_map T v))
 in _.
intros T H; intros.
induction n.
simpl in |- *.
apply Trans with (Build_lin_trafo H (zero V)); auto with algebra.
apply Trans with (T (sum (mult_by_scalars (hdtl a) (hdtl v)))).
apply Ap_comp; auto with algebra.
apply
 Trans
  with (T (sum (head a mX head v;; mult_by_scalars (Seqtl a) (Seqtl v)))).
unfold hdtl in |- *.
apply Ap_comp; auto with algebra.
apply
 Trans
  with (T (head a mX head v +' sum (mult_by_scalars (Seqtl a) (Seqtl v))));
 auto with algebra.
destruct H.
apply
 Trans
  with
    (T (head a mX head v) +' T (sum (mult_by_scalars (Seqtl a) (Seqtl v))));
 auto with algebra.
apply Trans with (sum (mult_by_scalars (hdtl a) (hdtl (comp_map_map T v))));
 auto with algebra.
unfold hdtl in |- *.
apply
 Trans
  with
    (sum
       (uncurry (MODULE_comp (R:=F) (Mod:=W))
          (couple (head a) (head (comp_map_map T v)));;
        pointwise (uncurry (MODULE_comp (R:=F) (Mod:=W)))
          (Seqtl a) (Seqtl (comp_map_map T v)))).
apply
 Trans
  with
    (head a mX head (comp_map_map T v) +'
     sum
       (pointwise (uncurry (MODULE_comp (R:=F) (Mod:=W)))
          (Seqtl a) (Seqtl (comp_map_map T v)))); auto with algebra.
apply SGROUP_comp.
apply Trans with (head a mX T (head v)); auto with algebra.
fold (mult_by_scalars (Seqtl a) (Seqtl (comp_map_map T v))) in |- *.
apply Trans with (sum (mult_by_scalars (Seqtl a) (comp_map_map T (Seqtl v))));
 auto with algebra.
apply sum_comp; auto with algebra.
apply toMap.
apply mult_by_scalars_comp; auto with algebra.
intro.
simpl in |- *.
destruct x.
unfold comp_map_fun in |- *.
apply Ap_comp; auto with algebra.
apply sum_comp; auto with algebra.
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Basic operations on floats: alignment, addition, multiplication *)

From Coq Require Import ZArith Reals Lia.

Require Import Zaux Raux Defs Float_prop.

Set Implicit Arguments.
Set Strongly Strict Implicit.

Section Float_ops.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Arguments Float {beta}.

Definition Falign (f1 f2 : float beta) :=
  let '(Float m1 e1) := f1 in
  let '(Float m2 e2) := f2 in
  if Zle_bool e1 e2
  then (m1, (m2 * Zpower beta (e2 - e1))%Z, e1)
  else ((m1 * Zpower beta (e1 - e2))%Z, m2, e2).

Theorem Falign_spec :
  forall f1 f2 : float beta,
  let '(m1, m2, e) := Falign f1 f2 in
  F2R f1 = @F2R beta (Float m1 e) /\ F2R f2 = @F2R beta (Float m2 e).
Proof.
unfold Falign.
intros (m1, e1) (m2, e2).
generalize (Zle_cases e1 e2).
case (Zle_bool e1 e2) ; intros He ; split ; trivial.
now rewrite <- F2R_change_exp.
rewrite <- F2R_change_exp.
apply refl_equal.
lia.
Qed.

Theorem Falign_spec_exp:
  forall f1 f2 : float beta,
  snd (Falign f1 f2) = Z.min (Fexp f1) (Fexp f2).
Proof.
intros (m1,e1) (m2,e2).
unfold Falign; simpl.
generalize (Zle_cases e1 e2);case (Zle_bool e1 e2); intros He.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
case (Zmin_spec e1 e2); intros (H1,H2); easy.
Qed.

Definition Fopp (f1 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  Float (-m1)%Z e1.

Theorem F2R_opp :
  forall f1 : float beta,
  (F2R (Fopp f1) = -F2R f1)%R.
intros (m1,e1).
apply F2R_Zopp.
Qed.

Definition Fabs (f1 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  Float (Z.abs m1)%Z e1.

Theorem F2R_abs :
  forall f1 : float beta,
  (F2R (Fabs f1) = Rabs (F2R f1))%R.
intros (m1,e1).
apply F2R_Zabs.
Qed.

Definition Fplus (f1 f2 : float beta) : float beta :=
  let '(m1, m2 ,e) := Falign f1 f2 in
  Float (m1 + m2) e.

Theorem F2R_plus :
  forall f1 f2 : float beta,
  F2R (Fplus f1 f2) = (F2R f1 + F2R f2)%R.
Proof.
intros f1 f2.
unfold Fplus.
generalize (Falign_spec f1 f2).
destruct (Falign f1 f2) as ((m1, m2), e).
intros (H1, H2).
rewrite H1, H2.
unfold F2R. simpl.
rewrite plus_IZR.
apply Rmult_plus_distr_r.
Qed.

Theorem Fplus_same_exp :
  forall m1 m2 e,
  Fplus (Float m1 e) (Float m2 e) = Float (m1 + m2) e.
Proof.
intros m1 m2 e.
unfold Fplus.
simpl.
now rewrite Zle_bool_refl, Zminus_diag, Zmult_1_r.
Qed.

Theorem Fexp_Fplus :
  forall f1 f2 : float beta,
  Fexp (Fplus f1 f2) = Z.min (Fexp f1) (Fexp f2).
Proof.
intros f1 f2.
unfold Fplus.
rewrite <- Falign_spec_exp.
now destruct (Falign f1 f2) as ((p,q),e).
Qed.

Definition Fminus (f1 f2 : float beta) :=
  Fplus f1 (Fopp f2).

Theorem F2R_minus :
  forall f1 f2 : float beta,
  F2R (Fminus f1 f2) = (F2R f1 - F2R f2)%R.
Proof.
intros f1 f2; unfold Fminus.
rewrite F2R_plus, F2R_opp.
ring.
Qed.

Theorem Fminus_same_exp :
  forall m1 m2 e,
  Fminus (Float m1 e) (Float m2 e) = Float (m1 - m2) e.
Proof.
intros m1 m2 e.
unfold Fminus.
apply Fplus_same_exp.
Qed.

Definition Fmult (f1 f2 : float beta) : float beta :=
  let '(Float m1 e1) := f1 in
  let '(Float m2 e2) := f2 in
  Float (m1 * m2) (e1 + e2).

Theorem F2R_mult :
  forall f1 f2 : float beta,
  F2R (Fmult f1 f2) = (F2R f1 * F2R f2)%R.
Proof.
intros (m1, e1) (m2, e2).
unfold Fmult, F2R. simpl.
rewrite mult_IZR, bpow_plus.
ring.
Qed.

End Float_ops.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library 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 library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Max.

Require Import Rseries_facts.
Require Import Rsequence_facts.
Require Import Rsequence_subsequence.
Require Import Rpser_usual.
Require Import Reals.
Require Import Rsequence_tactics.
Require Import Rtactic.

Require Import Lra.

Open Scope R_scope.

Definition e := exp 1.

Definition partial_e n := sum_f_R0 (fun n => /INR (fact n)) n.

(* begin hide *)
Lemma Rabs_div : forall x y, y <> 0 -> Rabs (x / y) = Rabs x / Rabs y.
Proof.
intros x y H.
unfold Rdiv.
rewrite Rabs_mult.
rewrite Rabs_Rinv. field.
apply Rabs_no_R0.
assumption.
intuition.
Qed.

Lemma integer_INR_div : forall b, b <> O -> / INR b * INR (fact b) = INR (fact (b - 1)).
Proof.
intros b Hb0.
destruct b.
 destruct Hb0. reflexivity.

 rewrite fact_simpl. rewrite mult_INR.
 field_simplify.
  simpl. rewrite <- minus_n_O. reflexivity.

 INR_solve.
Qed.
(* end hide *)

Lemma sum_integer_INR_div : forall n, {m |
   sum_f_R0 (fun i : nat => / INR (fact i) * INR (fact n)) n = INR m}.
Proof.
induction n.
 exists 1%nat. simpl. field.

 destruct IHn as (m1, Hm1).
 rewrite tech5. rewrite fact_simpl. rewrite mult_INR.
 exists (S n * m1 + 1)%nat.
 rewrite <- scal_sum.
 rewrite <- scal_sum in Hm1. rewrite Rmult_assoc. rewrite Hm1.
 rewrite plus_INR. rewrite mult_INR. do 2 rewrite S_INR. simpl.
 field.

 split.
  apply INR_fact_neq_0.
  assert (INR n >= 0) by intuition ; intro H1 ; lra.
Qed.

Lemma integer_exp_minus_sum : forall a b : nat,
  b <> O -> e = INR a / INR b ->
  {n | INR (fact b) * (e - partial_e b) = IZR n}.
Proof.
intros a b Hb0 Habs.
rewrite Habs.
rewrite Rmult_minus_distr_l.
unfold partial_e.
rewrite scal_sum.
unfold Rdiv. rewrite Rmult_comm. rewrite Rmult_assoc.
rewrite (integer_INR_div b Hb0).
destruct (sum_integer_INR_div b) as (m1, Hm1).
rewrite Hm1.
exists (Z_of_nat a * Z_of_nat (fact (b-1)) - Z_of_nat m1)%Z.
unfold Zminus. rewrite plus_IZR. rewrite mult_IZR.
rewrite Ropp_Ropp_IZR. repeat rewrite <- INR_IZR_INZ.
ring.
Qed.

Lemma sum_max : forall b N f,
  (forall n, f n > 0) -> (sum_f_R0 f b <
    sum_f_R0 f (max N (S b))).
Proof.
intros b N f Hpos.
assert (b < max N (S b))%nat by intuition.
induction H.
 replace (sum_f_R0 f b) with (sum_f_R0 f b + 0) by ring.
 simpl. apply Rplus_le_lt_compat.
  right. reflexivity.

  apply Hpos.
 simpl.
 replace (sum_f_R0 f b) with (sum_f_R0 f b + 0) by ring.
 apply Rplus_le_lt_compat.
  left. apply IHle.

  apply Hpos.
Qed.

Lemma inv_INR_fact_pos : forall n, (/INR (fact n)) > 0.
Proof.
intros n.
assert (INR (fact n) > 0).
 induction n.
  simpl. lra.

  simpl. rewrite plus_INR. replace 0 with (0 + 0) by intuition.
  apply Rplus_gt_ge_compat. apply IHn. intuition.
 apply Rinv_0_lt_compat. intuition.
Qed.

Lemma Rminus_lt_plus : forall a b c, a - b < c -> a < b + c.
Proof.
intros.
lra.
Qed.

Lemma Rplus_lt_minus : forall a b c, a < b + c -> a - b < c.
Proof.
intros.
lra.
Qed.

Lemma sum_max1 : forall N b f,
  (forall n, f n >= 0) ->
    sum_f_R0 f (max N (S b)) >=
    sum_f_R0 f (S b).
Proof.
intros N b f Hpos.
assert (H : (S b <= max N (S b))%nat) by intuition.
induction H.
 intuition.

 rewrite tech5.
 replace (sum_f_R0 f (S b)) with (sum_f_R0 f (S b) + 0) by ring.
 apply Rplus_ge_compat. apply IHle. apply Hpos.
Qed.

Lemma minus_exp_sum_pos : forall a b : nat,
  b <> O ->
  INR (fact b) * (e - partial_e b) > 0.
Proof.
intros a b Hb0.
unfold e, partial_e, exp.
destruct (exist_exp 1) as (y, Hexp). unfold exp_in in *. simpl.
apply Rmult_gt_0_compat ; [apply INR_fact_lt_0|].
unfold infinite_sum in Hexp.
(* Absurd reasoning *)
assert (H : y <= sum_f_R0 (fun n : nat => / INR (fact n)) b -> False).
 intro Habs.
 assert (H1 : /INR (fact (S b)) > 0) by (apply inv_INR_fact_pos).
 generalize (Hexp (/INR (fact (S b))) H1) ; clear Hexp ; intro Hexp.
 destruct Hexp as (N, Hexp).
 assert (Hmax : ((max N (S b)) >= N)%nat). intuition.
 generalize (Hexp (max N (S b)) Hmax). clear Hexp. intros Hexp.
 unfold R_dist in *. unfold Rabs in *.
 replace (sum_f_R0 (fun i : nat => / INR (fact i) * 1 ^ i) (max N (S b)))
 with (sum_f_R0 (fun n : nat => / INR (fact n)) (max N (S b))) in * by
 (apply Rseq_sum_ext ; intros n; rewrite pow1; ring).
 destruct (Rcase_abs (sum_f_R0 (fun i : nat => / INR (fact i)) (max N (S b)) - y)) as [H|H].
  apply Rle_minus in Habs.
  assert (sum_f_R0 (fun n : nat => / INR (fact n)) b - y <
  sum_f_R0 (fun i : nat => / INR (fact i)) (max N (S b)) - y).
   unfold Rminus. apply Rplus_lt_compat_r.
   apply sum_max. intuition. apply inv_INR_fact_pos.

  lra.

  apply Rminus_lt_plus in Hexp.
  apply (Rplus_le_compat_r (/ INR (fact (S b)))) in Habs.
  assert (sum_f_R0 (fun i : nat => / INR (fact i)) (max N (S b)) >=
  sum_f_R0 (fun n : nat => / INR (fact n)) b + / INR (fact (S b))).
   rewrite <- tech5. apply sum_max1. intros. left. apply inv_INR_fact_pos.
  assert (H2 : (sum_f_R0 (fun i : nat => / INR (fact i)) (max N (S b)) <
  sum_f_R0 (fun n : nat => / INR (fact n)) b + / INR (fact (S b)))).
   eapply Rlt_le_trans. apply Hexp. apply Habs.
  apply Rlt_not_ge in H2. apply H2.
  assumption.

 apply Rgt_minus. apply Rlt_gt.
 apply Rnot_le_gt. assumption.
Qed.

Lemma geometric_sum : forall (k:R),
  Rabs k < 1 -> infinite_sum (fun i:nat => k ^ i) (1 / (1 - k)).
Proof.
intros k H0k1.
intros eps Heps.
assert (Hpos : 0 < eps * (1 - k)).
 apply Rmult_lt_0_compat ; [apply Heps |].
 unfold Rabs in *. destruct (Rcase_abs k) ; lra.
destruct (pow_lt_1_zero k H0k1 (eps * (1 - k)) Hpos) as (N, HN).
exists N.
intros n Hn.
rewrite tech3.
 unfold R_dist, Rdiv.
 field_simplify ((1 - k ^ S n) * / (1 - k) - 1 * / (1 - k)).
  rewrite Rabs_div. rewrite Rabs_Ropp. unfold Rabs. destruct (Rcase_abs (-k + 1)) as [H|[H|H]].
(* environnement -> False beginning*)
   assert (H1 : (N >= N)%nat) by intuition. generalize (HN N H1). intros.
   assert (eps * (1 - k) < 0). replace 0 with (eps * 0) by intuition.
   apply Rmult_lt_compat_l. apply Heps. lra. lra.
(*end *)
   replace eps with (eps * (1 - k) * / (-k + 1)).
    unfold Rdiv. apply Rmult_lt_compat_r.
     apply Rinv_0_lt_compat. lra.

     apply HN. intuition. field. intros H3. lra.

   unfold Rabs in H0k1 ; destruct (Rcase_abs k) ; lra.
  intro H2. unfold Rabs in H0k1 ; destruct (Rcase_abs k) ; lra.
 intro H2. unfold Rabs in H0k1 ; destruct (Rcase_abs k) ; lra.
intro H2. unfold Rabs in H0k1 ; destruct (Rcase_abs k) ; lra.
Qed.

(* begin hide *)
Lemma identite : forall k b : nat, (k > b)%nat ->
  INR (fact b) * / INR (fact k)
    <= / INR (S b) * (/ INR (S b)) ^ (k - S b).
Proof.
intros k n Hnb.
induction Hnb.
 rewrite fact_simpl. rewrite mult_INR.
 replace (S n - S n)%nat with O by intuition.
 simpl pow.
 field_simplify.
  right. reflexivity.

  apply not_0_INR. intuition.

  split.
   apply INR_fact_neq_0.

   apply not_0_INR. intuition.

   rewrite fact_simpl. rewrite mult_INR.
   rewrite <- minus_Sn_m ; [|intuition].
   assert (/INR (S m) <= /INR (S n)) by (apply Rle_Rinv ; intuition) .
   rewrite <- tech_pow_Rmult.
   rewrite Rinv_mult_distr.
    rewrite Rmult_comm. rewrite Rmult_assoc.
    apply Rmult_le_compat.
     left. apply Rinv_0_lt_compat. intuition.

     left. rewrite Rmult_comm. apply Rlt_mult_inv_pos ; apply INR_fact_lt_0.

     apply Rle_Rinv ; [apply lt_0_INR ; intuition|apply lt_0_INR ; intuition|intuition].

     rewrite Rmult_comm. apply IHHnb.

    apply not_0_INR. intuition.

    apply INR_fact_neq_0.
Qed.

Lemma identite1 : forall b, INR (fact b) * / INR (fact (S (S b))) <
  / INR (S b) * (/ INR (S b)) ^ (S (S b) - S b).
Proof.
intros b.
do 2 rewrite fact_simpl.
rewrite <- minus_Sn_m ; [|intuition].
rewrite <- minus_diag_reverse.
rewrite <- tech_pow_Rmult. simpl pow.
do 2 rewrite mult_INR. field_simplify.
 unfold Rdiv. rewrite Rinv_mult_distr.
  unfold pow. rewrite Rinv_mult_distr.
   do 2 rewrite Rmult_1_l. rewrite Rmult_1_r. apply Rmult_lt_compat_r.
    apply Rinv_0_lt_compat. intuition.

    apply Rinv_lt_contravar. apply Rmult_lt_0_compat ; intuition.
    intuition.

   apply not_0_INR. intuition.

   rewrite Rmult_1_r.  apply not_0_INR. intuition.

  apply not_0_INR. intuition.

  apply not_0_INR. intuition.

 apply not_0_INR. intuition.

 split.
  apply INR_fact_neq_0.

  split.
   apply not_0_INR. intuition.

   apply not_0_INR. intuition.
Qed.
(* end hide *)

Lemma exp_remain_sum : forall n,
  n <> O -> INR (fact n) * (e - partial_e n) < 1 / INR n.
Proof.
intros b Hb0.
unfold partial_e, e, exp.
destruct (exist_exp 1) as (x, Hexp). simpl.
unfold exp_in in *.
(* geometric summation equal to 1 / b *)
assert (Hgeom : (infinite_sum (fun i => (/INR (S b)) ^ i) (1 / (1 - /INR (S b))))).
 apply (geometric_sum (/INR (S b))).
 unfold Rabs. destruct (Rcase_abs (/INR (S b))) as [H1|[H1|H1]].
  assert (H : (- /INR (S b) < 0 )) by intuition.
  eapply (Rlt_trans) ; [apply H|intuition].

  replace 1 with (/1) by intuition.
  apply Rinv_lt_contravar.
   rewrite Rmult_1_l. intuition.

   destruct b.
    destruct Hb0. reflexivity.

    rewrite S_INR. assert (INR (S b) > 0) by intuition. lra.

  rewrite H1. lra.
(* end of geometric summation *)

(* rewriting of Hexp *)
assert (He : (infinite_sum (fun i : nat => / INR (fact i)) x)).
 intros eps Heps. destruct (Hexp eps Heps) as (N, Hexp1).
 exists N. intros n Hn. generalize (Hexp1 n Hn). intros H1.
 assert (Hrew : (sum_f_R0 (fun i : nat => / INR (fact i) * 1 ^ i) n =
 sum_f_R0 (fun i : nat => / INR (fact i)) n)).
  apply sum_eq. intros. rewrite pow1. intuition.

 rewrite <- Hrew. apply H1. clear Hexp.
(* end of rewriting : He *)

pose (Un := fun n : nat => / INR (fact (n))).
pose (UUn := fun n : nat => Un (S b + n)%nat).
assert (Hluu : Rser_cv UUn (x - sum_f_R0 Un b)).
 apply (Rser_cv_shifts b Un). assumption.

assert (Hlu : Rser_cv Un x). apply He.

assert (HRser : Rser_cv (fun k => Un (S b+ k)%nat) (Rser_rem Un x Hlu b)).
 apply (Rser_rem_cv Un).

assert (Rser_cv Un (Rser_rem Un x Hlu b + sum_f_R0 Un b)).
 apply Rser_cv_shifts_rev. assumption.

assert (H1 : (x = Rser_rem Un x Hlu b + sum_f_R0 Un b)).
 apply Rser_cv_unique with Un ; assumption.

rewrite H1. unfold Un. ring_simplify.
assert (Hlmachin : Rser_cv Un x). intuition.

apply Rser_cv_scal_compat_l with Un x (INR (fact b)) in Hlmachin.
fold Un. apply Rle_lt_trans with ((INR (fact b) * Rser_rem Un x Hlu)%Rseq b).
reflexivity. rewrite <- (Rser_rem_scal_compat_l Un x (INR (fact b)) Hlmachin).

pose (Vn := (fun n0 : nat => INR (fact b) * / INR (fact n0) )).
assert (Hlv : (Rser_cv Vn (INR (fact b) * x))).
 unfold Vn. apply Rser_cv_scal_compat_l. assumption.

unfold Un. fold Vn.
pose (Wn := (fun i : nat => /(INR (S b)) * (/ INR (S b)) ^ i)).
assert (Hlw : Rser_cv Wn (( /INR (S b) *(1/ (1 - / INR (S b)))))).
 unfold Wn. apply Rser_cv_scal_compat_l.
 apply Rser_cv_ext with (fun i : nat => (/ INR (S b)) ^ i).
 intro ; reflexivity.

  apply Hgeom.

eapply Rlt_le_trans with (/ INR (S b) * (1 / (1 - / INR (S b)))).
 apply (Rser_Rser_rem_lt_le Wn Vn _ _ _ _).
  intros k Hkn.
  unfold Vn, Wn. apply identite. assumption.

  exists (S (S b)). intuition. unfold Vn, Wn. apply identite1.

  apply Hlw.

 field_simplify.
  replace (INR (S b) - 1) with (INR b). right. reflexivity.

  rewrite S_INR. ring.

  INR_solve.

split.
 apply not_0_INR.
  intuition.

  rewrite S_INR. unfold Rminus. rewrite Rplus_assoc.
  intro H2. ring_simplify in H2. revert H2. change (INR b <> 0). INR_solve.
Qed.

Lemma inv_inf_1 : forall x, x <> 0%nat -> /INR x <= 1.
Proof.
intros x Hx0.
assert (H : (INR x > 0)) by intuition.
assert (H1 : (INR x >= 1)).
 induction x.
  destruct Hx0. reflexivity.

  replace 1 with (0 + 1) by intuition. rewrite S_INR.
  apply Rplus_ge_compat. intuition. intuition.

 rewrite <- Rinv_1.
 apply Rle_Rinv. lra. assumption.
intuition.
Qed.

Lemma minus_exp_sum_one : forall a b : nat,
b <> 0%nat -> e = INR a / INR b ->
INR (fact b) * (e - partial_e b) < 1.
Proof.
intros a b Hb0 Habs.
eapply Rlt_le_trans.
 apply exp_remain_sum. assumption.

 unfold Rdiv. rewrite Rmult_1_l. apply inv_inf_1. assumption.
Qed.

Lemma integer_0_1 : forall x, 0 < IZR x < 1 -> False.
Proof.
  intros x [H0 H1].
  apply lt_IZR in H0; apply lt_IZR in H1.
  omega.
Qed.

Lemma eirr : forall a b, b <> 0%nat -> e = (INR a) / (INR b) -> False.
Proof.
intros a b Hb0 Habs.
pose (x := INR (fact b) * (e - partial_e b)).
assert (0 < x < 1).
 split.
  unfold x. apply (minus_exp_sum_pos a) ; intuition.

  unfold x. apply (minus_exp_sum_one a) ; intuition.

 destruct (integer_exp_minus_sum a b Hb0 Habs) as (m, Hm).
 unfold x in *.
 rewrite Hm in H.
 apply (integer_0_1 m). assumption.
Qed.

(** * Final result: e is irrational *)
Lemma e_is_irrational : forall (a : Z) (b : nat),
  b <> O -> e = (IZR a) / (INR b) -> False.
Proof.
intros [|a|a] b Hb He.
 refine (eirr O b Hb _).
 simpl in He; assumption.

 refine (eirr (nat_of_P a) b Hb _).
 rewrite INR_IPR. assumption.

 unfold IZR, e in *.
 assert (0 < IPR a / INR b).
 { rewrite <-INR_IPR. apply Rlt_mult_inv_pos. apply pos_INR_nat_of_P. INR_solve. }
 pose proof exp_pos 1 as Hpos.
 rewrite He in Hpos.
 lra.
Qed.


From Undecidability Require Import TM.Util.TM_facts.
Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.DepPairs EqdepFacts.

Set Default Goal Selector "!".

(* * Switch Combinator *)

Section Switch.

  Variable n : nat.
  Variable sig : finType.

  Variable F : finType.

  Variable pM1 : pTM sig F n.
  Variable F' : finType.
  Variable pMf : F -> pTM sig F' n.

  (* The (unlabelled) machine [M] *)
  Notation M1 := (projT1 pM1).
  (* The labelling function of the machine [M] *)
  Notation p1 := (projT2 pM1).

  (* The (unlabelled) case-machine [M' y] *)
  Notation "'Mf' y" := (projT1 (pMf y)) (at level 10).
  (* The labelling function of the case-machine [M' y] *)
  Notation "'p2' y" := (projT2 (pMf y)) (at level 10).

  Definition Switch_trans :
    (TM.state M1 + { f : F & TM.state (Mf f) }) * Vector.t (option sig) n ->
    (TM.state M1 + { f : F & TM.state (Mf f) }) * Vector.t (option sig * move) n :=
    fun '(q, s) =>
        match q with
        | inl q =>
          if halt q
          then (inr (existT _ (p1 q) (start (Mf (p1 q)))), nop_action)
          else let (q', a) := trans (q, s) in (inl q', a)
        | inr q =>
          let (q', a) := trans (projT2 q, s) in
          (inr (existT _ (projT1 q) q'), a)
        end.

  Definition Switch_halt : (TM.state M1 + { f : F & TM.state (Mf f) }) -> bool :=
    fun q =>
      match q with
      | inl _ => false
      | inr q => halt (projT2 q)
      end.

  Definition SwitchTM : TM sig n :=
    {|
      trans := Switch_trans;
      halt  := Switch_halt;
      start := inl (start M1);
    |}.

  Definition Switch_p : (state SwitchTM) -> F' :=
    fun q => match q with
          | inl q => p2 (p1 q) (start (Mf (p1 q))) (* Canonical value *)
          | inr q => p2 (projT1 q) (projT2 q)
          end.

  Definition Switch : pTM sig F' n := (SwitchTM; Switch_p).

  (* Lift configurations of [M1] to configurations of [Switch] *)
  Definition lift_confL (c : mconfig sig (state M1) n) : mconfig sig (state SwitchTM) n :=
    mk_mconfig (inl (cstate c)) (ctapes c).

  (* Lift configuration of [M2] to configurations of [Switch] *)
  Definition lift_confR (f : F) (c : mconfig sig (state (Mf f) ) n) : mconfig sig (state SwitchTM) n :=
    mk_mconfig (inr (existT (fun f0 : F => state (Mf f0)) f (cstate c))) (ctapes c).

  (* Lifted Steps of [M1] are compatible with steps in [M1], for non-halting state *)
  Lemma step_comp_liftL (c : mconfig sig (state M1) n) :
    haltConf c = false -> step (lift_confL c) = lift_confL (step c).
  Proof.
    unfold lift_confL, step, haltConf. cbn. destruct c as [q t]; cbn in *. intros H. rewrite H.
    destruct (trans _) eqn:E. cbn. reflexivity.
  Qed.

  (* Lifted steps of case-machines [Mf f] are compatible with steps in [Mf f] *)
  Lemma step_comp_liftR f (c : mconfig sig (state (Mf f)) n) :
    step (lift_confR c) = lift_confR (step c).
  Proof.
    destruct c. unfold lift_confR, step. cbn.
    destruct (trans _) eqn:E. cbn. reflexivity.
  Qed.

  (* Lifted halting state of [M1] *)
  Definition halt_liftL (c : mconfig sig (state (SwitchTM)) n) :=
    match cstate c with
    | inl q => halt (m := M1) q
    | inr q => true
    end.

  (* Non-halting state of [M1] are non-halting state of [Switch] *)
  Lemma halt_conf_liftL (c : mconfig sig (state SwitchTM) n) :
    halt_liftL c = false -> halt (cstate c) = false.
  Proof.
    intros H. cbn. unfold Switch_halt.
    destruct c as [q t]. now destruct q.
  Qed.

  (* The "nop" transition jumps from a halting configuration of [M1] to the initial configuration of the corresponding case-machine. *)
  Lemma step_nop_transition (c : mconfig sig (state M1) n) :
    haltConf c = true ->
     step (lift_confL c) = lift_confR (initc (Mf (p1 (cstate c))) (ctapes c)).
  Proof.
    intros Halt.
    unfold lift_confL, lift_confR. cbn. unfold haltConf in Halt.
    unfold step at 1; cbn.
    rewrite Halt. f_equal.
    apply doAct_nop.
  Qed.

  (* The starting configuration of [Switch] corresponds to the starting configuration of [M1]. *)
  Lemma lift_initc t :
    initc SwitchTM t = lift_confL (initc M1 t).
  Proof. reflexivity. Qed.

  (* This lemma is needed for the termination part. Suppose [M1] terminates in [c1].  The case machine [Mf f] starts with the tapes of [c1] and terminates in a configuration [c2]. Then, if we start [Switch] with the same tapes as [M1], [Switch] terminates in the lifted configuration of [c2]. *)
  Lemma Switch_merge t (k1 k2 : nat)
        (c1 : mconfig sig (state M1) n)
        (c2 : mconfig sig (state (Mf (p1 (cstate c1)))) n) :
    loopM (initc M1 t) k1 = Some c1 ->
    loopM (initc (Mf (p1 (cstate c1))) (ctapes c1)) k2 = Some c2 ->
    loopM (initc SwitchTM t) (k1 + (1 + k2)) = Some (lift_confR c2).
  Proof.
    intros HLoop1 HLoop2. unfold loopM in *.
    apply loop_merge with (h := halt_liftL) (a2 := lift_confL c1).
    - apply halt_conf_liftL.
    - rewrite lift_initc.
      apply loop_lift with (h := haltConf (M := M1)) (f := step (M := M1)).
      + unfold haltConf. intros. cbn. reflexivity.
      + apply step_comp_liftL.
      + apply HLoop1.
    - (* execute one step *)
      rewrite loop_step by auto.
      rewrite step_nop_transition by apply (loop_fulfills HLoop1).
      eapply loop_lift with (lift := lift_confR (f := p1 (cstate c1))) (f' := step (M := SwitchTM)) (h' := haltConf (M := SwitchTM)) in HLoop2.
      + apply HLoop2.
      + intros. cbn. now destruct x.
      + intros. apply step_comp_liftR.
  Qed.

  (* The [Switch] machine must take the "nop" action if it is in a final state of [M1]. *)
  Lemma step_nop_split (k2 : nat) (c2 : mconfig sig (state M1) n) (outc : mconfig sig (state SwitchTM) n) :
    haltConf c2 = true ->
    loopM (M := SwitchTM) (lift_confL c2) k2 = Some outc ->
    exists k2' c2',
      k2 = S k2' /\
      loopM (M := Mf (p1 (cstate c2))) (initc _ (ctapes c2)) k2' = Some c2' /\
      outc = lift_confR c2'.
  Proof.
    unfold loopM. intros HHalt HLoop2. unfold haltConf in HHalt.
    destruct k2 as [ | k2'].
    - inv HLoop2.
    - exists k2'. cbn in HLoop2.
      rewrite step_nop_transition in HLoop2 by assumption.
      apply loop_unlift with
          (f := step (M := Mf (p1 (cstate c2))))
          (h := haltConf (M := Mf (p1 (cstate c2)))) in HLoop2 as
          (c2'&HLoop2&->).
      + exists c2'. repeat split. exact HLoop2.
      + intros. reflexivity.
      + intros. apply step_comp_liftR.
  Qed.

  Lemma Switch_split k t (outc : mconfig sig (state SwitchTM) n) :
    loopM (initc SwitchTM t) k = Some outc ->
    exists k1 (c1 : mconfig sig (state M1) n) k2 (c2 : mconfig sig (state (Mf (p1 (cstate c1)))) n),
      loopM (initc M1 t) k1 = Some c1 /\
      loopM (initc (Mf (p1 (cstate c1))) (ctapes c1)) k2 = Some c2 /\
      outc = lift_confR c2.
  Proof.
    unfold loopM. intros H.
    apply loop_split with (h := halt_liftL) in H as (k1&c1&k2&HLoop1&HLoop2&_).
    - rewrite lift_initc in HLoop1.
      apply loop_unlift with (lift := lift_confL) (f := step (M := M1)) (h := haltConf (M := M1)) in HLoop1 as (c1'&HLoop1&->).
      + apply step_nop_split in HLoop2 as (k2'&c2'&_&HLoop2&->). 2: now apply (loop_fulfills HLoop1).
        exists k1, c1', k2', c2'. auto.
      + intros. cbn. reflexivity.
      + intros. now apply step_comp_liftL.
    - apply halt_conf_liftL.
  Qed.

  (* Correctness *)
  Lemma Switch_Realise (R1 : Rel _ (F * _)) (R2 : F -> Rel _ (F' * _)) :
    pM1 ⊨ R1 ->
    (forall f : F, pMf f ⊨ R2 f) -> Switch ⊨ (⋃_f (R1 |_ f) ∘ R2 f).
  Proof.
    intros HRel1 HRel2. hnf in HRel1.
    hnf. intros t i outc HLoop.
    apply Switch_split in HLoop as (k1&c1&k2&c2&HLoop1&HLoop2&->). cbn.
    exists (p1 (cstate c1)), (ctapes c1). split.
    - apply (HRel1 _ _ _ HLoop1).
    - apply (HRel2 _ _ _ _ HLoop2).
  Qed.

  (* Runtime *)
  Lemma Switch_TerminatesIn (R1 : Rel _ (F * _)) T1 T2 :
    pM1 ⊨ R1 -> M1 ↓ T1 -> (forall f : F, Mf f ↓(T2 f)) ->
    projT1 Switch ↓ (fun tin i => exists i1 i2, T1 tin i1 /\ 1 + i1 + i2 <= i /\ forall tout yout, R1 tin (yout, tout) -> T2 yout tout i2).
  Proof.
    unfold Switch. intros HRel1 HTerm1 HTerm2. hnf in HRel1, HTerm1.
    hnf. intros t i (i1&i2&HT1&Hk&H).
    specialize HTerm1 with (1 := HT1) as (c1&HLoop1).
    specialize HRel1 with (1 := HLoop1).
    specialize H with (1 := HRel1).
    specialize (HTerm2 _ _ _ H) as (c2&HLoop2).
    pose proof Switch_merge HLoop1 HLoop2 as HLoop.
    exists (lift_confR c2). eapply loop_monotone; eauto. lia.
  Qed.

  (* This is a stronger version where we can choose the running time of [Mf] depending on the output label of [M1]. This is usually not needed. *)
  Lemma Switch_TerminatesIn' (R1 : Rel _ (F * _)) T1 T2 :
    pM1 ⊨ R1 -> M1 ↓ T1 -> (forall f : F, Mf f ↓(T2 f)) ->
    projT1 Switch ↓ (fun tin i => exists i1, T1 tin i1 /\ forall tout yout, R1 tin (yout, tout) -> exists i2, 1 + i1 + i2 <= i /\ T2 yout tout i2).
  Proof.
    unfold Switch. intros HRel1 HTerm1 HTerm2. hnf in HRel1, HTerm1.
    hnf. intros t k (i1&HT1&H).
    specialize HTerm1 with (1 := HT1) as (c1&HLoop1).
    specialize HRel1 with (1 := HLoop1).
    specialize H with (1 := HRel1) as (i2&Hi&HT2).
    unfold TerminatesIn in HTerm2. specialize HTerm2 with (1 := HT2) as (c2&HLoop2).
    pose proof Switch_merge HLoop1 HLoop2 as HLoop.
    exists (lift_confR c2). eapply loop_monotone; eauto. lia.
  Qed.

  (* Correct + constant running time *)
  Lemma Switch_RealiseIn (R1 : Rel _ (F * _)) (R2 : F -> Rel _ (F' * _)) k1 k2:
    pM1 ⊨c(k1) R1 ->
    (forall f : F, pMf f ⊨c(k2) R2 f) ->
    Switch ⊨c(1 + k1 + k2) (⋃_f (R1 |_ f) ∘ R2 f).
  Proof.
    intros (H1&H2) % Realise_total H3. apply Realise_total. split.
    - eapply Switch_Realise; eauto. intros ?. eapply Realise_total; eauto.
    - eapply TerminatesIn_monotone.
      + apply Switch_TerminatesIn; eauto. intros ?. eapply Realise_total; eauto.
      + firstorder.
  Qed.

End Switch.

Arguments Switch : simpl never.

(* Deprecated names *)
Notation MATCH := Switch (only parsing).
Notation Match := Switch (only parsing).


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Export CoRN.reals.Q_in_CReals.
Require Export CoRN.ftc.MoreIntervals.
Require Export CoRN.reals.fast.CRIR.
Require Import CoRN.tactics.CornTac.
Require Export CoRN.model.metric2.Qmetric.
Require Export CoRN.model.totalorder.QposMinMax.

Opaque CR inj_Q.

Set Implicit Arguments.

Local Open Scope uc_scope.
(**
** Correctness of continuous functions.
We show that if two functions, one on IR and one on CR, agree on the
rational values of some closed interval, and both functions are continuous,
then the two functions agree on that entire closed interval.

This is our main method of proving the corrections of functions defined
on CR.
*)
Lemma Q_dense_in_compact : forall a b (Hab : a[<=]b) x, a[<]b -> Compact Hab x ->
 forall e, [0][<]e -> {q:Q | Compact Hab (inj_Q IR q) | AbsSmall e (x[-]inj_Q IR q)}.
Proof.
 intros a b Hab x Hab0 Hx e He.
 set (l:=Max a (x[-]e)).
 set (r:=Min b (x[+]e)).
 assert (Hlr:l[<]r).
  destruct Hx as [Hx0 Hx1].
  apply less_Min; apply Max_less.
     assumption.
    apply shift_minus_less.
    rstepl (x[+][0]).
    apply plus_resp_leEq_less; assumption.
   rstepl (a[+][0]).
   apply plus_resp_leEq_less; assumption.
  apply shift_zero_less_minus'.
  rstepr (e[+]e).
  apply plus_resp_pos; assumption.
 destruct (Q_dense_in_CReals' _ _ _ Hlr) as [q Hlq Hqr].
 exists q; split.
    eapply leEq_transitive.
     apply lft_leEq_Max.
    apply less_leEq; unfold l in Hlq; apply Hlq.
   eapply leEq_transitive.
    apply less_leEq;apply Hqr.
   apply Min_leEq_lft.
  apply shift_zero_leEq_minus'.
  rstepr ((x[+]e)[-]inj_Q IR q).
  apply shift_zero_leEq_minus.
  eapply leEq_transitive.
   apply less_leEq.
   apply Hqr.
  apply Min_leEq_rht.
 apply shift_zero_leEq_minus'.
 rstepr (inj_Q IR q[-](x[-]e)).
 apply shift_zero_leEq_minus.
 eapply leEq_transitive.
  apply rht_leEq_Max.
 apply less_leEq.
 unfold l in Hlq; apply Hlq.
Qed.

Section ContinuousCorrect.

Variable I : interval.
Hypothesis HI : proper I.

Variable f : PartFunct IR.
Hypothesis Hf : Continuous I f.

Variable g : CR --> CR.
Hypothesis Hg : forall (q:Q) Hq,
    I (inj_Q IR q) -> (g (' q) == IRasCR (f (inj_Q IR q) Hq))%CR.

Lemma ContinuousCorrect : forall (x:IR) Hx,
    I x -> (IRasCR (f x Hx) == g (IRasCR x))%CR.
Proof.
 intros x Hx H.
 set (J:=compact_in_interval I HI x H).
 apply ball_eq.
 intros e epos.
 assert (HJ:compact_ J) by apply compact_compact_in_interval.
 destruct Hf as [Hf1 Hf0].
 clear Hf.
 assert (X:Continuous_I (Lend_leEq_Rend J HJ) f).
  apply Hf0.
  eapply included_trans;[|apply included_compact_in_interval].
  unfold J;  apply iprop_compact_in_interval_inc1.
 clear Hf0.
 destruct X as [_ X].
 assert (He : [0][<](inj_Q IR (proj1_sig ((1#2)*exist _ _ epos)%Qpos))).
  stepl (inj_Q IR (nring 0)); [| now apply (inj_Q_nring IR 0)].
  apply inj_Q_less.
  apply Qpos_ispos.
 destruct (X _ He) as [d0 Hd0 Hf].
 clear X.
 set (d1:=mu g ((1#2)*exist _ _ epos)).
 set (Hab := (Lend_leEq_Rend J HJ)) in *.
 set (a:= (@Lend J HJ)) in *.
 set (b:= (@Rend J HJ)) in *.
 assert (HJ':included (Compact Hab) I).
  eapply included_trans.
   unfold Hab, a, b, J; apply iprop_compact_in_interval_inc1.
  apply included_compact_in_interval.
 assert (Hab0: a[<]b).
  apply proper_compact_in_interval'.
 assert (HJx:(Compact Hab) x).
  apply iprop_compact_in_interval'.
 clearbody Hab a b.
 clear J HJ.
 pose (d:=match d1 with | Qpos2QposInf q => Min (inj_Q IR (proj1_sig q)) d0 | QposInfinity => d0 end).
 assert (H0d : [0][<]d).
  destruct d1; try assumption.
  apply less_Min; try assumption.
  stepl (inj_Q IR [0]).
   apply inj_Q_less.
   apply Qpos_ispos.
  apply (inj_Q_nring IR 0).
 destruct (Q_dense_in_compact Hab0 HJx _ H0d) as [q Hq0 Hq1].
 setoid_replace e
   with (proj1_sig ((1#2)*exist _ _ epos+(1#2)*exist _ _ epos))%Qpos
   by (simpl; ring).
 assert (Hfq : Dom f (inj_Q IR q)).
  apply Hf1.
  apply HJ'.
  assumption.
 apply ball_triangle with (IRasCR (f (inj_Q IR q) Hfq)).
  rewrite <- CRAbsSmall_ball.
  stepr (IRasCR (f x Hx[-]f (inj_Q IR q) Hfq)); [| now (simpl; apply IR_minus_as_CR)].
  stepl (IRasCR (inj_Q IR (proj1_sig ((1 # 2) * exist _ _ epos)%Qpos))); [| now (simpl; apply IR_inj_Q_as_CR)].
  rewrite <- IR_AbsSmall_as_CR.
  apply AbsIR_imp_AbsSmall.
  apply Hf; try assumption.
  eapply leEq_transitive.
   apply AbsSmall_imp_AbsIR.
   apply Hq1.
  destruct d1.
   apply Min_leEq_rht.
  apply leEq_reflexive.
 rewrite <- Hg;[|apply HJ';assumption].
 apply uc_prf.
 fold d1.
 destruct d1; try constructor.
 simpl.
 rewrite <- IR_inj_Q_as_CR.
 rewrite <- CRAbsSmall_ball.
 stepr (IRasCR (inj_Q IR q[-]x)); [| now (simpl; apply IR_minus_as_CR)].
 stepl (IRasCR (inj_Q IR (proj1_sig q0))); [| now (simpl; apply IR_inj_Q_as_CR)].
 rewrite <- IR_AbsSmall_as_CR.
 apply AbsSmall_minus.
 eapply AbsSmall_leEq_trans;[|apply Hq1].
 apply Min_leEq_lft.
Qed.

End ContinuousCorrect.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library 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 library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

(** Properties of real sequences. *)
Require Import Max.
Require Export Rseries_facts.
Require Export Rsequence_facts.
Require Import Lia Lra.
Require Import Complex.
Require Import Csequence_facts.
Require Import Cseries.
Open Scope C_scope.
Open Scope Cseq_scope.

Lemma Cser_cv_re_compat : forall Un l, Cser_cv Un l ->
  Rser_cv (fun n : nat => Cre (Un n)) (Cre l).
Proof.
intros Un l HC.
apply Rseq_cv_eq_compat with (fun n => Cre (sum_f_C0 Un n)).
 intro; rewrite sum_f_C0_Cre_compat; trivial.
 apply Cseq_cv_re_compat.
 apply HC.
Qed.

Lemma Cser_cv_im_compat : forall Un l, Cser_cv Un l ->
  Rser_cv (fun n : nat => Cim (Un n)) (Cim l).
Proof.
intros Un l HC.
apply Rseq_cv_eq_compat with (fun n => Cim (sum_f_C0 Un n)).
 intro; rewrite sum_f_C0_Cim_compat; trivial.
 apply Cseq_cv_im_compat.
 apply HC.
Qed.

Lemma Cser_cv_re_im_compat : forall Un l,
  Rser_cv (fun n => Cre (Un n)) (Cre l) ->
  Rser_cv (fun n => Cim (Un n)) (Cim l) ->
  Cser_cv Un l.
Proof.
intros Un l HCre HCim.
apply Cseq_cv_re_im_compat.
 apply Rseq_cv_eq_compat with (sum_f_R0 (fun n => Cre (Un n))).
  intro; rewrite <- sum_f_C0_Cre_compat; trivial.
  apply HCre.
 apply Rseq_cv_eq_compat with (sum_f_R0 (fun n => Cim (Un n))).
  intro; rewrite <- sum_f_C0_Cim_compat; trivial.
  apply HCim.
Qed.

Lemma Ccauchy_product : forall An Bn la lb lna,
 Cser_cv An la ->
 Cser_cv Bn lb ->
 Cser_abs_cv An lna ->
 Cser_cv ((fun k:nat => sum_f_C0 (fun p:nat => An p * Bn (k - p)%nat) k)%C)
   (la * lb)%C.
Proof.
intros An Bn la lb lna HA HB HNA.
assert (HNAre : {lnare | Rser_abs_cv (fun n => Cre (An n)) lnare}).
 apply Rser_pos_maj_cv with (fun n => Cnorm (An n)).
  intro; apply Rabs_pos.
  intro; apply Cnorm_pos.
  intro; unfold Rseq_abs; apply Cre_le_Cnorm.
  exists lna; apply HNA.
destruct HNAre as [lnare HNAre].

assert (HNAim : {lnaim | Rser_abs_cv (fun n => Cim (An n)) lnaim}).
 apply Rser_pos_maj_cv with (fun n => Cnorm (An n)).
  intro; apply Rabs_pos.
  intro; apply Cnorm_pos.
  intro; unfold Rseq_abs; apply Cim_le_Cnorm.
  exists lna; apply HNA.
destruct HNAim as [lnaim HNAim].

apply Cser_cv_re_im_compat.
 rewrite Cre_mul.
 apply Rser_cv_ext with (fun k =>
   sum_f_R0 (fun p => ((Cre (An p) * Cre (Bn (k - p)%nat)))%R) k -
   sum_f_R0 (fun p => ((Cim (An p) * Cim (Bn (k - p)%nat)))%R) k )%R.
  repeat (intro; rewrite <- sum_f_C0_Cre_compat; rewrite <- minus_sum; apply Rseq_sum_ext).
  intro; rewrite <- Cre_mul; trivial.

  apply Rser_cv_minus_compat.
   eapply (Rser_cv_prod_compat (fun n => Cre (An n)) (fun n => Cre (Bn n)));
     try (apply Cser_cv_re_compat; auto).
   apply HNAre.

   eapply (Rser_cv_prod_compat (fun n => Cim (An n)) (fun n => Cim (Bn n)));
     try (apply Cser_cv_im_compat; auto).
   apply HNAim.

 rewrite Cim_mul.
 apply Rser_cv_ext with (fun k =>
   sum_f_R0 (fun p => ((Cre (An p) * Cim (Bn (k - p)%nat)))%R) k +
   sum_f_R0 (fun p => ((Cim (An p) * Cre (Bn (k - p)%nat)))%R) k )%R.
  intro; rewrite <- sum_f_C0_Cim_compat ; rewrite <- plus_sum ; apply Rseq_sum_ext.
  intro; rewrite Cim_mul; ring.

  apply Rser_cv_plus_compat.
   eapply (Rser_cv_prod_compat (fun n => Cre (An n)) (fun n => Cim (Bn n))).
    apply Cser_cv_re_compat; auto.
    apply Cser_cv_im_compat; auto.
    apply HNAre.

   rewrite Rmult_comm.
   eapply (Rser_cv_prod_compat (fun n => Cim (An n)) (fun n => Cre (Bn n))).
    apply Cser_cv_im_compat; auto.
    apply Cser_cv_re_compat; auto.
    apply HNAim.
Qed.

Lemma Cser_cv_unique : forall Un l1 l2, Cser_cv Un l1 -> Cser_cv Un l2 -> l1 = l2.
Proof.
intros Un l1 l2 H H'.
apply Cseq_cv_unique with (sum_f_C0 Un); auto.
Qed.

Lemma Csum_eq_compat_weak : forall Un Vn n,
  (forall j, Un j = Vn j) -> sum_f_C0 Un n = sum_f_C0 Vn n.
Proof.
intros Un Vn n H.
induction n.
 apply H.
 simpl; rewrite H; rewrite IHn; trivial.
Qed.

Lemma Csum_eq_compat : forall Un Vn n,
  (forall j, (j <= n)%nat -> Un j = Vn j) -> sum_f_C0 Un n = sum_f_C0 Vn n.
Proof.
intros Un Vn n H.
induction n.
 apply H; lia.
 simpl; rewrite H; try lia.
 rewrite IHn; trivial.
 intros j Hj.
 apply H; lia.
Qed.

Lemma Cser_cv_eq_compat : forall Un Vn l,
  (forall j, Un j = Vn j) -> Cser_cv Un l -> Cser_cv Vn l.
Proof.
intros Un Vn l H HC.
apply Cseq_cv_eq_compat with (sum_f_C0 Un).
 intro; apply Csum_eq_compat_weak; apply H.
 apply HC.
Qed.


(* $Id: Rolle.v,v 1.20 2003/03/13 12:06:23 lcf Exp $ *)

Require Export FunctTactics.
Require Export MoreFunctions.

Section Rolle.

(* Tex_Prose
\chapter{Rolle's Theorem}

We now begin to work with partial functions.  We begin by stating and proving Rolle's theorem in various forms and some of its corollaries.

\begin{convention} Assume that:
\begin{itemize}
\item \verb!a,b:IR! with $a<b$ and denote by \verb!I!$=[a,b]$;
\item \verb!F,F'! are partial functions such that \verb!F'! is the derivative of \verb!F! in \verb!I!;
\item \verb!e! is a positive real number.
\end{itemize}
\end{convention}
*)

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

Local Hab:=(less_leEq ??? Hab').
Local I:=(Compact Hab).

Variables F,F':PartIR.

Hypothesis derF:(Derivative_I Hab' F F').
Hypothesis Ha:(Pred F a).
Hypothesis Hb:(Pred F b).

(* Begin_Tex_Verb *)
Hypothesis Fab:(F a Ha)[=](F b Hb).
(* End_Tex_Verb *)

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

Local contF' : (Continuous_I Hab F').
Apply deriv_imp_contin'_I with Hab' F.
Assumption.
Qed.

Local derivF : (e:IR)(Zero[<]e)->{d:IR & (Zero[<]d) | (x,y:IR)(I x)->(I y)->(Hx,Hy,Hx':?)((AbsIR x[-]y)[<=]d)->
  (AbsIR ((F y Hy)[-](F x Hx))[-](F' x Hx')[*](y[-]x))[<=]e[*](AbsIR y[-]x)}.
Elim derF.
Intros a0 b0.
Elim b0; Intros H b1.
Unfold I; Assumption.
Qed.

Local Rolle_lemma2 : {d:IR & (Zero[<]d) | (x,y:IR)(I x)->(I y)->(Hx,Hy,Hx':?)((AbsIR x[-]y)[<=]d)->
  (AbsIR ((F y Hy)[-](F x Hx))[-](F' x Hx')[*](y[-]x))[<=](e[/]TwoNZ)[*](AbsIR y[-]x)}.
Exact (derivF ? (pos_div_two ?? He)).
Qed.

Local df:=(proj1_sigS2P ??? Rolle_lemma2).

Local Hdf : (Zero[<]df) := (proj2a_sigS2P ??? Rolle_lemma2).

Local Hf : ((x,y:IR)(I x)->(I y)->(Hx,Hy,Hx':?)((AbsIR x[-]y)[<=]df)->
  (AbsIR ((F y Hy)[-](F x Hx))[-](F' x Hx')[*](y[-]x))[<=](e[/]TwoNZ)[*](AbsIR y[-]x))
  := (proj2b_sigS2P ??? Rolle_lemma2).

Local Rolle_lemma3 : {d:IR & (Zero[<]d) | (x,y:IR)(I x)->(I y)->(Hx,Hy:?)((AbsIR x[-]y)[<=]d)->
  (AbsIR (F' x Hx)[-](F' y Hy))[<=]e[/]TwoNZ}.
Elim contF'; Intros.
Exact (b0 ? (pos_div_two ?? He)).
Qed.

Local df':=(proj1_sigS2P ??? Rolle_lemma3).

Local Hdf' : Zero[<]df' := (proj2a_sigS2P ??? Rolle_lemma3).

Local Hf' : ((x,y:IR)(I x)->(I y)->(Hx,Hy:?)((AbsIR x[-]y)[<=]df')->(AbsIR (F' x Hx)[-](F' y Hy))[<=]e[/]TwoNZ)
  := (proj2b_sigS2P ??? Rolle_lemma3).

Local d:=(Min df df').

Local Hd : (Zero[<]d).
Unfold d; Apply less_Min; Auto.
Qed.

Local incF : (included (Compact Hab) (Pred F)).
Elim derF; Intros; Assumption.
Qed.

Local n:=(compact_nat a b d Hd).

Local fcp [i:nat][Hi:(le i n)] := (F (compact_part a b Hab' d Hd i Hi) (incF ? (compact_part_hyp a b Hab Hab' d Hd i Hi))).

Local Rolle_lemma1 : (Sumx [i:nat; H:(lt i n)] (fcp (S i) H)[-](fcp i (lt_le_weak i n H))) [=] Zero.
Apply eq_transitive_unfolded with (fcp ? (le_n n))[-](fcp (0) (le_O_n n)).
Apply Mengolli_Sum with f:=[i:nat][H:(le i n)](fcp ? H).
Red; Do 3 Intro.
Rewrite H; Intros.
Unfold fcp; Simpl; Algebra.
Intros; Algebra.
Apply eq_transitive_unfolded with (F b Hb)[-](F a Ha).
Unfold fcp compact_part n; Simpl.
Apply cg_minus_wd; Apply pfwdef; Rational.
Step_rht (F a Ha)[-](F a Ha); Apply cg_minus_wd.
Apply eq_symmetric_unfolded; Apply Fab.
Algebra.
Qed.

Local incF' : (included (Compact Hab) (Pred F')).
Elim derF; Intros.
Elim b0; Intros.
Assumption.
Qed.

Local fcp' [i:nat][Hi:(le i n)] := (F' (compact_part a b Hab' d Hd i Hi) (incF' ? (compact_part_hyp a b Hab Hab' d Hd i Hi))).

Syntactic Definition cp := (compact_part a b Hab' d Hd).

Local Rolle_lemma4 : {i:nat & {H:(Clt i n) &
  Zero[<](((fcp' ? (lt_le_weak ?? (Clt_to ?? H)))[+]e)[*]((cp (S i) (Cle_to ?? H))[-](cp i (lt_le_weak ?? (Cle_to ?? H)))))}}.
Apply positive_Sumx with f:=[i:nat][H:(lt i n)]((fcp' ? (lt_le_weak ?? H))[+]e)[*]((cp ? H)[-](cp ? (lt_le_weak ?? H))).
Red; Do 3 Intro.
Rewrite H; Intros.
Unfold fcp'; Algebra.
Apply less_wdl with (Sumx [i:nat][H:(lt i n)](fcp ? H)[-](fcp ? (lt_le_weak ?? H))).
2: Apply Rolle_lemma1.
Apply Sumx_resp_less.
Apply less_nring with (IR::COrdField); Simpl; Unfold n; Apply pos_compact_nat; Auto.
Intros.
Apply leEq_less_trans with ((fcp' i (lt_le_weak ?? H))[+]e[/]TwoNZ)[*]((cp (S i) H)[-](cp i (lt_le_weak ?? H))).
2: Apply mult_resp_less.
3: Apply compact_less.
2: Apply plus_resp_less_lft.
2: Apply pos_div_two'; Assumption.
RStep (fcp' i (lt_le_weak ?? H))[*]((cp ? H)[-](cp ? (lt_le_weak ?? H)))[+]
  (((fcp ? H)[-](fcp ? (lt_le_weak ?? H)))[-](fcp' i (lt_le_weak ?? H))[*]((cp ? H)[-](cp ? (lt_le_weak ?? H)))).
EApply leEq_wdr.
2: Apply eq_symmetric_unfolded; Apply ring_distl_unfolded.
Apply plus_resp_leEq_lft.
Apply leEq_wdr with (e[/]TwoNZ)[*](AbsIR (cp (S i) H)[-](cp i (lt_le_weak ?? H))).
2: Apply mult_wd.
2: Algebra.
2: Apply AbsIR_eq_x.
2: Apply less_leEq; Apply compact_less.
EApply leEq_transitive.
Apply leEq_AbsIR.
Unfold fcp fcp'; Apply Hf.
Unfold I; Apply compact_part_hyp.
Unfold I; Apply compact_part_hyp.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_minus.
Apply leEq_transitive with d.
2: Unfold d; Apply Min_leEq_lft.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
Apply compact_leEq.
Apply less_leEq; Apply compact_less.
Qed.

Local Rolle_lemma5 : {i:nat & {H:(Cle i n) & [--]e[<](fcp' ? (Cle_to ?? H))}}.
Elim Rolle_lemma4; Intros i Hi; Elim Hi; Clear Hi; Intros Hi Hi'.
Exists i; Exists (Clt_le_weak ?? Hi).
Step Zero[-]e; Apply shift_minus_less.
Apply less_wdr with (fcp' ? (lt_le_weak ?? (Clt_to ?? Hi)))[+]e.
EApply mult_cancel_less.
2: EApply less_wdl.
2: Apply Hi'.
2: Algebra.
Apply compact_less.
Unfold fcp'; Algebra.
Qed.

Local Rolle_lemma6 : {i:nat & {H:(Clt i n) &
  (((fcp' ? (lt_le_weak ?? (Clt_to ?? H)))[-]e)[*]((cp (S i) (Cle_to ?? H))[-](cp i (lt_le_weak ?? (Cle_to ?? H)))))[<]Zero}}.
Apply negative_Sumx with f:=[i:nat][H:(lt i n)]((fcp' ? (lt_le_weak ?? H))[-]e)[*]((cp ? H)[-](cp ? (lt_le_weak ?? H))).
Red; Do 3 Intro.
Rewrite H; Intros.
Unfold fcp'; Algebra.
Apply less_wdr with (Sumx [i:nat][H:(lt i n)](fcp ? H)[-](fcp ? (lt_le_weak ?? H))).
2: Apply Rolle_lemma1.
Apply Sumx_resp_less.
Apply less_nring with (IR::COrdField); Simpl; Unfold n; Apply pos_compact_nat; Auto.
Intros.
Apply less_leEq_trans with ((fcp' ? (lt_le_weak ?? H))[-]e[/]TwoNZ)[*]((cp ? H)[-](cp ? (lt_le_weak ?? H))).
Apply mult_resp_less.
2: Apply compact_less.
Unfold cg_minus; Apply plus_resp_less_lft.
Apply inv_resp_less; Apply pos_div_two'; Assumption.
RStepr (fcp' ? (lt_le_weak ?? H))[*]((cp ? H)[-](cp ? (lt_le_weak ?? H)))[+]
  [--][--](((fcp ? H)[-](fcp ? (lt_le_weak ?? H)))[-](fcp' ? (lt_le_weak ?? H))[*]((cp ? H)[-](cp ? (lt_le_weak ?? H)))).
RStep
  (fcp' ? (lt_le_weak ?? H))[*]((cp ? H)[-](cp ? (lt_le_weak ?? H)))[-](e[/]TwoNZ)[*]((cp ? H)[-](cp ? (lt_le_weak ?? H))).
Unfold 1 cg_minus; Apply plus_resp_leEq_lft.
Apply inv_resp_leEq; Apply leEq_wdr with (e[/]TwoNZ)[*](AbsIR (cp ? H)[-](cp ? (lt_le_weak ?? H))).
2: Apply mult_wd.
2: Algebra.
2: Apply AbsIR_eq_x.
2: Apply less_leEq; Apply compact_less.
EApply leEq_transitive.
Apply inv_leEq_AbsIR.
Unfold fcp fcp'; Apply Hf.
Unfold I; Apply compact_part_hyp.
Unfold I; Apply compact_part_hyp.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_minus.
Apply leEq_transitive with d.
2: Unfold d; Apply Min_leEq_lft.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
Apply compact_leEq.
Apply less_leEq; Apply compact_less.
Qed.

Local Rolle_lemma7 : {i:nat & {H:(Cle i n) & (fcp' ? (Cle_to ?? H))[<]e}}.
Elim Rolle_lemma6; Intros i Hi; Elim Hi; Clear Hi; Intros Hi Hi'.
Exists i; Exists (Clt_le_weak ?? Hi).
Stepr e[+]Zero; Apply shift_less_plus'.
Apply less_wdl with (fcp' ? (lt_le_weak ?? (Clt_to ?? Hi)))[-]e.
EApply mult_cancel_less.
2: EApply less_wdr.
2: Apply Hi'.
2: Algebra.
Apply shift_less_minus.
Step (cp ? (lt_le_weak ?? (Cle_to ?? Hi))).
Unfold compact_part.
Apply plus_resp_less_lft.
Apply mult_resp_less.
Simpl; Apply less_plusOne.
Apply div_resp_pos.
2: Apply shift_less_minus; Step a; Auto.
Apply pos_compact_nat; Auto.
Unfold fcp'; Algebra.
Qed.

Local j:=(ProjS1 Rolle_lemma5).

Local Hj := (ProjS1 (ProjS2 Rolle_lemma5)).

Local Hj' : [--]e[<](fcp' ? (Cle_to j ? Hj)).
Exact (ProjS2 (ProjS2 Rolle_lemma5)).
Qed.

Local k:=(ProjS1 Rolle_lemma7).

Local Hk:=(ProjS1 (ProjS2 Rolle_lemma7)).

Local Hk' : (fcp' ? (Cle_to k ? Hk))[<]e.
Exact (ProjS2 (ProjS2 Rolle_lemma7)).
Qed.

Local Rolle_lemma8 : (i:nat)(H:(le i n))(((AbsIR (fcp' ? H))[<]e)+(e[/]TwoNZ[<](AbsIR (fcp' ? H)))).
Intros.
Cut ((e[/]TwoNZ)[<](AbsIR (fcp' ? H)))+((AbsIR (fcp' ? H))[<]e).
Intro; Inversion_clear H0; [Right | Left]; Assumption.
Apply cotrans_less_unfolded.
Apply pos_div_two'; Assumption.
Qed.

Local Rolle_lemma9 :
  {m:nat & {Hm:(Cle m n) & (((AbsIR (fcp' ? (Cle_to ?? Hm)))[<]e))}}+(i:nat)(H:(le i n))(e[/]TwoNZ[<](AbsIR (fcp' ? H))).
LetTac P := [i:nat][H:(le i n)]((AbsIR (fcp' ? H))[<]e).
LetTac Q := [i:nat][H:(le i n)]((e[/]TwoNZ)[<](AbsIR (fcp' ? H))).
Apply finite_or_elim with P:=P Q:=Q.
Red.
Intros i i' Hii'; Rewrite Hii'; Intros Hi Hi' HP.
Red; Red in HP.
EApply less_wdl.
Apply HP.
Apply AbsIR_wd; Unfold fcp'; Algebra.
Red.
Intros i i' Hii'; Rewrite Hii'; Intros Hi Hi' HQ.
Red; Red in HQ.
EApply less_wdr.
Apply HQ.
Apply AbsIR_wd; Unfold fcp'; Algebra.
Apply Rolle_lemma8.
Qed.

Local Rolle_lemma10 : {m:nat & {Hm:(Cle m n) & (((AbsIR (fcp' ? (Cle_to ?? Hm)))[<]e))}}->
  {x:IR & (I x) | (Hx:?)(AbsIR (F' x Hx))[<=]e}.
Intro.
Elim H; Intros m Hm; Elim Hm; Clear H Hm; Intros Hm Hm'.
Exists (cp ? (Cle_to ?? Hm)).
Red; Apply compact_part_hyp.
Intro; Apply less_leEq; EApply less_wdl.
Apply Hm'.
Apply AbsIR_wd; Unfold fcp'; Algebra.
Qed.

Local Rolle_lemma11 : ((i:nat)(H:(le i n))(e[/]TwoNZ[<](AbsIR (fcp' ? H))))->
  ((H:(le O n))((fcp' ? H)[<][--](e[/]TwoNZ)))->((i:nat)(H:(le i n))(fcp' ? H)[<]Zero).
Intros H H0.
Cut ((H:(le O n))(fcp' ? H)[<]Zero).
Intro.
Induction i.
Assumption.
Intros i' Hrec HSi'.
Stepr (e[/]TwoNZ)[-](e[/]TwoNZ).
Apply shift_less_minus.
Cut (le i' n).
2: Auto with arith.
Intro Hi'.
Apply less_leEq_trans with (fcp' ? HSi')[-](fcp' ? Hi').
Unfold cg_minus; Apply plus_resp_less_lft.
Cut ((e[/]TwoNZ)[<](fcp' ? Hi'))+((fcp' ? Hi')[<][--](e[/]TwoNZ)).
Intro.
Inversion_clear H2.
ElimType False.
Cut (e[/]TwoNZ)[<]Zero.
Apply less_antisymmetric_unfolded.
Apply pos_div_two; Assumption.
EApply less_transitive_unfolded; [Apply H3 | Apply Hrec].
Step [--][--](e[/]TwoNZ); Apply inv_resp_less; Assumption.
Cut (e[/]TwoNZ)[<](AbsIR (fcp' ? Hi')).
2: Exact (H i' Hi').
Intro.
Apply less_AbsIR.
Apply pos_div_two; Assumption.
Assumption.
EApply leEq_transitive.
Apply leEq_AbsIR.
Unfold fcp'; Apply Hf'.
Red; Apply compact_part_hyp.
Red; Apply compact_part_hyp.
Apply leEq_transitive with d.
2: Unfold d; Apply Min_leEq_rht.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
Apply compact_leEq.
Apply less_leEq; Apply compact_less.
Intro.
EApply less_transitive_unfolded.
Apply (H0 H1).
Stepr [--](Zero::IR); Apply inv_resp_less; Apply pos_div_two; Assumption.
Qed.

Local Rolle_lemma12 : ((i:nat)(H:(le i n))(e[/]TwoNZ[<](AbsIR (fcp' ? H))))->
  ((H:(le O n))((e[/]TwoNZ)[<](fcp' ? H)))->((i:nat)(H:(le i n))Zero[<](fcp' ? H)).
Intros H H0.
Cut ((H:(le O n))(Zero[<](fcp' ? H))).
Intro.
Induction i.
Assumption.
Intros i' Hrec HSi'.
Step [--](Zero::IR); Stepr [--][--](fcp' ? HSi'); Apply inv_resp_less.
Stepr (e[/]TwoNZ)[-](e[/]TwoNZ).
Apply shift_less_minus'.
Step (e[/]TwoNZ)[-](fcp' ? HSi').
Cut (le i' n).
2: Auto with arith.
Intro Hi'.
Apply less_leEq_trans with (fcp' ? Hi')[-](fcp' ? HSi').
Unfold cg_minus; Apply plus_resp_less_rht.
Cut ((e[/]TwoNZ)[<](fcp' ? Hi'))+((fcp' ? Hi')[<][--](e[/]TwoNZ)).
Intro; Inversion_clear H2.
Assumption.
ElimType False.
Cut Zero[<][--](e[/]TwoNZ).
Apply less_antisymmetric_unfolded.
Stepr [--](Zero::IR); Apply inv_resp_less; Apply pos_div_two; Assumption.
EApply less_transitive_unfolded; [Apply (Hrec Hi') | Apply H3].
Cut (e[/]TwoNZ)[<](AbsIR (fcp' ? Hi')).
2: Exact (H i' Hi').
Intro.
Apply less_AbsIR.
Apply pos_div_two; Assumption.
Assumption.
EApply leEq_transitive.
Apply leEq_AbsIR.
Unfold fcp'; Apply Hf'.
Red; Apply compact_part_hyp.
Red; Apply compact_part_hyp.
Apply leEq_transitive with d.
2: Unfold d; Apply Min_leEq_rht.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_minus.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
Apply compact_leEq.
Apply less_leEq; Apply compact_less.
Intro.
EApply less_transitive_unfolded.
2: Apply (H0 H1).
Apply pos_div_two; Assumption.
Qed.

Local Rolle_lemma13 : (((i:nat)(H:(le i n))(fcp' ? H)[<]Zero)+((i:nat)(H:(le i n))Zero[<](fcp' ? H)))->
  {x:IR & (I x) | (Hx:?)(AbsIR (F' x Hx))[<=]e}.
Intro; Inversion_clear H.
Exists (cp ? (Cle_to ?? Hj)).
Red; Apply compact_part_hyp.
Intro; Simpl; Unfold ABSIR; Apply Max_leEq.
Apply less_leEq; Apply less_transitive_unfolded with (Zero::IR).
EApply less_wdl.
Apply (H0 ? (Cle_to ?? Hj)).
Unfold fcp'; Algebra.
Assumption.
Stepr [--][--]e; Apply inv_resp_leEq.
Apply less_leEq; EApply less_wdr.
Apply Hj'.
Unfold fcp'; Algebra.
Exists (cp ? (Cle_to ?? Hk)).
Red; Apply compact_part_hyp.
Intros.
Simpl; Unfold ABSIR; Apply Max_leEq.
Apply less_leEq; EApply less_wdl.
Apply Hk'.
Unfold fcp'; Algebra.
Apply less_leEq; Apply less_transitive_unfolded with (Zero::IR).
Stepr [--](Zero::IR); Apply inv_resp_less; EApply less_wdr.
Apply (H0 ? (Cle_to ?? Hk)).
Unfold fcp'; Rational.
Assumption.
Qed.

Local Rolle_lemma15 : ((i:nat)(H:(le i n))(e[/]TwoNZ[<](AbsIR (fcp' ? H))))->
  ((fcp' ? (le_O_n n))[<][--](e[/]TwoNZ))+((e[/]TwoNZ)[<](fcp' ? (le_O_n n))).
Intro.
Cut ((e[/]TwoNZ)[<](fcp' ? (le_O_n n)))+((fcp' ? (le_O_n n))[<][--](e[/]TwoNZ)).
Intro; Inversion_clear H0; [Right | Left]; Assumption.
Apply less_AbsIR.
Apply pos_div_two; Assumption.
Apply H.
Qed.

(* Begin_Tex_Verb *)
Theorem Rolle : {x:IR & (I x) | (Hx:?)(AbsIR (F' x Hx))[<=]e}.
(* End_Tex_Verb *)
Elim Rolle_lemma9.
Exact Rolle_lemma10.
Intro.
Apply Rolle_lemma13.
Elim (Rolle_lemma15 b0).
Left; Apply Rolle_lemma11.
Assumption.
Intro.
EApply less_wdl.
Apply a0.
Unfold fcp'; Algebra.
Right; Apply Rolle_lemma12.
Assumption.
Intro.
EApply less_wdr.
Apply b1.
Unfold fcp'; Algebra.
Qed.

End Rolle.

Section Mean_Law.

(* Tex_Prose
The following is a simple corollary:
*)

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

Local Hab:=(less_leEq ??? Hab').
Local I:=(Compact Hab).

Variables F,F':PartIR.

Hypothesis HF:(Derivative_I Hab' F F').

Hypothesis HA:(Pred F a).
Hypothesis HB:(Pred F b).

(* Begin_Tex_Verb *)
Lemma Mean_Law_simple : (e:IR)(Zero[<]e)->{x:IR & (I x) | (Hx:?)
  ((AbsIR ((F b HB)[-](F a HA))[-](F' x Hx)[*](b[-]a))[<=]e)}.
(* End_Tex_Verb *)
Intros.
LetTac h:=(FId{-}({-C-}a)){*}({-C-}((F b HB)[-](F a HA))){-}F{*}({-C-}(b[-]a)).
LetTac h':=({-C-}((F b HB)[-](F a HA)){-}F'{*}({-C-}(b[-]a))).
Cut (Derivative_I Hab' h h').
Intro.
Cut {x:IR & (I x) | (Hx:?)(AbsIR (h' x Hx))[<=]e}.
Intro.
Elim H1; Intros x Ix Hx.
Exists x.
Assumption.
Intro.
EApply leEq_wdl.
Apply (Hx (derivative_imp_inc' ????? H0 x Ix)).
Apply AbsIR_wd; Simpl; Rational.
Unfold I Hab; EApply Rolle with
  h (derivative_imp_inc ????? H0 ? (compact_inc_lft ???)) (derivative_imp_inc ????? H0 ? (compact_inc_rht ???)).
Assumption.
Simpl; Rational.
Assumption.
Unfold h h'; Clear h h'.
New_Deriv.
Apply Feq_reflexive.
Apply included_FMinus; Included.
Apply eq_imp_Feq.
Apply included_FMinus.
Apply included_FPlus; Included.
Included.
Included.
Intros.
Simpl; Rational.
Qed.

End Mean_Law.

Section Corollaries.

(* Tex_Prose
We can also state these theorems without expliciting the derivative of $F$.
*)

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

Local Hab:=(less_leEq ??? Hab').
Variable F:PartIR.

(* Begin_Tex_Verb *)
Hypothesis HF:(Diffble_I Hab' F).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Theorem Rolle' : ((Ha:?)(Hb:?)((F a Ha)[=](F b Hb)))->
  (e:IR)(Zero[<]e)->{x:IR & (Compact Hab x) |
    (Hx:?)(AbsIR ((PartInt (ProjS1 HF)) x Hx))[<=]e}.
(* End_Tex_Verb *)
Intros.
Unfold Hab.
Apply Rolle with F (diffble_imp_inc ???? HF ? (compact_inc_lft a b Hab)) (diffble_imp_inc ???? HF ? (compact_inc_rht a b Hab)).
Apply projS2.
Apply H.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Mean_Law'_simple : (HA,HB:?)(e:IR)(Zero[<]e)->
  {x:IR & (Compact Hab x) | (Hx:?)
  (AbsIR ((F b HB)[-](F a HA))[-]
    ((PartInt (ProjS1 HF)) x Hx)[*](b[-]a))[<=]e}.
(* End_Tex_Verb *)
Intros.
Unfold Hab.
Apply Mean_Law_simple.
Apply projS2.
Assumption.
Qed.

End Corollaries.

Section Generalizations.

(* Tex_Prose
The mean law is more useful if we abstract $a$ and $b$ from the context---allowing them in particular to be equal.  In the case where $F(a)=F(b)$ we get Rolle's theorem again, so there is no need to state it also in this form.

\begin{convention} Assume \verb!I! is a proper interval, \verb!F,F':PartIR!.
\end{convention}
*)

Variable I:interval.
Hypothesis pI:(proper I).

Variables F,F':PartIR.
(* Begin_Tex_Verb *)
Hypothesis derF:(Derivative I pI F F').
(* End_Tex_Verb *)

Local incF:=(Derivative_imp_inc ???? derF).
Local incF':=(Derivative_imp_inc' ???? derF).

(* Begin_Tex_Verb *)
Theorem Mean_Law : (a,b:IR)(iprop I a)->(iprop I b)->
  (e:IR)(Zero[<]e)->{x:IR & (Compact (Min_leEq_Max a b) x) |
    (Ha,Hb,Hx:?)(AbsIR ((F b Hb)[-](F a Ha))[-]
                         (F' x Hx)[*](b[-]a))[<=]e}.
(* End_Tex_Verb *)
Intros a b Ha Hb e He.
Cut (included (Compact (Min_leEq_Max a b)) (iprop I)); Intros.
2: Apply included_interval'; Auto.
Elim (cotrans_less_unfolded ??? He
  (AbsIR ((F b (incF ? Hb))[-](F a (incF ? Ha)))[-](F' a (incF' ? Ha))[*](b[-]a))); Intros.
Cut (Min a b)[<](Max a b); Intros.
Cut (included (Compact (less_leEq ??? H0)) (iprop I)); Intros.
2: Apply included_interval'; Auto.
Elim (ap_imp_less ??? (Min_less_Max_imp_ap ?? H0)); Intro.
Cut (included (Compact (less_leEq ??? a1)) (iprop I)); Intros.
2: Apply included_trans with (Compact (less_leEq ??? H0)); [Apply compact_map2 | Apply H1].
Elim (Mean_Law_simple ?? a1 ?? (included_imp_Derivative ???? derF ?? a1 H2) (incF ? Ha) (incF ? Hb) e He).
Intros x H3 H4.
Exists x; Auto.
Apply compact_map2 with Hab:=(less_leEq ??? a1); Auto.
Intros.
EApply leEq_wdl.
Apply (H4 Hx).
Apply AbsIR_wd; Algebra.
Cut (included (Compact (Min_leEq_Max b a)) (Compact (Min_leEq_Max a b))); Intros.
Cut (included (Compact (less_leEq ??? b0)) (iprop I)); Intros.
2: Apply included_trans with (Compact (Min_leEq_Max b a)); [Apply compact_map2 |
  Apply included_trans with (Compact (less_leEq ??? H0)); [Apply H2 | Apply H1]].
Elim (Mean_Law_simple ?? b0 ?? (included_imp_Derivative ???? derF ?? b0 H3) (incF ? Hb) (incF ? Ha) e He).
Intros x H4 H5.
Exists x; Auto.
Apply H2; Apply compact_map2 with Hab:=(less_leEq ??? b0); Auto.
Intros.
EApply leEq_wdl.
Apply (H5 Hx).
EApply eq_transitive_unfolded.
Apply AbsIR_minus.
Apply AbsIR_wd; Rational.
Red; Intros.
Inversion_clear H2; Split.
EApply leEq_wdl; [Apply H3 | Apply Min_comm].
EApply leEq_wdr; [Apply H4 | Apply Max_comm].
Apply ap_imp_Min_less_Max.
Cut ((pfpfun ? ? (incF b Hb))[-](pfpfun ? ? (incF a Ha))[#]Zero)+((pfpfun ? ? (incF' a Ha))[*](b[-]a)[#]Zero).
Intro.
Inversion_clear H0.
Apply pfstrx with F (incF a Ha) (incF b Hb).
Apply ap_symmetric_unfolded; Apply zero_minus_apart; Auto.
Apply ap_symmetric_unfolded; Apply zero_minus_apart.
EApply cring_mult_ap_zero_op; Apply H1.
Apply cg_minus_strext.
Stepr (Zero::IR).
Apply AbsIR_cancel_ap_zero.
Apply Greater_imp_ap; Auto.
Exists a.
Apply compact_Min_lft.
Intros; Apply less_leEq.
EApply less_wdl.
Apply b0.
Apply AbsIR_wd; Algebra.
Qed.

(* Tex_Prose
We further generalize the mean law by writing as an explicit bound.
*)

(* Begin_Tex_Verb *)
Theorem Mean_Law_ineq : (a,b:IR)(iprop I a)->(iprop I b)->(c:IR)
  ((x:IR)(Compact (Min_leEq_Max a b) x)->(Hx:?)(AbsIR (F' x Hx))[<=]c)->
  (Ha,Hb:?)((F b Hb)[-](F a Ha))[<=]c[*](AbsIR b[-]a).
(* End_Tex_Verb *)
Intros a b Ia Ib c Hc Ha Hb.
Stepr c[*](AbsIR b[-]a)[+]Zero.
Apply shift_leEq_plus'.
Red; Apply approach_zero_weak.
Intros.
Elim Mean_Law with a b e; Auto.
Intros x H0 H1.
Cut (Pred F' x); Intros.
EApply leEq_transitive.
2: Apply (H1 Ha Hb H2).
EApply leEq_transitive.
2: Apply leEq_AbsIR.
Unfold 1 4 cg_minus; Apply plus_resp_leEq_lft.
Apply inv_resp_leEq.
EApply leEq_transitive.
Apply leEq_AbsIR.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_resp_mult.
Apply mult_resp_leEq_rht.
Auto.
Apply AbsIR_nonneg.
Apply (Derivative_imp_inc' ???? derF).
Exact (included_interval I a b Ia Ib (Min_leEq_Max a b) x H0).
Qed.

End Generalizations.


(** * Syntax for Object Ligics (OL).

This file defines the general requirements imposed on the syntax of
OLs to prove cut-elimination.

 *)

Require Export FLL.Misc.Hybrid.
Require Export FLL.SL.FLLTactics.
Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

(** ** Object Logic Signature *)

(** This signature includes the types for the Object Level quantifiers
as well as the definitions for the binary and unary connectives and the
quantifiers. We assume that these types will be filled in by a Coq
inductive Set, e.g.,

[OLType := nat],
[Inductive connectives := cand | cor | cimp . ], and
[Inductive quantifiers := qex | qall .
 *)

Class OLSyntax :=
  {
    OLType:Set;
    constants : Set ; (* 0 ary connectives *)
    uconnectives : Set ; (* unary connectives *)
    connectives : Set ; (* binary connectives *)
    quantifiers : Set (* quantifiers *)
  }.

(** ** Definition of the OL Syntax  *)

(** This module defines the [con] type needed in [Hybrid]. Such type
includes constructors for the atoms of the Object Logic, the binary
and unary connectives and also the quantifiers (of the object logic).
Measures and constructors for those types are also provided *)

Section OLSyntax.
  Context `{OL: OLSyntax}.

  (** Syntax of the Object logic *)
  Inductive Econ: Set :=
  | oo_cons : constants -> Econ
  | oo_un : uconnectives -> Econ
  | oo_bin : connectives -> Econ (* binary connectives *)
  | oo_q : quantifiers -> Econ (* quantifiers *)
  | oo_atom : nat -> Econ (* names for atoms *)
  | oo_term : OLType -> Econ    (* Coercion --terms *)
  .

  (** Notation for Syntax *)
  Definition uexp : Set := expr Econ.
  Definition Var : var -> uexp := (VAR Econ).
  Definition Bnd : bnd -> uexp := (BND Econ).

  (** Terms *)
  Definition t_term (t:OLType)   :=  (CON (oo_term  t)) .
  (** Atoms  *)
  Definition t_atom (id:nat) (A:uexp)  := APP (CON (oo_atom  id)) A.  (* atoms *)

    (** constants *)
  Definition t_cons (lab :constants)  := CON (oo_cons lab) .

  (* Unary connectives *)
  Definition t_ucon (lab : uconnectives) F    := APP (CON ( (oo_un lab ))) F .

  (** Binnary connectives *)
  Definition t_bin (lab : connectives) : uexp -> uexp -> uexp  :=
    fun M1:uexp => fun M2:uexp => (APP (APP (CON (oo_bin lab )) M1) M2).
  (** Quantifiers *)
  Definition t_quant (lab : quantifiers) : (uexp -> uexp) -> uexp :=
    fun M:uexp->uexp => (APP (CON (oo_q lab)) (lambda M)).

  (** *** Well-formedness conditions *)
  Inductive isOLTerm : uexp -> Prop :=
  | isOLTermT  : forall t, isOLTerm (t_term  t).

  Inductive isOLAtom : uexp -> Prop :=
  | isOLAtomAt : forall t id , isOLTerm t -> isOLAtom (t_atom id t).

  Inductive isOLConstant : uexp -> Prop :=
  | isOLCons : forall id , isOLConstant (t_cons id)
  .

  Inductive isOLFormula : uexp -> Prop :=
  | isFAtom : forall t id , isOLTerm t -> isOLFormula (t_atom id t)
  | isFCons : forall id , isOLConstant id -> isOLFormula id
  | isFUn : forall (lab : uconnectives) F ,
      isOLFormula F ->  isOLFormula ( t_ucon lab F)
  | isFBin : forall (lab : connectives) F G,
      isOLFormula F -> isOLFormula G -> isOLFormula ( t_bin lab F G)
  | isFQ : forall lab (FX : uexp -> uexp),
      uniform FX -> (forall (t:uexp), proper t -> isOLFormula (FX t)) ->
      isOLFormula (t_quant lab FX) .

  (** Well formendness conditions for lists of formulas and list of judgments *)
  Definition isOLFormulaL  L : Prop := Forall isOLFormula L.

  Hint Constructors isOLTerm isOLAtom isOLConstant isOLFormula : core.
  Hint Unfold isOLFormulaL : core.

  (* *** Complexity of OL formulas *)

  (** We count the number of constructors (CON) in the
  expression. Note that the measure of a formula is independent of the
  terms in the atoms *)

  Inductive lengthUexp : uexp -> nat -> Prop :=
  | l_Var : forall (v:var), lengthUexp (Var v) 0
  | l_t_term : forall (t:OLType), lengthUexp (t_term t) 0
  | l_t_atomU : forall (id:nat) (A:uexp), lengthUexp (t_atom id A) 1
  | l_cons : forall id, lengthUexp (t_cons id) 1
  | l_ucon : forall (lab:uconnectives) (M1:uexp) (n1:nat),
      lengthUexp M1 n1 ->  lengthUexp (t_ucon lab M1) (S n1)
  | l_tbin : forall (lab:connectives) (M1 M2:uexp) (n1 n2:nat),
      lengthUexp M1 n1 -> lengthUexp M2 n2 ->
      lengthUexp (t_bin lab M1 M2) (S (n1 + n2))
  | l_tall : forall (lab:quantifiers) (M:uexp -> uexp) (n:nat),
      uniform M -> lengthUexp (M (Var 0)) n -> lengthUexp (t_quant lab M) (S n).

  (** Some results regarding the length of formulas *)

  Lemma LengthTerm : forall F, isOLTerm F -> lengthUexp F 0.
    intros.
    inversion H;subst;clear H;constructor.
  Qed.

  Lemma LengthFormula : forall F n, isOLFormula F -> lengthUexp F n -> n > 0.
    intros.
    induction H;simpl.
    - inversion H0; lia.
    - inversion H;subst. inversion H0;lia.
    - inversion H0;subst;  lia.
    - inversion H0; lia.
    - inversion H0; lia.
  Qed.

  Lemma lengthAtom : forall id t, isOLFormula (t_atom id t)  -> lengthUexp (t_atom id t) 1.
    intros;inversion H;subst;simpl.
    inversion H1;subst;constructor.
    inversion H0;subst;constructor.
  Qed.

  Lemma lengthCons : forall id , isOLFormula (t_cons id )  -> lengthUexp (t_cons id) 1.
    intros;inversion H;subst;constructor.
  Qed.

    Lemma lengthUnary : forall lab F n , isOLFormula (t_ucon lab F) -> lengthUexp F n -> lengthUexp (t_ucon lab F) (S n).
    intros;subst;constructor;auto.
  Qed.

    Lemma lengthBin : forall lab F G n m, isOLFormula (t_bin lab F  G) -> lengthUexp F n -> lengthUexp G m -> lengthUexp (t_bin lab F G) (S (n+m)).
    intros;subst;constructor;auto.
  Qed.

  Lemma lengthAll : forall lab FX n, uniform FX -> isOLFormula (t_quant lab FX) -> lengthUexp (FX (Var 0)) n -> lengthUexp  (t_quant lab  FX) (S n).
    intros;subst.
    inversion H0;simpl;subst;constructor;auto.
  Qed.

  (** [lengthUexp] is indeed a function *)
  Lemma lengthFunction : forall n F , isOLFormula F -> lengthUexp F n -> forall n', lengthUexp F n' -> n = n'.
  Proof with auto;subst;try lia.
    induction n using strongind;intros ...
    apply LengthFormula in H0...

    inversion H0...
    inversion H1...
    inversion H2...

    inversion H3...
    inversion H2...
    inversion H1...

    inversion H2...
    inversion H1...
    assert (n = n1). eapply H with (F:= F0)...
    lia.

    inversion H2...
    inversion H1...
    assert (n0 = n1).
    eapply H with (F:= F0)...

    assert (n3 = n2).
    eapply H with (F:= G)...
    lia.

    inversion H2...
    inversion H1...
    apply lbindEq in H8...
    apply lbindEq in H6...
    assert (ext_eq FX M0).
    apply ext_eq_S_Symmetric...
    assert (ext_eq M M0).
    eapply ext_eq_trans;eauto.
    assert (proper (Var 0)) by constructor.

    assert (n = n0).
    eapply H with (F:= M0 (Var 0))...

    assert(isOLFormula (FX (Var 0))).
    apply H4 ...

    generalize (H8 (Var 0) H13);intro...
    rewrite H15...

    generalize (H10 (Var 0) H13);intro...
    rewrite H14 in H9...
    lia.
  Qed.

  Lemma lengthBinSizeL :
    forall F G C n n',
      isOLFormula F -> isOLFormula G ->
      lengthUexp (t_bin C F G) n -> lengthUexp F n' ->
      n' < n.
  Proof with auto;subst;try lia.
    intros.
    inversion H1...
    generalize (lengthFunction H H7);intros.
    apply H3 in H2...
  Qed.

  Lemma lengthBinSizeR :
    forall F G C n n', isOLFormula F -> isOLFormula G ->
                       lengthUexp (t_bin C F G) n ->
                       lengthUexp G n' ->
                       n' < n.
    Proof with auto;subst;try lia.
    intros.
    inversion H1...
    generalize (lengthFunction H0 H8);intros.
    apply H3 in H2...
    Qed.

    Lemma length1 : forall F ,
        isOLFormula F -> lengthUexp F 1 ->
        isOLAtom F \/ isOLConstant F.
  Proof with subst;auto.
    intros.
    inversion H ...
    - inversion H0...
      generalize (LengthFormula H1 H3);lia.
    - inversion H0...
      assert (n1 = 0) by lia.
      generalize (LengthFormula H2 H8);intro. lia.
    -  inversion H0 ...
       generalize (lbindEq  H6  H1 H4);intro.
       assert (proper (Var 0)). constructor.
       generalize (H3 _ H5);intro. rewrite H8 in H7.
       apply H2 in H5.
       generalize (LengthFormula H5 H7 );lia.

  Qed.

  (** Proper conditions *)

  Lemma isOLTermProper : forall t, isOLTerm t -> proper t.
    intros.
    inversion H.
    unfold t_term.
    auto with hybrid.
  Qed.

  Lemma isOLAtomProper : forall t, isOLAtom t -> proper t.
    intros.
    inversion H.
    unfold t_atom.
    inversion H0;subst.
    unfold t_term.
    auto with hybrid.
  Qed.

  Lemma isOLFormulaProper : forall F, isOLFormula F -> proper F.
  Proof with repeat constructor;auto.
    intros.
    induction H.
    - inversion H ...
    - inversion H...
    - constructor; eauto with hybrid.
    - constructor; eauto with hybrid.
    - constructor; eauto with hybrid.

  Qed.

  (** ** LL predicated needed in the encoding *)
  (** Predicates [up] (formulas on the right of the HyLL sequent) and
  [down] (formulas on the left of the HyLL sequent) *)
  Inductive atm' : Set :=
  | up' : uexp -> atm'    (* formulas on the right *)
  | down' : uexp -> atm'  (* formulas on the left *)
  .

  (** Uniform Predicate for atoms *)
  Inductive uniform_atm' : (uexp -> atm') -> Prop :=
  | uniform_up: forall FX, uniform FX -> uniform_atm' (fun x:uexp => up' (FX x))
  | uniform_down: forall FX, uniform FX -> uniform_atm' (fun x:uexp => down' (FX x))
  .
  Hint Constructors uniform_atm' : core.

  (** Well Formedness Conditions *)
  Lemma uniform_at : forall (FX:uexp->uexp),
      uniform FX -> uniform (fun x => FX x).
  Proof.
    intros.
    auto with hybrid.
  Qed.
  Hint Resolve uniform_at : core.

   Global Instance OLSyntaxIns : OLSig :=
    {|
      atm := atm';
      con := Econ ;
      uniform_atm := uniform_atm'
    |}.

   Definition up : uexp -> atm := up'.
   Definition down : uexp -> atm := down'.

End OLSyntax.

(** Notation for atoms of the form [up] and [down] *)
Notation "'u|' A '|'" := (atom (up A)) (at level 10) .
Notation "'d|' A '|'" := (atom (down A)) (at level 10) .
Notation "'u^|' A '|'" := (perp (up A)) (at level 10) .
Notation "'d^|' A '|'" := (perp (down A)) (at level 10) .


Require Import Arith.
Require Import Ascii.
Require Import Coq.Strings.Byte.
Require Import String.
Local Open Scope string_scope.

(* -------------------- Datatypes for VPL -------------------- *)
Add LoadPath "datatypes_folder".
Require Import datatypes.

(* -------------------- Variables, Environments, typeof() -------------------- *)
Add LoadPath "variables_folder".
Require Import variables.

(* -------------------- Expression Syntax -------------------- *)
Add LoadPath "val_expressions_folder".
Require Import VALexp.

(* ---------- Boolean Expression Syntax ---------- *)
Inductive boolean_expression :=
| bval : bool -> boolean_expression
| bnot : boolean_expression -> boolean_expression
| band : boolean_expression -> boolean_expression -> boolean_expression
| bor : boolean_expression -> boolean_expression -> boolean_expression
| blt : val_expression -> val_expression -> boolean_expression
| blteq : val_expression -> val_expression -> boolean_expression
| beq : val_expression -> val_expression -> boolean_expression
| bgt : val_expression -> val_expression -> boolean_expression
| bgteq : val_expression -> val_expression -> boolean_expression.

Coercion bval : bool >-> boolean_expression.

Notation "!' A" := (bnot A) (at level 75).
Notation "A 'and'' B" := (band A B) (at level 80).
Notation "A 'or'' B" := (bor A B) (at level 80).
Notation "A <' B" := (blt A B) (at level 70).
Notation "A <=' B" := (blteq A B) (at level 70).
Notation "A ==' B" := (beq A B) (at level 70).
Notation "A >' B" := (bgt A B) (at level 70).
Notation "A >=' B" := (bgteq A B) (at level 70).


(*
 * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

(** This library reexports portions of the Coq standard libraries used
    throughtout the proof.  It also defines some convenience tactics.
 *)
Require Export Bitoychain.Extensionality.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Relations.Relations.
Require Export Omega.

Definition compose (A B C:Type) (g:B -> C) (f:A -> B) := fun x => g (f x).
Arguments compose [A B C] _ _ _.
Infix "oo" := compose (at level 54, right associativity).

Lemma compose_assoc (A B C D:Type) (h:C->D) (g:B->C) (f:A->B) :
  (h oo g) oo f = h oo g oo f.
Proof.
  intros; apply extensionality; intro x; unfold compose; auto.
Qed.

Lemma compose_rewr {A B C} (f : B -> C) (g : A -> B) x : f (g x) = (f oo g) x.
Proof.
  reflexivity.
Qed.

Definition id (A:Type) := fun x:A => x.

Lemma id_unit1 : forall A B (f:A->B), f oo id A = f.
Proof.
  intros; apply extensionality; intro x; auto.
Qed.

Lemma id_unit2 : forall A B (f:A->B), id B oo f = f.
Proof.
  intros; apply extensionality; intro x; auto.
Qed.

Record bijection (A B:Type) : Type := Bijection {
  bij_f: A -> B;
  bij_g: B -> A;
  bij_fg: forall x, bij_f (bij_g x) = x;
  bij_gf: forall x, bij_g (bij_f x) = x
}.

Lemma bij_f_inj {A} {B} (bij: bijection A B):
     forall x y, bij_f _ _ bij x = bij_f _ _ bij y -> x=y.
Proof.
intros. rewrite <- (bij_gf _ _ bij x). rewrite <- (bij_gf _ _ bij y).
 rewrite H; auto.
Qed.

Lemma bij_g_inj {A} {B} (bij: bijection A B):
     forall x y, bij_g _ _ bij x = bij_g _ _ bij y -> x=y.
Proof.
intros. rewrite <- (bij_fg _ _ bij x). rewrite <- (bij_fg _ _ bij y).
 rewrite H; auto.
Qed.

Lemma bij_fg_id: forall {A B} (f: bijection A B),
  (bij_f _ _ f) oo (bij_g _ _ f) = id _.
Proof.
  intros.
  extensionality.
  unfold compose, id.
  apply bij_fg.
Qed.

Lemma bij_gf_id: forall {A B} (f: bijection A B),
  (bij_g _ _ f) oo (bij_f _ _ f) = id _.
Proof.
  intros.
  extensionality.
  unfold compose, id.
  apply bij_gf.
Qed.

Definition bij_compose {A B C:Type} (g: bijection B C) (f: bijection A B):
  bijection A C.
  refine (Bijection _ _
           ((bij_f _ _ g) oo (bij_f _ _ f))
           ((bij_g _ _ f) oo (bij_g _ _ g)) _ _).
  + intros.
    unfold compose.
    rewrite !bij_fg.
    auto.
  + intros.
    unfold compose.
    rewrite !bij_gf.
    auto.
Defined.

Infix "ooo" := bij_compose (at level 54, right associativity).

Definition bij_refl (A: Type): bijection A A.
  refine (Bijection _ _ (id _) (id _) _ _).
  + reflexivity.
  + reflexivity.
Defined.

Definition bij_sym {A B} (f: bijection A B): bijection B A.
  refine (Bijection _ _ (bij_g _ _ f) (bij_f _ _ f) _ _).
  + apply bij_gf.
  + apply bij_fg.
Defined.

Definition func_bij {A1 A2 B1 B2} (f: bijection A1 A2) (g: bijection B1 B2):
  bijection (A1 -> B1) (A2 -> B2).
  refine (Bijection _ _
            (fun F => (bij_f _ _ g) oo F oo (bij_g _ _ f))
            (fun F => (bij_g _ _ g) oo F oo (bij_f _ _ f)) _ _).
  + intros F; extensionality x.
    unfold compose; rewrite !bij_fg; auto.
  + intros F; extensionality x.
    unfold compose; rewrite !bij_gf; auto.
Defined.

Definition unit_unit1 (A: Type): bijection A (A * unit).
  refine (Bijection _ _ (fun a => (a, tt)) fst _ _).
  + intros; destruct x as [? []]; auto.
  + intros; auto.
Defined.

Definition unit_unit2 (A: Type): bijection A (unit * A).
  refine (Bijection _ _ (pair tt) snd _ _).
  + intros; destruct x as [[] ?]; auto.
  + intros; auto.
Defined.

Definition prod_bij_comm (A B: Type): bijection (A * B) (B * A).
  refine (Bijection _ _
           (fun p => (snd p, fst p))
           (fun p => (snd p, fst p)) _ _).
  + intros; destruct x; auto.
  + intros; destruct x; auto.
Defined.

(** Perform inversion on a hypothesis, removing it from the context, and
    perform substitutions
  *)
Tactic Notation "inv" hyp(H) := inversion H; clear H; subst.

Ltac detach H :=
  match goal with [ H : (?X -> ?Y) |- _ ] =>
    cut Y; [ clear H; intro H | apply H; clear H ]
  end.

(** Specialize a hypothesis with respect to specific terms or proofs. *)
Tactic Notation "spec" hyp(H) :=
  match type of H with ?a -> _ =>
    let H1 := fresh in (assert (H1: a); [|generalize (H H1); clear H H1; intro H]) end.

Tactic Notation "spec" hyp(H) constr(a) :=
  (generalize (H a); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) :=
  (generalize (H a b); clear H; intro H).

 Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) :=
  (generalize (H a b c); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) :=
  (generalize (H a b c d); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) :=
  (generalize (H a b c d e); clear H; intro H).

(* Some further tactics, from Barrier Project *)

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) :=
  (generalize (H a b c d e f); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) :=
  (generalize (H a b c d e f g); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) :=
  (generalize (H a b c d e f g h); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) :=
  (generalize (H a b c d e f g h i); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) constr(l) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) constr(l) constr(m) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) constr(l) constr(m) constr(n) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) constr(l) constr(m) constr(n) constr(o) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "spec" hyp(H) constr(a) constr(b) constr(c) constr(d) constr(e) constr(f) constr(g) constr(h) constr(i) constr(j) constr(k) constr(l) constr(m) constr(n) constr(o) constr(p) :=
  (generalize (H a b c d e f g h i j); clear H; intro H).

Tactic Notation "disc" := (try discriminate).

Tactic Notation "contr" := (try contradiction).

Tactic Notation "congr" := (try congruence).

Tactic Notation  "icase" constr(v) := (destruct v; disc; contr; auto).

Tactic Notation "omegac" := (elimtype False; omega).

Tactic Notation "copy" hyp(H) := (generalize H; intro).