(******************************************************************************
Markov's inequality.  Based on Wikipedia proof
Copyright 2008 Robert Kam

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

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

You should have received a copy of the GNU Lesser General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
******************************************************************************)

(* sigalg = sigma algebra
   preimg = preimage
   cntabl = countable
   msur = measure function
   msurable = measurable
   simple = simple function
   lebint = Lebesgue integral
   lebint_s = Lebesgue integral for simple function
   borl = Borel set
   unoin = union *)

(******************************************************************************
Note: chicli_pottier_simpson, classic, Extensionality_Ensembles, NNPP are used
frequently
Also lemmas from Rtopology which use classic as well as R_total_order
******************************************************************************)

Require Import Setoid.
Require Export Powerset.
Require Export Rtopology.
Require Export Raxioms.
Require Export Rfunctions.
Require Export Image.
Require Export RIneq.
Require Export PartSum.

Axiom constructive_definite_description:forall(A:Type)(P:A->Prop),
(exists!x:A,P x)->{x:A|P x}.

(******************************************************************************
from Coq.Logic.ChoiceFacts
******************************************************************************)
Lemma chicli_pottier_simpson(P:Prop):P\/~P->{P}+{~P}.
intros EM. pose(select:=fun b:bool=>if b then P else ~P). assert{b:bool|
select b}as([|],HP). apply constructive_definite_description. rewrite<-
unique_existence;split. destruct EM. exists true;trivial. exists false;trivial.
intros[|][|]H1 H2;simpl in *;reflexivity||contradiction. left;trivial. right;
trivial. Qed.

Lemma if_l:forall(A B:Prop)(C:Type)(H:{A}+{B})(x y:C),
~B->(if H then x else y)=x. intuition. Qed.

Lemma if_r:forall(A B:Prop)(C:Type)(H:{A}+{B})(x y:C),
~A->(if H then x else y)=y. intuition. Qed.

Definition cntabl(U:Type)(C:Ensemble(Ensemble U)):=
exists f:nat->Ensemble U,forall c,C c->exists i:nat,f i=c.

(******************************************************************************
from http://cl.cse.wustl.edu/classes/cse545/lec/sni.v
accessed 13 July 2007
******************************************************************************)
Lemma aaron_stump_cse545(Q:nat->Prop):
(forall n:nat,(forall n':nat,n'<n->Q n')->Q n)->
forall n:nat,forall n':nat,n'<=n->Q n'.
(**)
intros sIH n. induction n. intros n' Hn'. apply sIH. intros. elimtype False;
intuition. intuition. Qed.

Lemma first_sat(Q:nat->Prop):forall k:nat,Q k
->exists m:nat,Q m/\forall n:nat,Q n->m<=n.
(**)
intros k. apply aaron_stump_cse545 with(Q:=fun z=>Q z->exists m,Q m/\forall n
,Q n->m<=n)(n:=k). 2:auto. intros n H H1. elim(classic(forall i,i<n->~Q i)).
intro H2. exists n. split. auto. intros j H3. apply NNPP. red;intro H4. apply(
H2 j). intuition. auto.
(**)
intro H2. assert(H3:exists i:nat,i<n/\Q i). apply NNPP. red;intro H3. apply H2.
intros i H4. red;intro H5. apply H3. exists i. auto. elim H3. intros ii H4.
elim(H ii). intros m H5. exists m. auto. tauto. tauto. Qed.

(******************************************************************************
You can actually prove this without using constructive_definite_description,
you can use Yevgeniy Marakov's constructive_indefinite_description_nat from
Coq.Logic.ConstructiveEpsilon, which is purely constructive -- probably don't
even need classic really to do this proof.
******************************************************************************)
Lemma cntabl_P0(U:Type)(C:Ensemble(Ensemble U))
:cntabl _ C->
exists g:forall c,C c->nat,
(forall c c' c'',g c c'=g c c'')
/\forall c cc c' cc',g c c'=g cc cc'->c=cc.
(**)
intros H. elim H. intros f H1. assert(H2:forall c,C c->{i|f i=c/\forall j,f
j=c->i<=j}). intros c H2. apply constructive_definite_description. elim(H1 c).
intros k H3. elim(first_sat(fun i=>f i=c)k). intros m H4. exists m. red. split.
auto. intuition. auto. auto.
(**)
exists(fun c c'=>proj1_sig(H2 c c')). split. intros. elim(proj2_sig(H2 c c')).
elim(proj2_sig(H2 c c'')). intuition. intros c cc c' cc' H3. elim(proj2_sig(H2
c c')). elim(proj2_sig(H2 cc cc')). intros H4 H5 H6 H7. rewrite<-H4. rewrite<-
H6. auto. Qed.

(*-----------------------------------------------------------------------------
The 'other half' of cntabl_P0; just proving two common definitions of
countability equivalent.  g assigns a 'serial number' to each set in the
countable collection, and the two hypotheses say g is proof-irrelevant and
injective.
-----------------------------------------------------------------------------*)
Lemma cntabl_P1(U:Type)(C:Ensemble(Ensemble U))
:forall g:forall c,C c->nat,
(forall c c' c'',g c c'=g c c'')->
(forall c cc c' cc',g c c'=g cc cc'->c=cc)->cntabl _ C.
(**)
intros g g' g''. red. elim(classic(Inhabited _ C)). 2:intro H;exists(fun _:
nat=>Empty_set U);intros;elimtype False;apply H;exists c;auto. intro H. elim H.
intros d d'. assert(Q:forall i,{c|C c/\(forall z z',g z z'=i->c=z)/\((forall z
z',g z z'<>i)->c=d)}). intro. elim(chicli_pottier_simpson(exists z,C z/\forall
z',g z z'=i)(classic(exists z,C z/\forall z',g z z'=i))).
(**)
intro H1. assert(H2:exists!z,C z/\forall z',g z z'=i). elim H1. intros z z'.
exists z. split. auto. intros Z Z'. elim z';elim Z'. intros Z'' Z''' z'' z'''.
apply(g'' z Z z'' Z''). rewrite(Z''' Z''). auto. elim(
constructive_definite_description _ _ H2). intros z z'. elim z'. intros z''
z'''. exists z. split. auto. split. intros Z Z' Z''. apply(g'' z Z z'' Z').
rewrite Z'';auto. intro H3. elimtype False. apply(H3 z z''). auto.
(**)
intro H1. exists d. split. auto. split. intros z z' z''. elimtype False. apply
H1. exists z. split. auto. intro z'''. rewrite<-z''. apply g'. auto.
(**)
exists(fun i=>proj1_sig(Q i)). intros c c'. exists(g c c'). elim(proj2_sig(Q(g
c c'))). intros H1 H2. elim H2;intros H3 H4. eapply H3. intuition. Qed.

Definition unoin(U:Type)(C:Ensemble(Ensemble U)):=
fun x:U=>exists c,C c/\c x.

(*-----------------------------------------------------------------------------
This and the following other two Definitions are the three parts of the
definition of what it means to be a sigma-algebra.
-----------------------------------------------------------------------------*)
Definition sigalg_0(U:Type)(F:Ensemble(Ensemble U)):=
Inhabited _ F.

Definition sigalg_1(U:Type)(F:Ensemble(Ensemble U)):=
forall A:Ensemble U,F A->F(Complement _ A).

Definition sigalg_2(U:Type)(F:Ensemble(Ensemble U)):=
forall C:Ensemble(Ensemble U),Included _ C F->cntabl _ C
->F(unoin _ C).

(*-----------------------------------------------------------------------------
This and the following are simple facts about sigma-algebras: union of two sets
from the sigma-algebra is also in the sigma-algebra, and so on.
-----------------------------------------------------------------------------*)
Lemma sigalg_P0:
forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F),
forall A B:Ensemble U,F A->F B->F(Union _ A B).
(**)
intros U F F' F'' F''' A B A' B'. set(f:=fun i:nat=>if(eq_nat_dec i 0)then A
else B). assert(H:unoin _(fun A=>exists i,f i=A)=Union _ A B). apply(
Extensionality_Ensembles U). split. red. intros x H. elim H. intros c H1. elim
H1. intros H2 H3. elim H2. intros i H4. rewrite<-H4 in H3. red in H3. elim(
eq_nat_dec i 0). intro a. rewrite a in H3. intuition. intro b. assert(H5:(if
eq_nat_dec i 0 then A else B)=B). elim(eq_nat_dec i 0). intuition. auto.
rewrite H5 in H3. intuition.
(**)
red. intros x H. elim H. intros. exists A. split. exists 0. auto. auto. intros.
exists B. split. exists 1. auto. auto. rewrite<-H. apply F'''. red. intros c c'
. elim c'. intros i i'. elim i'. elim(eq_nat_dec i 0). intro a. rewrite a. auto
. intro b. assert(H1:f i=B). unfold f. elim(eq_nat_dec i 0). intuition. auto.
rewrite H1. auto. red. exists f. auto. Qed.

Lemma sigalg_P1:
forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F),
F(Empty_set _).
(**)
intros. elim F'. intros A A'. cut(Empty_set U=Complement _(Union _ A(Complement
_ A))). intro H. rewrite H. apply F''. apply(sigalg_P0 _ F F' F'' F'''). auto.
apply F''. auto.
(**)
apply Extensionality_Ensembles. split. intuition. red. intros x x'. elimtype
False. elim(classic(A x)). intuition. intuition. Qed.

Lemma sigalg_P2:
forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F),
forall(A B:Ensemble U),F A->F B->F(Intersection _ A B).
(**)
intros U F F' F'' F''' A B A' B'. cut(Intersection _ A B=Complement _(Union _(
Complement _ A)(Complement _ B))). intro H. rewrite H. apply F''. apply(
sigalg_P0 _ F F' F'' F'''). apply F''. auto. apply F''. auto.
(**)
apply Extensionality_Ensembles. split. red. unfold Complement;unfold In;unfold
not. intros x x' x''. elim(Intersection_inv _ _ _ _ x'). elim(Union_inv _ _ _ _
x''). auto. auto. split. apply NNPP. auto with sets. apply NNPP. auto with sets
. Qed.

Lemma sigalg_P3:
forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F),
F(Full_set U).
(**)
intros. cut(Full_set U=Complement _(Empty_set U)). intro H. rewrite H. apply
F''. apply(sigalg_P1 _ F F' F'' F'''). apply Extensionality_Ensembles. split.
red. unfold Complement;unfold In. intuition. red. intros. apply Full_intro. Qed
.

Inductive borl(D:Ensemble R):Prop:=
|borl_0:open_set D->borl D
|borl_1:borl(Complement _ D)->borl D
|borl_2:forall C:Ensemble(Ensemble R),(forall c,C c->borl c)
->cntabl _ C->D=_D(unoin _ C)->borl D.

Definition preimg(U:Type)(f:U->R)(D:Ensemble R):=
fun x:U=>D(f x).

Definition msurable(U:Type)(F:Ensemble(Ensemble U))
(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':sigalg_2 _ F)
(f:U->R):=forall(D:Ensemble R),borl D->F(preimg _ f D).

(*-----------------------------------------------------------------------------
helper for msurable_P1; i forget exactly what its for
-----------------------------------------------------------------------------*)
Lemma msurable_P0:
(forall(U:Type),
forall a:R,forall f:U->R,
let P:=fun i:nat=>fun x:U=>a<=f x<=a+INR i in
(fun x:U=>exists j:nat,P j x)=fun x:U=>f x>=a)%R.
(**)
intros. apply(Extensionality_Ensembles U). split. red;unfold In. intros x x'.
elim x'. unfold P. intuition. red;unfold In. intros x x'. unfold P. elim(
archimed(f x-a)). intros H H1;clear H1. induction(up(f x-a)). simpl in H.
elimtype False. apply(Rlt_not_ge(f x-a)0). auto. apply(Rplus_ge_reg_l a).
replace(a+(f x-a))%R with(f x). 2:ring. replace(a+0)%R with a. 2:ring. auto.
(**)
exists(nat_of_P p). split. intuition. unfold IZR in H. rewrite <- INR_IPR in H. apply Rge_le. apply Rgt_ge.
apply(Rplus_gt_reg_l(-a)%R). replace(-a+(a+INR(nat_of_P p)))%R with (INR(
nat_of_P p)). 2:ring. replace(-a+f x)%R with(f x-a)%R. 2:ring. auto.
(**)
unfold IZR in H; rewrite <- INR_IPR in H. elimtype False. apply(Rlt_not_ge(f x-a)0). apply Rgt_trans with(-
INR(nat_of_P p))%R. intuition. auto. apply(Rplus_ge_reg_l a). replace(a+(f x-a)
)%R with(f x). 2:ring. replace(a+0)%R with a. 2:ring. auto. Qed.

(*-----------------------------------------------------------------------------
That 'f(x)>=a' set which is central to the proof (and statement) of Markov's
inequality is indeed measurable.
-----------------------------------------------------------------------------*)
Lemma msurable_P1:
(forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F'''
:sigalg_2 _ F)(f:U->R)(f':forall x:U,f x>=0)(f'':msurable _ _ F' F'' F''' f),
forall a:R,0<a->F(fun x:U=>f x>=a))%R.
(**)
intros U F F' F'' F''' f f' f'' a a'. rewrite<-(msurable_P0 _ a f). set(P:=fun
i=>fun x=>(a<=f x<=a+INR i)%R). set(C:=fun A=>exists i,P i=A). assert(H:unoin _
C=fun x=>exists i,P i x%R). apply(Extensionality_Ensembles U). split. red.
intros x H. elim H. intros c H1. elim H1. intros H2 H3. elim H2. intros i H4.
red. exists i. rewrite<-H4 in H3. auto. red. intros x H. elim H. intros i H1.
red;red. exists(P i). split. exists i. auto. auto.
(**)
unfold P in H. rewrite<-H. apply F'''. intros c c'. elim c'. intros i i'.
rewrite<-i'. apply f'' with(D:=fun x=>(a<=x<=a+INR i)%R). apply borl_1. apply
borl_0. apply compact_P2. apply compact_P3. red. exists P. intuition. Qed.

Definition msur_0
(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F)(u:forall A,F A->R):=
u(Empty_set _)(sigalg_P1 U F F' F'' F''')=0%R.

