From Coq Require Import ClassicalChoice Program.Subset.
From ZornsLemma Require Import EnsemblesTactics Finite_sets Powerset_facts.
From Topology Require Export TopologicalSpaces Nets FilterLimits Homeomorphisms SeparatednessAxioms SubspaceTopology.
From Topology Require Import FiltersAndNets.
Set Asymmetric Patterns.

Definition compact (X:TopologicalSpace) :=
  forall C:Family X,
    (forall U:Ensemble X, In C U -> open U) ->
    FamilyUnion C = Full_set ->
    exists C':Family X,
      Finite C' /\ Included C' C /\
      FamilyUnion C' = Full_set.

Lemma compactness_on_indexed_covers:
  forall (X:TopologicalSpace) (A:Type) (C:IndexedFamily A X),
    compact X ->
    (forall a:A, open (C a)) -> IndexedUnion C = Full_set ->
  exists A':Ensemble A, Finite A' /\
    IndexedUnion (fun a':{a':A | In A' a'} => C (proj1_sig a')) = Full_set.
Proof.
intros.
pose (cover := ImageFamily C).
destruct (H cover) as [subcover].
{ intros.
  destruct H2.
  rewrite H3; apply H0.
}
{ unfold cover.
  now rewrite <- indexed_to_family_union.
}
destruct H2 as [? []].
destruct (finite_choice _ _
  (fun (U:{U:Ensemble X | In subcover U}) (a:A) =>
      proj1_sig U = C a)) as [choice_fun].
{ now apply Finite_ens_type. }
{ destruct x as [U].
  simpl.
  apply H3 in i.
  destruct i.
  now exists x.
}
exists (Im Full_set choice_fun).
split.
- apply FiniteT_img.
  + now apply Finite_ens_type.
  + intros; apply classic.
- extensionality_ensembles.
  { constructor. }
  assert (In Full_set x) by constructor.
  rewrite <- H4 in H6.
  destruct H6.
  assert (In (Im Full_set choice_fun) (choice_fun (exist _ S H6))).
  { exists (exist _ S H6); constructor. }
  exists (exist _ (choice_fun (exist _ S H6)) H8).
  simpl.
  now rewrite <- H5.
Qed.

Lemma compact_finite_nonempty_closed_intersection:
  forall X:TopologicalSpace, compact X ->
  forall F:Family X,
    (forall G:Ensemble X, In F G -> closed G) ->
    (forall F':Family X, Finite F' -> Included F' F ->
     Inhabited (FamilyIntersection F')) ->
    Inhabited (FamilyIntersection F).
Proof.
intros.
apply NNPP; red; intro.
pose (C := [ U:Ensemble X | In F (Complement U) ]).
specialize (H C) as [C' [? [? ?]]].
{ intros.
  destruct H.
  apply H0 in H.
  now apply closed_complement_open.
}
{ extensionality_ensembles.
  { constructor. }
  apply NNPP; red; intro.
  contradict H2.
  exists x.
  constructor.
  intros.
  apply NNPP; red; intro.
  contradict H.
  exists (Complement S).
  + constructor.
    now rewrite Complement_Complement.
  + assumption.
}
pose (F' := [G : Ensemble X | In C' (Complement G)]).
specialize (H1 F') as [x0].
{ cut (F' = Im C' Complement).
  { intros. rewrite H1.
    now apply finite_image.
  }
  apply Extensionality_Ensembles; split; red; intros.
  - exists (Complement x).
    + apply H1.
    + now rewrite Complement_Complement.
  - constructor.
    inversion H1; subst; clear H1.
    now rewrite Complement_Complement.
}
{ red; intros.
  destruct H1.
  apply H3 in H1 as [].
  now rewrite Complement_Complement in H1.
}
destruct H1.
assert (In (FamilyUnion C') x).
{ rewrite H4. constructor. }
destruct H5.
assert (In (Complement S) x).
{ apply H1.
  constructor.
  now rewrite Complement_Complement.
}
contradiction H7.
Qed.

Lemma finite_nonempty_closed_intersection_impl_compact:
  forall X:TopologicalSpace,
  (forall F:Family X,
    (forall G:Ensemble X, In F G -> closed G) ->
    (forall F':Family X, Finite F' -> Included F' F ->
     Inhabited (FamilyIntersection F')) ->
    Inhabited (FamilyIntersection F)) ->
  compact X.
Proof.
intros.
red; intros.
apply NNPP; red; intro.
pose (F := [ G:Ensemble X | In C (Complement G) ]).
specialize (H F) as [x].
{ intros.
  destruct H.
  apply H0 in H.
  assumption.
}
2: {
  apply H2.
  assert (In (FamilyUnion C) x).
  { rewrite H1. constructor. }
  destruct H3.
  assert (In (Complement S) x); try contradiction.
  destruct H.
  apply H.
  constructor.
  now rewrite Complement_Complement.
}
intros.
apply NNPP; red; intro.
contradiction H2.
exists [ U:Ensemble X | In F' (Complement U) ].
repeat split.
- replace [U:Ensemble X | In F' (Complement U)] with (Im F' Complement).
  { now apply finite_image. }
  extensionality_ensembles.
  + subst. constructor.
    now rewrite Complement_Complement.
  + econstructor.
    * eassumption.
    * now rewrite Complement_Complement.
- red; intros.
  destruct H5.
  apply H3 in H5.
  destruct H5.
  now rewrite Complement_Complement in H5.
- extensionality_ensembles.
  { constructor. }
  apply NNPP; red; intro.
  contradict H4.
  exists x.
  constructor.
  intros.
  apply NNPP; red; intro.
  contradict H5.
  exists (Complement S).
  + constructor.
    rewrite Complement_Complement; trivial.
  + exact H6.
Qed.

Lemma compact_impl_filter_cluster_point:
  forall X:TopologicalSpace, compact X ->
    forall F:Filter X, exists x0:X,
    filter_cluster_point F x0.
Proof.
intros.
pose proof (compact_finite_nonempty_closed_intersection
  _ H [ G:Ensemble X | In (filter_family F) G /\
                                   closed G ]) as [x0].
- intros.
  destruct H0 as [[]]; trivial.
- intros.
  assert (closed (FamilyIntersection F')).
{ apply closed_family_intersection.
  intros.
  apply H1 in H2.
  now destruct H2, H2. }
  assert (In (filter_family F) (FamilyIntersection F')).
{ clear H2.
  induction H0.
  - rewrite empty_family_intersection.
    apply filter_full.
  - replace (FamilyIntersection (Add A x)) with
      (Intersection (FamilyIntersection A) x).
    + apply filter_intersection.
      * apply IHFinite.
        auto with sets.
      * assert (In (Add A x) x).
      { right. constructor. }
        apply H1 in H3.
        now destruct H3, H3.
    + extensionality_ensembles.
      * constructor.
        intros.
        destruct H5.
        ** now apply H3.
        ** now destruct H5.
      * repeat constructor; intros; apply H3; auto with sets. }

  apply NNPP; intro.
  contradiction (filter_empty _ F).
  replace (@Empty_set X) with (FamilyIntersection F'); trivial.
  extensionality_ensembles.
  contradiction H4.
  exists x.
  now constructor.
- exists x0.
  red; intros.
  destruct H0.
  apply H0.
  constructor.
  split.
  + apply filter_upward_closed with S; trivial.
    apply closure_inflationary.
  + apply closure_closed.
Qed.

Lemma filter_cluster_point_impl_compact:
  forall X:TopologicalSpace,
    (forall F:Filter X, exists x0:X,
      filter_cluster_point F x0) -> compact X.
Proof.
intros.
apply finite_nonempty_closed_intersection_impl_compact.
intros.
unshelve refine (let H2:=_ in let filt := Build_Filter_from_subbasis F H2 in _).
- intros.
  rewrite indexed_to_family_intersection.
  apply H1.
  + apply FiniteT_img; trivial.
    intros.
    apply classic.
  + red; intros.
    destruct H4.
    rewrite H5; apply H3.
- assert (filter_subbasis filt F) by apply filter_from_subbasis_subbasis.
  destruct (H filt) as [x0].
  exists x0.
  constructor; intros.
  assert (closed S) by now apply H0.
  assert (In (filter_family filt) S).
{ eapply filter_subbasis_elements; eassumption. }
  pose proof (H4 _ H7).
  now rewrite closure_fixes_closed in H8.
Qed.

Lemma ultrafilter_limit_impl_compact:
  forall X:TopologicalSpace,
    (forall U:Filter X, ultrafilter U ->
      exists x0:X, filter_limit U x0) -> compact X.
Proof.
intros.
apply filter_cluster_point_impl_compact.
intros.
destruct (ultrafilter_extension F) as [U].
destruct H0.
destruct (H _ H1) as [x0].
exists x0.
red; intros.
apply filter_limit_is_cluster_point in H2.
apply H0 in H3.
now apply H2.
Qed.

Lemma compact_impl_net_cluster_point:
  forall X:TopologicalSpace, compact X ->
    forall (I:DirectedSet) (x:Net I X), inhabited (DS_set I) ->
    exists x0:X, net_cluster_point x x0.
Proof.
intros.
destruct (compact_impl_filter_cluster_point
  _ H (tail_filter x H0)) as [x0].
exists x0.
apply tail_filter_cluster_point_impl_net_cluster_point with H0.
apply H1.
Qed.

Lemma net_cluster_point_impl_compact: forall X:TopologicalSpace,
  (forall (I:DirectedSet) (x:Net I X), inhabited (DS_set I) ->
    exists x0:X, net_cluster_point x x0) ->
  compact X.
Proof.
intros.
apply filter_cluster_point_impl_compact.
intros.
destruct (H _ (filter_to_net _ F)) as [x0].
- cut (inhabited X).
  + intro.
    destruct H0 as [x].
    exists.
    simpl.
    apply Build_filter_to_net_DS_set with Full_set x.
    * apply filter_full.
    * constructor.
  + apply NNPP; intro.
    contradiction (filter_empty _ F).
    replace (@Empty_set X) with (@Full_set X).
    * apply filter_full.
    * extensionality_ensembles.
      contradiction H0.
      now constructor.
- exists x0.
  now apply filter_to_net_cluster_point_impl_filter_cluster_point.
Qed.

Lemma compact_closed: forall (X:TopologicalSpace)
  (S:Ensemble X), Hausdorff X ->
  compact (SubspaceTopology S) -> closed S.
Proof.
intros.
destruct (classic (Inhabited S)).
2: {
  red.
  rewrite (not_inhabited_empty _ H1).
  rewrite Complement_Empty_set.
  apply open_full.
}
replace S with (closure S).
{ apply closure_closed. }
apply Extensionality_Ensembles; split; red; intros.
2: {
  apply closure_inflationary. assumption.
}
destruct (net_limits_determine_topology _ _ H2) as [I0 [y []]].
pose (yS (i:DS_set I0) := exist (fun x:X => In S x) (y i) (H3 i)).
assert (inhabited (SubspaceTopology S)).
{ destruct H1.
  constructor.
  now exists x0.
}
assert (inhabited (DS_set I0)) as HinhI0.
{ red in H4.
  destruct (H4 Full_set) as [i0]; auto with topology.
  constructor.
}
pose proof (compact_impl_net_cluster_point
  (SubspaceTopology S) H0 _ yS HinhI0).
destruct H6 as [[x0]].
apply net_cluster_point_impl_subnet_converges in H6.
2: {
  destruct (H4 Full_set).
  - apply open_full.
  - constructor.
  - now constructor.
}
destruct H6 as [J [y' []]].
destruct H6.
assert (net_limit (fun j:DS_set J => y (h j)) x0).
{ apply continuous_func_preserves_net_limits with
  (f:=subspace_inc S) (Y:=X) in H7.
  - assumption.
  - apply continuous_func_continuous_everywhere, subspace_inc_continuous. }
assert (net_limit (fun j:DS_set J => y (h j)) x).
{ apply subnet_limit with I0 y; trivial.
  now constructor. }
assert (x = x0).
{ eapply Hausdorff_impl_net_limit_unique; eassumption. }
now subst.
Qed.

(* Every closed subset of a compact space is compact, but avoid
   mentioning the subspace topology. *)
Lemma closed_compact_ens (X : TopologicalSpace) (S : Ensemble X) :
  compact X -> closed S ->
  forall F : Family X,
    (forall U, In F U -> open U) ->
    Included S (FamilyUnion F) ->
    exists C,
      Finite C /\ Included C F /\
        Included S (FamilyUnion C).
Proof.
  intros X_compact S_closed cover_of_S cover_open cover_covers.
  specialize (X_compact (Union cover_of_S (Singleton (Complement S))))
    as [fincover [Hfincover0 [Hfincover1 Hfincover2]]].
  { intros. destruct H; auto.
    destruct H. auto.
  }
  { rewrite family_union_union.
    rewrite family_union_singleton.
    apply union_complement_included_l.
    assumption.
  }
  exists (Intersection cover_of_S fincover); repeat split.
  - apply Intersection_preserves_finite.
    assumption.
  - intros U HU.
    apply Intersection_decreases_l in HU.
    assumption.
  - intros x Hx.
    assert (In (FamilyUnion fincover) x).
    { rewrite Hfincover2. constructor. }
    destruct H. exists S0; auto.
    split; auto.
    apply Hfincover1 in H.
    destruct H.
    2: {
      destruct H; contradiction.
    }
    assumption.
Qed.

Lemma closed_compact: forall (X:TopologicalSpace) (S:Ensemble X),
  compact X -> closed S -> compact (SubspaceTopology S).
Proof.
intros.
apply net_cluster_point_impl_compact.
intros.
destruct (compact_impl_net_cluster_point _ H
  _ (fun i:DS_set I => subspace_inc _ (x i))) as [x0]; trivial.
assert (In S x0).
{ rewrite <- (closure_fixes_closed S); trivial.
  eapply net_cluster_point_in_closure;
[ | eassumption ].
  destruct H1 as [i0].
  exists i0.
  intros.
  now destruct (x j). }
exists (exist _ x0 H3).
red; intros.
red; intros.
rewrite subspace_open_char in H4.
destruct H4 as [V []].
rewrite H6 in H5.
destruct H5.
simpl in H5.
destruct (H2 V H4 H5 i) as [j []]; trivial.
exists j; split; trivial.
rewrite H6.
now constructor.
Qed.

Lemma compact_image: forall {X Y:TopologicalSpace}
  (f:X->Y),
  compact X -> continuous f -> surjective f -> compact Y.
Proof.
intros.
red; intros.
pose (B := fun U:{U:Ensemble Y | In C U} =>
           inverse_image f (proj1_sig U)).
destruct (compactness_on_indexed_covers _ _ B H) as [subcover].
{ destruct a as [U].
  now apply H0, H2.
}
{ extensionality_ensembles.
  { constructor. }
  assert (In (FamilyUnion C) (f x)).
  { rewrite H3; constructor. }
  inversion_clear H4 as [V].
  exists (exist _ V H5).
  now constructor.
}
exists (Im subcover (@proj1_sig _ (fun U:Ensemble Y => In C U))).
destruct H4.
repeat split.
- now apply finite_image.
- intros V ?.
  destruct H6 as [[U]].
  now subst.
- apply Extensionality_Ensembles; split; red; intros y ?.
  { constructor. }
  destruct (H1 y) as [x].
  assert (In (IndexedUnion
    (fun a':{a' | In subcover a'} => B (proj1_sig a'))) x).
  { rewrite H5; constructor. }
  destruct H8 as [[[U]]].
  exists U.
  + now exists (exist _ U i).
  + destruct H8.
    now subst.
Qed.

Lemma compact_Hausdorff_impl_T3_sep: forall X:TopologicalSpace,
  compact X -> Hausdorff X -> T3_sep X.
Proof.
intros X HX_compact HX_Hausdorff.
split.
{ now apply Hausdorff_impl_T1_sep. }
intros x F HF HFx.
pose (P := fun y => (fun p : Ensemble X * Ensemble X =>
                    open (fst p) /\ open (snd p) /\
                      Intersection (fst p) (snd p) = Empty_set /\
                      In (fst p) x /\ In (snd p) y)).
pose (cover_of_F := fun V => exists U y, In (P y) (U, V)).

assert (forall V, In cover_of_F V -> open V) as Hcover_open.
{ intros V HV.
  destruct HV as [U [y []]].
  intuition.
}
destruct (closed_compact_ens X F HX_compact HF cover_of_F) as
  [fincover [Hfincover0 [Hfincover1 Hfincover2]]]; auto.
{ intros y Hy.
  specialize (HX_Hausdorff x y) as [U [V [HU [HV [HUx [HVx0]]]]]].
  { intros ?. subst. contradiction. }
  exists V; auto.
  exists U, y.
  repeat split; auto.
}

(* recover the corresponding sets *)
destruct (finite_ens_pair_choice
            fincover (fun V U => exists y, In (P y) (U, V)))
  as [fincomplement [Hfincomplement0 [Hfincomplement1 Hfincomplement2]]];
  auto.
(* finish the proof *)
exists (FamilyIntersection fincomplement), (FamilyUnion fincover).
repeat split; auto using open_family_union.
1: apply open_finite_family_intersection; auto.
(* the other properties follow from [Hfincomplement2] and the def. of [P] *)
1,2: intros V H0; specialize (Hfincomplement2 V H0) as [? [? [? []]]];
  intuition.

(* disjointness needs some work *)
apply Extensionality_Ensembles; split;
  auto with sets; red; intros.
destruct H. destruct H. destruct H0 as [S ? HS_fincover].
specialize (Hfincomplement1 S HS_fincover)
  as [U [? [y []]]].
intuition. simpl in *.
specialize (H U H1).
rewrite <- H3.
split; assumption.
Qed.

Lemma compact_Hausdorff_impl_normal_sep: forall X:TopologicalSpace,
  compact X -> Hausdorff X -> normal_sep X.
Proof.
intros X HX_compact HX_Hausdorff.
apply compact_Hausdorff_impl_T3_sep in HX_Hausdorff as [HX_T1 HX_regular];
  try assumption.
split; try assumption.
intros F G HF_closed HG_closed HFG_disjoint.
pose (P := fun y => (fun p : Ensemble X * Ensemble X =>
                    open (fst p) /\ open (snd p) /\
                      Intersection (fst p) (snd p) = Empty_set /\
                      In (fst p) y /\ Included G (snd p))).
pose (cover_of_F := fun U => exists V y, In (P y) (U, V)).

assert (forall U, In cover_of_F U -> open U) as Hcover_open.
{ intros U HU.
  destruct HU as [V [y []]].
  intuition.
}
destruct (closed_compact_ens X F HX_compact HF_closed cover_of_F) as
  [fincover [Hfincover0 [Hfincover1 Hfincover2]]]; auto.
{ intros y Hy.
  specialize (HX_regular y G) as [U [V [HU [HV [HUx [HVx0]]]]]];
    auto.
  { intros ?.
    assert (In Empty_set y); try contradiction.
    rewrite <- HFG_disjoint; split; assumption.
  }
  exists U; auto.
  exists V, y.
  repeat split; auto.
}

destruct (finite_ens_pair_choice
            fincover (fun U V => exists y, In (P y) (U, V)))
  as [fincomplement [Hfincomplement0 [Hfincomplement1 Hfincomplement2]]];
  auto.
exists (FamilyUnion fincover), (FamilyIntersection fincomplement).
repeat split; auto using open_family_union.
1: apply open_finite_family_intersection; auto.
1,2: intros V H0; specialize (Hfincomplement2 V H0) as [? [? [? []]]];
  intuition.

apply Extensionality_Ensembles; split;
  auto with sets; red; intros.
destruct H. destruct H0. destruct H as [S ? HS_fincover].
specialize (Hfincomplement1 S HS_fincover)
  as [U [? [y []]]].
intuition. simpl in *.
specialize (H0 U H1).
rewrite <- H3.
split; assumption.
Qed.

Lemma topological_property_compact :
  topological_property compact.
Proof.
  intros X Y f [g Hcont_f Hcont_g Hgf Hfg] Hcomp F H eq.
  destruct (Hcomp (inverse_image (inverse_image g) F)) as [F' [H1 [H2 H3]]].
  - intros.
    rewrite <- (inverse_image_id_comp Hgf).
    apply Hcont_f, H.
    now destruct H0.
  - erewrite <- inverse_image_full,
             <- (inverse_image_id_comp Hgf (FamilyUnion _)).
    f_equal.
    now rewrite <- (inverse_image_family_union F Hgf),
               inverse_image_id_comp.
  - exists (inverse_image (inverse_image f) F').
    split; [|split].
    + apply inverse_image_finite; trivial.
      intro y.
      exists (g y).
      now rewrite Hfg.
    + intros S [Hin].
      destruct (H2 _ Hin) as [H0].
      now rewrite inverse_image_id_comp in H0.
    + rewrite <- (inverse_image_family_union _ Hfg Hgf), H3.
      apply inverse_image_full.
Qed.

Lemma finite_topology_compact (X : TopologicalSpace) :
  Finite (@open X) -> compact X.
Proof.
  intros.
  red. intros.
  exists C. repeat split; auto with sets.
  apply Finite_downward_closed with (A := open); assumption.
Qed.

Lemma compact_image_ens {X Y : TopologicalSpace} (f : X -> Y)
      (U : Ensemble X) :
  continuous f ->
  compact (SubspaceTopology U) ->
  compact (SubspaceTopology (Im U f)).
Proof.
  intros.
  unshelve eapply (@compact_image (SubspaceTopology U)).
  { refine (fun p => exist _ (f (proj1_sig p)) _).
    apply Im_def. apply proj2_sig.
  }
  1: assumption.
  { apply subspace_continuous_char.
    unfold compose. simpl.
    apply (continuous_composition f).
    - assumption.
    - apply subspace_inc_continuous.
  }
  intros [y Hy].
  inversion Hy; subst.
  exists (exist _ x H1).
  simpl.
  apply subset_eq. reflexivity.
Qed.

(* Every bijective map from a compact space to a Hausdorff space is a homeomorphism.
   Proof taken from Munkres, 2ed. Theorem 26.6
*)
Lemma compact_hausdorff_homeo {X Y : TopologicalSpace} (f : X -> Y) :
  compact X -> Hausdorff Y -> bijective f -> continuous f ->
  homeomorphism f.
Proof.
  intros.
  apply bijective_impl_invertible in H1.
  destruct H1 as [g Hgf Hfg].
  exists g; auto.
  apply continuous_closed.
  intros.
  assert (compact (SubspaceTopology U)) as HU_compact.
  { apply closed_compact; auto. }
  replace (inverse_image g U) with (Im U f).
  2: {
    extensionality_ensembles; subst.
    - constructor. rewrite Hgf. assumption.
    - exists (g x); auto.
  }
  apply compact_closed; auto.
  apply compact_image_ens; assumption.
Qed.


Set Implicit Arguments.

Require Import Coq.Lists.List.

Section TopSection.

  Fixpoint app_all A (ls : list (list A)) :=
    match ls with
      | nil => nil
      | x :: xs => x ++ app_all xs
    end.

  Definition Disjoint A (ls1 ls2 : list A) := forall e : A, ~ (In e ls1 /\ In e ls2).

  Definition IsInjection A B (f : A -> B) := forall x y, x <> y -> f x <> f y.

  Definition Injective A B (f : A -> B) := forall x1 x2, f x1 = f x2 -> x1 = x2.

  Lemma Injective_IsInjection A B (f : A -> B) : Injective f -> IsInjection f.
  Proof.
    unfold Injective, IsInjection in *; intuition.
  Qed.

  Variable t : Type.
  Variable B : Type.

  Implicit Types ls : list t.
  Implicit Types f : t -> B.
  Implicit Types x y e a : t.

  Lemma map_app_all : forall f lsls, map f (app_all lsls) = app_all (map (fun ls => map f ls) lsls).
    induction lsls; simpl; intros; eauto.
    rewrite map_app; f_equal; eauto.
  Qed.

  Require Import Coq.Bool.Sumbool.
  Require Import Bedrock.Platform.Cito.GeneralTactics.

  Lemma find_spec : forall (f : t -> bool) ls a, find f ls = Some a -> f a = true /\ In a ls.
    induction ls; simpl; intuition; try discriminate;
    (destruct (sumbool_of_bool (f a));
     [rewrite e in H; injection H; intros; subst; eauto |
      rewrite e in H; eapply IHls in H; openhyp; eauto]).
  Qed.

  Lemma find_spec_None : forall (f : t -> bool) ls, List.find f ls = None -> ~ exists a, List.In a ls /\ f a = true.
    induction ls; simpl; intuition.
    openhyp; intuition.
    openhyp.
    subst.
    rewrite H1 in H.
    intuition.
    eapply IHls.
    discriminate.
    discriminate.
    destruct (f a); intuition.
    discriminate.
    eapply H2.
    eexists; split; eauto.
  Qed.

  Lemma In_app_all_intro : forall lsls ls e, In e ls -> In ls lsls -> In e (app_all lsls).
    induction lsls; simpl; intros.
    eauto.
    openhyp.
    subst.
    eapply in_or_app.
    eauto.
    eapply in_or_app.
    right.
    eauto.
  Qed.

  Lemma In_app_all_elim : forall lsls x, In x (app_all lsls) -> exists ls, In x ls /\ In ls lsls.
    induction lsls; simpl; intros.
    intuition.
    eapply in_app_or in H.
    openhyp.
    eexists.
    eauto.
    eapply IHlsls in H.
    openhyp.
    eexists; eauto.
  Qed.

  Lemma Disjoint_symm : forall ls1 ls2, Disjoint ls1 ls2 -> Disjoint ls2 ls1.
    unfold Disjoint; intros; firstorder.
  Qed.

  Lemma Disjoint_incl : forall ls1 ls2 ls1' ls2', Disjoint ls1 ls2 -> incl ls1' ls1 -> incl ls2' ls2 -> Disjoint ls1' ls2'.
    unfold Disjoint, incl; intros; firstorder.
  Qed.

  Lemma incl_map : forall f ls1 ls2, incl ls1 ls2 -> incl (map f ls1) (map f ls2).
    unfold incl.
    intros.
    eapply in_map_iff in H0.
    openhyp.
    subst.
    eapply H in H1.
    eapply in_map_iff.
    eexists.
    eauto.
  Qed.

  Lemma Disjoint_map : forall f ls1 ls2, Disjoint (map f ls1) (map f ls2) -> Disjoint ls1 ls2.
    unfold Disjoint; intros.
    intuition.
    eapply H.
    split; eapply in_map; eauto.
  Qed.

  Lemma Injection_NoDup : forall f ls, IsInjection f -> NoDup ls -> NoDup (map f ls).
    unfold IsInjection.
    induction ls; simpl; intros.
    econstructor.
    inversion H0; subst.
    econstructor.
    intuition.
    contradict H3.
    eapply in_map_iff in H1.
    openhyp.
    eapply H in H1.
    intuition.
    intros.
    subst.
    inversion H0; subst.
    contradiction.
    eapply IHls.
    eauto.
    eauto.
  Qed.

  Lemma NoDup_app : forall ls1 ls2, NoDup ls1 -> NoDup ls2 -> Disjoint ls1 ls2 -> NoDup (ls1 ++ ls2).
    unfold Disjoint.
    induction ls1; simpl; intros.
    eauto.
    econstructor.
    intuition.
    eapply in_app_or in H2.
    openhyp.
    inversion H; subst.
    contradiction.
    eapply H1.
    eauto.
    eapply IHls1.
    inversion H; subst.
    eauto.
    eauto.
    intros.
    firstorder.
  Qed.

End TopSection.

Require Import Coq.Bool.Bool.

Local Open Scope bool_scope.

Fixpoint forall2 A B (pred : A -> B -> bool) ls1 ls2 :=
  match ls1, ls2 with
    | a :: ls1', b :: ls2' => pred a b && forall2 pred ls1' ls2'
    | nil, nil => true
    | _, _ => false
  end.

Lemma forall2_sound A B pred (P : A -> B -> Prop) : (forall a b, pred a b = true -> P a b) -> forall ls1 ls2, forall2 pred ls1 ls2 = true -> List.Forall2 P ls1 ls2.
Proof.
  intros Hs.
  induction ls1; destruct ls2; simpl; try solve [intros; try discriminate; intuition].
  intros Hp; eapply andb_true_iff in Hp.
  openhyp; econstructor; eauto.
Qed.


Require Import Logic.Description Classical_sets Reals Lra Lia.
From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(****************************************************************************************)

Lemma S_addn : forall n:nat, n.+1 = (n+1)%N.
Proof.
    by rewrite /addn /addn_rec; lia.
Qed.

Lemma iota_rcons : forall (m n : nat), rcons (iota m n) (m+n) = iota m (n+1).
Proof.
 by move => m n; rewrite -(cats0 (rcons _ _)) cat_rcons iotaD.
Qed.

Lemma iota_pttn : forall (n m : nat),
 [seq k | j <- iota 0 n, k <- iota (j*m) m] = iota 0 (n*m).
Proof.
 move => n; elim n => [// | p IHp].
 move => m.
 rewrite mulSn addnC iotaD add0n.
 rewrite -IHp.
 rewrite -flatten_rcons -(map_id (iota (p*m) m)) -map_rcons.
 by rewrite iota_rcons addn1.
Qed.

Lemma pairmap_pair1 : forall (T:Type) (n:nat) (f : nat -> T),
  pairmap (fun u v : T => (v,u)) (head (f 0) (mkseq f n.+1)) (behead (mkseq f n.+1))
    = [ seq (f i.+1, f i) | i <- seq.iota 0 n].
Proof.
  move => T; case => // p f.
  apply eq_from_nth with (x0 := (f 0, f 0));
    [ rewrite size_pairmap size_behead size_mkseq size_map size_iota; lia| ].
  case => //.
  case => [| j].
  - rewrite size_pairmap size_behead size_mkseq Nat.pred_succ => /ltP Hp.
    have Hp' : (0 < p)%coq_nat by lia.
    rewrite /=.
    rewrite (nth_pairmap (f 0)); [| by rewrite size_map size_iota; apply /ltP].
    rewrite !(nth_map 0); [| by rewrite size_iota; apply /ltP ..].
      by rewrite !nth_iota; [| by apply /ltP ..].
  - rewrite size_pairmap size_behead size_mkseq Nat.pred_succ => /ltP Hp.
    have Hj' : (j.+1 < p)%coq_nat by lia.
    rewrite /=.
    rewrite (nth_pairmap (f 0)) /=; [| by rewrite size_map size_iota; apply /ltP].
    rewrite !(nth_map 0); [| rewrite size_iota; apply /ltP; lia ..].
      by rewrite !nth_iota; [| apply /ltP; lia ..].
Qed.

Lemma pairmap_pair2 : forall (T:Type) (n:nat) (f : nat -> T),
  pairmap (fun u v : T => (v,v)) (head (f 0) (mkseq f n.+1)) (behead (mkseq f n.+1))
    = [ seq (f i.+1, f i.+1) | i <- seq.iota 0 n].
Proof.
  move => T; case => // p f.
  apply eq_from_nth with (x0 := (f 0, f 0));
    [ rewrite size_pairmap size_behead size_mkseq size_map size_iota; lia| ].
  case => //.
  case => [| j].
  - rewrite size_pairmap size_behead size_mkseq Nat.pred_succ => /ltP Hp.
    have Hp' : (0 < p)%coq_nat by lia.
    rewrite /=.
    rewrite (nth_pairmap (f 0)); [| by rewrite size_map size_iota; apply /ltP].
    rewrite !(nth_map 0); [| by rewrite size_iota; apply /ltP ..].
      by rewrite !nth_iota; [| by apply /ltP ..].
  - rewrite size_pairmap size_behead size_mkseq Nat.pred_succ => /ltP Hp.
    have Hj' : (j.+1 < p)%coq_nat by lia.
    rewrite /=.
    rewrite (nth_pairmap (f 0)) /=; [| by rewrite size_map size_iota; apply /ltP].
    rewrite !(nth_map 0); [| rewrite size_iota; apply /ltP; lia ..].
      by rewrite !nth_iota; [| apply /ltP; lia ..].
Qed.

Lemma INR_Ztonat_IZR : forall m:Z, (0 <= m)%Z -> INR (Z.to_nat m) = IZR m.
Proof.
  move => m Hm.
  rewrite INR_IZR_INZ.
  rewrite Z2Nat.id //.
Qed.

(****************************************************************************************)

From Coquelicot Require Import Coquelicot.

Coercion INR : nat >-> R.
Coercion IZR : Z >-> R.

Open Scope R_scope.

Infix ".^" := pow (at level 30, right associativity).
Infix "^" := Rpower : R_scope.

Reserved Notation "\Rsum_ ( m <= k < n | P ) F"
  (at level 41, F at level 41, k, m, n at level 50,
           format "'[' \Rsum_ ( m <= k < n | P ) '/  '  F ']'").
Reserved Notation "\Rsum_ ( m <= k < n ) F"
  (at level 41, F at level 41, k, m, n at level 50,
           format "'[' \Rsum_ ( m <= k < n ) '/  '  F ']'").
Notation "\Rsum_ ( m <= k < n | P ) F" :=
  (\big[Rplus/0]_(m <= k < n | P%B) F%R) : R_scope.
Notation "\Rsum_ ( m <= k < n ) F" :=
  (\big[Rplus/0]_(m <= k < n) F%R) : R_scope.

(* basic arithmetic *)

Lemma leastN : forall P : Ensemble nat,
  (exists n, P n) -> { m:nat | P m /\ forall n:nat, P n -> (m <= n)%coq_nat }.
Proof.
  move => P HPinh.
  case: (LPO P).
  - move => n; apply classic.
  - move => HPn.
    apply constructive_definite_description.
    apply dec_inh_nat_subset_has_unique_least_element; [move => n; apply classic | done].
  - move => HnotPn.
    exists 0%N.
    destruct HPinh as [n HPn].
      by contradict HPn.
Qed.

Lemma Rplus_assoc' : forall r1 r2 r3 : R, r1 + (r2 + r3) = r1 + r2 + r3.
Proof.
 by move=> r1 r2 r3; rewrite Rplus_assoc.
Qed.

Canonical Rplus_monoid := Monoid.Law Rplus_assoc' Rplus_0_l Rplus_0_r.
Canonical Rplus_monoid_RplusComm := Monoid.ComLaw Rplus_comm.
Canonical Rplus_monoid_Rmult := Monoid.MulLaw Rmult_0_l Rmult_0_r.
Canonical Rplus_monoid_RDistr := Monoid.AddLaw Rmult_plus_distr_r Rmult_plus_distr_l.

Lemma pos_neq0 : forall x:R, 0 < x -> x <> 0.
Proof.
 move => x; apply (Rgt_not_eq x 0).
Qed.

Hint Resolve pos_neq0 : core.

Lemma neg_neq0 : forall x:R, x < 0 -> x <> 0.
Proof.
 move => x; apply (Rlt_not_eq x 0).
Qed.

Hint Resolve neg_neq0 : core.

Lemma Sn_pos : forall n:nat, 0 < INR (n + 1).
Proof.
 move => n; rewrite plus_INR; apply INRp1_pos.
Qed.

Hint Resolve Sn_pos : core.

Lemma INR1_pos : 0 < INR 1.
Proof.
 by rewrite -(add0n 1%N).
Qed.

Hint Resolve INR1_pos : core.

Lemma Sn_neq0 : forall n:nat, INR (n + 1) <> 0.
Proof.
 move => n; auto.
Qed.

Hint Resolve Sn_neq0 : core.

Lemma one_pow : forall r:R, 1^r = 1.
Proof.
 move => r.
 rewrite /Rpower.
 rewrite ln_1 Rmult_0_r; apply exp_0.
Qed.

Lemma Rpower_2 : forall r:R, 0 < r -> r^2 = r*r.
Proof.
 move => r Hrpos.
 by rewrite -{-1}(Rpower_1 r) // -Rpower_plus.
Qed.

Lemma Ropp_r_simpl_l: forall r1 r2 : R, r2 + r1 - r1 = r2.
Proof.
 move => r1 r2.
 by rewrite /Rminus Rplus_assoc -/(Rminus _ r1) Rminus_eq_0 Rplus_0_r.
Qed.

Lemma Rmult_div_assoc : forall (r1 r2 r3 : R), r1 * r2 / r3 = r1 * (r2 / r3).
Proof.
  move => r1 r2 r3; lra.
Qed.

Lemma Finite_Rplus : forall r1 r2 : R, Finite (r1 + r2) = Rbar_plus (Finite r1) (Finite r2).
Proof.
  by move => r1 r2.
Qed.

Lemma Finite_Rminus : forall r1 r2 : R, Finite (r1 - r2) = Rbar_minus (Finite r1) (Finite r2).
Proof.
    by move => r1 r2.
Qed.

Lemma Finite_Rmult : forall r1 r2 : R, Finite (r1 * r2) = Rbar_mult (Finite r1) (Finite r2).
Proof.
  by move => r1 r2.
Qed.

Lemma Finite_Rinv : forall r:R, r <> 0 -> Finite (/r) = Rbar_inv r.
Proof.
    by move => r Hr.
Qed.

Lemma Rmult_opp1_l : forall r:R, (-1)*r = -r.
Proof.
  move => r; lra.
Qed.

Lemma Rmult_opp1_r : forall r:R, r*(-1) = -r.
Proof.
  move => r; lra.
Qed.

Lemma iter_Rplus : forall (n:nat) (a b : R), iter n (Rplus a) b = n*a + b.
Proof.
  induction n => a b;
    [rewrite /=; lra | rewrite [in LHS]/= IHn -Nat.add_1_r plus_INR /=; lra].
Qed.

Lemma Rabs_div : forall x y : R, y <> 0 -> Rabs (x / y) = Rabs x / Rabs y.
Proof.
  move => x y Hy.
  rewrite /Rdiv.
  rewrite Rabs_mult.
  rewrite Rabs_Rinv //.
Qed.

Lemma Rbar_mult_1_r : forall x : Rbar, Rbar_mult x 1 = x.
Proof.
 case.
   rewrite /= => r; by rewrite Rmult_1_r.
  rewrite /=; case Rle_dec; try lra => case Rle_dec; try lra;
  move=> Hle01; case Rle_lt_or_eq_dec => //; lra.
 rewrite /=; case Rle_dec; try lra => case Rle_dec; try lra;
 move=> Hle01; case Rle_lt_or_eq_dec => //; lra.
Qed.

Lemma Rbar_mult_1_l : forall x : Rbar, Rbar_mult 1 x = x.
Proof.
 case.
   rewrite /= => r; by rewrite Rmult_1_l.
  rewrite /=; case Rle_dec; try lra => case Rle_dec; try lra;
  move=> Hle01; case Rle_lt_or_eq_dec => //; lra.
 rewrite /=; case Rle_dec; try lra => case Rle_dec; try lra;
 move=> Hle01; case Rle_lt_or_eq_dec => //; lra.
Qed.

Lemma Rmult_lt_gt_compat_neg_r : forall r r1 r2 : R, r < 0 -> r1 < r2 -> r1 * r > r2 * r.
Proof.
  move => r r1 r2 Hr Hr1r2.
  rewrite (Rmult_comm r1) (Rmult_comm r2).
    by apply Rmult_lt_gt_compat_neg_l.
Qed.

Lemma Rpower_Ropp' : forall x y : R, 0 < x -> x ^ (-y) = (/x) ^ y.
Proof.
 move => x y Hxpos.
 rewrite -{2}(Rpower_1 x) //; rewrite -Rpower_Ropp.
 rewrite Rpower_mult.
 by rewrite -Ropp_mult_distr_l Rmult_1_l.
Qed.

Lemma Rpower_Ropp1 : forall x : R, 0 < x -> x ^ (-1) = / x.
Proof.
 by move => x Hxpos; rewrite (Rpower_Ropp _ 1) Rpower_1.
Qed.

Lemma Rpower_lt' : forall x y z : R, 0 < x < 1 -> y < z -> x ^ z < x ^ y.
Proof.
 move => x y z Hx Hyz.
 rewrite -(Rinv_involutive x); [| apply pos_neq0; apply Hx].
 rewrite -!(Rpower_Ropp' (x:=/x)); try apply Rinv_0_lt_compat; try apply Hx.
 apply (Rpower_lt (/x) (-z) (-y)).
  rewrite -Rinv_1; apply (Rinv_lt_contravar x 1); lra.
 lra.
Qed.

Lemma Rmax_same : forall x:R, Rmax x x = x.
Proof.
  move => x.
  rewrite /Rmax; case Rle_dec; lra.
Qed.

Lemma Rmin_same : forall x:R, Rmin x x = x.
Proof.
  move => x.
  rewrite /Rmin; case Rle_dec; lra.
Qed.

Lemma Rsum_le_compat : forall (m n : nat) (F G : nat -> R), (forall k:nat, (m <= k < n)%N -> (F k <= G k)) ->
  \big[Rplus/0]_(m <= k < n) F k <= \big[Rplus/0]_(m <= k < n) G k.
Proof.
  move => m n F G HFG.
  induction n.
  - rewrite !big_geq; try apply /leP; try lia; lra.
  - case (le_lt_dec m n) => [Hlemn | Hltnm].
    + rewrite !big_nat_recr; try apply /leP => //.
      apply Rplus_le_compat.
      * apply IHn.
        move => k /andP; case => /leP Hmk /leP Hkn.
        apply /HFG /andP; split; apply /leP; lia.
      * apply /HFG /andP; split; apply /leP; lia.
    + rewrite !big_geq; try apply /leP; try lia; lra.
Qed.

Lemma Rsum_nonneg : forall (m n : nat) (F : nat->R),
  (forall k:nat, (m <= k < n)%N -> 0 <= F k) -> 0 <= \Rsum_(m <= k < n) F k.
Proof.
  move => m n F H.
  rewrite {1}(_ : 0 = \big[Rplus/0]_(m <= k < n) (fun _:nat => 0) k); [| rewrite big1_eq //].
    by apply Rsum_le_compat.
Qed.

Lemma Rsum_Rabs : forall (m n : nat) (F : nat -> R),
    Rabs (\Rsum_(m <= i < n) F i) <= \Rsum_(m <= i < n) Rabs (F i).
Proof.
  move => m.
  wlog: m / (m = 0)%N.
  - move => H0 n F.
    rewrite -(add0n m) !big_addn /=.
      by apply H0.
  - move ->; clear.
    induction n => F; [rewrite !big_geq ?Rabs_R0 //; lra |].
    rewrite !big_nat_recr //=.
    eapply Rle_trans; [apply Rabs_triang |].
    apply Rplus_le_compat_r.
    eapply Rle_trans; [apply IHn |]; lra.
Qed.

(* geometric series *)

Lemma sum_geom : forall (n:nat)(r:R), 0 < r -> r <> 1 ->
 \Rsum_(0 <= k < n) r^k = (1 - r^n) / (1 - r).
Proof.
 induction n.
  move=> r Hrpos Hrnot1.
  by rewrite big_geq //= (Rpower_O r Hrpos) Rminus_eq_0 /Rdiv Rmult_0_l.
 move=> r Hrpos Hrnot1.
 rewrite big_nat_recr //.
 rewrite IHn //.
 rewrite -{2}(Rinv_r_simpl_l (1-r) (r^n)); [ |lra];
 rewrite [Rplus_monoid _ _] /= -(Rdiv_plus_distr _ _ (1-r)).
 rewrite Rmult_minus_distr_l Rmult_1_r -Rplus_assoc (Rmult_comm _ r) -{3}(Rpower_1 r) //
 -Rpower_plus {1}/Rminus (Rplus_assoc _ (-r^n)) Rplus_opp_l Rplus_0_r.
 by rewrite (Rplus_comm 1 n) S_INR.
Qed.

Lemma sum_geom_incr_aux : forall (n:nat)(r:R), 0 < r ->
 (1-r).^2 * (\Rsum_(0 <= k < n) (k+1)*r^k) = 1 - (n+1) * r^n + n * r^(n+1).
Proof.
 move => n r Hrpos; elim n => [| p IHp].
  rewrite big_nil.
  by rewrite Rmult_0_l Rmult_0_r Rplus_0_l Rplus_0_r Rpower_O // Rmult_1_r Rminus_eq_0.
 rewrite big_nat_recr //.
 rewrite Rmult_plus_distr_l.
 rewrite IHp.
 rewrite (_ : (1-r).^2 = 1 - 2*r + r.^2); [| lra].
 rewrite (Rmult_plus_distr_r _ (r.^2)) Rmult_minus_distr_r Rmult_1_l.
 rewrite -!Rmult_assoc 2!(Rmult_comm _ (p+1)) 3!Rmult_assoc -Rpower_pow //
 -{4}(Rpower_1 r) // -!Rpower_plus 2!(Rplus_comm _ p).
 rewrite (S_INR p) (_ : INR p +1 + 1 = p + 2); [| lra]; rewrite (_ : p + 2%N = p + 2) => //.
 lra.
Qed.

Lemma sum_geom_incr : forall (n:nat)(r:R), 0 < r < 1 ->
 \Rsum_(0 <= k < n) (k+1)*r^k = (1 - (n+1) * r^n + n * r^(n+1)) / (1-r)^2.
Proof.
 move => n r Hr.
 rewrite -(Rinv_r_simpl_m ((1-r)^2) (\Rsum_(0<=k<n) _ )); [| apply /pos_neq0 /exp_pos].
 rewrite {1}(Rpower_pow 2); [| lra].
 rewrite sum_geom_incr_aux //; apply Hr.
Qed.

(* ceil function *)

Definition ceil (x:R) : Z := ((floor1 x) + 1)%Z.

Lemma ceil_correct : forall x:R, (ceil x) - 1 < x <= ceil x.
Proof.
 move => x.
 rewrite /ceil.
 rewrite plus_IZR Ropp_r_simpl_l.
 rewrite /floor1; case floor1_ex => //.
Qed.

Lemma ceil_n : forall n:Z, ceil n = n.
Proof.
 move => n.
 rewrite /ceil /floor1.
 case floor1_ex => m Hn /=.
 apply Z.le_antisymm.
  rewrite Z.add_1_r; apply Zlt_le_succ.
  apply lt_IZR; apply Hn.
 apply le_IZR; rewrite plus_IZR; apply Hn.
Qed.

Lemma ceil_unique : forall (n:Z)(x:R), n - 1 < x <= n -> n = ceil x.
Proof.
 move => n x [Hgtx Hlex].
 apply Z.le_antisymm.
  rewrite -Z.lt_pred_le -Z.sub_1_r.
  apply lt_IZR; rewrite minus_IZR; eapply Rlt_le_trans.
   apply Hgtx.
  apply ceil_correct.
 case: (Rle_lt_or_eq_dec _ _ Hlex) => [Hltx | Heqx].
  apply Zlt_succ_le; rewrite -Z.add_1_r.
  apply lt_IZR; rewrite plus_IZR; apply (Rlt_trans _ (x+1)).
   rewrite -(Ropp_r_simpl_l (-1) (ceil x)) /Rminus Ropp_involutive; apply Rplus_lt_compat_r.
   apply ceil_correct.
  by apply Rplus_lt_compat_r.
 rewrite Heqx ceil_n; lia.
Qed.

(* elementary calculus *)

Lemma mulnl_eventually : forall n:nat, (0 < n)%coq_nat -> filterlim (muln n) eventually eventually.
Proof.
  move => n Hn.
  rewrite /filterlim /filter_le /filtermap !/eventually => P.
  case => N HNspec.
  exists N => m Hm.
  apply HNspec.
  have Hn' : (1 <= n)%N by [apply /leP; lia].
  rewrite -(mul1n N); apply /leP.
    by apply leq_mul; [| apply /leP].
Qed.

Lemma mulnr_eventually : forall n:nat, (0 < n)%coq_nat -> filterlim (muln^~ n) eventually eventually.
Proof.
  move => n Hn.
  rewrite /filterlim /filter_le /filtermap !/eventually => P.
  case => N HNspec.
  exists N => m Hm.
  apply HNspec.
  have Hn' : (1 <= n)%N by [apply /leP; lia].
  rewrite -(muln1 N); apply /leP.
    by apply leq_mul; [apply /leP |].
Qed.

Definition is_lower_bound (E : R -> Prop) (m:R) := forall x:R, E x -> m <= x.

Definition Eopp (E : R -> Prop) := fun x:R => E (-x).

Lemma low_up_bound (E : R -> Prop) (m:R) :
  is_upper_bound E m <-> is_lower_bound (Eopp E) (-m).
Proof.
  split.
  - intro Hub.
    rewrite /is_lower_bound.
    intros x HEopp.
    rewrite /Eopp in HEopp; rewrite /is_upper_bound in Hub.
    rewrite -(Ropp_involutive x).
    apply /Ropp_ge_le_contravar /Rle_ge /Hub => //.
  - intro Hlb.
    rewrite /is_upper_bound.
    intros x HE.
    rewrite -(Ropp_involutive x) -(Ropp_involutive m).
    apply Ropp_ge_le_contravar.
    rewrite /is_lower_bound in Hlb.
    apply /Rle_ge /Hlb.
    rewrite /Eopp Ropp_involutive //.
Qed.

Definition bound' (E : R -> Prop) := exists m:R, is_lower_bound E m.

Lemma bound_up_low : forall (E : R -> Prop) (m : R),
    is_upper_bound E m <-> is_lower_bound (Eopp E) (-m).
Proof.
  intros E m.
  split.
  - intro Hub.
    rewrite /is_lower_bound.
    intros x HEopp.
    rewrite -(Ropp_involutive x).
    apply Ropp_ge_le_contravar.
    rewrite /is_upper_bound in Hub.
    apply /Rle_ge /Hub /HEopp.
  - intro Hlb.
    rewrite /is_upper_bound.
    intros x HE.
    rewrite -(Ropp_involutive x) -(Ropp_involutive m).
    apply Ropp_ge_le_contravar.
    rewrite /is_lower_bound in Hlb.
    apply /Rle_ge /(Hlb (-x)).
    rewrite /Eopp Ropp_involutive //.
Qed.

Definition is_glb (E : R -> Prop) (m:R) :=
  is_lower_bound E m /\ (forall b:R, is_lower_bound E b -> b <= m).

Lemma lub_glb : forall (E : R -> Prop) (m:R), is_lub E m <-> is_glb (Eopp E) (-m).
Proof.
  intros E m.
  split.
  - intro Hlub.
    rewrite /is_glb.
    split.
    + apply bound_up_low.
      apply Hlub.
    + intros b Hlb.
      rewrite -(Ropp_involutive b).
      apply Ropp_ge_le_contravar.
      apply Rle_ge.
      apply Hlub.
      apply low_up_bound.
      rewrite Ropp_involutive //.
  - intro Hglb.
    rewrite /is_lub.
    split.
    + apply bound_up_low.
      apply Hglb.
    + intros b Hlb.
      rewrite -(Ropp_involutive b) -(Ropp_involutive m).
      apply Ropp_ge_le_contravar.
      apply Rle_ge.
      apply Hglb.
      by apply bound_up_low.
Qed.

Lemma completeness':
  forall E : R -> Prop, bound' E -> (exists x:R, E x) -> {m:R | is_glb E m}.
Proof.
  intros E HEb HEex.
  case: (completeness (Eopp E)).
  - case: HEb => [x Hlb].
    exists (-x).
    apply bound_up_low.
    rewrite Ropp_involutive /is_lower_bound.
    intros y HEopp2.
    apply Hlb.
    rewrite /Eopp in HEopp2.
    by rewrite -(Ropp_involutive y).
  - case: HEex => [x HEex].
    exists (-x).
    rewrite /Eopp.
    by rewrite (Ropp_involutive x).
  - intros b Hlub.
    exists (-b).
    apply lub_glb in Hlub.
    rewrite /is_glb in Hlub *.
    destruct Hlub as [Hlb Hmax].
    split.
    + rewrite /is_lower_bound in Hlb *.
      intros x HEx.
      apply Hlb.
      rewrite /Eopp.
      by rewrite Ropp_involutive.
    + intros a Hlb'.
      apply Hmax.
      rewrite /is_lower_bound in Hlb' *.
      intros x HEx.
      apply Hlb'.
        by rewrite -(Ropp_involutive x).
Qed.

Lemma glb_Empty_p_infty : forall E : Ensemble R, (Empty E) -> is_glb_Rbar E p_infty.
Proof.
  move => E HEemp.
  rewrite /is_glb_Rbar.
  split.
  - rewrite /is_lb_Rbar.
    move => x Hx.
    apply False_ind.
    by apply (Empty_correct_1 E HEemp x).
  - move => b Hblb.
    case b; by try move => _.
Qed.

Lemma Glb_Empty_p_infty : forall E : Ensemble R, (Empty E) -> Glb_Rbar E = p_infty.
Proof.
  move => E HEemp.
  apply is_glb_Rbar_unique.
    by apply glb_Empty_p_infty.
Qed.

Lemma complement_image_rec : forall f : R -> R, forall D : Ensemble R,
      complementary (image_rec f D) =_D image_rec f (complementary D).
Proof.
  move => f D.
  split; rewrite /included => x Hx; rewrite /image_rec /complementary; apply Hx.
Qed.

Lemma Rsingleton_closed : forall a:R, closed_set (fun x:R => x = a).
Proof.
  move => a.
  rewrite /closed_set.
  apply open_set_P1.
  split; [| apply interior_P1].
  rewrite /included => x Hx.
  rewrite /interior /neighbourhood.
  set (r := Rabs ((x-a)/2)).
  have Hrpos : 0 < r.
  { rewrite /r.
    rewrite /complementary in Hx.
    apply Rabs_pos_lt; lra. }
  exists (mkposreal r Hrpos).
  rewrite /included => y Hy.
  rewrite /complementary.
  move => Hya.
  rewrite /disc in Hy.
  apply (Rle_not_lt (Rabs (a-x)) 0); [apply Rabs_pos |].
  move: Hy; rewrite /r Hya /Rdiv /=.
  rewrite Rabs_mult {3}/Rabs; case Rcase_abs; [lra | move => _].
  rewrite Rabs_minus_sym; lra.
Qed.

Lemma is_lim_seq_abs_minus_0 : forall (u : nat -> R) (l:R),
  is_lim_seq u l <-> is_lim_seq (fun n:nat => Rabs (u n - l)) 0.
Proof.
  move => u l.
  rewrite !is_lim_seq_Reals !/Un_cv !/R_dist.
  split.
  - move => Hul.
    move => eps Heps.
    case: (Hul eps Heps) => N HN.
    exists N => n Hn.
    rewrite Rminus_0_r Rabs_Rabsolu.
      by apply HN.
  - move => Hul0.
    move => eps Heps.
    case: (Hul0 eps Heps) => N HN.
    exists N => n Hn.
    rewrite -(Rabs_Rabsolu (u n - l)) -(Rminus_0_r (Rabs (u n - l))).
      by apply HN.
Qed.

Lemma is_lim_seq_diff_0 : forall (u v : nat -> R) (l:R),
  is_lim_seq u l -> is_lim_seq (fun n:nat => u n - v n) 0 -> is_lim_seq v l.
Proof.
  move => u v l.
  move /is_lim_seq_abs_minus_0 => Hul.
  move /is_lim_seq_abs_minus_0 => Huv0.
  apply is_lim_seq_abs_minus_0.
  apply (is_lim_seq_le_le (fun _ => 0) _ (fun n:nat => Rabs (u n - v n) + Rabs (u n - l))).
  - move => n.
    split; [apply Rabs_pos |].
    rewrite (_ : v n - l = (v n - u n) + (u n - l)); [| lra].
    rewrite -(Rabs_Ropp (u n - v n)) Ropp_minus_distr.
    apply Rabs_triang.
  - apply is_lim_seq_const.
  - rewrite -(Rplus_0_r 0).
    apply (is_lim_seq_plus _ _ 0 0); auto.
    + apply (is_lim_seq_ext (fun n:nat => Rabs (u n - v n - 0))); auto.
        by move => n; rewrite Rminus_0_r.
    + rewrite /is_Rbar_plus //=.
Qed.

Lemma Rle_lim_decr : forall (b:R) (f : R -> R),
    (decreasing f) -> is_lim f p_infty b -> forall x:R, b <= f x.
Proof.
  move => b f Hdecr Hlim x.
  apply Rnot_lt_le.
  move => Hlt.
  apply (Rlt_irrefl (f x)).
  apply is_lim_spec in Hlim.
  rewrite /is_lim' in Hlim.
  assert (Hpos : 0 < b - (f x)) by lra.
  move: (Hlim (mkposreal (b - (f x)) Hpos)).
  rewrite /Rbar_locally'.
  case => a Hbnd.
  set a' := Rmax x a + 1.
  assert (Haa' : a < a').
  { rewrite /a'.
    apply /(Rle_lt_trans a (Rmax x a) _); [apply Rmax_r | apply Rlt_plus_1]. }
  assert (Hxa' : x < a').
  { rewrite /a'.
    apply /(Rle_lt_trans x (Rmax x a) _); [apply Rmax_l | apply Rlt_plus_1]. }
  assert (Hfa'fx : f a' <= f x) by (apply Hdecr; lra).
  apply (Rlt_le_trans (f x) (f a') (f x)).
  - rewrite -(Ropp_involutive (f x)) -(Ropp_involutive (f a'));
      apply /Ropp_gt_contravar /(Rplus_gt_reg_l b); rewrite -2!/(Rminus b _).
    move: (Hbnd a' Haa') => Hfa'b.
    rewrite (Rabs_left (f a' - b)) in Hfa'b; [| apply Rlt_minus; lra].
    rewrite Ropp_minus_distr in Hfa'b; done.
  - done.
Qed.

Lemma continuity_pt_continuous : forall (x:R) (f : R -> R), continuity_pt f x <-> continuous f x.
Proof.
  move => x f; apply continuity_pt_filterlim.
Qed.

Lemma eq_R_continuous : forall (f : R -> R), continuity f <-> forall x:R, continuous f x.
Proof.
  move => f.
  rewrite /continuity.
    by split; move => H x; apply continuity_pt_continuous.
Qed.

Definition continuity_open := open_set_P3.

Lemma continuity_closed : forall f : R -> R,
    continuity f <-> (forall D : Ensemble R, closed_set D -> closed_set (image_rec f D)).
Proof.
  move => f.
  move: (continuity_P3 f) => [Hfopen Hopenf].
  split.
  - move => HfC0 D HD.
    rewrite /closed_set.
    apply (open_set_P6 (image_rec f (complementary D))).
    + apply Hfopen; auto.
    + apply complement_image_rec.
  - move => Hclosed.
    apply Hopenf => D HD.
    rewrite -(Complement_Complement R D).
    rewrite (_ : Complement R = complementary) //.
    apply (open_set_P6 (complementary (image_rec f (complementary D))));
      [| apply complement_image_rec].
    apply Hclosed.
    rewrite /closed_set.
    rewrite (_ : complementary = Complement R) //.
    rewrite Complement_Complement //.
Qed.

Lemma continuous_Rplus_snd : forall (a x : R), continuous (Rplus a) x.
Proof.
  move => a x.
  apply (continuous_plus (fun => a) id); [apply continuous_const | apply continuous_id].
Qed.

Lemma continuous_Rplus_fst : forall (b x : R), continuous (Rplus ^~ b) x.
Proof.
  move => b x.
  apply (continuous_plus id (fun => b)); [apply continuous_id | apply continuous_const].
Qed.

Lemma continuous_Rminus_snd : forall (a x : R), continuous (Rminus a) x.
Proof.
  move => a x.
  rewrite /Rminus.
  apply (continuous_minus (fun => a) id); [apply continuous_const | apply continuous_id].
Qed.

Lemma continuous_Rminus_fst : forall (b x : R), continuous (Rminus ^~ b) x.
Proof.
  move => b x.
  rewrite /Rminus; apply continuous_Rplus_fst.
Qed.

Lemma continuous_Rmult_fst : forall x y : R, continuous (Rmult ^~ y) x.
Proof.
  move => x y.
  apply (continuous_mult id (fun => y)); [apply continuous_id | apply continuous_const].
Qed.

Lemma continuous_Rmult_snd : forall x y : R, continuous (Rmult x) y.
  move => x y.
  apply (continuous_mult (fun => x) id); [apply continuous_const | apply continuous_id].
Qed.

Lemma continuous_Rpower_fst : forall x y : R, 0 < x -> continuous (Rpower ^~ y) x.
Proof.
  move => x y Hx.
  rewrite /Rpower /=.
  apply continuous_comp => /=.
  - apply (continuous_mult (fun => y)); [apply continuous_const | by apply continuous_ln].
  - apply continuous_exp.
Qed.

Lemma continuous_Rpower_snd : forall x y : R, continuous (Rpower x) y.
Proof.
  move => x y.
  rewrite /Rpower.
  apply continuous_comp.
  - apply continuous_Rmult_fst.
  - apply continuous_exp.
Qed.

Lemma lim_pow_0 : forall r:R, 0 < r < 1 -> is_lim_seq (fun n:nat => r^n) 0.
Proof.
 move => r Hr01.
 rewrite /Rpower.
 apply (is_lim_comp_seq _ _ m_infty).
   apply is_lim_exp_m.
  exists 0%N.
  move => n Hn0 HFM; inversion HFM.
 rewrite -(is_Rbar_mult_unique p_infty (ln r) m_infty);
 [| apply is_Rbar_mult_p_infty_neg => /=; rewrite -ln_1; apply ln_increasing; lra].
 apply is_lim_seq_scal_r.
 apply is_lim_seq_INR.
Qed.

Lemma lim_mult_pow_0 : forall r s : R, 0 < r < 1 -> is_lim_seq (fun n:nat => n^s * r^n) 0.
Proof.
  move => r s Hr01.
  assert (H_lnr_neg : ln r < 0) by (rewrite -ln_1; apply ln_increasing; apply Hr01).
  apply (is_lim_comp_seq (fun x:R => x^s * r^x) _ p_infty 0).
  - apply (is_lim_ext_loc (fun x:R => exp (x * (s * (ln x / x) + ln r)))) => /=.
    + exists 0 => x Hxpos.
      rewrite Rmult_plus_distr_l /Rdiv -!Rmult_assoc (Rmult_assoc x) Rinv_r_simpl_m;
        [by rewrite exp_plus -/(Rpower x s) -/(Rpower r x) | apply pos_neq0 => //].
    + apply (is_lim_comp exp (fun x:R => x * (s * (ln x / x) + ln r)) _ _ m_infty).
      * apply is_lim_exp_m.
      * rewrite (_ : m_infty = Rbar_mult p_infty (ln r));
          [| apply /esym /is_Rbar_mult_unique /is_Rbar_mult_p_infty_neg;
             rewrite /Rbar_lt; apply H_lnr_neg].
        apply is_lim_mult => //; [| rewrite /ex_Rbar_mult; apply /neg_neq0 /H_lnr_neg].
        rewrite -{2}(Rplus_0_l (ln r)).
        apply (is_lim_plus _ _ _ 0 (ln r));
          [| apply is_lim_const |  by rewrite /is_Rbar_plus /=].
        rewrite (_ : 0 = Rbar_mult s 0); [| by rewrite /= Rmult_0_r].
        apply (is_lim_scal_l _ s p_infty 0).
        apply is_lim_div_ln_p.
      * rewrite /Rbar_locally'.
        exists 0.
        move => x Hxpos Heq; inversion Heq.
  - rewrite /eventually.
    exists 0%N.
    move => n Hle0n Heq; inversion Heq.
  - apply is_lim_seq_INR.
Qed.

Lemma lim_mult1_pow_0 : forall r:R, 0 < r < 1 -> is_lim_seq (fun n:nat => n * r^n) 0.
Proof.
  move => r Hr01.
  apply (is_lim_seq_ext_loc (fun n:nat => n^1 * r^n)).
  - exists 1%N.
    move => n Hnpos.
    by rewrite -{3}(Rpower_1 n); [| apply lt_0_INR; lia].
  - apply lim_mult_pow_0 => //.
Qed.

Lemma Derive_ln : forall x:R, 0 < x -> Derive ln x = 1 / x.
Proof.
  move => x Hx.
  apply is_derive_unique; try auto_derive => //.
Qed.

Lemma Derive_incr : forall (f : R -> R) (a b : R), ex_derive f (a+b) ->
  Derive (fun x:R => f (a+x)) b = Derive f (a+b).
Proof.
  move => f a b Hf.
  rewrite (Derive_comp f); last (by auto_derive); auto.
  rewrite Derive_plus; try auto_derive; auto.
  rewrite Derive_const Derive_id.
  rewrite Rplus_0_l Rmult_1_l //.
Qed.

Lemma is_derive_Rpower_fst : forall x y : R, 0 < x -> is_derive (fun x:R => x^y) x (y * x^(y-1)).
Proof.
  move => x y Hx.
  rewrite /Rpower.
  auto_derive; auto.
  rewrite Rmult_minus_distr_r /Rminus.
  rewrite exp_plus.
  rewrite !Rmult_1_l.
  rewrite exp_Ropp exp_ln; lra.
Qed.

Lemma ex_derive_Rpower_fst : forall x y : R, 0 < x -> ex_derive (fun x:R => x^y) x.
Proof.
  move => x y Hx.
  exists (y * x^(y-1)).
    by apply is_derive_Rpower_fst.
Qed.

Lemma is_derive_Rpower_snd : forall x y : R, is_derive (fun y:R => x^y) y ((ln x) * x^y).
Proof.
  move => x y.
  rewrite /Rpower.
  auto_derive; lra.
Qed.

Lemma ex_derive_Rpower_snd : forall x y : R, ex_derive (fun y:R => x^y) y.
Proof.
  move => x y.
  exists ((ln x) * x^y).
    by apply is_derive_Rpower_snd.
Qed.

Lemma RInt_comp_plus : forall {V : CompleteNormedModule R_AbsRing} (f : R -> V) (v a b : R),
  ex_RInt f (a + v) (b + v) -> RInt (fun y : R => f (y + v)) a b = RInt f (a + v) (b + v).
Proof.
  move => V f v a b HexRInt.
  rewrite -{2}(Rmult_1_l a) -{2}(Rmult_1_l b).
  rewrite (RInt_ext (fun y:R => f (y+v)) (fun y:R => scal 1 (f (1*y+v)))).
  - apply RInt_comp_lin.
      by rewrite !Rmult_1_l.
  - move => x Hx.
      by rewrite Rmult_1_l scal_one.
Qed.

Lemma MVT' : forall (f : R -> R) (a b : R) (df : R -> R), a <= b ->
  (forall x:R, a < x < b -> is_derive f x (df x)) ->
  (forall x:R, a <= x <= b -> continuity_pt f x) ->
  exists c:R, a <= c <= b /\ f b - f a = df c * (b - a).
Proof.
  move => f a b df Hab Hdiff Hcont.
  have Ha : Rmin a b = a by rewrite Rmin_left; lra.
  have Hb : Rmax a b = b by rewrite Rmax_right; lra.
  move: (MVT_gen f a b df).
  rewrite Ha Hb; auto.
Qed.

Lemma RInt_scal_Derive_l : forall (f : R -> R) (g : R -> R) (a b : R),
  (forall t : R, Rmin a b <= t <= Rmax a b -> ex_derive f t) ->
  (forall t : R, Rmin a b <= t <= Rmax a b -> ex_derive g t) ->
  (forall t : R, Rmin a b <= t <= Rmax a b -> continuous (Derive f) t) ->
  (forall t : R, Rmin a b <= t <= Rmax a b -> continuous (Derive g) t) ->
  RInt (fun t:R => scal ((Derive f) t) (g t)) a b =
  minus (minus (scal (f b) (g b)) (scal (f a) (g a)))
        (RInt (fun t:R => scal (f t) ((Derive g) t)) a b).
Proof.
  move => f g a b HfD HgD HfCD HgCD.
  apply is_RInt_unique.
  apply (is_RInt_scal_derive_l _ _ (Derive f) (Derive g)); auto;
    try (move => t Ht; auto_derive; auto; by rewrite Rmult_1_l).
  apply RInt_correct.
  apply ex_RInt_continuous => t Ht.
  apply continuous_mult; auto.
  apply (ex_derive_continuous f); auto.
Qed.

(* quadrature *)

Definition pr1 (T U : Type) (t:T) (u:U) := t.
Definition pr2 (T U : Type) (t:T) (u:U) := u.

Definition unif_div_l (a b : R) (n:nat) := SF_seq_f2 (pr1 (U:=R)) (unif_part a b n).
Definition unif_div_r (a b : R) (n:nat) := SF_seq_f2 (pr2 (U:=R)) (unif_part a b n).

Lemma filterlim_ext_loc_equiv : forall (T U : Type) (F : (T -> Prop) -> Prop) (G : (U -> Prop) -> Prop),
  Filter F -> forall f g : T -> U, F (fun x:T => f x = g x) -> filterlim f F G <-> filterlim g F G.
Proof.
  move => T U F G HFF f g Hfg.
  split; [by apply filterlim_ext_loc |].
  apply filterlim_ext_loc.
  apply (filter_imp (fun x:T => f x = g x)); auto.
Qed.

Lemma filter_le_Rloc_Rbarloc : forall r:R, filter_le (locally r) (Rbar_locally r).
Proof.
  move => r.
  rewrite /filter_le => P.
    by rewrite /Rbar_locally.
Qed.

Lemma Riemann_sum_calc : forall (n:nat) (a:R) (f : R -> R) (x y : nat -> R),
  Riemann_sum f (mkSF_seq a [ seq (x i, y i) | i <- seq.iota 0%N n.+1]) =
    (x 0%N - a) * f (y 0%N) + \Rsum_(0 <= i < n) (x i.+1 - x i) * f (y i.+1).
Proof.
  move => n a f x y.
  rewrite /Riemann_sum /= /plus /scal /= /mult /=.
  have Hpm : pairmap (fun x0 y0 : R * R => (y0.1 - x0.1) * f y0.2)
                     (x 0%N, y 0%N) [seq (x i, y i) | i <- seq.iota 1 n] =
             [ seq (x i.+1 - x i) * f (y i.+1) | i <- seq.iota 0 n].
  { apply eq_from_nth with (x0 := 0); [ by rewrite /= size_pairmap !size_map !size_iota |].
    move => i.
    rewrite size_pairmap size_map size_iota => Hi.
    rewrite (nth_pairmap (0,0)); [| by rewrite size_map size_iota].
    rewrite !(nth_map 0%N); [| by rewrite size_iota ..].
    rewrite !nth_iota //= add0n.
    move: Hi; case i => //= j Hj.
    rewrite (nth_map 0%N); [| rewrite size_iota; auto].
    rewrite nth_iota; auto. }
  rewrite Hpm.
  rewrite foldrE.
  rewrite big_map.
    by rewrite /index_iota subn0.
Qed.

Lemma is_RInt_regular : forall (V : NormedModule R_AbsRing) (f : R -> V) (a b : R) (If : V),
  a <= b -> is_RInt f a b If <-> filterlim (Riemann_sum f) (Riemann_fine a b) (locally If).
Proof.
  move => V f a b If Hab.
  rewrite /is_RInt.
  apply filterlim_ext_loc_equiv; [apply Riemann_fine_filter |].
  rewrite /Riemann_fine /within /locally_dist.
  have H1pos : 0 < 1 by lra.
  exists (mkposreal 1 H1pos) => /=.
  move => ptd _; case => Hpt.
  rewrite Rmin_left ?Rmax_right; [| lra ..].
  case => Ha Hb.
  rewrite /sign.
  case total_order_T; [case |].
  - by rewrite scal_one.
  - move => Heqab.
    rewrite scal_zero_l.
    rewrite Riemann_sum_zero; by [| apply ptd_sort | rewrite /SF_lx /=; lra].
  - lra.
Qed.

Lemma quadr_left : forall (f : R -> R) (a b : R), a <= b -> ex_RInt f a b ->
  is_lim_seq (fun n:nat => (b-a)/(n+1) * \Rsum_(0 <= k < n+1) f (a + k*(b-a)/(n+1))) (RInt f a b).
Proof.
  move => f a b Hab Hexint.
  set (Qdr := fun n:nat => (b-a)/(n+1) * \Rsum_(0 <= k < n+1) f (a + k*(b-a)/(n+1))).
  set (unif_div_l := fun n:nat => SF_seq_f2 (@pr1 R R) (unif_part a b n)).
  have HQdr : forall n:nat, Riemann_sum f (unif_div_l n) = Qdr n.
  { move => n.
    rewrite /unif_div_l /SF_seq_f2 /pr1.
    rewrite pairmap_pair1.
    rewrite [head _ _]/=.
    rewrite Riemann_sum_calc.
    rewrite -(big_nat_recl _ _
      (fun i:nat => (a+i.+1*(b-a)/(n+1)-(a+i*(b-a)/(n+1))) * f (a+i*(b-a)/(n+1)))); auto.
    rewrite /Qdr.
    under eq_big_nat => i Hi do (rewrite -Nat.add_1_r plus_INR /=
      (_ : a + (i+1)*(b-a)/(n+1) - (a + i*(b-a)/(n+1)) = (b-a)/(n+1)); [| lra]).
    by rewrite -big_distrr -Nat.add_1_r. }
  rewrite /is_lim_seq.
  eapply filterlim_filter_le_2; [apply filter_le_Rloc_Rbarloc |].
  eapply filterlim_ext; [apply HQdr |].
  apply (filterlim_comp _ _ _ unif_div_l (Riemann_sum f) _ (Riemann_fine a b)).
  - rewrite /filterlim /filter_le => P.
    rewrite /Riemann_fine /within /locally_dist.
    case => delta Hsubdiv.
    destruct delta as [delta Hdeltapos].
    rewrite /filtermap /eventually.
    exists (Z.to_nat (ceil ((b-a)/delta))).
    move => n Hn.
    have Hn1 : 0 < n+1 by rewrite (_ : 1 = 1%N) // -plus_INR; apply lt_0_INR; lia.
    have Hab' : 0 <= (b-a)/(n+1) by apply Rdiv_le_0_compat; lra.
    apply Hsubdiv.
    + rewrite /unif_div_l.
      rewrite SF_lx_f2; [| rewrite /unif_part size_mkseq; lia].
      rewrite seq_step_unif_part.
      rewrite /Rabs; case Rcase_abs; [lra |] => _.
      apply Rlt_div_l; auto.
      rewrite Rmult_comm.
      apply Rlt_div_l => //=.
      apply (Rle_lt_trans _ n); [| lra].
      apply (Rle_trans _ (ceil ((b-a)/delta))); [apply ceil_correct |].
      move: Hn => /le_INR.
      rewrite INR_Ztonat_IZR //.
      apply le_IZR.
      apply (Rle_trans _ ((b-a)/delta));
        [apply Rdiv_le_0_compat; lra | apply ceil_correct].
    + rewrite /Rmin /Rmax; case Rle_dec; [| lra] => _.
      split; [| split].
      * rewrite /unif_div_l.
        apply ptd_f2; [by apply unif_part_sort |].
        move => x y Hxy; rewrite /pr1; lra.
      * rewrite /unif_div_l /=; lra.
      * rewrite {2}/unif_div_l.
        rewrite SF_lx_f2; [| rewrite /unif_part size_mkseq; lia].
          by rewrite last_unif_part.
  - apply is_RInt_regular; auto.
      by apply (RInt_correct f a b).
Qed.

Lemma quadr_right : forall (f : R -> R) (a b : R), a <= b -> ex_RInt f a b ->
  is_lim_seq (fun n:nat => (b-a)/(n+1) * \Rsum_(0 <= k < n+1) f (a + k.+1*(b-a)/(n+1)))
             (RInt f a b).
Proof.
  move => f a b Hab Hexint.
  set (Qdr := fun n:nat => (b-a)/(n+1) * \Rsum_(0 <= k < n+1) f (a + k.+1*(b-a)/(n+1))).
  set (unif_div_l := fun n:nat => SF_seq_f2 (@pr2 R R) (unif_part a b n)).
  have HQdr : forall n:nat, Riemann_sum f (unif_div_l n) = Qdr n.
  { move => n.
    rewrite /unif_div_l /SF_seq_f2 /pr2.
    rewrite pairmap_pair2.
    rewrite [head _ _]/=.
    rewrite Riemann_sum_calc.
    rewrite -(big_nat_recl _ _
      (fun i:nat => (a+i.+1*(b-a)/(n+1)-(a+i*(b-a)/(n+1))) * f (a+i.+1*(b-a)/(n+1)))); auto.
    rewrite /Qdr.
    under eq_big_nat => i Hi do (
      rewrite -Nat.add_1_r plus_INR
        (_ : a + (i+1)*(b-a)/(n+1) - (a + i*(b-a)/(n+1)) = (b-a)/(n+1))
        -?plus_INR ?Nat.add_1_r; [| lra] ).
    by rewrite -big_distrr -Nat.add_1_r. }
  rewrite /is_lim_seq.
  eapply filterlim_filter_le_2; [apply filter_le_Rloc_Rbarloc |].
  eapply filterlim_ext; [apply HQdr |].
  apply (filterlim_comp _ _ _ unif_div_l (Riemann_sum f) _ (Riemann_fine a b)).
  - rewrite /filterlim /filter_le => P.
    rewrite /Riemann_fine /within /locally_dist.
    case => delta Hsubdiv.
    destruct delta as [delta Hdeltapos].
    rewrite /filtermap /eventually.
    exists (Z.to_nat (ceil ((b-a)/delta))).
    move => n Hn.
    have Hn1 : 0 < n+1 by rewrite (_ : 1 = 1%N) // -plus_INR; apply lt_0_INR; lia.
    have Hab' : 0 <= (b-a)/(n+1) by apply Rdiv_le_0_compat; lra.
    apply Hsubdiv.
    + rewrite /unif_div_l.
      rewrite SF_lx_f2; [| rewrite /unif_part size_mkseq; lia].
      rewrite seq_step_unif_part.
      rewrite /Rabs; case Rcase_abs; [lra |] => _.
      apply Rlt_div_l; auto.
      rewrite Rmult_comm.
      apply Rlt_div_l => //=.
      apply (Rle_lt_trans _ n); [| lra].
      apply (Rle_trans _ (ceil ((b-a)/delta))); [apply ceil_correct |].
      move: Hn => /le_INR.
      rewrite INR_Ztonat_IZR //.
      apply le_IZR.
      apply (Rle_trans _ ((b-a)/delta));
        [apply Rdiv_le_0_compat; lra | apply ceil_correct].
    + rewrite /Rmin /Rmax; case Rle_dec; [| lra] => _.
      split; [| split].
      * rewrite /unif_div_l.
        apply ptd_f2; [by apply unif_part_sort |].
        move => x y Hxy; rewrite /pr2; lra.
      * rewrite /unif_div_l /=; lra.
      * rewrite {2}/unif_div_l.
        rewrite SF_lx_f2; [| rewrite /unif_part size_mkseq; lia].
          by rewrite last_unif_part.
  - apply is_RInt_regular; auto.
      by apply (RInt_correct f a b).
Qed.


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import List ZArith Tactics.
Import ListNotations.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

(* TODO rename this file to util.v -- not only for nats *)

Lemma max_lub_l_ssr n m p:
  max n m < p -> n < p.
Proof.
  move /ltP/PeanoNat.Nat.max_lub_lt_iff => [/ltP H1 _].
  assumption.
Qed.

Lemma max_lub_r_ssr n m p:
  max n m < p -> m < p.
Proof.
  move /ltP/PeanoNat.Nat.max_lub_lt_iff => [_ /ltP H1].
  assumption.
Qed.

Lemma max_lub_ssr n m p :
  n < p -> m < p -> max n m < p.
Proof.
  move => /ltP H1 /ltP H2.
  apply/ltP/PeanoNat.Nat.max_lub_lt; eassumption.
Qed.

(* TODO do implicits for the rest of the file *)

Set Implicit Arguments.
Unset Strict Implicit.

Lemma lt0_False :
  forall n, ~ n < 0.
Proof.
  firstorder.
Qed.

Lemma leq_ltS n m :
  n <= m -> n < m.+1.
Proof.
  eauto.
Qed.

Lemma ltS_leq n m :
  n <= m -> n < m.+1.
Proof.
  eauto.
Qed.

Lemma plus_leq_compat_l n m k :
  n <= m ->
  n <= m + k.
Proof.
  intros. ssromega.
Qed.

Lemma plus_leq_compat_r n m k :
  n <= k ->
  n <= m + k.
Proof.
  intros. ssromega.
Qed.

Lemma leq_refl: forall n, n <= n.
Proof.
  intros. ssromega.
Qed.

Lemma succ_neq_zero :
  forall x, S x <> 0.
Proof.
  firstorder.
Qed.

Lemma isSomeSome {A : Type} (y : A) :
  Some y.
Proof.
  exact isT.
Qed.

Lemma eq_symm {A : Type} (x y : A) :
  x = y -> y = x.
Proof.
  firstorder.
Qed.

Lemma ltn0Sn_pair {A : Type} (n : nat) (g : A)  :
  0 < (n.+1, g).1.
Proof.
  ssromega.
Qed.

(* Yikes this is stupid, find a workaround *)
(* Leo, can you make me a real prop and a real forall in the plugin?? *)
Definition prop := Prop.

Definition all (A : Type) (f : A -> Prop) : Prop := forall (x : A), f x.


From Hammer Require Import Hammer.

Require Export ZBase.

Module ZAddProp (Import Z : ZAxiomsMiniSig').
Include ZBaseProp Z.

Hint Rewrite opp_0 : nz.

Theorem add_pred_l : forall n m, P n + m == P (n + m).
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_pred_l".
intros n m.
rewrite <- (succ_pred n) at 2.
now rewrite add_succ_l, pred_succ.
Qed.

Theorem add_pred_r : forall n m, n + P m == P (n + m).
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_pred_r".
intros n m; rewrite 2 (add_comm n); apply add_pred_l.
Qed.

Theorem add_opp_r : forall n m, n + (- m) == n - m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_opp_r".
nzinduct m.
now nzsimpl.
intro m. rewrite opp_succ, sub_succ_r, add_pred_r. now rewrite pred_inj_wd.
Qed.

Theorem sub_0_l : forall n, 0 - n == - n.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_0_l".
intro n; rewrite <- add_opp_r; now rewrite add_0_l.
Qed.

Theorem sub_succ_l : forall n m, S n - m == S (n - m).
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_succ_l".
intros n m; rewrite <- 2 add_opp_r; now rewrite add_succ_l.
Qed.

Theorem sub_pred_l : forall n m, P n - m == P (n - m).
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_pred_l".
intros n m. rewrite <- (succ_pred n) at 2.
rewrite sub_succ_l; now rewrite pred_succ.
Qed.

Theorem sub_pred_r : forall n m, n - (P m) == S (n - m).
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_pred_r".
intros n m. rewrite <- (succ_pred m) at 2.
rewrite sub_succ_r; now rewrite succ_pred.
Qed.

Theorem opp_pred : forall n, - (P n) == S (- n).
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.opp_pred".
intro n. rewrite <- (succ_pred n) at 2.
rewrite opp_succ. now rewrite succ_pred.
Qed.

Theorem sub_diag : forall n, n - n == 0.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_diag".
nzinduct n.
now nzsimpl.
intro n. rewrite sub_succ_r, sub_succ_l; now rewrite pred_succ.
Qed.

Theorem add_opp_diag_l : forall n, - n + n == 0.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_opp_diag_l".
intro n; now rewrite add_comm, add_opp_r, sub_diag.
Qed.

Theorem add_opp_diag_r : forall n, n + (- n) == 0.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_opp_diag_r".
intro n; rewrite add_comm; apply add_opp_diag_l.
Qed.

Theorem add_opp_l : forall n m, - m + n == n - m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_opp_l".
intros n m; rewrite <- add_opp_r; now rewrite add_comm.
Qed.

Theorem add_sub_assoc : forall n m p, n + (m - p) == (n + m) - p.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_sub_assoc".
intros n m p; rewrite <- 2 add_opp_r; now rewrite add_assoc.
Qed.

Theorem opp_involutive : forall n, - (- n) == n.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.opp_involutive".
nzinduct n.
now nzsimpl.
intro n. rewrite opp_succ, opp_pred. now rewrite succ_inj_wd.
Qed.

Theorem opp_add_distr : forall n m, - (n + m) == - n + (- m).
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.opp_add_distr".
intros n m; nzinduct n.
now nzsimpl.
intro n. rewrite add_succ_l; do 2 rewrite opp_succ; rewrite add_pred_l.
now rewrite pred_inj_wd.
Qed.

Theorem opp_sub_distr : forall n m, - (n - m) == - n + m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.opp_sub_distr".
intros n m; rewrite <- add_opp_r, opp_add_distr.
now rewrite opp_involutive.
Qed.

Theorem opp_inj : forall n m, - n == - m -> n == m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.opp_inj".
intros n m H. apply opp_wd in H. now rewrite 2 opp_involutive in H.
Qed.

Theorem opp_inj_wd : forall n m, - n == - m <-> n == m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.opp_inj_wd".
intros n m; split; [apply opp_inj | intros; now f_equiv].
Qed.

Theorem eq_opp_l : forall n m, - n == m <-> n == - m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.eq_opp_l".
intros n m. now rewrite <- (opp_inj_wd (- n) m), opp_involutive.
Qed.

Theorem eq_opp_r : forall n m, n == - m <-> - n == m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.eq_opp_r".
symmetry; apply eq_opp_l.
Qed.

Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_add_distr".
intros n m p; rewrite <- add_opp_r, opp_add_distr, add_assoc.
now rewrite 2 add_opp_r.
Qed.

Theorem sub_sub_distr : forall n m p, n - (m - p) == (n - m) + p.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_sub_distr".
intros n m p; rewrite <- add_opp_r, opp_sub_distr, add_assoc.
now rewrite add_opp_r.
Qed.

Theorem sub_opp_l : forall n m, - n - m == - m - n.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_opp_l".
intros n m. rewrite <- 2 add_opp_r. now rewrite add_comm.
Qed.

Theorem sub_opp_r : forall n m, n - (- m) == n + m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_opp_r".
intros n m; rewrite <- add_opp_r; now rewrite opp_involutive.
Qed.

Theorem add_sub_swap : forall n m p, n + m - p == n - p + m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_sub_swap".
intros n m p. rewrite <- add_sub_assoc, <- (add_opp_r n p), <- add_assoc.
now rewrite add_opp_l.
Qed.

Theorem sub_cancel_l : forall n m p, n - m == n - p <-> m == p.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_cancel_l".
intros n m p. rewrite <- (add_cancel_l (n - m) (n - p) (- n)).
rewrite 2 add_sub_assoc. rewrite add_opp_diag_l; rewrite 2 sub_0_l.
apply opp_inj_wd.
Qed.

Theorem sub_cancel_r : forall n m p, n - p == m - p <-> n == m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_cancel_r".
intros n m p.
stepl (n - p + p == m - p + p) by apply add_cancel_r.
now do 2 rewrite <- sub_sub_distr, sub_diag, sub_0_r.
Qed.

Theorem add_move_l : forall n m p, n + m == p <-> m == p - n.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_move_l".
intros n m p.
stepl (n + m - n == p - n) by apply sub_cancel_r.
now rewrite add_comm, <- add_sub_assoc, sub_diag, add_0_r.
Qed.

Theorem add_move_r : forall n m p, n + m == p <-> n == p - m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_move_r".
intros n m p; rewrite add_comm; now apply add_move_l.
Qed.

Theorem sub_move_l : forall n m p, n - m == p <-> - m == p - n.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_move_l".
intros n m p; rewrite <- (add_opp_r n m); apply add_move_l.
Qed.

Theorem sub_move_r : forall n m p, n - m == p <-> n == p + m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_move_r".
intros n m p; rewrite <- (add_opp_r n m). now rewrite add_move_r, sub_opp_r.
Qed.

Theorem add_move_0_l : forall n m, n + m == 0 <-> m == - n.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_move_0_l".
intros n m; now rewrite add_move_l, sub_0_l.
Qed.

Theorem add_move_0_r : forall n m, n + m == 0 <-> n == - m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_move_0_r".
intros n m; now rewrite add_move_r, sub_0_l.
Qed.

Theorem sub_move_0_l : forall n m, n - m == 0 <-> - m == - n.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_move_0_l".
intros n m. now rewrite sub_move_l, sub_0_l.
Qed.

Theorem sub_move_0_r : forall n m, n - m == 0 <-> n == m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_move_0_r".
intros n m. now rewrite sub_move_r, add_0_l.
Qed.

Theorem add_simpl_l : forall n m, n + m - n == m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_simpl_l".
intros; now rewrite add_sub_swap, sub_diag, add_0_l.
Qed.

Theorem add_simpl_r : forall n m, n + m - m == n.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_simpl_r".
intros; now rewrite <- add_sub_assoc, sub_diag, add_0_r.
Qed.

Theorem sub_simpl_l : forall n m, - n - m + n == - m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_simpl_l".
intros; now rewrite <- add_sub_swap, add_opp_diag_l, sub_0_l.
Qed.

Theorem sub_simpl_r : forall n m, n - m + m == n.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_simpl_r".
intros; now rewrite <- sub_sub_distr, sub_diag, sub_0_r.
Qed.

Theorem sub_add : forall n m, m - n + n == m.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_add".
intros. now rewrite <- add_sub_swap, add_simpl_r.
Qed.

Theorem add_add_simpl_l_l : forall n m p, (n + m) - (n + p) == m - p.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_add_simpl_l_l".
intros n m p. now rewrite (add_comm n m), <- add_sub_assoc,
sub_add_distr, sub_diag, sub_0_l, add_opp_r.
Qed.

Theorem add_add_simpl_l_r : forall n m p, (n + m) - (p + n) == m - p.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_add_simpl_l_r".
intros n m p. rewrite (add_comm p n); apply add_add_simpl_l_l.
Qed.

Theorem add_add_simpl_r_l : forall n m p, (n + m) - (m + p) == n - p.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_add_simpl_r_l".
intros n m p. rewrite (add_comm n m); apply add_add_simpl_l_l.
Qed.

Theorem add_add_simpl_r_r : forall n m p, (n + m) - (p + m) == n - p.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.add_add_simpl_r_r".
intros n m p. rewrite (add_comm p m); apply add_add_simpl_r_l.
Qed.

Theorem sub_add_simpl_r_l : forall n m p, (n - m) + (m + p) == n + p.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_add_simpl_r_l".
intros n m p. now rewrite <- sub_sub_distr, sub_add_distr, sub_diag,
sub_0_l, sub_opp_r.
Qed.

Theorem sub_add_simpl_r_r : forall n m p, (n - m) + (p + m) == n + p.
Proof. hammer_hook "ZAdd" "ZAdd.ZAddProp.sub_add_simpl_r_r".
intros n m p. rewrite (add_comm p m); apply sub_add_simpl_r_l.
Qed.

End ZAddProp.


(**
 * Author:    Yuting Wang
 * Created:   Sep 5, 2019
*)

Require Import Arith.
Require Import ZArith.
Require Import List.
Require Import Utils.
Import ListNotations.

Open Scope list_scope.
Open Scope nat_scope.
Open Scope option_monad_scope.

Set Implicit Arguments.

(** * The Language of Simply Typed Lambda Calculus with Equality Proofs *)

(** The language is an extension of STLC with equality and proof terms.
    It is represented by using the hybrid de-bruijn representation first
    introduced by Stampoulis and Shao *)

(** ** The Syntax *)

(** Constants *)
Definition const := positive.

(** Types *)
Inductive ty : Type :=
| prop
| bty
| arr : ty -> ty -> ty.

(** Terms *)
Inductive term: Type :=
| cst  : const -> term
| fvar : nat -> term
| bvar : nat -> term
| abs  : ty -> term -> term
| app  : term -> term -> term
| teq   : term -> term -> term.

Notation "t1 == t2" := (teq t1 t2) (at level 60) : stlcd_scope.
Local Open Scope stlcd_scope.

(** Proof terms *)
Inductive pterm: Type :=
| refl: term -> pterm
| trans: pterm -> pterm -> pterm
| symm : pterm -> pterm
| congAbs: ty -> pterm -> pterm
| congAppL: pterm -> pterm
| congAppR: pterm -> pterm
| congEqL: pterm -> pterm
| congEqR: pterm -> pterm
| beta: ty -> term -> term -> pterm
| conv: pterm -> pterm -> pterm.

(** Typing contexts *)
Definition tyctx := list ty.

(** Simultaenous Substitutions *)
Definition sub := list term.

(** ** The Definitions of Freshing and Binding Operations *)

(** Freshening of terms *)
Fixpoint fresh_tm (t:term) (bn fn: nat) : term :=
  match t with
  | cst _ => t
  | fvar _ => t
  | bvar i => if beq_nat i bn then fvar fn else t
  | abs ty t =>
    abs ty (fresh_tm t (S bn) fn)
  | app t1 t2 =>
    app (fresh_tm t1 bn fn) (fresh_tm t2 bn fn)
  | t1 == t2 =>
    (fresh_tm t1 bn fn) == (fresh_tm t2 bn fn)
  end.

Definition fresh_tm_0 t fn := fresh_tm t 0 fn.

(** Freshening of proof terms *)
Fixpoint fresh_ptm (pt:pterm) (bn fn: nat) : pterm :=
  match pt with
  | refl t => refl (fresh_tm t bn fn)
  | trans pt1 pt2 =>
    trans (fresh_ptm pt1 bn fn) (fresh_ptm pt2 bn fn)
  | symm pt1 =>
    symm (fresh_ptm pt1 bn fn)
  | congAbs ty pt1 =>
    congAbs ty (fresh_ptm pt1 (S bn) fn)
  | congAppL pt1 =>
    congAppL (fresh_ptm pt1 bn fn)
  | congAppR pt1 =>
    congAppR (fresh_ptm pt1 bn fn)
  | congEqL pt1 =>
    congEqL (fresh_ptm pt1 bn fn)
  | congEqR pt1 =>
    congEqR (fresh_ptm pt1 bn fn)
  | beta ty t1 t2 =>
    beta ty (fresh_tm t1 (S bn) fn) (fresh_tm t2 bn fn)
  | conv pt1 pt2 =>
    conv (fresh_ptm pt1 bn fn) (fresh_ptm pt2 bn fn)
end.

Definition fresh_ptm_0 t fn := fresh_ptm t 0 fn.

(** Binding of terms *)
Fixpoint bind_tm (t:term) (bn fn: nat) : term :=
  match t with
  | cst _ => t
  | fvar i => if beq_nat i fn then bvar bn else t
  | bvar i => t
  | abs ty t =>
    abs ty (bind_tm t (S bn) fn)
  | app t1 t2 =>
    app (bind_tm t1 bn fn) (bind_tm t2 bn fn)
  | t1 == t2 =>
    (bind_tm t1 bn fn) == (bind_tm t2 bn fn)
  end.

Definition bind_tm_0 t fn := bind_tm t 0 fn.

(** Binding of proof terms *)
Fixpoint bind_ptm (pt:pterm) (bn fn: nat) : pterm :=
  match pt with
  | refl t => refl (fresh_tm t bn fn)
  | trans pt1 pt2 =>
    trans (bind_ptm pt1 bn fn) (bind_ptm pt2 bn fn)
  | symm pt1 =>
    symm (bind_ptm pt1 bn fn)
  | congAbs ty pt1 =>
    congAbs ty (bind_ptm pt1 (S bn) fn)
  | congAppL pt1 =>
    congAppL (bind_ptm pt1 bn fn)
  | congAppR pt1 =>
    congAppR (bind_ptm pt1 bn fn)
  | congEqL pt1 =>
    congEqL (bind_ptm pt1 bn fn)
  | congEqR pt1 =>
    congEqR (bind_ptm pt1 bn fn)
  | beta ty t1 t2 =>
    beta ty (fresh_tm t1 (S bn) fn) (fresh_tm t2 bn fn)
  | conv pt1 pt2 =>
    conv (bind_ptm pt1 bn fn) (bind_ptm pt2 bn fn)
end.

Definition bind_ptm_0 t fn := bind_ptm t 0 fn.

(** ** Operations on substitutions *)

(** Generate identity substitutions *)
Fixpoint idsub_acc (acc:sub) (n:nat) : sub :=
  match n with
  | O => acc
  | S n' => idsub_acc (fvar (length acc)::acc) n'
  end.

Compute (idsub_acc [] 11).

Definition idsub (n:nat) : sub :=
  idsub_acc [] n.

(** Access the i-th element of a substitution *)
(* Module ALT_SUB_INDEX. *)
(* Program Fixpoint index_sub (s:sub) (i: {n:nat | n < length s}) : term := *)
(*   match s with *)
(*   | [] => False_rec _ _ *)
(*   | t :: s' =>  *)
(*     match (proj1_sig i) with *)
(*     | O => t *)
(*     | S i' => index_sub s' (exist _ i' _) *)
(*     end *)
(*   end. *)
(* Next Obligation. *)
(*   simpl in H. eapply Nat.nlt_0_r; eauto. *)
(* Defined. *)
(* Next Obligation. *)
(*   simpl in H. apply lt_S_n. auto. *)
(* Defined. *)
(* End ALT_SUB_INDEX. *)

Definition index_sub (s:sub) (i:nat) : option term :=
  if le_dec i (length s -1) then
    nth_error s (length s - 1 - i)
  else
    None.

Compute (index_sub (idsub_acc [] 11) 10).

(** Application of substitution to terms *)
Fixpoint app_sub_tm (t:term) (s:sub) : option term :=
  match t with
  | cst _ => Some t
  | fvar i => index_sub s i
  | bvar _ => Some t
  | abs ty t1 =>
    do t1' <- app_sub_tm t1 s;
    Some (abs ty t1')
  | app t1 t2 =>
    do t1' <- app_sub_tm t1 s;
    do t2' <- app_sub_tm t2 s;
    Some (app t1' t2')
  | t1 == t2 =>
    do t1' <- app_sub_tm t1 s;
    do t2' <- app_sub_tm t2 s;
    Some (t1' == t2')
  end.

(** Application of substitution to proof terms *)
Fixpoint app_sub_ptm (pt:pterm) (s:sub) : option pterm :=
  match pt with
  | refl t =>
    do t' <- app_sub_tm t s;
    Some (refl t')
  | trans pt1 pt2 =>
    do pt1' <- app_sub_ptm pt1 s;
    do pt2' <- app_sub_ptm pt2 s;
    Some (trans pt1' pt2')
  | symm pt1 =>
    do pt1' <- app_sub_ptm pt1 s;
    Some (symm pt1')
  | congAbs ty pt1 =>
    do pt1' <- app_sub_ptm pt1 s;
    Some (congAbs ty pt1')
  | congAppL pt1 =>
    do pt1' <- app_sub_ptm pt1 s;
    Some (congAppL pt1')
  | congAppR pt1 =>
    do pt1' <- app_sub_ptm pt1 s;
    Some (congAppR pt1')
  | congEqL pt1 =>
    do pt1' <- app_sub_ptm pt1 s;
    Some (congEqL pt1')
  | congEqR pt1 =>
    do pt1' <- app_sub_ptm pt1 s;
    Some (congEqR pt1')
  | beta ty t1 t2 =>
    do t1' <- app_sub_tm t1 s;
    do t2' <- app_sub_tm t2 s;
    Some (beta ty t1' t2')
  | conv pt1 pt2 =>
    do pt1' <- app_sub_ptm pt1 s;
    do pt2' <- app_sub_ptm pt2 s;
    Some (conv pt1' pt2')
end.

(** ** Operations on typing contexts *)
Definition index_ctx (ctx:tyctx) (i:nat) : option ty :=
  if Nat.leb i (length ctx -1) then
    nth_error ctx (length ctx - 1 - i)
  else
    None.

(** ** Typing rules *)

(** Signatures *)
Definition sign := const -> option ty.
Definition empty_sign: sign := fun _ => None.

(** Typing rules for terms *)
Inductive tm_of: sign -> tyctx -> term -> ty -> Prop :=
| tm_of_cst : forall sgn ctx c ty, sgn c = Some ty -> tm_of sgn ctx (cst c) ty
| tm_of_fvar : forall sgn ctx i ty,
    index_ctx ctx i = Some ty ->
    tm_of sgn ctx (fvar i) ty
| tm_of_abs : forall sgn ctx ty1 ty2 t n,
    length ctx = n ->
    tm_of sgn (ty1::ctx) (fresh_tm_0 t n) ty2 ->
    tm_of sgn ctx (abs ty1 t) (arr ty1 ty2)
| tm_of_app : forall sgn ctx t1 t2 ty1 ty2,
    tm_of sgn ctx t1 (arr ty1 ty2) ->
    tm_of sgn ctx t2 ty1 ->
    tm_of sgn ctx (app t1 t2) ty2
| tm_of_eq : forall sgn ctx t1 t2 ty,
    tm_of sgn ctx t1 ty ->
    tm_of sgn ctx t2 ty ->
    tm_of sgn ctx (t1 == t2) prop.

Notation "S ; C |- t : ty" := (tm_of S C t ty)
  (at level 70, C at level 200, t at level 100, ty at level 200): stlcd_scope.

(** Typing rules for proof terms *)
Inductive ptm_of: sign -> tyctx -> pterm -> term -> Prop :=
| ptm_of_refl: forall sgn ctx t ty,
    tm_of sgn ctx t ty ->
    ptm_of sgn ctx (refl t) (t == t)
| ptm_of_trans: forall sgn ctx pt1 pt2 t1 t2 t3,
    ptm_of sgn ctx pt1 (t1 == t2) ->
    ptm_of sgn ctx pt2 (t2 == t3) ->
    ptm_of sgn ctx (trans pt1 pt2) (t1 == t3)
| ptm_of_symm: forall sgn ctx pt t1 t2,
    ptm_of sgn ctx pt (t2 == t1) ->
    ptm_of sgn ctx (symm pt) (t1 == t2)
| ptm_of_congAbs: forall sgn ctx ty pt t1 t2 n,
    length ctx = n ->
    ptm_of sgn (ty::ctx) (fresh_ptm_0 pt n) (t1 == t2) ->
    ptm_of sgn ctx (congAbs ty pt)
           (abs ty (bind_tm_0 t1 (length ctx)) == abs ty (bind_tm_0 t2 n))
| ptm_of_congAppL: forall sgn ctx pt t1 t1' t2,
    ptm_of sgn ctx pt (t1 == t1') ->
    ptm_of sgn ctx (congAppL pt) (app t1 t2 == app t1' t2)
| ptm_of_congAppR: forall sgn ctx pt t1 t2 t2',
    ptm_of sgn ctx pt (t2 == t2') ->
    ptm_of sgn ctx (congAppR pt) (app t1 t2 == app t1 t2')
| ptm_of_congEqL: forall sgn ctx pt t1 t1' t2,
    ptm_of sgn ctx pt (t1 == t1') ->
    ptm_of sgn ctx (congEqL pt) ((t1 == t2) == (t1' == t2))
| ptm_of_congEqR: forall sgn ctx pt t1 t2 t2',
    ptm_of sgn ctx pt (t2 == t2') ->
    ptm_of sgn ctx (congEqR pt) ((t1 == t2) == (t1 == t2'))
| ptm_of_beta: forall sgn ctx t1 t2 t3 n ty1 ty2,
    length ctx = n ->
    tm_of sgn ctx (abs ty1 t1) (arr ty1 ty2) ->
    tm_of sgn ctx t2 ty1 ->
    app_sub_tm (fresh_tm_0 t1 n) (t2::(idsub n)) = Some t3 ->
    ptm_of sgn ctx (beta ty1 t1 t2)
           (app (abs ty1 t1) t2 == t3)
| ptm_of_conv: forall sgn ctx pt1 pt2 t1 t2,
    ptm_of sgn ctx pt1 t1 ->
    ptm_of sgn ctx pt2 (t1 == t2) ->
    ptm_of sgn ctx (conv pt1 pt2) t2.

Notation "S; C ||- pt : t" := (ptm_of S C pt t)
  (at level 70): stlcd_scope.

Local Open Scope stlcd_scope.

(** ** Examples *)
Definition a := bty.
(** x: a -> a |- fun y:a => x y : arr a a *)
Example of_tm_ex1: tm_of empty_sign [arr a a] (abs a (app (fvar 0) (bvar 0))) (arr a a).
Proof.
  econstructor. reflexivity.
  cbn.
  econstructor.
  constructor. cbn. reflexivity.
  constructor. cbn. auto.
Qed.

Example of_tm_ex2: forall t,
    tm_of empty_sign [arr a a] (abs a (app (fvar 0) (bvar 0))) t ->
    t = arr a a.
Proof.
  intros t OF.
  inversion OF; subst; cbn in *.
  inversion H5; subst; cbn in *.
  inversion H3; subst; cbn in *.
  inversion H2; subst. auto.
Qed.

(** z:a -> a |- pt: (fun x:a->a => fun y:a => x y) z = (fun y:a => z y) *)
Example pof_tm_ex1: exists pt,
    ptm_of empty_sign [arr a a] pt
           (app (abs (arr a a) (abs a (app (bvar 1) (bvar 0)))) (fvar 0) ==
            abs a (app (fvar 0) (bvar 0))).
Proof.
  eexists.
  eapply ptm_of_beta. reflexivity.
  - econstructor. reflexivity.
    cbn. econstructor. reflexivity.
    cbn. econstructor. constructor. cbn. reflexivity.
    econstructor. reflexivity.
  - constructor. reflexivity.
  - cbn. reflexivity.
Qed.

Example pof_tm_ex2: forall pt,
    pt = beta (arr a a) (abs a (app (bvar 1) (bvar 0))) (fvar 0) ->
    ptm_of empty_sign [arr a a] pt
           (app (abs (arr a a) (abs a (app (bvar 1) (bvar 0)))) (fvar 0) ==
            abs a (app (fvar 0) (bvar 0))).
Proof.
  intros. subst.
  eapply ptm_of_beta. reflexivity.
  econstructor. reflexivity.
  cbn. econstructor. reflexivity.
  cbn. econstructor. econstructor. reflexivity.
  econstructor. reflexivity.
  econstructor. reflexivity.
  cbn. reflexivity.
Qed.

(** ** Decidability of substitution applications *)
Definition ty_dec (ty1 ty2: ty) : {ty1 = ty2} + {ty1 <> ty2}.
  decide equality.
Qed.

Definition tm_dec (t1 t2: term) : {t1 = t2} + {t1 <> t2}.
  decide equality; decide equality.
Qed.

(* Program Fixpoint ty_dec ty1 ty2 : {ty1 = ty2} + {ty1 <> ty2} := *)
(*   match ty1, ty2 with *)
(*   | prop, prop => left _ *)
(*   | bty, bty => left _ *)
(*   | arr ty1' ty1'', arr ty2' ty2'' => *)
(*     if ty_dec ty1' ty2' then *)
(*       if ty_dec ty1'' ty2'' then left _ else right _ *)
(*     else *)
(*       right _ *)
(*   | _, _ => right _ *)
(*   end. *)
(* Next Obligation. *)
(*   destruct ty1, ty2; try tauto; try (intro EQ; congruence). *)
(*   intro EQ. eapply H0; eauto. *)
(* Defined. *)
(* Next Obligation. *)
(*   split. intros [H1 H2]. congruence. *)
(*   split. intros ty1' ty1'' ty2' ty2'' [H1 H2]. congruence. *)
(*   intros [H1 H2]. congruence. *)
(* Defined. *)
(* Next Obligation. *)
(*   split. intros [H1 H2]. congruence. *)
(*   split. intros ty1' ty1'' ty2' ty2'' [H1 H2]. congruence. *)
(*   intros [H1 H2]. congruence. *)
(* Defined. *)
(* Next Obligation. *)
(*   split. intros [H1 H2]. congruence. *)
(*   split. intros ty1' ty1'' ty2' ty2'' [H1 H2]. congruence. *)
(*   intros [H1 H2]. congruence. *)
(* Defined. *)
(* Next Obligation. *)
(*   split. intros [H1 H2]. congruence. *)
(*   split. intros ty1' ty1'' ty2' ty2'' [H1 H2]. congruence. *)
(*   intros [H1 H2]. congruence. *)
(* Defined.   *)
(* Next Obligation. *)
(*   split. intros [H1 H2]. congruence. *)
(*   split. intros ty1' ty1'' ty2' ty2'' [H1 H2]. congruence. *)
(*   intros [H1 H2]. congruence. *)
(* Defined.   *)
(* Next Obligation. *)
(*   split. intros [H1 H2]. congruence. *)
(*   split. intros ty1' ty1'' ty2' ty2'' [H1 H2]. congruence. *)
(*   intros [H1 H2]. congruence. *)
(* Defined.   *)

Lemma app_sub_tm_cst: forall c s t, app_sub_tm (cst c) s = Some t -> t = (cst c).
Proof.
  simpl. intros. congruence.
Qed.

Lemma app_sub_tm_bvar: forall i s t, app_sub_tm (bvar i) s = Some t -> t = (bvar i).
Proof.
  simpl. intros. congruence.
Qed.

Lemma app_sub_tm_abs: forall ty t s t',
    app_sub_tm (abs ty t) s = Some t' ->
    exists t1, app_sub_tm t s = Some t1 /\ t' = abs ty t1.
Proof.
  simpl. intros.
  opt_monad_inv H.
  eauto.
Qed.

Lemma app_sub_tm_app: forall t1 t2 s t',
    app_sub_tm (app t1 t2) s = Some t' ->
    exists t1' t2', app_sub_tm t1 s = Some t1' /\
               app_sub_tm t2 s = Some t2' /\
               t' = app t1' t2'.
Proof.
  simpl. intros.
  opt_monad_inv H.
  eauto.
Qed.

Lemma app_sub_tm_teq: forall t1 t2 s t',
    app_sub_tm (t1 == t2) s = Some t' ->
    exists t1' t2', app_sub_tm t1 s = Some t1' /\
               app_sub_tm t2 s = Some t2' /\
               t' = (t1' == t2').
Proof.
  simpl; intros.
  opt_monad_inv H.
  eauto.
Qed.

(** Decidability of index_sub *)
Program Definition index_sub_dec t s i:
  {index_sub s i = Some t} + {index_sub s i <> Some t} :=
  if le_dec i (length s - 1) then
    match nth_error s (length s - 1 - i) with
    | None => right _
    | Some t' =>
      if tm_dec t t' then left _ else right _
    end
  else
    right _.
Next Obligation.
  unfold index_sub.
  destruct (le_dec i (length s - 1)); congruence.
Defined.
Next Obligation.
  unfold index_sub.
  destruct (le_dec i (length s - 1)); congruence.
Defined.
Next Obligation.
  unfold index_sub.
  destruct (le_dec i (length s - 1)); congruence.
Defined.
Next Obligation.
  unfold index_sub.
  destruct (le_dec i (length s - 1)); congruence.
Defined.

Local Ltac solve_cong :=
  lazymatch goal with
  | [ |- forall _, _ ] =>
    intro; solve_cong
  | [ |- ~ (_ /\ _) ] =>
    let H1 := fresh "H" in
    let H2 := fresh "H" in
    intros; intros (H1 & H2); congruence
  end.

Local Ltac solve_neq :=
  match goal with
  | [ |- _ <> _ ] =>
    let EQ := fresh "EQ" in
    intro EQ; opt_monad_inv EQ; simpl in *; congruence
  end.

Show Obligation Tactic.

Local Obligation Tactic :=
  Tactics.program_simpl;
  try solve_neq; try (repeat split; solve_cong).

Program Fixpoint app_sub_tm_dec t s t'
  : {app_sub_tm t s = Some t'} + {app_sub_tm t s <> Some t'} :=
  match t, t' with
  | cst i, cst i' =>
    if Pos.eq_dec i i' then left _ else right _
  | fvar i, _ =>
    if index_sub_dec t' s i then left _ else right _
  | bvar i, bvar i' =>
    if Nat.eq_dec i i' then left _ else right _
  | abs ty t1, abs ty' t1' =>
    if ty_dec ty ty' then
      if app_sub_tm_dec t1 s t1' then left _ else right _
    else
      right _
  | app t1 t2, app t1' t2' =>
    if app_sub_tm_dec t1 s t1' then
      if app_sub_tm_dec t2 s t2' then left _ else right _
    else
      right _
  | t1 == t2, t1' == t2' =>
    if app_sub_tm_dec t1 s t1' then
      if app_sub_tm_dec t2 s t2' then left _ else right _
    else
      right _
  | _, _ => right _
  end.
Next Obligation.
  rewrite H0. simpl. auto.
Defined.
Next Obligation.
  rewrite H, H0. simpl. congruence.
Defined.
Next Obligation.
  rewrite H, H0. simpl. congruence.
Defined.
Next Obligation.
  intro EQ.
  destruct t.
  - apply app_sub_tm_cst in EQ; subst. eapply H4; eauto.
  - eapply H; eauto.
  - apply app_sub_tm_bvar in EQ; subst. eapply H0; eauto.
  - apply app_sub_tm_abs in EQ. destruct EQ as [t1 [EQ1 EQ2]]. subst.
    eapply H1; eauto.
  - apply app_sub_tm_app in EQ.
    destruct EQ as (t1' & t2' & EQ1 & EQ2 & EQ3). subst.
    eapply H2; eauto.
  - apply app_sub_tm_teq in EQ.
    destruct EQ as (t1' & t2' & EQ1 & EQ2 & EQ3). subst.
    eapply H3; eauto.
Defined.

(** ** Decidability of typing terms *)

Definition sign_dec: forall (sgn:sign) c ty,
    {sgn c = Some ty} + {sgn c <> Some ty}.
Proof.
  decide equality.
  apply ty_dec.
Defined.

Definition index_ctx_dec C i ty
  : {index_ctx C i = Some ty} + {index_ctx C i <> Some ty}.
Proof.
  decide equality.
  apply ty_dec.
Defined.

(* Program Fixpoint tm_of_dec S C t ty : *)
(*   {tm_of S C t ty} + {~tm_of S C t ty} := *)
(*   match t with *)
(*   | cst c =>  *)
(*     if sign_dec S c ty then left _ else right _ *)
(*   | fvar i => *)
(*     if index_ctx_dec C i ty then left _ else right _ *)
(*   | _ => right _ *)
(*   end. *)
(* Next Obligation. *)
(*   constructor. auto. *)
(* Defined. *)
(* Next Obligation. *)
(*   intro OF. apply H. inversion OF; auto. *)
(* Defined. *)
(* Next Obligation. *)
(*   constructor. auto. *)
(* Defined. *)
(* Next Obligation. *)
(*   intro OF. apply H. inversion OF; subst. auto. *)
(* Defined. *)


Require Import
  Arith
  ZArith
  Omega
  List
  Zwf
  Relations
  Inverse_Image
  Transitive_Closure
  Zdiv.

Theorem divisor_smaller :
  forall m p:nat, 0 < m -> forall q:nat, m = q * p -> q <= m.
  induction m.
  auto with *.
  induction p.
  auto with *.
  intros.
  rewrite H0.
  rewrite mult_succ_r.
  auto with *.
Qed.

Theorem verif_divide :
  forall m p:nat, 0 < m -> 0 < p ->
    (exists q:nat, m = q*p)->(Z_of_nat m mod Z_of_nat p = 0)%Z.
  intros m p Hltm Hltp (q, Heq).
  subst.
  rewrite inj_mult.
  replace (Z_of_nat q * Z_of_nat p)%Z with (0 + Z_of_nat q * Z_of_nat p)%Z.
  rewrite Z_mod_plus.
  auto.
  omega.
  ring.
Qed.

Open Scope nat_scope.

Inductive bin : Set :=
| node: bin -> bin ->  bin
| leaf: nat ->  bin
| neutral: bin .

Fixpoint flatten_aux (t fin : bin) {struct t} : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten_aux t2 fin)
  | x => node x fin
  end.

Fixpoint flatten (t : bin) : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten t2)
  | x => x
  end.

Fixpoint remove_neutral1 (t : bin) : bin :=
  match t with
  | leaf n => leaf n
  | neutral => neutral
  | node neutral t' => remove_neutral1 t'
  | node t t' => node t (remove_neutral1 t')
  end.

Fixpoint remove_neutral2 (t : bin) : bin :=
  match t with
  | leaf n => leaf n
  | neutral => neutral
  | node t neutral => t
  | node t1 t2 => node t1 (remove_neutral2 t2)
  end.

Definition remove_neutral (t : bin) := remove_neutral2 (remove_neutral1 t).

Section assoc_eq.

Variables
  (A : Set) (f : A -> A ->  A) (zero_A : A)
  (assoc : forall (x y z : A),  f x (f y z) = f (f x y) z)
  (zero_left : forall (x : A),  f zero_A x = x)
  (zero_right : forall (x : A),  f x zero_A = x).

Fixpoint bin_A (l : list A) (t : bin) {struct t} : A :=
  match t with
  | node t1 t2 => f (bin_A l t1) (bin_A l t2)
  | leaf n => nth n l zero_A
  | neutral => zero_A
  end.

Theorem flatten_aux_valid_A:
  forall (l : list A) (t t' : bin),
    f (bin_A l t) (bin_A l t') = bin_A l (flatten_aux t t').
  induction t.
  simpl.
  intuition.
  rewrite <- IHt1.
  rewrite <- IHt2.
  auto.
  simpl.
  auto.
  simpl.
  auto.
Qed.

Theorem flatten_valid_A:
  forall (l : list A) (t : bin),  bin_A l t = bin_A l (flatten t).
  induction t.
  simpl.
  rewrite <- flatten_aux_valid_A.
  f_equal.
  trivial.
  trivial.
  trivial.
Qed.

Theorem flatten_valid_A_2:
  forall (t t' : bin) (l : list A),
    bin_A l (flatten t) = bin_A l (flatten t') ->  bin_A l t = bin_A l t'.
  intros.
  rewrite (flatten_valid_A l t).
  rewrite (flatten_valid_A l t').
  trivial.
Qed.

Theorem remove_neutral1_valid_A:
  forall (l : list A) (t : bin),  bin_A l (remove_neutral1 t) = bin_A l t.
  induction t.
  case t1.
  simpl.
  intros.
  f_equal.
  trivial.
  intros.
  simpl in *.
  f_equal.
  trivial.
  simpl in *.
  rewrite IHt2.
  trivial.
  auto.
  trivial.
  trivial.
Qed.

Theorem remove_neutral2_valid_A:
  forall (l : list A) (t : bin),  bin_A l (remove_neutral2 t) = bin_A l t.
  intros.
  elim t.
  destruct b0.
  simpl.
  intuition.
  f_equal.
  trivial.
  trivial.
  eauto.
  trivial.
  trivial.
Qed.

Theorem remove_neutral_equal:
  forall (t t' : bin) (l : list A),
    bin_A l (remove_neutral t) = bin_A l (remove_neutral t') ->
      bin_A l t = bin_A l t'.
  unfold remove_neutral.
  intros.
  repeat rewrite remove_neutral2_valid_A in *.
  repeat rewrite remove_neutral1_valid_A in *.
  trivial.
Qed.

End assoc_eq.

Ltac term_list f l zero v :=
  match v with
  | f ?X1 ?X2 =>
      let l1 := term_list f l zero X2 in
        term_list f l1 zero X1
  | zero => l
  | ?X1 => constr:(cons X1 l)
  end.

Ltac compute_rank l n v :=
  match l with
  | cons ?X1 ?X2 =>
      let tl := constr:X2 in
      match constr:(X1 = v) with
      | ?X1 = ?X1 => n
      | _ => compute_rank tl (S n) v
      end
  end.

Ltac model_aux l f zero v :=
  match v with
  | f ?X1 ?X2 =>
      let r1 := model_aux l f zero X1 with r2 := model_aux l f zero X2 in
        constr:(node r1 r2)
  | zero => constr:neutral
  | ?X1 =>
      let n := compute_rank l 0 X1 in
        constr:(leaf n)
  end.

Ltac model_A A f zero v :=
  let l := term_list f (nil (A:=A)) zero v in
    let t := model_aux l f zero v in
      constr:(bin_A A f zero l t).

Ltac assoc_eq A f zero assoc_thm neutral_left_thm neutral_right_thm :=
match goal with
| |- @eq A ?X1 ?X2 =>
  let term1 := model_A A f zero X1 with term2 := model_A A f zero X2 in
    (change (term1 = term2); apply flatten_valid_A_2 with ( 1 := assoc_thm );
      apply remove_neutral_equal
        with ( 1 := neutral_left_thm ) ( 2 := neutral_right_thm ); auto)
end.

Theorem reflection_test3:
  forall (x y z t u : Z),
    (x * (((y * z) *1 )* (t * u)) =
    (x * (1 * y * 1)) * (z * (t * u)) * 1)%Z.
  intros.
  assoc_eq Z Zmult 1%Z Zmult_assoc Zmult_1_l Zmult_1_r.
Qed.