Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Cartesian.
Require Export Category.Instance.Sets.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section Closed.

Context {C : Category}.
Context `{@Cartesian C}.

Class Closed := {
  exponent_obj : obj -> obj -> obj    (* internal homs *)
    where "y ^ x" := (exponent_obj x y);

  exp_iso {x y z} : x × y ~> z ≊ x ~> z^y;

  curry'   {x y z} := to (@exp_iso x y z);
  uncurry' {x y z} := from (@exp_iso x y z);

  eval' {x y} : y^x × x ~> y := uncurry' _ _ _ id;

  ump_exponents' {x y z} (f : x × y ~> z) :
    eval' ∘ first (curry' _ _ _ f) ≈ f
}.

Notation "y ^ x" := (exponent_obj x y)
  (at level 30, right associativity) : object_scope.

Context `{@Closed}.

Definition curry   {x y z} := @curry' _ x y z.
Definition uncurry {x y z} := @uncurry' _ x y z.
Arguments curry' {_ _ _ _} /.
Arguments uncurry' {_ _ _ _} /.

Definition eval {x y} : y^x × x ~> y := uncurry id.
Arguments eval' {_ _ _} /.

Definition ump_exponents {x y z} (f : x × y ~> z) :
  eval ∘ first (curry f) ≈ f := @ump_exponents' _ x y z f.

Global Program Instance parametric_morphism_curry (a b c : C) :
  Proper (equiv ==> equiv) (@curry a b c).
Next Obligation.
  proper.
  unfold curry; simpl in *.
  destruct exp_iso; simpl in *.
  destruct to; simpl in *.
  rewrites; reflexivity.
Qed.

Global Program Instance parametric_morphism_uncurry (a b c : C) :
  Proper (equiv ==> equiv) (@uncurry a b c).
Next Obligation.
  proper.
  unfold uncurry; simpl in *.
  destruct exp_iso; simpl in *.
  destruct from; simpl in *.
  rewrites; reflexivity.
Qed.

Corollary curry_uncurry {x y z} (f : x ~> z^y) :
  curry (uncurry f) ≈ f.
Proof.
  replace (curry (uncurry f)) with ((curry ∘ uncurry) f) by auto.
  unfold curry, uncurry; simpl.
  pose proof (iso_to_from (@exp_iso _ x y z)) as HA.
  unfold equiv in HA; simpl in HA.
  autounfold in HA.
  unfold equiv in HA; simpl in HA.
  apply HA.
Qed.

Corollary uncurry_curry {x y z} (f : x × y ~> z) :
  uncurry (curry f) ≈ f.
Proof.
  replace (uncurry (curry f)) with ((uncurry ∘ curry) f) by auto.
  unfold curry, uncurry; simpl.
  pose proof (iso_from_to (@exp_iso _ x y z)) as HA.
  simpl in HA.
  unfold equiv in HA; simpl in HA.
  autounfold in HA.
  unfold equiv in HA; simpl in HA.
  apply HA.
Qed.

Hint Rewrite @curry_uncurry : categories.
Hint Rewrite @uncurry_curry : categories.
Hint Rewrite @ump_exponents : categories.

Definition flip {x y z : C} `(f : x ~> z ^ y) : y ~> z ^ x :=
  curry (uncurry f ∘ swap).

Corollary eval_curry {x y z w : C} (f : y × z ~> w) (g : x ~> y) (h : x ~> z) :
  eval ∘ ((curry f ∘ g) △ h) ≈ f ∘ g △ h.
Proof.
  intros.
  rewrite <- (ump_exponents f) at 2.
  rewrite <- comp_assoc.
  unfold first.
  rewrite <- fork_comp; cat.
  rewrite <- comp_assoc; cat.
Qed.

Hint Rewrite @eval_curry : categories.

Corollary curry_eval {x y : C} :
  curry eval ≈ @id _ (y^x).
Proof.
  intros; unfold eval; simpl; cat.
Qed.

Hint Rewrite @curry_eval : categories.

Corollary eval_first {x y z : C} (f : x ~> z^y) :
  eval ∘ first f ≈ uncurry f.
Proof.
  rewrite <- (curry_uncurry f); cat.
Qed.

Corollary curry_inj {x y z : C} (f g : x × y ~> z) :
  curry f ≈ curry g -> f ≈ g.
Proof.
  intros.
  rewrite <- (uncurry_curry f).
  rewrite <- (uncurry_curry g).
  rewrites; reflexivity.
Qed.

Corollary uncurry_inj {x y z : C} (f g : x ~> z^y) :
  uncurry f ≈ uncurry g -> f ≈ g.
Proof.
  intros.
  rewrite <- (curry_uncurry f).
  rewrite <- (curry_uncurry g).
  rewrites; reflexivity.
Qed.

Corollary curry_comp_l {x y z w : C} (f : y × z ~> w) (g : x ~> y) :
  curry f ∘ g ≈ curry (f ∘ first g).
Proof.
  apply uncurry_inj; cat.
  rewrite <- (ump_exponents (uncurry (curry f ∘ g))).
  rewrite curry_uncurry.
  unfold first in *.
  rewrite <- comp_assoc.
  rewrite eval_curry.
  reflexivity.
Qed.

Corollary curry_comp {x y z w : C} (f : z ~> w) (g : x × y ~> z) :
  curry (f ∘ g) ≈ curry (f ∘ eval) ∘ curry g.
Proof.
  rewrite curry_comp_l.
  rewrite <- comp_assoc.
  rewrite eval_first; cat.
Qed.

Corollary uncurry_comp_r {x y z w : C} (f : z ~> w) (g : x ~> z^y) :
  f ∘ uncurry g ≈ uncurry (curry (f ∘ eval) ∘ g).
Proof.
  rewrite curry_comp_l; cat.
  rewrite <- comp_assoc.
  rewrite eval_first; reflexivity.
Qed.

Corollary uncurry_comp {x y z w : C} (f : y ~> w^z) (g : x ~> y) :
  uncurry (f ∘ g) ≈ uncurry f ∘ first g.
Proof.
  intros.
  apply curry_inj; cat.
  rewrite <- curry_comp_l; cat.
Qed.

Theorem curry_id {x y z : C} (f : x ~> y) :
  curry (@id _ (y × z)) ∘ f ≈ curry (first f).
Proof.
  intros.
  rewrite curry_comp_l.
  apply uncurry_inj; cat.
Qed.

Global Program Instance exp_respects_iso {x y z : C} :
  Proper (Isomorphism ==> Isomorphism ==> Isomorphism) exponent_obj.
Next Obligation.
  proper.
  transitivity (y1 ^ x0). {
    isomorphism.
    - apply (curry (to X0 ∘ eval)).
    - apply (curry (from X0 ∘ eval)).
    - rewrite <- curry_comp.
      rewrite comp_assoc.
      rewrite iso_to_from, id_left.
      rewrite curry_eval.
      reflexivity.
    - rewrite <- curry_comp.
      rewrite comp_assoc.
      rewrite iso_from_to, id_left.
      rewrite curry_eval.
      reflexivity.
  }
  isomorphism.
  - apply (curry (eval ∘ second (from X))).
  - apply (curry (eval ∘ second (to X))).
  - rewrite curry_comp_l.
    rewrite <- comp_assoc.
    rewrite <- first_second.
    rewrite comp_assoc.
    rewrite eval_first.
    rewrite uncurry_curry.
    rewrite <- comp_assoc.
    rewrite <- second_comp.
    rewrite iso_to_from.
    rewrite second_id, id_right.
    rewrite curry_eval.
    reflexivity.
  - rewrite curry_comp_l.
    rewrite <- comp_assoc.
    rewrite <- first_second.
    rewrite comp_assoc.
    rewrite eval_first.
    rewrite uncurry_curry.
    rewrite <- comp_assoc.
    rewrite <- second_comp.
    rewrite iso_from_to.
    rewrite second_id, id_right.
    rewrite curry_eval.
    reflexivity.
Qed.

Global Program Instance exp_prod_l {x y z : C} :
  z^(x × y) ≅ (z^y)^x := {
  to   := curry (curry (eval ∘ to prod_assoc));
  from := curry (uncurry eval ∘ from prod_assoc)
}.
Next Obligation.
  rewrite curry_comp_l.
  unfold first.
  rewrite curry_comp_l.
  unfold first.
  rewrite <- comp_assoc.
  rewrite <- fork_comp.
  rewrite <- comp_assoc; cat.
  rewrite comp_assoc; cat.
  rewrite <- fork_comp; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite comp_assoc; cat.
  rewrite comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- fork_comp.
  rewrite <- fork_comp; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite fork_comp; cat.
Qed.
Next Obligation.
  rewrite curry_comp_l.
  apply uncurry_inj; cat.
  rewrite <- comp_assoc.
  rewrite <- eval_first.
  rewrite <- comp_assoc.
  rewrite (comp_assoc (first eval)).
  unfold first at 1.
  rewrite <- fork_comp.
  rewrite <- comp_assoc; cat.
  unfold first.
  rewrite <- fork_comp.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- fork_comp.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- fork_comp; cat.
  rewrite <- fork_comp; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- comp_assoc; cat.
  rewrite fork_comp; cat.
Qed.

Hint Rewrite @exp_prod_l : isos.

Global Program Instance exp_prod_r {x y z : C} :
  (y × z)^x ≅ y^x × z^x := {
  to   := curry (exl ∘ eval) △ curry (exr ∘ eval);
  from := curry (uncurry exl △ uncurry exr)
}.
Next Obligation.
  rewrite <- fork_comp.
  rewrite <- fork_exl_exr.
  apply fork_inv; split;
  rewrite <- curry_comp; cat;
  pose proof (@eval_first) as HA;
  unfold first in HA;
  rewrites; cat.
Qed.
Next Obligation.
  apply uncurry_inj.
  rewrite uncurry_comp; cat.
  rewrite <- fork_comp.
  rewrite <- !eval_first.
  rewrite <- !comp_assoc.
  rewrite <- !first_comp; cat.
  rewrite fork_comp; cat.
  unfold first; cat.
Qed.

Hint Rewrite @exp_prod_r : isos.

Local Obligation Tactic := program_simpl.

Global Program Instance exp_swap {x y z : C} :
  (z^y)^x ≅ (z^x)^y := {
  to   := to exp_prod_l
        ∘ to (@exp_respects_iso x y z _ _ (@prod_comm _ _ x y) z z iso_id)
        ∘ from exp_prod_l;
  from := to exp_prod_l
        ∘ from (@exp_respects_iso x y z _ _ (@prod_comm _ _ x y) z z iso_id)
        ∘ from exp_prod_l
}.
Next Obligation.
  rewrite <- !comp_assoc.
  rewrite (comp_assoc (curry _) (curry _)).
  rewrite (iso_from_to exp_prod_l), id_left.
  rewrite (comp_assoc (exp_respects_iso _ _ _ _ _ _)).
  rewrite iso_to_from, id_left.
  apply (iso_to_from exp_prod_l).
Defined.
Next Obligation.
  rewrite <- !comp_assoc.
  rewrite (comp_assoc (curry _) (curry _)).
  rewrite (iso_from_to exp_prod_l), id_left.
  rewrite (comp_assoc _ (exp_respects_iso _ _ _ _ _ _)).
  rewrite iso_from_to, id_left.
  apply (iso_to_from exp_prod_l).
Defined.

Lemma curry_fork {x y z w : C} (f : x × y ~> z) (g : x × y ~> w) :
  curry (f △ g) ≈ from exp_prod_r ∘ curry f △ curry g.
Proof.
  simpl.
  apply uncurry_inj; cat.
  rewrite uncurry_comp; cat.
  unfold first.
  rewrite <- fork_comp.
  apply fork_inv; split;
  rewrite <- eval_curry;
  rewrite curry_uncurry;
  rewrite comp_assoc; cat.
Qed.

Corollary curry_unfork {x y z w : C} (f : x × y ~> z) (g : x × y ~> w) :
  curry f △ curry g ≈ to exp_prod_r ∘ curry (f △ g).
Proof.
  rewrite curry_fork.
  rewrite comp_assoc.
  rewrite iso_to_from; cat.
Qed.

Context `{@Terminal C}.

Global Program Instance exp_one {x : C} :
  x^1 ≅ x := {
  to   := eval ∘ id △ one;
  from := curry exl
}.
Next Obligation.
  rewrite <- comp_assoc.
  rewrite <- fork_comp; cat.
  rewrite <- (id_right (curry exl)); cat.
Qed.
Next Obligation.
  rewrite comp_assoc.
  rewrite !curry_comp_l.
  apply uncurry_inj; cat.
  unfold first, eval; cat.
  rewrite <- comp_assoc; cat.
  rewrite <- fork_comp.
  rewrite id_left.
  cut (@one _ _ (x^1) ∘ exl ≈ exr).
    intros; rewrites; cat.
  cat.
Qed.

Hint Rewrite @exp_one : isos.

Global Program Instance one_exp {x : C} :
  1^x ≅ 1 := {
  to   := one;
  from := curry one
}.
Next Obligation. apply one_unique. Qed.
Next Obligation.
  rewrite curry_comp_l.
  rewrite one_comp.
  apply uncurry_inj.
  rewrite uncurry_curry.
  apply one_unique.
Qed.

Hint Rewrite @one_exp : isos.

End Closed.

Notation "y ^ x" := (exponent_obj x y) : category_scope.

Hint Rewrite @curry_uncurry : categories.
Hint Rewrite @uncurry_curry : categories.
Hint Rewrite @ump_exponents : categories.
Hint Rewrite @eval_curry : categories.
Hint Rewrite @curry_eval : categories.
Hint Rewrite @exp_prod_l : isos.
Hint Rewrite @exp_prod_r : isos.
Hint Rewrite @exp_one : isos.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq.
Require Import fintype.