(*-----------------------------------------------------------------------------
Countable additivity.  C is the countable collection, g is again the injective
proof-irrelevant serial number mapping, and us is a list of the measures of the
sets in the collection (sprinkled with zeroes throughout).
-------------------------------------------------------------------------------
One note that might be interesting is that even though the hypotheses about
'us' 'force' the measure function u to be compatible when dealing with sets
that are actually in C (as opposed to sets in the sigma-algebra F which are not
known for sure if they are in C), one cannot generally prove (I think) that the
measure function u is compatible from the hypotheses given here.  This was kind
of a stumbling block and why I eventually had to add the 'msur_3' axiom below.
-----------------------------------------------------------------------------*)
Definition msur_1
(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F)(u:forall A,F A->R):=
forall C:Ensemble(Ensemble U),
forall C1:Included _ C F,
forall C2:forall c cc,C c->C cc->c<>cc->Disjoint _ c cc,
forall g:forall c,C c->nat,
forall g1:forall c c' c'',g c c'=g c c'',
forall g2:forall c cc c' cc',g c c'=g cc cc'->c=cc,
forall us:nat->R,
(forall c c',us(g c c')=u c(C1 _ c'))->
(forall n:nat,(forall c c',n<>g c c')->us n=0%R)->
forall l,infinit_sum us l->l
=u(unoin _ C)(F''' C C1(cntabl_P1 _ _ g g1 g2)).

(*-----------------------------------------------------------------------------
probability spaces have measure 1
-----------------------------------------------------------------------------*)
Definition msur_2
(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F)(u:forall A,F A->R):=
u (Full_set U) (sigalg_P3 U F F' F'' F''')=1%R.

Definition msur_3
(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F)(u:forall A,F A->R):=
forall A A' A'',u A A'=u A A''.

Definition simple_0(U:Type)(n:nat)(v:nat->R)(w:nat->Ensemble U)
:=forall i j:nat,i<>j->Disjoint _(w i)(w j).

Definition simple_1(U:Type)(n:nat)(v:nat->R)(w:nat->Ensemble U)
:=forall x:U,exists i:nat,i<n/\w i x.

(*-----------------------------------------------------------------------------
the list of range values for a simple function doesnt HAVE to be injective, but
i thought itd be nice
-----------------------------------------------------------------------------*)
Definition simple_2(U:Type)(n:nat)(v:nat->R)(w:nat->Ensemble U)
:=forall i j:nat,v i=v j->i=j.

Definition simple_3(U:Type)(n:nat)(v:nat->R)(w:nat->Ensemble U)
:=forall i:nat,(v i>=0)%R.

(*-----------------------------------------------------------------------------
constructive 'get_index_of'-type function
-----------------------------------------------------------------------------*)
Definition simple_P0
(U:Type)(n:nat)(v:nat->R)(w:nat->Ensemble U):simple_0 _ n v w->simple_1 _ n v w
->simple_2 _ n v w->simple_3 _ n v w->
forall x:U,{i:nat|i<n/\w i x/\forall i',w i' x->i'=i}.
(**)
intros S0 S1 S2 S3 x. assert(H:exists!i:nat,i<n/\w i x/\forall i',w i'
x->i'=i). elim(S1 x). intros i H. elim H. intros H1 H2. exists i. split. split.
auto. split. auto. intros i' H3. apply NNPP. unfold not;intro H4. elim(S0 i i')
. intro H5. apply(H5 x). intuition. auto. intuition. apply
constructive_definite_description. auto. Defined.

Lemma simple_P1:
forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F)(n:nat)(v:nat->R)(w:nat->Ensemble U)(S0:simple_0 _ n v w)(S1:
simple_1 _ n v w)(S2:simple_2 _ n v w)(S3:simple_3 _ n v w),
msurable _ _ F' F'' F''' (fun x:U=>v(proj1_sig(simple_P0 _ n v w S0 S1 S2 S3 x)
))->forall i:nat,F(w i).
(**)
intros U F F' F'' F''' n v w S0 S1 S2 S3 M i. assert(H:w i=preimg _(fun x:U=>v(
proj1_sig(simple_P0 _ _ _ _ S0 S1 S2 S3 x)))(fun r:R=>v i<=r<=v i)%R). apply
Extensionality_Ensembles. split. red. red. red. intros x H1. elim(simple_P0 _ n
v w S0 S1 S2 S3 x). simpl. intros j H2. elim H2. intros H3 H4. elim H4.
intros H5 H6. elim(H6 i). intuition. auto.
(**)
red. unfold preimg;unfold In. intros x H1. rewrite(S2 i (proj1_sig(simple_P0 _
n v w S0 S1 S2 S3 x))). 2:intuition. elim(simple_P0 _ n v w S0 S1 S2 S3 x).
simpl. intuition. rewrite H. apply M. apply borl_1. apply borl_0. apply
compact_P2. apply compact_P3. Qed.

Lemma simple_P4:
forall(U:Type)(A:Ensemble U),
simple_0 _ 2(fun i:nat=>INR i)(fun i:nat=>if eq_nat_dec i 0 then Complement _ A
else if eq_nat_dec i 1 then A else Empty_set _).
(**)
intros. red. intros i j H. split. intro x. red. intro H1. elim H1. intros y H2
H3. elim(eq_nat_dec i 0). intro a. rewrite a in H2. simpl in H2. elim(
eq_nat_dec j 0). intuition. intro bb. rewrite(if_r _ _ _(eq_nat_dec j 0)(
Complement _ A)(if eq_nat_dec j 1 then A else Empty_set _)bb)in H3. elim(
eq_nat_dec j 1). intro aaa. rewrite aaa in H3. simpl in H3. auto. intro bbb.
rewrite(if_r _ _ _(eq_nat_dec j 1)A(Empty_set _)bbb)in H3. elim H3.
(**)
intro b. rewrite(if_r _ _ _(eq_nat_dec i 0)(Complement _ A)(if eq_nat_dec i 1
then A else Empty_set _)b)in H2. elim(eq_nat_dec i 1). intro aa. rewrite aa in
H2. simpl in H2. elim(eq_nat_dec j 0). intro aaa. rewrite aaa in H3. simpl in
H3. auto. intro bbb. rewrite(if_r _ _ _(eq_nat_dec j 0)(Complement _ A)(if
eq_nat_dec j 1 then A else Empty_set _)bbb)in H3. elim(eq_nat_dec j 1).
intuition. intro bbbb. rewrite(if_r _ _ _(eq_nat_dec j 1)A(Empty_set _)bbbb) in
H3. elim H3. intro bb. rewrite(if_r _ _ _(eq_nat_dec i 1)A(Empty_set _)bb)in H2
. elim H2. Qed.

Lemma simple_P5:
forall(U:Type)(A:Ensemble U),
simple_1 _ 2(fun i:nat=>INR i)(fun i:nat=>if eq_nat_dec i 0 then Complement _ A
else if eq_nat_dec i 1 then A else Empty_set _).
(**)
intros. red. intro x. elim(classic(A x)). intro. exists 1. auto. intro. exists
0. auto. Qed.

Lemma simple_P6:
forall(U:Type)(A:Ensemble U),
simple_2 _ 2(fun i:nat=>INR i)(fun i:nat=>if eq_nat_dec i 0 then Complement _ A
else if eq_nat_dec i 1 then A else Empty_set _).
(**)
intros. red. intuition. Qed.

Lemma simple_P7:
forall(U:Type)(A:Ensemble U),
simple_3 _ 2(fun i:nat=>INR i)(fun i:nat=>if eq_nat_dec i 0 then Complement _ A
else if eq_nat_dec i 1 then A else Empty_set _).
(**)
intros. red. intuition. Qed.

Lemma simple_P8:
forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F),
forall A:Ensemble U,F A->
let n:=2 in
let v:=fun i:nat=>INR i in
let w:=fun i:nat=>if eq_nat_dec i 0 then Complement _ A else if
eq_nat_dec i 1 then A else Empty_set _ in
msurable _ _ F' F'' F''' (fun x:U=>v(proj1_sig(simple_P0 _ n v w
(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _) x))).
(**)
intros U F F' F'' F''' A A' n v w. set(I:=simple_P0 _ _ _ _(simple_P4 _ A)(
simple_P5 _ A)(simple_P6 _ A)(simple_P7 _ A)). fold n v w in I. assert(V:forall
x:U,v(proj1_sig(I x))=0%R\/v(proj1_sig(I x))=1%R). intro. elim(eq_nat_dec(
proj1_sig(I x))0). intro a. rewrite a;auto. intro b. elim(eq_nat_dec(proj1_sig(
I x))1). intro a. rewrite a;auto. intro c. elimtype False. elim(proj2_sig(I x))
. intuition.
(**)
assert(Z0:forall x:U,v(proj1_sig(I x))=0%R->(Complement _ A)x). intros. assert(
Z:proj1_sig(I x)=0). apply(simple_P6 _ A). auto. elim(proj2_sig(I x)). rewrite
Z;intuition. assert(Z1:forall x:U,v(proj1_sig(I x))=1%R->A x). intros. assert(Z
:proj1_sig(I x)=1). apply(simple_P6 _ A). auto. elim(proj2_sig(I x)). rewrite Z
;intuition.
(**)
assert(Q0:forall x:U,~A x->v(proj1_sig(I x))=0%R). intros. assert(Q:w 0 x).
auto. elim(proj2_sig(I x)). intros q1 q2. elim q2. intros q3 q4. rewrite<-(q4 0
Q). auto. assert(Q1:forall x:U,A x->v(proj1_sig(I x))=1%R). intros. assert(Q:w
1 x). auto. elim(proj2_sig(I x)). intros q1 q2. elim q2. intros q3 q4. rewrite
<-(q4 1 Q). auto.
(**)
red. fold I. intros D B. unfold preimg. elim(classic(D(INR 0))). elim(classic(D
(INR 1))). intros H1 H0. cut(Full_set _=fun x=>D(v(proj1_sig(I x)))). intro H.
rewrite<-H. apply sigalg_P3. elim F'. intros x K;exists x;auto. auto. auto.
apply Extensionality_Ensembles. split. red. intros x H. clear H. red. elim(
classic(A x)). intro H. rewrite(Q1 x H). auto. intro H. rewrite(Q0 x H). auto.
red. intros. apply Full_intro. intros H1 H0. cut(Complement _ A=fun x=>D(v(
proj1_sig(I x)))). intro H. rewrite<-H. apply F''. auto. apply
Extensionality_Ensembles. split. red. intros x H. red. elim(V x). intro HH.
rewrite HH. auto. intro. elimtype False. apply H. red. apply Z1. auto. red.
intros x H. red in H. elim(V x). intro. red. apply Z0. auto. intro HH. rewrite
HH in H. intuition.
(**)
elim(classic(D(INR 1))). intros H1 H0. cut(A=fun x=>D(v(proj1_sig(I x)))).
intro H. rewrite<-H. auto. apply Extensionality_Ensembles. split. red. intros x
H. red. rewrite(Q1 x H). auto. red. intros x H. red in H. elim(V x). intro HH.
rewrite HH in H. intuition. intuition. intros H1 H0. cut(Empty_set _=fun x=>D(v
(proj1_sig(I x)))). intro H. rewrite<-H. apply sigalg_P1. elim F'. intros x K;
exists x;auto. auto. auto. apply Extensionality_Ensembles. split. intuition.
red. intros x H. red in H. elim(V x). intro HH. rewrite HH in H. intuition.
intro HH. rewrite HH in H. intuition. Qed.

Lemma simple_P9:
(forall(U:Type)(n:nat)(v:nat->R)(w:nat->Ensemble U)(S0:simple_0 _ n v w)(S1:
simple_1 _ n v w)(S2:simple_2 _ n v w)(S3:simple_3 _ n v w),
forall c:R,0<c->simple_0 _ n (fun i:nat=>v i*c)w)%R. auto. Qed.

Lemma simple_P10:
(forall(U:Type)(n:nat)(v:nat->R)(w:nat->Ensemble U)(S0:simple_0 _ n v w)(S1:
simple_1 _ n v w)(S2:simple_2 _ n v w)(S3:simple_3 _ n v w),
forall c:R,0<c->simple_1 _ n (fun i:nat=>v i*c)w)%R. auto. Qed.

