(*
(C) Copyright 2010, COQTAIL team

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

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

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

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

Require Import Ctacfield.
Require Import Cbase.
Require Import Cprop_base.
Require Import Cfunctions.
Require Import Cpow.

Open Scope C_scope.

Lemma binom_add_INC : forall n k : nat, (n>= k)%nat -> - INC (fact n) / INC (fact (n-k) * fact k)
 + INC (fact (S n)) / INC (fact k * fact (S (n - k)))
= INC (k * fact n) / INC ( fact k * fact (S (n-k))).
Proof.
intros n k H.
do 2 rewrite fact_simpl.
replace (INC (fact k * (S (n - k) * fact (n - k)))) with (INC (S (n-k)) * INC (fact k * fact (n-k))) by
(rewrite mult_comm ; symmetry ; rewrite mult_comm ; rewrite <- mult_INC ;
rewrite mult_assoc ; reflexivity).

replace (INC (S n * fact n)) with (INC (S n) * INC (fact n))
by (rewrite mult_INC ; reflexivity).

unfold Cdiv. rewrite Cinv_mult_distr.
  apply (Cmult_eq_reg_l (INC (S (n - k)))). apply not_0_INC. intuition.
  rewrite Cmult_add_distr_l. repeat rewrite mult_INC.
  field_simplify.
    rewrite Cmult_comm. rewrite <- Cmult_add_distr_l.
    unfold Cdiv. repeat rewrite Cmult_assoc. apply Cmult_eq_compat_l.
    rewrite Cadd_comm.
    replace (INC (S n) + - INC (S (n - k))) with (INC (S n) - INC (S (n - k))) by intuition.
    rewrite <- minus_INC. intuition.
   intuition.
  split. apply not_0_INC. apply fact_neq_0. split. apply not_0_INC. apply fact_neq_0.
   apply not_0_INC. intuition.
   split. apply not_0_INC. apply fact_neq_0. split. apply not_0_INC. apply fact_neq_0.
   apply not_0_INC. intuition.
 apply not_0_INC. intuition.
apply not_0_INC. intro Habs. apply mult_is_O in Habs. elim Habs; apply fact_neq_0.
Qed.

(* begin hide *)
Lemma equi_binom_add :
forall zR zI : R, forall n n0 : nat, (n0 <= n)%nat ->
   ((zR +i 0%R) + (0%R +i zI)) *
   ((zR +i 0%R) ^ n0 * (0%R +i zI) ^ (n - n0) * INC (fact n) *
    / INC (fact n0 * fact (n - n0))) -
   (zR +i 0%R) ^ n0 * (0%R +i zI) ^ (S n - n0) * INC (fact (S n)) *
   / INC (fact n0 * fact (S n - n0)) =
   (zR +i 0%R) ^ (S n0) * (0%R  +i zI) ^ (n - n0) *  INC (fact n) *
    / INC (fact n0 * fact (n - n0)) - (zR +i 0%R) ^ n0 * (0%R +i zI) ^ (S n - n0) *
INC (n0 * fact n)/ INC ( (fact n0) * fact (n-n0+1)).
Proof.
intros zR zI n k Hinf.
apply Cminus_diag_uniq.
rewrite Cmult_add_distr_r.
repeat rewrite <- Cmult_assoc.
assert (H : ( forall a b c d : C, a + b - c - d = a + (b - c) - d)). intros ; ring.
rewrite H.
(*replace*)
replace ((0%R +i  zI) * (zR +i 0%R) ^ k * (0%R +i zI) ^ (n - k) ) with
 ( (zR +i 0%R) ^ k * (0%R +i zI) ^ (S n - k)) by
(symmetry ; rewrite Cmult_comm ; rewrite <- Cmult_assoc ; rewrite Cmult_comm ;
rewrite <- Cpow_S ; rewrite minus_Sn_m ; intuition ;apply Hinf).
(*end replace*)
replace ((zR +i 0%R) ^ k * (0%R +i zI) ^ (S n - k) * INC (fact n) *
 / INC (fact k * fact (n - k)) -
 (zR +i 0%R) ^ k * (0%R +i zI) ^ (S n - k) * INC (fact (S n)) *
 / INC (fact k * fact (S n - k))) with
((zR +i 0%R) ^ k * (0%R +i zI) ^ (S n - k) * (INC (fact n) *
 / INC (fact k * fact (n - k)) - INC (fact (S n)) *
 / INC (fact k * fact (S n - k)))) by ring.
(* replace *)
replace (INC (fact n) * / INC (fact k * fact (n - k)) -
 INC (fact (S n)) * / INC (fact k * fact (S n - k))) with
(-(INC (k * fact n) / INC ( fact k * fact (S (n-k))))).
Focus 2. rewrite <- binom_add_INC.
rewrite minus_Sn_m. unfold Cdiv. rewrite Copp_add_distr. rewrite Copp_mult_distr_l_reverse.
rewrite Copp_invol.
replace (fact k * fact (n-k))%nat with (fact (n-k) * fact k)%nat by ring.
reflexivity. apply Hinf. apply Hinf.
(* end replace*)
assert (H1 : (forall a b c d : C, a + b - (c - d) = (a -c) + (b + d))). intros. ring.
rewrite H1.
rewrite Cpow_S. ring_simplify.
replace ((n- k +1)%nat) with (S(n-k))%nat by ring.
field. apply not_0_INC. intro Habs.  apply mult_is_O in Habs. elim Habs.
apply fact_neq_0. apply fact_neq_0.
Qed.

Lemma fun_prop_bin_add_INC : forall (n : nat) (zR zI : R), (sum_f_C0
  (fun n0 : nat =>
   (zR +i zI) * ((zR +i 0%R) ^ n0 * (0%R +i zI) ^ (n - n0) * INC (fact n) /
    INC (fact n0 * fact (n - n0))) -
   (zR +i 0%R) ^ n0 * (0%R +i zI) ^ (S n - n0) * INC (fact (S n)) /
   INC (fact n0 * fact (S n - n0))) n) = (sum_f_C0
     (fun n0 : nat => (zR +i0%R)^ S n0 * (0%R +i zI) ^ (n-n0) * INC (fact n)
     /INC (fact n0 * fact (n - n0)) - (zR +i 0%R) ^ n0 * (0%R +i zI)^ (S n-n0) * INC (n0*fact n)
     / INC (fact n0 * fact (n-n0 + 1))) n ).
Proof.
intros n zR zI.
apply sum_f_C0_eq_seq.
intros n0 H.
replace (zR +i zI) with ((zR, 0%R) + (0%R, zI)) by (rewrite <- Ceq ; simpl ; intuition).
generalize equi_binom_add. intro Hn1. unfold Cdiv in *. apply Hn1. exact H.
Qed.
(* end hide *)

Lemma Cpow_add_dev : forall z : C, forall n : nat,
((z ^ n)%C = (sum_f_C0 (fun k => (Cre z +i 0%R)^k * (0%R +i Cim z) ^ (n-k) * INC (fact n)/INC ((fact k) * fact (n-k))) n))%C.
Proof.
intros z.
induction n.
simpl. CusingR_f.
destruct z as (zR, zI).
replace ((zR, zI) ^ S n) with ((zR, zI) * (zR, zI) ^ n) by (simpl; reflexivity).
rewrite IHn.
replace (Cre (zR, zI)) with zR by (simpl; reflexivity).
replace (Cim (zR, zI)) with zI by (simpl; reflexivity).
rewrite sum_f_C0_mult.
rewrite sum_f_C0_simpl.
apply Cminus_diag_uniq.
assert (H4 : ( forall a b c : C, a - (b + c) = (a - b) - c)). intros; ring.
rewrite H4.
rewrite <- sum_f_C0_minus_compat.
replace (zR, zI) with (zR +i zI) by reflexivity.
replace (sum_f_C0
  (fun n0 : nat =>
   (zR +i zI) * ((zR +i 0%R) ^ n0 * (0%R +i zI) ^ (n - n0) * INC (fact n) /
    INC (fact n0 * fact (n - n0))) -
   (zR +i 0%R) ^ n0 * (0%R +i zI) ^ (S n - n0) * INC (fact (S n)) /
   INC (fact n0 * fact (S n - n0))) n)
with (sum_f_C0
     (fun n0 : nat => (zR +i0%R)^ S n0 * (0%R +i zI) ^ (n-n0) * INC (fact n)
     /INC (fact n0 * fact (n - n0)) - (zR +i 0%R) ^ n0 * (0%R +i zI)^ (S n-n0) * INC (n0 * fact n) / INC (fact n0 * fact (n-n0 + 1))) n )
by (rewrite fun_prop_bin_add_INC ; reflexivity).
rewrite sum_f_C0_minus_compat.
destruct n. CusingR_f.
rewrite sum_f_C0_simpl. rewrite <- sum_f_C0_reindex.
(* begin replace *)
replace (sum_f_C0
  (fun n0 : nat =>
   (zR +i 0%R) ^ S n0 * (0%R +i zI) ^ (S n - n0) * INC (fact (S n)) /
   INC (fact n0 * fact (S n - n0))) n) with
(sum_f_C0
   (fun k : nat =>
    (zR +i 0%R) ^ S k * (0%R +i zI) ^ (S (S n) - S k) *
    INC (S k * fact (S n)) / INC (fact (S k) * fact (S n - S k + 1))) n).
Focus 2. apply sum_f_C0_eq_seq. intros m H.
repeat rewrite fact_simpl. repeat rewrite mult_INC.
replace (S n - S m + 1)%nat with (S n - m)%nat by intuition.
replace (S (S n) - S m)%nat with (S n - m)%nat by intuition.
field.
split ; try split ; apply not_0_INC ; try apply fact_neq_0 ; intuition.
(* end replace *)
ring_simplify.
replace (S n - S n)%nat with O by intuition.
replace (S (S n) - S (S n))%nat with O by intuition.
repeat rewrite fact_simpl.
repeat rewrite mult_INC. simpl (INC 0).
field.
split ; try split ; try split ; try split ; try apply not_0_INC ; try apply fact_neq_0 ; intuition.
Qed.


(**
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 Export Reals Coquelicot.Coquelicot.
Require Export R_compl.
Require Export logic_tricks.

(** * Fixed Point Theorem without subspaces *)

Section FixedPoint_1.

Context {X : UniformSpace}.
Context {Y : UniformSpace}.

Definition ball_x : X -> R -> X -> Prop := UniformSpace.ball _ (UniformSpace.class X).
Definition ball_y : Y -> R -> Y -> Prop := UniformSpace.ball _ (UniformSpace.class Y).

(** Lispchitz functions *)

Definition is_Lipschitz (f: X -> Y) (k:R) :=
  0 <= k /\
    forall x1 x2 r, 0 < r ->
      ball_x x1 r x2 -> ball_y (f x1) (k*r) (f x2).

Definition is_contraction (f: X -> Y) :=
  exists k, k < 1 /\ is_Lipschitz f k.

End FixedPoint_1.

(** Balls and iterations *)

Section iter_dist.

Context {X : UniformSpace}.

Fixpoint iter (f:X -> X) (n:nat) (x:X) := match n with
   | O => x
   | S m => f (iter f m x)
  end.

Lemma dist_iter_aux_aux: forall (f:X->X) a k p D, 0 < k < 1 -> is_Lipschitz f k ->
    0 < D -> ball a D (f a) ->
   ball (iter f p a) (k ^ p * D) (iter f (p + 1) a).
Proof.
intros f a k p D (Hk1',Hk2') (_,Hk2) HD H.
induction p.
(* *)
simpl.
now rewrite Rmult_1_l.
(* *)
simpl.
rewrite Rmult_assoc.
apply Hk2.
apply Rmult_lt_0_compat; try assumption.
now apply pow_lt.
assumption.
Qed.

Lemma dist_iter_aux: forall (f:X->X) a k p m D, 0 < k < 1 -> is_Lipschitz f k ->
    0 < D -> ball a D (f a) -> (0 < m)%nat ->
    ball (iter f p a) (k^p*(1-k^m)/(1-k) *D)  (iter f (p+m) a).
intros f a k p m D (Hk1',Hk2') (Hk1,Hk2) HD H Hm.
case_eq m.
intros Y; rewrite Y in Hm.
now contradict Hm.
intros n _; clear Hm.
induction n.
(* . *)
simpl.
rewrite Rmult_1_r.
replace (k ^ p * (1 - k) / (1 - k) * D) with (k^p*D).
2: field.
2: now apply Rgt_not_eq, Rlt_Rminus.
apply dist_iter_aux_aux; try split; assumption.
(* . *)
replace (k ^ p * (1 - k ^ S (S n)) / (1 - k) * D) with
   ((k ^ p * (1 - k ^ S n) / (1 - k) * D)+(k ^ (p+S n) * D)).
apply ball_triangle with (iter f (p + S n) a).
exact IHn.
replace (p + S (S n))%nat with ((p+S n)+1)%nat.
apply dist_iter_aux_aux; try split; assumption.
ring.
rewrite pow_add.
simpl; field.
now apply Rgt_not_eq, Rlt_Rminus.
Qed.

Lemma dist_iter: forall (f:X->X) a k p m D, 0 < k < 1 -> is_Lipschitz f k ->
    0 < D -> ball a D (f a) ->
    ball (iter f p a) (k^p/(1-k) *D)  (iter f (p+m) a).
Proof.
intros f a k p m D H1 H2 H3 H4.
case_eq m.
(* *)
intros _; rewrite plus_0_r.
assert (L:(0 < k ^ p / (1 - k) * D)).
apply Rmult_lt_0_compat; trivial.
apply Rdiv_lt_0_compat.
now apply pow_lt.
now apply Rlt_Rminus.
replace (k ^ p / (1 - k) * D) with (pos (mkposreal _ L)) by reflexivity.
apply ball_center.
(* *)
intros n Hn.
apply ball_le with (k^p*(1-k^m)/(1-k) *D).
apply Rmult_le_compat_r.
now left.
unfold Rdiv; apply Rmult_le_compat_r.
left; apply Rinv_0_lt_compat.
now apply Rlt_Rminus.
rewrite <- (Rmult_1_r (k^p)) at 2.
apply Rmult_le_compat_l.
left; now apply pow_lt.
apply Rplus_le_reg_l with (-1).
ring_simplify.
rewrite <- Ropp_0.
apply Ropp_le_contravar.
left; now apply pow_lt.
rewrite Hn.
apply dist_iter_aux; try assumption.
auto with arith.
Qed.

Variable f: X -> X.
Variable phi: X -> Prop.
Hypothesis phi_f: forall x:X, phi x -> phi (f x).
Hypothesis phi_distanceable:
   forall (x y:X), phi x -> phi y-> exists M, 0 <= M /\ ball x M y.

Lemma phi_iter_f: forall a n, phi a -> phi (iter f n a).
Proof.
intros a; induction n; intros Phi_a.
now simpl.
simpl.
now apply phi_f, IHn.
Qed.

Lemma dist_iter_aux_zero: forall (a:X) p m,
    phi a ->
    is_Lipschitz f 0 ->
    (0 < p)%nat -> (0 < m)%nat ->
   ball (iter f p a) 0 (iter f m a).
Proof.
intros a p m phi_a (_,H) Hp Hm.
case_eq p.
intros V; rewrite V in Hp; now contradict Hp.
intros n1 Hn1.
case_eq m.
intros V; rewrite V in Hm; now contradict Hm.
intros n2 Hn2.
simpl.
destruct (phi_distanceable (iter f n1 a) (iter f n2 a)) as (M,(HM1,HM2)).
now apply phi_iter_f.
now apply phi_iter_f.
replace 0 with (0*(M+1)) by ring.
apply H; try assumption.
apply Rle_lt_trans with (M+0).
now rewrite Rplus_0_r.
apply Rplus_lt_compat_l, Rlt_0_1.
apply ball_le with M; try assumption.
apply Rle_trans with (M+0).
right; ring.
apply Rplus_le_compat_l, Rle_0_1.
Qed.

Lemma dist_iter_gen: forall a k p m n D, 0 <= k < 1 -> is_Lipschitz f k ->
   phi a ->
   0 < D -> ball a D (f a) -> (n <= p)%nat -> (n <= m)%nat -> (0 < n)%nat ->
    ball (iter f p a) (k^n/(1-k) *D) (iter f m a).
Proof.
intros a k p m n D (H1,H1') H2 Phi_a H3 H4 Hp Hm Hn.
case H1; intros P.
(* *)
case (le_or_lt p m); intros H5.
(* . *)
replace m with (p+(m-p))%nat.
apply ball_le with (k^p/(1-k) *D).
apply Rmult_le_compat_r.
now left.
unfold Rdiv; apply Rmult_le_compat_r.
left; apply Rinv_0_lt_compat.
now apply Rlt_Rminus.
apply Rle_pow_le; try assumption.
split; try left; try assumption.
apply dist_iter; try assumption.
split; assumption.
now apply le_plus_minus_r.
(* . *)
apply ball_sym.
replace p with (m+(p-m))%nat.
apply ball_le with (k^m/(1-k) *D).
apply Rmult_le_compat_r.
now left.
unfold Rdiv; apply Rmult_le_compat_r.
left; apply Rinv_0_lt_compat.
now apply Rlt_Rminus.
apply Rle_pow_le; try assumption.
split; try left; assumption.
apply dist_iter; try assumption.
split; assumption.
now apply le_plus_minus_r, lt_le_weak.
(* *)
apply ball_le with 0.
rewrite <- P.
rewrite pow_i; try assumption.
right; unfold Rdiv; ring.
apply dist_iter_aux_zero; try assumption.
now rewrite P.
now apply lt_le_trans with n.
now apply lt_le_trans with n.
Qed.

End iter_dist.

(** My_complete *)

Section closed_compl.

Context {X : CompleteSpace}.
Definition lim : ((X -> Prop) -> Prop) -> X := CompleteSpace.lim _ (CompleteSpace.class X).

Definition my_complete (phi:X->Prop) := (forall (F:(X -> Prop) -> Prop),
    ProperFilter F -> cauchy F ->
   (forall P, F P -> ~~(exists x, P x /\ phi x)) -> phi (lim F)).

Lemma closed_my_complete: forall phi,
     closed phi -> my_complete phi.
Proof.
intros phi phi_closed F H1 H2 H3.
generalize (@complete_cauchy X F H1 H2).
intros H4.
unfold closed in *; unfold open in *.
(*apply H5.*)
apply phi_closed.
intros H6'.
destruct H6' as (eps,H6).
specialize (H3 (ball (lim F) eps)).
apply H3.
apply H4.
intros (y,(Hy1,Hy2)).
specialize (H6 y Hy1).
now apply H6.
Qed.

End closed_compl.

Section closed_compl2.

Context {X : CompleteNormedModule R_AbsRing}.

Variable phi: X -> Prop.

Lemma my_complete_closed:
   my_complete phi -> closed phi.
Proof.
intros H x Hx.
pose (F:= locally x).
assert (ProperFilter F).
apply locally_filter.
assert (cauchy F).
intros e; unfold F.
exists x.
now exists e.
replace x with (lim F).
apply H; try assumption.
unfold F; intros P T1 T2.
destruct T1 as (e,He).
apply Hx.
exists e.
intros y Hy1 Hy2.
apply T2.
exists y; split; try easy.
now apply He.
apply sym_eq, eq_close.
intros e.
generalize (complete_cauchy F H0 H1 e).
unfold F; simpl.
intros (ee,Hee).
apply ball_sym.
apply Hee.
apply ball_center.
Qed.

End closed_compl2.

(** Fixed Point Theorem *)

Section FixedPoint_2.

Context {X : CompleteSpace}.

Variable (f:X->X).

(* subset *)
Variable phi: X -> Prop.

Hypothesis phi_f: forall x:X, phi x -> phi (f x).
Hypothesis phi_distanceable:
   forall (x y:X), phi x -> phi y-> exists M, 0 <= M /\ ball x M y.

Lemma FixedPoint_uniqueness_weak: forall a b, is_contraction f
      -> phi a -> phi b
      -> close (f a) a -> close (f b) b ->
        close a b.
Proof.
intros a b (k,(Hk1,(Hk2,Hf))) Phi_a Phi_b Ha Hb eps.
destruct (phi_distanceable a b) as (M,(HM1,HM2)); try assumption.
destruct HM1.
(* *)
pose (k' := (k + 1)/2).
assert (k < k').
unfold k'; apply Rmult_lt_reg_l with 2%R.
apply Rlt_0_2.
apply Rplus_lt_reg_l with (-k).
replace (-k+2*k) with k by ring.
replace (-k + 2 * ((k + 1) / 2)) with 1 by field.
assumption.
assert (0 < k' < 1).
split.
apply Rle_lt_trans with k; assumption.
unfold k'; apply Rmult_lt_reg_l with 2%R.
apply Rlt_0_2.
apply Rplus_lt_reg_l with (-1).
replace (-1+2*1) with 1 by ring.
replace (-1 + 2 * ((k + 1) / 2)) with k by field.
assumption.
(* *)
destruct (contraction_lt_any k' (eps/M)) as (N,HN).
now (split; try left).
apply Rdiv_lt_0_compat; trivial.
destruct eps; simpl; easy.
apply ball_le with (M*k'^N).
apply Rmult_le_reg_r with (/M).
now apply Rinv_0_lt_compat.
left; apply Rle_lt_trans with (2:=HN).
right; field.
now apply Rgt_not_eq.
(* *)
clear HN; induction N.
simpl; rewrite Rmult_1_r.
assumption.
assert (L:(0 < M*k'^S N*(k'-k)/2)).
apply Rdiv_lt_0_compat; try apply Rlt_0_2.
apply Rmult_lt_0_compat.
apply Rmult_lt_0_compat; try assumption.
now apply pow_lt.
now apply Rlt_Rminus.
specialize (Ha (mkposreal _ L)).
specialize (Hb (mkposreal _ L)).
apply ball_le with ((M * k' ^ (S N) * (k' - k) / 2) + ((k*(M * k' ^ N)) + (M * k' ^ (S N) * (k' - k) / 2))).
simpl.
apply Rle_trans with ((k'*(k' - k)  + k)*M*k'^N).
right; field.
apply Rle_trans with (k'*M*k'^N).
2: right; ring.
apply Rmult_le_compat_r.
left; now apply pow_lt.
apply Rmult_le_compat_r.
now left.
apply Rplus_le_reg_l with (-k'*(k'-k)-k).
apply Rle_trans with 0.
right; ring.
apply Rle_trans with (Rsqr ((k-1)/2)).
apply Rle_0_sqr.
right; unfold Rsqr, k'.
field.
apply ball_triangle with (f a).
apply ball_sym, Ha.
apply ball_triangle with (f b).
apply Hf; try assumption.
apply Rmult_lt_0_compat; try assumption.
now apply pow_lt.
apply Hb.
(* *)
apply ball_le with M; try assumption.
rewrite <- H; destruct eps; simpl; left; easy.
Qed.

Lemma Fixed_Point_aux_Proper: forall (a:X),
    ProperFilter (fun P => eventually (fun n => P (iter f n a))).
Proof.
intros a; split.
intros P (N,HN).
exists (iter f N a).
apply HN.
apply le_n.
split.
exists 0%nat; easy.
intros P Q (N1,H1) (N2,H2).
exists (max N1 N2).
intros n Hn; split.
apply H1.
apply le_trans with (2:=Hn).
apply Max.le_max_l.
apply H2.
apply le_trans with (2:=Hn).
apply Max.le_max_r.
intros P Q H (N,HN).
exists N.
intros n Hn.
apply H.
now apply HN.
Qed.

Lemma Fixed_Point_aux_cauchy: forall (a:X), is_contraction f ->
    phi a -> cauchy (fun P => eventually (fun n => P (iter f n a))).
intros a (k,(Hk1,(Hk2,Hf))) Phi_a.
generalize (@cauchy_distance X _ (Fixed_Point_aux_Proper a)).
unfold cauchy; intros (_,T); apply T; clear T.
intros eps.
destruct (phi_distanceable a (f a)) as (M,(HM1,HM2)).
assumption.
now apply phi_f.
destruct HM1.
(* 0 < M *)
destruct (contraction_lt_any' k (eps/M*(1-k)*/3)) as (n,(Hn',Hn)).
now split.
apply Rmult_lt_0_compat.
apply Rmult_lt_0_compat.
apply Rdiv_lt_0_compat; trivial.
destruct eps; now simpl.
now apply Rlt_Rminus.
apply Rinv_0_lt_compat.
apply Rplus_lt_0_compat; try apply Rlt_0_1; apply Rlt_0_2.
exists (fun x => exists m:nat, (n <= m)%nat /\ close x (iter f m a)).
split.
(* . *)
exists n.
intros l Hl.
exists l; split; try easy.
intros E; apply ball_center.
(* . *)
intros u v (n1,(Hn1,Hu)) (n2,(Hn2,Hv)).
assert (L:(0 < eps/3)).
apply Rdiv_lt_0_compat.
destruct eps; now simpl.
apply Rplus_lt_0_compat; try apply Rlt_0_1; apply Rlt_0_2.
pose (e:=mkposreal _ L).
replace (pos eps) with (pos e+(pos e+pos e))%R by (simpl;field).
apply ball_triangle with (iter f n1 a).
apply Hu.
apply ball_triangle with (iter f n2 a).
2: apply ball_sym, Hv.
apply ball_le with (k ^ n / (1 - k) * M).
unfold e; simpl.
apply Rmult_le_reg_l with (/M).
now apply Rinv_0_lt_compat.
apply Rmult_le_reg_l with (1-k).
now apply Rlt_Rminus.
apply Rle_trans with (eps / M * (1 - k) * / 3).
2: right; unfold Rdiv; ring.
left; apply Rle_lt_trans with (2:=Hn).
right; field.
split; apply Rgt_not_eq; try assumption.
now apply Rlt_Rminus.
apply dist_iter_gen with phi; try assumption.
now split.
now split.
(* M = 0 *)
rewrite <- H in HM2.
assert (forall n, close (iter f n a) a).
apply strong_induction with (P:= fun n => close (iter f n a) a).
intros n; case n.
simpl; intros _.
intros e; apply ball_center.
clear n; intros n; case n.
intros _; simpl.
intros e; apply ball_sym, ball_le with 0; try assumption.
destruct e; left; now simpl.
clear n; intros n IH.
apply close_trans with (iter f (S n) a).
2: apply IH.
2: apply le_n.
simpl; intros e.
apply ball_le with (k*e).
rewrite <- (Rmult_1_l e) at 2.
apply Rmult_le_compat_r.
destruct e; left; now simpl.
now left.
apply Hf.
apply cond_pos.
assert (L:(close (iter f (S n) a) (iter f n a))).
apply close_trans with a.
apply IH.
apply le_n.
apply close_sym.
apply IH.
apply le_S, le_n.
apply L.
exists (fun x => close x a).
split.
exists 0%nat.
intros n _; apply H0.
intros u v Hu Hv.
assert (close u v).
apply close_trans with a; try assumption.
now apply close_sym.
apply H1.
Qed.

Lemma FixedPoint_aux1: forall (a:X), is_contraction f -> phi a ->
  let  x := lim  (fun P => eventually (fun n => P (iter f n a))) in
      close (f x) x.
Proof.
intros a Hf Phi_a x.
generalize (complete_cauchy
   (fun P => eventually (fun n => P (iter f n a)))
    (Fixed_Point_aux_Proper a)
    (Fixed_Point_aux_cauchy a Hf Phi_a)).
replace ((Hierarchy.lim
         (fun P : X -> Prop => eventually (fun n0 : nat => P (iter f n0 a))))) with x by reflexivity.
intros H eps.
pose (e2 :=mkposreal _ (is_pos_div_2 eps)).
specialize (H e2).
destruct H as (n,Hn).
replace (pos eps) with (pos e2 + pos e2).
2: simpl; field.
apply ball_sym.
apply ball_triangle with (iter f (S n) a).
apply Hn.
apply le_S, le_n.
destruct Hf as (k,(Hk1,(Hk2,Hk3))).
apply ball_le with (k*e2).
rewrite <- (Rmult_1_l e2) at 2.
apply Rmult_le_compat_r.
destruct e2; left; now simpl.
now left.
simpl.
apply Hk3.
apply (cond_pos e2).
apply ball_sym.
apply Hn.
apply le_n.
Qed.

Hypothesis phi_X_not_empty: exists (a:X), phi a.
Hypothesis phi_closed: my_complete phi.

Lemma FixedPoint_aux2: forall (a:X), is_contraction f -> phi a ->
  let  x := lim
  (fun P => eventually (fun n => P (iter f n a))) in
      phi x.
Proof.
intros a Hf Phi_a x.
apply phi_closed.
apply Fixed_Point_aux_Proper.
now apply Fixed_Point_aux_cauchy.
intros P (N,HN).
intros K; apply K.
exists (iter f N a).
split.
apply HN.
apply le_n.
now apply phi_iter_f.
Qed.

Theorem FixedPoint_C: is_contraction f ->
   exists a:X,
     phi a
      /\ close (f a) a
      /\ (forall b, phi b -> close (f b) b -> close b a) /\
    forall x, phi x -> close (lim  (fun P => eventually (fun n => P (iter f n x)))) a.
Proof.
intros Hf.
destruct phi_X_not_empty as (a, Ha).
exists (lim (fun P => eventually (fun n => P (iter f n a)))).
split.
now apply FixedPoint_aux2.
split.
now apply FixedPoint_aux1.
split.
intros b Phi_b Hb.
apply FixedPoint_uniqueness_weak; try assumption.
now apply FixedPoint_aux2.
now apply FixedPoint_aux1.
intros x Phi_x.
apply FixedPoint_uniqueness_weak; try assumption.
now apply FixedPoint_aux2.
now apply FixedPoint_aux2.
now apply FixedPoint_aux1.
now apply FixedPoint_aux1.
Qed.

End FixedPoint_2.

(** Fixed Point Theorem without norms *)

Section FixedPoint_Normed.

Variable K : AbsRing.
Context {X : CompleteNormedModule K}.

Variable (f:X->X).

Variable phi: X -> Prop.
Hypothesis phi_f: forall x:X, phi x -> phi (f x).
Hypothesis phi_X_not_empty: exists (a:X), phi a.
Hypothesis phi_closed: my_complete phi.

Theorem FixedPoint: is_contraction f ->
   exists a:X,
     phi a
      /\ f a = a
      /\ (forall b, phi b -> f b = b -> b = a) /\
    forall x, phi x -> lim  (fun P => eventually (fun n => P (iter f n x))) = a.
Proof.
intros Hf.
destruct (FixedPoint_C f phi) as (a,Ha); try assumption.
intros x y _ _.
case (Rle_lt_or_eq_dec 0 (norm (minus y x))).
apply norm_ge_0.
intros H1.
(* . *)
assert (Y: 0 < 2*norm (minus y x)).
apply Rmult_lt_0_compat; try apply Rlt_0_2; assumption.
exists (mkposreal _ Y).
split.
left; apply cond_pos.
apply (norm_compat1 x y).
simpl.
apply Rplus_lt_reg_r with (-norm (minus y x)).
ring_simplify.
apply Rle_lt_trans with (2:=H1).
apply Rle_minus.
right; reflexivity.
(* . *)
intros H1.
exists (mkposreal _ Rlt_0_1).
split.
left; apply cond_pos.
replace x with y.
apply ball_center.
apply plus_reg_r with (opp x).
rewrite plus_opp_r.
apply (norm_eq_zero (plus y (opp x))).
now apply sym_eq.
(* *)
destruct Ha as (Ha1,(Ha2,(Ha3,Ha4))).
exists a.
split; [assumption|split].
now apply eq_close.
split.
intros b Hb1 Hb2.
apply eq_close, Ha3; try assumption.
rewrite Hb2; now apply close_refl.
intros x Hx.
apply eq_close, Ha4; try assumption.
Qed.

End FixedPoint_Normed.

(** * Fixed Point Theorem with subsets *)

Section FixedPoint_1_sub.

Context {X : UniformSpace}.
Context {Y : UniformSpace}.

(** Lispchitz functions with subsets *)

Definition is_Lipschitz_phi (f: X -> Y) (k:R) (P : X -> Prop) :=
  0 <= k /\
    forall x1 x2 r, 0 < r -> P x1 -> P x2 ->
      ball_x x1 r x2 -> ball_y (f x1) (k*r) (f x2).

Definition is_contraction_phi (f: X -> Y) (P : X -> Prop) :=
  exists k, k < 1 /\ is_Lipschitz_phi f k P.

End FixedPoint_1_sub.

(** Balls and iterations with subsets *)

Section iter_dist_sub.

Context {X : UniformSpace}.

Lemma dist_iter_aux_aux_phi: forall (f:X->X) (P : X -> Prop) a k p D, 0 < k < 1
   -> (forall p, P (iter f p a)) -> is_Lipschitz_phi f k P -> 0 < D -> ball a D (f a) ->
   ball (iter f p a) (k ^ p * D) (iter f (p + 1) a).
Proof.
intros f P a k p D (Hk1',Hk2') HH (_,Hk2) HD H.
induction p.
(* *)
simpl.
now rewrite Rmult_1_l.
(* *)
simpl.
rewrite Rmult_assoc.
apply Hk2.
apply Rmult_lt_0_compat; try assumption.
now apply pow_lt.
apply HH.
apply HH.
assumption.
Qed.

Lemma dist_iter_aux_phi : forall (f:X->X) (P : X -> Prop) a k p m D,
    0 < k < 1 ->  (forall p, P (iter f p a)) -> is_Lipschitz_phi f k P ->
    0 < D -> ball a D (f a) -> (0 < m)%nat ->
    ball (iter f p a) (k^p*(1-k^m)/(1-k) *D)  (iter f (p+m) a).
intros f P a k p m D (Hk1',Hk2') HH (Hk1,Hk2) HD H Hm.
case_eq m.
intros Y; rewrite Y in Hm.
now contradict Hm.
intros n _; clear Hm.
induction n.
(* . *)
simpl.
rewrite Rmult_1_r.
replace (k ^ p * (1 - k) / (1 - k) * D) with (k^p*D).
2: field.
2: now apply Rgt_not_eq, Rlt_Rminus.
apply dist_iter_aux_aux_phi with P; try split; assumption.
(* . *)
replace (k ^ p * (1 - k ^ S (S n)) / (1 - k) * D) with
   ((k ^ p * (1 - k ^ S n) / (1 - k) * D)+(k ^ (p+S n) * D)).
apply ball_triangle with (iter f (p + S n) a).
exact IHn.
replace (p + S (S n))%nat with ((p+S n)+1)%nat.
apply dist_iter_aux_aux_phi with P; try split; assumption.
ring.
rewrite pow_add.
simpl; field.
now apply Rgt_not_eq, Rlt_Rminus.
Qed.

Lemma dist_iter_phi: forall (f:X->X) (P:X-> Prop) a k p m D, 0 < k < 1
    -> (forall p, P (iter f p a)) -> is_Lipschitz_phi f k P ->
    0 < D -> ball a D (f a) ->
    ball (iter f p a) (k^p/(1-k) *D)  (iter f (p+m) a).
Proof.
intros f P a k p m D H1 H2 HH H3 H4.
case_eq m.
(* *)
intros _; rewrite plus_0_r.
assert (L:(0 < k ^ p / (1 - k) * D)).
apply Rmult_lt_0_compat; trivial.
apply Rdiv_lt_0_compat.
now apply pow_lt.
now apply Rlt_Rminus.
replace (k ^ p / (1 - k) * D) with (pos (mkposreal _ L)) by reflexivity.
apply ball_center.
(* *)
intros n Hn.
apply ball_le with (k^p*(1-k^m)/(1-k) *D).
apply Rmult_le_compat_r.
now left.
unfold Rdiv; apply Rmult_le_compat_r.
left; apply Rinv_0_lt_compat.
now apply Rlt_Rminus.
rewrite <- (Rmult_1_r (k^p)) at 2.
apply Rmult_le_compat_l.
left; now apply pow_lt.
apply Rplus_le_reg_l with (-1).
ring_simplify.
rewrite <- Ropp_0.
apply Ropp_le_contravar.
left; now apply pow_lt.
rewrite Hn.
apply dist_iter_aux_phi with P; try assumption.
auto with arith.
Qed.

Variable f: X -> X.
Variable phi: X -> Prop.

Hypothesis phi_f: forall x:X, phi x -> phi (f x).

Hypothesis phi_distanceable:
   forall (x y:X), phi x -> phi y-> exists M, 0 <= M /\ ball x M y.

Lemma dist_iter_aux_zero_phi : forall (a:X) p m,
    phi a ->
    is_Lipschitz_phi f 0 phi ->
    (0 < p)%nat -> (0 < m)%nat ->
   ball (iter f p a) 0 (iter f m a).
Proof.
intros a p m phi_a (_,H) Hp Hm.
case_eq p.
intros V; rewrite V in Hp; now contradict Hp.
intros n1 Hn1.
case_eq m.
intros V; rewrite V in Hm; now contradict Hm.
intros n2 Hn2.
simpl.
destruct (phi_distanceable (iter f n1 a) (iter f n2 a)) as (M,(HM1,HM2)).
now apply phi_iter_f.
now apply phi_iter_f.
replace 0 with (0*(M+1)) by ring.
apply H; try assumption.
apply Rle_lt_trans with (M+0).
now rewrite Rplus_0_r.
apply Rplus_lt_compat_l, Rlt_0_1.
apply phi_iter_f.
trivial.
trivial.
apply phi_iter_f.
trivial.
trivial.
apply ball_le with M; try assumption.
apply Rle_trans with (M+0).
right; ring.
apply Rplus_le_compat_l, Rle_0_1.
Qed.

Lemma dist_iter_gen_phi : forall a k p m n D, 0 <= k < 1 -> is_Lipschitz_phi  f k phi ->
   phi a ->
   0 < D -> ball a D (f a) -> (n <= p)%nat -> (n <= m)%nat -> (0 < n)%nat ->
    ball (iter f p a) (k^n/(1-k) *D) (iter f m a).
Proof.
intros a k p m n D (H1,H1') H2 Phi_a H3 H4 Hp Hm Hn.
case H1; intros P0.
(* *)
case (le_or_lt p m); intros H5.
(* . *)
replace m with (p+(m-p))%nat.
apply ball_le with (k^p/(1-k) *D).
apply Rmult_le_compat_r.
now left.
unfold Rdiv; apply Rmult_le_compat_r.
left; apply Rinv_0_lt_compat.
now apply Rlt_Rminus.
apply Rle_pow_le; try assumption.
split; try left; try assumption.
apply dist_iter_phi with phi; try assumption.
split; assumption.
intros p0.
apply phi_iter_f.
trivial.
trivial.
now apply le_plus_minus_r.
(* . *)
apply ball_sym.
replace p with (m+(p-m))%nat.
apply ball_le with (k^m/(1-k) *D).
apply Rmult_le_compat_r.
now left.
unfold Rdiv; apply Rmult_le_compat_r.
left; apply Rinv_0_lt_compat.
now apply Rlt_Rminus.
apply Rle_pow_le; try assumption.
split; try left; assumption.
apply dist_iter_phi with phi; try assumption.
split; assumption.
intros p0.
apply phi_iter_f; trivial.
now apply le_plus_minus_r, lt_le_weak.
(* *)
apply ball_le with 0.
rewrite <- P0.
rewrite pow_i; try assumption.
right; unfold Rdiv; ring.
apply dist_iter_aux_zero_phi; try assumption.
now rewrite P0.
now apply lt_le_trans with n.
now apply lt_le_trans with n.
Qed.

End iter_dist_sub.

(** Fixed Point Theorem with subsets *)

Section FixedPoint_2_sub.

Context {X : CompleteSpace}.

Variable (f:X->X).

Variable phi: X -> Prop.

Hypothesis phi_f: forall x:X, phi x -> phi (f x).
Hypothesis phi_distanceable:
   forall (x y:X), phi x -> phi y-> exists M, 0 <= M /\ ball x M y.
Hypothesis phi_c : my_complete phi.

Lemma FixedPoint_uniqueness_weak_phi : forall a b, is_contraction_phi f phi
      -> phi a -> phi b
      -> close (f a) a -> close (f b) b ->
        close a b.
Proof.
intros a b (k,(Hk1,(Hk2,Hf))) Phi_a Phi_b Ha Hb eps.
destruct (phi_distanceable a b) as (M,(HM1,HM2)); try assumption.
destruct HM1.
(* *)
pose (k' := (k + 1)/2).
assert (k < k').
unfold k'; apply Rmult_lt_reg_l with 2%R.
apply Rlt_0_2.
apply Rplus_lt_reg_l with (-k).
replace (-k+2*k) with k by ring.
replace (-k + 2 * ((k + 1) / 2)) with 1 by field.
assumption.
assert (0 < k' < 1).
split.
apply Rle_lt_trans with k; assumption.
unfold k'; apply Rmult_lt_reg_l with 2%R.
apply Rlt_0_2.
apply Rplus_lt_reg_l with (-1).
replace (-1+2*1) with 1 by ring.
replace (-1 + 2 * ((k + 1) / 2)) with k by field.
assumption.
(* *)
destruct (contraction_lt_any k' (eps/M)) as (N,HN).
now (split; try left).
apply Rdiv_lt_0_compat; trivial.
destruct eps; simpl; easy.
apply ball_le with (M*k'^N).
apply Rmult_le_reg_r with (/M).
now apply Rinv_0_lt_compat.
left; apply Rle_lt_trans with (2:=HN).
right; field.
now apply Rgt_not_eq.
(* *)
clear HN; induction N.
simpl; rewrite Rmult_1_r.
assumption.
assert (L:(0 < M*k'^S N*(k'-k)/2)).
apply Rdiv_lt_0_compat; try apply Rlt_0_2.
apply Rmult_lt_0_compat.
apply Rmult_lt_0_compat; try assumption.
now apply pow_lt.
now apply Rlt_Rminus.
specialize (Ha (mkposreal _ L)).
specialize (Hb (mkposreal _ L)).
apply ball_le with ((M * k' ^ (S N) * (k' - k) / 2) + ((k*(M * k' ^ N)) + (M * k' ^ (S N) * (k' - k) / 2))).
simpl.
apply Rle_trans with ((k'*(k' - k)  + k)*M*k'^N).
right; field.
apply Rle_trans with (k'*M*k'^N).
2: right; ring.
apply Rmult_le_compat_r.
left; now apply pow_lt.
apply Rmult_le_compat_r.
now left.
apply Rplus_le_reg_l with (-k'*(k'-k)-k).
apply Rle_trans with 0.
right; ring.
apply Rle_trans with (Rsqr ((k-1)/2)).
apply Rle_0_sqr.
right; unfold Rsqr, k'.
field.
apply ball_triangle with (f a).
apply ball_sym, Ha.
apply ball_triangle with (f b).
apply Hf; try assumption.
apply Rmult_lt_0_compat; try assumption.
now apply pow_lt.
apply Hb.
(* *)
apply ball_le with M; try assumption.
rewrite <- H; destruct eps; simpl; left; easy.
Qed.

Lemma Fixed_Point_aux_Proper_phi : forall (a:X),
    ProperFilter (fun P => eventually (fun n => P (iter f n a))).
Proof.
intros a; split.
intros P (N,HN).
exists (iter f N a).
apply HN.
apply le_n.
split.
exists 0%nat; easy.
intros P Q (N1,H1) (N2,H2).
exists (max N1 N2).
intros n Hn; split.
apply H1.
apply le_trans with (2:=Hn).
apply Max.le_max_l.
apply H2.
apply le_trans with (2:=Hn).
apply Max.le_max_r.
intros P Q H (N,HN).
exists N.
intros n Hn.
apply H.
now apply HN.
Qed.

Lemma Fixed_Point_aux_cauchy_phi : forall (a:X), is_contraction_phi f phi ->
    phi a -> cauchy (fun P => eventually (fun n => P (iter f n a))).
intros a (k,(Hk1,(Hk2,Hf))) Phi_a.
generalize (@cauchy_distance X _ (Fixed_Point_aux_Proper_phi a)).
unfold cauchy; intros (_,T); apply T; clear T.
intros eps.
destruct (phi_distanceable a (f a)) as (M,(HM1,HM2)).
assumption.
now apply phi_f.
destruct HM1.
(* 0 < M *)
destruct (contraction_lt_any' k (eps/M*(1-k)*/3)) as (n,(Hn',Hn)).
now split.
apply Rmult_lt_0_compat.
apply Rmult_lt_0_compat.
apply Rdiv_lt_0_compat; trivial.
destruct eps; now simpl.
now apply Rlt_Rminus.
apply Rinv_0_lt_compat.
apply Rplus_lt_0_compat; try apply Rlt_0_1; apply Rlt_0_2.
exists (fun x => exists m:nat, (n <= m)%nat /\ close x (iter f m a)).
split.
(* . *)
exists n.
intros l Hl.
exists l; split; try easy.
intros E; apply ball_center.
(* . *)
intros u v (n1,(Hn1,Hu)) (n2,(Hn2,Hv)).
assert (L:(0 < eps/3)).
apply Rdiv_lt_0_compat.
destruct eps; now simpl.
apply Rplus_lt_0_compat; try apply Rlt_0_1; apply Rlt_0_2.
pose (e:=mkposreal _ L).
replace (pos eps) with (pos e+(pos e+pos e))%R by (simpl;field).
apply ball_triangle with (iter f n1 a).
apply Hu.
apply ball_triangle with (iter f n2 a).
2: apply ball_sym, Hv.
apply ball_le with (k ^ n / (1 - k) * M).
unfold e; simpl.
apply Rmult_le_reg_l with (/M).
now apply Rinv_0_lt_compat.
apply Rmult_le_reg_l with (1-k).
now apply Rlt_Rminus.
apply Rle_trans with (eps / M * (1 - k) * / 3).
2: right; unfold Rdiv; ring.
left; apply Rle_lt_trans with (2:=Hn).
right; field.
split; apply Rgt_not_eq; try assumption.
now apply Rlt_Rminus.
apply dist_iter_gen_phi with phi; try assumption.
now split.
now split.
(* M = 0 *)
rewrite <- H in HM2.
assert (forall n, close (iter f n a) a).
apply strong_induction with (P:= fun n => close (iter f n a) a).
intros n; case n.
simpl; intros _.
intros e; apply ball_center.
clear n; intros n; case n.
intros _; simpl.
intros e; apply ball_sym, ball_le with 0; try assumption.
destruct e; left; now simpl.
clear n; intros n IH.
apply close_trans with (iter f (S n) a).
2: apply IH.
2: apply le_n.
simpl; intros e.
apply ball_le with (k*e).
rewrite <- (Rmult_1_l e) at 2.
apply Rmult_le_compat_r.
destruct e; left; now simpl.
now left.
apply Hf.
apply cond_pos.
apply phi_iter_f.
intros x Hx.
apply phi_f; trivial.
apply phi_f; trivial.
apply phi_iter_f.
apply phi_f; trivial.
trivial.
assert (L:(close (iter f (S n) a) (iter f n a))).
apply close_trans with a.
apply IH.
apply le_n.
apply close_sym.
apply IH.
apply le_S, le_n.
apply L.
exists (fun x => close x a).
split.
exists 0%nat.
intros n _; apply H0.
intros u v Hu Hv.
assert (close u v).
apply close_trans with a; try assumption.
now apply close_sym.
apply H1.
Qed.

Lemma FixedPoint_aux1_phi : forall (a:X), is_contraction_phi f phi -> phi a ->
  let  x := lim  (fun P => eventually (fun n => P (iter f n a))) in
      close (f x) x.
Proof.
intros a Hf Phi_a x.
generalize (complete_cauchy
   (fun P => eventually (fun n => P (iter f n a)))
    (Fixed_Point_aux_Proper_phi a)
    (Fixed_Point_aux_cauchy_phi _ Hf Phi_a)).
replace ((Hierarchy.lim
         (fun P : X -> Prop => eventually (fun n0 : nat => P (iter f n0 a))))) with x by reflexivity.
intros H eps.
pose (e2 :=mkposreal _ (is_pos_div_2 eps)).
specialize (H e2).
destruct H as (n,Hn).
replace (pos eps) with (pos e2 + pos e2).
2: simpl; field.
apply ball_sym.
apply ball_triangle with (iter f (S n) a).
apply Hn.
apply le_S, le_n.
generalize Hf; intro Hf'.
destruct Hf as (k,(Hk1,(Hk2,Hk3))).
apply ball_le with (k*e2).
rewrite <- (Rmult_1_l e2) at 2.
apply Rmult_le_compat_r.
destruct e2; left; now simpl.
now left.
simpl.
apply Hk3.
apply (cond_pos e2).
apply phi_iter_f.
intros xx Hxx.
apply phi_f; trivial.
trivial.
unfold x.
unfold my_complete in phi_c.
apply phi_c.
apply Fixed_Point_aux_Proper_phi.
apply Fixed_Point_aux_cauchy_phi.
trivial.
trivial.
intros P Hev.
intro.
apply H.
unfold eventually in Hev.
destruct Hev as (N,Hev).
specialize (Hev (N+1)%nat).
assert (Hev' : P (iter f (N+1) a)).
apply Hev.
intuition.
exists (iter f (N+1) a).
split; try assumption.
apply phi_iter_f.
trivial.
trivial.
apply ball_sym.
apply Hn.
apply le_n.
Qed.

Hypothesis phi_X_not_empty: exists (a:X), phi a.
Hypothesis phi_closed: my_complete phi.

Lemma FixedPoint_aux2_phi : forall (a:X), is_contraction_phi f phi -> phi a ->
  let  x := lim
  (fun P => eventually (fun n => P (iter f n a))) in
      phi x.
Proof.
intros a Hf Phi_a x.
apply phi_closed.
apply Fixed_Point_aux_Proper_phi.
now apply Fixed_Point_aux_cauchy_phi.
intros P (N,HN).
intros K; apply K.
exists (iter f N a).
split.
apply HN.
apply le_n.
now apply phi_iter_f.
Qed.

Theorem FixedPoint_C_phi : is_contraction_phi f phi ->
   exists a:X,
     phi a
      /\ close (f a) a
      /\ (forall b, phi b -> close (f b) b -> close b a) /\
    forall x, phi x -> close (lim  (fun P => eventually (fun n => P (iter f n x)))) a.
Proof.
intros Hf.
destruct phi_X_not_empty as (a, Ha).
exists (lim (fun P => eventually (fun n => P (iter f n a)))).
split.
now apply FixedPoint_aux2_phi.
split.
now apply FixedPoint_aux1_phi.
split.
intros b Phi_b Hb.
apply FixedPoint_uniqueness_weak_phi; try assumption.
now apply FixedPoint_aux2_phi.
now apply FixedPoint_aux1_phi.
intros x Phi_x.
apply FixedPoint_uniqueness_weak_phi; try assumption.
now apply FixedPoint_aux2_phi.
now apply FixedPoint_aux2_phi.
now apply FixedPoint_aux1_phi.
now apply FixedPoint_aux1_phi.
Qed.

End FixedPoint_2_sub.


Require Import List String Ensembles Arith
        Computation.Core
        ADT.ADTSig ADT.Core
        Common.ilist ADTNotation.StringBound
        ADTNotation.BuildADT ADTNotation.BuildADTSig
        QueryStructure.QueryStructureSchema QueryStructure.QueryStructure.

(* Definitions for updating query structures. *)

(* 'Inserting' a Tuple [tup] into a relation [R] represented
    as an ensemble produces a new ensemble that holds for any
    Tuple [tup'] equal to [tup] or which is already in [R]. *)
Definition EnsembleInsert {A : Type}
           (a : A)
           (R : Ensemble A)
           (a' : A) :=
  a' = a \/ R a'.

Lemma in_ensemble_insert_iff :
  forall {A} table tup inserted,
    In A (EnsembleInsert inserted table) tup <->
    tup = inserted \/ In A table tup.
Proof.
  firstorder.
Qed.

Definition QSInsertSpec
           (qs : QueryStructureHint)
           (Ridx : _)
           (tup : @IndexedTuple (schemaHeading (QSGetNRelSchema _ Ridx)))
           (qs' : QueryStructure qsSchemaHint')
: Prop :=
  (* All of the relations with a different index are untouched
     by insert. *)
  (forall Ridx',
     Ridx <> Ridx' ->
     GetRelation qsHint Ridx' = GetRelation qs' Ridx') /\
  (* If [tup] is consistent with the schema constraints, *)
  (SatisfiesSchemaConstraints Ridx tup tup)
  -> (forall tup', GetRelation qsHint Ridx tup' ->
                SatisfiesSchemaConstraints Ridx tup tup')
  -> (forall tup', GetRelation qsHint Ridx tup' ->
    SatisfiesSchemaConstraints Ridx tup' tup)
  (* and [tup] is consistent with the other tables per the cross-relation
     constraints, *)
  -> (forall Ridx', SatisfiesCrossRelationConstraints Ridx Ridx' tup
                                                      ((GetRelation qsHint Ridx')))
  (* and each tuple in the other tables is consistent with the
     table produced by inserting [tup] into the relation indexed by [Ridx], *)
  -> (forall Ridx',
        Ridx' <> Ridx ->
        forall tup',
        (GetRelation qsHint Ridx') tup'
        -> SatisfiesCrossRelationConstraints
             Ridx' Ridx tup'
             (EnsembleInsert tup ((GetRelation qsHint Ridx))))
  (* [tup] is included in the relation indexed by [Ridx] after insert.
   The behavior of insertion is unspecified otherwise. *)
  -> (forall t, GetRelation qs' Ridx t <->
                (EnsembleInsert tup (GetRelation qsHint Ridx) t)).

Definition freshIdx (qs : QueryStructureHint) Ridx (n : nat) :=
  forall tup,
    GetRelation qsHint Ridx tup ->
    tupleIndex tup <> n.

Definition SuccessfulInsertSpec
           (qs : QueryStructureHint)
           (Ridx : _)
           (qs' : QueryStructure qsSchemaHint')
           (tup : @IndexedTuple (schemaHeading (QSGetNRelSchema _ Ridx)))
           (result : bool) : Prop :=
  decides result (forall t,
               GetRelation qs' Ridx t <->
               (EnsembleInsert tup
                               (GetRelation qsHint Ridx) t)).

Definition QSInsert (qs : QueryStructureHint) Ridx tup :=
  (idx <- Pick (freshIdx _ Ridx);
   qs' <- Pick (QSInsertSpec _ Ridx {| tupleIndex := idx;
                                      indexedTuple := tup |});
   b <- Pick (SuccessfulInsertSpec _ Ridx qs'
                                   {| tupleIndex := idx;
                                      indexedTuple := tup |});
   ret (qs', b))%comp.

Opaque QSInsert.

Notation "'Insert' b 'into' Ridx " :=
  (QSInsert _ {|bindex := Ridx%comp |} b)
    (at level 80) : QuerySpec_scope.


Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import TLA.TLA.
Require Import TLA.EnabledLemmas.
Require Import TLA.ProofRules.
Require Import TLA.Inductively.
Require Import Examples.System2.
Require Import Examples.FirstDerivShimCtrl.
Require Import ChargeTactics.Lemmas.
Require Import ChargeTactics.Indexed.

Set Implicit Arguments.
Set Strict Implicit.

Local Open Scope string_scope.
Local Open Scope HP_scope.

Module Type UpperLowerFirstParams.
  Parameter ub : R.
  Parameter d : R.
  Parameter d_gt_0 : (d > 0)%R.
End UpperLowerFirstParams.

Module UpperLowerFirst (Import P : UpperLowerFirstParams).
  Module V <: FirstDerivShimParams.
    Definition ub := P.ub.
    Definition d := P.d.
    Definition d_gt_0 := P.d_gt_0.
  End V.

  Module Vel := FirstDerivShim V.

  Let mirror : RenameList :=
    {{ "v" ~> --"v" & "a" ~> --"a" }}%rn.

  Definition mirrored : ActionFormula :=
    SysRename mirror (deriv_term_RenameList mirror)
              Vel.Next.

  Definition Next : ActionFormula :=
    SysCompose mirrored Vel.Next.

  Definition IndInv : StateFormula :=
    Rename mirror Vel.IndInv //\\ Vel.IndInv.

  Lemma TimedPreserves_Next :
    |-- TimedPreserves d IndInv Next.
  Proof with (refine _).
    unfold IndInv, Next. unfold SysCompose.
    rewrite SysCompose_simpl.
    rewrite <- TimedPreserves_And_simple...
    charge_split.
    { rewrite Sys_rename_formula by eauto with rw_rename.
      rewrite SysRename_rule by eauto with rw_rename.
      rewrite TimedPreserves_Rename by eauto with rw_rename.
      eapply Proper_Rename_True.
      apply Vel.TimedPreserves_Next. }
    { eapply Vel.TimedPreserves_Next. }
  Qed.

  Theorem SysNeverStuck_Next : |-- SysNeverStuck d IndInv Next.
  Proof.
    eapply SysNeverStuck_Sys'; [ refine _ | pose proof d_gt_0 ; solve_linear | | ].
    { enable_ex_st.
      pose proof d_gt_0.
      do 2 eexists; exists d; solve_linear. }
    { admit. (** Provable, but we won't worry about it *) }
  Qed.

  Definition Safe : Formula :=
    --P.ub <= "v" <= P.ub.

  Lemma IndInv_impl_Inv : IndInv //\\ 0 <= "T" <= d |-- Safe.
  Proof with (eauto with rw_rename).
    unfold IndInv, Safe, Vel.IndInv, V.ub.
    rewrite <- Rename_ok...
    solve_nonlinear.
  Qed.

  Theorem Spec_safe :
    |-- (IndInv //\\ 0 <= "T" <= d) //\\ []Next -->> []Safe.
  Proof.
    rewrite Preserves_Inv_simple.
    { rewrite IndInv_impl_Inv.
      charge_tauto. }
    { compute; tauto. }
    { apply TimedPreserves_Next. }
  Qed.

End UpperLowerFirst.


Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import VST.floyd.functional_base.
Require Import hmacdrbg.DRBG_functions.
Require Import hmacdrbg.HMAC_DRBG_algorithms.

Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.

Lemma HMAC_DRBG_generate_helper_Z_any_prop_fst:
  forall (P: list byte -> Prop) HMAC key v z,
    0 <= z ->
    P v ->
    (forall x y, P (HMAC x y)) ->
    P (fst (HMAC_DRBG_generate_helper_Z HMAC key v z)).
Proof.
  intros P HMAC key v z Hz Hv H.
  remember (z/32) as n.
  rewrite <- (Z2Nat.id n) in Heqn by (subst; apply (Z_div_pos z 32); lia).
  generalize dependent z.
  induction (Z.to_nat n); intros.
  {
    rewrite (Z_div_mod_eq z 32); try lia.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    rewrite <- Heqn.
    change (Z.of_nat 0) with 0.
    change (32 * 0 + z mod 32) with (z mod 32).
    change (Z.of_nat 32) with 32.
    remember (0 >=? z mod 32) as zero_geb_z; destruct zero_geb_z.
    auto.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    remember (0 >=? z mod 32 - 32) as zero_geb_z_minus_32; destruct zero_geb_z_minus_32.
    apply H.
    {
      rewrite Z.geb_leb in Heqzero_geb_z_minus_32.
      symmetry in Heqzero_geb_z_minus_32; apply Z.leb_gt in Heqzero_geb_z_minus_32.
      pose proof (Z_mod_lt z 32); lia.
    }
  }
  {
    rewrite (Z_div_mod_eq z 32); try lia.
    rewrite <- Heqn.
    assert (Hn: 32 * Z.of_nat (S n0) + z mod 32 = 32 * Z.of_nat n0 + z mod 32 + 32).
    {
      rewrite Nat2Z.inj_succ.
      rewrite <- Zmult_succ_r_reverse.
      lia.
    }
    rewrite Hn.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    destruct (0 >=? 32 * Z.of_nat n0 + z mod 32 + 32); auto.
    change (Z.of_nat 32) with 32.
    replace (32 * Z.of_nat n0 + z mod 32 + 32 - 32) with (32 * Z.of_nat n0 + z mod 32) by lia.
    remember (HMAC_DRBG_generate_helper_Z HMAC key v
               (32 * Z.of_nat n0 + z mod 32)) as result; destruct result.
    simpl.
    apply H.
  }
Qed.

Lemma HMAC_DRBG_generate_helper_Z_incremental_fst:
  forall HMAC key v z v',
    0 <= z ->
    v' = fst (HMAC_DRBG_generate_helper_Z HMAC key v z) ->
    HMAC v' key = fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32)).
Proof.
  intros HMAC key v z v' Hz H.
  remember (z/32) as n.
  rewrite <- (Z2Nat.id n) in Heqn by (subst; apply (Z_div_pos z 32); lia).
  assert (Hf: 0 >=? z + 32 = false).
  {
    assert (0 < z + 32) by lia.
    rewrite Z.geb_leb.
    apply Z.leb_gt; lia.
  }
  rewrite HMAC_DRBG_generate_helper_Z_equation.
  rewrite Hf.
  remember (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32)) as result; destruct result.
  simpl.
  replace l with (fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
  change (Z.of_nat 32) with 32.
  replace (z + 32 - 32) with z by lia.
  rewrite H.
  reflexivity.
Qed.

Lemma HMAC_DRBG_generate_helper_Z_incremental_snd:
  forall HMAC key v z v',
    0 <= z ->
    v' = fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32)) ->
    snd (HMAC_DRBG_generate_helper_Z HMAC key v z) ++ v' = snd (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32)).
Proof.
  intros HMAC key v z v' Hz H.
  remember (z/32) as n.
  rewrite <- (Z2Nat.id n) in Heqn by (subst; apply (Z_div_pos z 32); lia).
  assert (Hf: 0 >=? z + 32 = false).
  {
    assert (0 < z + 32) by lia.
    rewrite Z.geb_leb.
    apply Z.leb_gt; lia.
  }
  remember (HMAC_DRBG_generate_helper_Z HMAC key v z) as saved;
    rewrite HMAC_DRBG_generate_helper_Z_equation; subst saved.
  rewrite Hf.
  remember (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32)) as result; destruct result.
  simpl.
  replace l with (fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
  replace l0 with (snd (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
  change (Z.of_nat 32) with 32.
  replace (z + 32 - 32) with z by lia.
  rewrite H.
  erewrite <- HMAC_DRBG_generate_helper_Z_incremental_fst; eauto.
Qed.

Lemma HMAC_DRBG_generate_helper_Z_Zlength_fst:
  forall HMAC key v z,
    0 <= z ->
    Zlength v = 32 ->
    (forall x y, Zlength (HMAC x y) = 32) ->
    Zlength (fst (HMAC_DRBG_generate_helper_Z HMAC key v z)) = 32.
Proof.
  apply HMAC_DRBG_generate_helper_Z_any_prop_fst.
Qed.

Lemma HMAC_DRBG_generate_helper_Z_Zlength_snd:
  forall HMAC key v z,
    0 <= z ->
    (forall x y, Zlength (HMAC x y) = 32) ->
    (exists n, z = n * 32) ->
    Zlength (snd (HMAC_DRBG_generate_helper_Z HMAC key v z)) = z.
Proof.
  intros HMAC key v z Hz Hlength Hn.
  destruct Hn as [n Hn].
  rewrite <- (Z2Nat.id n) in Hn by lia.
  generalize dependent z. revert Hlength.
  induction (Z.to_nat n); intros.
  {
    change (Z.of_nat 0) with 0 in Hn.
    change (0 * 32) with 0 in Hn.
    subst.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    reflexivity.
  }
  {
    assert (Hn': z = Z.of_nat n0 * 32 + 32).
    {
      rewrite Nat2Z.inj_succ in Hn.
      rewrite <- Zmult_succ_l_reverse in Hn.
      auto.
    }
    clear Hn.
    rename Hn' into Hn.
    subst z.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf: 0 >=? Z.of_nat n0 * 32 + 32 = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; lia.
    }
    rewrite Hf.
    remember (HMAC_DRBG_generate_helper_Z HMAC key v
               (Z.of_nat n0 * 32 + 32 - Z.of_nat 32)) as result; destruct result.
    simpl.
    rewrite Zlength_correct.
    rewrite app_length.
    rewrite Nat2Z.inj_add.
    do 2 rewrite <- Zlength_correct.
    rewrite Hlength.
    replace l0 with (snd (HMAC_DRBG_generate_helper_Z HMAC key v
                (Z.of_nat n0 * 32 + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
    change (Z.of_nat 32) with 32.
    rewrite IHn0; auto; lia.
  }
Qed.

Lemma HMAC_DRBG_generate_helper_Z_incremental_equiv:
  forall HMAC key v z incr,
    0 <= z ->
    0 < incr <= 32 ->
    (exists n, z = n * 32) ->
    HMAC_DRBG_generate_helper_Z HMAC key v (z + incr) = HMAC_DRBG_generate_helper_Z HMAC key v (z + 32).
Proof.
  intros HMAC key v z incr Hz Hlength Hn.
  destruct Hn as [n Hn].
  rewrite <- (Z2Nat.id n) in Hn by lia.
  generalize dependent z.
  induction (Z.to_nat n); intros.
  {
    (* base case *)
    change ((Z.of_nat 0) * 32) with 0 in Hn.
    subst z; simpl.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf: 0 >=? incr = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; lia.
    }
    rewrite Hf.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf2: 0 >=? incr - Z.of_nat 32 = true).
    {
      change (Z.of_nat 32) with 32.
      rewrite Z.geb_leb.
      apply Z.leb_le; lia.
    }
    rewrite Hf2.
    reflexivity.
  }
  {
    (* inductive case *)
    assert (Hn': z = Z.of_nat n0 * 32 + 32).
    {
      rewrite Nat2Z.inj_succ in Hn.
      rewrite <- Zmult_succ_l_reverse in Hn.
      auto.
    }
    clear Hn; rename Hn' into Hn.
    subst z.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf: 0 >=? Z.of_nat n0 * 32 + 32 + incr = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; lia.
    }
    rewrite Hf.
    change (Z.of_nat 32) with 32.
    replace (Z.of_nat n0 * 32 + 32 + incr - 32) with (Z.of_nat n0 * 32 + incr) by lia.
    rewrite IHn0; try lia.
    remember (let (v0, rest) :=
        HMAC_DRBG_generate_helper_Z HMAC key v (Z.of_nat n0 * 32 + 32) in
    (HMAC v0 key, rest ++ HMAC v0 key)) as saved; rewrite HMAC_DRBG_generate_helper_Z_equation; subst saved.
    assert (Hf2: 0 >=? Z.of_nat n0 * 32 + 32 + 32 = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; lia.
    }
    rewrite Hf2.
    change (Z.of_nat 32) with 32.
    replace (Z.of_nat n0 * 32 + 32 + 32 - 32) with (Z.of_nat n0 * 32 + 32) by lia.
    reflexivity.
  }
Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import Limits.Limit Limits.GenProd_GenSum.
From Categories Require Import Archetypal.Discr.Discr.
From Categories Require Import PreSheaf.PreSheaf.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.

Section PSh_GenSum.
  Context (C : Category) (A : Type) (map : A → PShCat C).

  Local Notation Fm := (Discr_Func_op (PShCat C) map) (only parsing).

  Local Hint Extern 1 => match goal with [h : {x : _ & _} |- _] => destruct x end.
  Local Hint Extern 1 => match goal with
                          [|- context [(?F _a id)%morphism]] => rewrite (F_id F)
                        end.
  Local Hint Extern 1 =>
  match goal with
    [|- context [(?F _a (?f ∘ ?g))%morphism]] =>
    cbn_rewrite (F_compose F f g)
  end.

  (** The pointwise generalized sum presheaf. *)
  Program Definition PSh_GenSum_func : PreSheaf C :=
    {|
      FO :=
        fun c =>
          {x : A & ((Fm _o x) _o c)%object};
      FA :=
        fun _ _ h x => existT _ (projT1 x)
                           ((map (projT1 x) _a h (projT2 x))%morphism)
    |}.

  (** The injection of generalized sum presheaf. *)
  Program Definition PSh_GenProd_inj (x : A) :
    (map x –≻ PSh_GenSum_func)%nattrans :=
    {|
      Trans := fun c y => existT _ x y
    |}.

  (** The cone for generalized sum presheaf. *)
  Program Definition PSh_GenSum_CoCone : CoCone Fm :=
    {|
      cone_apex :=
        {|FO := fun _ => PSh_GenSum_func;
          FA :=
            fun _ _ h => id
        |};
      cone_edge := {|Trans := fun x => PSh_GenProd_inj x |}
    |}.

  Local Hint Extern 1 =>
    match goal with
      [|- context [Trans ?f _ ((?F _a)%morphism ?h _)]] =>
      cbn_rewrite (equal_f (Trans_com f h))
    end.

  Local Hint Extern 1 => match goal with [H : unit |- _] => destruct H end.

  Local Hint Resolve NatTrans_eq_simplify.

  Local Hint Extern 1 => rewrite From_Term_Cat.

  (** The morphism that maps to the generalized product given a map to its
      components. *)
  Program Definition PSh_GenSum_morph_ex
          (Cn : LoKan_Cone
                  (Functor_To_1_Cat (Discr_Cat A ^op) ^op)
                  (Discr_Func_op ((PShCat C))  map ^op)
          )
    : (PSh_GenSum_func –≻ (Cn _o)%object tt)%nattrans :=
    {|
      Trans := fun c y => Trans (Trans Cn (projT1 y)) c (projT2 y)
    |}.

  Local Hint Extern 1 => progress cbn.

  Local Obligation Tactic := basic_simpl; auto 10.

  Program Definition PSh_GenSum : (Σ map)%object :=
    {|
      LRKE := PSh_GenSum_CoCone;
      LRKE_morph_ex :=
        fun Cn =>
          {|
            cone_morph :=
              {|
                Trans :=
                  fun x => _
                          match x as u return
                                (PSh_GenSum_func –≻ (Cn _o)%object u)%nattrans
                          with
                            tt => PSh_GenSum_morph_ex Cn
                          end
              |}
          |}
    |}.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    intros Cn h h'.
    apply NatTrans_eq_simplify.
    extensionality x.
    apply NatTrans_eq_simplify.
    extensionality y.
    extensionality z.
    destruct z as [z u].
    cbn in *.
    destruct x.
    cbn_rewrite
      <-
      (
        equal_f
          (
            f_equal
              (fun w :
                     (
                       (Cn ∘ Functor_To_1_Cat (Discr_Cat A ^op) ^op)
                          –≻ Discr_Func_op (PShCat C) map ^op
                     )%nattrans
               =>
                 Trans (Trans w z) y
              ) (cone_morph_com h)
          )
          u
      ).
    cbn_rewrite
      <-
      (
        equal_f
          (
            f_equal
              (fun w :
                     (
                       (Cn ∘ Functor_To_1_Cat (Discr_Cat A ^op) ^op)
                          –≻ Discr_Func_op (PShCat C) map ^op
                     )%nattrans
               =>
                 Trans (Trans w z) y
              ) (cone_morph_com h')
          )
          u
      ).
    trivial.
  Qed.

End PSh_GenSum.

(** In category of types, generalized sums are simply dependent sum types. *)
Section Type_Cat_GenSum.
  Context (A : Type) (map : A → Type_Cat).

  Local Notation Fm := (Discr_Func_op Type_Cat map) (only parsing).

  (** The cocone for the colimit of generalized sum. *)
  Program Definition Type_Cat_GenSum_CoCone : CoCone Fm :=
    {|
      cone_apex :=
        {|FO := fun _ => {x : A & (Fm _o x)%object}; FA := fun _ _ _ h => h|};
      cone_edge := {|Trans := fun x => existT _ x |}
    |}.

   Program Definition Type_Cat_GenSum : (Σ map)%object :=
    {|
      LRKE := Type_Cat_GenSum_CoCone;
      LRKE_morph_ex :=
        fun Cn =>
          {|
            cone_morph :=
              {|Trans :=
                  fun c h =>
                    match c as u return ((Cn _o) u)%object with
                    | tt => Trans Cn (projT1 h) (projT2 h)
                    end
              |}
          |}
    |}.

  Next Obligation.
  Proof.
    extensionality x.
    destruct c; destruct c'; destruct h.
    apply (equal_f (@Trans_com _ _ _ _ Cn (projT1 x) (projT1 x) eq_refl)).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Type_Cat_GenSum_obligation_1.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality x; extensionality y.
    destruct x.
    destruct y as [y1 y2].
    cbn in *.
    set (hc := (cone_morph_com h')).
    rewrite (cone_morph_com h) in hc.
    set (hc' := (
                 f_equal
                   (fun w :
                        ((Cn ∘ (Functor_To_1_Cat
                                  (Discr_Cat A)^op) ^op) –≻ Fm^op)%nattrans
                    =>
                      Trans w y1 y2) hc
               )
        ); clearbody hc'; clear hc.
    cbn in *.
    apply hc'.
  Qed.

End Type_Cat_GenSum.


From Hammer Require Import Hammer.

Require Import Bool.
Require Import Arith.
Require Import ZArith.
From IntMap Require Import Allmaps.
Require Import EqNat.
From TreeAutomata Require Import bases.

Inductive term : Set :=
app : ad -> term_list -> term
with term_list : Set :=
| tnil : term_list
| tcons : term -> term_list -> term_list.

Scheme term_term_list_rec := Induction for term
Sort Set
with term_list_term_rec := Induction for term_list
Sort Set.

Scheme term_term_list_ind := Induction for term
Sort Prop
with term_list_term_ind := Induction for term_list
Sort Prop.

Lemma term_list_disj :
forall l : term_list,
l = tnil \/ (exists hd : term, (exists tl : term_list, l = tcons hd tl)).
Proof. hammer_hook "defs" "defs.term_list_disj".
simple induction l. left. trivial. right. split with t. split with t0.
trivial.
Qed.

Fixpoint lst_length (l : term_list) : nat :=
match l with
| tnil => 0
| tcons _ l' => S (lst_length l')
end.

Fixpoint term_high (t : term) : nat :=
match t with
| app a l => S (term_high_0 l)
end

with term_high_0 (l : term_list) : nat :=
match l with
| tnil => 0
| tcons hd tl => max (term_high hd) (term_high_0 tl)
end.

Lemma high_aux_0 :
forall (a : ad) (l : term_list), S (term_high_0 l) <= term_high (app a l).
Proof. hammer_hook "defs" "defs.high_aux_0".
intros. unfold term_high in |- *. unfold term_high_0 in |- *. exact (le_n_n _).
Qed.

Lemma high_aux_1 :
forall (a : ad) (l : term_list), S (term_high_0 l) = term_high (app a l).
Proof. hammer_hook "defs" "defs.high_aux_1".
intros. unfold term_high in |- *. unfold term_high_0 in |- *. trivial.
Qed.

Lemma high_aux_2 : forall (l : term_list) (c : ad), 1 <= term_high (app c l).
Proof. hammer_hook "defs" "defs.high_aux_2".
intros. cut (S (term_high_0 l) <= term_high (app c l)).
intro. cut (1 <= S (term_high_0 l)). intro.
exact (le_trans 1 (S (term_high_0 l)) (term_high (app c l)) H0 H).
exact (le_n_S 0 (term_high_0 l) (le_O_n (term_high_0 l))).
exact (high_aux_0 c l).
Qed.

Lemma high_aux_3 :
forall (t : term) (tl : term_list), term_high t <= term_high_0 (tcons t tl).
Proof. hammer_hook "defs" "defs.high_aux_3".
intros. simpl in |- *. unfold term_high in |- *. exact (le_max_l _ (term_high_0 tl)).
Qed.

Lemma high_aux_4 :
forall (t : term) (tl : term_list),
term_high_0 tl <= term_high_0 (tcons t tl).
Proof. hammer_hook "defs" "defs.high_aux_4".
intros.
cut (term_high_0 (tcons t tl) = max (term_high t) (term_high_0 tl)).
intro. rewrite H. exact (le_max_r (term_high t) (term_high_0 tl)).
unfold term_high_0 in |- *. trivial.
Qed.

Fixpoint taille_term (t : term) : nat :=
match t with
| app c l => S (mtaille_term_list l)
end

with mtaille_term_list (l : term_list) : nat :=
match l with
| tnil => 0
| tcons hd tl => max (taille_term hd) (mtaille_term_list tl)
end.

Inductive prec_list : Set :=
| prec_cons : ad -> prec_list -> prec_list -> prec_list
| prec_empty : prec_list.

Lemma pl_sum :
forall pl : prec_list,
pl = prec_empty \/
(exists a : ad,
(exists la : prec_list, (exists ls : prec_list, pl = prec_cons a la ls))).
Proof. hammer_hook "defs" "defs.pl_sum".
intros. induction  pl as [a pl1 Hrecpl1 pl0 Hrecpl0| ]. right. split with a. split with pl1.
split with pl0. reflexivity. left. reflexivity.
Qed.

Definition state := Map prec_list.

Definition preDTA := Map state.

Inductive DTA : Set :=
dta : preDTA -> ad -> DTA.

Fixpoint taille_0 (l : prec_list) : nat :=
match l with
| prec_empty => 0
| prec_cons x y z => S (taille_0 y + taille_0 z)
end.

Fixpoint taille_1 (s : state) : nat :=
match s with
| M0 => 0
| M1 x y => taille_0 y
| M2 x y => max (taille_1 x) (taille_1 y)
end.

Fixpoint DTA_taille (d : preDTA) : nat :=
match d with
| M0 => 0
| M1 x y => taille_1 y
| M2 x y => max (DTA_taille x) (DTA_taille y)
end.

Lemma taille_aux_0 :
forall (a : ad) (la ls : prec_list),
S (taille_0 la) <= taille_0 (prec_cons a la ls).
Proof. hammer_hook "defs" "defs.taille_aux_0".
intros. simpl in |- *.
apply (le_n_S (taille_0 la) (taille_0 la + taille_0 ls)).
exact (le_plus_l (taille_0 la) (taille_0 ls)).
Qed.

Lemma taille_aux_1 :
forall (a : ad) (la ls : prec_list), 1 <= taille_0 (prec_cons a la ls).
Proof. hammer_hook "defs" "defs.taille_aux_1".
intros. unfold taille_0 in |- *.
exact (le_n_S 0 _ (le_O_n _)).
Qed.

Lemma taille_aux_2 :
forall (a : ad) (la ls : prec_list),
S (taille_0 ls) <= taille_0 (prec_cons a la ls).
Proof. hammer_hook "defs" "defs.taille_aux_2".
intros. simpl in |- *.
apply (le_n_S (taille_0 ls) (taille_0 la + taille_0 ls)).
exact (le_plus_r (taille_0 la) (taille_0 ls)).
Qed.

Inductive prec_occur : prec_list -> ad -> Prop :=
| prec_hd :
forall (a : ad) (pl0 pl1 : prec_list),
prec_occur (prec_cons a pl0 pl1) a
| prec_int0 :
forall (a b : ad) (pl0 pl1 : prec_list),
prec_occur pl0 b -> prec_occur (prec_cons a pl0 pl1) b
| prec_int1 :
forall (a b : ad) (pl0 pl1 : prec_list),
prec_occur pl1 b -> prec_occur (prec_cons a pl0 pl1) b.

Inductive prec_contained : prec_list -> prec_list -> Prop :=
| prec_id : forall p : prec_list, prec_contained p p
| prec_c_int0 :
forall (p p0 p1 : prec_list) (a : ad),
prec_contained p p0 -> prec_contained p (prec_cons a p0 p1)
| prec_c_int1 :
forall (p p0 p1 : prec_list) (a : ad),
prec_contained p p1 -> prec_contained p (prec_cons a p0 p1).

Definition state_in_dta (d : preDTA) (s : state) : Prop :=
exists a : ad, MapGet state d a = Some s.

Definition state_in_dta_diff (d : preDTA) (s : state)
(a : ad) : Prop := exists b : ad, MapGet state d b = Some s /\ a <> b.

Definition prec_in_dta (d : preDTA) (p : prec_list) : Prop :=
exists s : state,
(exists a : ad,
(exists c : ad,
MapGet state d a = Some s /\
MapGet prec_list s c = Some p)).

Definition prec_in_dta_cont (d : preDTA) (p : prec_list) : Prop :=
exists s : state,
(exists b : ad,
(exists c : ad,
(exists p0 : prec_list,
MapGet state d b = Some s /\
MapGet prec_list s c = Some p0 /\ prec_contained p p0))).

Definition prec_in_dta_diff (d : preDTA) (p : prec_list)
(a : ad) : Prop :=
exists s : state,
(exists b : ad,
(exists c : ad,
MapGet state d b = Some s /\
MapGet prec_list s c = Some p /\ a <> b)).

Definition prec_in_dta_diff_cont (d : preDTA) (p : prec_list)
(a : ad) : Prop :=
exists s : state,
(exists b : ad,
(exists c : ad,
(exists p0 : prec_list,
MapGet state d b = Some s /\
MapGet prec_list s c = Some p0 /\
prec_contained p p0 /\ a <> b))).

Definition prec_in_state (s : state) (p : prec_list) : Prop :=
exists c : ad, MapGet prec_list s c = Some p.

Lemma prec_in_state_M0_false :
forall p : prec_list, ~ prec_in_state (M0 prec_list) p.
Proof. hammer_hook "defs" "defs.prec_in_state_M0_false".
intros. exact (in_M0_false prec_list p).
Qed.

Lemma state_in_dta_M0_false : forall s : state, ~ state_in_dta (M0 state) s.
Proof. hammer_hook "defs" "defs.state_in_dta_M0_false".
intros. exact (in_M0_false state s).
Qed.

Lemma prec_occur_1 :
forall (a : ad) (p0 p1 p2 : prec_list),
prec_contained (prec_cons a p0 p1) p2 -> prec_occur p2 a.
Proof. hammer_hook "defs" "defs.prec_occur_1".
intros. induction  p2 as [a0 p2_1 Hrecp2_1 p2_0 Hrecp2_0| ]. inversion H. exact (prec_hd a0 p2_1 p2_0).
exact (prec_int0 a0 a p2_1 p2_0 (Hrecp2_1 H2)).
exact (prec_int1 a0 a p2_1 p2_0 (Hrecp2_0 H2)).
inversion H.
Qed.

Lemma prec_contained_0 :
forall (a : ad) (p0 p1 p2 : prec_list),
prec_contained (prec_cons a p0 p1) p2 -> prec_contained p0 p2.
Proof. hammer_hook "defs" "defs.prec_contained_0".
intros. induction  p2 as [a0 p2_1 Hrecp2_1 p2_0 Hrecp2_0| ]. inversion H.
exact (prec_c_int0 p2_1 p2_1 p2_0 a0 (prec_id p2_1)).
exact (prec_c_int0 _ _ _ _ (Hrecp2_1 H2)).
exact (prec_c_int1 _ _ _ _ (Hrecp2_0 H2)).
inversion H.
Qed.

Lemma prec_contained_1 :
forall (a : ad) (p0 p1 p2 : prec_list),
prec_contained (prec_cons a p0 p1) p2 -> prec_contained p1 p2.
Proof. hammer_hook "defs" "defs.prec_contained_1".
intros. induction  p2 as [a0 p2_1 Hrecp2_1 p2_0 Hrecp2_0| ]. inversion H.
exact (prec_c_int1 _ _ _ _ (prec_id p2_0)).
exact (prec_c_int0 _ _ _ _ (Hrecp2_1 H2)).
exact (prec_c_int1 _ _ _ _ (Hrecp2_0 H2)).
inversion H.
Qed.

Inductive term_occur : term -> term -> Prop :=
| to_eq : forall t : term, term_occur t t
| to_st :
forall (t : term) (a : ad) (tl : term_list),
term_list_occur t tl -> term_occur t (app a tl)
with term_list_occur : term -> term_list -> Prop :=
| tlo_head :
forall (t hd : term) (tl : term_list),
term_occur t hd -> term_list_occur t (tcons hd tl)
| tlo_tail :
forall (t hd : term) (tl : term_list),
term_list_occur t tl -> term_list_occur t (tcons hd tl).

Definition term_occur_def_0 (t : term) :=
forall u : term, term_occur u t -> term_high u <= term_high t.

Definition term_occur_def_1 (t : term_list) :=
forall u : term, term_list_occur u t -> term_high u <= term_high_0 t.

Lemma term_occur_0_0 :
forall (a : ad) (t : term_list),
term_occur_def_1 t -> term_occur_def_0 (app a t).
Proof. hammer_hook "defs" "defs.term_occur_0_0".
unfold term_occur_def_1 in |- *. unfold term_occur_def_0 in |- *. intros. inversion H0.
exact (le_n_n _). apply
(le_trans (term_high u) (term_high_0 t) (term_high (app a t)) (H u H3)). unfold term_high in |- *. exact (le_n_Sn _).
Qed.

Lemma term_occur_0_1 : term_occur_def_1 tnil.
Proof. hammer_hook "defs" "defs.term_occur_0_1".
unfold term_occur_def_1 in |- *. intros. induction  u as (a, t). inversion H.
Qed.

Lemma term_occur_0_2 :
forall t : term,
term_occur_def_0 t ->
forall t0 : term_list, term_occur_def_1 t0 -> term_occur_def_1 (tcons t t0).
Proof. hammer_hook "defs" "defs.term_occur_0_2".
unfold term_occur_def_0 in |- *. unfold term_occur_def_1 in |- *. intros. inversion H1.
apply (le_trans (term_high u) (term_high t) (term_high_0 (tcons t t0))).
exact (H u H4). exact (le_max_l _ _). apply (le_trans (term_high u) (term_high_0 t0) (term_high_0 (tcons t t0))). exact (H0 u H4).
exact (le_max_r _ _).
Qed.

Lemma term_occur_0 :
forall t u : term, term_occur u t -> term_high u <= term_high t.
Proof. hammer_hook "defs" "defs.term_occur_0".
exact
(term_term_list_ind term_occur_def_0 term_occur_def_1 term_occur_0_0
term_occur_0_1 term_occur_0_2).
Qed.

Lemma term_occur_1 :
forall (t : term_list) (u : term),
term_list_occur u t -> term_high u <= term_high_0 t.
Proof. hammer_hook "defs" "defs.term_occur_1".
exact
(term_list_term_ind term_occur_def_0 term_occur_def_1 term_occur_0_0
term_occur_0_1 term_occur_0_2).
Qed.

Definition indprinciple_3_aux (n : nat) :=
forall P : term -> Prop,
(forall (a : ad) (tl : term_list),
(forall u : term, term_list_occur u tl -> P u) -> P (app a tl)) ->
forall t : term, term_high t <= n -> P t.

Lemma indprinciple_3_0 : indprinciple_3_aux 0.
Proof. hammer_hook "defs" "defs.indprinciple_3_0".
unfold indprinciple_3_aux in |- *. intros. induction  t as (a, t). simpl in H0. inversion H0.
Qed.

Lemma indprinciple_3_1 :
forall n : nat, indprinciple_3_aux n -> indprinciple_3_aux (S n).
Proof. hammer_hook "defs" "defs.indprinciple_3_1".
unfold indprinciple_3_aux in |- *. intros. induction  t as (a, t). apply (H0 a t).
intros. apply (H P H0 u). apply (le_trans (term_high u) (term_high_0 t) n).
exact (term_occur_1 t u H2). exact (le_S_n _ _ H1).
Qed.

Lemma indprinciple_3_2 :
forall (n : nat) (P : term -> Prop),
(forall (a : ad) (tl : term_list),
(forall u : term, term_list_occur u tl -> P u) -> P (app a tl)) ->
forall t : term, term_high t <= n -> P t.
Proof. hammer_hook "defs" "defs.indprinciple_3_2".
exact (nat_ind indprinciple_3_aux indprinciple_3_0 indprinciple_3_1).
Qed.

Lemma indprinciple_term :
forall P : term -> Prop,
(forall (a : ad) (tl : term_list),
(forall u : term, term_list_occur u tl -> P u) -> P (app a tl)) ->
forall t : term, P t.
Proof. hammer_hook "defs" "defs.indprinciple_term".
intros. exact (indprinciple_3_2 (term_high t) P H t (le_n_n _)).
Qed.

Lemma Ndouble_inv_N0 : forall x : ad, N.double x = N0 -> x = N0.
Proof. hammer_hook "defs" "defs.Ndouble_inv_N0".
simple induction x. intros. reflexivity. simpl in |- *. intros. inversion H.
Qed.

Lemma Ndouble_inv_xO :
forall (x : ad) (p : positive), N.double x = Npos (xO p) -> x = Npos p.
Proof. hammer_hook "defs" "defs.Ndouble_inv_xO".
simple induction x. intros. inversion H. intros. simpl in H.
inversion H. reflexivity.
Qed.

Lemma Ndouble_plus_one_inv_xH :
forall x : ad, Ndouble_plus_one x = Npos 1 -> x = N0.
Proof. hammer_hook "defs" "defs.Ndouble_plus_one_inv_xH".
simple induction x. intros. reflexivity. simpl in |- *. intros. inversion H.
Qed.

Lemma Ndouble_plus_one_inv_xI :
forall (x : ad) (p : positive),
Ndouble_plus_one x = Npos (xI p) -> x = Npos p.
Proof. hammer_hook "defs" "defs.Ndouble_plus_one_inv_xI".
simple induction x. intros. inversion H. intros. simpl in H.
inversion H. reflexivity.
Qed.


(** * Model of Time *)

(** Prosa is based on a discrete model of time. Thus, time is simply defined by
    the natural numbers. To aid readability, we distinguish between values of time
    that represent a duration and values of time that represent a specific
    instant. *)
Definition duration := nat.
Definition instant  := nat.


Require Import Undecidability.SOL.SOL.
Require Import Undecidability.Shared.Dec.
From Undecidability.Shared.Libs.PSL Require Import Vectors.
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
Require Import EqdepFacts Eqdep_dec.

Unset Implicit Arguments.

Module VectorForall.
Import Vector.

Definition Forall {X} (p : X -> Prop) := fix Forall {n} (v : t X n) :=
  match v with
  | nil _ => True
  | cons _ x _ v => p x /\ Forall v
  end.

Definition Forall2 {X Y} (p : X -> Y -> Prop) := fix Forall2 {n} (v1 : t X n) (v2 : t Y n) :=
  match v1 in Vector.t _ n return t Y n -> Prop with
  | nil _ => fun _ => True
  | cons _ x _ v1 => fun v2 => p x (hd v2) /\ Forall2 v1 (tl v2)
  end v2.

Lemma Forall2_Forall {X Y Z n} (p : Y -> Z -> Prop) (f1 : X -> Y) (f2 : X -> Z) v :
  @Forall2 Y Z p n (map f1 v) (map f2 v) <-> @Forall X (fun x => p (f1 x) (f2 x)) n v.
Proof.
  induction v; firstorder.
Qed.

Lemma Forall_ext {X n} (p q : X -> Prop) (v : t X n) :
  (forall x, p x -> q x) -> Forall p v -> Forall q v.
Proof.
  induction v; firstorder.
Qed.

Lemma Forall_ext_Forall {X n} (p q : X -> Prop) (v : t X n) :
  Forall (fun x => p x -> q x) v -> Forall p v -> Forall q v.
Proof.
  induction v; firstorder.
Qed.

Lemma Forall_ext_in {X n} (p q : X -> Prop) (v : t X n) :
  (forall x, In x v -> p x -> q x) -> Forall p v -> Forall q v.
Proof.
  intros H1 H2. induction v; cbn. easy. split. apply H1. constructor.
  apply H2. apply IHv. intros x H3. apply H1. now constructor. apply H2.
Qed.

Lemma Forall_in {X n} (p : X -> Prop) (v : t X n) :
  Forall p v <-> forall x, In x v -> p x.
Proof.
  induction v. easy. split.
  - intros H1 x.
    assert (HIn : forall {n: nat} (x : X) (xs : Vector.t X n), In x xs ->
      match xs with | Vector.nil _ => False | cons _ y _ ys => y = x \/ In x ys end).
    { now intros ??? []; [left|right]. }
    intros ?%HIn. firstorder (now subst).
  - intros H. split. apply H. constructor. apply IHv. intros x H1. apply H. now constructor.
Qed.

Lemma Forall_map {X Y n} (p : Y -> Prop) (f : X -> Y) (v : t X n) :
  Forall p (map f v) <-> Forall (fun x => p (f x)) v.
Proof.
  induction v; firstorder.
Qed.

Lemma map_ext_forall {X Y n} (f g : X -> Y) (v : t X n):
  Forall (fun x => f x = g x) v -> map f v = map g v.
Proof.
  induction v; cbn. reflexivity. intros. f_equal; firstorder.
Qed.

End VectorForall.
Export VectorForall.

#[export]
Instance eqdec_full_logic_sym : eq_dec full_logic_sym.
Proof.
  intros x y. unfold dec. decide equality.
Qed.

#[export]
Instance eqdec_full_logic_quant : eq_dec full_logic_quant.
Proof.
  intros x y. unfold dec. decide equality.
Qed.

Definition L_binop (n : nat) := List.cons Conj (List.cons Impl (List.cons Disj List.nil)).

#[export]
Instance enum_binop :
  list_enumerator__T L_binop binop.
Proof.
  intros []; exists 0; cbn; tauto.
Qed.

Definition L_quantop (n : nat) := List.cons All (List.cons Ex List.nil).

#[export]
Instance enum_quantop :
  list_enumerator__T L_quantop quantop.
Proof.
  intros []; exists 0; cbn; tauto.
Qed.

Lemma enumT_binop :
  enumerable__T binop.
Proof.
  apply enum_enumT. exists L_binop. apply enum_binop.
Qed.

Lemma enumT_quantop :
  enumerable__T quantop.
Proof.
  apply enum_enumT. exists L_quantop. apply enum_quantop.
Qed.

(* ** Elimination for terms *)

Section Elimination.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_pred : preds_signature}.

  Lemma term_ind (p : term -> Prop) :
    (forall n, p (var_indi n))
    -> (forall ar n v (IH : Forall p v), p (func (var_func n ar) v))
    -> (forall f v (IH : Forall p v), p (func (sym f) v))
    -> forall t, p t.
  Proof.
    intros H1 H2 H3. fix term_ind 1. destruct t.
    - apply H1.
    - destruct f.
      + apply H2. induction v.
        * constructor.
        * constructor. apply term_ind. exact IHv.
      + apply H3. induction v.
        * constructor.
        * constructor. apply term_ind. exact IHv.
  Qed.

  Lemma term_ind' (p : term -> Prop) :
    (forall n, p (var_indi n))
    -> (forall ar (f : function ar) v (IH : Forall p v), p (func f v))
    -> forall t, p t.
  Proof.
    intros H1 H2. fix term_ind' 1. destruct t.
    - apply H1.
    - apply H2. clear f. induction v; constructor. apply term_ind'. exact IHv.
  Qed.

End Elimination.

Section FirstorderFragment.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_pred : preds_signature}.
  Context {ops : operators}.

  Fixpoint first_order_term (t : term) := match t with
    | var_indi _ => True
    | func (var_func _) _ => False
    | func (sym f) v => Forall first_order_term v
  end.

  Fixpoint first_order phi := match phi with
    | fal => True
    | atom (pred _) v => Forall first_order_term v
    | atom (var_pred _ _) _ => False
    | bin _ phi psi => first_order phi /\ first_order psi
    | quant_indi _ phi => first_order phi
    | quant_func _ _ _ => False
    | quant_pred _ _ _ => False
  end.

End FirstorderFragment.

Section FunctionFreeFragment.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_pred : preds_signature}.
  Context {ops : operators}.

  Fixpoint funcfreeTerm (t : SOL.term) := match t with
  | var_indi x => True
  | func (var_func _) _ => False
  | func (sym _) v => Forall funcfreeTerm v
  end.

  Fixpoint funcfree (phi : SOL.form) := match phi with
  | atom _ v => Forall funcfreeTerm v
  | fal => True
  | bin _ phi psi => funcfree phi /\ funcfree psi
  | quant_indi _ phi => funcfree phi
  | quant_func _ ar' phi => False
  | quant_pred _ _ phi => funcfree phi
  end.

  Lemma firstorder_funcfree_term t :
    first_order_term t -> funcfreeTerm t.
  Proof.
    now induction t.
  Qed.

  Lemma firstorder_funcfree phi :
    first_order phi -> funcfree phi.
  Proof.
    induction phi; firstorder. now destruct p.
  Qed.

End FunctionFreeFragment.

(* *** Bounds *)

Section Bounded.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_pred : preds_signature}.
  Context {ops : operators}.

  Fixpoint bounded_indi_term n (t : term) := match t with
    | var_indi x => n > x
    | func _ v => Forall (bounded_indi_term n) v
  end.

  Fixpoint bounded_func_term ar n (t : term) := match t with
    | var_indi x => True
    | @func _ ar' (var_func x) v => (n > x \/ ar <> ar') /\ Forall (bounded_func_term ar n) v
    | func (sym _) v => Forall (bounded_func_term ar n) v
  end.

  Fixpoint bounded_indi n (phi : form) := match phi with
    | atom _ v => Forall (bounded_indi_term n) v
    | fal => True
    | bin _ phi psi => bounded_indi n phi /\ bounded_indi n psi
    | quant_indi _ phi => bounded_indi (S n) phi
    | quant_func _ _ phi => bounded_indi n phi
    | quant_pred _ _ phi => bounded_indi n phi
  end.

  Fixpoint bounded_func ar n (phi : form) := match phi with
    | atom _ v => Forall (bounded_func_term ar n) v
    | fal => True
    | bin _ phi psi => bounded_func ar n phi /\ bounded_func ar n psi
    | quant_indi _ phi => bounded_func ar n phi
    | quant_func _ ar' phi => (ar = ar' /\ bounded_func ar (S n) phi) \/ (ar <> ar' /\ bounded_func ar n phi)
    | quant_pred _ _ phi => bounded_func ar n phi
  end.

  Fixpoint bounded_pred ar n (phi : form) := match phi with
    | @atom _ _ _ ar' (var_pred x) _ => n > x \/ ar <> ar'
    | atom (pred _) _ => True
    | fal => True
    | bin _ phi psi => bounded_pred ar n phi /\ bounded_pred ar n psi
    | quant_indi _ phi => bounded_pred ar n phi
    | quant_func _ _ phi => bounded_pred ar n phi
    | quant_pred _ ar' phi => (ar = ar' /\ bounded_pred ar (S n) phi) \/ (ar <> ar' /\ bounded_pred ar n phi)
  end.

  Definition closed phi := bounded_indi 0 phi /\ (forall ar, bounded_func ar 0 phi) /\ (forall ar, bounded_pred ar 0 phi).

  Definition bounded_indi_L n A := forall phi, List.In phi A -> bounded_indi n phi.
  Definition bounded_func_L ar n A := forall phi, List.In phi A -> bounded_func ar n phi.
  Definition bounded_pred_L ar n A := forall phi, List.In phi A -> bounded_pred ar n phi.

  Lemma bounded_indi_term_up n m t :
    m >= n -> bounded_indi_term n t -> bounded_indi_term m t.
  Proof using Σ_pred ops.
    intros H1. induction t; intros H2; cbn in *.
    lia. induction v; firstorder. induction v; firstorder.
  Qed.

  Lemma bounded_func_term_up ar n m t :
    m >= n -> bounded_func_term ar n t -> bounded_func_term ar m t.
  Proof.
    intros H1. induction t; intros H2; cbn in *. easy. split. lia.
    eapply Forall_ext_Forall. apply IH. apply H2.
    eapply Forall_ext_Forall. apply IH. apply H2.
  Qed.

  Lemma bounded_indi_up n m phi :
    m >= n -> bounded_indi n phi -> bounded_indi m phi.
  Proof.
    revert m n. induction phi; intros m n' H1 H2; cbn in *. easy.
    eapply Forall_ext. 2: apply H2. intros v; now apply bounded_indi_term_up.
    firstorder. eapply IHphi. 2: apply H2. lia. all: firstorder.
  Qed.

  Lemma bounded_func_up ar n m phi :
    m >= n -> bounded_func ar n phi -> bounded_func ar m phi.
  Proof.
    revert m n. induction phi; intros m n' H1 H2; cbn in *. easy.
    eapply Forall_ext. 2: apply H2. intros v; now apply bounded_func_term_up.
    1,2,4: firstorder. destruct H2 as [H2|H2].
    - left. split. easy. eapply IHphi. 2: apply H2. lia.
    - right. split. easy. eapply IHphi. 2: apply H2. lia.
  Qed.

  Lemma bounded_pred_up ar n m phi :
    m >= n -> bounded_pred ar n phi -> bounded_pred ar m phi.
  Proof.
    revert m n. induction phi; intros m n' H1 H2; cbn in *. easy.
    destruct p. lia. easy. 1-3: firstorder. destruct H2 as [H2|H2].
    - left. split. easy. eapply IHphi. 2: apply H2. lia.
    - right. split. easy. eapply IHphi. 2: apply H2. lia.
  Qed.

  Lemma funcfree_bounded_func_term t :
    funcfreeTerm t -> forall x ar, bounded_func_term x ar t.
  Proof.
    intros F x ar. induction t; cbn in *; try easy.
    eapply Forall_ext_Forall. apply IH. apply F.
  Qed.

  Lemma funcfree_bounded_func phi :
    funcfree phi -> forall x ar, bounded_func x ar phi.
  Proof.
    intros F. induction phi; intros x ar'; cbn. 1,3-6: firstorder.
    apply Forall_in. intros v H. apply funcfree_bounded_func_term.
    eapply Forall_in in F. apply F. easy.
  Qed.

  Lemma firstorder_bounded_pred phi :
    first_order phi -> forall x ar, bounded_pred x ar phi.
  Proof.
    induction phi; firstorder. now destruct p.
  Qed.

End Bounded.

(* *** Discreteness *)

Section EqDec.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ops : operators}.

  Context `{syms_eq_dec : eq_dec syms}.
  Context `{preds_eq_dec : eq_dec preds}.
  Context `{binop_eq_dec : eq_dec binop}.
  Context `{quantop_eq_dec : eq_dec quantop}.

  Lemma function_eq_dep ar (f1 f2 : function ar) :
    eq_dep _ _ ar f1 ar f2 <-> f1 = f2.
  Proof.
    rewrite <- eq_sigT_iff_eq_dep. split.
    - intros H%Eqdep_dec.inj_pair2_eq_dec. exact H. decide equality.
    - now intros ->.
  Qed.

  Lemma predicate_eq_dep ar (P1 P2 : predicate ar) :
    eq_dep _ _ ar P1 ar P2 <-> P1 = P2.
  Proof.
    rewrite <- eq_sigT_iff_eq_dep. split.
    - intros H%inj_pair2_eq_dec. exact H. decide equality.
    - now intros ->.
  Qed.

  Lemma dec_function_dep ar1 ar2 (f1 : function ar1) (f2 : function ar2) :
    dec (eq_dep _ _ ar1 f1 ar2 f2).
  Proof using syms_eq_dec.
    destruct f1, f2.
    - destruct (PeanoNat.Nat.eq_dec ar ar0) as [->|].
      destruct (PeanoNat.Nat.eq_dec n n0) as [->|].
      left; now apply function_eq_dep.
      right. intros H%eq_sigT_iff_eq_dep%inj_pair2_eq_dec; try congruence. decide equality.
      right; intros H%eq_sigT_iff_eq_dep; congruence.
    - destruct (PeanoNat.Nat.eq_dec ar (ar_syms f)) as [->|].
      right. intros H%eq_sigT_iff_eq_dep%inj_pair2_eq_dec; try congruence. decide equality.
      right. intros H%eq_sigT_iff_eq_dep. inversion H.
    - destruct (PeanoNat.Nat.eq_dec ar (ar_syms f)) as [->|].
      right. intros H%eq_sigT_iff_eq_dep%inj_pair2_eq_dec; try congruence. decide equality.
      right. intros H%eq_sigT_iff_eq_dep. inversion H.
    - destruct (syms_eq_dec f f0) as [->|].
      left; now apply function_eq_dep.
      right. now intros [=]%eq_sigT_iff_eq_dep.
  Qed.

  Lemma dec_predicate_dep ar1 ar2 (P1 : predicate ar1) (P2 : predicate ar2) :
    dec (eq_dep _ _ ar1 P1 ar2 P2).
  Proof using preds_eq_dec.
    destruct P1, P2.
    - destruct (PeanoNat.Nat.eq_dec ar ar0) as [->|].
      destruct (PeanoNat.Nat.eq_dec n n0) as [->|].
      left; now apply predicate_eq_dep.
      right. intros H%eq_sigT_iff_eq_dep%inj_pair2_eq_dec; try congruence. decide equality.
      right; intros H%eq_sigT_iff_eq_dep; congruence.
    - destruct (PeanoNat.Nat.eq_dec ar (ar_preds P)) as [->|].
      right. intros H%eq_sigT_iff_eq_dep%inj_pair2_eq_dec; try congruence. decide equality.
      right. intros H%eq_sigT_iff_eq_dep. inversion H.
    - destruct (PeanoNat.Nat.eq_dec ar (ar_preds P)) as [->|].
      right. intros H%eq_sigT_iff_eq_dep%inj_pair2_eq_dec; try congruence. decide equality.
      right. intros H%eq_sigT_iff_eq_dep. inversion H.
    - destruct (preds_eq_dec P P0) as [->|].
      left; now apply predicate_eq_dep.
      right. now intros [=]%eq_sigT_iff_eq_dep.
  Qed.

  #[export]
  Instance function_eq_dec ar :
    eq_dec (function ar).
  Proof using syms_eq_dec.
    intros f1 f2. destruct (dec_function_dep _ _ f1 f2).
    - left. now apply function_eq_dep.
    - right. now intros H%function_eq_dep.
  Qed.

  #[export]
  Instance predicate_eq_dec ar :
    eq_dec (predicate ar).
  Proof using preds_eq_dec.
    intros P1 P2. destruct (dec_predicate_dep _ _ P1 P2).
    - left. now apply predicate_eq_dep.
    - right. now intros H%predicate_eq_dep.
  Qed.

  #[export]
  Instance term_eq_dec :
    eq_dec term.
  Proof using syms_eq_dec.
    fix IH 1. intros [] []; try (right; congruence).
    - destruct (PeanoNat.Nat.eq_dec n n0) as [->|]. now left. right; congruence.
    - destruct (PeanoNat.Nat.eq_dec ar ar0) as [->|]. 2: right; congruence.
      destruct (function_eq_dec ar0 f f0) as [->|].
      + assert ({v = v0} + {v <> v0}) as [->|]. {
          clear f0. induction v.
          * left. pattern v0. now apply Vector.case0.
          * apply (Vector.caseS' v0). intros.
            destruct (IH h h0) as [->|]. 2: right; congruence.
            destruct (IHv t) as [->|]. now left. right. intros H. apply n0.
            enough (Vector.tl (Vector.cons term h0 n v) = Vector.tl (Vector.cons term h0 n t)) by easy.
            now rewrite H. }
        now left. right. intros H. apply n. inversion H.
        apply inj_pair2_eq_dec in H1. exact H1. decide equality.
      + right. intros H. apply n. inversion H.
        apply inj_pair2_eq_dec in H1. exact H1. decide equality.
  Qed.

  #[export]
  Instance form_eq_dec :
    eq_dec form.
  Proof using syms_eq_dec quantop_eq_dec preds_eq_dec binop_eq_dec.
    induction x; intros []; try (right; congruence).
    - now left.
    - destruct (PeanoNat.Nat.eq_dec ar ar0) as [->|]. 2: right; congruence.
      destruct (predicate_eq_dec ar0 p p0) as [->|].
      + rename t into v. rename t0 into v0. assert ({v = v0} + {v <> v0}) as [->|]. {
          clear p0. induction v.
          * left. pattern v0. now apply Vector.case0.
          * apply (Vector.caseS' v0). intros.
            destruct (term_eq_dec h h0) as [->|]. 2: right; congruence.
            destruct (IHv t) as [->|]. now left. right. intros H. apply n0.
            enough (Vector.tl (Vector.cons term h0 n v) = Vector.tl (Vector.cons term h0 n t)) by easy.
            now rewrite H. }
        now left. right. intros H. apply n. inversion H.
        apply inj_pair2_eq_dec in H1. exact H1. decide equality.
      + right. intros H. apply n. inversion H. apply inj_pair2_eq_dec in H1. exact H1. decide equality.
    - destruct (binop_eq_dec b b0) as [->|]. 2: right; congruence.
      destruct (IHx1 f) as [->|]. 2: right; congruence.
      destruct (IHx2 f0) as [->|]. now left. right; congruence.
    - destruct (quantop_eq_dec q q0) as [->|]. 2: right; congruence.
      destruct (IHx f) as [->|]. now left. right; congruence.
    - destruct (quantop_eq_dec q q0) as [->|]. 2: right; congruence.
      destruct (PeanoNat.Nat.eq_dec n n0) as [->|]. 2: right; congruence.
      destruct (IHx f) as [->|]. now left. right; congruence.
    - destruct (quantop_eq_dec q q0) as [->|]. 2: right; congruence.
      destruct (PeanoNat.Nat.eq_dec n n0) as [->|]. 2: right; congruence.
      destruct (IHx f) as [->|]. now left. right; congruence.
  Qed.

End EqDec.

(* *** Enumerability *)

Require Import List.
Import ListNotations.

#[local] Notation "x 'el' L" := (In x L) (at level 70).
#[local] Notation "[ s | p ∈ A ]" := (map (fun p => s) A) (p pattern).

Ltac in_app n :=
  (match goal with
  | [ |- In _ (_ ++ _) ] =>
    match n with
    | 0 => idtac
    | 1 => eapply in_app_iff; left
    | S ?n => eapply in_app_iff; right; in_app n
    end
  | [ |- In _ (_ :: _) ] => match n with 0 => idtac | 1 => left | S ?n => right; in_app n end
  end) || (repeat (try right; eapply in_app_iff; right)).

Ltac in_collect a :=
  eapply in_map_iff; exists a; split; [ eauto | match goal with [ |- In _ (filter _ _) ] =>  eapply filter_In; split; [ try (rewrite !in_prod_iff; repeat split) ] | _ => try (rewrite !in_prod_iff; repeat split) end ].

Section Enumerability.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_pred : preds_signature}.
  Context {ops : operators}.

  Variable L_Funcs : nat -> list syms.
  Hypothesis enum_Funcs : list_enumerator__T L_Funcs syms.

  Variable L_Preds : nat -> list preds.
  Hypothesis enum_Preds : list_enumerator__T L_Preds preds.

  Variable L_binop : nat -> list binop.
  Hypothesis enum_binop : list_enumerator__T L_binop binop.

  Variable L_quantop : nat -> list quantop.
  Hypothesis enum_quantop : list_enumerator__T L_quantop quantop.

  Fixpoint vecs_from {X} (A : list X) (n : nat) : list (vec X n) :=
    match n with
    | 0 => [Vector.nil X]
    | S n => [ Vector.cons X x _ v | (x, v) ∈ (list_prod A (vecs_from A n)) ]
    end.

  Fixpoint L_nat n : list nat := match n with
    | 0 => [0]
    | S n => S n :: L_nat n
  end.

  Fixpoint L_term n : list term := match n with
    | 0 => []
    | S n => L_term n ++ var_indi n ::
                   concat [[ func (@var_func _ x ar) v | v ∈ vecs_from (L_term n) ar ] | (x, ar) ∈ (list_prod (L_nat n) (L_nat n)) ]
                ++ concat [[ func (@sym _ f) v | v ∈ vecs_from (L_term n) (ar_syms f) ] | f ∈ L_T n]
  end.

  Fixpoint L_form n : list form := match n with
    | 0 => [fal]
    | S n => L_form n
                ++ concat [[ atom (var_pred x ar) v | v ∈ vecs_from (L_term n) ar ] | (x, ar) ∈ (list_prod (L_nat n) (L_nat n)) ]
                ++ concat [[ atom (pred P) v | v ∈ vecs_from (L_term n) (ar_preds P) ] | P ∈ L_T n]
                ++ concat ([ [ bin op phi psi | (phi, psi) ∈ (list_prod (L_form n) (L_form n)) ] | op ∈ L_T n])
                ++ concat ([ [ quant_indi op phi | phi ∈ L_form n ] | op ∈ L_T n])
                ++ concat ([ [ quant_func op ar phi | phi ∈ L_form n ] | (op, ar) ∈ (list_prod (L_T n) (L_nat n))])
                ++ concat ([ [ quant_pred op ar phi | phi ∈ L_form n ] | (op, ar) ∈ (list_prod (L_T n) (L_nat n))])
  end.

  Lemma L_nat_correct n m :
    m <= n -> m el L_nat n.
  Proof.
    induction n.
    - intros H. left. lia.
    - intros H. cbn. assert (m = S n \/ m <= n) as [] by lia; firstorder.
  Qed.

  Lemma list_prod_in X Y (x : X * Y) A B :
      x el (list_prod A B) -> exists a b, x = (a , b) /\ a el A /\ b el B.
  Proof.
    induction A; cbn.
    - intros [].
    - intros [H | H] % in_app_or. 2: firstorder.
      apply in_map_iff in H as (y & <- & Hel). exists a, y. tauto.
  Qed.

  Lemma vecs_from_correct X (A : list X) (n : nat) (v : vec X n) :
    VectorForall.Forall (fun x => x el A) v <-> v el vecs_from A n.
  Proof.
    induction n; cbn.
    - split.
      + intros. left. pattern v. now apply Vector.case0.
      + now intros [<-|[]].
    - split.
      + intros. revert H. apply (Vector.caseS' v). intros. in_collect (h, t); destruct (IHn t).
        apply H. apply H0. apply H.
      + intros Hv. apply in_map_iff in Hv as ([h v'] & <- & (? & ? & [= <- <-] & ? & ?) % list_prod_in).
        split. easy. destruct (IHn v'). now apply H2.
  Qed.

  Lemma vec_forall_cml X (L : nat -> list X) n (v : vec X n) :
    cumulative L -> (VectorForall.Forall (fun x => exists m, x el L m) v) -> exists m, v el vecs_from (L m) n.
  Proof.
    intros HL Hv. induction v; cbn.
    - exists 0. now left.
    - destruct IHv as [m H], Hv as [[m' H'] Hv]. easy.
      exists (m + m'). in_collect (h, v).
      apply (cum_ge' (n:=m')); intuition lia.
      apply vecs_from_correct. rewrite <- vecs_from_correct in H.
      eapply Forall_ext. 2: apply H. cbn.
      intros x Hx. apply (cum_ge' (n:=m)). all: eauto. lia.
  Qed.

  Lemma L_term_cml :
    cumulative L_term.
  Proof.
    intros ?; cbn; eauto.
  Qed.

  Lemma enum_term :
    list_enumerator__T L_term term.
  Proof with eapply cum_ge'; eauto; lia.
    intros t. induction t.
    - exists (S n); cbn. apply in_or_app. right. now left.
    - apply vec_forall_cml in IH as [m H]. 2: exact L_term_cml.
      exists (S (m + n + ar)); cbn. in_app 3. eapply in_concat. eexists. split.
      1: in_collect (n, ar). 1,2: apply L_nat_correct; lia.
      in_collect v. rewrite <- vecs_from_correct in H |-*. eapply Forall_ext.
      2: apply H. cbn. intros...
    - apply vec_forall_cml in IH as [m H]. 2: exact L_term_cml.
      destruct (el_T f) as [m' H']. exists (S (m + m')); cbn.
      in_app 4. eapply in_concat. eexists. split. 1: in_collect f...
      in_collect v. rewrite <- vecs_from_correct in H |-*. eapply Forall_ext.
      2: apply H. cbn. intros...
  Qed.

  Lemma enum_form :
    list_enumerator__T L_form form.
  Proof with eapply cum_ge'; eauto; lia.
    intros phi. induction phi.
    - exists 0. now left.
    - rename t into v. destruct (@vec_forall_cml term L_term _ v) as [m H]; eauto.
      + clear p. induction v. easy. split. apply enum_term. apply IHv.
      + destruct p; cbn.
        * exists (S (m + n + ar)); cbn. in_app 2. eapply in_concat.
          eexists. split. 1: in_collect (n, ar). 1,2: apply L_nat_correct; lia.
          in_collect v. rewrite <- vecs_from_correct in H |-*. eapply Forall_ext.
          2: apply H. cbn. intros...
        * destruct (el_T P) as [m']. exists (S (m + m')); cbn. in_app 3.
          eapply in_concat. eexists. split. 1: in_collect P...
          in_collect v. rewrite <- vecs_from_correct in H |-*. eapply Forall_ext.
          2: apply H. cbn. intros...
    - destruct (el_T b) as [m], IHphi1 as [m1], IHphi2 as [m2].
      exists (1 + m + m1 + m2); cbn. in_app 4. apply in_concat. eexists. split.
      in_collect b... in_collect (phi1, phi2)...
    - destruct (el_T q) as [m], IHphi as [m']. exists (S (m + m')); cbn. in_app 5.
      apply in_concat. eexists. split. in_collect q... in_collect phi...
    - destruct (el_T q) as [m], IHphi as [m']. exists (S (m + m' + n)); cbn.
      in_app 6. apply in_concat. eexists. split. in_collect (q, n).
      eapply cum_ge'; eauto; lia. apply L_nat_correct; lia. in_collect phi...
    - destruct (el_T q) as [m], IHphi as [m']. exists (S (m + m' + n)); cbn.
      in_app 7. apply in_concat. eexists. split. in_collect (q, n).
      eapply cum_ge'; eauto; lia. apply L_nat_correct; lia. in_collect phi...
  Qed.

End Enumerability.

Section Enumerability'.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_pred : preds_signature}.
  Context {ops : operators}.

  Hypothesis enumerable_funcs : enumerable__T syms.
  Hypothesis enumerable_preds : enumerable__T preds.
  Hypothesis enumerable_binop : enumerable__T binop.
  Hypothesis enumerable_quantop : enumerable__T quantop.

  Lemma form_enumerable :
    enumerable__T form.
  Proof using enumerable_quantop enumerable_preds enumerable_funcs enumerable_binop.
    apply enum_enumT.
    apply enum_enumT in enumerable_funcs as [Lf HLf].
    apply enum_enumT in enumerable_preds as [Lp HLp].
    apply enum_enumT in enumerable_binop as [Lb HLb].
    apply enum_enumT in enumerable_quantop as [Lq HLq].
    eexists. apply enum_form.
  Qed.

End Enumerability'.