Lemma test15: forall (y : nat) (x : 'I_2), y < 1 -> val x = y -> Some x = insub y.
move=> y x le_1 defx; rewrite insubT ?(leq_trans le_1) // => ?.
by congr (Some _); apply: val_inj=> /=; exact: defx.
Qed.

Axiom P : nat -> Prop.
Axiom Q : forall n, P n -> Prop.
Definition R := fun (x : nat) (p : P x) m (q : P (x+1)) => m > 0.

Inductive myEx : Type := ExI : forall n (pn : P n) pn', Q n pn -> R n pn n pn' -> myEx.

Variable P1 : P 1.
Variable P11 : P (1 + 1).
Variable Q1 : forall P1, Q 1 P1.

Lemma testmE1 : myEx.
Proof.
apply: ExI 1 _ _ _ _.
  match goal with |- P 1 => exact: P1 | _ => fail end.
  match goal with |- P (1+1) => exact: P11 | _ => fail end.
  match goal with |- forall p : P 1, Q 1 p => move=>*; exact: Q1 | _ => fail end.
match goal with |- forall (p : P 1) (q : P (1+1)), is_true (R 1 p 1 q) => done | _ => fail end.
Qed.

Lemma testE2 : exists y : { x | P x }, sval y = 1.
Proof.
apply: ex_intro (exist _ 1 _) _.
  match goal with |- P 1 => exact: P1 | _ => fail end.
match goal with |- forall p : P 1, @sval _ _ (@exist _ _ 1 p) = 1 => done | _ => fail end.
Qed.

Lemma testE3 : exists y : { x | P x }, sval y = 1.
Proof.
have := (ex_intro _ (exist _ 1 _) _); apply.
  match goal with |- P 1 => exact: P1 | _ => fail end.
match goal with |- forall p : P 1, @sval _ _ (@exist _ _ 1 p) = 1 => done | _ => fail end.
Qed.

Lemma testE4 : P 2 -> exists y : { x | P x }, sval y = 2.
Proof.
move=> P2; apply: ex_intro (exist _ 2 _) _.
match goal with |- @sval _ _ (@exist _ _ 2 P2) = 2 => done | _ => fail end.
Qed.

Hint Resolve P1.

Lemma testmE12 : myEx.
Proof.
apply: ExI 1 _ _ _ _.
  match goal with |- P (1+1) => exact: P11 | _ => fail end.
  match goal with |- Q 1 P1 => exact: Q1 | _ => fail end.
match goal with |- forall (q : P (1+1)), is_true (R 1 P1 1 q) => done | _ => fail end.
Qed.

Create HintDb SSR.

Hint Resolve P11 : SSR.

Ltac ssrautoprop := trivial with SSR.

Lemma testmE13 : myEx.
Proof.
apply: ExI 1 _ _ _ _.
  match goal with |- Q 1 P1 => exact: Q1 | _ => fail end.
match goal with |- is_true (R 1 P1 1 P11) => done | _ => fail end.
Qed.

Definition R1 := fun (x : nat) (p : P x) m (q : P (x+1)) (r : Q x p) => m > 0.

Inductive myEx1 : Type :=
  ExI1 : forall n (pn : P n) pn' (q : Q n pn), R1 n pn n pn' q -> myEx1.

Hint Resolve (Q1 P1) : SSR.

(* tests that goals in prop are solved in the right order, propagating instantiations,
   thus the goal Q 1 ?p1 is faced by trivial after ?p1, and is thus evar free *)
Lemma testmE14 : myEx1.
Proof.
apply: ExI1 1 _ _ _ _.
match goal with |- is_true (R1 1 P1 1 P11 (Q1 P1)) => done | _ => fail end.
Qed.


From mathcomp Require Import ssreflect.
From Category.Base Require Import Logic Category Functor NatTran.
From Category.Instances Require Import Univ.FunctorComp.

Set Universe Polymorphism.

Program Definition Cats : Category :=
  {|
    Obj := Category;
    Hom := fun (C D : Category) => Functor C D;
    Hom_Id := fun (C : Category) => IdFunctor C;
    Hom_comp := fun (C1 C2 C3 : Category) => fun (F1 : Functor C2 C3) (F2 : Functor C1 C2) => Functor_Comp F1 F2
  |}.
Next Obligation.
Proof.
  exact: Functor_Comp_assoc.
Qed.
Next Obligation.
  exact: Functor_Comp_IdL.
Qed.
Next Obligation.
  exact: Functor_Comp_IdR.
Qed.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Import Reals.
Require Import mathcomp.ssreflect.ssreflect.
Require Import Rcomplements.

(** This file contains the definition and properties of the set
 [R] # ∪ {+ ∞} ∪ {- ∞} # denoted by [Rbar]. We have defined:
  - coercions from [R] to [Rbar] and vice versa ([Finite] gives [R0] at infinity points)
  - an order [Rbar_lt] and [Rbar_le]
  - total operations: [Rbar_opp], [Rbar_plus], [Rbar_minus], [Rbar_inv], [Rbar_min] and [Rbar_abs]
  - lemmas about the decidability of the order and properties of the operations (such as [Rbar_plus_comm] or [Rbar_plus_lt_compat])
 *)

Open Scope R_scope.

(** * Definitions *)

Inductive Rbar :=
  | Finite : R -> Rbar
  | p_infty : Rbar
  | m_infty : Rbar.
Definition real (x : Rbar) :=
  match x with
    | Finite x => x
    | _ => 0
  end.
Coercion Finite : R >-> Rbar.
Coercion real : Rbar >-> R.

Definition is_finite (x : Rbar) := Finite (real x) = x.
Lemma is_finite_correct (x : Rbar) :
  is_finite x <-> exists y : R, x = Finite y.
Proof.
  rewrite /is_finite ;
  case: x => /= ; split => // H.
  by exists r.
  by case: H.
  by case: H.
Qed.

(** ** Order *)

Definition Rbar_lt (x y : Rbar) : Prop :=
  match x,y with
    | p_infty, _ | _, m_infty => False
    | m_infty, _ | _, p_infty => True
    | Finite x, Finite y => Rlt x y
  end.

Definition Rbar_le (x y : Rbar) : Prop :=
  match x,y with
    | m_infty, _ | _, p_infty => True
    | p_infty, _ | _, m_infty => False
    | Finite x, Finite y => Rle x y
  end.

(** ** Operations *)
(** *** Additive operators *)

Definition Rbar_opp (x : Rbar) :=
  match x with
    | Finite x => Finite (-x)
    | p_infty => m_infty
    | m_infty => p_infty
  end.

Definition Rbar_plus' (x y : Rbar) :=
  match x,y with
    | p_infty, m_infty | m_infty, p_infty => None
    | p_infty, _ | _, p_infty => Some p_infty
    | m_infty, _ | _, m_infty => Some m_infty
    | Finite x', Finite y' => Some (Finite (x' + y'))
  end.
Definition Rbar_plus (x y : Rbar) :=
  match Rbar_plus' x y with Some z => z | None => Finite 0 end.
Arguments Rbar_plus !x !y /.
Definition is_Rbar_plus (x y z : Rbar) : Prop :=
  Rbar_plus' x y = Some z.
Definition ex_Rbar_plus (x y : Rbar) : Prop :=
  match Rbar_plus' x y with Some _ => True | None => False end.
Arguments ex_Rbar_plus !x !y /.

Lemma is_Rbar_plus_unique (x y z : Rbar) :
  is_Rbar_plus x y z -> Rbar_plus x y = z.
Proof.
  unfold is_Rbar_plus, ex_Rbar_plus, Rbar_plus.
  case: Rbar_plus' => // a Ha.
  by inversion Ha.
Qed.
Lemma Rbar_plus_correct (x y : Rbar) :
  ex_Rbar_plus x y -> is_Rbar_plus x y (Rbar_plus x y).
Proof.
  unfold is_Rbar_plus, ex_Rbar_plus, Rbar_plus.
  by case: Rbar_plus'.
Qed.

Definition Rbar_minus (x y : Rbar) := Rbar_plus x (Rbar_opp y).
Arguments Rbar_minus !x !y /.
Definition is_Rbar_minus (x y z : Rbar) : Prop :=
  is_Rbar_plus x (Rbar_opp y) z.
Definition ex_Rbar_minus (x y : Rbar) : Prop :=
  ex_Rbar_plus x (Rbar_opp y).
Arguments ex_Rbar_minus !x !y /.

(** *** Multiplicative operators *)

Definition Rbar_inv (x : Rbar) : Rbar :=
  match x with
    | Finite x => Finite (/x)
    | _ => Finite 0
  end.

Definition Rbar_mult' (x y : Rbar) :=
  match x with
    | Finite x => match y with
      | Finite y => Some (Finite (x * y))
      | p_infty => match (Rle_dec 0 x) with
        | left H => match Rle_lt_or_eq_dec _ _ H with left _ => Some p_infty | right _ => None end
        | right _ => Some m_infty
      end
      | m_infty => match (Rle_dec 0 x) with
        | left H => match Rle_lt_or_eq_dec _ _ H with left _ => Some m_infty | right _ => None end
        | right _ => Some p_infty
      end
    end
    | p_infty => match y with
      | Finite y => match (Rle_dec 0 y) with
        | left H => match Rle_lt_or_eq_dec _ _ H with left _ => Some p_infty | right _ => None end
        | right _ => Some m_infty
      end
      | p_infty => Some p_infty
      | m_infty => Some m_infty
    end
    | m_infty => match y with
      | Finite y => match (Rle_dec 0 y) with
        | left H => match Rle_lt_or_eq_dec _ _ H with left _ => Some m_infty | right _ => None end
        | right _ => Some p_infty
      end
      | p_infty => Some m_infty
      | m_infty => Some p_infty
    end
  end.
Definition Rbar_mult (x y : Rbar) :=
  match Rbar_mult' x y with Some z => z | None => Finite 0 end.
Arguments Rbar_mult !x !y /.

Definition is_Rbar_mult (x y z : Rbar) : Prop :=
  Rbar_mult' x y = Some z.
Definition ex_Rbar_mult (x y : Rbar) : Prop :=
  match x with
    | Finite x => match y with
      | Finite y => True
      | p_infty => x <> 0
      | m_infty => x <> 0
    end
    | p_infty => match y with
      | Finite y => y <> 0
      | p_infty => True
      | m_infty => True
    end
    | m_infty => match y with
      | Finite y => y <> 0
      | p_infty => True
      | m_infty => True
    end
  end.
Arguments ex_Rbar_mult !x !y /.

Definition Rbar_mult_pos (x : Rbar) (y : posreal) :=
  match x with
    | Finite x => Finite (x*y)
    | _ => x
  end.

Lemma is_Rbar_mult_unique (x y z : Rbar) :
  is_Rbar_mult x y z -> Rbar_mult x y = z.
Proof.
  unfold is_Rbar_mult ;
  case: x => [x | | ] ;
  case: y => [y | | ] ;
  case: z => [z | | ] //= H ;
  inversion H => // ;
  case: Rle_dec H => // H0 ;
  case: Rle_lt_or_eq_dec => //.
Qed.
Lemma Rbar_mult_correct (x y : Rbar) :
  ex_Rbar_mult x y -> is_Rbar_mult x y (Rbar_mult x y).
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //= H ;
  apply sym_not_eq in H ;
  unfold is_Rbar_mult ; simpl ;
  case: Rle_dec => // H0 ;
  case: Rle_lt_or_eq_dec => //.
Qed.
Lemma Rbar_mult_correct' (x y z : Rbar) :
  is_Rbar_mult x y z -> ex_Rbar_mult x y.
Proof.
  unfold is_Rbar_mult ;
  case: x => [x | | ] ;
  case: y => [y | | ] //= ;
  case: Rle_dec => //= H ; try (case: Rle_lt_or_eq_dec => //=) ; intros.
  by apply Rgt_not_eq.
  by apply Rlt_not_eq, Rnot_le_lt.
  by apply Rgt_not_eq.
  by apply Rlt_not_eq, Rnot_le_lt.
  by apply Rgt_not_eq.
  by apply Rlt_not_eq, Rnot_le_lt.
  by apply Rgt_not_eq.
  by apply Rlt_not_eq, Rnot_le_lt.
Qed.

Definition Rbar_div (x y : Rbar) : Rbar :=
  Rbar_mult x (Rbar_inv y).
Arguments Rbar_div !x !y /.
Definition is_Rbar_div (x y z : Rbar) : Prop :=
  is_Rbar_mult x (Rbar_inv y) z.
Definition ex_Rbar_div (x y : Rbar) : Prop :=
  ex_Rbar_mult x (Rbar_inv y).
Arguments ex_Rbar_div !x !y /.
Definition Rbar_div_pos (x : Rbar) (y : posreal) :=
  match x with
    | Finite x => Finite (x/y)
    | _ => x
  end.

(** * Compatibility with real numbers *)
(** For equality and order.
The compatibility of addition and multiplication is proved in Rbar_seq *)

Lemma Rbar_finite_eq (x y : R) :
  Finite x = Finite y <-> x = y.
Proof.
  split ; intros.
  apply Rle_antisym ; apply Rnot_lt_le ; intro.
  assert (Rbar_lt (Finite y) (Finite x)).
  simpl ; apply H0.
  rewrite H in H1 ; simpl in H1 ; by apply Rlt_irrefl in H1.
  assert (Rbar_lt (Finite x) (Finite y)).
  simpl ; apply H0.
  rewrite H in H1 ; simpl in H1 ; by apply Rlt_irrefl in H1.
  rewrite H ; reflexivity.
Qed.
Lemma Rbar_finite_neq (x y : R) :
  Finite x <> Finite y <-> x <> y.
Proof.
  split => H ; contradict H ; by apply Rbar_finite_eq.
Qed.

(** * Properties of order *)

(** ** Relations between inequalities *)

Lemma Rbar_lt_not_eq (x y : Rbar) :
  Rbar_lt x y -> x<>y.
Proof.
  destruct x ; destruct y ; simpl ; try easy.
  intros H H0.
  apply Rbar_finite_eq in H0 ; revert H0 ; apply Rlt_not_eq, H.
Qed.

Lemma Rbar_not_le_lt (x y : Rbar) :
  ~ Rbar_le x y -> Rbar_lt y x.
Proof.
  destruct x ; destruct y ; simpl ; intuition.
Qed.

Lemma Rbar_lt_not_le (x y : Rbar) :
  Rbar_lt y x -> ~ Rbar_le x y.
Proof.
  destruct x ; destruct y ; simpl ; intuition.
  apply (Rlt_irrefl r0).
  now apply Rlt_le_trans with (1 := H).
Qed.

Lemma Rbar_not_lt_le (x y : Rbar) :
  ~ Rbar_lt x y -> Rbar_le y x.
Proof.
  destruct x ; destruct y ; simpl ; intuition.
  now apply Rnot_lt_le.
Qed.

Lemma Rbar_le_not_lt (x y : Rbar) :
  Rbar_le y x -> ~ Rbar_lt x y.
Proof.
  destruct x ; destruct y ; simpl ; intuition ; contradict H0.
  now apply Rle_not_lt.
Qed.

Lemma Rbar_le_refl :
  forall x : Rbar, Rbar_le x x.
Proof.
intros [x| |] ; try easy.
apply Rle_refl.
Qed.

Lemma Rbar_lt_le :
  forall x y : Rbar,
  Rbar_lt x y -> Rbar_le x y.
Proof.
  intros [x| |] [y| |] ; try easy.
  apply Rlt_le.
Qed.

(** ** Decidability *)

Lemma Rbar_total_order (x y : Rbar) :
  {Rbar_lt x y} + {x = y} + {Rbar_lt y x}.
Proof.
  destruct x ; destruct y ; simpl ; intuition.
  destruct (total_order_T r r0) ; intuition.
Qed.

Lemma Rbar_eq_dec (x y : Rbar) :
  {x = y} + {x <> y}.
Proof.
  intros ; destruct (Rbar_total_order x y) as [[H|H]|H].
  right ; revert H ; destruct x as [x| |] ; destruct y as [y| |] ; simpl ; intros H ;
  try easy.
  contradict H.
  apply Rbar_finite_eq in H ; try apply Rle_not_lt, Req_le ; auto.
  left ; apply H.
  right ; revert H ; destruct x as [x| |] ; destruct y as [y| |] ; simpl ; intros H ;
  try easy.
  contradict H.
  apply Rbar_finite_eq in H ; apply Rle_not_lt, Req_le ; auto.
Qed.

Lemma Rbar_lt_dec (x y : Rbar) :
  {Rbar_lt x y} + {~Rbar_lt x y}.
Proof.
  destruct (Rbar_total_order x y) as [H|H] ; [ destruct H as [H|H]|].
  now left.
  right ; rewrite H ; clear H ; destruct y ; auto ; apply Rlt_irrefl ; auto.
  right ; revert H ; destruct x as [x | | ] ; destruct y as [y | | ] ; intros H ; auto ;
  apply Rle_not_lt, Rlt_le ; auto.
Qed.

Lemma Rbar_lt_le_dec (x y : Rbar) :
  {Rbar_lt x y} + {Rbar_le y x}.
Proof.
  destruct (Rbar_total_order x y) as [[H|H]|H].
  now left.
  right.
  rewrite H.
  apply Rbar_le_refl.
  right.
  now apply Rbar_lt_le.
Qed.

Lemma Rbar_le_dec (x y : Rbar) :
  {Rbar_le x y} + {~Rbar_le x y}.
Proof.
  destruct (Rbar_total_order x y) as [[H|H]|H].
  left.
  now apply Rbar_lt_le.
  left.
  rewrite H.
  apply Rbar_le_refl.
  right.
  now apply Rbar_lt_not_le.
Qed.

Lemma Rbar_le_lt_dec (x y : Rbar) :
  {Rbar_le x y} + {Rbar_lt y x}.
Proof.
  destruct (Rbar_total_order x y) as [[H|H]|H].
  left.
  now apply Rbar_lt_le.
  left.
  rewrite H.
  apply Rbar_le_refl.
  now right.
Qed.

Lemma Rbar_le_lt_or_eq_dec (x y : Rbar) :
  Rbar_le x y -> { Rbar_lt x y } + { x = y }.
Proof.
  destruct (Rbar_total_order x y) as [[H|H]|H].
  now left.
  now right.
  intros K.
  now elim (Rbar_le_not_lt _ _ K).
Qed.

(** ** Transitivity *)

Lemma Rbar_lt_trans (x y z : Rbar) :
  Rbar_lt x y -> Rbar_lt y z -> Rbar_lt x z.
Proof.
  destruct x ; destruct y ; destruct z ; simpl ; intuition.
  now apply Rlt_trans with r0.
Qed.

Lemma Rbar_lt_le_trans (x y z : Rbar) :
  Rbar_lt x y -> Rbar_le y z -> Rbar_lt x z.
Proof.
  destruct x ; destruct y ; destruct z ; simpl ; intuition.
  now apply Rlt_le_trans with r0.
Qed.

Lemma Rbar_le_lt_trans (x y z : Rbar) :
  Rbar_le x y -> Rbar_lt y z -> Rbar_lt x z.
Proof.
  destruct x ; destruct y ; destruct z ; simpl ; intuition.
  now apply Rle_lt_trans with r0.
Qed.

Lemma Rbar_le_trans (x y z : Rbar) :
  Rbar_le x y -> Rbar_le y z -> Rbar_le x z.
Proof.
  destruct x ; destruct y ; destruct z ; simpl ; intuition.
  now apply Rle_trans with r0.
Qed.

Lemma Rbar_le_antisym (x y : Rbar) :
  Rbar_le x y -> Rbar_le y x -> x = y.
Proof.
  destruct x ; destruct y ; simpl ; intuition.
Qed.

(** * Properties of operations *)
(** ** Additive operators *)
(** *** Rbar_opp *)

Lemma Rbar_opp_involutive (x : Rbar) : (Rbar_opp (Rbar_opp x)) = x.
Proof.
  destruct x as [x| | ] ; auto ; simpl ; rewrite Ropp_involutive ; auto.
Qed.

Lemma Rbar_opp_lt (x y : Rbar) : Rbar_lt (Rbar_opp x) (Rbar_opp y) <-> Rbar_lt y x.
Proof.
  destruct x as [x | | ] ; destruct y as [y | | ] ;
  split ; auto ; intro H ; simpl ; try left.
  apply Ropp_lt_cancel ; auto.
  apply Ropp_lt_contravar ; auto.
Qed.

Lemma Rbar_opp_le (x y : Rbar) : Rbar_le (Rbar_opp x) (Rbar_opp y) <-> Rbar_le y x.
Proof.
  destruct x as [x| |] ; destruct y as [y| |] ; simpl ; intuition.
Qed.

Lemma Rbar_opp_eq (x y : Rbar) : (Rbar_opp x) = (Rbar_opp y) <-> x = y.
Proof.
  split ; intros H.
  rewrite <- (Rbar_opp_involutive x), H, Rbar_opp_involutive ; reflexivity.
  rewrite H ; reflexivity.
Qed.

Lemma Rbar_opp_real (x : Rbar) : real (Rbar_opp x) = - real x.
Proof.
  destruct x as [x | | ] ; simpl ; intuition.
Qed.

(** *** Rbar_plus *)

Lemma Rbar_plus'_comm :
  forall x y, Rbar_plus' x y = Rbar_plus' y x.
Proof.
intros [x| |] [y| |] ; try reflexivity.
apply (f_equal (fun x => Some (Finite x))), Rplus_comm.
Qed.

Lemma ex_Rbar_plus_comm :
  forall x y,
  ex_Rbar_plus x y -> ex_Rbar_plus y x.
Proof.
now intros [x| |] [y| |].
Qed.

Lemma ex_Rbar_plus_opp (x y : Rbar) :
  ex_Rbar_plus x y -> ex_Rbar_plus (Rbar_opp x) (Rbar_opp y).
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] => //.
Qed.

