(**
This file is part of the Elfic library

Copyright (C) Boldo, Clément, Faissole, Martin, Mayero

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 hilbert.
Require Export continuous_linear_map.
Require Export Decidable.
Require Export FunctionalExtensionality.
Require Export mathcomp.ssreflect.ssreflect.
Require Export Coquelicot.Hierarchy.
Require Export Reals.
Require Export logic_tricks.
Require Export ProofIrrelevanceFacts.
Require Export Reals Coquelicot.Coquelicot.
Require Export R_compl.
Require Export logic_tricks.
Require Export compatible.

Section ker_generic.

Context {E : Hilbert}.
Context {F : NormedModule R_AbsRing}.

(**  Kernel of an application *)

Definition ker (f : E -> F) := fun x:E => f x = zero.

Lemma compatible_m_ker : forall (f : E -> F), is_linear_mapping f ->
                  compatible_m (ker f).
Proof.
intros.
unfold compatible_m; unfold compatible_g.
split; intros.
split; intros.
unfold ker in *.
unfold is_linear_mapping in H.
intuition. rewrite H2. rewrite H0.
rewrite <- scal_opp_one. rewrite H3.
rewrite H1. rewrite scal_zero_r.
rewrite plus_zero_r; reflexivity.
exists zero. unfold ker.
apply: is_linear_mapping_zero; trivial.
unfold is_linear_mapping in H.
unfold ker. destruct H. rewrite H1.
unfold ker in H0. rewrite H0.
rewrite scal_zero_r; reflexivity.
Qed.

Lemma clm_ker_convex : forall (f : E->F), is_linear_mapping f ->
                 convex (ker f).
Proof.
intros f H x y t Hx Hy Ht.
unfold ker in *.
destruct H as (G1,G2).
rewrite G1.
repeat (rewrite G2).
rewrite Hx; rewrite Hy.
repeat (rewrite scal_zero_r).
rewrite plus_zero_l.
reflexivity.
Qed.

End ker_generic.

(** Kernel of an application in the topo dual *)

Section ker_dual.

Context {E : Hilbert}.

Lemma ker_nnker_equiv : forall (f : topo_dual E) x,
                        (ker (m f) x) <-> ~~(ker (m f) x).
Proof.
intros f x.
apply (logic_dec_notnot E (ker f) x).
apply Req_dec.
Qed.

Lemma clm_ker_closed : forall (f : topo_dual E),
                  closed (ker f).
Proof.
intros f x Hx.
unfold ker in *.
cut (continuous f x).
unfold continuous, filterlim, filter_le, filtermap.
intros H; specialize H with (P:=fun y => y <> 0).
case (Req_dec (f x) 0); try easy; intros H1.
assert (K: 0 < Rabs (f x)).
apply Rabs_pos_lt.
trivial.
exfalso.
apply Hx.
apply H.
exists (pos_div_2 (mkposreal _ K)).
simpl; unfold ball; simpl.
unfold AbsRing_ball; simpl.
unfold abs; simpl.
intros y Hy.
destruct (Req_dec y 0).
rewrite H0 in Hy.
unfold minus in *.
rewrite plus_zero_l in Hy.
rewrite Rabs_Ropp in Hy.
assert (Rabs (f x) / 2 < Rabs (f x)).
apply Rmult_lt_reg_l with 2.
intuition.
assert (H1':2 * (Rabs (f x) / 2) = (Rabs (f x))).
field.
rewrite H1'.
replace (Rabs (f x)) with (1*(Rabs (f x))) at 1.
apply Rmult_lt_compat_r; intuition.
ring_simplify; reflexivity.
exfalso.
apply Rlt_not_le in Hy.
apply Hy.
intuition.
trivial.
apply continuous_linear_map_3_2.
apply continuous_linear_map_4_3.
apply continuous_linear_map_5_4.
apply f.
apply continuous_linear_map_6_5.
apply f.
apply Cf.
Qed.

Lemma clm_ker_my_complete : forall (f : topo_dual E),
                  my_complete (ker f).
Proof.
intros f.
apply closed_my_complete.
apply clm_ker_closed.
Qed.

Lemma compatible_m_nnker : forall (f : topo_dual E),
                  compatible_m  (ker f).
Proof.
intros.
unfold compatible_m; unfold compatible_g.
assert (is_linear_mapping f).
apply Lf.
intros.
split; intros.
split; intros.
apply compatible_m_ker; try easy.
exists zero.
apply: is_linear_mapping_zero; trivial.
apply compatible_m_ker; try assumption.
Qed.

Lemma clm_ker_complete : forall (f : topo_dual E),
                  complete_subset (ker f).
Proof.
intros f.
generalize (closed_my_complete (ker f) (clm_ker_closed f)).
intros H.
unfold my_complete in H.
exists fixed_point.lim.
intros F HF1 HF2 HF3.
split.
apply H; try assumption.
apply: complete_cauchy; easy.
Qed.

Lemma clm_ker_convex2 : forall (f : topo_dual E),
                 convex (ker f).
Proof.
intros f x y t Hx Hy Ht.
apply clm_ker_convex; trivial.
apply f.
Qed.

End ker_dual.

(** * RIESZ-FRECHET *)

Section Riesz_Frechet.

Context {E : Hilbert}.

Variable phi : E -> Prop.

Hypothesis phi_C : my_complete phi.

Hypothesis m_C : compatible_m phi.

Definition f_phi_neq_zero (f : topo_dual E) :=
                     (exists u0, phi u0 /\ f u0 <> 0).

(** Riesz-Frechet theorem *)

Theorem Riesz_Frechet'_zero_phi : forall (f:topo_dual E),
   ~f_phi_neq_zero f ->  exists (u:E), phi u /\ forall (v:E),
     phi v -> f v = inner u v.
Proof.
intros f H.
exists zero.
split.
destruct m_C as ((CG1,(z,CG2)),CS).
unfold compatible_m in m_C.
assert (C0 := CS z 0%R CG2).
now rewrite scal_zero_l in C0.
intros v Hv.
rewrite inner_zero_l.
destruct (Req_dec (f v) 0).
trivial.
exfalso.
apply H.
exists v.
split; trivial.
Qed.

Lemma compatible_m_and : forall (phi phi' : E -> Prop), compatible_m phi ->
          compatible_m phi' -> compatible_m (fun x : E => phi x /\ phi' x).
Proof.
intros phi0 phi0' C C'.
unfold compatible_m.
split.
unfold compatible_g.
split.
intros x y H H0.
destruct H as (H1,H2).
destruct H0 as (H01,H02).
destruct C as (C1,C2).
destruct C1 as (C1,C11).
destruct C' as (C1',C2').
destruct C1' as (C1',C11').
split.
apply C1; trivial.
apply C1'; trivial.
exists zero.
split.
apply compatible_m_zero.
apply C.
apply compatible_m_zero.
apply C'.
intros x l.
split.
destruct C as (_,C).
apply C.
exact (proj1 H).
destruct C' as (_,C').
apply C'.
exact (proj2 H).
Qed.

Lemma closed_and : forall (phi phi' : E -> Prop), my_complete phi ->
    my_complete phi' -> my_complete (fun x : E => phi x /\ phi' x).
Proof.
intros phi0 phi0' C C' F HPf Hcf H.
split.
unfold my_complete in C, C'.
apply C; try assumption.
intros P HFP.
intro.
specialize (H P HFP).
apply H.
intro.
apply H0.
destruct H1 as (x,(H1,(H2,_))).
exists x; try intuition.
apply C'; try assumption.
intros P HFP.
intro.
specialize (H P HFP).
apply H.
intro.
apply H0.
destruct H1 as (x,(H1,(_,H2))).
exists x; try intuition.
Qed.

Lemma Riesz_Frechet'_nzero_phi : forall (f:topo_dual E),
   (forall u, forall eps:posreal, decidable (exists w:E, ((ker f w /\ phi w)
                                                          /\ norm (minus u w) < eps))) ->
   f_phi_neq_zero f ->  exists (u:E), phi u /\ forall (v:E),
     phi v -> f v = inner u v.
Proof.
intros f HD2 H.
destruct H as (u0,H).
pose (PHI := fun w : E => ker f w /\ phi w).
assert (forall u v,
    PHI v -> norm (minus u v)
        = Glb_Rbar (fun r => exists w:E, PHI w /\ r = norm (minus u w)) ->
      (PHI u <-> v = u)).
apply: direct_sum_with_orth_compl_charac1.
apply compatible_m_and.
apply compatible_m_ker.
apply f.
trivial.
unfold complete_subset.
exists (fixed_point.lim).
intros F K K0 K1.
split.
assert (PHI_C : my_complete PHI).
apply closed_and.
(*apply closed_my_complete.*)
apply clm_ker_my_complete.
apply phi_C; try assumption.
apply PHI_C; try assumption.
apply: complete_cauchy; easy.
assert (forall u, exists! v:E,
       PHI v /\ norm (minus u v)
       = Glb_Rbar (fun r => exists w:E, PHI w
        /\ r = norm (minus u w))).
intros u; apply: ortho_projection_convex.
exists zero.
split.
(*apply ker_nnker_equiv.*)
apply: compatible_m_zero.
apply compatible_m_ker, f.
destruct m_C as ((CG1,(z,CG2)),CS).
specialize (CS z 0%R CG2).
now rewrite scal_zero_l in CS.
split.
assert (compatible_m (fun x : E => ker f x)).
apply compatible_m_ker, f.
destruct H4 as ((G1,G2),G3).
replace (scal (1 - theta) v)
        with (opp (opp (scal (1 - theta) v))).
apply G1.
apply G3.
apply H1.
rewrite <- scal_opp_one.
apply G3.
apply G3.
apply H2.
now rewrite opp_opp.
destruct m_C as ((G1,G2),G3).
replace (scal (1 - theta) v)
        with (opp (opp (scal (1 - theta) v))).
apply G1.
apply G3.
apply H1.
rewrite <- scal_opp_one.
apply G3.
apply G3.
apply H2.
now rewrite opp_opp.
unfold complete_subset.
exists (fixed_point.lim).
intros F K K0 K1.
split.
assert (PHI_C : my_complete PHI).
apply closed_and.
(*apply closed_my_complete.*)
apply clm_ker_my_complete.
apply phi_C; try assumption.
apply PHI_C; try assumption.
apply: complete_cauchy; easy.
apply HD2.
destruct (H1 u0).
assert (~(x = u0)).
rewrite <- H0.
intro hF.
unfold PHI in hF.
destruct hF as (hF1,hF2).
(*rewrite <- ker_nnker_equiv in hF1.*)
unfold ker in hF1.
intuition.
apply H2.
apply H2.
pose (v0 := minus u0 x).
assert (v0 <> zero).
unfold v0. intro.
absurd (x = u0).
trivial.
apply plus_reg_r with (opp x).
unfold minus in H4.
rewrite plus_opp_r.
symmetry; trivial.
pose (e0 := scal (/ (norm v0)) v0).
pose (u := scal (f e0) e0).
exists u.
split.
unfold u.
destruct m_C as ((P1,P2),P3).
apply P3.
unfold e0.
apply P3.
unfold v0.
unfold minus.
apply P1.
intuition.
apply H2.
intros v Hv.
assert (e0 <> zero).
assert (f e0  <> zero).
unfold e0.
assert (Lin : (is_linear_mapping f)).
apply Lf.
destruct Lin as (Lin1,Lin2).
rewrite Lin2.
unfold scal.
simpl.
apply Rmult_integral_contrapositive.
split.
apply Rinv_neq_0_compat.
intro.
apply NormedModule.ax5 in H5.
intuition.
unfold v0. unfold minus.
rewrite Lin1.
assert (f (opp x) = 0).
assert (opp x = scal (opp one) x).
rewrite scal_opp_one.
reflexivity.
rewrite H5.
rewrite Lin2.
assert (ker f x).
apply H2.
(*rewrite <- ker_nnker_equiv in H6.*)
unfold ker in H6.
rewrite H6.
rewrite scal_zero_r.
reflexivity.
rewrite H5.
rewrite plus_zero_r.
intuition.
trivial.
intro. rewrite H6 in H5.
rewrite is_linear_mapping_zero in H5.
intuition.
apply Lf.
assert (norm e0 = 1).
unfold e0.
rewrite norm_scal_R.
assert (abs (/norm v0) = /norm v0).
assert (forall x : R, (0 <= x) -> abs(x) = x).
intros.
unfold abs.
simpl.
apply Rabs_pos_eq.
trivial.
apply H6.
assert (0 < / norm v0).
apply Rinv_0_lt_compat.
apply norm_gt_0.
intuition.
intuition.
rewrite H6.
field. intro.
apply NormedModule.ax5 in H7.
intuition.
pose (lambda := (f v) / (f e0)).
pose (w := minus v (scal lambda e0)).
assert (f w = 0).
unfold w. unfold lambda. unfold minus.
assert (is_linear_mapping f).
apply Lf.
destruct H7.
rewrite H7.
assert (f (opp (scal (f v / f e0) e0))
        = opp ((scal (f v / f e0) (f e0)))).
rewrite <- scal_opp_one.
rewrite H8.
symmetry.
rewrite H8. rewrite scal_opp_one.
rewrite <- H8. rewrite <- H8. unfold e0.
reflexivity.
rewrite H9. unfold scal. simpl.
assert (mult (f v / f e0) (f e0) = f v).
assert ((f v / f e0) = mult (f v) (/f e0)).
intuition. rewrite H10.
rewrite <- mult_assoc.
change ((mult (/ f e0) (f e0)))
        with ((/ f e0)*(f e0)).
rewrite Rinv_l. rewrite mult_one_r. reflexivity.
unfold e0.
assert (Lin : (is_linear_mapping f)).
apply Lf. destruct Lin as (Lin1,Lin2).
rewrite Lin2. unfold scal; simpl.
apply Rmult_integral_contrapositive.
split. assert (0 < / norm v0).
apply Rinv_0_lt_compat.
apply norm_gt_0.
intuition.
intro. apply Rlt_not_le in H11.
apply H11.
intuition.
unfold v0. unfold minus.
rewrite Lin1.
assert (f (opp x) = 0).
assert (opp x = scal (opp one) x).
rewrite scal_opp_one.
reflexivity.
rewrite H11.
rewrite Lin2.
assert (ker f x).
apply H2.
(*rewrite <- ker_nnker_equiv in H12.*)
unfold ker in H12.
rewrite H12.
rewrite scal_zero_r.
reflexivity.
rewrite H11.
rewrite plus_zero_r.
intuition.
rewrite H10.
rewrite plus_opp_r.
reflexivity.
assert (orth_compl (fun x => PHI x) v0).
unfold v0.
apply: direct_sum_with_orth_compl_decomp.
apply compatible_m_and.
apply compatible_m_ker, f.
trivial.
apply H2.
apply H2.
assert (orth_compl (fun x => PHI x) e0).
unfold e0.
assert (compatible_m
                (orth_compl (fun x0 : E => PHI x0))).
apply orth_compl_compat.
destruct H9 as ((G1,(a,G2)),G3).
apply G3; trivial.
assert (orth_compl (fun x => PHI x) u).
unfold u.
assert (compatible_m
                (orth_compl (fun x0 : E => PHI x0))).
apply orth_compl_compat.
destruct H10 as ((G1,(a,G2)),G3).
apply G3; trivial.
assert (inner u w = 0).
unfold orth_compl in H10.
apply H10.
split.
(*apply ker_nnker_equiv.*)
trivial.
unfold w.
destruct m_C as ((P1,P2),P3).
unfold minus.
apply P1.
trivial.
apply P3.
unfold e0.
apply P3.
unfold v0.
unfold minus.
apply P1.
intuition.
apply H2.
assert (inner u w = minus (inner u v) (f v)).
assert (minus (inner u v) (f v)
        = minus (inner u v) (scal lambda (inner u e0))).
unfold lambda. unfold u at 3.
rewrite (inner_scal_l e0 e0 (f e0)).
unfold scal. simpl.
rewrite mult_assoc.
assert (inner e0 e0 = 1).
rewrite <- squared_norm.
unfold norm in H6. simpl in H6.
rewrite H6.
ring_simplify; reflexivity.
rewrite H12.
rewrite mult_one_r.
assert ((f v / f e0) = mult (f v) (/ f e0)).
reflexivity.
rewrite H13.
rewrite <- mult_assoc.
rewrite <- Rinv_l_sym.
rewrite mult_one_r.
reflexivity.
assert (f e0  <> zero).
unfold e0.
assert (Lin : (is_linear_mapping f)).
apply Lf.
destruct Lin as (Lin1,Lin2).
rewrite Lin2.
unfold scal.
simpl.
apply Rmult_integral_contrapositive.
split.
apply Rinv_neq_0_compat.
intro.
apply NormedModule.ax5 in H14.
intuition.
unfold v0. unfold minus.
rewrite Lin1.
assert (f (opp x) = 0).
assert (opp x = scal (opp one) x).
rewrite scal_opp_one.
reflexivity.
rewrite H14.
rewrite Lin2.
assert (ker f x).
apply H2.
(*rewrite <- ker_nnker_equiv in H15.*)
unfold ker in H15.
rewrite H15.
rewrite scal_zero_r.
reflexivity.
rewrite H14.
rewrite plus_zero_r.
intuition.
apply H14.
rewrite H12.
unfold w.
unfold minus.
rewrite inner_plus_r.
rewrite <- inner_scal_r.
rewrite <- inner_opp_r.
reflexivity.
rewrite H11 in H12.
apply plus_reg_r with (opp (f v)).
rewrite plus_opp_r.
unfold minus in H12.
trivial.
Qed.

Theorem Riesz_Frechet_uniqueness_phi: forall (f:topo_dual E),
    forall u u',
     ((phi u) /\ forall (v:E),  phi v -> f v = inner u v) ->
     ((phi u') /\  forall (v:E), phi v -> f v = inner u' v) -> u = u'.
Proof.
intros f u u' H H0.
assert (forall v : E, phi v -> inner u v = inner u' v).
intros.
transitivity (f v).
symmetry.
apply H.
trivial.
apply H0.
trivial.
assert (forall v : E, phi v -> inner (minus u u') v = 0).
intros. unfold minus.
rewrite inner_plus_l. rewrite inner_opp_l.
ring_simplify. rewrite H1. ring_simplify; reflexivity.
trivial.
apply trivial_orth_compl' in H2.
unfold minus in H2. apply plus_reg_r with (opp u').
rewrite plus_opp_r. trivial.
now apply: my_complete_closed.
unfold minus; apply m_C; intuition.
Qed.

Theorem Riesz_Frechet_zero_phi : forall (f:topo_dual E),
      (~ f_phi_neq_zero f) -> exists! (u:E), phi u /\ (forall (v:E),
      phi v -> f v = inner u v).
Proof.
intros f H.
apply unique_existence1; split.
apply Riesz_Frechet'_zero_phi.
trivial.
unfold uniqueness.
apply Riesz_Frechet_uniqueness_phi.
Qed.

Theorem Riesz_Frechet_nzero_phi : forall (f:topo_dual E),
       (forall u, forall eps:posreal, decidable (exists w:E, ((ker f w /\ phi w)
                                                          /\ norm (minus u w) < eps))) ->
      f_phi_neq_zero f -> exists! (u:E), phi u /\ (forall (v:E),
      phi v -> f v = inner u v).
Proof.
intros f HD2 H.
apply unique_existence1; split.
apply Riesz_Frechet'_nzero_phi.
trivial.
trivial.
trivial.
unfold uniqueness.
apply Riesz_Frechet_uniqueness_phi.
Qed.

Theorem Riesz_Frechet_strong_phi : forall (f:topo_dual E),
    (forall u, forall eps:posreal, decidable (exists w:E, ((ker f w /\ phi w)
                                                          /\ norm (minus u w) < eps))) ->
    (decidable (f_phi_neq_zero f)) ->  exists! (u:E), phi u /\ (forall (v:E),
    phi v -> f v = inner u v).
Proof.
intros f J Hor.
destruct Hor.
now apply Riesz_Frechet_nzero_phi.
now apply Riesz_Frechet_zero_phi.
Qed.

(** Riesz representation function *)

Context {F : Hilbert}.

Definition tau := fun (f:topo_dual E) =>
  (iota (fun u : E => phi u /\ forall v : E, phi v -> f v = inner u v)).

Lemma iota_elim : forall (P : E->Prop) (v : E),
     (unique (fun x : E => P x) v) ->  iota P = v.
Proof.
intros P v Hu.
assert (exists! v, P v).
exists v.
trivial.
apply iota_correct in H.
assert (P v).
apply Hu.
unfold unique in Hu.
destruct Hu as (_,Hu).
symmetry.
apply Hu.
trivial.
Qed.

Lemma iota_elimE (H : (CompleteNormedModule R_AbsRing)) : forall (P : H->Prop) (v : H),
     (unique (fun x : H => P x) v) ->  iota P = v.
Proof.
intros P v Hu.
assert (H' : exists! v, P v).
exists v.
trivial.
apply iota_correct in H'.
assert (P v).
apply Hu.
unfold unique in Hu.
destruct Hu as (_,Hu).
symmetry.
apply Hu.
trivial.
Qed.

Lemma phi_tau :
    forall (f : topo_dual E),
     (forall u, forall eps:posreal,
        decidable (exists w:E, ((ker f w /\ phi w) /\ norm (minus u w) < eps))) ->
    (decidable (f_phi_neq_zero f)) -> phi (tau f).
Proof.
intros f Hd Hd'.
unfold tau.
assert (H : exists! (w:E), phi w /\ forall (v:E),
      phi v -> f v = inner w v).
apply Riesz_Frechet_strong_phi; trivial.
destruct H as (w,H).
generalize H.
intros H'.
apply (iota_elim _ _) in H.
rewrite H.
apply H'.
Qed.

Theorem Riesz_Frechet_moreover1_zero_phi :
   forall (f:topo_dual E),
       (~ f_phi_neq_zero f) -> operator_norm_phi phi f
                                   = norm (tau f).
Proof.
intros f H.
simpl.
assert (exists! (u:E), phi u /\ forall (v:E), phi v ->
      f v = inner u v).
apply Riesz_Frechet_zero_phi.
intro Hf.
destruct Hf as (vf,Hf).
apply H.
exists vf; trivial.
destruct H0 as (u,H0).
apply (iota_elim _ _ ) in H0.
unfold tau.
rewrite H0.
assert (forall v, phi v -> f v = 0).
intros v HV.
destruct (Req_dec (f v) 0).
trivial.
exfalso.
apply H.
exists v.
split; trivial.
assert (u = zero).
rewrite <- H0.
assert (exists! (u:E), phi u /\ forall (v:E),
      phi v -> f v = inner u v).
apply Riesz_Frechet_zero_phi.
intro Hf.
destruct Hf as (vf,Hf).
apply H.
exists vf; trivial.
destruct H2 as (u2,H2).
assert (forall v, phi v -> inner u2 v = zero).
intros v0 Hv0.
assert (f v0 = inner u2 v0).
apply H2.
trivial.
rewrite <- H3.
unfold f_phi_neq_zero in H.
destruct (is_zero_dec (f v0)).
trivial.
exfalso.
apply H.
exists v0; split; trivial.
generalize H2; intro H2'.
apply (iota_elim _ _ ) in H2.
rewrite H2.
specialize (H3 u2).
apply PreHilbert.ax3 in H3.
trivial.
apply H2'.
rewrite H2.
rewrite norm_zero.
assert (forall u, u <> zero -> phi u -> norm (f u) <= 0 * norm u).
intros u0 H3 H3'.
unfold f_phi_neq_zero.
rewrite H1.
rewrite norm_zero.
ring_simplify; intuition.
trivial.
apply (operator_norm_helper3'_phi phi) in H3.
assert (Rbar_le 0 (operator_norm_phi phi f)).
apply operator_norm_ge_0_phi.
try assumption.
apply Rbar_le_antisym.
assert (is_finite (operator_norm_phi phi f)).
apply operator_norm_helper3_phi with 0.
try assumption.
apply Rle_refl.
intros u0 Hu0 Hu0'.
rewrite H1.
rewrite norm_zero.
ring_simplify; intuition.
trivial.
unfold Rbar_le.
rewrite <- H5.
trivial.
trivial.
try assumption.
now apply Rle_refl.
Qed.

Theorem Riesz_Frechet_moreover1_nzero_phi :
   forall (f:topo_dual E),
    (forall u, forall eps:posreal, decidable (exists w:E, ((ker f w
                                                          /\ (phi w))
                                                          /\ norm (minus u w) < eps))) ->
        (f_phi_neq_zero f) -> operator_norm_phi phi f = norm (tau f).
Proof.
intros f K H.
simpl.
assert (exists! (u:E), phi u /\forall (v:E), phi v ->
      f v = inner u v).
apply Riesz_Frechet_nzero_phi; trivial.
destruct H as (v,H).
destruct H0 as (u,H0).
assert (exists! (u:E), phi u /\ forall (v:E), phi v ->
      f v = inner u v).
apply Riesz_Frechet_nzero_phi; trivial.
exists v.
trivial.
destruct H1 as (u1,H1).
assert (Heq : u = u1).
unfold unique in H1.
destruct H1 as (H11,H12).
symmetry.
apply H12.
apply H0.
apply (iota_elim _ _ ) in H0.
unfold tau.
rewrite H0.
assert (u <> zero).
rewrite Heq.
destruct H1 as (H11,H12).
assert (f v = inner u1 v).
apply H11.
exact (proj1 H).
intro.
absurd (f v = zero).
trivial.
rewrite H2 in H1.
rewrite inner_zero_l in H1.
trivial.
assert (norm u <> 0).
intro.
apply norm_eq_zero in H3.
intuition.
exfalso; intuition.
rewrite H2 in H1.
rewrite inner_zero_l in H1.
trivial.
assert (Haf : (norm(f u))/(norm u)=norm u).
assert (f u = inner u u).
rewrite <- Heq in H1.
apply H1.
apply H1.
rewrite H3.
rewrite <- squared_norm.
assert (norm (Hnorm u * Hnorm u) = norm u * norm u).
assert (HnN : Hnorm u = norm u).
reflexivity.
rewrite HnN.
assert (Hnorm : forall x, 0 <= x -> norm(x) = x).
intros x Posx.
unfold norm.
simpl.
unfold abs.
simpl.
unfold Rabs.
destruct (Rcase_abs x).
absurd (0 <= x); trivial.
apply Rlt_not_le in r.
trivial.
trivial.
apply Hnorm.
apply Rle_0_sqr.
rewrite H4.
field.
destruct (Req_dec (norm u) 0).
apply norm_eq_zero in H5.
exfalso; intuition.
trivial.
assert (HG : Rbar_le (norm u) (operator_norm_phi phi f)).
rewrite <- Haf.
unfold operator_norm_phi.
destruct (Is_only_zero_set_dec_phi E).
unfold Lub_Rbar.
destruct (ex_lub_Rbar
 (fun x : R => exists u0 : Hilbert_NormedModule E,
 u0 <> zero /\ phi u0 /\ x = norm (f u0) / norm u0)).
simpl. destruct x.
unfold is_lub_Rbar in i.
unfold is_ub_Rbar in i.
destruct i.
apply H3.
exists u; intuition.
rewrite <- Heq in H1.
apply H1.
trivial.
trivial.
destruct i.
unfold is_ub_Rbar in H3.
simpl in H3.
apply H3 with (norm (f u) / norm u).
exists u.
rewrite <- Heq in H1.
split; try assumption.
split; try reflexivity.
apply H1.
apply (Is_only_zero_set_correct1_phi E phi) with u in i.
absurd (norm u = 0).
exfalso; intuition.
rewrite i.
rewrite norm_zero.
reflexivity.
rewrite <- Heq in H1.
apply H1.
assert (HD : Rbar_le (operator_norm_phi phi f) (norm u)).
destruct (operator_norm_helper2'_phi phi f).
destruct f.
apply op_norm_finite_phi; try assumption.
destruct H3 as (HZ,Hof).
rewrite Hof.
apply norm_ge_0.
destruct H3 as (HZ,Hof).
assert (Hfin : is_finite (operator_norm_phi phi f)).
destruct f; trivial.
apply op_norm_finite_phi; try assumption.
destruct (operator_norm_phi phi f).
apply Hof.
apply norm_ge_0.
intros u0 Hu0 Hp0.
assert (HU0 : (Rabs (f u0) / (norm u0)) <= norm u).
assert (HU02 : f u0 = inner u u0).
rewrite <- Heq in H1.
apply H1.
trivial.
rewrite HU02.
assert (HU03 : Rabs (inner u u0) <= norm u *  norm u0).
apply Cauchy_Schwartz_with_norm.
apply Rmult_le_reg_r with (norm u0).
assert (Hvnz : u0 <> zero).
intro.
absurd (u0 <> zero).
intuition.
trivial.
apply norm_gt_0.
trivial.
field_simplify.
assert (forall x, x / 1 = x).
intro x.
field.
repeat (rewrite H4).
rewrite Rmult_comm.
field_simplify in HU03.
trivial.
assert (Hvnz : u0 <> zero).
trivial.
apply Rgt_not_eq.
apply Rlt_gt.
apply norm_gt_0.
trivial.
assert (RaN : Rabs (f u0) = norm (f u0)).
unfold norm; simpl.
reflexivity.
rewrite RaN in HU0.
apply (Rmult_le_compat_r (norm u0)
                         (norm (f u0) / norm u0)
                         (norm u)) in HU0.
field_simplify in HU0.
assert (Hx1 : forall x, x / 1 = x).
intro x; field.
repeat (rewrite Hx1 in HU0).
rewrite Rmult_comm.
trivial.
absurd (norm u0 = 0).
apply Rgt_not_eq.
apply Rlt_gt.
apply norm_gt_0.
trivial.
trivial.
apply norm_ge_0.
simpl.
apply is_finite_correct in Hfin.
destruct Hfin as (y,Hy).
absurd (Rbar_lt (Finite y) p_infty).
apply Rbar_le_not_lt.
rewrite Hy.
apply Rbar_le_refl.
intuition.
apply is_finite_correct in Hfin.
destruct Hfin as (y,Hy).
absurd (Rbar_lt m_infty (Finite y)).
apply Rbar_le_not_lt.
rewrite Hy.
apply Rbar_le_refl.
simpl.
trivial.
apply Rbar_le_antisym; trivial.
Qed.

Theorem Riesz_Frechet_moreover1_phi:
   forall (f:topo_dual E),
     (decidable (f_phi_neq_zero f)) ->
      (forall u, forall eps:posreal, decidable (exists w:E, ((ker f w /\ phi w)
                                                          /\ norm (minus u w) < eps))) ->
         operator_norm_phi phi f = norm (tau f).
Proof.
intros f Hd Hd0.
destruct Hd.
apply Riesz_Frechet_moreover1_nzero_phi; trivial.
apply Riesz_Frechet_moreover1_zero_phi; trivial.
Qed.

Theorem Riesz_Frechet_moreover2_phi :
    (forall f:topo_dual E,
     decidable (f_phi_neq_zero f)) ->
  (forall (f:topo_dual E), forall u, forall eps:posreal, decidable (exists w:E, ((ker f w /\ phi w)
                                                          /\ norm (minus u w) < eps))) ->
     is_linear_mapping tau.
Proof.
intros H HhH; split.
intros x y.
apply Riesz_Frechet_uniqueness_phi with (plus x y).
apply (iota_correct (fun u : E => phi u /\ forall v0 : E, phi v0 ->
                                  (plus x y) v0 = inner u v0)).
apply Riesz_Frechet_strong_phi.
apply HhH.
trivial.
split.
destruct m_C as ((P1,P2),P3).
replace (tau y) with (opp (opp (tau y))).
apply P1.
apply phi_tau.
trivial.
trivial.
trivial.
replace (opp (tau y)) with (scal (opp one) (tau y)).
apply P3.
apply phi_tau.
trivial. trivial. trivial.
rewrite scal_opp_one.
reflexivity.
rewrite opp_opp.
reflexivity.
intros v Hv.
rewrite inner_plus_l.
apply trans_eq with (x v + y v).
reflexivity.
f_equal.
apply (iota_correct (fun u : E => phi u /\ forall v0 : E,
                              phi v0 -> x v0 = inner u v0)).
apply Riesz_Frechet_strong_phi; trivial.
trivial.
apply (iota_correct (fun u : E => phi u /\ forall v0 : E,
                              phi v0 -> y v0 = inner u v0)).
apply Riesz_Frechet_strong_phi.
trivial.
trivial.
trivial.
intros x l.
apply Riesz_Frechet_uniqueness_phi with (scal l x).
apply (iota_correct (fun u : E => phi u /\ forall v0 : E,
                     phi v0 -> (scal l x) v0 = inner u v0)).
apply Riesz_Frechet_strong_phi.
trivial.
trivial.
split.
destruct m_C as ((P1,P2),P3).
apply P3.
apply phi_tau.
trivial. trivial. trivial.
intros v Hv.
rewrite inner_scal_l.
apply trans_eq with (l*x v).
reflexivity.
f_equal.
apply (iota_correct (fun u : E => phi u /\ forall v0 : E,
                         phi v0 -> x v0 = inner u v0)).
apply Riesz_Frechet_strong_phi.
trivial.
trivial.
trivial.
Qed.

End Riesz_Frechet.

(** * LAX-MILGRAM *)

Section LM_aux.

Context {E : Hilbert}.

Variable a : E -> E -> R.
Variable M : R.
Variable alpha : R.
Variable phi : E -> Prop.

Hypothesis phi_C : my_complete phi.
Hypothesis phi_m : compatible_m phi.
Hypothesis Hba : is_bounded_bilinear_mapping a M.
Hypothesis Hca : is_coercive a alpha.

Definition is_sol_linear_pb_phi (f:E -> R) (u:E):=
    phi u /\ forall v:E, phi v -> a u v = f v.

Definition Tau := fun (f:topo_dual E) =>
  (iota (fun u : E => phi u /\ forall v : E, phi v -> f v = inner u v)).

Lemma phi_Tau : forall (f : topo_dual E),
    (forall u, forall eps:posreal, decidable (exists w:E, ((ker f w /\ phi w)
                                                          /\ norm (minus u w) < eps))) ->
    (decidable (f_phi_neq_zero phi f)) -> phi (Tau f).
Proof.
intros f HdH Hd.
unfold Tau.
assert (H : exists! (w:E), phi w /\ forall (v:E),
      phi v -> f v = inner w v).
apply Riesz_Frechet_strong_phi; trivial.
destruct H as (w,H).
generalize H.
intros H'.
apply (iota_elim _ _) in H.
rewrite H.
apply H'.
Qed.

(** Calculations *)

Variable A : (clm E (topo_dual E)).
Hypothesis A_bil : unique (fun A : (clm E (topo_dual E)) =>
                                    forall (u v:E), a u v = (A u) v) A.
Hypothesis A_dec : forall (u0 : E), decidable (exists u : E, phi u /\ A u0 u <> 0).
Hypothesis A_dec2 : forall (u0 : E), decidable (exists u : E, A u0 u <> 0).

Lemma comp_lm_aux_phi : forall (C : R),
     (0 < alpha <= C) -> (forall (rho : R), 0 < rho < (2*alpha)/(C*C)
     -> 0 <= ((1 - (2*rho*alpha)) + rho*rho*C*C)).
Proof.
intros C Halpha rho Hrho.
assert (HR : (-(alpha*alpha)/(C*C)) + ((Rsqr ((rho*C) - (alpha/C))) + 1)
       =
        1 - 2 * rho * alpha + rho * rho * C * C).
rewrite Rsqr_minus.
assert (Hra :  2 * (rho * C) * (alpha / C) = 2*rho*alpha).
rewrite Rmult_assoc.
assert (Hra2 : (Rmult (Rmult rho C) (Rdiv alpha C))
               =
               (Rmult rho (Rmult C (Rdiv alpha C)))).
ring.
rewrite Hra2.
assert (Hra3 : Rdiv alpha C = Rmult alpha (Rinv C)).
field.
apply Rgt_not_eq.
apply Rlt_gt.
apply Rlt_le_trans with alpha.
apply Halpha.
apply Halpha.
rewrite Hra3.
assert (Hra4 : (C * (alpha * / C)) = alpha).
field.
apply Rgt_not_eq.
apply Rlt_gt.
apply Rlt_le_trans with alpha.
apply Halpha.
apply Halpha.
trivial.
rewrite Hra4.
rewrite Rmult_assoc.
reflexivity.
rewrite Hra.
ring_simplify.
assert (Hp : forall r r1 r2, r1 = r2 -> r1 + r = r2 + r).
intros r r1 r2 Heq.
rewrite Heq; reflexivity.
apply Hp.
rewrite Rsqr_mult.
assert (Hqd : (alpha * alpha) / (C * C)
       = (alpha / C)²).
rewrite Rsqr_div.
reflexivity.
apply Rgt_not_eq.
apply Rlt_gt.
apply Rlt_le_trans with alpha.
apply Halpha.
apply Halpha.
rewrite <- Hqd.
rewrite Rplus_comm.
rewrite <- Rplus_assoc.
assert (Aa : alpha * alpha / (C * C)
      + - (alpha * alpha) / (C * C) = 0).
field.
apply Rgt_not_eq.
apply Rlt_gt.
apply Rlt_le_trans with alpha.
apply Halpha.
apply Halpha.
rewrite Aa.
ring_simplify.
assert (Hpowr : Rsqr rho = pow rho (S (S O))).
unfold Rsqr.
ring_simplify.
reflexivity.
assert (Hpowc : Rsqr C = pow C (S (S O))).
unfold Rsqr.
ring_simplify.
reflexivity.
rewrite Hpowr.
rewrite Hpowc.
reflexivity.
rewrite <- HR.
rewrite <- Rplus_assoc.
rewrite Rplus_comm.
rewrite <- Rplus_assoc.
apply Rplus_le_le_0_compat.
assert (H2 : (alpha * alpha) / (C * C) <= 1).
apply Rmult_le_reg_r with (C*C).
apply Rlt_0_sqr.
trivial.
apply Rgt_not_eq.
apply Rlt_gt.
apply Rlt_le_trans with alpha.
apply Halpha.
apply Halpha.
field_simplify; trivial.
assert (Hd1 : forall x, x / 1 = x).
intros x.
field.
repeat (rewrite Hd1).
assert (Hpowc : Rsqr C = pow C (S (S O))).
unfold Rsqr.
ring_simplify.
reflexivity.
assert (Hpowa : Rsqr alpha = pow alpha (S (S O))).
unfold Rsqr.
ring_simplify.
reflexivity.
rewrite <- Hpowc. rewrite <- Hpowa.
apply Rsqr_le_abs_1.
unfold Rabs.
destruct (Rcase_abs alpha).
absurd (0 < alpha); trivial.
apply Rle_not_lt.
intuition.
trivial.
apply Halpha.
destruct (Rcase_abs C).
absurd (0 < C); trivial.
apply Rle_not_lt.
intuition.
trivial.
apply Rlt_le_trans with alpha.
apply Halpha.
apply Halpha.
apply Halpha.
apply Rgt_not_eq.
apply Rlt_gt.
apply Rlt_le_trans with alpha.
apply Halpha.
apply Halpha.
apply Rplus_le_reg_r with (alpha * alpha / (C * C)).
ring_simplify.
rewrite Ropp_div.
ring_simplify.
trivial.
apply Rle_0_sqr.
Qed.

Lemma comp_lax_milgram_phi : forall (C : R),
     (0 < alpha <= C) -> (forall (rho : R), 0 < rho < (2*alpha)/(C*C)
     -> 0 <= (sqrt ((1 - (2*rho*alpha)) + rho*rho*C*C)) < 1).
Proof.
intros C Halpha rho Hrho.
assert (Hc : C <> 0).
replace C with (0 + C).
apply tech_Rplus.
intuition.
apply Rlt_le_trans with alpha.
apply Halpha.
apply Halpha.
ring.
split.
apply sqrt_pos.
assert ((rho*rho*C*C < (2*rho*alpha))).
rewrite (Rmult_comm 2 rho).
rewrite (Rmult_assoc (Rmult rho rho) C).
assert (H : (Rmult (Rmult rho rho) (Rmult C C))
       = Rmult rho (Rmult rho (Rmult C C))).
ring.
rewrite H.
assert (H0 : rho * 2 * alpha = Rmult rho (Rmult 2 alpha)).
ring.
rewrite H0.
clear H.
clear H0.
apply Rmult_lt_compat_l.
intuition.
apply Rmult_lt_reg_r with (/(C*C)).
apply Rinv_0_lt_compat.
apply Rlt_0_sqr.
trivial.
field_simplify.
assert (H : rho / 1 = rho).
field.
assert (Hcarre : C ^ 2 = C * C).
field.
rewrite Hcarre.
clear Hcarre.
apply Hrho.
trivial. trivial.
assert (H' : 1 - 2 * rho * alpha + rho * rho * C * C < 1).
assert (H0 : (1 - (2*rho*alpha)) + rho * rho * C * C
           =
            Rplus 1 (Rplus (-2*rho*alpha) (rho*rho*C*C))).
ring_simplify.
assert (Hp : forall r r1 r2, r1 = r2 -> r1 + r = r2 + r).
intros r r1 r2 Heq.
rewrite Heq; reflexivity.
apply Hp.
ring_simplify.
reflexivity.
rewrite H0.
replace 1 with (Rplus 1 0) at 2.
apply Rplus_lt_compat_l.
apply Rplus_lt_reg_r with (2 * rho * alpha).
rewrite Rplus_comm.
rewrite <- Rplus_assoc.
ring_simplify.
ring_simplify in H.
trivial.
ring.
rewrite <- sqrt_1 at 2.
apply sqrt_lt_1_alt.
split.
assert (HR : (-(alpha*alpha)/(C*C)) + ((Rsqr ((rho*C) - (alpha/C))) + 1)
       =
        1 - 2 * rho * alpha + rho * rho * C * C).
rewrite Rsqr_minus.
assert (Hra :  2 * (rho * C) * (alpha / C) = 2*rho*alpha).
rewrite Rmult_assoc.
assert (Hra2 : (Rmult (Rmult rho C) (Rdiv alpha C))
               =
               (Rmult rho (Rmult C (Rdiv alpha C)))).
ring.
rewrite Hra2.
assert (Hra3 : Rdiv alpha C = Rmult alpha (Rinv C)).
field.
trivial.
rewrite Hra3.
assert (Hra4 : (C * (alpha * / C)) = alpha).
field.
trivial.
rewrite Hra4.
rewrite Rmult_assoc.
reflexivity.
rewrite Hra.
ring_simplify.
assert (Hp : forall r r1 r2, r1 = r2 -> r1 + r = r2 + r).
intros r r1 r2 Heq.
rewrite Heq; reflexivity.
apply Hp.
rewrite Rsqr_mult.
assert (Hqd : (alpha * alpha) / (C * C)
       = (alpha / C)²).
rewrite Rsqr_div.
reflexivity.
trivial.
rewrite <- Hqd.
rewrite Rplus_comm.
rewrite <- Rplus_assoc.
assert (Aa : alpha * alpha / (C * C)
      + - (alpha * alpha) / (C * C) = 0).
field.
trivial.
rewrite Aa.
ring_simplify.
assert (Hpowr : Rsqr rho = pow rho (S (S O))).
unfold Rsqr.
ring_simplify.
reflexivity.
assert (Hpowc : Rsqr C = pow C (S (S O))).
unfold Rsqr.
ring_simplify.
reflexivity.
rewrite Hpowr.
rewrite Hpowc.
reflexivity.
apply comp_lm_aux_phi.
trivial.
trivial.
trivial.
Qed.

Theorem Lax_Milgram_115
   (f:topo_dual E):
  forall u : E, alpha*(Rsqr (norm u)) <= ((a u) u).
Proof.
intros u.
unfold is_coercive in Hca.
unfold Rsqr.
rewrite <- Rmult_assoc.
apply (proj2 Hca).
Qed.

Theorem Lax_Milgram_116_phi :
               forall u : E, operator_norm_phi phi (A u) <= M*(norm u).
Proof.
intros u.
unfold operator_norm_phi.
destruct (Is_only_zero_set_dec_phi E).
unfold Lub_Rbar.
destruct (ex_lub_Rbar
 (fun x : R => exists u0 : Hilbert_NormedModule E,
     u0 <> zero /\ phi u0 /\ x = (norm (A u u0) / norm u0))).
simpl.
unfold is_lub_Rbar in i.
unfold is_ub_Rbar in i.
destruct i.
assert (HM : exists M', M' = M*norm u).
exists (M*norm u).
reflexivity.
destruct HM as (N,HN).
rewrite <- HN.
assert (H' : Rbar_le x N).
apply H0.
intros x0 HH.
simpl.
destruct HH as (u0,(Hu01,(Hu00,Hu02))).
rewrite Hu02.
rewrite HN.
apply Rmult_le_reg_r with (norm u0).
apply norm_gt_0; trivial.
replace (norm ((A u) u0)
        / norm u0 * norm u0) with
        (norm ((A u) u0)).
destruct Hba as (Hba1,(Hba2,Hba3)).
replace ((A u) u0) with (a u u0).
apply Hba3.
apply A_bil.
field.
assert (Hg : 0 < norm u0).
apply norm_gt_0; trivial.
apply Rgt_not_eq.
apply Rlt_gt; trivial.
unfold Rbar_le in H'.
destruct x.
trivial.
simpl.
rewrite HN.
replace 0 with (0*0) by ring.
apply Rmult_le_compat; trivial.
apply Rle_refl.
apply Rle_refl.
apply (proj1 (proj2 Hba)).
apply norm_ge_0.
simpl.
replace 0 with (0*0) by ring.
rewrite HN.
apply Rmult_le_compat; trivial.
apply Rle_refl.
apply Rle_refl.
apply (proj1 (proj2 Hba)).
apply norm_ge_0.
simpl.
replace 0 with (0*0) by ring.
apply Rmult_le_compat; trivial.
apply Rle_refl.
apply Rle_refl.
apply (proj1 (proj2 Hba)).
apply norm_ge_0.
Qed.

Theorem Lax_Milgram_117_phi (f:topo_dual E) : (forall g : topo_dual E, decidable (f_phi_neq_zero phi g)) ->
  (forall (f:topo_dual E), forall u, forall eps:posreal, decidable (exists w:E, ((ker f w /\ phi w)
                                                          /\ norm (minus u w) < eps))) ->
  forall u : E, phi u -> - (inner (Tau (A u)) u) <= - (alpha*(Rsqr (norm u))).
Proof.
intros HdD HD u Hu.
apply Ropp_le_contravar.
apply Rle_trans with (a u u).
apply Lax_Milgram_115.
apply f.
assert (H : (A u) u = inner (Tau (A u)) u).
unfold Tau.
assert (H0 : exists! (u0:E), phi u0 /\ forall (v:E),
             phi v -> ((A u) v = inner u0 v)).
apply Riesz_Frechet_strong_phi; trivial.
destruct H0 as (w,H0).
assert (H0' : iota (fun u0 : E => phi u0 /\ forall v : E, phi v ->
       ((A u) v = inner u0 v)) = w).
apply iota_elim.
trivial.
rewrite H0'.
apply H0.
trivial.
rewrite <- H.
assert (Hr : a u u = (A u) u).
apply A_bil.
rewrite Hr.
apply Rle_refl.
Qed.

Theorem Lax_Milgram_118_phi (f:topo_dual E) :
             (forall (f:topo_dual E), forall u, forall eps:posreal,
                     decidable (exists w:E, ((ker f w /\ phi w)
                                                          /\ norm (minus u w) < eps))) ->
             (forall f: topo_dual E, decidable (f_phi_neq_zero phi f)) ->
             forall u : E, norm (Tau (A u)) <= M*(norm u).
Proof.
intros HH HD u.
apply Rle_trans with (operator_norm_phi phi (A u)).
unfold Tau.
rewrite (Riesz_Frechet_moreover1_phi phi).
apply Rle_refl.
trivial.
trivial.
try assumption.
trivial.
trivial.
apply Lax_Milgram_116_phi; trivial.
Qed.

(** Implication (2) -> (1) *)

Theorem Lax_Milgram'_aux1_phi (f:topo_dual  E)  :
     (forall f : topo_dual E, decidable (f_phi_neq_zero phi f))
  -> (forall g : topo_dual E, forall u, forall eps:posreal, decidable (exists w:E, ((ker g w /\ phi w)
                                                          /\ norm (minus u w) < eps)))
  -> ((exists! u:E, phi u /\ Tau ((A u)) = Tau f)
  -> (exists! u:E, (is_sol_linear_pb_phi f u))).
Proof.
intros Hd Hdec H.
destruct H as (u,H).
exists u.
assert (HA : forall v, (A u) v = a u v).
intros v.
symmetry.
apply A_bil.
unfold unique.
split.
unfold is_sol_linear_pb_phi.
split.
apply H.
intros v phi_V.
assert (H1 : exists! (w:E), phi w /\ forall (v:E),
      phi v -> f v = inner w v).
apply Riesz_Frechet_strong_phi; try assumption.
intro xx.
trivial.
trivial.
destruct H1 as (uf,Huf).
assert (Huf' : iota (fun w : E => phi w /\ forall v0 : E, phi v0 ->
                                  f v0 = inner w v0) = uf).
apply iota_elim.
trivial.
unfold Tau in H.
rewrite Huf' in H.
assert (H2 : exists! (w:E), phi w /\ forall (v:E),
      phi v -> (A u) v = inner w v).
apply Riesz_Frechet_strong_phi; trivial.
trivial.
destruct H2 as (uA,HuA).
assert (HuA' : iota (fun w : E => phi w /\ forall v0 : E, phi v0 ->
                                           (A u) v0 = inner w v0) = uA).
apply iota_elim.
trivial.
assert (Haf : uA = uf).
rewrite <- HuA'.
destruct H as (H,Hun).
rewrite <- (proj2 H).
trivial.
assert (HH1 : a u v = inner uA v).
rewrite <- HA.
apply HuA.
trivial.
assert (HH2 : f v = inner uA v).
rewrite Haf.
apply Huf.
trivial.
rewrite HH1 HH2.
reflexivity.
intros x' Hx'.
destruct H as (H,Hun).
apply Hun.
unfold is_sol_linear_pb_phi in Hx'.
unfold Tau.
assert (H1 : exists! (w:E), phi w /\ forall (v:E),
      phi v -> ((A u) v = inner w v)).
apply Riesz_Frechet_strong_phi; trivial.
split.
exact (proj1 Hx').
assert (H2 : exists! (w:E), phi w /\ forall (v:E),
      phi v -> f v = inner w v).
apply Riesz_Frechet_strong_phi; trivial.
destruct H1 as (wa,H1).
destruct H2 as (wf,H2).
assert (H1' : iota (fun u0 : E => phi u0 /\
       forall v : E, phi v -> ((A u) v = inner u0 v)) = wa).
apply iota_elim.
trivial.
assert (H2' : iota (fun u0 : E => phi u0 /\
       forall v : E, phi v -> f v = inner u0 v) = wf).
apply iota_elim.
trivial.
rewrite H2'.
assert (forall v: E, phi v -> f v = inner wf v).
intros v'.
apply H2.
assert (forall v: E, phi v -> a x' v = inner wf v).
intros v' Hv'.
rewrite (proj2 Hx').
apply H0.
trivial.
trivial.
assert ((iota (fun u0 : E => phi u0 /\ forall v : E, phi v ->
   ((A x') v = inner u0 v))) = wf).
apply iota_elim.
assert (H5 : exists! (w:E), phi w /\ forall (v:E),
             phi v -> ((A x') v = inner w v)).
apply Riesz_Frechet_strong_phi; trivial.
unfold unique; split.
split.
rewrite <- H2'.
assert (Hphi: exists! (w:E), phi w /\ forall (v:E),
      phi v -> f v = inner w v).
apply Riesz_Frechet_strong_phi; trivial.
destruct Hphi as (w,Hphi).
generalize Hphi.
intros Hphi'.
apply (iota_elim _ _) in Hphi.
rewrite Hphi.
apply Hphi'.
intros v Hv.
transitivity (a x' v).
symmetry.
apply A_bil.
apply H3.
trivial.
intros x'0 Hh.
destruct H5 as (y,H5).
destruct H5 as (H51,H52).
assert (y = x'0).
apply H52.
trivial.
assert (y = wf).
apply H52.
split.
rewrite <- H2'.
assert (Hphi: exists! (w:E), phi w /\ forall (v:E),
      phi v -> f v = inner w v).
apply Riesz_Frechet_strong_phi; trivial.
destruct Hphi as (w,Hphi).
generalize Hphi.
intros Hphi'.
apply (iota_elim _ _) in Hphi.
rewrite Hphi.
apply Hphi'.
intros v Hv.
transitivity (a x' v).
symmetry.
apply A_bil.
apply H3.
trivial.
rewrite <- H5, H4.
reflexivity.
trivial.
Qed.

(** Implication (3) -> (2) *)

Definition g_map_app (r : R) (f : topo_dual E) :=
      (fun u:E =>  plus (minus u (scal r (Tau (A u)))) (scal r (Tau f))).

Theorem Lax_Milgram'_aux2_phi (r : R) (f:topo_dual  E) :
     0 < r < ((2*alpha)/(M*M))
  -> (forall (f : topo_dual E), decidable (f_phi_neq_zero phi f))
  -> (forall (g : topo_dual E), forall u, forall eps:posreal, decidable (exists w:E, ((ker g w /\ phi w)
                                                          /\ norm (minus u w) < eps)))
  -> (exists! u:E, phi u /\ (g_map_app r f u = u))
  -> (exists! u:E, (is_sol_linear_pb_phi f u)).
Proof.
intros Hr Hd Hd0 H.
destruct H as (u,H).
apply Lax_Milgram'_aux1_phi; trivial.
exists u.
unfold g_map_app in H.
unfold minus in H.
destruct H as (H,H2).
rewrite <- plus_assoc in H.
destruct H as (Pu,H).
symmetry in H.
assert (Hu0 : plus u zero = u).
rewrite plus_zero_r. reflexivity.
rewrite <- Hu0 in H at 1.
apply plus_reg_l in H.
clear Hu0.
symmetry in H.
assert (H0 : minus (scal r (Tau f))
              (scal r (Tau (A u))) = zero).
unfold minus.
rewrite plus_comm.
trivial.
assert (Hm : minus (scal r (Tau f))
        (scal r (Tau (A u))) =
       scal r (minus (Tau f) (Tau (A  u)))).
rewrite scal_minus_distr_l.
reflexivity.
rewrite Hm in H0.
assert (minus (Tau f) (Tau (A u)) = zero).
destruct (is_zero_dec
          (minus (Tau f) (Tau (A u)))).
trivial.
absurd (norm
       (scal r (minus (Tau f)
        (Tau (A u))))= 0).
apply Rgt_not_eq.
apply Rlt_gt.
rewrite norm_scal_R.
apply Rmult_lt_0_compat.
unfold abs.
simpl.
unfold Rabs.
destruct (Rcase_abs r).
absurd (0 < r).
apply Rle_not_lt.
intuition.
apply Hr.
apply Hr.
apply norm_gt_0.
trivial.
rewrite H0.
rewrite norm_zero.
reflexivity.
split.
unfold minus in H1.
split; try assumption.
apply plus_reg_r with (opp (Tau (A u))).
rewrite plus_opp_r.
symmetry.
trivial.
intros x' Hbil.
apply H2.
split.
exact (proj1 Hbil).
rewrite (proj2 Hbil).
rewrite <- plus_assoc.
rewrite plus_opp_l.
rewrite plus_zero_r.
reflexivity.
Qed.

(** Contraction and Fixpoint *)

Lemma g_map_diff_phi (r : R) (f:topo_dual  E) :
       (forall (f0 : topo_dual E), decidable (f_phi_neq_zero phi f0))
     ->  (forall (f : topo_dual E), forall u, forall eps:posreal, decidable (exists w:E, ((ker f w /\ phi w)
                                                          /\ norm (minus u w) < eps)))
    -> 0 < r < ((2*alpha)/(M*M))
    -> forall (v v' : E), phi v -> phi v' ->
       Rsqr (norm (minus (g_map_app r f v) (g_map_app r f v')))
       <= (1 - 2 * r * alpha + r * r * M * M)
          * Rsqr (norm (minus v v')).
Proof.
intros Hd Hd0 Hr v v'.
assert (H :(norm (minus (g_map_app r f v)
                     (g_map_app r f v')))²
         = (plus (norm (minus v v'))² (-
   2 * r * inner (Tau (A (minus v v'))) (minus v v') +
   r * r * (norm (Tau (A (minus v v'))))²))).
assert (Haux : minus (g_map_app r f v)
                     (g_map_app r f v')
              = (minus (minus v v')
               (scal r (Tau (A (minus v v')))))).
unfold g_map_app.
unfold minus.
rewrite opp_plus.
rewrite opp_plus.
rewrite <- plus_assoc.
rewrite <- plus_assoc.
rewrite <- plus_assoc.
rewrite <- plus_assoc.
rewrite plus_comm.
rewrite (plus_comm (opp v') _).
assert (Hp1 : forall a b, plus (plus a b) v
              = plus a (plus b v)).
intros.
rewrite plus_assoc.
reflexivity.
rewrite Hp1.
rewrite Hp1.
rewrite Hp1.
rewrite (plus_assoc v (opp v') _).
assert (Hp2 : forall a b, plus a (plus b
          (plus (opp v') v)) =
          plus (plus a b) (plus (opp v') v)).
intros.
rewrite plus_assoc. reflexivity.
rewrite Hp2.
rewrite Hp2.
rewrite plus_comm.
rewrite (plus_comm (opp v') v).
assert (Hpaux : ((plus (opp (scal r (Tau (A v))))
     (plus (scal r (Tau f))
        (plus (opp (opp (scal r (Tau (A v')))))
           (opp (scal r (Tau f)))))))
   = (opp (scal r (Tau (A (plus v (opp v'))))))).
rewrite plus_assoc.
rewrite opp_opp.
rewrite (plus_comm _ (opp (scal r (Tau f)))).
assert (Hg : forall a b c d : E, plus (plus a b) (plus c d)
                           = plus (plus a d) (plus b c)).
intros.
rewrite plus_assoc.
rewrite plus_assoc.
rewrite plus_comm.
rewrite (plus_comm a0 d).
rewrite <- (plus_assoc d a0 b).
rewrite <- (plus_assoc d _ _).
reflexivity.
rewrite Hg.
rewrite plus_opp_r.
rewrite plus_zero_r.
replace (opp (scal r (Tau (A (plus v (opp v'))))))
        with
        (scal r (Tau (A (opp (plus v (opp v')))))).
replace ((opp (scal r (Tau (A v)))))
        with
        (scal r (Tau (A (opp v)))).
rewrite opp_plus.
rewrite opp_opp.
assert (ALf : is_linear_mapping A).
apply A.
destruct ALf as (Alf1,Alf2).
assert (H : is_linear_mapping Tau).
apply Riesz_Frechet_moreover2_phi; trivial.
destruct H as (Hl1,Hl2).
rewrite Alf1.
rewrite Hl1.
rewrite scal_distr_l.
reflexivity.
rewrite <- scal_opp_one.
rewrite scal_assoc.
assert (H : is_linear_mapping Tau).
apply Riesz_Frechet_moreover2_phi; trivial.
destruct H as (Hl1,Hl2).
rewrite <- Hl2.
rewrite <- Hl2.
assert (ALf : is_linear_mapping A).
apply A.
destruct ALf as (Alf1,Alf2).
rewrite <- Alf2.
rewrite <- Alf2.
assert (Hsr : (scal r (opp v))
        = (scal (mult (opp one) r) v)).
rewrite <- scal_assoc.
rewrite scal_opp_one.
rewrite scal_opp_r.
reflexivity.
rewrite Hsr.
reflexivity.
rewrite <- scal_opp_r.
rewrite <- scal_opp_one.
replace ((scal (opp one) (Tau (A (plus v (opp v'))))))
        with
        ((Tau (scal (opp one) (A (plus v (opp v')))))).
assert (H : is_linear_mapping Tau).
apply Riesz_Frechet_moreover2_phi; trivial.
destruct H as (Hl1,Hl2).
replace (Tau (A (opp (plus v (opp v')))))
     with (Tau (scal (opp one) (A (plus v (opp v'))))).
reflexivity.
clear Hp1 Hp2 Hg.
assert (Hlb : forall l y, scal l (A y)
                      = A (scal l y)).
intros l y.
apply clm_eq_ext.
intro x.
replace ((A (scal l y)) x) with (a (scal l y) x).
replace ((scal l (A y) x)) with (scal l (a y x)).
destruct Hba as (Hba1,Hba2).
destruct Hba1 as (Hba11,(Hba12,(Hba13,Hba14))).
symmetry; apply Hba11.
replace (a y x) with ((A y) x).
reflexivity.
symmetry.
apply A_bil.
assert (HAa : (A (scal l y)) x = a (scal l y) x).
symmetry; apply A_bil.
rewrite HAa.
reflexivity.
symmetry.
rewrite Hlb.
rewrite scal_opp_one.
reflexivity.
assert (HL : is_linear_mapping Tau).
apply Riesz_Frechet_moreover2_phi; trivial.
destruct HL as (Hl1,Hl2).
rewrite Hl2.
reflexivity.
rewrite Hpaux.
reflexivity.
rewrite Haux.
transitivity ((Hnorm (minus (minus v v')
              (scal r (Tau (A (minus v v'))))))*
              (Hnorm (minus (minus v v')
              (scal r (Tau (A (minus v v'))))))).
unfold norm; simpl.
reflexivity.
rewrite squared_norm.
rewrite square_expansion_minus.
rewrite <- squared_norm.
replace (Hnorm (minus v v')
       * Hnorm (minus v v')) with
         ((norm (minus v v'))²).
replace ((norm (minus v v'))² -
   2 * inner (minus v v') (scal r (Tau (A (minus v v')))) +
       inner (scal r (Tau (A (minus v v'))))
     (scal r (Tau (A (minus v v')))))
  with
   (plus ((norm (minus v v'))²)
     (- 2 * inner (minus v v') (scal r (Tau (A (minus v v')))) +
       inner (scal r (Tau (A (minus v v'))))
     (scal r (Tau (A (minus v v')))))).
apply Rplus_eq_compat_l.
rewrite <- squared_norm.
replace (Hnorm (scal r (Tau (A (minus v v')))))
      with (r* (Hnorm (Tau (A (minus v v'))))).
replace (r * Hnorm (Tau (A (minus v v'))) *
        (r * Hnorm (Tau (A (minus v v')))))
       with (r * r * (norm (Tau (A (minus v v'))))²).
rewrite Rplus_comm.
rewrite (Rplus_comm (-2 * r * inner (Tau (A
                 (minus v v'))) (minus v v')) _ ).
apply Rplus_eq_compat_l.
rewrite inner_scal_r.
rewrite inner_sym.
ring.
ring_simplify.
replace (Hnorm (Tau (A (minus v v'))) ^ 2)
   with ((norm (Tau (A (minus v v'))))²).
reflexivity.
unfold Rsqr.
unfold pow.
ring_simplify.
reflexivity.
replace r with (Rabs r) at 1.
rewrite hilbert.norm_scal.
reflexivity.
unfold Rabs.
destruct (Rcase_abs r).
absurd (r < 0).
apply Rle_not_lt.
intuition.
trivial.
reflexivity.
rewrite Rplus_assoc.
apply Rplus_eq_compat_l.
ring.
reflexivity.
intros Hv Hv'.
rewrite H.
assert (H2 : (1 - 2 * r * alpha + r * r * M * M)
            * (norm (minus v v'))²
           = plus (Rsqr (norm (minus v v')))
             (- 2*r*alpha*(Rsqr (norm (minus v v')))
              + r*r*M*M*(Rsqr (norm (minus v v'))))).
rewrite Rmult_plus_distr_r.
rewrite Rplus_comm.
rewrite <- Rplus_assoc.
rewrite (Rplus_comm
        ((norm (minus v v'))²
         + -2 * r * alpha * (norm (minus v v'))²) _).
apply Rplus_eq_compat_l.
rewrite Rmult_plus_distr_r.
ring_simplify.
reflexivity.
rewrite H2.
apply Rplus_le_compat_l.
apply Rplus_le_compat.
replace (-2 * r * alpha * (norm (minus v v'))²)
    with ((-2*r)*(alpha *(norm (minus v v'))²)).
replace (-2 * r * inner
     (Tau (A (minus v v'))) (minus v v'))
    with
     ((2*r)*(- inner
     (Tau (A (minus v v'))) (minus v v')))
    by ring.
replace (-2 * r * (alpha * (norm (minus v v'))²))
    with
     ((2*r)*(-alpha * (norm (minus v v'))²))
    by ring.
apply Rmult_le_compat_l.
apply Rmult_le_pos.
intuition.
intuition.
replace (- alpha * (norm (minus v v'))²)
        with (- (alpha*(Rsqr (norm (minus v v'))))).
apply Lax_Milgram_117_phi; trivial.
unfold minus.
apply (proj1 phi_m); trivial.
ring.
replace (norm (inner (Tau (A (minus v v'))) (minus v v')))
    with (abs ((inner (Tau (A (minus v v'))) (minus v v')))).
ring.
reflexivity.
replace (r*r * (norm (Tau (A (minus v v'))))²)
        with
        ((r*r) * (norm (Tau (A (minus v v'))))²).
replace (r*r * M*M * (norm (minus v v'))²)
        with
        ((r*r) *(M*M * (norm (minus v v'))²)).
apply Rmult_le_compat_l.
apply Rle_0_sqr.
replace (M * M * (norm (minus v v'))²)
        with (Rsqr (M * (norm (minus v v')))).
apply sqrt_le_0.
apply Rle_0_sqr.
apply Rle_0_sqr.
repeat (rewrite sqrt_Rsqr).
apply Lax_Milgram_118_phi; trivial.
apply Rmult_le_pos.
apply Hba.
apply norm_ge_0.
apply norm_ge_0.
ring_simplify.
rewrite Rsqr_mult.
apply Rmult_eq_compat_r.
unfold pow.
replace (M*1) with M by ring.
reflexivity.
ring.
reflexivity.
Qed.

Theorem Lax_Milgram'_aux3_phi (r : R)(f:topo_dual  E) :
     (forall f0 : topo_dual E, decidable (f_phi_neq_zero phi f0))
  -> (forall f0 : topo_dual E, forall u, forall eps:posreal, decidable (exists w:E, ((ker f0 w /\ phi w)
                                                          /\ norm (minus u w) < eps)))
  -> (~ Is_only_zero_set_phi E (fun x:E => phi x))
  -> 0 < r < ((2*alpha)/(M*M))
  -> (exists! u:E, phi u /\ (g_map_app r f u = u)).
Proof.
intros Hd Hd0 HE Hr.
assert (HC : is_contraction_phi (g_map_app r f) phi).
unfold is_contraction_phi.
destruct (Req_dec ((1 - (2*r*alpha)) + r*r*M*M) 0).
assert (forall v v', phi v -> phi v' -> Rsqr (norm (minus (g_map_app r f v) (g_map_app r f v')))
         = 0).
assert (forall v v', phi v -> phi v' -> Rsqr (norm (minus (g_map_app r f v) (g_map_app r f v')))
         <= 0).
intros v v' Hv Hv'.
replace 0 with ((1 - 2 * r * alpha + r * r * M * M)
          * Rsqr (norm (minus v v'))).
apply g_map_diff_phi; trivial.
rewrite H.
ring.
intros v v' Hv Hv'.
destruct (Req_dec (norm (minus (g_map_app r f v)
         (g_map_app r f v')))² 0).
trivial.
destruct (Rlt_le_dec
     (norm (minus (g_map_app r f v)
     (g_map_app r f v')))² 0).
absurd ((norm (minus (g_map_app r f v)
           (g_map_app r f v')))² < 0).
apply Rle_not_gt.
apply Rle_0_sqr.
trivial.
apply Rle_le_eq.
split; trivial.
apply H0; trivial.
exists (1 / 2).
split.
apply Rmult_lt_reg_r with 2.
intuition.
field_simplify.
replace (1 / 1) with 1 by field.
replace (2/1) with 2 by field.
intuition.
unfold is_Lipschitz_phi.
split.
assert (Hstrong : 0 < 1/2).
apply Rdiv_lt_0_compat.
intuition.
intuition.
intuition.
intros x1 x2 r0 Hr0 Hp1 Hp2 Hx2.
unfold ball_x in Hx2.
simpl in Hx2.
unfold hilbert.ball in Hx2.
unfold ball_y.
simpl.
unfold hilbert.ball.
specialize (H0 x1 x2).
unfold norm in H0; simpl in H0.
apply Rsqr_0_uniq in H0.
rewrite H0.
apply Rmult_lt_0_compat.
apply Rdiv_lt_0_compat.
intuition.
intuition.
trivial.
trivial.
trivial.
exists ((sqrt ((1 - (2*r*alpha)) + r*r*M*M))).
split.
apply comp_lax_milgram_phi; trivial.
split.
apply (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
unfold is_Lipschitz_phi.
split.
apply comp_lax_milgram_phi; trivial.
split.
exact (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
intros x1 x2 r1 Hr0 Hp1 Hp2 Hx2.
unfold ball_x in Hx2.
simpl in Hx2.
unfold hilbert.ball in Hx2.
unfold ball_y.
simpl.
unfold hilbert.ball.
apply Rle_lt_trans with
    (sqrt (1 - 2 * r * alpha + r * r * M * M)
   * (Hnorm (minus x1 x2))).
assert (Hsq : Hnorm (minus (g_map_app r f x1)
       (g_map_app r f x2))
     = (sqrt (Rsqr (norm (minus (g_map_app r f x1)
          (g_map_app r f x2)))))).
rewrite sqrt_Rsqr.
unfold norm; simpl.
reflexivity.
apply norm_ge_0.
rewrite Hsq.
assert (Hsq2 : sqrt (1 - 2 * r * alpha + r * r * M * M)
               * Hnorm (minus x1 x2)
              =
               sqrt ((1 - 2 * r * alpha + r * r * M * M)
                     * Rsqr (Hnorm (minus x1 x2)))).
rewrite sqrt_mult_alt.
rewrite sqrt_Rsqr.
reflexivity.
assert (Hh : Hnorm (minus x1 x2) = norm (minus x1 x2)).
unfold norm; simpl; reflexivity.
rewrite Hh.
apply norm_ge_0.
apply comp_lm_aux_phi.
split.
exact (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
trivial.
rewrite Hsq2.
apply sqrt_le_1.
apply Rle_0_sqr.
apply Rmult_le_pos.
apply comp_lm_aux_phi.
split.
exact (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
trivial.
apply Rle_0_sqr.
apply g_map_diff_phi; trivial.
apply Rmult_lt_compat_l.
apply sqrt_lt_R0.
assert (0 <= 1 - 2 * r * alpha + r * r * M * M).
apply comp_lm_aux_phi.
split.
exact (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
trivial.
apply Rdichotomy in H.
destruct H.
absurd (0 <= 1 - 2 * r * alpha + r * r * M * M).
apply Rlt_not_le.
trivial.
trivial.
trivial.
trivial.
destruct (FixedPoint_C_phi (g_map_app r f) phi); trivial.
intros x Hx.
unfold g_map_app.
destruct phi_m as ((P1,P2),P3).
replace (scal r (Tau f)) with (opp (scal (opp r) (Tau f))).
apply P1.
unfold minus.
apply P1.
trivial.
apply P3.
apply phi_Tau.
trivial.
trivial.
trivial.
apply P3.
apply phi_Tau.
trivial. trivial.
trivial.
rewrite scal_opp_l.
rewrite opp_opp; reflexivity.
intros x y _ _.
exists (2*(norm (minus x y)) + 1).
split.
apply Rplus_le_le_0_compat.
apply Rmult_le_pos.
intuition.
apply norm_ge_0.
intuition.
unfold ball. simpl. unfold hilbert.ball.
unfold norm. simpl.
rewrite <- Rplus_0_r at 1.
apply Rplus_le_lt_compat.
assert (Hh : Hnorm (minus x y) = 1*Hnorm (minus x y)).
ring.
rewrite Hh.
apply Rmult_le_compat.
intuition.
destruct (norm_ge_0 (minus x y)).
unfold norm in H. simpl in H.
intuition.
rewrite H.
unfold norm; simpl.
intuition.
intuition.
ring_simplify.
intuition.
intuition.
destruct phi_m as ((_,HH),_).
apply HH.
exists x.
unfold unique.
split.
split.
exact (proj1 H).
apply eq_close.
apply (proj1 (proj2 H)).
intros y Hy.
apply eq_close.
apply close_sym.
apply (proj1 (proj2 (proj2 H))).
exact (proj1 Hy).
rewrite (proj2 Hy); apply close_refl.
Qed.

(** Weak versions of Lax-Milgram theorem *)

Theorem Lax_Milgram''_phi (f:topo_dual E):
  (forall f0 : topo_dual E, decidable (f_phi_neq_zero phi f0))
  -> (forall f0 : topo_dual E, forall u, forall eps:posreal,
                               decidable (exists w:E, ((ker f0 w /\ phi w)
                               /\ norm (minus u w) < eps)))
  -> exists u:E, is_sol_linear_pb_phi f u /\
          (forall u', is_sol_linear_pb_phi f u' -> u'=u).
Proof.
intros Hd Hd0.
destruct (Is_only_zero_set_dec_phi E phi).
assert (Haux : forall r, 0 < r < ((2*alpha)/(M*M))
             -> exists! u:E, (is_sol_linear_pb_phi f u)).
intros r Hr.
apply Lax_Milgram'_aux2_phi with r; trivial.
trivial.
apply Lax_Milgram'_aux3_phi; trivial.
specialize (Haux (alpha / (M * M))).
assert (Haux' : exists ! u : E, is_sol_linear_pb_phi f u).
apply Haux.
split.
apply Rdiv_lt_0_compat.
exact (proj1 Hca).
apply Rmult_lt_0_compat.
apply Rlt_le_trans with alpha.
exact (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
apply Rlt_le_trans with alpha.
exact (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
replace (alpha / (M * M)) with (1 * (alpha / (M * M))).
replace (2 * alpha / (M * M)) with (2* (alpha / (M * M))).
apply Rmult_lt_compat_r.
apply Rdiv_lt_0_compat.
exact (proj1 Hca).
apply Rmult_lt_0_compat.
apply Rlt_le_trans with alpha.
exact (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
apply Rlt_le_trans with alpha.
exact (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
intuition.
replace (alpha / (M * M)) with (alpha * (/ (M*M))).
replace (2* alpha / (M * M)) with (2* alpha * (/ (M*M))).
rewrite Rmult_assoc.
reflexivity.
field.
assert (HM : 0 < M).
apply Rlt_le_trans with alpha.
exact (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
apply Rgt_not_eq.
apply Rlt_gt.
trivial.
field.
assert (HM : 0 < M).
apply Rlt_le_trans with alpha.
exact (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
apply Rgt_not_eq.
apply Rlt_gt.
trivial.
field.
assert (HM : 0 < M).
apply Rlt_le_trans with alpha.
exact (proj1 Hca).
apply coercivity_le_continuity_phi with phi a; trivial.
apply Rgt_not_eq.
apply Rlt_gt.
trivial.
destruct Haux' as (u,Hu).
unfold unique in Hu.
exists u.
split.
exact (proj1 Hu).
intros u' Hu'.
symmetry.
apply (proj2 Hu).
trivial.
exists zero.
split.
unfold is_sol_linear_pb_phi.
split.
apply (compatible_m_zero phi).
trivial.
intros v Hv.
apply Is_only_zero_set_correct1_phi with E phi v in i.
rewrite i.
destruct Hba as ((Hba1,(Hba2,Hba3)),Hba4).
assert (a zero zero = a (scal zero zero) zero).
rewrite scal_zero_l.
reflexivity.
rewrite H.
replace (a (scal zero zero) zero)
        with (scal zero (a zero zero)).
rewrite scal_zero_l.
assert (is_linear_mapping f).
apply f.
destruct H0 as (H01,H02).
replace (f zero) with (f (scal zero zero)).
transitivity (scal zero (f zero)).
rewrite scal_zero_l.
reflexivity.
symmetry.
apply H02.
rewrite scal_zero_l.
reflexivity.
symmetry.
apply Hba1.
trivial.
intros u' Hu'.
apply Is_only_zero_set_correct1_phi with E phi u' in i.
rewrite i.
reflexivity.
exact (proj1 Hu').
Qed.

Theorem Lax_Milgram_Aux_phi (f:topo_dual E):
  (forall f0 : topo_dual E, decidable (f_phi_neq_zero phi f0))
  -> (forall f0 : topo_dual E, forall u, forall eps:posreal,
      decidable (exists w:E, ((ker f0 w /\ phi w)
      /\ norm (minus u w) < eps)))
  -> exists u:E, is_sol_linear_pb_phi f u /\
          (forall u', is_sol_linear_pb_phi f u' -> u'=u) /\
           norm u <= /alpha * norm f.
Proof.
intros Hd Hd0.
assert (H' : exists u : E,
             is_sol_linear_pb_phi f u /\
             (forall u' : E, is_sol_linear_pb_phi f u' -> u' = u)).
apply Lax_Milgram''_phi; trivial.
destruct H' as (u,(He,Hu)).
exists u.
split; trivial.
split; trivial.
destruct (is_zero_dec u).
+ rewrite H.
  rewrite norm_zero.
  destruct Hca as (Hca',_).
  apply Rmult_le_pos.
  assert (Hsp : 0 < / alpha).
  apply Rinv_0_lt_compat.
  trivial.
  intuition.
  apply norm_ge_0.
+ assert (alpha*(Rsqr (norm u)) <= norm f * norm u).
  apply Rle_trans with (norm (f u)).
  apply Rle_trans with (norm (a u u)).
  destruct Hca as (Hca1,Hca2).
  specialize (Hca2 u).
  unfold norm; simpl.
  unfold abs; simpl.
  unfold Rsqr.
  unfold norm in Hca2; simpl in Hca2.
  rewrite <- Rmult_assoc.
  apply Rle_trans with (a u u).
  exact Hca2.
  unfold Rabs.
  destruct (Rcase_abs (a u u)).
  apply Rle_trans with 0.
  intuition.
  apply Ropp_0_ge_le_contravar.
  apply Rle_ge.
  intuition.
  right; reflexivity.
  specialize ((proj2 He) u).
  intros Heu.
  specialize (Heu (proj1 He)).
  rewrite Heu.
  apply Rle_refl.
  apply operator_norm_estimation.
  apply Rmult_le_reg_l with (norm u).
  apply norm_gt_0; trivial.
  rewrite (Rmult_comm (norm u) (/ alpha * norm f)).
  apply Rmult_le_reg_l with alpha.
  apply Hca.
  assert (Ha : alpha * (/ alpha * norm f * norm u)
               = norm f * norm u).
  field.
  apply Rgt_not_eq.
  apply Rlt_gt.
  apply Hca.
  rewrite Ha.
  intuition.
Qed.

End LM_aux.

(** Lax-Milgram theorem *)

Section Lax_Milgram.

Context {E : Hilbert}.

Variable a : E -> E -> R.
Variable M : R.
Variable alpha : R.
Variable phi : E -> Prop.
Hypothesis phi_C : my_complete phi.
Hypothesis phi_m : compatible_m phi.
Hypothesis Hba : is_bounded_bilinear_mapping a M.
Hypothesis Hca : is_coercive a alpha.

Theorem Lax_Milgram_phi (f:topo_dual E):
  (forall f0 : topo_dual E, decidable (f_phi_neq_zero phi f0))
  -> (forall f0 : topo_dual E, forall u, forall eps:posreal,
      decidable (exists w:E, ((ker f0 w /\ phi w)
      /\ norm (minus u w) < eps)))
  -> exists u:E, is_sol_linear_pb_phi a phi f u /\
          (forall u', is_sol_linear_pb_phi a phi f u' -> u'=u) /\
           norm u <= /alpha * norm f.
Proof.
intros Hd Hd0.
assert (Hbil : exists! (A:(clm E (topo_dual E))),
             forall (u v:E), a u v = (A u) v).
apply is_bounded_bilinear_mapping_representation with M.
trivial.
destruct Hbil as (A0,Hbil).
apply Lax_Milgram_Aux_phi with M A0; try assumption.

Qed.

End Lax_Milgram.

Section LM_True.

Context{E : Hilbert}.
Variable a : E -> E -> R.
Variable M : R.
Variable alpha : R.
Hypothesis Hba : is_bounded_bilinear_mapping a M.
Hypothesis Hca : is_coercive a alpha.

Theorem Lax_Milgram_true (f:topo_dual E):
  (forall g: topo_dual E, decidable (exists u0, g u0 <> 0)) ->
  (forall f0 : topo_dual E, forall u, forall eps:posreal,
      decidable (exists w:E, ((ker f0 w)
      /\ norm (minus u w) < eps)))
  -> exists u:E, is_sol_linear_pb_phi a (fun _ => True) f u /\
          (forall u', is_sol_linear_pb_phi a (fun _ => True) f u' -> u'=u) /\
           norm u <= /alpha * norm f.
Proof.
intros Hd HD.
assert (Hdd : decidable (f_phi_neq_zero (fun _ => True) f)).
unfold f_phi_neq_zero.
destruct (Hd f).
left.
destruct H as (u,H).
exists u; now split.
right.
intros (u,J).
apply H.
exists u; intuition.
assert (Hmc : my_complete (fun x : E => True)).
easy.
assert (Hmm : compatible_m (fun x : E =>  True)).
split; try split; try easy.
now exists zero.
generalize (Lax_Milgram_phi a M alpha (fun x : E => True)
 Hmc Hmm Hba Hca) => LMP.
specialize (LMP f).
assert (Haa : (forall f0 : topo_dual E,
       decidable (f_phi_neq_zero (fun _ : E => True) f0))).
intros g.
destruct (Hd g).
destruct H as (v,H).
left.
exists v.
split; try easy.
right.
intro Hh.
apply H.
destruct Hh as (h,(_,Hhh)).
now exists h.
specialize (LMP Haa).
assert (HD' : (forall (f0 : topo_dual E) (u : E) (eps : posreal),
       decidable
         (exists w : E,
            (ker f0 w /\ True) /\ norm (minus u w) < eps))).
intros g u e.
destruct (HD g u e).
left.
destruct H as (w,H).
exists w.
split; try intuition.
right.
intro Hh.
apply H.
destruct Hh as (w,Hh).
exists w.
intuition.
specialize (LMP HD').
trivial.
Qed.

End LM_True.


Require Import
        Coq.omega.Omega
        Fiat.Common
        Fiat.Computation.Notations
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts.

Unset Implicit Arguments.
Section Word.
  Context {sz : nat}.

  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Fixpoint encode_word' (s : nat) (w : word s) (b' : B) : B :=
    match w with
    | WO => b'
    | WS b s' w' => enqueue_opt b (encode_word' s' w' b')
    end.

  Eval compute in (wordToNat (WS true (WS false (WS false (WS false (WO)))))).

  Definition encode_word (w : word sz) (ce : CacheFormat) : B * CacheFormat := (encode_word' sz w mempty, addE ce sz).

  Definition format_word (w : word sz) (ce : CacheFormat) : Comp (B * CacheFormat) :=
    ret (encode_word' sz w mempty, addE ce sz).

  Fixpoint SW_word {sz} (b : bool) (w : word sz) : word (S sz) :=
    match w with
    | WO => WS b WO
    | WS b' s' w'' => WS b' (SW_word b w'')
    end.

  Fixpoint word_split_hd {sz} (w : word (S sz))
    : bool :=
    match sz return word (S sz) -> bool with
    | 0 => @whd _
    | S n' => fun w => word_split_hd (wtl w)
    end w.

  Fixpoint word_split_tl {sz} (w : word (S sz))
    : word sz :=
    match sz return word (S sz) -> word sz with
    | 0 => fun _ => WO
    | S n' => fun w => WS (whd w) (word_split_tl (wtl w))
    end w.

  Lemma word_split_SW {n}
    : forall (w : word (S n)),
      w = SW_word (word_split_hd w) (word_split_tl w).
  Proof.
    induction n; simpl; intros.
    - shatter_word w; reflexivity.
    - destruct (shatter_word_S w) as (?, (?, ?)); subst; simpl.
      rewrite (IHn x0) at 1; reflexivity.
  Qed.

  Fixpoint decode_word' (s : nat) (b : B) {struct s} : option (word s * B) :=
    match s with
    | O => Some (WO, b)
    | S s' =>
      `(c, b') <- dequeue_opt b;
      `(w', b') <- decode_word' s' b';
      Some (SW_word c w', b')
    end.

  Definition decode_word (b : B) (cd : CacheDecode) : option (word sz * B * CacheDecode) :=
    Ifopt decode_word' sz b as decoded Then Some (decoded, addD cd sz) Else None.

  Lemma enqueue_opt_format_word :
    forall n w b b',
      enqueue_opt b (encode_word' n w b') =
      mappend (encode_word' n w b') (enqueue_opt b mempty).
  Proof.
    induction w; simpl; intros; eauto.
    - rewrite <- enqueue_mappend_opt, mempty_right; auto.
    - rewrite !IHw.
      rewrite <- mappend_assoc.
      rewrite <- !enqueue_mappend_opt, !mempty_right.
      rewrite IHw; reflexivity.
  Qed.

  Lemma dequeue_encode_word'_enqueue_opt' :
    forall n w w' b b' ext,
      dequeue_opt w' = Some (b, b')
      -> dequeue_opt (mappend (encode_word' n w w') ext) =
           Some (b, (mappend (encode_word' n w b') ext)).
  Proof.
    induction w; simpl; intros.
    - erewrite dequeue_mappend_opt; eauto using dequeue_head_opt.
    - eapply dequeue_mappend_opt.
      rewrite enqueue_opt_format_word.
      erewrite IHw; eauto.
      rewrite <- enqueue_opt_format_word; reflexivity.
  Qed.

  Corollary dequeue_encode_word'_enqueue_opt :
    forall n w b ext,
      dequeue_opt (mappend (encode_word' n w (enqueue_opt b mempty)) ext) =
      Some (b, (mappend (encode_word' n w mempty) ext)).
  Proof.
    intros; eapply dequeue_encode_word'_enqueue_opt'.
    eapply dequeue_head_opt.
  Qed.

  Lemma dequeue_opt_Some' :
    forall n w ext,
      dequeue_opt (mappend (encode_word' (S n) w mempty) ext)
      = Some (word_split_hd w, (mappend (encode_word' n (word_split_tl w) mempty) ext)).
  Proof.
    induction n; simpl; intros.
    - shatter_word w; simpl in *.
      erewrite dequeue_mappend_opt; eauto using dequeue_head_opt.
    - destruct (shatter_word_S w) as (?, (?, ?)); subst; simpl.
      simpl in *.
      rewrite enqueue_opt_format_word.
      rewrite <- mappend_assoc.
      rewrite IHn.
      rewrite enqueue_opt_format_word.
      rewrite <- mappend_assoc; auto.
  Qed.

  Lemma decode_encode_word'
    : forall {n} w ext,
      decode_word' n (mappend (encode_word' n w mempty) ext)
      = Some (w, ext).
  Proof.
    induction n; simpl; intros; try shatter_word w; simpl in *.
    - rewrite mempty_left; reflexivity.
    - destruct (shatter_word_S w) as (?, (?, ?)); subst; simpl.
      rewrite enqueue_opt_format_word.
      rewrite <- !mappend_assoc.
      destruct n.
      + shatter_word x0; simpl.
        rewrite mempty_left.
        erewrite dequeue_mappend_opt;
          eauto using dequeue_head_opt.
        simpl.
        rewrite mempty_left; auto.
      + rewrite dequeue_opt_Some'.
        unfold DecodeBindOpt, BindOpt at 1; unfold If_Opt_Then_Else.
        assert (decode_word' (S n)
                   (mappend (encode_word' n (word_split_tl x0) mempty)
                              (mappend (enqueue_opt x mempty) ext))
                = Some (WS x (word_split_tl x0), ext)).
        { simpl.
          pose proof (IHn (WS x (word_split_tl x0)) ext).
          simpl in H.
          rewrite enqueue_opt_format_word in H.
          rewrite <- mappend_assoc in H.
          rewrite H.
          eauto. }
        unfold BindOpt. rewrite H; simpl; rewrite <- (word_split_SW x0); auto.
  Qed.

  Lemma decode_encode_word'_Some
    : forall sz bin data ext,
      decode_word' sz bin = Some (data, ext)
      -> bin = mappend (encode_word' sz data mempty) ext.
  Proof.
    induction sz0; simpl; intros.
    - shatter_word data; simpl; injections.
      rewrite mempty_left; auto.
    - destruct (dequeue_opt bin) as [ [? ?] | ] eqn: ? ;
        simpl in *; try discriminate.
      destruct (decode_word' sz0 b0) as [ [? ?] | ] eqn: ? ;
        simpl in *; try discriminate.
      injections.
      apply IHsz0 in Heqo0; subst.
      eapply dequeue_opt_inj; eauto.
      simpl.
      rewrite <- dequeue_encode_word'_enqueue_opt.
      clear; revert ext; induction w; simpl; auto; intros.
      rewrite !enqueue_opt_format_word, <- !mappend_assoc.
      rewrite IHw; reflexivity.
  Qed.

  Theorem Word_decode_correct
          {P : CacheDecode -> Prop}
          (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b)))
    :
      CorrectDecoder monoid (fun _ => True)
                              (fun _ _ => True)
                              format_word decode_word P.
  Proof.
    unfold CorrectDecoder, format_word, decode_word; split.
    - intros env env' xenv w w' ext env_OK Eeq _ _ Penc.
      computes_to_inv; injections.
      generalize dependent sz.
      intros; rewrite decode_encode_word'; simpl.
      eexists; split; eauto using add_correct.
    - intros.
      destruct (decode_word' sz bin)
        as [ [? ?] | ] eqn: ?; simpl in *; try discriminate.
      injections.
      apply decode_encode_word'_Some in Heqo; subst.
      split; eauto using add_correct.
      eexists; eexists; repeat split.
      eauto using add_correct.
  Qed.

  Lemma decode_word'_le
    : forall (a : word sz) (b' b1 : B),
      decode_word' _ b1 = Some (a, b') -> le_B b' b1.
  Proof.
    intros; apply decode_encode_word'_Some in H; subst.
    unfold le_B.
    rewrite mappend_measure; omega.
  Qed.

  Lemma decode_word_le
    : forall (b1 : B) (cd : CacheDecode) (a : word sz)
             (b' : B) (cd' : CacheDecode),
      decode_word b1 cd = Some (a, b', cd') -> le_B b' b1.
  Proof.
    unfold decode_word.
    intros; destruct (decode_word' sz b1) as [ [? ?] | ] eqn: ? ;
      subst; simpl in *; try discriminate.
    injections.
    eapply decode_word'_le; eauto.
  Qed.

  Lemma decode_word'_lt
    : forall (a : word (S sz)) (b' b1 : B),
      decode_word' _ b1 = Some (a, b') -> lt_B b' b1.
  Proof.
    simpl; intros; injections; unfold lt_B.
    destruct (dequeue_opt b1) as [ [? ?] | ] eqn: ? ;
      subst; simpl in *; try discriminate.
    apply measure_dequeue_Some in Heqo; subst.
    destruct (decode_word' sz b0) as [ [? ?] | ] eqn: ? ;
        subst; simpl in *; try discriminate.
    eapply decode_word'_le in Heqo0; injections.
    rewrite Heqo.
    unfold le_B in *.
    pose proof (B_measure_gt_0 b).
    omega.
  Qed.

  Lemma decode_word_lt
    : forall (b' : B) (cd : CacheDecode) (a : word (S sz))
             (b1 : B) (cd' : CacheDecode),
      Ifopt decode_word' _ b' as decoded Then Some (decoded, addD cd (S sz)) Else None = Some (a, b1, cd') -> lt_B b1 b'.
  Proof.
    intros; destruct (decode_word' (S sz) b') as [ [? ?] | ] eqn: ? ;
    try eapply decode_word'_lt in Heqo;
      simpl in *; try (subst; discriminate).
    injections.
    unfold lt_B in *.
    omega.
  Qed.

  Definition format_unused_word' (sz : nat) b
             (_ : unit) (ctx : CacheFormat) :=
    (w <- { w : word sz | True};
       ret (encode_word' sz w b, addE ctx sz))%comp.

  Definition format_unused_word
             (sz : nat) :=
    format_unused_word' sz mempty tt.

  Fixpoint monoid_get_word {B}
           {monoid : Monoid B}
           {monoid_opt : QueueMonoidOpt monoid bool}
           (sz : nat)
           (b : B)
    : option (word sz) :=
    match sz with
    | 0 => Some WO
    | S sz' =>
      match dequeue_opt b with
      | Some (c, b') =>
        match monoid_get_word sz' b' with
        | Some w => Some (SW_word c w)
        | _ => None
        end
      | _ => None
      end
    end.

  Definition monoid_dequeue_word
         (sz : nat)
         (b : B)
  : option (word sz * B) := decode_word' sz b.

  Lemma monoid_dequeue_word_eq_decode_word' :
    forall (sz : nat)
           (b : B),
      monoid_dequeue_word sz b = decode_word' sz b.
  Proof.
    reflexivity.
  Qed.

  Lemma monoid_dequeue_encode_word'
        (sz' : nat)
    : forall (w : word sz') (ext : B),
      monoid_dequeue_word sz' (mappend (encode_word' _ w mempty ) ext) = Some (w, ext).
  Proof.
    intros; unfold monoid_dequeue_word.
    apply decode_encode_word'.
  Qed.

  Definition decode_unused_word' (s : nat) (b : B) : option (unit * B) :=
    Ifopt monoid_dequeue_word s b as b' Then Some (tt, snd b') Else None.

  Definition decode_unused_word (sz' : nat)
             (b : B) (cd : CacheDecode) : option (unit * B * CacheDecode) :=
    Ifopt decode_unused_word' sz' b as decoded Then Some (decoded, addD cd sz') Else None.

  Theorem unused_word_decode_correct sz'
          {P : CacheDecode -> Prop}
          (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b)))
    :
      CorrectDecoder monoid (fun _ => True)
                              (fun _ _ => True)
                              (format_unused_word' sz' mempty) (decode_unused_word sz') P.
  Proof.
    unfold CorrectDecoder, format_unused_word', decode_unused_word; split.
    - intros env env' xenv w w' ext env_OK Eeq _ _ Penc.
      computes_to_inv; injections.
      unfold decode_unused_word'.
      rewrite monoid_dequeue_encode_word'; simpl.
      destruct w.
      eexists; split; eauto using add_correct.
    - intros.
      destruct (decode_unused_word' sz' bin)
        as [ [? ?] | ] eqn: ?; simpl in *; try discriminate.
      injections.
      unfold decode_unused_word', monoid_dequeue_word in Heqo.
      simpl in Heqo.
      split; auto.
      destruct (decode_word' sz' bin)  as [ [? ?] | ] eqn: ? ; simpl in *;
        try discriminate.
      injections.
      apply decode_encode_word'_Some in Heqo0.
      eexists; eexists; repeat split.
      repeat computes_to_econstructor; eauto.
      apply Heqo0.
      apply add_correct; eauto.
  Qed.

End Word.

Arguments format_unused_word {_ _ _ _ _} sz ctx _.

Lemma monoid_get_encode_word' {B}
      {monoid : Monoid B}
      {monoid_opt : QueueMonoidOpt monoid bool}
      (sz : nat)
  : forall (w : word sz) (ext : B),
    monoid_get_word sz (mappend (encode_word' _ w mempty) ext) = Some w.
Proof.
  induction sz; simpl; intros; try shatter_word w; simpl in *.
    - reflexivity.
    - destruct (shatter_word_S w) as (?, (?, ?)); subst; simpl.
      rewrite enqueue_opt_format_word.
      rewrite <- !mappend_assoc.
      destruct sz.
      + shatter_word x0; simpl.
        rewrite mempty_left.
        erewrite dequeue_mappend_opt;
          eauto using dequeue_head_opt.
      + rewrite dequeue_opt_Some'.
          pose proof (IHsz (WS x (word_split_tl x0)) ext).
          simpl in *.
          rewrite enqueue_opt_format_word in H.
          rewrite <- mappend_assoc in H.
          destruct (dequeue_opt
          (mappend (encode_word' sz (word_split_tl x0) mempty)
                     (mappend (enqueue_opt x mempty) ext))) as [ [? ?] | ];
            simpl in *; try discriminate.
          destruct (monoid_get_word sz b0); try discriminate.
          injections.
          rewrite H0.
          simpl.
          rewrite <- (word_split_SW x0); auto.
  Qed.


Require Export Iron.Language.SystemF2Cap.Value.Relation.TyJudge.

(* A well typed expression is well formed *)
Lemma typex_wfX
 :  forall ke te se sp x t e
 ,  TypeX  ke te se sp x t e
 -> wfX (length ke) (length te) (length se) x.
Proof.
 intros. gen ke te se sp t e.
 induction x using exp_mutind with
  (PV := fun v => forall ke te se sp t1
      ,  TypeV ke te se sp v t1
      -> wfV (length ke) (length te) (length se) v);
   rip; inverts_type; try burn.

 Case "VLam".
  spec IHx H8. burn.

 Case "VLAM".
  eapply WfV_VLAM.
  spec IHx H7. simpl in IHx.
  rewrite <- length_liftTE in IHx.
  rewrite <- length_liftTE in IHx.
  auto.

 Case "XLet".
  spec IHx1 H10.
  spec IHx2 H11.
  burn.

 Case "XNew".
  eapply WfX_XNew.
  spec IHx H7.
  rrwrite (length (ke :> KRegion) = S (length ke)) in IHx.
  rewrite <- length_liftTE in IHx.
  rewrite <- length_liftTE in IHx.
  burn.
Qed.
Hint Resolve typex_wfX.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_ABCequalsCBA.
Require Import ProofCheckingEuclid.lemma_NCorder.
Require Import ProofCheckingEuclid.lemma_angledistinct.
Require Import ProofCheckingEuclid.lemma_angleorderrespectscongruence_smaller.
Require Import ProofCheckingEuclid.lemma_angletrichotomy.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_collinearorder.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_equalangleshelper.
Require Import ProofCheckingEuclid.lemma_equalanglesreflexive.
Require Import ProofCheckingEuclid.lemma_equalanglessymmetric.
Require Import ProofCheckingEuclid.lemma_equalanglestransitive.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_s_lta.
Require Import ProofCheckingEuclid.lemma_s_ncol_ABD_col_ABC_ncol_ACD.
Require Import ProofCheckingEuclid.lemma_s_ncol_n_col.
Require Import ProofCheckingEuclid.lemma_s_onray_assert_ABB.
Require Import ProofCheckingEuclid.lemma_s_onray_assert_bets_AEB.
Require Import ProofCheckingEuclid.proposition_03.
Require Import ProofCheckingEuclid.proposition_04.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_06a :
	forall A B C,
	Triangle A B C ->
	CongA A B C A C B ->
	~ Lt A C A B.
Proof.
	intros A B C.
	intros Triangle_ABC.
	intros CongA_ABC_ACB.

	assert (nCol A B C) as nCol_A_B_C by (unfold Triangle in Triangle_ABC; exact Triangle_ABC).
	pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_B_C) as n_Col_A_B_C.
	pose proof (lemma_NCorder _ _ _ nCol_A_B_C) as (nCol_B_A_C & _ & _ & nCol_A_C_B & nCol_C_B_A).
	pose proof (lemma_equalanglesreflexive _ _ _ nCol_A_B_C) as CongA_ABC_ABC.
	pose proof (lemma_ABCequalsCBA _ _ _ nCol_A_C_B) as CongA_ACB_BCA.
	pose proof (lemma_ABCequalsCBA _ _ _ nCol_C_B_A) as CongA_CBA_ABC.

	pose proof (lemma_angledistinct _ _ _ _ _ _ CongA_ABC_ACB) as (neq_A_B & neq_B_C & neq_A_C & _ & neq_C_B & _).

	pose proof (lemma_inequalitysymmetric _ _ neq_A_B) as neq_B_A.
	pose proof (lemma_inequalitysymmetric _ _ neq_A_C) as neq_C_A.

	pose proof (lemma_s_onray_assert_ABB _ _ neq_B_C) as OnRay_BC_C.
	pose proof (lemma_s_onray_assert_ABB _ _ neq_C_A) as OnRay_CA_A.
	pose proof (lemma_s_onray_assert_ABB _ _ neq_C_B) as OnRay_CB_B.

	pose proof (cn_congruencereflexive B C) as Cong_BC_BC.
	pose proof (cn_congruencereverse B A) as Cong_BA_AB.
	pose proof (cn_congruencereverse B C) as Cong_BC_CB.

	assert (~ Lt A C A B) as n_Lt_AC_AB.
	{
		intros Lt_AC_AB.

		pose proof (proposition_03 _ _ _ _ _ _ Lt_AC_AB Cong_BA_AB) as (D & BetS_B_D_A & Cong_BD_AC).

		pose proof (lemma_betweennotequal _ _ _ BetS_B_D_A) as (_ & neq_B_D & _).

		assert (Col B D A) as Col_B_D_A by (unfold Col; one_of_disjunct BetS_B_D_A).
		pose proof (lemma_collinearorder _ _ _ Col_B_D_A) as (_ & _ & _ & Col_B_A_D & _).

		pose proof (lemma_s_onray_assert_bets_AEB _ _ _ BetS_B_D_A neq_B_A) as OnRay_BA_D.
		pose proof (lemma_equalangleshelper _ _ _ _ _ _ _ _ CongA_ABC_ABC OnRay_BA_D OnRay_BC_C) as CongA_ABC_DBC.
		pose proof (lemma_equalanglessymmetric _ _ _ _ _ _ CongA_ABC_DBC) as CongA_DBC_ABC.
		pose proof (lemma_equalanglestransitive _ _ _ _ _ _ _ _ _ CongA_DBC_ABC CongA_ABC_ACB) as CongA_DBC_ACB.

		pose proof (lemma_congruenceflip _ _ _ _ Cong_BD_AC) as (_ & _ & Cong_BD_CA).

		pose proof (lemma_s_ncol_ABD_col_ABC_ncol_ACD _ _ _ _ nCol_B_A_C Col_B_A_D neq_B_D) as nCol_B_D_C.
		pose proof (lemma_NCorder _ _ _ nCol_B_D_C) as (_ & _ & _ & nCol_B_C_D & _).
		pose proof (lemma_equalanglesreflexive _ _ _ nCol_B_C_D) as CongA_BCD_BCD.

		pose proof (proposition_04 _ _ _ _ _ _ Cong_BD_CA Cong_BC_CB CongA_DBC_ACB) as (_ & _ & CongA_BCD_CBA).
		pose proof (lemma_equalanglestransitive _ _ _ _ _ _ _ _ _ CongA_BCD_CBA CongA_CBA_ABC) as CongA_BCD_ABC.
		pose proof (lemma_equalanglestransitive _ _ _ _ _ _ _ _ _ CongA_BCD_ABC CongA_ABC_ACB) as CongA_BCD_ACB.
		pose proof (lemma_equalanglestransitive _ _ _ _ _ _ _ _ _ CongA_BCD_ACB CongA_ACB_BCA) as CongA_BCD_BCA.
		pose proof (lemma_equalanglessymmetric _ _ _ _ _ _ CongA_BCD_BCA) as CongA_BCA_BCD.

		pose proof (lemma_s_lta _ _ _ _ _ _ _ _ _ BetS_B_D_A OnRay_CB_B OnRay_CA_A CongA_BCD_BCD) as LtA_BCD_BCA.
		pose proof (lemma_angleorderrespectscongruence_smaller _ _ _ _ _ _ _ _ _ LtA_BCD_BCA CongA_BCA_BCD) as LtA_BCA_BCA.
		pose proof (lemma_angletrichotomy _ _ _ _ _ _ LtA_BCA_BCA) as n_LtA_BCA_BCA.

		contradict LtA_BCA_BCA.
		exact n_LtA_BCA_BCA.
	}

	exact n_Lt_AC_AB.

Qed.

End Euclid.


From mathcomp Require Import ssreflect ssrnat eqtype ssrbool ssrfun seq.
From mathcomp Require Import finmap choice finfun fintype.
From deriving Require Import deriving.
From coqspec Require Import utilities.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Open Scope fmap_scope.
Open Scope fset_scope.
Definition Atom  := nat.
Definition Var  := nat.
Definition FName := nat.

Inductive Val := ATOM of Atom.
Notation "''' e" := (ATOM e) (at level 0).

Notation "'ERROR'" := ('0) (only parsing).

Definition val_indDef := [indDef for Val_rect].
Canonical val_indType := IndType Val val_indDef.

Definition val_eqMixin := [derive eqMixin for Val].
Canonical val_eqType := EqType Val val_eqMixin.
Definition val_choiceMixin := [derive choiceMixin for Val].
Canonical val_choiceType := Eval hnf in ChoiceType Val val_choiceMixin.

Inductive Arg :=
  | Arg_Val of Val
  | Arg_Var of Var.
Coercion Arg_Val : Val >-> Arg.
Coercion Arg_Var : Var >-> Arg.

Definition arg_indDef := [indDef for Arg_rect].
Canonical arg_indType := IndType Arg arg_indDef.

Definition eq_arg a b :=
  match a, b with
  | Arg_Val 'a, Arg_Val 'b => a == b
  | Arg_Var x, Arg_Var y => x == y
  | _, _ => false
  end.

Lemma eqargP : Equality.axiom eq_arg.
Proof.
by case=> [[]?[[]|]|?[]]?/=; try (by constructor); apply/(iffP eqP)=> [|[]]->.
Qed.

Canonical arg_eqMixin := EqMixin eqargP.
Canonical arg_eqType := Eval hnf in EqType Arg arg_eqMixin.

Definition arg_choiceMixin := [derive choiceMixin for Arg].
Canonical arg_choiceType := Eval hnf in ChoiceType Arg arg_choiceMixin.

Inductive Exp :=
  | Exp_Arg of Arg
  | CONS of Exp & Exp.
Coercion Exp_Arg : Arg >-> Exp.

Fixpoint eq_exp a b :=
  match a, b with
  | Exp_Arg a,  Exp_Arg b  => a == b
  | CONS e1 e2, CONS e3 e4 => eq_exp e1 e3 && eq_exp e2 e4
  | _,          _          => false
  end.

Lemma eqexpP : Equality.axiom eq_exp.
Proof.
elim=> [?[]*|? IHe1 ? IHe2[]]/= *; first by apply/(iffP eqP)=> [|[]]//->.
1,2: by constructor.
by apply/(iffP andP)=> [][]/IHe1->/IHe2->.
Qed.

Canonical exp_eqMixin := EqMixin eqexpP.
Canonical exp_eqType := Eval hnf in EqType Exp exp_eqMixin.

Definition exp_indDef := [indDef for Exp_rect].
Canonical exp_indType := IndType Exp exp_indDef.

Definition exp_choiceMixin := [derive choiceMixin for Exp].
Canonical exp_choiceType := Eval hnf in ChoiceType Exp exp_choiceMixin.

Definition Env := {fsfun Var -> Exp for id}.

Fixpoint subst (e : Exp) (env : Env) : Exp :=
  match e with
  | CONS e1 e2 => CONS (subst e1 env) (subst e2 env)
  | 'a         => 'a
  | (Exp_Arg (Arg_Var v))      =>  env v
  end.

Notation "e '/s/' env" := (subst e env) (at level 1, left associativity).

Arguments subst : simpl nomatch.

Definition comp (e1 e2 : Env) : Env :=
  [fsfun x in (finsupp e1 `|` finsupp e2) => (e1 x) /s/ e2].

Definition emsub : Env := [fsfun for (id : Var -> Exp)].

Definition mkEnv (ks : seq Var) (vs : seq Exp) : Env :=
  foldr (fun '(v, x) a => [fsfun a with v |-> x]) emsub (zip ks vs).

Fixpoint FVExp (e : Exp) : {fset Var} :=
  match e with
  | CONS e1 e2 => FVExp e1 `|` FVExp e2
  | (Exp_Arg (Arg_Var v))      => [fset v]
  | _          => fset0
  end.

Definition closed e := FVExp e == fset0.

Definition FVArg (a : Arg) :=
  if a is (Arg_Var x) then [fset x] else fset0.

Definition closed_sub (e : Env) :=
  forall x, x \in finsupp e -> closed (e x).

Inductive Restr :=
  | Neq of Arg & Arg
  | NCONS of Arg.

Definition restr_indDef := [indDef for Restr_rect].
Canonical restr_indType := IndType Restr restr_indDef.

Definition restr_eqMixin := [derive eqMixin for Restr].
Canonical restr_eqType := Eval hnf in EqType Restr restr_eqMixin.

Definition restr_choiceMixin := [derive choiceMixin for Restr].
Canonical restr_choiceType := Eval hnf in ChoiceType Restr restr_choiceMixin.

Notation "e1 '≠' e2" := (Neq e1 e2) (at level 10).

Definition Cenv := (Env * seq Restr)%type.

Definition FVRestr (r : Restr) : {fset Var} :=
  match r with
  | NCONS v => FVArg v
  | r1 ≠ r2 => FVArg r1 `|` FVArg r2
  end.

Inductive Bind :=
  | isEQ of Arg & Arg
  | isCONS of Arg.

Definition contr  (b : Bind) (r : Restr) :=
  match r, b with
  | v ≠ u, isEQ v' u' => ((v, u) == (v', u')) || ((u, v) == (v', u'))
  | NCONS v, isCONS u => v == u
  | _, _              => false
  end.

Definition is_arg (e : Exp) :=
  if e is Exp_Arg _ then true else false.

Definition is_cons (e : Exp) :=
  if e is CONS _ _ then true else false.

Definition ncontr_neq env r1 r2 :=
    is_arg (r1 /s/ env) ->
    is_arg (r2 /s/ env) ->
    r1 /s/ env <> r2 /s/ env.

Definition ncontr_ncons env r :=
  ~~ is_cons (r /s/ env).

Definition ncontr_env (env : Env) (rs : seq Restr) :=
  (forall r1 r2, r1 ≠ r2 \in rs -> ncontr_neq env r1 r2) /\
  (forall r, NCONS r \in rs -> ncontr_ncons env r).

Definition contradict r b : bool :=
  has (contr b) r .

Definition delete_restr (v : Var) :=
  filter (fun r => match r with
                   | (r1 ≠ r2) => (r1 != v) && (r2 != v)
                   | NCONS r => r != v
                  end).

Definition cas  (v u : Arg) (r : Restr) :=
  if r is x ≠ y then
    (if x == v then u else x) ≠ (if y == v then u else y)
  else r.

Definition rsubst (r : seq Restr) (b : Bind) : seq Restr :=
  match b with
  | isEQ u v => map (cas u v) r
  | isCONS _ => r
  end.

Definition of_Bind b : Env :=
  match b with
  | isEQ (Arg_Var u) v => [fsfun emsub with u |-> Exp_Arg v]
  | _                  => emsub
  end.

Coercion of_Bind : Bind >-> Env.

Definition b2r b : Restr :=
  match b with
  | isEQ u v => u ≠ v
  | isCONS u => NCONS u
  end.
Coercion b2r : Bind >-> Restr.

Definition csubst (c : Cenv) (e : Bind) :=
  let: (ce, r) := c in
  (comp ce e, rsubst r e).

Definition restr (c : Cenv) (b : Bind) :=
  let: (e, r) := c in (e, b2r b :: r).

Lemma substE (e1 e2 : Env) :
  (forall v : Var, v /s/ e1 = v /s/ e2) -> e1 = e2.
Proof.
by move=> E; apply/fsfunP=> [n]; move: (E n).
Qed.

Lemma substP (f : Exp -> Exp) (env : Env):
  (forall v : Var, env v = f v) ->
  (forall a, f 'a = 'a) ->
  (forall e1 e2, f (CONS e1 e2) = CONS (f e1) (f e2)) ->
  (forall e, e /s/ env = f e).
Proof.
move=> ???; elim=> /= [[[]|?]|?->?->]//=.
Qed.

Lemma emsubv (v : Var):
  emsub v = v.
Proof. by rewrite fsfun_dflt /= ?finsupp0 ?inE. Qed.

Lemma comp_env x e1 e2:
  x /s/ (comp e1 e2) = (x /s/ e1) /s/ e2.
Proof.
rewrite -[(x /s/ e1) /s/ e2]/((fun y => (y /s/ e1) /s/ e2) x).
apply/substP=> // ?.
rewrite /comp fsfunE; case: ifP=> //= /negbT.
by rewrite inE negb_or => /andP[??]; rewrite fsfun_dflt //= fsfun_dflt.
Qed.

Lemma comp0e e1: comp emsub e1 = e1.
Proof. by apply/substE=> v; rewrite comp_env /= emsubv. Qed.

Lemma compe0 e1: comp e1 emsub = e1.
Proof.
apply/substE=> v. rewrite comp_env /= -{2}[e1 v]/(id (e1 v)).
apply/substP=> //; exact/emsubv.
Qed.

Lemma compA e1 e2 e3 : comp e1 (comp e2 e3) = comp (comp e1 e2) e3.
Proof. by apply/substE=> ?; rewrite ?comp_env. Qed.

Lemma subst_var (v u : Var) (e : Exp):
  v /s/ ([fsfun emsub with u |-> e]) = if v == u then e else v.
Proof. by rewrite /= fsfun_withE emsubv. Qed.

Lemma subst_fv e (e1 e2 : Env):
  (forall x, x \in FVExp e -> e1 x = e2 x) ->
  e /s/ e1 = e /s/ e2.
Proof.
elim: e=> /= [[[]|?]|? IHe1 ? IHe2 H]//; first by (apply; rewrite ?inE).
by apply/congr2; rewrite (IHe1, IHe2) // => ? I; rewrite H // ?inE I ?orbT.
Qed.

Definition whole_env (e : Env)  :=
  [fset x | a in finsupp e, x in FVExp (e a)].

Lemma mem_whole_env x e:
  reflect (exists2 y, y \in finsupp e & (x \in FVExp (e y)))
  (x \in whole_env e).
Proof.
apply/(iffP idP)=> [/imfset2P[y ? [? /[swap]<- ?]]|[y *]].
- by exists y.
apply/imfset2P; exists y=> //; by exists x.
Qed.

Definition whole_rs (rs : seq Restr) :=
  [fset x | a in rs, x in FVRestr a].

Lemma mem_whole_rs x rs:
  reflect (exists2 y, (y \in rs) & (x \in FVRestr y))
  (x \in whole_rs rs).
apply/(iffP idP)=> [/imfset2P[y ? [? /[swap]<- ?]]|[y *]].
- by exists y.
apply/imfset2P; exists y=> //; by exists x.
Qed.

Definition whole (e : Cenv) : {fset Var} :=
  whole_env e.1 `|` whole_rs e.2.

Lemma whole_env_substin (env : Env) v:
  v \in finsupp env ->
  FVExp (env v) `<=` whole_env env.
Proof. move=> ?; apply/fsubsetP=> ??; apply/mem_whole_env; by exists v. Qed.

Lemma whole_env_subst (env : Env) (e : Exp):
  FVExp (e /s/ env) `<=` FVExp e `|` whole_env env.
Proof.
elim: e=> /= [[[]|v]|? IHe1 ? IHe2] //=.
- case: (boolP (v \in finsupp env))=> [?|?].
  apply/(fsubset_trans (whole_env_substin _ _ _))=> //.
  by rewrite fsubsetUr.
  by rewrite fsfun_dflt //= fsubsetUl.
rewrite fsubUset; apply/andP; split.
- apply/(fsubset_trans IHe1).
  by rewrite [FVExp _ `|` FVExp _]fsetUC -fsetUA fsubsetUr.
apply/(fsubset_trans IHe2); by rewrite -fsetUA fsubsetUr.
Qed.

Lemma whole_subst (env : Env) (rs : seq Restr) (e : Exp):
  FVExp (e /s/ env) `<=` FVExp e `|` whole (env, rs).
Proof. by rewrite /whole fsetUA /= fsubsetU // whole_env_subst. Qed.

Lemma whole_restr {e rs r}:
  whole (e, r :: rs) = FVRestr r `|` whole (e, rs).
Proof.
rewrite /whole /= fsetUC [whole_env _ `|` _]fsetUC fsetUA.
apply/congr2=> //; apply/fsetP=> ?; rewrite inE.
apply/(sameP idP)/(iffP idP)=> [/orP[]I|/mem_whole_rs[]].
- apply/mem_whole_rs; exists r=> //=; by rewrite inE eq_refl.
- case/mem_whole_rs: I=> y I *. apply/mem_whole_rs; exists y=> //.
  by rewrite inE orbC I.
move=> x; rewrite inE=> /orP[/eqP->-> //|??]; apply/orP; right.
by apply/mem_whole_rs; exists x.
Qed.

Lemma whole_with {env : Env} {v : Var} {e : Exp} {rs}:
  whole ([fsfun env with v |-> e], rs) `<=` v |` (FVExp e) `|` whole (env, rs).
Proof.
rewrite -fsetUA fsubsetU //; apply/orP; right.
rewrite /whole /= fsetUA fsetSU //.
apply/fsubsetP=> ? /mem_whole_env[x].
rewrite finsupp_with; case: ifP=> [/eqP->|].
- rewrite fsfun_withE ?inE. case: ifP=> //= ???; apply/orP; right.
  by apply/mem_whole_env; exists x.
rewrite ?inE fsfun_withE; case: ifP=> //= [???->//|*]; apply/orP; right.
by apply/mem_whole_env; exists x.
Qed.

Lemma comp_var (v : Var) env env':
  comp env env' v = (env v) /s/ env'.
Proof. by rewrite -[comp env env' v]/(v /s/ (comp env env')) comp_env. Qed.

Lemma whole_comp {env : Env} {v : Var} {e : Exp} {rs}:
  whole (comp env [fsfun emsub with v |-> e], rs) `<=` (FVExp e) `|` whole (env, rs).
Proof.
rewrite /whole /= fsetUA fsetSU //.
apply/fsubsetP=> ? /mem_whole_env[x]; rewrite comp_var /comp.
rewrite inE=> /(fsubsetP finsupp_fsfun); rewrite inE.
case: (boolP (x \in finsupp env))=> /= [? _|?].
- move/(fsubsetP (whole_env_subst _ _)); rewrite inE=> /orP[?|].
  apply/orP; right; apply/mem_whole_env; by exists x.
- case/mem_whole_env=> ?; rewrite finsupp_with; case: ifP=> [|?].
  - by rewrite finsupp0 ?inE andbF.
  by rewrite ?inE orbF=> /eqP->; rewrite fsfun_with=>->.
rewrite finsupp_with; case: ifP; first by rewrite finsupp0 ?inE andbF.
rewrite ?inE orbF fsfun_dflt // => ? /eqP-> /=.
by rewrite fsfun_with=>->.
Qed.

Lemma whole_cas {v a env rs}:
  whole (env, [seq cas v a i | i <- rs]) `<=`
  FVArg a `|` whole (env, rs).
Proof.
rewrite /whole /= [FVArg _ `|` _]fsetUC -fsetUA fsetUS //.
apply/fsubsetP=> x /mem_whole_rs[y /mapP[z]].
rewrite /cas. case: z=> [r1 r2|].
- case: ifP=> [/eqP->|].
  - case: ifP=> [/eqP-> ? -> /=|].
    - rewrite fsetUid inE=>->; by rewrite orbT.
    move=> ?? -> /=; rewrite ?inE=> /orP[->|H]; first by rewrite orbT.
    apply/orP; left; apply/mem_whole_rs; exists (v ≠ r2)=> //=.
    by rewrite ?inE H orbT.
  - case: ifP=> [/eqP-> ?? -> /=|].
    - rewrite ?inE=> /orP[H|->]; last by rewrite orbT.
    apply/orP; left; apply/mem_whole_rs; exists (r1 ≠ v)=> //=.
    by rewrite ?inE H.
  move=> ??? -> ?; rewrite ?inE.
  apply/orP; left; apply/mem_whole_rs; by exists (r1 ≠ r2)=> //=.
move=> u ? -> /= ?; rewrite ?inE.
apply/orP; left; apply/mem_whole_rs; by exists (NCONS u)=> //=.
Qed.

Definition aux (e : Env) (f : {fset Var}): {fset Var} :=
  [fset x | a in f, x in FVExp (e a)].

Lemma mem_aux (e : Env) (f : {fset Var}) x:
  reflect (exists2 y, y \in f & x \in FVExp (e y))
  (x \in aux e f).
Proof.
apply/(iffP idP)=> [/imfset2P[y ? [? /[swap]-> ?]]|[y ??]].
- by exists y.
apply/imfset2P; exists y=> //; by exists x.
Qed.

Lemma auxU f g e: aux e (f `|` g) = aux e f `|` aux e g.
Proof.
apply/fsetP=> ?; apply/(sameP idP)/(iffP idP); rewrite ?inE.
- by case/orP=> /mem_aux[x I ?]; apply/mem_aux; exists x=> //; rewrite ?inE I ?orbT.
case/mem_aux=> x.
by rewrite ?inE=> /orP[] I ?; apply/orP; [left | right]; apply/mem_aux; exists x.
Qed.

Lemma aux_FVExp e a : aux e (FVExp a) = FVExp a /s/ e.
Proof.
elim: a=> [|? IH1 ? IH2] /=; last by rewrite auxU IH1 IH2.
- case=> [[]?|v] //=; apply/fsetP=> ?; apply/(sameP idP)/(iffP idP).
  - by rewrite inE.
  - case/mem_aux=> ?; by rewrite inE.
  - move=> ?; apply/mem_aux; exists v=> //; by rewrite ?inE.
  by case/mem_aux=> ?; rewrite ?inE=> /eqP->.
Qed.

Lemma memNwhole k rs v env env'  e1 l:
  max_set (whole (env, rs)) <= k ->
  v < l -> k < l ->
  (env v) /s/ [fsfun env' with l |-> e1] =
  (env v) /s/ env'.
Proof.
move/mem_max_set=> m ??.
case: (boolP (v \in finsupp env))=> [/whole_env_substin H|?].
- have: forall x, x \in FVExp (env v) -> x <= k.
  move=> ? /(fsubsetP H) I; apply/m; by rewrite inE /= I.
  elim: (env v)=> [[[]|u /(_ _ (fset11 _))]|] //=.
  - rewrite fsfun_withE; case: ifP; slia.
  move=> ? IHe1 ? IHe2 I; rewrite IHe1 ?IHe2 //;
  by move=> ? I'; apply/I; rewrite ?inE I' ?orbT.
rewrite fsfun_dflt //= fsfun_withE; case: ifP; slia.
Qed.

Lemma whole_cons rs (env : Env) (v : Var) e1 e2:
  env v = CONS e1 e2 ->
  ((FVExp e1 `<=` whole (env, rs)) * (FVExp e2 `<=` whole (env, rs)))%type.
Proof.
case: (boolP (v \in finsupp env))=> [/whole_env_substin|?].
- move=> /[swap]-> /=; rewrite fsubUset /whole /= => /andP[H1 H2].
  by rewrite ?fsubsetU // (H1, H2).
by rewrite fsfun_dflt.
Qed.

Section ContradictTh.

Lemma cont_isCONS rs v: contradict rs (isCONS v) = (NCONS v \in rs).
Proof.
elim: rs=> //= a ?; rewrite inE /contr; case: a=> // a ->; apply/orb_id2r=> ?.
by apply/(sameP _ eqP)/(iffP eqP)=> [|[]]->.
Qed.

Lemma cont_isEQ rs v u:
  reflect (exists r1 r2, r1 ≠ r2 \in rs /\
  ((r1, r2) = (v, u) \/ (r2, r1) = (v, u)))
  (contradict rs (isEQ v u)).
Proof.
apply/(iffP hasP)=> [[[]//= r1 r2 ?]|[r1 [r2 [?]]]] /pred2P ?.
- by exists r1, r2.
by exists (r1 ≠ r2).
Qed.

Lemma Ncont_isEQ rs v u:
  reflect (forall r1 r2, r1 ≠ r2 \in rs ->
  ((r1, r2) <> (v, u) /\ (r2, r1) <> (v, u)))
  (~~ (contradict rs (isEQ v u))).
Proof.
apply/(iffP hasPn)=> [H ?? /H|H []// ?? /H[/eqP/[swap]/eqP]]; rewrite negb_or.
- by case/andP=>/eqP?/eqP.
by move->=>->.
Qed.

Lemma ncontr_cons e rs v:
  ncontr_env e (NCONS v :: rs) <->
  (ncontr_env e rs /\ ncontr_ncons e v).
Proof.
split=> [][] H1 H2; do ?split.
- by move=> ?? I; apply/H1; rewrite ?inE I orbT.
- by move=> ? I; apply/H2; rewrite ?inE I orbT.
- by apply/H2; rewrite ?inE eq_refl.
- by move=> ??; rewrite inE=> /orP[]//; case: H1=> H ? /H.
by move=> ?; rewrite inE=> /orP[/eqP[->]|]//; case: H1=> ? H /H.
Qed.

Lemma ncontr_eq e rs v u:
  ncontr_env e (v ≠ u :: rs) <->
  (ncontr_env e rs /\ ncontr_neq e v u).
Proof.
split=> [][] H1 H2; do ?split.
- by move=> ?? I; apply/H1; rewrite ?inE I orbT.
- by move=> ? I; apply/H2; rewrite ?inE I orbT.
- by apply/H1; rewrite ?inE eq_refl.
- by move=> ??; rewrite inE=> /orP[/eqP[->->]|]//; case: H1=> H ? /H.
by move=> ?; rewrite inE=> /orP[]//; case: H1=> ? H /H.
Qed.

Lemma ncontr_whole env' env v rs e:
  max_set (whole (env', rs)) < v ->
  ncontr_env env rs ->
  ncontr_env [fsfun env with v |-> e] rs.
Proof.
move/mem_max_set'=> H.
have: {in whole_rs rs, forall x : nat, x < v}=> [? I|{H}H].
- by apply/H; rewrite /whole /= ?inE I orbT.
case=> H1 H2; split=> [r1 r2 I|].
  - have: {subset FVRestr (r1 ≠ r2) <= whole_rs rs}.
    move=> ??; apply/mem_whole_rs; by exists (r1 ≠ r2).
  case: r1 r2 I=> [[? [[? /H1 //]|u /H1 N I]]|] /=.
  - have ?: u < v.
    - by apply/H/I=> /=; rewrite ?inE eq_refl.
    move=> ? /= /[dup] ?; rewrite fsfun_withE; case: ifP; try slia.
    move=> *; exact/N.
  move=> u [[? /H1 N I]|] /=.
    - have ?: u < v by apply/H/I=> /=; rewrite ?inE eq_refl.
      move=> /[swap] ? /= /[dup] ?; rewrite fsfun_withE; case: ifP; try slia.
    move=> *; exact/N.
  move=> u' /H1 N I .
  - have ?: u < v by apply/H/I=> /=; rewrite ?inE eq_refl.
  - have ?: u' < v by apply/H/I=> /=; rewrite ?inE eq_refl orbT.
  move=> /[dup] ? /[dup] ? /=; rewrite ?fsfun_withE; do ?case: ifP; try slia.
  move=> *; exact/N.
move=> [[]|] // u I.
have: {subset FVRestr (NCONS u) <= whole_rs rs}.
move=> ??; apply/mem_whole_rs; by exists (NCONS u).
move: I=> /[swap] /= I /H2 N.
- have ? : u < v by apply/H/I; rewrite ?inE eq_refl.
rewrite /ncontr_ncons /= fsfun_withE; case: ifP; slia.
Qed.

Lemma fmap_of0 xs: mkEnv xs [::] = emsub.
Proof. by case: xs. Qed.

Lemma fmap_ofcons v vs x xs: mkEnv (x :: xs) (v :: vs) =
  [fsfun mkEnv xs vs with x |-> v].
Proof. by []. Qed.

Lemma whole_fmap {xs} {e : Env} {l rs}:
  whole (mkEnv xs (map (subst^~ e) l), rs) `<=`
  whole (e, rs) `|` [fset x | y in l, x in FVExp y].
Proof.
rewrite /whole /= [(_ `|` _)`|` _]fsetUC fsetUA fsetSU //.
apply/fsubsetP=> y /mem_whole_env [x].
elim: xs l=> [l|b l' IHxs [/=|a l /=]].
- rewrite /mkEnv /= . case: l=> //=; by rewrite finsupp0.
- by rewrite fmap_of0 /= finsupp0.
rewrite fmap_ofcons fsfun_withE; case: ifP=> [??|E].
- move/(fsubsetP (whole_env_subst _ _)); rewrite ?inE=> /orP[|->].
  - move=> ?; apply/orP; left; apply/imfset2P; exists a.
    - by rewrite /= mem_head.
   by exists y.
  by rewrite orbT.
have /fsubsetP/[apply]:
  finsupp [fsfun mkEnv l' [seq x0 /s/ e | x0 <- l] with b |-> a /s/ e] `<=`
  b |` finsupp (mkEnv l' [seq x0 /s/ e | x0 <- l]).
- rewrite finsupp_with; case: ifP=> // ?.
  exact/(fsubset_trans (fsubD1set _ _ ))/fsubsetU1.
rewrite ?inE E /==> /IHxs /[apply]; rewrite ?inE => /orP[/imfset2P[z I [w ? ->]]|->].
- apply/orP; left. apply/imfset2P; exists z; first by rewrite ?inE I orbT.
  by exists w.
by rewrite orbT.
Qed.

Lemma subst_closed e env: closed e -> e = e /s/ env.
Proof.
elim: e=> [[[]|? /eqP /= /(congr1 (fun x => #|` x|))]|? IH1 ? IH2] //=.
- by rewrite cardfs1.
rewrite /closed /= fsetU_eq0=> /andP[??].
by apply/congr2; rewrite -(IH1, IH2).
Qed.

Lemma fmap_cat e1 e2 t:
  (forall x, x \in e1 -> closed x) ->
  size t = (size e1 + size e2)%N  ->
  mkEnv t (e1 ++ e2) =
  comp (mkEnv t e1) (mkEnv (drop (size e1) t) e2).
Proof.
elim: e1 t=> /= [?|?? IH [|?? c /=?]]; first by rewrite fmap_of0 comp0e drop0.
- slia.
rewrite ?fmap_ofcons; apply/substE=> v; rewrite comp_env /= ?fsfun_withE.
case: ifP=> ?; first (rewrite -subst_closed //; exact/c/mem_head).
rewrite IH ?comp_var // => [? I|]; last slia; apply/c; by rewrite ?inE I orbT.
Qed.

End ContradictTh.