Lemma simple_P11:
(forall(U:Type)(n:nat)(v:nat->R)(w:nat->Ensemble U)(S0:simple_0 _ n v w)(S1:
simple_1 _ n v w)(S2:simple_2 _ n v w)(S3:simple_3 _ n v w),
forall c:R,0<c->simple_2 _ n (fun i:nat=>v i*c)w)%R.
(**)
intros. red. intros i j Z. apply S2. apply(Rmult_eq_reg_l c). rewrite
Rmult_comm. rewrite Z. intuition. apply Rgt_not_eq. auto. Qed.

Lemma simple_P12:
(forall(U:Type)(n:nat)(v:nat->R)(w:nat->Ensemble U)(S0:simple_0 _ n v w)(S1:
simple_1 _ n v w)(S2:simple_2 _ n v w)(S3:simple_3 _ n v w),
forall c:R,0<c->simple_3 _ n (fun i:nat=>v i*c) w)%R.
(**)
intros. red. intro. replace 0%R with(0*c)%R. 2:ring. apply Rmult_ge_compat_r.
apply Rle_ge. intuition. auto. Qed.

Lemma simple_P13:
(forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F'''
:sigalg_2 _ F)(n:nat)(v:nat->R)(w:nat->Ensemble U)(S0:simple_0 _ n v w)(S1:
simple_1 _ n v w)(S2:simple_2 _ n v w)(S3:simple_3 _ n v w)(M:msurable _ _ F'
F'' F''' (fun x:U=>v(proj1_sig(simple_P0 _ n v w S0 S1 S2 S3 x)
))),
forall c:R,forall c':0<c,msurable _ _ F' F'' F''' (fun x:U=>(fun i:nat=>v i*c)(
proj1_sig(simple_P0 _ n (fun i:nat=>v i*c) w (simple_P9 _ n v w S0 S1 S2 S3 c
c')(simple_P10 _ n v w S0 S1 S2 S3 c c')(simple_P11 _ n v w S0 S1 S2 S3 c c')(
simple_P12 _ n v w S0 S1 S2 S3 c c') x))))%R.
(**)
intros. red. intros D D'. set(I:=simple_P0 _ n(fun i:nat=>v i*c)%R w(simple_P9
_ _ _ _ S0 S1 S2 S3 c c')(simple_P10 _ _ _ _ S0 S1 S2 S3 c c')(simple_P11 _ _ _
_ S0 S1 S2 S3 c c')(simple_P12 _ _ _ _ S0 S1 S2 S3 c c')). unfold preimg.
assert(H:forall i:nat,{D(v i*c)%R}+{~D(v i*c)%R}). intro. apply
chicli_pottier_simpson. apply classic. set(W:=fun i=>if H i then w i else
Empty_set _). set(C:=fun z=>exists i:nat,z=W i). cut(unoin _ C=fun x=>D(v(
proj1_sig(I x))*c)%R). intro H1. rewrite<-H1. apply F'''. red. intros z H2. red
in H2;red in H2;unfold W in H2. elim H2. intros i H3. red. rewrite H3. elim(H i
). intro. apply(simple_P1 _ _ _ _ _ _ _ _ _ _ _ _ M i). intro. apply(sigalg_P1
_ _ F' F'' F'''). red. exists W. intros z H2. red in H2. elim H2. intros i H3.
exists i. auto.
(**)
apply(Extensionality_Ensembles U). split. red. intros x H1. red. red in H1;red
in H1;unfold C in H1. elim H1. intros z H2. elim H2. intros H3 H4. elim H3.
intros i H5. unfold W in H5. rewrite H5 in H4. elim(H i). intro H6. assert(H7:~
~D(v i*c)%R). auto. rewrite(if_l _ _ _(H i)(w i)(Empty_set _)H7)in H4. elim(
proj2_sig(I x)). intros H8 H9. elim H9. intros H10 H11. rewrite<-(H11 i H4).
auto. intro H6. rewrite(if_r _ _ _(H i)(w i)(Empty_set _)H6)in H4. intuition.
(**)
red. intros x H1. red. red. red in H1. exists(w(proj1_sig(I x))). unfold C.
split. exists(proj1_sig(I x)). unfold W. elim(proj2_sig(I x)). intros H2 H3.
assert(H4:~~D(v(proj1_sig(I x))*c)%R). auto. exact(sym_eq(if_l _ _ _(H(
proj1_sig(I x)))(w(proj1_sig(I x)))(Empty_set _)H4)). elim(proj2_sig(I x)).
intuition. Qed.