Lemma Rbar_plus_0_r (x : Rbar) : Rbar_plus x (Finite 0) = x.
Proof.
  case: x => //= ; intuition.
Qed.
Lemma Rbar_plus_0_l (x : Rbar) : Rbar_plus (Finite 0) x = x.
Proof.
  case: x => //= ; intuition.
Qed.

Lemma Rbar_plus_comm (x y : Rbar) : Rbar_plus x y = Rbar_plus y x.
Proof.
  case x ; case y ; intuition.
  simpl.
  apply f_equal, Rplus_comm.
Qed.

Lemma Rbar_plus_lt_compat (a b c d : Rbar) :
  Rbar_lt a b -> Rbar_lt c d -> Rbar_lt (Rbar_plus a c) (Rbar_plus b d).
Proof.
  case: a => [a | | ] // ; case: b => [b | | ] // ;
  case: c => [c | | ] // ; case: d => [d | | ] // ;
  apply Rplus_lt_compat.
Qed.

Lemma Rbar_plus_le_compat (a b c d : Rbar) :
  Rbar_le a b -> Rbar_le c d -> Rbar_le (Rbar_plus a c) (Rbar_plus b d).
Proof.
  case: a => [a | | ] // ; case: b => [b | | ] // ;
  case: c => [c | | ] // ; case: d => [d | | ] //.
  apply Rplus_le_compat.
  intros _ _.
  apply Rle_refl.
  intros _ _.
  apply Rle_refl.
Qed.

Lemma Rbar_plus_opp (x y : Rbar) :
  Rbar_plus (Rbar_opp x) (Rbar_opp y) = Rbar_opp (Rbar_plus x y).
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //= ; apply f_equal ; ring.
Qed.

(** *** Rbar_minus *)

Lemma Rbar_minus_eq_0 (x : Rbar) : Rbar_minus x x = 0.
Proof.
  case: x => //= x ; by apply f_equal, Rcomplements.Rminus_eq_0.
Qed.
Lemma Rbar_opp_minus (x y : Rbar) :
  Rbar_opp (Rbar_minus x y) = Rbar_minus y x.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //=.
  by rewrite Ropp_minus_distr'.
  by rewrite Ropp_0.
  by rewrite Ropp_0.
Qed.

(** ** Multiplicative *)

(** *** Rbar_inv *)

Lemma Rbar_inv_opp (x : Rbar) :
  x <> 0 -> Rbar_inv (Rbar_opp x) = Rbar_opp (Rbar_inv x).
Proof.
  case: x => [x | | ] /= Hx.
  rewrite Ropp_inv_permute => //.
  contradict Hx.
  by rewrite Hx.
  by rewrite Ropp_0.
  by rewrite Ropp_0.
Qed.

(** *** Rbar_mult *)

Lemma Rbar_mult'_comm (x y : Rbar) :
  Rbar_mult' x y = Rbar_mult' y x.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //=.
  by rewrite Rmult_comm.
Qed.

Lemma Rbar_mult'_opp_r (x y : Rbar) :
  Rbar_mult' x (Rbar_opp y) = match Rbar_mult' x y with Some z => Some (Rbar_opp z) | None => None end.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //= ;
  (try case: Rle_dec => Hx //=) ;
  (try case: Rle_lt_or_eq_dec => //= Hx0).
  by rewrite Ropp_mult_distr_r_reverse.
  rewrite -Ropp_0 in Hx0.
  apply Ropp_lt_cancel in Hx0.
  case Rle_dec => Hy //=.
  now elim Rle_not_lt with (1 := Hy).
  case Rle_dec => Hy //=.
  case Rle_lt_or_eq_dec => Hy0 //=.
  elim Rlt_not_le with (1 := Hy0).
  apply Ropp_le_cancel.
  by rewrite Ropp_0.
  elim Hy.
  apply Ropp_le_cancel.
  rewrite -Hx0 Ropp_0.
  apply Rle_refl.
  case Rle_dec => Hy //=.
  case Rle_lt_or_eq_dec => Hy0 //=.
  elim Hx.
  rewrite -Hy0 Ropp_0.
  apply Rle_refl.
  elim Hx.
  rewrite -Ropp_0.
  apply Ropp_le_contravar.
  apply Rlt_le.
  now apply Rnot_le_lt.
  case Rle_dec => Hy //=.
  elim Rlt_not_le with (1 := Hx0).
  rewrite -Ropp_0.
  now apply Ropp_le_contravar.
  case Rle_dec => Hy //=.
  case Rle_lt_or_eq_dec => Hy0 //=.
  elim Rlt_not_le with (1 := Hy0).
  apply Ropp_le_cancel.
  rewrite -Hx0 Ropp_0.
  apply Rle_refl.
  elim Hy.
  apply Ropp_le_cancel.
  rewrite -Hx0 Ropp_0.
  apply Rle_refl.
  case Rle_dec => Hy //=.
  case Rle_lt_or_eq_dec => Hy0 //=.
  elim Hx.
  rewrite -Hy0 Ropp_0.
  apply Rle_refl.
  elim Hx.
  rewrite -Ropp_0.
  apply Ropp_le_contravar.
  apply Rlt_le.
  now apply Rnot_le_lt.
Qed.

Lemma Rbar_mult_comm (x y : Rbar) :
  Rbar_mult x y = Rbar_mult y x.
Proof.
  unfold Rbar_mult.
  by rewrite Rbar_mult'_comm.
Qed.
Lemma Rbar_mult_opp_r (x y : Rbar) :
  Rbar_mult x (Rbar_opp y) = (Rbar_opp (Rbar_mult x y)).
Proof.
  unfold Rbar_mult.
  rewrite Rbar_mult'_opp_r.
  case Rbar_mult' => //=.
  apply f_equal, eq_sym, Ropp_0.
Qed.
Lemma Rbar_mult_opp_l (x y : Rbar) :
  Rbar_mult (Rbar_opp x) y = Rbar_opp (Rbar_mult x y).
Proof.
  rewrite ?(Rbar_mult_comm _ y).
  by apply Rbar_mult_opp_r.
Qed.
Lemma Rbar_mult_opp (x y : Rbar) :
  Rbar_mult (Rbar_opp x) (Rbar_opp y) = Rbar_mult x y.
Proof.
  by rewrite Rbar_mult_opp_l -Rbar_mult_opp_r Rbar_opp_involutive.
Qed.
Lemma Rbar_mult_0_l (x : Rbar) : Rbar_mult 0 x = 0.
Proof.
  case: x => [x | | ] //=.
  by rewrite Rmult_0_l.
  case: Rle_dec (Rle_refl 0) => // H _.
  case: Rle_lt_or_eq_dec (Rlt_irrefl 0) => // _ _.
  case: Rle_dec (Rle_refl 0) => // H _.
  case: Rle_lt_or_eq_dec (Rlt_irrefl 0) => // _ _.
Qed.
Lemma Rbar_mult_0_r (x : Rbar) : Rbar_mult x 0 = 0.
Proof.
  rewrite Rbar_mult_comm ; by apply Rbar_mult_0_l.
Qed.

Lemma Rbar_mult_eq_0 (y x : Rbar) :
  Rbar_mult x y = 0 -> x = 0 \/ y = 0.
Proof.
  case: x => [x | | ] //= ;
  case: y => [y | | ] //= ;
  (try case: Rle_dec => //= H) ;
  (try case: Rle_lt_or_eq_dec => //=) ;
  (try (left ; by apply f_equal)) ;
  (try (right ; by apply f_equal)).
  intros H.
  apply (f_equal real) in H.
  simpl in H.
  apply Rmult_integral in H ; case: H => ->.
  by left.
  by right.
Qed.

Lemma ex_Rbar_mult_sym (x y : Rbar) :
  ex_Rbar_mult x y -> ex_Rbar_mult y x.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //.
Qed.
Lemma ex_Rbar_mult_opp_l (x y : Rbar) :
  ex_Rbar_mult x y -> ex_Rbar_mult (Rbar_opp x) y.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //= Hx ;
  by apply Ropp_neq_0_compat.
Qed.
Lemma ex_Rbar_mult_opp_r (x y : Rbar) :
  ex_Rbar_mult x y -> ex_Rbar_mult x (Rbar_opp y).
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] //= Hx ;
  by apply Ropp_neq_0_compat.
Qed.

Lemma is_Rbar_mult_sym (x y z : Rbar) :
  is_Rbar_mult x y z -> is_Rbar_mult y x z.
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] ;
  case: z => [z | | ] //= ;
  unfold is_Rbar_mult, Rbar_mult' ;
  try (case: Rle_dec => // H) ;
  try (case: Rle_lt_or_eq_dec => // H0) ;
  try (case => <-) ; try (move => _).
  by rewrite Rmult_comm.
Qed.
Lemma is_Rbar_mult_opp_l (x y z : Rbar) :
  is_Rbar_mult x y z -> is_Rbar_mult (Rbar_opp x) y (Rbar_opp z).
Proof.
  case: x => [x | | ] ;
  case: y => [y | | ] ;
  case: z => [z | | ] //= ;
  unfold is_Rbar_mult, Rbar_mult' ;
  try (case: Rle_dec => // H) ;
  try (case: Rle_lt_or_eq_dec => // H0) ;
  try (case => <-) ; try (move => _).
  apply (f_equal (@Some _)), f_equal ; ring.
  apply Ropp_lt_contravar in H0 ; rewrite Ropp_0 in H0 ;
  now move/Rlt_not_le: H0 ; case: Rle_dec.
  apply Rnot_le_lt, Ropp_lt_contravar in H ; rewrite Ropp_0 in H ;
  move/Rlt_le: (H) ; case: Rle_dec => // H0 _ ;
  now move/Rlt_not_eq: H ; case: Rle_lt_or_eq_dec.
  apply Rnot_le_lt, Ropp_lt_contravar in H ; rewrite Ropp_0 in H ;
  move/Rlt_le: (H) ; case: Rle_dec => // H0 _ ;
  now move/Rlt_not_eq: H ; case: Rle_lt_or_eq_dec.
  apply Ropp_lt_contravar in H0 ; rewrite Ropp_0 in H0 ;
  now move/Rlt_not_le: H0 ; case: Rle_dec.
Qed.
Lemma is_Rbar_mult_opp_r (x y z : Rbar) :
  is_Rbar_mult x y z -> is_Rbar_mult x (Rbar_opp y) (Rbar_opp z).
Proof.
  move/is_Rbar_mult_sym => H.
  now apply is_Rbar_mult_sym, is_Rbar_mult_opp_l.
Qed.

Lemma is_Rbar_mult_p_infty_pos (x : Rbar) :
  Rbar_lt 0 x -> is_Rbar_mult p_infty x p_infty.
Proof.
  case: x => [x | | ] // Hx.
  unfold is_Rbar_mult, Rbar_mult'.
  case: Rle_dec (Rlt_le _ _ Hx) => // Hx' _.
  now case: Rle_lt_or_eq_dec (Rlt_not_eq _ _ Hx).
Qed.
Lemma is_Rbar_mult_p_infty_neg (x : Rbar) :
  Rbar_lt x 0 -> is_Rbar_mult p_infty x m_infty.
Proof.
  case: x => [x | | ] // Hx.
  unfold is_Rbar_mult, Rbar_mult'.
  case: Rle_dec (Rlt_not_le _ _ Hx) => // Hx' _.
Qed.
Lemma is_Rbar_mult_m_infty_pos (x : Rbar) :
  Rbar_lt 0 x -> is_Rbar_mult m_infty x m_infty.
Proof.
  case: x => [x | | ] // Hx.
  unfold is_Rbar_mult, Rbar_mult'.
  case: Rle_dec (Rlt_le _ _ Hx) => // Hx' _.
  now case: Rle_lt_or_eq_dec (Rlt_not_eq _ _ Hx).
Qed.
Lemma is_Rbar_mult_m_infty_neg (x : Rbar) :
  Rbar_lt x 0 -> is_Rbar_mult m_infty x p_infty.
Proof.
  case: x => [x | | ] // Hx.
  unfold is_Rbar_mult, Rbar_mult'.
  case: Rle_dec (Rlt_not_le _ _ Hx) => // Hx' _.
Qed.

(** Rbar_div *)

Lemma is_Rbar_div_p_infty (x : R) :
  is_Rbar_div x p_infty 0.
Proof.
  apply (f_equal (@Some _)).
  by rewrite Rmult_0_r.
Qed.
Lemma is_Rbar_div_m_infty (x : R) :
  is_Rbar_div x m_infty 0.
Proof.
  apply (f_equal (@Some _)).
  by rewrite Rmult_0_r.
Qed.

(** Rbar_mult_pos *)

Lemma Rbar_mult_pos_eq (x y : Rbar) (z : posreal) :
  x = y <-> (Rbar_mult_pos x z) = (Rbar_mult_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H ; apply Rbar_finite_eq in H.
  by rewrite H.
  apply Rbar_finite_eq, (Rmult_eq_reg_r (z)) => // ;
  by apply Rgt_not_eq.
Qed.

Lemma Rbar_mult_pos_lt (x y : Rbar) (z : posreal) :
  Rbar_lt x y <-> Rbar_lt (Rbar_mult_pos x z) (Rbar_mult_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H.
  apply (Rmult_lt_compat_r (z)) => //.
  apply (Rmult_lt_reg_r (z)) => //.
Qed.

Lemma Rbar_mult_pos_le (x y : Rbar) (z : posreal) :
  Rbar_le x y <-> Rbar_le (Rbar_mult_pos x z) (Rbar_mult_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H.
  apply Rmult_le_compat_r with (2 := H).
  now apply Rlt_le.
  now apply Rmult_le_reg_r with (2 := H).
Qed.

(** Rbar_div_pos *)

Lemma Rbar_div_pos_eq (x y : Rbar) (z : posreal) :
  x = y <-> (Rbar_div_pos x z) = (Rbar_div_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H ; apply Rbar_finite_eq in H.
  by rewrite H.
  apply Rbar_finite_eq, (Rmult_eq_reg_r (/z)) => // ;
  by apply Rgt_not_eq, Rinv_0_lt_compat.
Qed.

Lemma Rbar_div_pos_lt (x y : Rbar) (z : posreal) :
  Rbar_lt x y <-> Rbar_lt (Rbar_div_pos x z) (Rbar_div_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H.
  apply (Rmult_lt_compat_r (/z)) => // ; by apply Rinv_0_lt_compat.
  apply (Rmult_lt_reg_r (/z)) => // ; by apply Rinv_0_lt_compat.
Qed.

Lemma Rbar_div_pos_le (x y : Rbar) (z : posreal) :
  Rbar_le x y <-> Rbar_le (Rbar_div_pos x z) (Rbar_div_pos y z).
Proof.
  case: z => z Hz ; case: x => [x | | ] ; case: y => [y | | ] ;
  split => //= H.
  apply Rmult_le_compat_r with (2 := H).
  now apply Rlt_le, Rinv_0_lt_compat.
  apply Rmult_le_reg_r with (2 := H).
  now apply Rinv_0_lt_compat.
Qed.

(** * Rbar_min *)

Definition Rbar_min (x y : Rbar) : Rbar :=
  match x, y with
  | z, p_infty | p_infty, z => z
  | _ , m_infty | m_infty, _ => m_infty
  | Finite x, Finite y => Rmin x y
  end.

Lemma Rbar_lt_locally (a b : Rbar) (x : R) :
  Rbar_lt a x -> Rbar_lt x b ->
  exists delta : posreal,
    forall y, Rabs (y - x) < delta -> Rbar_lt a y /\ Rbar_lt y b.
Proof.
  case: a => [ a /= Ha | | _ ] //= ; (try apply Rminus_lt_0 in Ha) ;
  case: b => [ b Hb | _ | ] //= ; (try apply Rminus_lt_0 in Hb).
  assert (0 < Rmin (x - a) (b - x)).
    by apply Rmin_case.
  exists (mkposreal _ H) => y /= Hy ; split.
  apply Rplus_lt_reg_r with (-x).
  replace (a+-x) with (-(x-a)) by ring.
  apply (Rabs_lt_between (y - x)).
  apply Rlt_le_trans with (1 := Hy).
  by apply Rmin_l.
  apply Rplus_lt_reg_r with (-x).
  apply (Rabs_lt_between (y - x)).
  apply Rlt_le_trans with (1 := Hy).
  by apply Rmin_r.
  exists (mkposreal _ Ha) => y /= Hy ; split => //.
  apply Rplus_lt_reg_r with (-x).
  replace (a+-x) with (-(x-a)) by ring.
  by apply (Rabs_lt_between (y - x)).
  exists (mkposreal _ Hb) => y /= Hy ; split => //.
  apply Rplus_lt_reg_r with (-x).
  by apply (Rabs_lt_between (y - x)).
  exists (mkposreal _ Rlt_0_1) ; by split.
Qed.

Lemma Rbar_min_comm (x y : Rbar) : Rbar_min x y = Rbar_min y x.
Proof.
  case: x => [x | | ] //= ;
  case: y => [y | | ] //=.
  by rewrite Rmin_comm.
Qed.

Lemma Rbar_min_r (x y : Rbar) : Rbar_le (Rbar_min x y) y.
Proof.
  case: x => [x | | ] //= ;
  case: y => [y | | ] //=.
  by apply Rmin_r.
  by apply Rle_refl.
Qed.

Lemma Rbar_min_l (x y : Rbar) : Rbar_le (Rbar_min x y) x.
Proof.
  rewrite Rbar_min_comm.
  by apply Rbar_min_r.
Qed.

Lemma Rbar_min_case (x y : Rbar) (P : Rbar -> Type) :
  P x -> P y -> P (Rbar_min x y).
Proof.
  case: x => [x | | ] //= ;
  case: y => [y | | ] //=.
  by apply Rmin_case.
Qed.
Lemma Rbar_min_case_strong (r1 r2 : Rbar) (P : Rbar -> Type) :
  (Rbar_le r1 r2 -> P r1) -> (Rbar_le r2 r1 -> P r2)
    -> P (Rbar_min r1 r2).
Proof.
  case: r1 => [x | | ] //= ;
  case: r2 => [y | | ] //= Hx Hy ;
  (try by apply Hx) ; (try by apply Hy).
  by apply Rmin_case_strong.
Qed.

(** * Rbar_abs *)

Definition Rbar_abs (x : Rbar) :=
  match x with
    | Finite x => Finite (Rabs x)
    | _ => p_infty
  end.

Lemma Rbar_abs_lt_between (x y : Rbar) :
  Rbar_lt (Rbar_abs x) y <-> (Rbar_lt (Rbar_opp y) x /\ Rbar_lt x y).
Proof.
  case: x => [x | | ] ; case: y => [y | | ] /= ; try by intuition.
  by apply Rabs_lt_between.
Qed.

Lemma Rbar_abs_opp (x : Rbar) :
  Rbar_abs (Rbar_opp x) = Rbar_abs x.
Proof.
  case: x => [x | | ] //=.
  by rewrite Rabs_Ropp.
Qed.

Lemma Rbar_abs_pos (x : Rbar) :
  Rbar_le 0 x -> Rbar_abs x = x.
Proof.
  case: x => [x | | ] //= Hx.
  by apply f_equal, Rabs_pos_eq.
Qed.
Lemma Rbar_abs_neg (x : Rbar) :
  Rbar_le x 0 -> Rbar_abs x = Rbar_opp x.
Proof.
  case: x => [x | | ] //= Hx.
  rewrite -Rabs_Ropp.
  apply f_equal, Rabs_pos_eq.
  now rewrite -Ropp_0 ; apply Ropp_le_contravar.
Qed.


(** * Finite dimensional subspaces of Hilbert spaces are closed:
  proof with decidability hypotheses *)

Require Export Coquelicot.Coquelicot.
Require Export Reals.
Require Export mathcomp.ssreflect.ssreflect.
Require Export FunctionalExtensionality.
Require Export hilbert.
Require Import Decidable.
Require Export lax_milgram.

(** * Definitions *)
Section FDIM_dec_f_zero.

Context {E : Hilbert}.

Variable phi : E -> Prop.
Variable dim:nat.
Variable B: nat -> E.

Definition phi_FDIM_def (p : E -> Prop) := match (eq_nat_dec dim 0) with
              | left _ => forall u, p u <-> u = zero
              | right _ => forall u, p u <-> exists L : nat -> R,
           u = sum_n (fun n => scal (L n) (B n)) (dim-1)%nat
         end.

Hypothesis phi_FDIM: phi_FDIM_def phi.

(** * Decidability preliminaries *)

Hypothesis Hdec : forall x:E, decidable (phi x).

Lemma Dec_nndec : forall f, decidable (f_phi_neq_zero phi f)
                  <-> decidable (f_phi_neq_zero (fun x:E => ~~phi x) f).
Proof.
intros f.
split.
intro H.
destruct H.
left.
unfold f_phi_neq_zero in *.
destruct H as (v,H).
exists v.
intuition.
right.
unfold f_phi_neq_zero in *.
intro Hf.
destruct Hf as (v,Hf).
apply H.
exists v; intuition.
intro H.
destruct H.
left.
unfold f_phi_neq_zero in *.
destruct H as (v,H).
exists v; intuition.
right.
intro Hf.
unfold f_phi_neq_zero in *.
apply H.
destruct Hf as (v,Hf).
exists v; intuition.
Qed.

Lemma clm_sum_n: forall (f : topo_dual E) m C L,
    f (sum_n (fun n => scal (L n) (C n)) m)
      = sum_n (fun n => scal (L n) (f (C n))) m.
Proof.
intros f m C L; induction m.
rewrite 2!sum_O.
apply (Lf _ _ f).
rewrite 2!sum_Sn.
rewrite (proj1 (Lf _ _ f)).
f_equal.
exact IHm.
apply (Lf _ _ f).
Qed.

Lemma phi_B_aux: forall i m, ( i <= m)%nat ->
 B i = sum_n (fun n : nat => scal
     (match (eq_nat_dec i n) with
       | left _ => 1
       | _ => 0
     end) (B n)) m.
Proof.
induction m.
intros Hi.
replace i with 0%nat by auto with zarith.
rewrite sum_O.
simpl.
now rewrite scal_one.
intros Hi; case (le_lt_or_eq _ _ Hi); intros Hi2.
rewrite IHm.
2: auto with zarith.
rewrite sum_Sn.
replace (scal (match (eq_nat_dec i (S m)) with
  | left _ => 1 | _ => 0 end) (B (S m))) with (@zero E).
apply sym_eq, plus_zero_r.
case (eq_nat_dec i (S m)); intros T.
contradict Hi2; auto with zarith.
now rewrite scal_zero_l.
rewrite <- (plus_zero_l (B i)).
rewrite sum_Sn.
rewrite Hi2; f_equal.
apply sym_eq.
apply: sum_n_eq_zero.
intros k Hk.
case eq_nat_dec; try easy.
intros Hk2; contradict Hk; auto with zarith.
intros _; apply: scal_zero_l.
case eq_nat_dec.
intros _; now rewrite scal_one.
intros H; now contradict H.
Qed.

Lemma phi_B: (0 < dim)%nat -> forall i:nat, (i <= dim-1)%nat ->
   phi (B i).
Proof.
intros Hdim i Hi.
unfold phi_FDIM_def in phi_FDIM.
destruct (eq_nat_dec dim 0).
exfalso.
auto with zarith.
apply phi_FDIM.
eexists.
now apply phi_B_aux.
Qed.

Lemma EVN_dec_f_phi_zero_aux:
   forall f : topo_dual E,
    (exists i:nat, (i <= dim-1)%nat /\ f (B i) <> 0)
       \/ (forall i, (i <= dim-1)%nat -> f (B i) = 0).
Proof.
intros f.
clear phi_FDIM; induction dim.
case (Req_dec (f (B 0)) 0); intros T.
right; intros i Hi.
now replace i with 0%nat by auto with zarith.
left; exists 0%nat.
split; try auto with zarith; assumption.
case IHn.
intros (i,(Hi1,Hi2)).
left; exists i.
split; try assumption.
auto with zarith.
intros T1.
case (Req_dec (f (B (S n -1))) 0); intros T2.
right; intros i Hi.
case (le_lt_or_eq i (S n - 1)).
auto with zarith.
intros Hi2.
apply T1. auto with zarith.
intros Hi2; rewrite Hi2; assumption.
left.
exists (S n - 1)%nat; split; try assumption.
auto with zarith.
Qed.

Lemma EVN_dec_f_phi_zero:
 forall f : topo_dual E,
    decidable (f_phi_neq_zero phi f).
Proof.
intros f; unfold f_phi_neq_zero.
generalize phi_FDIM; intros phi_FDIM'.
unfold phi_FDIM_def in phi_FDIM'.
destruct (eq_nat_dec dim 0).
right.
intro Hf.
destruct Hf as (u,(Hf1,Hf2)).
apply logic_dec_notnot in Hf1.
apply (phi_FDIM' u) in Hf1.
rewrite Hf1 in Hf2.
absurd (f zero = 0).
trivial.
apply: is_linear_mapping_zero.
apply f.
trivial.
case (EVN_dec_f_phi_zero_aux f).
intros (i,(Hi1,Hi2)).
left.
exists (B i).
rewrite <- (logic_dec_notnot E phi).
split; try assumption.
apply phi_B.
auto with zarith.
trivial.
trivial.
intros Hi.
right.
intros (u,(Hu1,Hu2)).
apply Hu2.
rewrite <- (logic_dec_notnot E phi) in Hu1.
apply phi_FDIM' in Hu1.
destruct Hu1 as (l,HL).
rewrite HL.
rewrite clm_sum_n.
apply: sum_n_eq_zero.
intros k Hk.
rewrite Hi; try easy.
apply: scal_zero_r.
trivial.
Qed.

Lemma inner_sum_n: forall m f (x : E),
    inner (sum_n (fun n => f n) m) x
      = sum_n (fun n => inner (f n) x) m.
Proof.
intros m f x.
induction m.
now rewrite 2!sum_O.
rewrite 2!sum_Sn.
rewrite inner_plus_l.
rewrite IHm.
reflexivity.
Qed.

End FDIM_dec_f_zero.

Section FDIM_span.

Context{E : Hilbert}.

Definition phi_FDIM (p : E -> Prop) (dim : nat) (B : nat -> E)
          := match (eq_nat_dec dim 0) with
              | left _ => forall u, p u <-> u = zero
              | right _ => forall u, p u <-> exists L : nat -> R,
           u = sum_n (fun n => scal (L n) (B n)) (dim - 1)
         end.

(** * Linear span *)

Definition span (u : E) := fun x:E => (exists (l : R), x = scal l u).

(** decidability of span *)
Lemma span_dec : forall u:E, forall x:E, decidable ((span u) x).
Proof.
intros u x.
destruct (is_zero_dec u).
destruct (is_zero_dec x).
left.
exists 0%R.
rewrite scal_zero_l.
trivial.
right.
intro HF.
destruct HF as (l,Hl).
rewrite H in Hl.
rewrite scal_zero_r in Hl.
intuition.
case (is_zero_dec (minus (scal (inner u u) x) (scal (inner x u) u))) => HT.
left.
unfold minus in HT.
assert (HT' : (scal (inner u u) x) = (scal (inner x u) u)).
apply plus_reg_r with (opp ((scal (inner x u) u))).
rewrite plus_opp_r.
trivial.
assert (HT'' : x = scal ((inner x u) / (inner u u)) u).
unfold Rdiv.
rewrite Rmult_comm.
replace (/ inner u u * inner x u) with (mult (/ inner u u) (inner x u)).
rewrite <- scal_assoc.
rewrite <- HT'.
rewrite scal_assoc.
unfold mult.
simpl.
rewrite Rinv_l.
rewrite scal_one.
reflexivity.
rewrite <- squared_norm.
replace 0 with (Hnorm u * 0) by ring.
intro F.
ring_simplify in F.
generalize (norm_gt_0 u H) => HO.
unfold norm in HO.
simpl in HO.
replace (Hnorm u ^ 2) with (Rsqr (Hnorm u)) in F.
apply Rsqr_0_uniq in F.
rewrite F in HO.
apply (Rlt_irrefl 0 HO).
unfold Rsqr.
unfold pow.
ring.
unfold mult.
simpl.
reflexivity.
now exists (inner x u / inner u u).
right.
intro H0.
destruct H0 as (l,H0).
rewrite H0 in HT.
apply HT.
unfold minus.
apply plus_reg_r with (scal (inner (scal l u) u) u).
rewrite <- Hierarchy.plus_assoc.
rewrite plus_opp_l.
rewrite plus_zero_r.
rewrite plus_zero_l.
rewrite inner_scal_l.
rewrite scal_assoc.
rewrite Rmult_comm.
unfold mult.
simpl.
reflexivity.
Qed.

(** clean_scal transformer *)
Definition clean_scal (u : E) (F : (E -> Prop) -> Prop):
                       (R -> Prop) -> Prop
     := fun A : (R -> Prop) => exists V : E -> Prop,
           F V /\ (forall l,  V (scal l u) -> A l).

Lemma proper_proj' (u : E) (F : (E -> Prop) -> Prop) :
  ProperFilter F -> (forall V : E -> Prop, F V -> ~~ exists x : E,
                            V x /\ span u x)
                    ->  ProperFilter' (clean_scal u F).
Proof.
intros (FF1,FF2).
intros Hsp.
constructor.
intro Hkk.
unfold clean_scal in Hkk.
destruct Hkk as (V,(H1,H2)).
specialize (Hsp V).
apply Hsp.
trivial.
intro Hj.
destruct Hj as (j,(Hj,(l,Hj'))).
apply (H2 l).
now rewrite <- Hj'.
constructor.
unfold clean_scal.
exists (fun _ : E => True).
split.
apply FF2.
now intros.
intros P Q HP HQ.
unfold clean_scal in *.
destruct FF2.
destruct HP as (V,(P1,P2)).
destruct HQ as (V',(Q1,Q2)).
exists (fun x : E => V x /\ V' x).
split.
now apply filter_and.
intros l (HL1,HL2).
split.
now apply P2.
now apply Q2.
intros P Q HImp (V,(HP1,HP2)).
unfold clean_scal in *.
exists V.
split; try assumption.
intros l Hvl.
apply HImp.
now apply HP2.
Qed.

Lemma proper_proj (u : E) (F : (E -> Prop) -> Prop) :
  ProperFilter F -> (forall V : E -> Prop, F V ->  exists x : E,
                            V x /\ span u x)
                    ->  ProperFilter (clean_scal u F).
Proof.
intros (FF1,FF2).
intros Hsp.
constructor.
unfold clean_scal.
intros P (V,(HV1,HV2)).
destruct (FF1 V HV1) as (f,Hf).
specialize (Hsp V HV1).
destruct Hsp as (x,(Hx1,(l,Hx2))).
exists l.
apply HV2.
now rewrite <- Hx2.
constructor.
unfold clean_scal.
exists (fun _ : E => True).
split.
apply FF2.
now intros.
intros P Q HP HQ.
unfold clean_scal in *.
destruct FF2.
destruct HP as (V,(P1,P2)).
destruct HQ as (V',(Q1,Q2)).
exists (fun x : E => V x /\ V' x).
split.
now apply filter_and.
intros l (HL1,HL2).
split.
now apply P2.
now apply Q2.
intros P Q HImp (V,(HP1,HP2)).
unfold clean_scal in *.
exists V.
split; try assumption.
intros l Hvl.
apply HImp.
now apply HP2.
Qed.

Lemma cauchy_scal (u : E) (F : (E -> Prop) -> Prop) :
  u <> zero -> ProperFilter F -> cauchy F -> (forall V : E -> Prop, F V -> exists x : E,
                            V x /\ span u x)
                    ->  cauchy (clean_scal u F).
Proof.
intros Ho PF C HV.
unfold cauchy.
intros e.
unfold clean_scal.
unfold cauchy in C.
assert (hp : 0 < (e * norm u) / 2).
apply Rmult_lt_0_compat.
apply Rmult_lt_0_compat.
apply e.
now apply norm_gt_0.
intuition.
pose (eu := mkposreal ((e * norm u)/2) hp).
specialize (C eu).
simpl in C.
destruct C as (x,C).
unfold Hierarchy.ball in C; simpl in C; unfold ball in C; simpl in C.
specialize (HV (fun y : E => Hnorm (minus x y) < ((e * norm u) / 2)) C).
destruct HV as (z,(HV1,(l,HV2))).
exists l.
exists (fun y : E => Hnorm (minus z y) < e * norm u).
split.
apply filter_imp with (fun y : E => Hnorm (minus x y) < (e * norm u)/2).
intros s Hs.
generalize (norm_triangle (minus z x) (minus x s)) => Hnt.
assert (Ha : plus (minus z x) (minus x s) = minus z s).
unfold minus.
rewrite (Hierarchy.plus_comm x (opp s)).
rewrite plus_assoc_gen.
rewrite plus_opp_l.
now rewrite plus_zero_r.
rewrite Ha in Hnt.
apply Rle_lt_trans with
      (Hnorm (minus z x) + Hnorm (minus x s)).
trivial.
replace (e * norm u) with ((e * norm u / 2)+(e * norm u / 2)) by field.
apply Rplus_lt_le_compat.
replace (Hnorm (minus z x)) with (Hnorm (minus x z)).
trivial.
unfold Hnorm.
f_equal.
unfold minus.
rewrite inner_plus_l.
rewrite inner_plus_l.
rewrite inner_opp_l.
rewrite inner_opp_l.
rewrite Rplus_comm.
f_equal.
replace (plus z (opp x)) with
           (opp (plus x (opp z))).
now rewrite inner_opp_r.
rewrite opp_plus.
rewrite opp_opp.
now rewrite Hierarchy.plus_comm.
replace (plus x (opp z)) with
           (opp (plus z (opp x))).
now rewrite inner_opp_r.
rewrite opp_plus.
rewrite opp_opp.
now rewrite Hierarchy.plus_comm.
intuition.
trivial.
intros l0 Hl0.
unfold Hierarchy.ball; simpl.
unfold AbsRing_ball; simpl.
rewrite HV2 in HV1.
rewrite HV2 in Hl0.
assert (Hl0' : Hnorm (scal (minus l l0) u) < e * norm u).
unfold minus.
rewrite scal_distr_r.
rewrite scal_opp_l.
now unfold minus in Hl0.
rewrite norm_scal in Hl0'.
unfold abs.
simpl.
simpl in Hl0'.
apply Rmult_lt_reg_r in Hl0'.
rewrite Rabs_minus_sym.
trivial.
unfold Hnorm.
now apply norm_gt_0.
Qed.

Hypothesis Hdec3 : forall (u : E) (V : E -> Prop),
             decidable (exists x : E, V x /\ span u x).

Hypothesis Hdec4 : forall u:E, forall x:E, decidable (span u x).

Lemma my_complete_decdec (u : E) : my_complete (span u) ->
         (forall F : (E -> Prop) -> Prop,
             ProperFilter F -> cauchy F ->
             (forall P : E -> Prop, F P ->
             (exists x : E, P x /\ span u x)) -> span u (lim F)).
Proof.
intros Hmc F PF cF HFF.
assert (Hdsnn : forall x:E, span u x <-> ~~ span u x).
intros x.
rewrite (logic_dec_notnot _ (span u)).
intuition.
trivial.
rewrite Hdsnn.
intro Hk.
apply Hk.
apply Hmc; try trivial.
intros P HP.
specialize (HFF P HP).
intro H; apply H.
trivial.
Qed.

(** closedness of the linear span *)
Lemma span_closed (u : E) : my_complete (span u).
Proof.
destruct (is_zero_dec u).
assert (Hdsnn : forall x:E, span u x <-> ~~ span u x).
intros x.
rewrite (logic_dec_notnot _ (span u)).
intuition.
trivial.
assert (Hds2 : my_complete (span u) <->
               my_complete (fun x:E => ~~ span u x)).
split.
intro Hh.
generalize my_complete_decdec => MCDD.
unfold my_complete.
intros F PF cF HFF.
apply Hdsnn.
apply Hh; try assumption.
intros P HP.
specialize (HFF P HP).
intros Hj.
apply HFF.
intros (l,Hl).
apply Hj.
exists l.
split; try easy.
destruct Hl as (Hl1,Hl2).
now apply Hdsnn in Hl2.
intros HH F PF cF HF.
unfold my_complete in HH.
apply Hdsnn.
apply HH; try assumption.
intros P HP.
specialize (HF P HP).
intro Hj.
apply HF.
intros (l,Hl).
destruct Hl as (Hl1,Hl2).
apply Hj.
exists l.
split; try easy.
rewrite Hds2.
apply closed_my_complete.
unfold closed; unfold open; simpl.
intros x Hx.
unfold locally.
unfold Hierarchy.ball; simpl.
unfold ball; simpl.
assert (0 < 1).
intuition.
pose (e := mkposreal 1 H0).
destruct (is_zero_dec x).
exists e.
intros y Hh.
unfold span in Hx.
exfalso.
apply Hx.
exists e.
rewrite H1.
rewrite H.
rewrite scal_zero_r.
reflexivity.
assert (Hnx : 0 < norm x).
apply norm_gt_0.
trivial.
exists (mkposreal (norm x) Hnx).
intros y Hk.
simpl in Hk.
intro.
unfold span in H2.
destruct H2 as (l,H2).
rewrite H in H2.
rewrite scal_zero_r in H2.
rewrite H2 in Hk.
unfold minus in Hk.
rewrite opp_zero in Hk.
rewrite plus_zero_r in Hk.
unfold Hnorm in Hk.
unfold norm in Hk.
simpl in Hk.
unfold Hnorm in Hk.
absurd (sqrt (inner x x) < sqrt (inner x x)).
apply Rlt_irrefl.
trivial.
assert (HO := H); clear H.
assert (Ho' : norm u <> 0).
generalize (norm_gt_0 u HO) => NG.
apply Rlt_dichotomy_converse.
right.
intuition.
assert (Ho'' : 0 < norm u).
now apply norm_gt_0.
intros F PF CF H.
pose (ff := clean_scal u F).
exists (lim ff).
assert (Hk : forall P : Hilbert_CompleteSpace -> Prop,
    F P -> (exists x : Hilbert_CompleteSpace, P x /\ span u x)).
intros P HP.
apply logic_dec_notnot.
trivial.
now apply H.
clear H.
generalize (proper_proj u F PF Hk) => ffP.
generalize (cauchy_scal u F HO PF CF Hk) => ffC.
fold ff in ffP, ffC.
apply ball_eq.
intros eu.
unfold cauchy in ffC, CF.
simpl in ffC, CF.
generalize (@complete_cauchy _ ff ffP ffC) => Hff.
simpl in Hk.
unfold ff in Hff at 1.
unfold clean_scal in Hff.
assert (Hep : 0 < (eu / norm u) /2).
apply Rmult_lt_0_compat.
apply Rmult_lt_0_compat.
apply eu.
generalize (norm_gt_0 u HO) => NG.
assert (/ norm u <> 0).
apply Rinv_neq_0_compat.
apply Rlt_dichotomy_converse.
right.
intuition.
intuition.
intuition.
pose (e := mkposreal ((eu / norm u)/2) Hep).
specialize (Hff (mkposreal e Hep)).
destruct Hff as (V,(Hv1,Hv2)).
generalize Hk => Hk0.
generalize (@complete_cauchy _ F PF CF) => HC.
assert (P2 : 0 < eu/2).
apply Rmult_lt_0_compat.
apply eu.
intuition.
specialize (HC (mkposreal (eu/2) P2)).
assert (H : F (fun x:E => (V x) /\
          (Hierarchy.ball (Hierarchy.lim F) (eu/2)) x)).
now apply filter_and.
specialize (Hk0 _ H).
destruct Hk0 as (x0,((Hx01,Hx02),(lx,Hx1))).
rewrite Hx1 in Hx02.
rewrite Hx1 in Hx01.
specialize (Hv2 lx Hx01).
simpl in Hv2.
unfold Hierarchy.ball; simpl.
unfold ball; simpl.
unfold Hierarchy.ball in Hx02, Hv2.
simpl in Hx02, Hv2.
unfold ball in Hx02; simpl in Hx02.
unfold AbsRing_ball in Hv2; simpl in Hv2.
clear Hx01 H HC P2 Hx1 Hv1.
clear PF CF Hk ffP ffC Hdec3.
assert (HX2 : Hnorm (minus (scal lx u) (scal (lim ff) u)) < eu / 2).
replace (minus (scal lx u) (scal (lim ff) u))
   with (scal (minus lx (lim ff)) u).
rewrite norm_scal.
apply Rmult_lt_reg_r with (/ norm u).
generalize (norm_gt_0 u HO) => NG.
assert (/ norm u <> 0).
apply Rinv_neq_0_compat.
apply Rlt_dichotomy_converse.
right.
intuition.
intuition.
field_simplify.
unfold norm.
simpl.
field_simplify.
replace (Rabs (minus lx (lim ff)) / 1)
        with (abs (minus lx (lim ff))).
replace (eu / (2 * Hnorm u)) with (eu / norm u / 2).
trivial.
field_simplify.
reflexivity.
generalize (norm_gt_0 u HO) => NG.
apply Rlt_dichotomy_converse.
right; intuition.
generalize (norm_gt_0 u HO) => NG.
apply Rlt_dichotomy_converse.
right; intuition.
field_simplify.
reflexivity.
trivial.
trivial.
trivial.
trivial.
unfold minus.
rewrite scal_distr_r.
now rewrite scal_opp_l.
assert (Hy : minus (lim F) (scal (lim ff) u) =
        (plus (minus (lim F) (scal lx u))
        (minus (scal lx u) (scal (lim ff) u)))).
unfold minus.
rewrite (Hierarchy.plus_comm
         (scal lx u) (opp (scal (lim ff) u))).
rewrite plus_assoc_gen.
rewrite plus_opp_l.
rewrite plus_zero_r.
reflexivity.
generalize (norm_triangle (minus (lim F) (scal lx u))
        (minus (scal lx u) (scal (lim ff) u))) => Hnt.
rewrite Hy.
apply Rle_lt_trans with (Hnorm (minus (lim F) (scal lx u)) +
      Hnorm (minus (scal lx u) (scal (lim ff) u))).
trivial.
assert (H2p : 0  < eu / 2).
apply Rmult_lt_0_compat.
apply eu.
intuition.
destruct eu as (eu,Heu).
simpl.
replace eu with (plus (eu/2) (eu/2)).
simpl in Hx02.
simpl in HX2.
now apply Rplus_lt_compat.
unfold plus.
simpl.
field.
Qed.

End FDIM_span.

Section FDIM_sum.
(** * Orthogonal projection *)

Context {E : Hilbert}.

Definition proj (V : E -> Prop) :=
          fun u : E => iota (fun v : E => V v /\ norm (minus u v)
        = Glb_Rbar (fun r => exists w:E, V w /\ r = norm (minus u w))).

Definition proj' (V : E -> Prop) := fun u : E => minus u (proj V u).

Variable G : E -> Prop.

Hypothesis Hs : forall u:E, (forall eps:posreal,
        decidable (exists w:E, G w /\ norm (minus u w) < eps)).

Hypothesis HcG : my_complete G.

Hypothesis HcM : compatible_m G.

Lemma my_complete_complete : complete_subset G.
Proof.
unfold my_complete in HcG.
unfold complete_subset.
exists lim.
intros F PF cF HF.
split.
apply HcG; try assumption.
intros e.
generalize (@complete_cauchy _ F PF cF) => HC.
apply HC.
Qed.

Lemma projG : forall x, G (proj G x).
Proof.
intros x.
unfold proj.
assert (exists! v : E, G v /\ norm (minus x v)
        = Glb_Rbar (fun r => exists w:E, G w /\ r = norm (minus x w))).
apply: ortho_projection_subspace; try assumption.
apply my_complete_complete.
trivial.
destruct H as (c,H).
assert (H' := H).
apply iota_elim in H'.
rewrite H'.
apply H.
Qed.

(** clean_proj and clean_proj' transformers *)

Definition clean_proj (u : E) (F : (E -> Prop) -> Prop) :
                   (E -> Prop) -> Prop
        := filtermap (proj G) F.

Definition clean_proj' (u : E) (F : (E -> Prop) -> Prop) :
                   (E -> Prop) -> Prop
        := filtermap (proj' G) F.

Lemma norm_minus_sym : forall x y : E, Hnorm (minus x y) = Hnorm (minus y x).
Proof.
intros x y.
unfold Hnorm.
assert (Hin : inner (minus x y) (minus x y)
            = inner (minus y x) (minus y x)).
replace (minus y x) with (opp (minus x y)) at 1.
rewrite inner_opp_l.
replace (minus y x) with (opp (minus x y)).
rewrite inner_opp_r.
ring_simplify.
reflexivity.
unfold minus.
rewrite opp_plus.
rewrite opp_opp.
rewrite Hierarchy.plus_comm.
reflexivity.
unfold minus.
rewrite opp_plus.
rewrite opp_opp.
rewrite Hierarchy.plus_comm.
reflexivity.
rewrite Hin.
reflexivity.
Qed.

Lemma proj_sum : forall x, plus (proj G x) (proj' G x) = x.
Proof.
intros x.
unfold proj'.
unfold minus.
rewrite Hierarchy.plus_comm.
rewrite <- Hierarchy.plus_assoc.
rewrite plus_opp_l.
rewrite plus_zero_r.
reflexivity.
Qed.

Lemma PGuisu : forall x, G x -> (proj G x = x).
Proof.
intros x Gx.
generalize (my_complete_complete) => Hcc.
generalize (@direct_sum_with_orth_compl_charac1
             E G HcM Hcc x (proj G x)) => Ds1.
generalize (projG x) => GP.
specialize (Ds1 GP).
assert (Hu : exists! v:E,
          G v /\ norm (minus x v)
        = Glb_Rbar (fun r => exists w:E, G w /\ r = norm (minus x w))).
apply: ortho_projection_subspace; try easy.
destruct Hu as (k,Hk).
assert (Hk2 := Hk).
apply iota_elim in Hk.
assert (iota (fun v : E =>
        G v /\
        norm (minus x v) =
        Glb_Rbar (fun r : R => exists w : E, G w /\ r = norm (minus x w)))
        = proj G x).
unfold proj.
reflexivity.
rewrite H in Hk.
rewrite <- Hk in Hk2.
assert (Ha : norm (minus x (proj G x)) =
      Glb_Rbar (fun r : R => exists w : E, G w /\ r = norm (minus x w))).
apply Hk2.
clear Hk2 Hk H.
specialize (Ds1 Ha).
clear Ha.
now apply Ds1.
Qed.

Lemma PGorth_compl : forall x, orth_compl G x -> (proj G x = zero).
Proof.
intros x Gx.
generalize (my_complete_complete) => Hcc.
generalize (@direct_sum_with_orth_compl_charac2
             E G HcM Hcc x (proj G x)) => Ds2.
generalize (projG x) => GP.
specialize (Ds2 GP).
assert (Hu : exists! v:E,
          G v /\ norm (minus x v)
        = Glb_Rbar (fun r => exists w:E, G w /\ r = norm (minus x w))).
apply: ortho_projection_subspace; try easy.
destruct Hu as (k,Hk).
assert (Hk2 := Hk).
apply iota_elim in Hk.
assert (iota (fun v : E =>
        G v /\
        norm (minus x v) =
        Glb_Rbar (fun r : R => exists w : E, G w /\ r = norm (minus x w)))
        = proj G x).
unfold proj.
reflexivity.
rewrite H in Hk.
rewrite <- Hk in Hk2.
assert (Ha : norm (minus x (proj G x)) =
      Glb_Rbar (fun r : R => exists w : E, G w /\ r = norm (minus x w))).
apply Hk2.
clear Hk2 Hk H.
specialize (Ds2 Ha).
clear Ha.
now apply Ds2.
Qed.

(** linearity of proj *)
Lemma lin_proj : is_linear_mapping (proj G).
Proof.
split.
intros x y.
assert (H : exists! v:E,
          G v /\ norm (minus (plus x y) v)
        = Glb_Rbar (fun r => exists w:E, G w /\ r = norm (minus (plus x y) w))).
apply: ortho_projection_subspace; try easy.
apply my_complete_complete.
destruct H as (zxy,Hxy).
assert (H : exists! v:E,
          G v /\ norm (minus x v)
        = Glb_Rbar (fun r => exists w:E, G w /\ r = norm (minus x w))).
apply: ortho_projection_subspace; try easy.
apply my_complete_complete.
destruct H as (zx,Hx).
assert (H : exists! v:E,
          G v /\ norm (minus y v)
        = Glb_Rbar (fun r => exists w:E, G w /\ r = norm (minus y w))).
apply: ortho_projection_subspace; try easy.
apply my_complete_complete.
destruct H as (zy,Hy).
assert (H : unique (fun v : E =>
         G v /\
         norm (minus (plus x y) v) =
         Glb_Rbar
           (fun r : R => exists w : E, G w /\ r = norm (minus (plus x y) w)))
        (plus zx zy)).
split.
split.
destruct HcM as ((HcM1,HcM2),HcM3).
replace zy with (opp (opp zy)).
apply HcM1.
apply Hx.
replace (opp zy) with (scal (opp one) zy).
apply HcM3.
apply Hy.
rewrite scal_opp_one; reflexivity.
rewrite opp_opp; reflexivity.
generalize (@charac_ortho_projection_subspace2
             E G HcM (plus x y) (plus zx zy)) => CC.
assert (Hgs : G (plus zx zy)).
destruct HcM as ((HcM1,HcM2),HcM3).
replace zy with (opp (opp zy)).
apply HcM1.
apply Hx.
replace (opp zy) with (scal (opp one) zy).
apply HcM3.
apply Hy.
rewrite scal_opp_one.
reflexivity.
rewrite opp_opp.
reflexivity.
specialize (CC Hgs).
clear Hgs.
apply CC.(** linearity of proj *)
intros w Hw.
rewrite inner_plus_l.
rewrite inner_plus_l.
f_equal.
revert Hw.
apply charac_ortho_projection_subspace2.
trivial.
apply Hx.
apply Hx.
revert Hw.
apply charac_ortho_projection_subspace2.
trivial.
apply Hy.
apply Hy.
intros xs (Hg,H).
assert (Hu : unique (fun t => G t /\ norm (minus (plus x y) t) =
     Glb_Rbar
       (fun r0 : R => exists w : E, G w /\ r0 = norm (minus (plus x y) w))) xs).
split.
split; trivial.
assert (Hn : exists! t:E, G t /\ norm (minus (plus x y) t) =
     Glb_Rbar
       (fun r0 : R => exists w : E, G w /\ r0 = norm (minus (plus x y) w))).
apply: ortho_projection_subspace.
trivial.
apply my_complete_complete.
trivial.
destruct Hn as (p,Hn).
assert (Hn' := Hn).
assert (Hn'' := Hn).
apply iota_elim in Hn'.
intros x' Hx'.
destruct Hn as (Hn1,Hn2).
specialize (Hn2 x' Hx').
rewrite <- Hn2.
destruct Hn'' as (Hn''1,Hn''2).
specialize (Hn''2 xs).
symmetry.
apply Hn''2.
split; trivial.
assert (Hu2 : G (plus zx zy) /\  norm (minus (plus x y) (plus zx zy)) =
       Glb_Rbar
       (fun r0 : R => exists w : E, G w /\ r0 = norm (minus (plus x y) w))).
split.
destruct HcM as ((HcM1,Ho),HcM2).
replace zy with (opp (opp zy)).
apply HcM1.
apply Hx.
replace (opp zy) with (scal (opp one) zy).
apply HcM2.
apply Hy.
rewrite scal_opp_one.
reflexivity.
rewrite opp_opp.
reflexivity.
generalize (@charac_ortho_projection_subspace2
             E G HcM (plus x y) (plus zx zy)) => CC.
assert (Hgi : G (plus zx zy)).
destruct HcM as ((HcM1,Ho),HcM2).
replace zy with (opp (opp zy)).
apply HcM1.
apply Hx.
replace (opp zy) with (scal (opp one) zy).
apply HcM2.
apply Hy.
rewrite scal_opp_one.
reflexivity.
rewrite opp_opp.
reflexivity.
specialize (CC Hgi).
apply CC.
intros w Hw.
rewrite inner_plus_l.
rewrite inner_plus_l.
f_equal.
revert Hw.
apply charac_ortho_projection_subspace2.
trivial.
apply Hx.
apply Hx.
revert Hw.
apply charac_ortho_projection_subspace2.
trivial.
apply Hy.
apply Hy.
unfold unique in Hu.
destruct Hu as (Hu,Hu').
symmetry.
apply Hu'.
trivial.
apply iota_elim in H.
apply iota_elim in Hxy.
apply iota_elim in Hx.
apply iota_elim in Hy.
rewrite <- Hx in H.
rewrite <- Hy in H.
now unfold proj.
(* scal *)
intros x l.
assert (H : exists! v:E,
          G v /\ norm (minus (scal l x) v)
        = Glb_Rbar (fun r => exists w:E, G w /\ r = norm (minus (scal l x) w))).
apply: ortho_projection_subspace; try easy.
apply my_complete_complete.
destruct H as (z,Hz).
assert (H : exists! v:E,
          G v /\ norm (minus x v)
        = Glb_Rbar (fun r => exists w:E, G w /\ r = norm (minus x w))).
apply: ortho_projection_subspace; try easy.
apply my_complete_complete.
destruct H as (s,H0).
assert (H : unique (fun v : E =>
         G v /\
         norm (minus (scal l x) v) =
         Glb_Rbar
           (fun r : R => exists w : E, G w /\ r = norm (minus (scal l x) w)))
        (scal l s)).
split.
split.
destruct HcM as ((HcM1,HcM2),HcM3).
apply HcM3.
apply H0.
generalize (@charac_ortho_projection_subspace2
             E G HcM (scal l x) (scal l s)) => CC.
assert (Hgs : G (scal l s)).
destruct HcM as ((HcM1,HcM2),HcM3).
apply HcM3.
apply H0.
specialize (CC Hgs).
clear Hgs.
apply CC.
intros w Hw.
rewrite inner_scal_l.
rewrite inner_scal_l.
apply Rmult_eq_compat_l.
revert Hw.
apply charac_ortho_projection_subspace2.
trivial.
apply H0.
apply H0.
intros r (H1,H2).
assert (Hu : unique (fun t => G t /\ norm (minus (scal l x) t) =
     Glb_Rbar
       (fun r0 : R => exists w : E, G w /\ r0 = norm (minus (scal l x) w))) r).
split.
split; trivial.
assert (Hn : exists! t:E, G t /\ norm (minus (scal l x) t) =
     Glb_Rbar
       (fun r0 : R => exists w : E, G w /\ r0 = norm (minus (scal l x) w))).
apply: ortho_projection_subspace.
trivial.
apply my_complete_complete.
trivial.
destruct Hn as (p,Hn).
assert (Hn' := Hn).
assert (Hn'' := Hn).
apply iota_elim in Hn'.
intros x' Hx'.
destruct Hn as (Hn1,Hn2).
specialize (Hn2 x' Hx').
rewrite <- Hn2.
destruct Hn'' as (Hn''1,Hn''2).
specialize (Hn''2 r).
symmetry.
apply Hn''2.
split; trivial.
assert (Hu2 : G (scal l s) /\  norm (minus (scal l x) (scal l s)) =
       Glb_Rbar
       (fun r0 : R => exists w : E, G w /\ r0 = norm (minus (scal l x) w))).
split.
destruct HcM as (HcM1,HcM2).
apply HcM2; apply H0.
replace (minus (scal l x) (scal l s)) with (scal l (minus x s)).
unfold norm.
simpl.
rewrite norm_scal.
unfold Glb_Rbar.
destruct (ex_glb_Rbar
    (fun r0 : R => exists w : E, G w /\ r0
     = Hnorm (minus (scal l x) w))).
simpl.
unfold is_glb_Rbar in i.
destruct i as (I1,I2).
unfold is_lb_Rbar in I1.
unfold is_lb_Rbar in I2.
assert (J1 : Rbar_le x0 (Rabs l * Hnorm (minus x s))).
apply I1.
exists (scal l s).
split.
apply (proj2 HcM).
apply H0.
rewrite <- norm_scal.
unfold minus.
rewrite scal_distr_l.
rewrite scal_opp_r.
reflexivity.
assert (J2 : Rbar_le (Rabs l * Hnorm (minus x s)) x0).
apply I2.
intros x1 Hx1.
destruct Hx1 as (w,(Hw1,Hw2)).
rewrite Hw2.
destruct (is_zero_dec l).
rewrite H.
rewrite Rabs_R0.
simpl.
ring_simplify.
apply norm_ge_0.
assert (Hq : exists y:E, G y /\ (y = scal (1 / l) w)).
exists (scal (1/l) w).
split.
apply (proj2 HcM).
trivial.
reflexivity.
destruct Hq as (y,(Hy1,Hy2)).
assert (Hc : w = scal l y).
rewrite Hy2.
rewrite scal_assoc.
unfold mult.
simpl.
replace (l * (1 / l)) with 1.
rewrite scal_one.
reflexivity.
now field.
rewrite Hc.
rewrite <- norm_scal.
unfold minus.
rewrite <- scal_opp_r.
rewrite <- scal_distr_l.
assert (Rap : 0 < Rabs l).
now apply Rabs_pos_lt.
rewrite norm_scal.
rewrite norm_scal.
pose (L := mkposreal (Rabs l) Rap).
generalize (Rbar_mult_pos_le (Hnorm (minus x s))
                             (Hnorm (minus x y))
                              L) => RMP.
simpl in RMP.
assert (RMP' : Hnorm (minus x s) <= Hnorm (minus x y) <->
       Rabs l * Hnorm (minus x s)<= Rabs l * Hnorm (minus x y)).
rewrite RMP.
rewrite Rmult_comm.
rewrite (Rmult_comm (Hnorm (minus x y)) (Rabs l)).
reflexivity.
clear RMP.
unfold Rbar_le.
rewrite <- RMP'.
assert (HG: norm (minus x s) =
        Glb_Rbar (fun r : R => exists w : E, G w /\ r = norm (minus x w))).
apply H0.
unfold Glb_Rbar in HG.
destruct ((ex_glb_Rbar
          (fun r0 : R => exists w0 : E, G w0 /\ r0 = norm (minus x w0)))).
simpl in HG.
unfold is_glb_Rbar in i.
unfold is_lb_Rbar in i.
destruct i as (S1,S2).
destruct x2.
unfold real in HG.
rewrite <- HG in S1.
unfold norm in HG.
simpl in HG.
specialize (S1 (Hnorm (minus x y))).
simpl in S1.
apply S1.
exists y.
split.
trivial.
reflexivity.
simpl in S1.
specialize (S1 (norm (minus x w))).
exfalso.
apply S1.
exists w.
split.
trivial.
reflexivity.
simpl in HG.
unfold norm in HG; simpl in HG.
rewrite HG.
apply norm_ge_0.
generalize (Rbar_le_antisym (Rabs l * Hnorm (minus x s)) x0) => RL.
specialize (RL J2 J1).
destruct x0.
intuition.
simpl in J1.
now exfalso.
simpl in J2.
now exfalso.
rewrite scal_distr_l.
unfold minus.
rewrite scal_opp_r.
reflexivity.
unfold unique in Hu.
destruct Hu as (Hu,Hu').
symmetry.
apply Hu'.
trivial.
apply iota_elim in H.
apply iota_elim in H0.
rewrite <- H0 in H.
now unfold proj.
Qed.

(** metric properties of proj  *)
Lemma proj_min : forall x:E, norm (proj G x) <= norm x.
Proof.
intros x.
destruct (is_zero_dec x).
assert (GO : G zero).
destruct HcM as ((HcM1,Ho),HcM2).
destruct Ho as (z,Ho).
specialize (HcM2 z 0%R).
rewrite scal_zero_l in HcM2.
now apply HcM2.
rewrite H.
generalize (@PGuisu zero GO) => Gz.
rewrite Gz.
apply Rle_refl.
destruct (is_zero_dec (proj G x)).
rewrite H0.
unfold norm. simpl.
rewrite norm_zero.
apply norm_ge_0.
apply Rmult_le_reg_r with (norm (proj G x)).
apply norm_gt_0.
trivial.
rewrite squared_norm.
generalize (@charac_ortho_projection_subspace2
             E G HcM x (proj G x) (projG x)) => CC.
assert (Hh : inner (proj G x) (proj G x) = inner x (proj G x)).
apply CC.
assert (He : exists! v:E,
          G v /\ norm (minus x v)
        = Glb_Rbar (fun r => exists w:E, G w /\ r = norm (minus x w))).
apply: ortho_projection_subspace; try easy.
apply my_complete_complete.
destruct He as (c,He).
assert (He' := He).
apply iota_elim in He.
assert (He2 : iota
       (fun v : E =>
        G v /\
        norm (minus x v) =
        Glb_Rbar
          (fun r : R => exists w : E, G w /\ r = norm (minus x w)))
       = proj G x).
unfold proj; reflexivity.
rewrite He in He2.
rewrite He2 in He'.
apply He'.
apply projG.
rewrite Hh.
apply Rle_trans with (Rabs (inner x (proj G x))).
unfold Rabs.
destruct (Rcase_abs (inner x (proj G x))).
apply Rle_trans with 0.
intuition.
intuition.
apply Rle_refl.
apply Cauchy_Schwartz_with_norm.
Qed.

Lemma dist_proj (e : posreal) :  forall x y: E,
                  Hierarchy.ball x e y -> (Hierarchy.ball (proj G x) e
                                                          (proj G y)).
Proof.
intros x y Hxy.
unfold Hierarchy.ball in *; simpl in *.
unfold ball in *; simpl in *.
assert (HL : minus (proj G x) (proj G y) = (proj G (minus x y))).
generalize lin_proj => LL.
destruct LL as (LL1,LL2).
unfold minus at 1.
assert (Ho : opp (proj G y) = scal (opp one) (proj G y)).
rewrite scal_opp_one; reflexivity.
rewrite Ho.
rewrite <- LL2.
rewrite LL1.
rewrite scal_opp_one.
reflexivity.
rewrite HL.
apply Rle_lt_trans with (Hnorm (minus x y)).
apply proj_min.
trivial.
Qed.

Lemma cauchy_proj (u : E) (F : (E -> Prop) -> Prop) :
             ProperFilter F -> cauchy F -> cauchy (clean_proj u F).
Proof.
intros PF cF.
unfold cauchy in *.
intros e.
specialize (cF e).
destruct cF as (x,cF).
exists (proj G x).
unfold clean_proj, filtermap.
apply filter_imp with (Hierarchy.ball x e); try assumption.
intros y Hy.
now apply dist_proj.
Qed.

Lemma cauchy_proj' (u : E) (F : (E -> Prop) -> Prop):
             ProperFilter F -> cauchy F -> cauchy (clean_proj' u F).
Proof.
intros PF cF.
unfold cauchy in *.
intros e.
assert (H2: 0 < e/ 2).
apply Rlt_div_r.
intuition.
ring_simplify.
apply e.
specialize (cF (mkposreal (e/2) H2)).
simpl in cF.
destruct cF as (x,cF).
exists (proj' G x).
unfold clean_proj', filtermap.
apply filter_imp with (Hierarchy.ball x (e/2)); try assumption.
intros y Hy.
unfold proj'.
unfold Hierarchy.ball; simpl.
unfold ball; simpl.
assert (Hl: (minus (minus x (proj G x)) (minus y (proj G y))) =
        (plus (minus x y) (minus (proj G y) (proj G x)))).
unfold minus.
rewrite (Hierarchy.plus_comm (proj G y) (opp (proj G x))).
rewrite plus_assoc_gen.
rewrite opp_plus.
rewrite opp_opp.
reflexivity.
rewrite Hl.
apply Rle_lt_trans with (plus (Hnorm (minus x y))
                        (Hnorm (minus (proj G y) (proj G x)))).
apply: norm_triangle.
destruct e as (e,he).
replace e with ((e/2) + (e /2)) by field.
simpl in *.
unfold plus; simpl.
apply Rplus_lt_compat.
unfold Hierarchy.ball in Hy.
simpl in Hy.
now unfold ball in Hy.
replace (Hnorm (minus (proj G y) (proj G x))) with
        (Hnorm (minus (proj G x) (proj G y))).
generalize (dist_proj (mkposreal (e/2) H2) x y) => Hdi.
unfold Hierarchy.ball in Hdi; simpl in Hdi.
unfold ball in Hdi; simpl in Hdi.
apply Hdi.
apply Hy.
rewrite norm_minus_sym.
reflexivity.
Qed.

Hypothesis Hdec3s : forall (u : E) (V : E -> Prop),
             decidable (exists x : E, V x /\ span u x).

Hypothesis Hdec4s : forall u:E, forall x:E, decidable (span u x).
Hypothesis Hdec5s : forall (u : E) (V : E -> Prop),
             decidable (exists x : E, V x /\
                   (exists g w : E, G g /\
                   span u w /\ x = plus g w)).

(** sum of closed subset and linear span is closed, with
continuity proofs of proj *)
Lemma sum_span_cl_cl : forall (u : E),
          (forall x:E, decidable (G x)) -> orth_compl G u ->
         my_complete (fun x:E => exists g : E, exists w : E,
                      G g /\ span u w /\ x = plus g w).
Proof.
intros u GD Go.
case (GD u) => GU.
generalize (@direct_sumable_with_orth_compl E G) => Hz.
unfold direct_sumable in Hz.
specialize (Hz u GU Go).
intros F PF cF HF.
exists (lim F).
exists zero.
split.
apply HcG; try easy.
intros P HP S.
specialize (HF P HP).
apply HF.
intro S'.
apply S.
destruct S' as (x,(H1,(g,(w,(H2,(H3,H4)))))).
exists x.
split; try easy.
rewrite H4.
rewrite Hz in H3.
destruct H3 as (l,H3).
rewrite scal_zero_r in H3.
rewrite H3.
now rewrite plus_zero_r.
split.
exists 0%R.
rewrite scal_zero_l.
reflexivity.
rewrite plus_zero_r.
reflexivity.
intros F PF cF H.
simpl in *.
pose (Fw' := clean_proj u F).
pose (Fw'' := clean_proj' u F).
assert (Fw'PF : ProperFilter Fw').
now apply filtermap_proper_filter.
assert (Fw''PF : ProperFilter Fw'').
now apply filtermap_proper_filter.
exists (lim Fw').
exists (lim Fw'').
split.
assert (HG : lim Fw' = proj G (lim F)).
apply @filterlim_locally_unique with (F:=F)
        (f := fun x => proj G x).
now apply Proper_StrongProper.
unfold filterlim, filter_le, filtermap.
intros P HlP.
unfold locally in HlP.
destruct HlP as (e,HlP).
assert (HW'c : cauchy Fw').
unfold Fw'.
apply cauchy_proj; try assumption.
unfold cauchy in cF.
specialize (cF e).
destruct cF as (x,cF).
apply filter_imp with (fun x0 => Hierarchy.ball (lim Fw') e (proj G x0)).
intros x0 HA.
specialize (HlP (proj G x0)).
now apply HlP.
generalize (@complete_cauchy _ Fw' Fw'PF HW'c) => Hgw'.
unfold Fw' at 1 in Hgw'.
unfold clean_proj at 1 in Hgw'.
unfold filtermap in Hgw'.
specialize (Hgw' e).
trivial.
unfold filterlim, filter_le, filtermap.
intros P HlP.
unfold locally in HlP.
destruct HlP as (e,HlP).
apply filter_imp with (fun x0 => Hierarchy.ball (proj G (lim F)) e (proj G x0)).
intros x0 HA.
specialize (HlP (proj G x0)).
now apply HlP.
generalize (@complete_cauchy _ F PF cF) => Hg.
assert (H2p : 0 < e / 2).
apply Rlt_div_r.
intuition.
ring_simplify.
apply e.
specialize (Hg (mkposreal (e/2) H2p)).
apply filter_imp with (Hierarchy.ball (Hierarchy.lim F) (e/2)).
intros x HX.
apply dist_proj.
unfold Hierarchy.ball.
simpl.
unfold ball; simpl.
unfold Hierarchy.ball in HX.
simpl in HX.
unfold ball in HX.
simpl in HX.
apply Rlt_trans with (e/2).
trivial.
apply Rlt_div_l.
intuition.
destruct e as (e,He).
simpl in *.
replace e with (e*1) at 1 by field.
apply Rmult_lt_compat_l.
apply He.
intuition.
trivial.
rewrite HG.
apply projG.
split.
assert (cF'' : cauchy Fw'').
apply cauchy_proj'.
trivial. trivial.
generalize (@complete_cauchy _ Fw'' Fw''PF cF'') => Hgw''.
generalize (span_closed Hdec3s Hdec4s u) => Hj.
unfold my_complete in Hj.
assert (H2 : forall P : E -> Prop,
    F P ->
    (exists x : E, P x /\
     (exists g w : E, G g /\ span u w /\ x = plus g w))).
intros P HP.
apply logic_dec_notnot.
trivial.
now apply H.
assert (H3 : forall P, Fw'' P -> exists x : E, P x /\ span u x).
intros V HV.
unfold Fw'' in HV.
unfold clean_proj' in HV.
unfold filtermap in HV.
apply H2 in HV.
destruct HV as (x,HV).
exists (proj' G x).
split.
intuition.
unfold proj'.
destruct HV as (HV1,(g,(w,(HV2,((l,HV3),HV4))))).
rewrite HV4.
generalize (@lin_proj) => LP.
destruct LP as (LP1,LP2).
rewrite (LP1 g w).
rewrite PGuisu; try easy.
unfold minus.
rewrite opp_plus.
rewrite plus_assoc_gen.
rewrite plus_opp_r.
rewrite plus_zero_l.
exists l.
replace (opp (proj G w)) with (@zero E).
now rewrite plus_zero_r.
replace (@zero E) with (opp (opp (@zero E))).
assert (HO : opp zero = proj G w).
rewrite opp_zero.
rewrite HV3.
generalize lin_proj => Hl.
destruct Hl as (_,Hl).
specialize (Hl u l).
rewrite Hl.
rewrite PGorth_compl.
rewrite scal_zero_r.
reflexivity.
trivial.
rewrite HO.
reflexivity.
rewrite opp_opp; reflexivity.
apply Hj.
trivial.
trivial.
intros P HOP.
intro S; apply S.
specialize (H3 _ HOP).
intuition.
apply ball_eq.
intros e.
assert (cF' : cauchy Fw').
apply cauchy_proj.
trivial.
trivial.
assert (cF'' : cauchy Fw'').
apply cauchy_proj'.
trivial.
trivial.
generalize (@complete_cauchy _ Fw' Fw'PF cF') => Hgw'.
generalize (@complete_cauchy _ Fw'' Fw''PF cF'') => Hgw''.
generalize (@complete_cauchy _ F PF cF) => Hg.
assert (h2 : 0 < e/2).
apply Rlt_div_r.
intuition.
ring_simplify.
apply e.
specialize (Hg (mkposreal (e/2) h2)).
assert (H4p : 0 < e/4).
apply Rlt_div_r.
apply Rlt_trans with 3.
apply Rlt_trans with 2.
intuition.
intuition.
replace 3 with (2 + 1) by ring.
replace 4 with (3 + 1) by ring.
apply Rplus_lt_le_compat.
intuition.
intuition.
ring_simplify.
apply e.
specialize (Hgw' (mkposreal (e/4) H4p)).
specialize (Hgw'' (mkposreal (e/4) H4p)).
unfold Fw' at 1 in Hgw'.
unfold clean_proj in Hgw'.
unfold Fw'' at 1 in Hgw''.
unfold clean_proj' in Hgw''.
unfold filtermap in Hgw', Hgw''.
assert (H2 : forall P : E -> Prop,
    F P ->
    (exists x : E, P x /\
     (exists g w : E, G g /\
                   span u w /\ x = plus g w))).
intros P HP.
apply logic_dec_notnot.
trivial.
now apply H.
simpl in Hgw', Hgw''.
specialize (H2 (fun x : E => (Hierarchy.ball (Hierarchy.lim Fw') (e/4) (proj G x) /\
            Hierarchy.ball (Hierarchy.lim Fw'') (e/4) (proj' G x)) /\
            Hierarchy.ball (Hierarchy.lim F) (e/2) x)).
assert (Hand : F
       (fun x : E =>
        (Hierarchy.ball (Hierarchy.lim Fw') (e/4) (proj G x) /\
         Hierarchy.ball (Hierarchy.lim Fw'') (e/4) (proj' G x)) /\
         Hierarchy.ball (Hierarchy.lim F) (e/2) x)).
apply filter_and.
now apply filter_and.
trivial.
specialize (H2 Hand).
destruct H2 as (x2,(H21,(g2,(w2,(H22,(H23,H24)))))).
clear Hand.
unfold Hierarchy.ball in H21; simpl in H21.
unfold ball in H21; simpl in H21.
destruct H21 as ((Hn1,Hn2),Hn3).
unfold Hierarchy.ball; simpl.
unfold ball; simpl.
assert (Hss : minus (lim F) (plus (lim Fw') (lim Fw'')) =
         (plus (minus (lim F) x2) (minus x2 (plus (lim Fw') (lim Fw''))))).
unfold minus.
rewrite (Hierarchy.plus_comm (lim F) (opp x2)).
rewrite plus_assoc_gen.
rewrite plus_opp_l.
rewrite plus_zero_l.
reflexivity.
rewrite Hss.
apply Rle_lt_trans with (plus (Hnorm (minus (lim F) x2))
                    (Hnorm (minus x2 (plus (lim Fw') (lim Fw''))))).
apply: norm_triangle.
destruct e as (e,He).
simpl.
replace e with ((e/2)+(e/2)) by field.
simpl in *.
apply Rplus_lt_compat.
trivial.
assert (Hx : plus (Hnorm (minus (Hierarchy.lim Fw') (proj G x2)))
                  (Hnorm (minus (Hierarchy.lim Fw'') (proj' G x2))) < e / 2).
replace (e/2) with ((e/4) + (e/4)) by field.
now apply Rplus_lt_compat.
rewrite norm_minus_sym.
replace (Hnorm (minus (plus (lim Fw') (lim Fw'')) x2)) with
        (Hnorm (minus (plus (lim Fw') (lim Fw''))
               (plus (proj G x2) (proj' G x2)))).
unfold minus.
unfold minus in Hx.
rewrite opp_plus.
rewrite plus_assoc_gen.
apply Rle_lt_trans with (plus (Hnorm (plus (Hierarchy.lim Fw')
                (opp (proj G x2))))
       (Hnorm (plus (Hierarchy.lim Fw'') (opp (proj' G x2))))).
apply: norm_triangle.
trivial.
rewrite proj_sum.
reflexivity.
Qed.

End FDIM_sum.

Section FDIM_closed.

Context {E : Hilbert}.

Hypothesis Hdec3c : forall (u : E) (V : E -> Prop),
             decidable (exists x : E, V x /\ span u x).

Definition B_ortho (B : nat -> E) := forall (i : nat), Hnorm (B i) = 1
                     /\ (forall i j, i <> j ->
                        (inner (B i) (B j)) = 0).

Lemma dim_f_span_sum : forall (d: nat) (B : nat -> E), (0 < d)%nat ->
           B_ortho B -> forall Phi : E -> Prop,
           (phi_FDIM Phi (S d) B) <->
           (exists phi_m, phi_FDIM phi_m d B /\
             orth_compl phi_m (B (S (d-1))) /\
             (forall x:E, Phi x  <->
            (exists a s, span (B (S (d -1))) s /\ phi_m a /\ x = plus s a))).
Proof.
intros d B dpos B_ortho Phi.
split.
intros Hphin.
unfold phi_FDIM in *.
destruct (eq_nat_dec (S d) 0).
exfalso.
intuition.
destruct (eq_nat_dec d 0).
exfalso; auto with zarith.
exists (fun r : E =>
       (exists L : nat -> R, r = sum_n (fun n : nat => scal (L n) (B n)) (d-1))).
split.
unfold phi_FDIM.
intros u0; reflexivity.
split.
unfold orth_compl.
intros y Hy.
destruct Hy as (L,Hy).
rewrite Hy.
rewrite inner_sym.
rewrite inner_sum_n.
replace 0 with (sum_n (fun n : nat => 0) (d-1)).
apply sum_n_ext_loc.
intros m Hm.
rewrite inner_scal_l.
destruct B_ortho with m.
specialize (H0 m (S (d-1))).
assert (H0' : m <> S (d-1)).
auto with zarith.
specialize (H0 H0').
rewrite H0.
ring_simplify.
reflexivity.
unfold sum_n.
rewrite sum_n_m_const_zero.
reflexivity.
intros x.
split.
intros Hx.
specialize (Hphin x).
apply Hphin in Hx.
destruct Hx as (L,Hx).
exists (sum_n (fun n : nat => scal (L n) (B n)) (d-1)).
exists (scal (L (S d -1)%nat) (B (S d -1)%nat)).
split.
unfold span.
exists (L (S (d - 1))).
replace (S d -1)%nat with (S (d -1)) by auto with zarith.
reflexivity.
split.
exists L; reflexivity.
rewrite Hx.
replace (S d -1)%nat with (S (d-1))%nat by auto with zarith.
rewrite sum_Sn.
rewrite Hierarchy.plus_comm.
reflexivity.
intros Has.
specialize (Hphin x).
apply Hphin.
destruct Has as (a,(s,(Ha1,(Ha2,Ha3)))).
destruct Ha2 as (L,Ha2).
unfold span in Ha1.
destruct Ha1 as (l,Ha1).
exists (fun n : nat => match le_gt_dec n (d-1) with
               | left _ => L n
               | right _ => l end).
rewrite Ha3.
rewrite Ha2.
rewrite Ha1.
replace (S d -1)%nat with (S (d -1)%nat) by auto with zarith.
rewrite sum_Sn.
destruct (le_gt_dec (S d) d).
exfalso; intuition.
rewrite Hierarchy.plus_comm.
f_equal.
apply sum_n_ext_loc.
intros m Hm.
destruct (le_gt_dec m (d-1)).
reflexivity.
exfalso; intuition.
destruct (le_gt_dec (S (d -1)) (d-1)).
exfalso; auto with zarith.
reflexivity.
intros Hh.
destruct Hh as (phi_m,(K1,(K3,K2))).
unfold phi_FDIM in *.
intros x.
split.
intros Px.
specialize (K2 x).
apply K2 in Px.
destruct Px as (a,HPx).
destruct HPx as (s,(P1,(P2,P3))).
destruct (eq_nat_dec d 0).
exfalso; auto with zarith.
specialize (K1 a).
apply K1 in P2.
destruct P2 as (L,P2).
unfold span in P1.
destruct P1 as (l,P1).
exists (fun n : nat => match le_gt_dec n (d-1) with
               | left _ => L n
               | right _ => l end).
rewrite P3 P2 P1.
replace (S d -1)%nat with (S (d-1)) by auto with zarith.
rewrite sum_Sn.
rewrite Hierarchy.plus_comm.
f_equal.
apply sum_n_ext_loc.
intros m Hm.
destruct (le_gt_dec m (d-1)).
reflexivity.
exfalso; intuition.
destruct (le_gt_dec (S (d-1)) (d-1)).
exfalso; intuition.
reflexivity.
intros H.
specialize (K2 x).
apply K2.
destruct H as (L,H).
exists (sum_n (fun n : nat => scal (L n) (B n)) (d-1)).
exists (scal (L (S (d-1))) (B (S (d-1)))).
split.
unfold span.
exists (L (S (d-1))).
reflexivity.
split.
destruct (eq_nat_dec d 0).
exfalso; auto with zarith.
specialize (K1 ((sum_n (fun n : nat => scal (L n) (B n)) (d-1)))).
apply K1.
exists L.
reflexivity.
rewrite H.
replace (S d -1)%nat with (S (d-1)) by auto with zarith.
rewrite sum_Sn.
rewrite Hierarchy.plus_comm.
reflexivity.
Qed.

(** * Decidability of the belonging to finite dim subspace *)

Lemma FDIM_dec : forall (d:nat) (Phi : E -> Prop) (b : nat -> E),
                phi_FDIM Phi d b -> B_ortho b ->
                forall x:E, decidable (Phi x).
Proof.
intros d Phi b phi_EV B_ortho x.
unfold phi_FDIM in phi_EV.
destruct (eq_nat_dec d 0).
specialize (phi_EV x).
destruct (is_zero_dec x).
left.
now apply phi_EV.
right.
intro Hf.
apply phi_EV in Hf.
rewrite Hf in H.
intuition.
case (is_zero_dec (minus x
     (sum_n (fun i => scal (inner x (b i)) (b i)) (d-1))))
     => HT.
left.
rewrite (phi_EV x).
assert (x = sum_n (fun i : nat => scal (inner x (b i)) (b i)) (d-1)).
apply plus_reg_r with
      (opp (sum_n (fun i : nat => scal (inner x (b i)) (b i)) (d-1))).
rewrite plus_opp_r.
now unfold minus in HT.
now exists (fun n:nat => inner x (b n)).
right.
intro H.
apply (phi_EV x) in H.
destruct H as (L,H).
rewrite H in HT.
apply HT.
unfold minus.
apply plus_reg_r with
      ((sum_n
        (fun i : nat =>
         scal (inner (sum_n (fun n : nat => scal (L n) (b n)) (d-1)) (b i))
           (b i)) (d-1))).
simpl.
rewrite <- Hierarchy.plus_assoc.
simpl.
rewrite plus_opp_l.
rewrite plus_zero_l.
rewrite plus_zero_r.
apply sum_n_ext_loc.
intros m Hm.
induction m.
rewrite inner_sum_n.
unfold sum_n.
rewrite (sum_n_m_Chasles _ 0 0 (d-1)); try auto with zarith.
rewrite scal_distr_r.
replace (scal (L 0%nat) (b O)) with (plus (scal (L 0%nat) (b O)) zero)
         by (rewrite plus_zero_r; reflexivity).
f_equal.
unfold sum_n_m; simpl.
unfold Iter.iter_nat.
simpl.
rewrite plus_zero_r.
rewrite inner_scal_l.
rewrite <- squared_norm.
rewrite (proj1 (B_ortho O)).
replace (L 0%nat * (1 * 1)) with (L 0%nat) by ring.
reflexivity.
assert ((@zero E) = (sum_n_m (fun n => (@zero E)) 1 (d-1))).
rewrite sum_n_m_const_zero.
reflexivity.
rewrite H0.
assert (sum_n_m (fun _ : nat => zero) 1 (d-1) =
        scal (sum_n_m (fun _ : nat => zero) 1 (d-1)) (b O)).
repeat (rewrite sum_n_m_const_zero).
rewrite scal_zero_l.
reflexivity.
rewrite H1.
f_equal; try reflexivity.
apply sum_n_m_ext_loc.
intros k Hk.
assert (H' : k <> O).
auto with zarith.
apply ((proj2 (B_ortho O))) in H'.
rewrite inner_scal_l.
rewrite H'.
rewrite Rmult_0_r.
reflexivity.
f_equal.
rewrite inner_sum_n.
replace (L (S m)) with (sum_n (fun n0 => match (le_gt_dec n0 (S m)) with
                               |left _ => match (eq_nat_dec n0 (S m)) with
                                    |left _ => L n0 |right _ => 0 end
                               |right _ => 0
                               end) (d-1)).
apply sum_n_ext_loc.
intros no Hno.
destruct (le_gt_dec no (S m)).
destruct (eq_nat_dec no (S m)).
rewrite e.
rewrite inner_scal_l.
rewrite <- squared_norm.
rewrite (proj1 (B_ortho (S m))).
ring_simplify.
reflexivity.
rewrite inner_scal_l.
rewrite ((proj2 (B_ortho (S m))) no); try assumption.
ring_simplify.
reflexivity.
rewrite inner_scal_l.
rewrite ((proj2 (B_ortho (S m))) no); try assumption.
ring_simplify. reflexivity.
auto with zarith.
unfold sum_n.
rewrite (sum_n_m_Chasles _ 0 (S m) (d-1)); try auto with zarith.
rewrite (sum_n_m_Chasles _ 0 m (S m)); try auto with zarith.
replace (L (S m)) with (plus (plus 0 (L (S m))) 0).
f_equal.
f_equal.
replace 0%R with (sum_n_m (fun n => 0%R) 0 m).
apply sum_n_m_ext_loc.
intros k Hk.
destruct (le_gt_dec k (S m)).
destruct (eq_nat_dec k (S m)).
exfalso.
intuition.
rewrite sum_n_m_const_zero.
reflexivity.
exfalso.
intuition.
rewrite sum_n_m_const_zero.
reflexivity.
replace (L (S m)) with (sum_n_m (fun n0 => match (le_gt_dec n0 (S m)) with
                               |left _ => match (eq_nat_dec n0 (S m)) with
                                    |left _ => L n0 |right _ => 0 end
                               |right _ => 0
                               end) (S m) (S m)).
apply sum_n_m_ext_loc.
intros no Hno.
destruct (le_gt_dec no (S m)).
destruct (eq_nat_dec no (S m)).
reflexivity.
reflexivity.
reflexivity.
rewrite sum_n_n.
destruct (le_gt_dec (S m) (S m)).
destruct (eq_nat_dec (S m) (S m)).
reflexivity.
exfalso; auto with zarith.
exfalso; auto with zarith.
replace 0 with (sum_n_m (fun n => 0) (S (S m)) (d-1)).
apply sum_n_m_ext_loc.
intros k Hk.
destruct (le_gt_dec k (S m)).
destruct (eq_nat_dec k (S m)).
exfalso; intuition.
rewrite sum_n_m_const_zero.
reflexivity.
rewrite sum_n_m_const_zero.
reflexivity.
rewrite sum_n_m_const_zero.
reflexivity.
rewrite plus_zero_l.
now rewrite plus_zero_r.
Qed.

(** * Finite subspace is ModuleSpace-compatible *)

Lemma FDIM_comp_m : forall (d:nat) (phi : E -> Prop) (b : nat -> E),
                phi_FDIM phi d b -> compatible_m phi.
Proof.
intros dim phi b phi_EV.
unfold phi_FDIM in phi_EV.
destruct (eq_nat_dec dim 0).
split.
split.
intros x y Hx Hy.
apply phi_EV in Hx.
apply phi_EV in Hy.
rewrite Hx Hy.
rewrite plus_zero_l.
rewrite opp_zero.
apply phi_EV.
reflexivity.
exists zero.
apply phi_EV; reflexivity.
intros x l Hl.
apply phi_EV in Hl.
rewrite Hl.
rewrite scal_zero_r.
apply phi_EV; reflexivity.
split.
split.
intros x y Hx Hy.
apply (phi_EV x) in Hx.
apply (phi_EV y) in Hy.
apply phi_EV.
destruct Hx as (Lx,Hx).
destruct Hy as (Ly,Hy).
exists (fun n: nat => minus (Lx n) (Ly n)).
rewrite Hx Hy.
unfold minus.
rewrite <- scal_opp_one.
rewrite <- sum_n_scal_l.
rewrite <- sum_n_plus.
f_equal.
apply functional_extensionality.
intros m.
rewrite scal_distr_r.
rewrite scal_opp_one.
rewrite scal_opp_l.
reflexivity.
exists zero.
apply phi_EV.
exists (fun n => zero).
transitivity (sum_n
             (fun n : nat => (@zero E)) (dim-1)).
unfold sum_n.
rewrite sum_n_m_const_zero.
reflexivity.
apply sum_n_ext_loc.
intros m Hm.
rewrite scal_zero_l.
reflexivity.
intros x l Hx.
apply phi_EV.
apply (phi_EV x) in Hx.
destruct Hx as (L,Hx).
exists (fun n : nat => scal l (L n)).
rewrite Hx.
rewrite <- sum_n_scal_l.
apply sum_n_ext_loc.
intros m Hm.
rewrite scal_assoc.
reflexivity.
Qed.

(** * Finite dim subspace is closed *)

Hypothesis Hs : forall phi : E -> Prop, forall u:E, (forall eps:posreal,
        decidable (exists w:E, phi w /\ norm (minus u w) < eps)).

Hypothesis Hdec6f : forall phi : E -> Prop, forall (u : E) (V : E -> Prop),
       decidable (exists x : E, V x /\ (exists g w : E,
             phi g /\ span u w /\ x = plus g w)).

Lemma FDIM_closed : forall (d : nat) (B : nat -> E),
                    forall Phi : E -> Prop,
                   (forall u:E, (forall eps:posreal,
                  decidable (exists w:E, Phi w /\ norm (minus u w) < eps))) ->
                   phi_FDIM Phi d B -> B_ortho B -> my_complete Phi.
Proof.
induction d.
intros B Phi HD H B_ortho.
assert (Heq : forall u:E, Phi u <-> span zero u).
intros u.
split.
intros Hphi.
exists 0.
rewrite scal_zero_l.
unfold phi_FDIM in H.
apply (H u) in Hphi.
trivial.
intros Hss.
unfold phi_FDIM in H.
destruct (eq_nat_dec 0 0).
apply H.
destruct Hss as (l,Hl).
rewrite scal_zero_r in Hl.
rewrite Hl.
reflexivity.
exfalso; auto with zarith.
intros F PF cF HH.
apply Heq.
assert (Heq' : (forall P0 : E -> Prop,
           F P0 -> ~ ~ (exists x : E, P0 x /\ Phi x))
             -> (forall K : E -> Prop,
           F K -> ~ ~ (exists x : E, K x /\ span zero x))).
intros H1 Q HQ.
intro HF.
specialize (HH Q HQ).
apply HH.
intro HF2.
destruct HF2 as (w,(W1,W2)).
apply HF.
exists w.
split; try assumption.
now apply Heq.
assert (HH2 : forall K : E -> Prop,
        F K -> ~ ~ (exists x : E, K x /\ span zero x)).
now apply Heq'.
generalize HH2.
generalize F PF cF.
assert (my_complete ((@span E) zero)).
apply span_closed.
apply Hdec3c.
apply span_dec.
trivial.
intros B Phi HD HS B_ortho.
assert (P := HS).
destruct (eq_nat_dec d 0).
unfold phi_FDIM in HS.
destruct (eq_nat_dec (S d) 0).
exfalso; auto with zarith.
rewrite e in HS.
simpl in HS.
assert (HS' : forall u : E,
     Phi u <-> span (B O) u).
intros u.
split.
intros Hph.
apply HS in Hph.
destruct Hph as (L,Hph).
rewrite sum_O in Hph.
now exists (L 0%nat).
intros Hsp.
apply HS.
destruct Hsp as (l,Hsp).
exists (fun n => l).
now rewrite sum_O.
generalize (@span_closed E Hdec3c (span_dec) (B 0%nat)) => SC.
intros F PF cF HF.
apply HS'.
apply SC; try easy.
intros V HV.
intro VF.
specialize (HF V HV).
apply HF.
intros (f,GF).
apply VF.
exists f.
split; try easy.
apply HS'.
easy.
apply dim_f_span_sum in P.
destruct P as (phi_m,(P1,(P0,P2))).
assert (P3 : forall x : E, Phi x <->
       (exists a s : E, phi_m a /\ span (B (S (d-1))) s /\ x = plus a s)).
intros z.
specialize (P2 z).
split.
intros Hp.
apply P2 in Hp.
destruct Hp as (a,(s,(hp1,(hp2,hp3)))).
exists a, s.
split; try assumption.
split; try assumption.
now rewrite Hierarchy.plus_comm.
intros Hex.
destruct Hex as (a,(s,(hp1,(hp2,hp3)))).
apply P2.
exists a, s.
split; try assumption.
split; try assumption.
now rewrite Hierarchy.plus_comm.
assert (PP : my_complete Phi <-> my_complete (fun x => exists a s : E, phi_m a
               /\ span (B (S (d-1))) s
           /\ x = plus a s)).
split.
intros Hmcp.
unfold my_complete in Hmcp.
unfold my_complete.
intros F PF cF HF.
specialize (Hmcp F PF cF).
rewrite <- P3.
apply Hmcp.
intros P FP.
specialize (HF P FP).
intro.
apply HF.
intro.
apply H.
destruct H0 as (x,H0).
exists x.
split.
intuition.
destruct H0 as (H01,H02).
rewrite P3.
trivial.
intros Hcls.
unfold my_complete.
intros F PF cF HF.
specialize (Hcls F PF cF).
rewrite P3.
apply Hcls.
intros P FP.
specialize (HF P FP).
intro.
apply HF.
intro.
apply H.
destruct H0 as (x,H0).
exists x.
split.
intuition.
destruct H0 as (H01,H02).
rewrite <- P3.
trivial.
apply PP.
apply sum_span_cl_cl; trivial.
apply IHd with B; trivial.
apply FDIM_comp_m with d B; trivial.
apply span_dec.
generalize (FDIM_dec d phi_m) => Dm.
specialize (Dm B P1 B_ortho).
apply: Dm.
trivial.
auto with zarith.
trivial.
Qed.

End FDIM_closed.