Definition lebint_s
(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F)(u:forall A,F A->R)(u':msur_0 _ _ F' F'' F''' u)(u'':msur_1 _ _ F'
F'' F''' u)(u''':msur_2 _ _ F' F'' F''' u)(u'''':msur_3 _ _ F' F'' F''' u)(n:
nat)(v:nat->R)(w:nat->Ensemble U)(S0:simple_0 _ n v w)(S1:simple_1 _ n v w)(S2:
simple_2 _ n v w)(S3:simple_3 _ n v w)(M:msurable _ _ F' F'' F'''(fun x:U=>v(
proj1_sig(simple_P0 _ n v w S0 S1 S2 S3 x))))(E:Ensemble U)(E':F E)
:=sum_f_R0 (fun i:nat=>((v i)*(u(Intersection _(w i)E)(sigalg_P2 _ _ F' F''
F'''(w i)E(simple_P1 _ _ F' F'' F''' n v w S0 S1 S2 S3 M i)E')))%R) n.

Definition lebint
(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F)(u:forall A,F A->R)(u':msur_0 _ _ F' F'' F''' u)(u'':msur_1 _ _ F'
F'' F''' u)(u''':msur_2 _ _ F' F'' F''' u)(u'''':msur_3 _ _ F' F'' F''' u)(f:U
->R)(f':forall x:U,(f x>=0)%R)(M:msurable _ _ F' F'' F''' f)(E:Ensemble U)(E':F
E)
:=let B:=fun l=>forall n,forall v,forall w,forall S0,forall S1,forall S2,forall
S3,forall M',(forall x:U,(0<=(fun y:U=>v(proj1_sig(simple_P0 _ n v w S0 S1 S2
S3 y)))x<=f x)%R)->(lebint_s _ _ _ _ _ u u' u'' u''' u'''' n v w S0 S1 S2 S3 M'
E E'<=l)%R in fun L=>B L/\forall L',B L'->(L'<=L)%R.

(*-----------------------------------------------------------------------------
A simple function that is less than or equal to a general function g
everywhere, has its Lebesgue integral less than or equal to the Lebesgue
integral of the general function g.  This fact is true for nonsimple functions
too, but we just prove only what we need for the final theorem.
-----------------------------------------------------------------------------*)
Lemma lebint_P0:
(forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F'''
:sigalg_2 _ F)(u:forall A,F A->R)(u':msur_0 _ _ F' F'' F''' u)(u'':msur_1 _ _
F' F'' F''' u)(u''':msur_2 _ _ F' F'' F''' u)(u'''':msur_3 _ _ F' F'' F''' u)(n
:nat)(v:nat->R)(w:nat->Ensemble U)(S0:simple_0 _ n v w)(S1:simple_1 _ n v w)(S2
:simple_2 _ n v w)(S3:simple_3 _ n v w)(M:msurable _ _ F' F'' F'''(fun x:U=>v(
proj1_sig(simple_P0 _ n v w S0 S1 S2 S3 x))))(g:U->R)(g':forall x:U,g x>=0)(g''
:msurable _ _ F' F'' F''' g)(E:Ensemble U)(E':F E),
(forall y:U,(fun x:U=>v(proj1_sig(simple_P0 _ n v w S0 S1 S2 S3 x)))y<=g y)->
forall L,lebint _ _ _ _ _ u u' u'' u''' u'''' g g' g'' E E' L->lebint_s _ _ F'
F'' F''' u u' u'' u''' u'''' n v w S0 S1 S2 S3 M E E'<=L)%R.
(**)
intros U F F' F'' F''' u u' u'' u''' u'''' n v w S0 S1 S2 S3 M g g' g'' E E' H
L H1. elim H1. intros H2 H3. apply H2. split. apply Rge_le. apply S3. apply H.
Qed.

Lemma u_cmp:
forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F)(u:forall A,F A->R)(u'''':msur_3 _ _ F' F'' F''' u)A B A' B',
A=B->u A A'=u B B'.
(**)
intros U F F' F'' F''' u u'''' A B A' B' H. generalize B'. rewrite<-H. apply
u''''. Qed.

(*-----------------------------------------------------------------------------
The Lebesgue integral of an indicator function is just the measure of the event
interval.
-----------------------------------------------------------------------------*)
Lemma lebint_P1:
forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F''':
sigalg_2 _ F)(u:forall A,F A->R)(u':msur_0 _ _ F' F'' F''' u)(u'':msur_1 _ _ F'
F'' F''' u)(u''':msur_2 _ _ F' F'' F''' u)(u'''':msur_3 _ _ F' F'' F''' u)(f:U
->R)(f':forall x:U,(f x>=0)%R)(f'':msurable _ _ F' F'' F''' f)(E:Ensemble U)(E'
:F E),
forall(A:Ensemble U)(A':F A)(A'':Included _ A E),
lebint_s _ _ F' F'' F''' u u' u'' u''' u'''' 2(fun i:nat=>INR i)(fun i:nat=>if
eq_nat_dec i 0 then Complement _ A else if eq_nat_dec i 1 then A else Empty_set
_)(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)(simple_P8 _ _ F'
F'' F''' A A')E E'=u A A'.
(**)
intros. unfold lebint_s. simpl. assert(H:Intersection _(Empty_set U)E=Empty_set
U). apply Extensionality_Ensembles. split. red. intros x H1. elim H1. auto. red
. intros. split. auto. red in H. intuition.
(**)
replace(u(Intersection _(Empty_set _)E)(sigalg_P2 U F F' F'' F'''(Empty_set U)E
(simple_P1 U F F' F'' F''' 2(fun i=>INR i)(fun i=>if eq_nat_dec i 0 then
Complement _ A else if eq_nat_dec i 1 then A else Empty_set _)(simple_P4 _ A)(
simple_P5 _ A)(simple_P6 _ A)(simple_P7 _ A)(simple_P8 _ _ F' F'' F''' A A')2)
E'))with(u(Empty_set _)(sigalg_P1 _ _ F' F'' F''')). 2:apply sym_eq. 2:apply(
u_cmp U F F' F'' F''' u u''''(Intersection _(Empty_set _)E)(Empty_set _)). 2:
exact H. replace(u(Empty_set _)(sigalg_P1 _ F F' F'' F'''))with 0%R.
(**)
replace(0*u(Intersection _(Complement _ A)E)(sigalg_P2 U F F' F'' F'''(
Complement _ A)E(simple_P1 U F F' F'' F''' 2(fun i=>INR i)(fun i=>if eq_nat_dec
i 0 then Complement _ A else if eq_nat_dec i 1 then A else Empty_set _)(
simple_P4 _ A)(simple_P5 _ A)(simple_P6 _ A)(simple_P7 _ A)(simple_P8 _ _ F'
F'' F''' A A')0)E'))%R with 0%R.
(**)
2:apply sym_eq. 2:apply Rmult_eq_0_compat_r. 2:auto. rewrite Rplus_0_l. rewrite
Rmult_1_l. replace((1+1)*0)%R with 0%R. 2:ring. rewrite Rplus_0_r.
(**)
apply(u_cmp U F F' F'' F''' u u''''(Intersection _ A E)A). apply
Extensionality_Ensembles. split. red. intros x H1. elim H1. auto. intuition.
Qed.

Lemma misc_P0
(U:Type)(f:U->R)(f':forall x:U,(f x>=0)%R)
:forall a:R,(0<a)%R->forall x:U,((fun y:U=>(f y*a))x>=0)%R.
(**)
intros a a' x. rewrite<-(Rmult_0_l a). apply Rle_ge. apply
Rmult_le_compat_r. red. auto. apply Rge_le. auto. Qed.

(******************************************************************************
Latter half of this proof adapted from scal_sum in Coq.Reals.PartSum
******************************************************************************)
(*-----------------------------------------------------------------------------
For a simple function s and constant c, integral(c*s)=c*integral(s).
-----------------------------------------------------------------------------*)
Lemma lebint_P2:
(forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F'''
:sigalg_2 _ F)(u:forall A,F A->R)(u':msur_0 _ _ F' F'' F''' u)(u'':msur_1 _ _
F' F'' F''' u)(u''':msur_2 _ _ F' F'' F''' u)(u'''':msur_3 _ _ F' F'' F''' u)(n
:nat)(v:nat->R)(w:nat->Ensemble U)(S0:simple_0 _ n v w)(S1:simple_1 _ n v w)(S2
:simple_2 _ n v w)(S3:simple_3 _ n v w)(M:msurable _ _ F' F'' F'''(fun x:U=>v(
proj1_sig(simple_P0 _ n v w S0 S1 S2 S3 x))))(E:Ensemble U)(E':F E),
forall(c:R)(c':0<c),lebint_s _ _ _ _ _ u u' u'' u''' u'''' n(fun i:nat=>v i*c)w
(simple_P9 _ n v w S0 S1 S2 S3 c c')(simple_P10 _ n v w S0 S1 S2 S3 c c')(
simple_P11 _ n v w S0 S1 S2 S3 c c')(simple_P12 _ n v w S0 S1 S2 S3 c c')(
simple_P13 _ _ F' F'' F''' n v w S0 S1 S2 S3 M c c') E E' =
c*lebint_s _ _ _ _ _ u u' u'' u''' u'''' n v w S0 S1 S2 S3 M E E')%R.
(**)
intros. unfold lebint_s. cut(forall(An Bn:nat->R)(N:nat)(x:R),(forall i,Bn i=(x
*An i)%R)->(x*sum_f_R0 An N)%R=sum_f_R0 Bn N). intro H. apply sym_eq. apply H.
(**)
intro. rewrite Rmult_assoc. rewrite Rmult_comm. rewrite Rmult_assoc. apply
Rmult_eq_compat_l. rewrite Rmult_comm. apply Rmult_eq_compat_l. apply(u_cmp U F
F' F'' F''' u u''''). auto.
(**)
intros An Bn N x H. induction N as[|N HrecN]. simpl. auto. do 2 rewrite tech5.
rewrite Rmult_plus_distr_l. rewrite<-HrecN. apply Rplus_eq_compat_l. apply
sym_eq. apply H. Qed.

Theorem markov:
(forall(U:Type)(F:Ensemble(Ensemble U))(F':sigalg_0 _ F)(F'':sigalg_1 _ F)(F'''
:sigalg_2 _ F)(u:forall A,F A->R)(u':msur_0 _ _ F' F'' F''' u)(u'':msur_1 _ _
F' F'' F''' u)(u''':msur_2 _ _ F' F'' F''' u)(u'''':msur_3 _ _ F' F'' F''' u)(f
:U->R)(f':forall x:U,f x>=0)(f'':msurable _ _ F' F'' F''' f)(a:R)(a':0<a),
forall L,lebint _ _ _ _ _ u u' u'' u''' u'''' f f' f''(Full_set U)(sigalg_P3 U
F F' F'' F''') L
->u(fun x:U=>f x>=a)(msurable_P1 _ _ F' F'' F''' f f' f'' a a')<=/a*L)%R.

intros U F F' F'' F''' u u' u'' u''' u'''' f f' f'' a a' L L'.
apply(Rmult_le_reg_l a). auto.
replace(a*(/a*L))%R with L.
2:rewrite<-Rmult_assoc. 2:rewrite Rinv_r. 2:ring. 2:auto with real.
set(A:=(fun x:U=>f x>=a)%R).
set(A':=msurable_P1 U F F' F'' F''' f f' f'' a a').
set(v:=fun i:nat=>INR i).
set(w:=fun i:nat=>if eq_nat_dec i 0 then Complement _ A
       else if eq_nat_dec i 1 then A else Empty_set _).
set(I:=lebint_s U F F' F'' F''' u u' u'' u''' u'''' 2 v w
       (simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)
       (simple_P8 _ _ F' F'' F''' A A')(Full_set _)
       (sigalg_P3 U F F' F'' F''')).

replace(u A A')with I.
2:unfold I.
2:unfold w.
2:apply lebint_P1 with(f:=f). 2:auto. 2:auto.
2:red. 2:intros. 2:apply Full_intro.

replace(a*I)%R with(lebint_s U F F' F'' F''' u u' u'' u''' u'''' 2(fun i=>v i*a)w
 (simple_P9 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
(simple_P10 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
(simple_P11 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
(simple_P12 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
(simple_P13 U F F' F'' F''' 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)
 (simple_P7 _ _)(simple_P8 U F F' F'' F''' A A')a a')
 (Full_set _)(sigalg_P3 U F F' F'' F'''))%R.
2:apply(lebint_P2 U F F' F'' F''' u u' u'' u''' u'''' 2 v w
(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)
(simple_P8 U F F' F'' F''' A A')(Full_set U)(sigalg_P3 U F F' F'' F''')a a').

apply(lebint_P0 U F F' F'' F''' u u' u'' u''' u'''' 2(fun i:nat=>v i*a)w
 (simple_P9 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
(simple_P10 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
(simple_P11 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
(simple_P12 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
(simple_P13 U F F' F'' F''' 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)
 (simple_P7 _ _)(simple_P8 U F F' F'' F''' A A')a a')f f' f'')%R.
2:exact L'.

intro y.
elim(simple_P0 U 2(fun i=>v i*a)w
 (simple_P9 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
(simple_P10 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
(simple_P11 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
(simple_P12 _ 2 v w(simple_P4 _ _)(simple_P5 _ _)(simple_P6 _ _)(simple_P7 _ _)a a')
y)%R.

intros i p. elim(classic(i=0)).
intro H. simpl. rewrite H. simpl. replace(0*a)%R with 0%R. intuition. ring.
intro H. assert(H1:i=1). intuition. simpl. rewrite H1. simpl. replace(1*a)%R with a.
2:ring.
rewrite H1 in p. intuition. Qed.


Require Import ILogic BILogic.
Require Import SetInterface SetFacts SetProperties.
Require Import Compare_dec.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Section IteratedSeparatingConjunction.
	Context {A : Type} {HO : OrderedType A} {HF : FSet} {HS : FSetSpecs HF}.
	Context {B : Type} `{HBI : BILogic B}.

	Definition isc (f : A -> B) (s : set A) := fold (fun b acc => f b ** acc) s empSP.

	Lemma isc_add (f : A -> B) (s : set A) (a : A) {H : Proper (_eq ==> lentails) f}
	              (Ha : ~(In a s)) :
	              isc f (add a s) -|- f a ** isc f s.
	Proof.
		unfold isc; rewrite fold_add; [reflexivity | apply _ | | | assumption].
		+ intros b c Hbc p q Hpq; rewrite Hpq.
		  split; apply bilsep; apply H; [|symmetry]; assumption.
		+ intros b c p. repeat rewrite <- sepSPA; rewrite sepSPC with (P := f b).
		  reflexivity.
    Qed.

    Lemma isc_union (f : A -> B) (s1 s2 : set A) {H : Proper (_eq ==> lentails) f}
                    (Hs1s2 : forall x, ~(In x s1 /\ In x s2)) :
                    isc f (union s1 s2) -|- isc f s1 ** isc f s2.
    Proof.
        unfold isc; rewrite fold_union; [ | apply _ | | |].
        + revert Hs1s2. apply set_induction with (s := s1); clear s1.
		  * intros s1 Hs1 Hs1s2.
		    do 2 (rewrite fold_1 with (s := s1); [| apply _ | assumption]).
		    rewrite sepSPC, empSPR; reflexivity.
		  * intros s1 s3 IH x Hx Hadd Hs3s2.
		    rewrite fold_2 with (s' := s3); [| apply _ | | | eassumption | assumption].
		    - rewrite fold_2 with (s' := s3); [| apply _ | | | eassumption | assumption].
		      rewrite sepSPA. rewrite <- IH. reflexivity.
		      intros y [Hs1 Hs2]. specialize (Hs3s2 y). apply Hs3s2.
		      split; [|apply Hs2].
		      SearchAbout add Add.
		      pose proof (Add_Equal x s1 s3) as H1; destruct H1 as [H1 _].
		      specialize (H1 Hadd). rewrite H1.
		      rewrite add_iff. right; assumption.
		      intros a b Hab p q Hpq; rewrite Hpq.
   		 	  split; apply bilsep; apply H; [|symmetry]; assumption.
   		 	  intros a b p; repeat rewrite <- sepSPA; rewrite sepSPC with (P := f a);
       		  reflexivity.
       		- intros a b Hab p q Hpq; rewrite Hpq.
   		 	  split; apply bilsep; apply H; [|symmetry]; assumption.
   		 	- intros a b p; repeat rewrite <- sepSPA; rewrite sepSPC with (P := f a);
       		  reflexivity.
    	+ intros a b Hab p q Hpq; rewrite Hpq.
    	  split; apply bilsep; apply H; [|symmetry]; assumption.
        + intros a b p; repeat rewrite <- sepSPA; rewrite sepSPC with (P := f a);
          reflexivity.
        +  intros x [Hs1 Hs2]. specialize (Hs1s2 x).
           apply Hs1s2; split; assumption.
	Qed.

	Global Instance isc_m (f : A -> B) {H : Proper (_eq ==> lentails) f} :
		Proper (Equal ==> lequiv) (isc f).
	Proof.
		intros a b Hab.
		unfold isc. apply fold_equal.
		+ apply _.
   	    + intros c d Hcd p q Hpq; rewrite Hpq.
    	  split; apply bilsep; apply H; [|symmetry]; assumption.
        + intros c d p; repeat rewrite <- sepSPA; rewrite sepSPC with (P := f c);
          reflexivity.
        + assumption.
	Qed.

End IteratedSeparatingConjunction.

Section NatSet.
	Context {HF : @FSet nat _} {HS : FSetSpecs HF}.
	Context {A : Type} `{HBI: BILogic A}.

	Fixpoint nat_set_aux (count start : nat) : set nat :=
		match count with
			| O => add start empty
			| S x => add (start + count) (nat_set_aux x start)
		end.

	Definition nat_set (from to : nat) :=
		if le_dec from to then
			nat_set_aux (to - from) from
		else
			empty.

	Lemma nat_set_empty (from to : nat) (H : to > from) : Equal (nat_set to from) empty.
	Proof.
		unfold nat_set.
		destruct (le_dec to from); [omega|reflexivity].
	Qed.

	Lemma nat_set_singleton (from to : nat) (H : from = to) : Equal (nat_set to from) {from; empty}.
	Proof.
		unfold nat_set.
		destruct (le_dec to from); [|omega].
		assert (from - to = 0) as H1 by omega.
		rewrite H1. simpl. rewrite H. reflexivity.
	Qed.

    Lemma nat_set_in (a b x : nat) (Hax : a <= x) (Hbx : b >= x) : In x (nat_set a b).
    Proof.
    	unfold nat_set. destruct (le_dec a b); [|omega].
    	remember (b - a) as c. generalize dependent b. induction c; intros.
    	+ simpl. assert (a = b) by omega; subst. rewrite add_iff.
    	  left; unfold Equivalence.equiv; simpl; omega.
    	+ simpl. rewrite add_iff. destruct (eq_dec (a + S c) x).
          - left; assumption.
          - right. unfold Equivalence.equiv in H; simpl in H.
            apply IHc with (b := b - 1); try omega.
    Qed.

    Lemma nat_set_in_from (a b x : nat) (Hin : In x (nat_set a b)) : x >= a.
    Proof.
    	unfold nat_set in Hin.
    	destruct (le_dec a b).
    	- remember (b - a) as c. generalize dependent b; induction c; intros.
    	  + simpl in Hin. rewrite add_iff in Hin. destruct Hin as [Hax | Hin].
    	    * rewrite Hax. reflexivity.
    	    * rewrite empty_iff in Hin; destruct Hin.
    	  + simpl in Hin. rewrite add_iff in Hin; destruct Hin as [Hax | Hin].
            * rewrite <- Hax. omega.
            * apply IHc with (b := b - 1); try omega. assumption.
        - rewrite empty_iff in Hin; destruct Hin.
    Qed.

    Lemma nat_set_in_to (a b x : nat) (Hin : In x (nat_set a b)) : x <= b.
    Proof.
    	unfold nat_set in Hin.
    	destruct (le_dec a b).
    	- remember (b - a) as c; generalize dependent a;
    	  generalize dependent x; induction c; intros.
    	  + simpl in Hin. rewrite add_iff in Hin. destruct Hin as [Hax | Hin].
    	    * rewrite <- Hax. assumption.
    	    * rewrite empty_iff in Hin; destruct Hin.
    	  + simpl in Hin.
    	    rewrite add_iff in Hin; destruct Hin as [Hax | Hin];
    	    unfold Equivalence.equiv in *; simpl in *; try omega.
    	    assert (S x <= b); [|omega].
    	    apply IHc with (a := S a); try omega.
    	    clear IHc Heqc l. induction c; simpl in *.
    	    * rewrite add_iff in Hin. destruct Hin as [Hax | Hin].
    	      rewrite Hax, add_iff; left; reflexivity.
    	      rewrite empty_iff in Hin; destruct Hin.
    	    * rewrite add_iff in Hin. destruct Hin as [Hacx | Hin].
    	      rewrite add_iff; left; rewrite Hacx; reflexivity.
    	      rewrite add_iff; right; apply IHc; assumption.
        - rewrite empty_iff in Hin; destruct Hin.
    Qed.

    Lemma nat_set_inter (a b c d : nat) (Hbc : b < c) :
    	Equal (inter (nat_set a b) (nat_set c d)) empty.
    Proof.
    	intros x; split; intros H.
    	+ rewrite inter_iff in H. destruct H as [H1 H2].
		  assert (x >= c) by (eapply nat_set_in_from; eassumption).
		  assert (x <= b) by (eapply nat_set_in_to; eassumption).
		  omega.
		+ rewrite empty_iff in H. destruct H.
	Qed.

	Lemma nat_set_split (a b c : nat) (Hab : a <= b) (Hbc : b <= c) :
		Equal (nat_set a c) (nat_set a b ++ nat_set (b + 1) c).
	Proof.
		intros x; split; intros H.
		* assert (x >= a) by (eapply nat_set_in_from; eassumption).
		  assert (x <= c) by (eapply nat_set_in_to; eassumption).
	  	  rewrite union_iff. destruct (le_gt_dec x b).
		  + left. apply nat_set_in; assumption.
		  + right. apply nat_set_in; [omega|assumption].
		* rewrite union_iff in H. destruct H as [H | H].
		  + assert (x >= a) by (eapply nat_set_in_from; eassumption).
	  	    assert (x <= b) by (eapply nat_set_in_to; eassumption).
	  	    apply nat_set_in; [assumption | omega].
		  + assert (x >= b + 1) by (eapply nat_set_in_from; eassumption).
	  	    assert (x <= c) by (eapply nat_set_in_to; eassumption).
	  	    apply nat_set_in; [omega | assumption].
	Qed.

	Definition isc_nat (f : nat -> A) (from to : nat) := isc f (nat_set from to).

	Lemma isc_nat_split (f : nat -> A) (a b c : nat) (Hab : a < b) (Hbc : b < c) :
		  isc_nat f a c -|- isc_nat f a b ** isc_nat f (b + 1) c.
	Proof.
		unfold isc_nat.
		rewrite <- isc_union.
		rewrite <- nat_set_split. reflexivity.
		omega. omega.
		intros x [H1 H2].
		pose proof (@nat_set_inter a b (b + 1) c).
		assert (b < b + 1) by omega.
		specialize (H H0 x). destruct H. rewrite empty_iff in H. apply H.
		rewrite inter_iff; split; assumption.
	Qed.
End NatSet.


Require Import PL.Imp PL.ImpExt PL.RTClosure.
Local Open Scope imp.

Require Import PL.Denotational_Semantics_2.

(* ################################################################# *)
(** * From Denotations To Multi-step Relations *)

Lemma semantic_equiv_iter_loop1: forall st1 st2 n b c,
  (forall st1 st2, (exists t: Z, ceval c st1 t st2) -> multi_cstep (c, st1) (Skip, st2)) ->
  (exists n0 : nat, iter_loop_body b (ceval c) n0 st1 n st2) ->
  multi_cstep (While b Do c EndWhile, st1) (Skip, st2).
Proof.
  intros. destruct H0.
  revert st1 st2 n H0; induction x; intros.
  + simpl in H0.
    unfold BinRel.test_rel in H0.
    destruct H0.
    subst st2.
    etransitivity_1n; [apply CS_While |].
    etransitivity; [apply multi_congr_CIf, semantic_equiv_bexp1_false, H1 |].
    etransitivity_1n; [apply CS_IfFalse |].
    reflexivity.
  + simpl in H0.
    unfold seq_sem at 1,
           test_sem in H0.
    destruct H0. destruct H0. destruct H0. destruct H0. destruct H1.
    unfold seq_sem in H1. destruct H1. destruct H1. destruct H1.
    etransitivity_1n; [apply CS_While |].
    etransitivity; [apply multi_congr_CIf, semantic_equiv_bexp1_true, H0 |].
    etransitivity_1n; [apply CS_IfTrue |]. destruct H0. destruct H0. destruct H1. destruct H1.
    etransitivity. apply multi_congr_CSeq. apply H. exists x3. apply H0.
    etransitivity_1n; [apply CS_Seq |].
    apply IHx with x4.
    tauto.
Qed.

Theorem semantic_equiv_com1: forall st1 st2 c,
  (exists t : Z, ceval c st1 t st2) -> multi_cstep (c, st1) (Skip, st2).
Proof.
  intros.
  revert st1 st2 H. induction c; intros.
  + simpl in H.
    unfold skip_sem in H.
    destruct H. destruct H.
    rewrite H.
    reflexivity.
  + simpl in H.
    unfold asgn_sem in H.
    destruct H.
    etransitivity_n1.
    - apply multi_congr_CAss, semantic_equiv_aexp1.
      reflexivity.
    - apply CS_Ass. tauto. destruct H.
      apply H0.
  + simpl in H.
    unfold seq_sem in H.
    destruct H. destruct H. destruct H. destruct H. destruct H. destruct H0.
    etransitivity. apply multi_congr_CSeq.
    pose proof IHc1 st1 x2. apply H2. exists x0. tauto.
    etransitivity_1n; [ apply CS_Seq |].
    pose proof IHc2 x2 st2. apply H2. exists x1. tauto.
  + simpl in H.
    unfold if_sem in H.
    unfold union_sem,seq_sem,test_sem in H.
    pose proof semantic_equiv_bexp1 st1 b.
    destruct H0. destruct H. destruct H as [H | H]. destruct H. destruct H. destruct H.
    destruct H. destruct H. destruct H3. destruct H2.
    - etransitivity. apply multi_congr_CIf. apply H0. tauto.
      etransitivity_1n; [apply CS_IfTrue |].
      pose proof IHc1 st1 st2. apply H6. exists x1. rewrite H. tauto.
    - etransitivity. apply multi_congr_CIf. apply H1.
      destruct H. destruct H. destruct H. destruct H. destruct H.
      destruct H3. destruct H2. simpl in H3.
      unfold Sets.complement in H3. tauto.
      etransitivity_1n; [apply CS_IfFalse |].
      destruct H. destruct H. destruct H. destruct H. destruct H.
      destruct H3. destruct H2.
      pose proof IHc2 x2 st2. rewrite H. apply H6. exists x1. tauto.
  + simpl in H.
    unfold loop_sem in H.
    unfold omega_union_sem in H.
    destruct H as [n ?].
    apply semantic_equiv_iter_loop1 with n.
    - exact IHc.
    - exact H.
Qed.

(* ################################################################# *)
(** * From Multi-step Relations To Denotations*)
Lemma loop_unrolling: forall b c (a b0: state) (t:Z),
    ceval (While b Do c EndWhile) a t b0 <->
    ceval (If b Then c;; While b Do c EndWhile Else Skip EndIf) a t b0.
Proof.
  intros. simpl.
    unfold iff; split; intros.
  + unfold loop_sem, omega_union_sem in H.
    destruct H as [n ?].
    destruct n.
    - simpl in H.
      unfold if_sem, union_sem.
      right; simpl.
      unfold seq_sem, skip_sem.
      exists t. exists 0. exists b0; split; [exact H | ].
      split. tauto. lia.
    - simpl in H.
      unfold if_sem, union_sem.
      left.
      unfold seq_sem in H.
      unfold seq_sem.
      destruct H as [t1 [t2 [st1' [? ?]]]].
      destruct H0.
      destruct H0 as [t0 [t3 [st2' [? ?]]]].
      exists t1. exists t2. exists st1'; split; [exact H |].
      split. exists t0. exists t3. exists st2';split; [exact H0 |].
      unfold loop_sem, omega_union_sem. split.
      exists n. destruct H2.
      exact H2. lia. lia.
  + unfold if_sem, union_sem in H.
    unfold loop_sem, omega_union_sem.
    destruct H.
    2: {
      exists 0%nat.
      simpl.
      unfold seq_sem, skip_sem in H.
      destruct H as [t1 [t2 [st2' [? ?]]]]. destruct H0. destruct H0.
      rewrite H0 in H. rewrite H2 in H1.
      assert (t = t1). rewrite H1. lia.
      rewrite <- H3 in H. tauto.
    }
    unfold seq_sem at 1 in H.
    destruct H as [t1 [t2 [st1' [? ?]]]].
    unfold seq_sem in H0. destruct H0.
    destruct H0 as [t0 [t3 [st0 [? ?]]]].
    destruct H2.
    unfold loop_sem, omega_union_sem in H2.
    destruct H2 as [n ?].
    exists (S n).
    simpl.
    unfold seq_sem at 1.
    exists t1. exists t2.
    exists st1'; split; [exact H |].
    unfold seq_sem. split. exists t0. exists t3.
    exists st0; split; [exact H0 |]. split. tauto. tauto. tauto.
Qed.

Lemma ceval_preserve_1: forall c1 c2 st1 st2,
  cstep (c1, st1) (c2, st2) ->
  forall st3 t1, ceval c2 st2 t1 st3 -> (ceval c1 st1 t1 st3 \/ ceval c1 st1 (t1+1)%Z st3).
Proof.
  intros. revert t1 st3 H0.
  induction_cstep H; simpl; intros.
  + apply aeval_preserve in H.
    unfold asgn_sem in H0. unfold asgn_sem.
    rewrite H. destruct H0. left. tauto.
  + unfold skip_sem in H1.
    unfold asgn_sem.
    destruct H1. destruct H1. right. split.
    unfold aeval. unfold constant_func. tauto.
    intros. pose proof H0 Y. apply H3 in H1. rewrite H2. tauto.
  + unfold seq_sem in H0. destruct H0 as [t2 [t3 [st2' [? ?]]]].
    pose proof IHcstep t2 st2'.
    destruct H2. tauto.
    unfold seq_sem. left. exists t2. exists t3. exists st2'. tauto.
    unfold seq_sem. right. exists (t2+1)%Z. exists t3. exists st2'.
    destruct H1. split. tauto. split. tauto. rewrite H3. lia.
  + left. unfold seq_sem, skip_sem.
    exists 0. exists t1. exists st. tauto.
  + left.
    unfold if_sem in H0.
    unfold if_sem.
    unfold union_sem, seq_sem, test_sem in H0.
    unfold union_sem, seq_sem, test_sem.
    apply beval_preserve in H.
    simpl in H0.
    simpl.
    unfold Sets.complement in H0.
    unfold Sets.complement.
    destruct H0 as [[t2 [t3 [st2' ?]]] | [t2 [t3 [st2' ?]]]].
    destruct H0. left. exists t2. exists t3. exists st2'. tauto.
    right. exists t2. exists t3. exists st2'. tauto.
  + right. unfold if_sem.
    unfold union_sem, seq_sem, test_sem.
    left. exists 1. exists t1. exists st; split.
    simpl. unfold Sets.full. tauto. split. tauto. lia.
  + right. unfold if_sem.
    unfold union_sem, seq_sem, test_sem.
    right. exists 1. exists t1. exists st; split.
    simpl. unfold Sets.complement, Sets.empty. tauto. split. tauto. lia.
  + pose proof loop_unrolling b c st st3 t1.
    simpl in H.
    left. tauto.
Qed.

Lemma ceval_preserve: forall c1 c2 st1 st2,
  cstep (c1, st1) (c2, st2) ->
  forall st3, (exists t1, ceval c2 st2 t1 st3) -> (exists t2, ceval c1 st1 t2 st3).
Proof.
  intros.
  pose proof ceval_preserve_1 c1 c2 st1 st2.
  assert (forall (st3 : state) (t1 : Z),
     ceval c2 st2 t1 st3 -> ceval c1 st1 t1 st3 \/ ceval c1 st1 (t1 + 1) st3).
  apply H1. tauto. clear H1.
  pose proof H2 st3. clear H2.
  destruct H0.
  pose proof H1 x.
  apply H2 in H0.
  destruct H0.
  + exists x. tauto.
  + exists (x+1)%Z. tauto.
Qed.

Theorem semantic_equiv_com2: forall c st1 st2,
  multi_cstep (c, st1) (Skip, st2) -> (exists t : Z, ceval c st1 t st2).
Proof.
  intros.
  remember (CSkip) as c' eqn:H0.
  induction_1n H.
  simpl; intros; subst.
  + simpl.
    unfold skip_sem. exists 0.
    split. reflexivity.
    reflexivity.
  + pose proof ceval_preserve _ _ _ _ H st2.
    tauto.
Qed.

(* ################################################################# *)
(** * Final Theorem of semantic equivalence between the second Denotational Semantics and Small Step Semantics. *)
Theorem semantic_equiv: forall c st1 st2,
  (exists t: Z, ceval c st1 t st2) <-> multi_cstep (c, st1) (CSkip, st2).
Proof.
  intros.
  split.
  + apply semantic_equiv_com1.
  + apply semantic_equiv_com2.
Qed.


Require Import List.

Theorem correctness_of_hd :
   (forall A:Type,
   (forall (default : A) (x : A) (lst : list A),
   (hd default nil) = default /\ (hd default (x :: lst)) = x)).
Proof.
  intros.
  refine (conj _ _).
    simpl.
    reflexivity.

    simpl.
    reflexivity.
Qed.


(** Formalization of the algorithm to solve rendezvous in R² with 1 bit
    from "Rendezvous of two robots with visible bits", G. Viglietta, ALGOSENSORS 2013

    2 full lights: A and B

    Robogram:
    - me=A, you=A: move to middle location, light goes to B
    - me=A, you=B: move to the other location
    - me=B, you=A: stay
    - me=B, you=B: stay, light goes to A *)

Require Import Lia.
Require Import Pactole.Setting.
Require Import Pactole.Spaces.R.
Require Import Pactole.Spaces.R2.
Require Import Pactole.Models.Similarity.
Require Import Pactole.Models.NoByzantine.
Require Import Pactole.CaseStudies.Gathering.Definitions.

(* Helping typeclass resolution avoid infinite loops. *)
Typeclasses eauto := (bfs).

(* Avoid problems with previous instances. *)
Remove Hints eq_setoid : typeclass_instances.

Local Existing Instance R2.R2_VS.
Local Existing Instance R2.R2_ES.

Section RDV.

(** There are only 2 robots: r0 and r1, and neither is Byzantine. *)
Instance N : Names := Robots 2 0.
Instance NoByz : NoByzantine.
Proof using . now split. Qed.

Notation lt2 := (fun x => x < 2)%nat.
Definition lt02 : (0 < 2)%nat := ltac:(abstract lia).
Definition lt12 : (1 < 2)%nat := ltac:(abstract lia).
Definition r0 : G := exist lt2 0%nat lt02.
Definition r1 : G := exist lt2 1%nat lt12.

Lemma id_case : forall id, id = Good r0 \/ id = Good r1.
Proof. Admitted.

(** The space is R², so that we can define similarities and they respect middle points. *)
Instance Loc : Location := make_Location R2.

(** State: location + light *)
Inductive light := A | B.

Instance light_Setoid : Setoid light := eq_setoid light.

Instance light_EqDec : EqDec light_Setoid.
refine (fun x y => match x, y with A, A | B, B => left _ | A, B | B, A => right _ end).
Proof. all:abstract (auto; discriminate). Defined.

Definition info := (location * light)%type.

Instance St : State info := AddInfo light
   (OnlyLocation (fun f => sigT (fun sim : similarity location => Bijection.section sim == f))).

(** The robot have access to the full state of all robots, that is, their locations and lights. *)
Instance Obs : @Observation info Loc St N.
simple refine {| observation := info * info;   (* self & other robot's state *)
                 observation_Setoid := prod_Setoid state_Setoid state_Setoid;
                 obs_from_config config st :=
                   let st0 := config (Good r0) in
                   let st1 := config (Good r1) in
                   if st0 =?= st then (st0, st1) else (st1, st0);
                 obs_is_ok obs config st :=
                   let st0 := config (Good r0) in
                   let st1 := config (Good r1) in
                   obs == if st0 =?= st then (st0, st1) else ( st1, st0) |}; autoclass; [|].
Proof.
+ Time abstract (intros ? ? Hconfig ? ? Hpt; cbn zeta;
                 repeat destruct_match;
                 solve [ split ; apply Hconfig
                       | split ; rewrite Hconfig, Hpt in *; now exfalso ]).
+ intros. cbn -[equiv]. reflexivity.
Defined.

(** Robot choices *)
(* TODO: use [light * ratio] to get exactly the algorithms from the class L *)
Instance RC2 : robot_choice info := {|
  robot_choice_Setoid := prod_Setoid location_Setoid light_Setoid |}.

(** Demon choices:
    - the frame change is a similarity
    - no choice for update for both active and inactive robots. *)
Instance FC2 : frame_choice (similarity location) := FrameChoiceSimilarity.
Instance UC2 : update_choice unit := {| update_choice_EqDec := unit_EqDec |}.
Instance IC2 : inactive_choice unit := {| inactive_choice_EqDec := unit_EqDec |}.

(** Update functions: the robot gets to its target, and nothing happne ot inactive robots. *)
Instance UF : update_function _ _ _.
refine {| update := fun _ _ _ pt _ => pt;
          update_compat := _ |}.
Proof. now repeat intro. Defined.
Instance IF2 : inactive_function _.
refine {| inactive := fun config id _ => config id;
          inactive_compat := _ |}.
Proof. now repeat intro; subst. Defined.

(** In this setting, only SSYNC demons can be defined (the inactive choice is ignored). *)
Lemma SSYNC_setting : forall da, SSYNC_da da.
Proof using . repeat intro. reflexivity. Qed.

(** The robogram in both the local and global frames of reference. *)
Definition rendezvous_pgm : observation -> info :=
  fun '((pt1, l1), (pt2, l2)) =>
    match l1, l2 with
      | A, A => (middle pt1 pt2, B)
      | B, A => (pt1, l1)
      | A, B => (pt2, l1)
      | B, B => (pt1, A)
    end.

Instance rdv_compat : Proper (equiv ==> equiv) rendezvous_pgm.
Proof using .
intros [[] []] [[] []] [[] []]. simpl in *.
repeat destruct_match; simpl; repeat split; congruence.
Qed.

Definition rendezvous : robogram := {| pgm := rendezvous_pgm |}.

Notation "!! config § st " := (obs_from_config (Observation := Obs) config st) (at level 60).

(** Express the algorithm in the global frame of reference. *)
Definition map_spect f : observation -> observation :=
  fun s => (f (fst s), f (snd s)).

Lemma obs_from_config_map : forall (f : sigT precondition),
  Proper ((equiv ==> equiv)%signature) (projT1 f) ->
  forall config st,
    !! map_config (lift f) config § lift f st == map_spect (lift f) (!! config § st).
Proof using .
intros f Hf config st.
unfold obs_from_config. cbn -[equiv_dec equiv].
repeat destruct_match.
+ now repeat split.
+ exfalso. apply c. inv e ; simpl in H, H0.
  destruct f as [f [sim Hsim]]. split ; auto.
  simpl in H. now apply (injective sim) ; rewrite Hsim, H.
+ exfalso. cut (lift f (config (Good r0)) == lift f st); auto; [].
  now apply (lift_compat Hf).
+ now repeat split.
Qed.

Lemma rendezvous_pgm_map : forall f s,
  rendezvous_pgm (map_spect (lift (State := St) f) s) == lift f (rendezvous_pgm s).
Proof using .
intros [f Pf] [[pt1 l1] [pt2 l2]].
unfold rendezvous_pgm. cbn -[equiv middle].
destruct l1, l2; cbn -[equiv middle] in *; repeat split; auto; [].
cbn [fst]. destruct Pf as [sim Hsim]. rewrite <- Hsim. apply R2_middle_morph.
Qed.

Lemma round_simplify : forall da config,
  similarity_da_prop da -> (* the frame of the observing robot is centered on itself *)
  round rendezvous da config
  == fun id => if activate da id
               then rendezvous (!! config § config id)
               else config id.
Proof using .
intros da config simP. apply no_byz_eq. intros g. unfold round.
cbn -[inverse equiv lift frame_choice_bijection location].
destruct_match ; try reflexivity.
pose (f_state := existT (fun f => {sim : similarity location & Bijection.section sim == f})
  (frame_choice_bijection (change_frame da config g))
  (precondition_satisfied da config g)).
pose (f_state_inv := existT (fun f => {sim : similarity location & Bijection.section sim == f})
  (frame_choice_bijection (change_frame da config g) ⁻¹)
  (precondition_satisfied_inv da config g)).
change (@equiv info _
  (lift f_state_inv (rendezvous_pgm (!! map_config (lift f_state) config § lift f_state (config (Good g)))))
  (rendezvous_pgm (!! config § config (Good g)))).
rewrite <-rendezvous_pgm_map. f_equiv.
rewrite <-obs_from_config_map. f_equiv.
+ intros id. cbn [map_config]. split ; simpl ; try reflexivity.
  now rewrite Bijection.retraction_section.
+ split ; simpl ; try reflexivity.
  now rewrite Bijection.retraction_section.
+ intros x y Hxy. cbn -[equiv].
  now apply Bijection.retraction_compat.
Qed.

(** Correctness: if the program terminates, it is correct *)

(** Once we are gathered, everything is good. *)
Lemma gathered_at_forever : forall da config pt, similarity_da_prop da ->
  gathered_at pt config -> gathered_at pt (round rendezvous da config).
Proof using .
intros da config pt Hsim Hgather.
rewrite round_simplify; trivial; [].
intro g. destruct (da.(activate) (Good g)); [| now apply Hgather].
unfold rendezvous, rendezvous_pgm, obs_from_config, Obs.
destruct (config (Good r0)) as [pt1 l1] eqn:Hr0,
         (config (Good r1)) as [pt2 l2] eqn:Hr1.
assert (Hpt1 : pt1 == pt) by now rewrite <- Hgather, Hr0.
assert (Hpt2 : pt2 == pt) by now rewrite <- Hgather, Hr1.
assert (Hg : g = r0 \/ g = r1).
{ destruct g as [[| [| ?]] ?].
  - left. unfold r0. f_equal. apply le_unique.
  - right. unfold r1. f_equal. apply le_unique.
  - exfalso. lia. }
destruct Hg; subst g.
* rewrite Hr0. rewrite equiv_dec_refl.
  destruct l1, l2; cbn -[equiv middle]; trivial;
  try match goal with H : lt _ _, H' : lt _ _ |- _ => clear -H H'; exfalso; lia end; [].
  now rewrite Hpt1, middle_eq.
* rewrite Hr1. destruct_match.
  + match goal with H : (_, _) == _ |- _ => destruct H as [Hpt Hl] end.
    simpl in Hpt, Hl. subst. cbn -[equiv middle].
    repeat destruct_match; cbn -[equiv middle]; trivial; [].
    now rewrite Hpt1, middle_eq.
  + assert (Hl : l1 =/= l2).
    { intro Habs. cut ((pt1, l1) == (pt2, l2)); trivial; []. now split; rewrite Hpt1, Hpt2, Habs. }
    simpl in Hl.
  destruct l1, l2; cbn -[equiv middle]; trivial;
  try match goal with H : lt _ _, H' : lt _ _ |- _ => clear -H H'; exfalso; lia end; [].
  now rewrite Hpt2, middle_eq.
Qed.

Lemma gathered_at_over : forall d,
  Stream.forever (Stream.instant similarity_da_prop) d ->
  forall pt (config : configuration),
    gathered_at pt config -> Gather pt (execute rendezvous d config).
Proof using .
cofix Hind. intros d Hsim pt config Hgather. constructor.
+ clear Hind. simpl. assumption.
+ apply Hind. try apply gathered_at_forever; trivial; apply Hd || apply Hsim.
Qed.

(** Termination measure *)
Definition measure (config : configuration) : nat :=
  match snd (config (Good r0)), snd (config (Good r1)) with
    | A, A => 2
    | B, A | A, B => 1
    | B, B => 3
  end.

Instance measure_compat : Proper (equiv ==> eq) measure.
Proof using .
intros config1 config2 Hconfig. unfold measure.
assert (Hr0 := Hconfig (Good r0)). assert (Hr1 := Hconfig (Good r1)).
destruct (config1 (Good r0)) as [pt1 l1], (config1 (Good r1)) as [pt2 l2].
symmetry in Hr0, Hr1. destruct Hr0 as [Hpt1 Hl1], Hr1 as [Hpt2 Hl2].
cbn -[location] in Hl1, Hl2. rewrite Hl1, Hl2.
destruct l1, l2; simpl; reflexivity.
Qed.

(* A result ensuring that the measure strictly decreases after each round. *)
Lemma round_measure : forall da config, similarity_da_prop da ->
  moving rendezvous da config <> nil ->
  (exists pt, gathered_at pt (round rendezvous da config))
  \/ measure (round rendezvous da config) < measure config.
Proof using .
intros da config Hda Hmove.
destruct (gathered_at_dec config (get_location (config (Good r0)))) as [| Hgather];
[| destruct (gathered_at_dec (round rendezvous da config)
              (get_location (round rendezvous da config (Good r0)))) as [| Hgather']].
* left. eexists. now apply gathered_at_forever.
* left. now eexists.
* right. rewrite round_simplify; trivial; [].
  assert (Hone_active : activate da (Good r0) = true \/ activate da (Good r1) = true).
  { destruct (activate da (Good r0)) eqn:Hr0, (activate da (Good r1)) eqn:Hr1; auto; [].
    elim Hmove. apply incl_nil. cut (active da = nil).
    - intro Hactive. rewrite <- Hactive. apply moving_active.
      intros id Hid config'. reflexivity.
    - unfold active, names. simpl.
      assert (Hid : forall id, activate da id = false).
      { intro id. now destruct (id_case id); subst id. }
      now rewrite 2 Hid. }
  assert (Hneq : config (Good r0) =/= config (Good r1)).
  { intro Habs. apply Hgather. intro g.
    now destruct (id_case (Good g)) as [Hg | Hg]; rewrite Hg, ?Habs. }
  assert (Hobs1 : !! config § config (Good r0) = (config (Good r0), config (Good r1))).
  { unfold obs_from_config, Obs. now rewrite equiv_dec_refl. }
  assert (Hobs2 : !! config § config (Good r1) = (config (Good r1), config (Good r0))).
  { unfold obs_from_config, Obs. destruct_match; trivial; contradiction. }
    unfold measure. unfold obs_from_config, Obs, Datatypes.id.
    rewrite equiv_dec_refl.
    destruct (config (Good r0) =?= config (Good r1)); try contradiction; [].
  destruct (config (Good r0)) as [pt1 []] eqn:Hr0,
           (config (Good r1)) as [pt2 []] eqn:Hr1;
  cbn -[location location_Setoid location_EqDec middle].
  + (* both robots have color A, hence measure config = 2 *)
    destruct (activate da (Good r0)) eqn:Hactive1,
             (activate da (Good r1)) eqn:Hactive2; simpl.
    - (* both robots are active so they gather in one step *)
      exfalso. apply Hgather'. intro g.
      rewrite (round_simplify da config Hda (Good g)),
              (round_simplify da config Hda (Good r0)).
      destruct (id_case (Good g)) as [Hid | Hid]; inv Hid; try reflexivity; [].
      rewrite Hactive1, Hactive2. apply get_location_compat.
      rewrite Hr0, Hr1, Hobs1, Hobs2. cbn -[equiv middle].
      split; try reflexivity; []. apply middle_comm.
    - lia.
    - lia.
    - destruct Hone_active; discriminate.
  + (* one robot has color A, the other B, hence measure config = 1;
       since one robot moves, A is activated and they gather in one step *)
    assert (Hactive1 : activate da (Good r0) = true).
    { destruct (activate da (Good r0)) eqn:Hactive1; trivial; [].
      exfalso. apply Hmove.
      assert (Hmove1 : round rendezvous da config (Good r0) == config (Good r0)).
      { unfold round. rewrite Hactive1. reflexivity. }
      assert (Hmove2 : round rendezvous da config (Good r1) == config (Good r1)).
      { rewrite (round_simplify da config Hda (Good r1)).
        destruct_match; reflexivity || now rewrite Hr1, Hobs2. }
      assert (Hmoving := moving_spec rendezvous da config).
      destruct (moving rendezvous da config) as [| id ?]; trivial; exfalso; [].
      specialize (Hmoving id). apply proj1 in Hmoving. specialize (Hmoving ltac:(now left)).
      destruct (id_case id); subst id; contradiction. }
    exfalso. apply Hgather'. intro g.
    destruct (id_case (Good g)) as [Hid | Hid]; inv Hid; try reflexivity; [].
    rewrite (round_simplify da config Hda (Good r0)),
            (round_simplify da config Hda (Good r1)).
    rewrite Hactive1, Hr0, Hr1, Hobs1, Hobs2. cbn -[equiv].
    now destruct_match.
  + (* by symmetry, idem *)
    assert (Hactive2 : activate da (Good r1) = true).
    { destruct (activate da (Good r1)) eqn:Hactive2; trivial; [].
      exfalso. apply Hmove.
      assert (Hmove1 : round rendezvous da config (Good r0) == config (Good r0)).
      { rewrite (round_simplify da config Hda (Good r0)).
        destruct_match; reflexivity || now rewrite Hr0, Hobs1. }
      assert (Hmove2 : round rendezvous da config (Good r1) == config (Good r1)).
      { unfold round. rewrite Hactive2. reflexivity. }
      assert (Hmoving := moving_spec rendezvous da config).
      destruct (moving rendezvous da config) as [| id ?]; trivial; exfalso; [].
      specialize (Hmoving id). apply proj1 in Hmoving. specialize (Hmoving ltac:(now left)).
      destruct (id_case id); subst id; contradiction. }
    exfalso. apply Hgather'. intro g.
    destruct (id_case (Good g)) as [Hid | Hid]; inv Hid; try reflexivity; [].
    rewrite (round_simplify da config Hda (Good r0)),
            (round_simplify da config Hda (Good r1)).
    rewrite Hactive2, Hr0, Hr1, Hobs1, Hobs2. cbn -[equiv].
    now destruct_match.
  + (* both robots have color B, hence measure config = 3 *)
    destruct (activate da (Good r0)) eqn:Hactive1,
             (activate da (Good r1)) eqn:Hactive2; simpl.
    -- try lia.
    -- try lia.
    -- try lia.
    -- (* in coq8.13 lia also solves this. *)
      destruct Hone_active; discriminate.
Qed.

(** Fairness entails progress. *)
Lemma OneMustMove : forall config, ~(exists pt, gathered_at pt config) ->
  exists r, forall da, similarity_da_prop da -> activate da r = true ->
                       round rendezvous da config r =/= config r.
Proof using .
intros config Hnotgather.
destruct (config (Good r0)) as [pt1 l1] eqn:Hr0,
         (config (Good r1)) as [pt2 l2] eqn:Hr1.
assert (Hpt : pt1 =/= pt2).
{ intro Habs. rewrite Habs in Hr0. apply Hnotgather.
  exists (get_location (config (Good r0))). intros [[| [| ?]] ?]; simpl.
  + unfold r0. do 4 f_equal. now apply eq_proj1.
  + transitivity (Datatypes.id (fst (config (Good r1)))).
    - unfold r1. simpl. do 4 f_equal. now apply eq_proj1.
    - now rewrite Hr0, Hr1.
  + exfalso. lia. }
destruct l1 eqn:Hl1; [| destruct l2 eqn:Hl2].
+ (* if r0's color is A, it changes its location *)
  exists (Good r0). intros da Hda Hactivate.
  rewrite (round_simplify da config Hda (Good r0)).
  rewrite Hactivate. rewrite Hr0. unfold rendezvous, rendezvous_pgm, obs_from_config.
  cbn -[equiv equiv_dec middle]. rewrite Hr0, Hr1.
  destruct_match; try (now intuition); [].
  destruct_match.
  - intros [_ Habs]. simpl in Habs. congruence.
  - intros []. cbn -[equiv] in *. congruence.
+ (* if r1's color is A, it changes its location *)
  exists (Good r1). intros da Hda Hactivate.
  rewrite (round_simplify da config Hda (Good r1)).
  rewrite Hactivate. rewrite Hr1. unfold rendezvous, rendezvous_pgm, obs_from_config.
  cbn -[equiv equiv_dec middle]. rewrite Hr0, Hr1.
  assert ((pt1, B) =/= (pt2, A)) by (intros []; contradiction).
  destruct_match; try (now intuition); [].
  intros []; contradiction.
+ (* when both robots have color B, they change color. *)
  exists (Good r0). intros da Hda Hactivate.
  rewrite (round_simplify da config Hda (Good r0)).
  rewrite Hactivate. rewrite Hr0. unfold rendezvous, rendezvous_pgm, obs_from_config.
  cbn -[equiv equiv_dec middle]. rewrite Hr0, Hr1.
  destruct_match; try (now intuition); [].
  intros [_ Habs]. simpl in Habs. congruence.
Qed.

Lemma Fair_FirstMove : forall d, Fair d -> Stream.forever (Stream.instant similarity_da_prop) d ->
  forall config, ~(exists pt, gathered_at pt config) -> FirstMove rendezvous d config.
Proof using .
intros d Hfair Hsim config Hgather.
destruct (OneMustMove config Hgather) as [idmove Hmove].
destruct Hfair as [locallyfair Hfair].
specialize (locallyfair idmove).
revert config Hgather Hmove.
induction locallyfair as [d Hnow | d]; intros config Hgather Hmove.
* apply MoveNow. apply Hmove in Hnow.
  + rewrite <- (moving_spec rendezvous (Stream.hd d) config idmove) in Hnow.
    intro Habs. rewrite Habs in Hnow. tauto.
  + apply Hsim.
* destruct (moving rendezvous (Stream.hd d) config) as [| id mov] eqn:Hmoving.
  + apply MoveLater; trivial; [].
    apply IHlocallyfair.
    - now destruct Hfair.
    - apply Hsim.
    - apply no_moving_same_config in Hmoving. now setoid_rewrite Hmoving.
    - intros da Hda Hactive. apply no_moving_same_config in Hmoving.
      rewrite (Hmoving idmove).
      apply (round_compat (reflexivity rendezvous) (reflexivity da)) in Hmoving; trivial; [].
      rewrite (Hmoving idmove).
      now apply Hmove.
  + apply MoveNow. rewrite Hmoving. discriminate.
Qed.

(** Final result: correctness of the Viglietta algorithm *)
Theorem Viglietta_correct : forall d, Fair d ->
  Stream.forever (Stream.instant similarity_da_prop) d ->
  forall config, WillGather (execute rendezvous d config).
Proof using .
intros d Hfair Hsim config.
generalize (eq_refl (measure config)). generalize (measure config) at -1.
intro n. revert d Hfair Hsim config. pattern n. apply (well_founded_ind lt_wf). clear n.
intros n Hind d Hfair Hsim config Hmeasure.
(* are we already gathered? *)
destruct (gathered_at_dec config (get_location (config (Good r0)))) as [Hgather | Hgather].
* (* if so, nothing to do *)
  apply Stream.Now.
  exists (get_location (config (Good r0))).
  now apply gathered_at_over.
* (* otherwise, we wait until one robot moves *)
  induction (Fair_FirstMove _ Hfair Hsim config) as [ | d config Hmove Hfirst IHf].
  + apply Stream.Later. rewrite (execute_tail rendezvous).
    change (WillGather (execute rendezvous (Stream.tl d) (round rendezvous (Stream.hd d) config))).
    (* are we gathered at the next step? *)
    destruct (gathered_at_dec (round rendezvous (Stream.hd d) config)
                                (get_location (round rendezvous (Stream.hd d) config (Good r0))))
      as [Hgather' | Hgather'].
    - (* if so, OK in one round *)
      apply Stream.Now. eexists. apply gathered_at_over; eauto; apply Hsim.
    - (* otherwise, we can use the induction hypothesis as the measure is smaller *)
      apply (Hind (measure (round rendezvous (Stream.hd d) config))).
      ++ subst n. destruct (round_measure (Stream.hd d) config) as [[pt Hpt] | ?]; trivial; [|].
         -- apply Hsim.
         -- elim Hgather'. now rewrite (Hpt r0).
      ++ apply Hfair.
      ++ apply Hsim.
      ++ reflexivity.
+ apply Stream.Later. apply IHf.
  - apply Hfair.
  - apply Hsim.
  - apply no_moving_same_config in Hmove. now rewrite Hmove.
  - apply no_moving_same_config in Hmove. now rewrite Hmove, (Hmove (Good r0)).
+ intros [pt Hpt]. apply Hgather. now rewrite (Hpt r0).
Qed.

End RDV.


(* Lazy Rose Trees *)

Require Import List mathcomp.ssreflect.ssreflect.
Set Implicit Arguments.

Record Lazy (T : Type) := lazy { force : T }.

Inductive Rose (A : Type) : Type :=
  MkRose : A -> Lazy (list (Rose A)) -> Rose A.

Definition returnRose {A : Type} (x : A) := MkRose x (lazy nil).

Fixpoint joinRose {A : Type} (r : Rose (Rose A)) : Rose A :=
  match r with
    | MkRose (MkRose a ts) tts =>
      MkRose a (lazy ((List.map joinRose (force tts)) ++ (force ts)))
  end.

Fixpoint repeatRose {A : Type} (n : nat) (r : Rose A) :=
  match r with
  | MkRose a ts => MkRose a (lazy (concat (repeat (force ts) n)))
  end.

Fixpoint fmapRose {A B : Type} (f : A -> B) (r : Rose A) : Rose B :=
  match r with
    | MkRose x rs => MkRose (f x) (lazy (List.map (fmapRose f) (force rs)))
  end.

Definition bindRose {A B : Type} (m : Rose A) (k : A -> Rose B) : Rose B :=
  joinRose (fmapRose k m).

(*
(* CH: these seem unused now *)
Lemma joinRoseFmapRose :
  forall {A B} (f: A -> B) (x : Rose A),
    fmapRose f x = joinRose (fmapRose (fun x0 : A => returnRose (f x0)) x).
Proof.
  fix 4.
  move=> A B f x.
  destruct x as [a l]. destruct l as [lst]. induction lst as [|x lst IHlst].
  - reflexivity.
  - inversion IHlst as [Heq]. simpl.
    rewrite Heq. repeat apply f_equal. apply f_equal2.
    apply joinRoseFmapRose. reflexivity.
Qed.

Lemma monadFunctorLaw :
  (forall A B (f : A -> B) a,
     fmapRose f a = bindRose a (fun x => returnRose (f x))).
Proof.
  move => A B f a.
  destruct a. destruct l as [lst]. induction lst as [|x lst Hlst].
  + reflexivity.
  + simpl in Hlst. rewrite /bindRose /= in Hlst.
    inversion Hlst as [Heq].
    simpl. rewrite Heq /bindRose /= app_nil_r.
    repeat apply f_equal. apply f_equal2. apply joinRoseFmapRose. reflexivity.
Qed.

(* CH: TODO: need a proper induction principle for rose trees *)
Lemma fmapRose_id : forall a (rose : Rose a) f,
  (forall x : a, f x = x) ->
  fmapRose f rose = rose.
Proof.
  fix 2. (* <-- nasty *)
  move => a [r [xs]] f H. induction xs as [|x xs]; simpl in *.
  - by rewrite H.
  - inversion IHxs. f_equal. by repeat apply H1. f_equal. f_equal.
    + by apply fmapRose_id.
    + by do 2 rewrite H2.
Qed.
*)


(** Realisation of the time using vector clocs. *)

From aneris.aneris_lang Require Import lang.
From aneris.prelude Require Import misc strings.
From stdpp Require Import list sets.

Definition vector_clock := list nat.

(** Alternatively the specs in vector_clock.v can use
    the following instead of the is_vc predicate. *)
Fixpoint vector_clock_to_val (t : vector_clock) : val :=
  match t with
  | [] => NONEV
  | a :: t' => SOMEV (#a, vector_clock_to_val t')
  end.

Program Instance Inj_vector_clock : Inj eq eq vector_clock_to_val.
Next Obligation.
  intros x; induction x as [ | h x' IH]; intros y Heq;
    destruct y; [done | done | done |].
  inversion Heq as [[Hh Ht]].
  apply f_equal2; [by apply Z_of_nat_inj | by apply IH].
Qed.

Definition vector_clock_le (t t' : vector_clock) := Forall2 le t t'.

Definition vector_clock_lt (t t' : vector_clock) :=
  vector_clock_le t t' ∧ Exists (λ x, x.1 < x.2) (zip t t').

Instance vector_clock_le_dec : RelDecision vector_clock_le.
Proof. apply Forall2_dec; apply _. Qed.

Instance vector_clock_lt_dec : RelDecision vector_clock_lt.
Proof. intros ? ?; apply and_dec; apply _. Qed.

Instance vector_clock_le_PO : PartialOrder vector_clock_le.
Proof.
  split; first split.
  - intros ?; rewrite /vector_clock_le /=; reflexivity.
  - intros ???; rewrite /vector_clock_le /=; etrans; eauto.
  - intros ? ?; rewrite /vector_clock_le /=.
    revert y; induction x as [|a x].
    + by inversion 1; simplify_eq.
    + intros [|b y]; first by inversion 1.
      do 2 inversion 1; simplify_eq.
      auto with f_equal lia.
Qed.

Lemma vector_clock_lt_irreflexive x : ¬ vector_clock_lt x x.
Proof.
  intros [? (?&(?&?&?&?&?&?)%elem_of_lookup_zip_with_1&?)%Exists_exists];
    simplify_eq/=; lia.
Qed.

Instance vector_clock_lt_transitive : Transitive vector_clock_lt.
Proof.
  intros x y z
         [Hxy1 (?&(i&xi&yi&?&Hi1&Hi2)%elem_of_lookup_zip_with_1&?)%Exists_exists]
         [Hyz1 Hyz2];
    simplify_eq/=.
  split; first etrans; eauto.
  apply Exists_exists.
  destruct (Forall2_lookup_l _ _ _ _ _ Hyz1 Hi2) as (zi&?&?).
  exists (xi, zi); split; last by simpl; lia.
  apply elem_of_lookup_zip_with; eauto 10.
Qed.

Lemma vector_clock_lt_le t t' : vector_clock_lt t t' → vector_clock_le t t'.
Proof. by intros [? ?]. Qed.

Lemma vector_clock_lt_exclusion t t' :
  vector_clock_lt t t' → vector_clock_lt t' t → False.
Proof.
  intros [Htt'1 (?&(i&xi&yi&?&Hi1&Hi2)%elem_of_lookup_zip_with_1&?)%Exists_exists]
         [Ht't1 Ht't2]; simplify_eq/=.
  pose proof (Forall2_lookup_lr _ _ _ _ _ _ Ht't1 Hi2 Hi1); lia.
Qed.

Lemma vector_clock_le_eq_or_lt t t' :
  vector_clock_le t t' → t = t' ∨ vector_clock_lt t t'.
Proof.
  intros Hlt.
  destruct (decide (t = t')) as [|Hneq]; first by left.
  right.
  split; first done.
  revert t' Hlt Hneq.
  induction t as [|a t IHt].
  - by inversion 1.
  - intros [|b t']; inversion 1; simplify_eq/=.
    intros.
    destruct (decide (a = b)); last by constructor 1; simpl; lia.
    subst.
    constructor 2; apply IHt; auto with f_equal.
Qed.

Lemma vector_clock_le_lt_trans t t' t'' :
  vector_clock_le t t' → vector_clock_lt t' t'' →
  vector_clock_lt t t''.
Proof.
  intros Hle [? Hlt]; split; first by etrans; eauto.
  apply Exists_exists in Hlt as
      (?&(i&xi&yi&?&Hi1&Hi2)%elem_of_lookup_zip_with_1&?); simplify_eq/=.
  destruct (Forall2_lookup_r _ _ _ _ _ Hle Hi1) as (zi&?&?).
  apply Exists_exists.
  eexists (zi, yi); split; last by simpl; lia.
  eapply elem_of_lookup_zip_with; eauto 10.
Qed.

Lemma vector_clock_lt_le_trans t t' t'' :
  vector_clock_lt t t' → vector_clock_le t' t'' →
  vector_clock_lt t t''.
Proof.
  intros [? Hlt] Hle; split; first by etrans; eauto.
  apply Exists_exists in Hlt as
      (?&(i&xi&yi&?&Hi1&Hi2)%elem_of_lookup_zip_with_1&?); simplify_eq/=.
  destruct (Forall2_lookup_l _ _ _ _ _ Hle Hi2) as (zi&?&?).
  apply Exists_exists.
  eexists (xi, zi); split; last by simpl; lia.
  eapply elem_of_lookup_zip_with; eauto 10.
Qed.

  Definition incr_time (t : vector_clock) (i : nat) :=
    <[ i := S (default 0 (t !! i)) ]> t.

  Lemma incr_time_length t i : length (incr_time t i) = length t.
  Proof. by rewrite /incr_time insert_length. Qed.

  Lemma incr_time_proj t i k :
    t !! i = Some k → (incr_time t i) !! i = Some (S k).
  Proof.
    rewrite /incr_time; intros Heq.
    rewrite list_lookup_insert; last by apply lookup_lt_is_Some_1; eauto.
    rewrite !Heq; done.
  Qed.

  Lemma incr_time_proj_neq t i j : i ≠ j → (incr_time t i) !! j = t !! j.
  Proof. apply list_lookup_insert_ne. Qed.

  Lemma incr_time_lt t i : i < length t → vector_clock_lt t (incr_time t i).
  Proof.
    intros Hit.
    destruct (lookup_lt_is_Some_2 t i) as [q Hq]; first done.
    split.
    - eapply Forall2_lookup; intros j.
      destruct (decide (i = j)) as [->|].
      + erewrite Hq, incr_time_proj; last done.
        constructor; auto.
      + rewrite incr_time_proj_neq; done.
    - apply Exists_exists.
      exists (q, S q); split; last by auto.
      apply elem_of_lookup_zip_with.
      eexists i, _, _; split_and!; auto.
      erewrite incr_time_proj; eauto.
  Qed.

Section Compute_Maximals.
  Context `{!EqDecision T, !Countable T} (f : T → vector_clock).

  Instance: RelDecision (λ x y, vector_clock_lt (f x) (f y)).
  Proof. solve_decision. Qed.

  Definition compute_maximals_as_list (g : gset T) : list T :=
    let el := elements g in
    (filter (λ x : T, (Forall (λ y, ¬ vector_clock_lt (f x) (f y)) el)) el).

  Definition compute_maximals (g : gset T) : gset T :=
    list_to_set (compute_maximals_as_list g).

  Lemma elem_of_compute_maximals_as_list1 g x :
    x ∈ compute_maximals_as_list g →
    x ∈ g ∧ ∀ y, y ∈ g → ¬ vector_clock_lt (f x) (f y).
  Proof.
    intros Ht.
    apply elem_of_list_filter in Ht as [Ht1 Ht2%elem_of_elements].
    split; first done.
    intros.
    eapply Forall_forall in Ht1; eauto.
    by apply elem_of_elements.
  Qed.

  Lemma elem_of_compute_maximals_as_list2 g x :
    x ∈ g → (∀ y, y ∈ g → ¬ vector_clock_lt (f x) (f y)) →
    x ∈ compute_maximals_as_list g.
  Proof.
    intros Ht1 Ht2.
    apply elem_of_list_filter; split; last by apply elem_of_elements.
    apply Forall_forall; intros ?; rewrite elem_of_elements; auto.
  Qed.

  Lemma compute_maximals_as_list_NoDup g : NoDup (compute_maximals_as_list g).
  Proof.
    apply NoDup_filter, NoDup_elements.
  Qed.

  Lemma elem_of_compute_maximals_as_list_union_singleton g z x:
    z ∈ compute_maximals_as_list g →
    z ∈ compute_maximals_as_list ({[x]} ∪ g) ∨
    (vector_clock_lt (f z) (f x) ∧ x ∈ compute_maximals_as_list ({[x]} ∪ g)).
  Proof.
    intros [Hz1 Hz2]%elem_of_compute_maximals_as_list1.
    destruct (decide (vector_clock_lt (f z) (f x))).
    - right; split; first done.
      apply elem_of_compute_maximals_as_list2; first set_solver.
      intros y [Hy%elem_of_singleton_1|Hy]%elem_of_union; first subst.
      + apply vector_clock_lt_irreflexive.
      + intros ?; apply (Hz2 y); first done.
        etrans; eauto.
    - left.
      apply elem_of_compute_maximals_as_list2; first set_solver.
      intros y [?%elem_of_singleton_1|]%elem_of_union; first subst; auto.
  Qed.

  Lemma find_one_maximal_in_maximals x g :
    x ∈ g →
    find_one_maximal f vector_clock_lt x (elements g)
      ∈ compute_maximals_as_list g.
  Proof.
    intros Hx.
    apply elem_of_compute_maximals_as_list2.
    - destruct (find_one_maximal_eq_or_elem_of f vector_clock_lt x (elements g))
        as [->|]; first done.
      by apply elem_of_elements.
    - intros ? ?%elem_of_elements.
      apply (find_one_maximal_maximal f vector_clock_lt vector_clock_le);
        eauto using vector_clock_le_eq_or_lt, vector_clock_lt_irreflexive,
        vector_clock_lt_exclusion, vector_clock_le_lt_trans, vector_clock_lt_le.
  Qed.

  Lemma compute_maximals_as_list_correct g x :
    x ∈ g →
    ∃ y, y ∈ compute_maximals_as_list g ∧ vector_clock_le (f x) (f y).
  Proof.
    intros Hx.
    exists (find_one_maximal f vector_clock_lt x (elements g));
      split.
    - by apply find_one_maximal_in_maximals.
    - apply (find_one_maximal_rel f vector_clock_lt vector_clock_le);
        eauto using vector_clock_lt_le.
  Qed.

  Definition compute_maximum (g : gset T) : option T :=
  match (compute_maximals_as_list g) with
  | [] => None
  | t :: l =>
    match l with
    | [] => Some t
    | _ => None
    end
  end.

  Definition IsMaximals (g g' : gset T) :=
    ∀ t : T, t ∈ g' ↔ t ∈ g ∧ ∀ t' : T, t' ∈ g → ¬ vector_clock_lt (f t) (f t').

  Definition IsMaximum (g : gset T) (mx : T) :=
    mx ∈ g ∧ ∀ t, t ∈ g → (¬ t = mx) → vector_clock_lt (f t) (f mx).

  Lemma compute_maximals_correct
        (g : gset T) : IsMaximals g (compute_maximals g).
  Proof.
    rewrite /compute_maximals.
    intros t; split.
    - intros Ht%elem_of_list_to_set.
      by apply elem_of_compute_maximals_as_list1.
    - intros [Ht1 Ht2].
      apply elem_of_list_to_set.
      by apply elem_of_compute_maximals_as_list2.
  Qed.

  Lemma compute_maximum_correct (g : gset T) :
    (∀ x y, x ∈ g → y ∈ g → f x = f y → x = y) →
    (∀ x, compute_maximum g = Some x ↔ IsMaximum g x).
  Proof.
    intros Hginj.
    rewrite /compute_maximum.
    intros x; split; intros Hx.
    - destruct (compute_maximals_as_list g) as [|z []] eqn:Heql; simplify_eq/=.
      assert (∀ y, y ∈ compute_maximals_as_list g ↔ y = x) as Hx.
      { rewrite Heql; set_solver. }
      split.
      + by apply elem_of_compute_maximals_as_list1; apply Hx.
      + intros t Ht Htx.
        pose proof (compute_maximals_as_list_correct _ _ Ht) as (y & Hy1 & Hy2).
        apply Hx in Hy1; subst.
        apply vector_clock_le_eq_or_lt in Hy2 as [Hy2|Hy2]; last done.
        contradict Htx; apply Hginj; auto.
        by apply elem_of_compute_maximals_as_list1, Hx.
    - destruct (compute_maximals_as_list g) as [|z []] eqn:Heql.
      + destruct Hx as [Hx1 Hx2].
        apply compute_maximals_as_list_correct in Hx1 as (y & Hy1 & Hy2).
        rewrite Heql in Hy1; eapply elem_of_nil in Hy1; done.
      + destruct Hx as [Hx1 Hx2].
        destruct (decide (z = x)) as [->|Hneq]; first done.
        pose proof (elem_of_compute_maximals_as_list1 g z) as [Hz1 Hz2].
        { rewrite Heql; constructor. }
        specialize (Hz2 x Hx1).
        specialize (Hx2 _ Hz1 Hneq); done.
      + destruct Hx as [Hx1 Hx2].
        assert (z ≠ x ∨ t ≠ x) as [Hzx|Htx].
        { destruct (decide (z = x)); last by eauto.
          destruct (decide (t = x)); last by eauto.
          pose proof (compute_maximals_as_list_NoDup g) as Hnd.
          rewrite Heql in Hnd.
          apply NoDup_cons in Hnd as [[Hneq1 Hnin1]%not_elem_of_cons Hnd].
          simplify_eq. }
        * assert (z ∈ compute_maximals_as_list g) as Hzmg.
          { rewrite Heql; repeat constructor. }
          pose proof (elem_of_compute_maximals_as_list1 g z Hzmg) as [Hzg Hz].
          exfalso; by eapply Hz; last apply Hx2.
        * assert (t ∈ compute_maximals_as_list g) as Htmg.
          { rewrite Heql; repeat constructor. }
          pose proof (elem_of_compute_maximals_as_list1 g t Htmg) as [Htg Ht].
          exfalso; by eapply Ht; last apply Hx2.
  Qed.

End Compute_Maximals.