Require Import Utf8 ssreflect ssrfun.

Set Implicit Arguments.

Unset Strict Implicit.

Axiom NNPP:forall a,~~a->a.

Goal Type.
Proof.
exact Type.
Qed.

Goal Set.
Proof.
exact nat.
Qed.

Goal Prop.
Proof.
exact True.
Qed.

Definition imp a b:=a → b.

Definition ref U R:=∀x:U,R x x.

Goal ref imp.
Proof.
refine(λ(x:Type)(H:x),_).
exact H.
Qed.

Goal forall U(x:U),id x = x.
Proof.
refine(λ(U:Type)(x:U),_).
exact eq_refl.
Qed.

Definition tran U R:=∀x y z:U,R x y → R y z → R x z.

Goal tran imp.
Proof.
refine(λ(x y z:Type)(H:imp x y)(H0:imp y z)(H1:x),_:z).
exact(H0(H H1)).
Qed.

Goal tran imp.
Proof.
cbv.
refine(λ x y z:Type,_).
exact catcomp.
Qed.

Definition l_total A B R:=∀a:A,∃b:B,R a b.

Goal ∀U(R:U → U → Prop),ref R → l_total R.
Proof.
refine(λ(U:Type)(R:U → U → Prop)(H:ref R)(a:U),_).
refine(ex_intro _ a _).
exact(H a).
Qed.

Definition r_total A B R:=∀b:B,∃a:A,R a b.

Goal ∀U(R:U → U → Prop),ref R → r_total R.
Proof.
firstorder.
Qed.

Definition imp'(a b:Prop):=a → b.

Definition antsym U R:=∀x y:U,R x y → R y x → x = y.

Definition eqprop:=∀a b,a ↔ b → a = b.

Goal eqprop → antsym imp'.
Proof.
intro.
red.
intros.
red in H.
apply H.
red in H0,H1.
tauto.
Qed.

Definition em:=∀a,a∨¬a.

Definition nnpp:=∀a,¬¬a → a.

Goal em ↔ nnpp.
Proof.
split.
intro.
red.
intros.
red in H.
destruct(H a).
auto.
contradiction.
intro.
red.
intro.
red in H.
apply H.
intro.
apply H0.
right.
intro.
apply H0.
left.
auto.
Qed.

Definition pasu:=∀a b:Prop,((a → b) → a) → a.

Goal pasu ↔ nnpp.
Proof.
split.
intro.
red.
intros.
red in H.
specialize(H (a)(~a)).
apply H.
intro.
clear H.
exfalso.
apply H0.
intro.
apply H0.
apply H1.
auto.
intro.
red.
intros a b.
apply H.
intro.
apply H0.
intro.
apply H1.
intro.
apply H.
intro.
apply H0.
intro.
auto.
Qed.

Goal pasu ↔ em.
Proof.
split.
intro.
red.
intro.
red in H.
specialize(H(a\/~a)(~a)).
apply H.
intro.
right.
intro.
clear H.
destruct H0.
tauto.
auto.
intro.
red.
intros.
red in H.
specialize(H(a)).
destruct H.
auto.
apply H0.
intro.
contradiction.
Qed.

Definition total U R:=∀x y:U,R x y∨R y x.

Goal em → total imp'.
Proof.
intro.
red.
intros.
cbv.
red in H.
destruct(H x).
right.
auto.
left.
tauto.
Qed.

Goal ∀U(R:U → U → Prop),total R → ref R.
Proof.
intros.
red.
intro.
red in H.
specialize(H x x).
tauto.
Qed.

Definition iref U R:=∀x:U,R x x → False.

Goal ∀U(R:U → U → Type),U → ref R → ¬iref R.
Proof.
intros.
intro.
red in X0,H.
specialize(X0 X).
specialize(H X).
apply(H X0).
Qed.

Definition asym U R:=∀x y:U,R x y → R y x → False.

Goal ∀U(R:U → U → Type),asym R → iref R.
Proof.
intros.
red.
intros.
red in H.
specialize(H x x).
tauto.
Qed.

Goal ∀U(R:U → U → Type),asym R → antsym R.
Proof.
intros.
red.
intros.
red in H.
specialize(H x y).
tauto.
Qed.

Goal ∀U(R:U → U → Type),tran R → iref R → asym R.
Proof.
intros.
red.
intros.
red in X,H.
specialize(H x).
specialize(X x y x).
exact(H(X X0 X1)).
Qed.

Definition sym U R:=∀x y:U,R x y → R y x.

Goal ∀U(R:U → U → Prop),
 tran R → sym R → l_total R → ref R.
Proof.
intros.
red.
intro.
red in X,X0,H.
destruct(H x).
clear H.
specialize(X x x0 x).
specialize(X0 x x0).
exact(X H0(X0 H0)).
Qed.

Goal ∀U(R:U → U → Prop),
 tran R → sym R → r_total R → ref R.
Proof.
firstorder.
Qed.

Goal sym imp' → False.
Proof.
intro.
red in X.
specialize(X False True).
cbv in X.
tauto.
Qed.

Definition or a b:=a∨b.

Goal sym or.
Proof.
red.
intros.
red.
red in H.
tauto.
Qed.

Goal l_total or.
Proof.
red.
intro.
cbv.
exists True.
tauto.
Qed.

Goal ∀U(R:U → U → Prop),sym R → l_total R ↔ r_total R.
Proof.
intros.
red in X.
cbv.
split.
intros.
specialize(H b).
destruct H.
specialize(X b x).
exists x.
tauto.
firstorder.
destruct(H a).
firstorder.
Qed.

Goal ref or → False.
Proof.
intro.
red in X.
specialize(X False).
case X;auto.
Qed.

Goal ¬iref or.
Proof.
intro.
red in H.
specialize(H True).
apply H.
red.
tauto.
Qed.

Definition and a b:=a∧b.

Goal sym and.
Proof.
red.
cbv.
intros.
tauto.
Qed.

Goal ¬l_total and.
Proof.
intro.
red in H.
specialize(H False).
destruct H.
red in H.
destruct H.
auto.
Qed.

Goal tran and.
Proof.
red.
cbv.
intros.
destruct H,H0.
tauto.
Qed.

Goal eqprop → antsym and.
Proof.
cbv.
intros.
apply H.
destruct H0,H1.
split.
tauto.
tauto.
Qed.

Goal ¬iref and.
Proof.
intro.
cbv in H.
specialize(H True).
apply H.
tauto.
Qed.

Definition iff a b:=a ↔ b.

Goal ref iff.
Proof.
red.
intro.
red.
tauto.
Qed.

Goal ¬total iff.
Proof.
intro.
red in H.
unfold iff in H.
specialize(H False True).
destruct H.
destruct H.
apply H0.
split.
tauto.
Qed.

Goal tran iff.
Proof.
red.
intros.
red.
red in H,H0.
tauto.
Qed.

Goal eqprop → antsym iff.
Proof.
cbv.
intros.
apply H.
auto.
Qed.

Definition eq U x y:=x = y:>U.

Goal ∀U,ref(@eq U).
Proof.
intro.
red.
intro.
red.
split.
Qed.

Goal ¬∀U,total(@eq U).
Proof.
intro.
red in H.
cbv in H.
specialize(H Prop True False).
destruct H.
destruct H.
split.
rewrite H.
split.
Qed.

Goal ∀U,tran(@eq U).
Proof.
intro.
red.
intros.
red.
red in H,H0.
congruence.
Qed.

Goal ∀U,antsym(@eq U).
Proof.
intro.
red.
cbv.
intros.
auto.
Qed.

Definition max U R(a:U):=∀x:U,R x a.

Definition min U R(a:U):=∀x:U,R a x.

Goal max imp True.
Proof.
red.
intro.
red.
intro.
split.
Qed.

Goal min imp False.
Proof.
cbv.
intros.
case H.
Qed.

Goal max or True.
Proof.
cbv.
intro.
right.
split.
Qed.

Goal min or True.
Proof.
cbv.
intro.
left.
split.
Qed.

Goal ∀x,max and x → False.
Proof.
intros.
cbv in X.
specialize(X False).
destruct X.
auto.
Qed.

Definition uni U P:=∀ x1 x2:U,P x1 → P x2 → x1 = x2.

Goal ∀U(R:U → U → Type),antsym R → uni(max R).
Proof.
intros.
red.
intros.
red in H,X,X0.
specialize(H x1 x2).
specialize(X x2).
specialize(X0 x1).
auto.
Qed.

Goal ∀U(R:U → U → Type),antsym R → uni(min R).
Proof.
firstorder.
Qed.

Definition maximal U R(a:U):=∀x:U,R a x → a = x.

Definition minimal U R(a:U):=∀x:U,R x a → a = x.

Goal ∀U R(a:U),antsym R → max R a → maximal R a.
Proof.
intros.
red.
intros.
red in H,X.
specialize(H a x).
specialize(X x).
auto.
Qed.

Goal ∀U R(a:U),antsym R → min R a → minimal R a.
Proof.
firstorder.
Qed.

Goal ∀U R(a b:U),max R a → maximal R b → a = b.
Proof.
intros.
red in X,H.
specialize(H a).
specialize(X b).
firstorder.
Qed.

Goal ∀U R(a b:U),min R a → minimal R b → a = b.
Proof.
firstorder.
Qed.

Goal ∀U R(a:U),total R → maximal R a → max R a.
Proof.
intros.
red.
intro.
red in H,H0.
specialize(H a x).
destruct H.
specialize(H0 x).
specialize(H0 H).
subst.
auto.
auto.
Qed.

Goal ∀U R(a:U),total R → minimal R a → min R a.
Proof.
cbv.
firstorder.
case(H a x).
auto.
firstorder.
specialize(H0 x H1).
subst.
auto.
Qed.

Definition com U(f:U → U → U):=∀a b,f a b = f b a.

Definition aso U f:=
 ∀a b c:U,f a (f b c) = f (f a b) c.

Goal eqprop → com or.
Proof.
cbv.
intros.
apply H.
split.
tauto.
tauto.
Qed.

Goal eqprop → com and.
Proof.
cbv.
intros.
apply H.
split.
tauto.
tauto.
Qed.

Goal eqprop → aso or.
Proof.
cbv.
intros.
apply H.
split.
tauto.
tauto.
Qed.

Goal eqprop → com iff.
Proof.
cbv.
intros.
apply H.
split.
tauto.
tauto.
Qed.

Definition inj A B(f:A → B):=
 ∀a1 a2,f a1 = f a2 → a1 = a2.

Definition sur A B f:=∀b:B,∃a:A,f a = b.

Definition not a:=a → False.

Definition not' a:=¬a.

Goal nnpp → eqprop → inj not'.
Proof.
intro.
red.
intros.
apply H0.
cbv in H1.
split.
intro.
apply H.
intro.
red in H3.
rewrite <-H1 in H3.
auto.
intro.
apply H.
intro.
red in H3.
rewrite H1 in H3.
auto.
Qed.

Goal nnpp → eqprop → sur not'.
Proof.
intros.
red.
intro.
unfold not'.
exists(~b).
apply H0.
split.
intro.
apply H.
auto.
intro.
intro.
auto.
Qed.

Goal ∀U,inj(@id U).
Proof.
intro.
red.
intros.
cbv in H.
auto.
Qed.

Goal ∀U,sur(@id U).
Proof.
cbv.
intros.
exists b.
split.
Qed.

Goal inj S.
Proof.
red.
intros.
injection H.
auto.
Qed.

Goal ¬sur S.
Proof.
intro.
red in H.
specialize(H 0).
destruct H.
discriminate.
Qed.

Definition hmm1 A B fa fb (f:A → B):=
 ∀a,f (fa a) = fb (f a).

Definition hmm2 A B fa fb (f:A → B):=
 ∀a1 a2,f (fa a1 a2) = fb (f a1) (f a2).

Goal eqprop → hmm2 or and not.
Proof.
red.
intros.
apply H.
cbv.
split.
intro.
split.
intro.
apply H0.
auto.
tauto.
intros.
destruct H0.
destruct H1.
auto.
auto.
Qed.

Goal eqprop → nnpp → hmm2 and or not.
Proof.
intros.
red.
intros.
apply H;clear H.
cbv.
split.
intros.
apply H0.
intro.
apply H1.
left.
intro.
apply H1.
right.
intro.
apply H.
tauto.
intros.
destruct H1.
destruct H.
auto.
auto.
Qed.

Definition all U P:=∀x:U,P x.

Definition ex U P:=∃x:U,P x.

Definition comple U P(x:U):=P x → False.

Goal ∀U(P:U → Type),ex(comple P) → not(all P).
Proof.
intros.
red.
intro.
red in H,X.
destruct H.
red in H.
specialize(X x).
auto.
Qed.

Goal nnpp → ∀U(P:U → Prop),not(all P) → ex(comple P).
Proof.
intros.
red.
red in H0.
apply H.
intro.
apply H0.
red.
intro.
apply H.
intro.
apply H1.
exists x.
red.
apply H2.
Qed.

Goal ∀U(P:U → Prop),¬ex P → all(comple P).
Proof.
intros.
red.
intro.
red.
intro.
red in H.
apply H.
red.
exists x.
auto.
Qed.

Goal ∀U(P:U → Prop),all(comple P) → ¬ex P.
Proof.
intros.
intro.
red in X,H.
destruct H.
specialize(X x).
red in X.
auto.
Qed.

Definition union U P Q(x:U):=P x∨Q x.

Goal ∀U(A B:U → Prop),ex(union A B) ↔ ex A∨ex B.
Proof.
intros.
split.
intro.
red in H.
destruct H.
red in H.
destruct H.
left.
red.
exists x.
auto.
right.
firstorder.
intro.
red.
destruct H.
red in H.
destruct H.
exists x.
red.
tauto.
firstorder.
Qed.

Definition inter U P Q(x:U):=P x∧Q x.

Definition all' U(P:U → Prop):=∀x,P x.

Goal ∀U(A B:U → Prop),all'(inter A B) ↔ all' A∧all' B.
Proof.
intros.
split.
intro.
red in H.
split.
red.
intro.
specialize(H x).
red in H.
tauto.
firstorder.
intro.
red.
intro.
red.
destruct H.
red in H,H0.
firstorder.
Qed.

Definition inc U A B:=∀x:U,A x → B x.

Definition same U A B:=∀x:U,A x ↔ B x.

Goal ∀U,ref(@inc U).
Proof.
intro.
red.
intro.
red.
intros.
rename x into A.
auto.
Qed.

Goal ∀U,tran(@inc U).
Proof.
intro.
red.
intros.
red.
intros.
red in X,X0.
rename x into A.
rename y into B.
rename z into C.
specialize(X x0).
specialize(X0 x0).
auto.
Qed.

Definition eqset:=∀U(A B:U → Prop),same A B → A = B.

Definition inc' U(A B:U → Prop):=∀x:U,A x → B x.

Goal eqset → ∀U,antsym(@inc' U).
Proof.
intros.
red.
intros.
apply H.
red.
intro.
rename x into A.
rename y into B.
red in H0,H1.
split.
firstorder.
firstorder.
Qed.

Definition full U(x:U):=True.

Definition emp U(x:U):=False.

Goal ∀U,max(@inc U)(@full U).
Proof.
intro.
red.
intro.
red.
intros.
rename x into A.
red.
split.
Qed.

Goal ∀U,min(@inc U)(@emp U).
Proof.
intro.
red.
intro.
rename x into A.
red.
intros.
red in H.
tauto.
Qed.

Goal ∀U,ref(@same U).
Proof.
intro.
red.
intros.
red.
intro.
tauto.
Qed.

Definition exinj A B:=∃f:A → B,inj f.

Goal ref exinj.
Proof.
red.
intro.
red.
exists(@id x).
red.
intros.
cbv in H.
auto.
Qed.

Goal tran exinj.
Proof.
red.
intros.
red.
red in H,H0.
destruct H,H0.
red in H,H0.
rename x0 into f.
rename x1 into g.
exists(fun x=>g(f x)).
red.
intros.
specialize(H a1 a2).
apply H.
specialize(H0(f a1)(f a2)).
auto.
Qed.

Definition comp A B C(f:A → B)(g:B → C)x:=g(f x).

Goal ∀A B C D(f:A → B)(g:B → C)(h:C → D),
 comp f(comp g h) = comp(comp f g)h.
Proof.
intros.
cbv.
split.
Qed.

Goal ∀A B C D(f:A → B)(g:B → C)(h:C → D),
 f\;g\;h = (f\;g)\;h.
intros.
cbv.
split.
Qed.

Goal ∀U,aso(@comp U U U).
Proof.
intro.
red.
intros.
cbv.
split.
Qed.

Goal ∀A B C(f:A → B)(g:B → C),
 inj f → inj g → inj(comp f g).
Proof.
intros.
red.
intros.
red in H,H0.
unfold comp in H1.
specialize(H a1 a2).
apply H.
specialize(H0(f a1)(f a2)).
auto.
Qed.

Goal ∀A B C(f:A → B)(g:B → C),
 sur f → sur g → sur(comp f g).
Proof.
intros.
red.
intro.
unfold comp.
red in H,H0.
specialize(H0 b).
destruct H0.
specialize(H x).
destruct H.
exists x0.
congruence.
Qed.

Definition eqf A B(f g:A → B):=∀x,f x = g x.

Goal ∀A B,ref(@eqf A B).
Proof.
intros.
red.
intro.
red.
intro.
split.
Qed.

Goal ∀A B,tran(@eqf A B).
Proof.
intros.
red.
intros.
red.
intro.
red in H,H0.
rename x into f.
rename y into g.
rename z into h.
specialize(H x0).
specialize(H0 x0).
congruence.
Qed.

Goal ∀A B,sym(@eqf A B).
Proof.
intros.
red.
intros.
red.
intro.
red in H.
specialize(H x0).
firstorder.
Qed.

Definition l_nuet U f(e:U):=∀x:U,f e x = x.

Definition r_nuet U f(e:U):=∀x:U,f x e = x.

Definition nuet U f(e:U):=l_nuet f e∧r_nuet f e.

Goal ∀U f(e1 e2:U),l_nuet f e1 → r_nuet f e2 → e1 = e2.
Proof.
intros.
red in H,H0.
specialize(H e2).
specialize(H0 e1).
congruence.
Qed.

(*Definition cancel U f(e x y:U):=f x y = e.*)

Goal ∀U f(e a1 a2 b:U),
 aso f →
 nuet f e →
 f a1 b = e →
 f b a2 = e →
 a1 = a2.
Proof.
intros.
red in H,H0.
destruct H0.
red in H0,H3.
specialize(H0 a2).
rewrite<-H0.
case H1.
case H.
rewrite H2.
specialize(H3 a1).
rewrite H3.
split.
Qed.

Inductive set:=sup:∀A,(A → set) → set.

Definition pair e1 e2:=
 sup(λ x,if x then e1 else e2).

Fixpoint Eqset e1 e2:=
 match e1,e2 with
  |sup f,sup g =>
    ∀a,∃b,Eqset(f a)(g b)∧
    ∀b,∃a,Eqset(f a)(g b)
 end.

Definition In e1 e2:=
 match e2 with
  |sup f => ∃a,Eqset e1(f a)
 end.

Goal ∀a b:set,In a(pair a b).
Proof.
induction a.
destruct b.
red.
exists true.
simpl.
intro.
exists a.
split.
specialize(H a(s a)).
destruct H.
destruct x.
auto.
auto.
intro.
exists b.
specialize(H b(s b)).
destruct H.
destruct x.
auto.
auto.
Qed.

Definition empty:=

Definition l_inv U f e x':=nuet f e∧∀x:U,f x' x = e.

Definition r_inv U f e x':=nuet f e∧∀x:U,f x x' = e.

Definition inv U f(e x':U):=l_inv f e x'∧r_inv f e x'.

Goal ∀U f(e:U),aso f → uni(inv f e).
Proof.
intros.
red.
intros.
red in H,H0,H1.
destruct H0,H1.
red in H0,H2,H1,H3.
destruct H0,H2,H1,H3.
red in H0,H2,H1,H3.

Goal nuet f e -> aso f -> f x x'=e

Goal

Definition cancel

Definition id'{U}x:=x:U.

Goal ∀A (f:A → A),comp id' f = id'.
Goal ∀U,@min(U->Type) (@inc U)(@emp U).

Goal ¬∀U,total(@inc' U).
Proof.
intro.

intro.
red in H.
unfold inc' in H.

specialize(H Prop).
red in H.

intros.
rename x into A.
rename y into B.
unfold inc'.
apply NNPP.
intro.
apply H0.
left.
intros.
apply NNPP.
intro.
apply H0.
right.
intros.
apply NNPP.
intro.
apply H0.
assert((forall x,A x)\/~forall x,A x).
apply H.
destruct H0.
right.
intros.
firstorder.
left.
intros.
apply NNPP.
intro.
apply H0.

assert(forall x,A x\/~A x).
intro.
apply H.
unfold inc'.
assert(inhabited U\/~inhabited U).
apply H.
destruct H1.
destruct H1.
specialize(H0 X).
destruct H0.
right.
intros.
auto.
red in H.
specialize(H(inc' A B)).
cbv in H.
destruct H.
left.
auto.
right.
red.
intros.
assert(~~A x).
intro.
apply H.
intros.
op),not(all P)->ex(not' P).

Goal ∀U,hmm1 (@all U) (@ex U) not.

Goal forall a b,~(a\/b)<->~a/\~b.
tauto.

Goal eqprop → ∀(P:Prop)(p1 p2:P),p1 = p2.
intros.
red in H.

destruct P.
split.
specialize(H P P).
apply H.

Variant T1:=t1.

Variant T2:=t2.

Goal exists f:T1->T2,inj f.
exists(fun

cbv.

intros.
apply H.

Goal eqprop->¬aso iff.
intro.
intro.
red in H0.
unfold iff in H0.
specialize(H0 True True False).
assert(False<->(False<->True)).
rewrite H0.
tauto.
destruct H1.

destruct H0.

destruct H.

Goal ∀U(P:U → Prop),
uni P ∧ (∃x:U,P x) ↔ exists! x:U,P x.
split.

Goal ~forall a b:Prop,(a->b)->b->a.
exact Unnamed_thm15.
Qed.

Print Unnamed_thm16.

Goal sym imp ->False.
exact Unnamed_thm15.

Goal forall U(R:U->U->Prop),
U->(forall x,R x x)->~forall x,R x x->False.
intros U R.
apply Unnamed_thm9.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype tuple finfun bigop prime binomial.
From mathcomp Require Import ssralg finset fingroup finalg matrix.
Require Import Reals Fourier.
Require Import ssrR Reals_ext logb ssr_ext ssralg_ext.

(** * Instantiation of canonical big operators with Coq reals *)

Notation "\rsum_ ( i <- r | P ) F" := (\big[Rplus/R0]_(i <- r | P%B) F)
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \rsum_ ( i  <-  r  |  P ) '/  '  F ']'").
Notation "\rsum_ ( i <- r ) F" :=  (\big[Rplus/R0]_(i <- r) F)
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \rsum_ ( i  <-  r ) '/  '  F ']'").
Notation "\rsum_ ( m <= i < n | P ) F" := (\big[Rplus/R0]_(m <= i < n | P%B) F)
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \rsum_ ( m  <=  i  <  n  |  P ) '/  '  F ']'").
Notation "\rsum_ ( m <= i < n ) F" := (\big[Rplus/R0]_(m <= i < n) F)
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \rsum_ ( m  <=  i  <  n ) '/  '  F ']'").
Notation "\rsum_ ( i | P ) F" := (\big[Rplus/R0]_(i | P%B) F)
  (at level 41, F at level 41, i at level 50,
           format "'[' \rsum_ ( i  |  P ) '/  '  F ']'").
Notation "\rsum_ ( i : t | P ) F" := (\big[Rplus/R0]_(i : t | P%B) F)
  (at level 41, F at level 41, i at level 50,
           only parsing).
Notation "\rsum_ ( i : t ) F" := (\big[Rplus/R0]_(i : t) F)
  (at level 41, F at level 41, i at level 50,
           only parsing).
Notation "\rsum_ ( i < n | P ) F" := (\big[Rplus/R0]_(i < n | P%B) F)
  (at level 41, F at level 41, i, n at level 50,
           format "'[' \rsum_ ( i  <  n  |  P ) '/  '  F ']'").
Notation "\rsum_ ( i < n ) F" := (\big[Rplus/R0]_(i < n) F)
  (at level 41, F at level 41, i, n at level 50,
           format "'[' \rsum_ ( i  <  n ) '/  '  F ']'").
Notation "\rsum_ ( i 'in' A | P ) F" := (\big[Rplus/R0]_(i in A | P%B) F)
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \rsum_ ( i  'in'  A  |  P ) '/  '  F ']'").
Notation "\rsum_ ( i 'in' A ) F" := (\big[Rplus/R0]_(i in A) F)
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \rsum_ ( i  'in'  A ) '/  '  F ']'").

Notation "\rprod_ ( i <- r | P ) F" := (\big[Rmult/R1]_(i <- r | P%B) F)
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \rprod_ ( i  <-  r  |  P ) '/  '  F ']'").
Notation "\rprod_ ( i <- r ) F" :=  (\big[Rmult/R1]_(i <- r) F)
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \rprod_ ( i  <-  r ) '/  '  F ']'").
Notation "\rprod_ ( m <= i < n | P ) F" := (\big[Rmult/R1]_(m <= i < n | P%B) F)
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \rprod_ ( m  <=  i  <  n  |  P ) '/  '  F ']'").
Notation "\rprod_ ( m <= i < n ) F" := (\big[Rmult/R1]_(m <= i < n) F)
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \rprod_ ( m  <=  i  <  n ) '/  '  F ']'").
Notation "\rprod_ ( i | P ) F" := (\big[Rmult/R1]_(i | P%B) F)
  (at level 41, F at level 41, i at level 50,
           format "'[' \rprod_ ( i  |  P ) '/  '  F ']'").
Notation "\rprod_ ( i : t | P ) F" := (\big[Rmult/R1]_(i : t | P%B) F)
  (at level 41, F at level 41, i at level 50,
           only parsing).
Notation "\rprod_ ( i : t ) F" := (\big[Rmult/R1]_(i : t) F)
  (at level 41, F at level 41, i at level 50,
           only parsing).
Notation "\rprod_ ( i < n | P ) F" := (\big[Rmult/R1]_(i < n | P%B) F)
  (at level 41, F at level 41, i, n at level 50,
           format "'[' \rprod_ ( i  <  n  |  P ) '/  '  F ']'").
Notation "\rprod_ ( i < n ) F" := (\big[Rmult/R1]_(i < n) F)
  (at level 41, F at level 41, i, n at level 50,
           format "'[' \rprod_ ( i  <  n ) '/  '  F ']'").
Notation "\rprod_ ( i 'in' A | P ) F" := (\big[Rmult/R1]_(i in A | P%B) F)
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \rprod_ ( i  'in'  A  |  P ) '/  '  F ']'").
Notation "\rprod_ ( i 'in' A ) F" := (\big[Rmult/R1]_(i in A) F)
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \rprod_ ( i  'in'  A ) '/  '  F ']'").

Notation "\rmax_ ( i <- r | P ) F" := (\big[Rmax/R0]_(i <- r | P%B) F)
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \rmax_ ( i  <-  r  |  P ) '/  '  F ']'").
Notation "\rmax_ ( i <- r ) F" :=  (\big[Rmax/R0]_(i <- r) F)
  (at level 41, F at level 41, i, r at level 50,
           format "'[' \rmax_ ( i  <-  r ) '/  '  F ']'").
Notation "\rmax_ ( i | P ) F" := (\big[Rmax/R0]_(i | P%B) F)
  (at level 41, F at level 41, i at level 50,
           format "'[' \rmax_ ( i  |  P ) '/  '  F ']'").
Notation "\rmax_ ( i : t | P ) F" := (\big[Rmax/R0]_(i : t | P%B) F)
  (at level 41, F at level 41, i at level 50,
           only parsing).
Notation "\rmax_ ( i : t ) F" := (\big[Rmax/R0]_(i : t) F)
  (at level 41, F at level 41, i at level 50,
           only parsing).
Notation "\rmax_ ( i 'in' A | P ) F" := (\big[Rmax/R0]_(i in A | P%B) F)
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \rmax_ ( i  'in'  A  |  P ) '/  '  F ']'").
Notation "\rmax_ ( i 'in' A ) F" := (\big[Rmax/R0]_(i in A) F)
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \rmax_ ( i  'in'  A ) '/  '  F ']'").
Reserved Notation "\min^ b '_(' a 'in' A ) F" (at level 41,
  F at level 41, a, A at level 50,
   format "'[' \min^ b '_(' a  'in'  A ) '/  '  F ']'").

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope reals_ext_scope.

Canonical addR_monoid := Monoid.Law addRA add0R addR0.
Canonical addR_comoid := Monoid.ComLaw addRC.
Canonical mulR_monoid := Monoid.Law mulRA mul1R mulR1.
Canonical mulR_muloid := Monoid.MulLaw mul0R mulR0.
Canonical mulR_comoid := Monoid.ComLaw mulRC.
Canonical addR_addoid := Monoid.AddLaw mulRDl mulRDr.

Lemma morph_Ropp : {morph [eta Ropp] : x y / x + y}.
Proof. by move=> x y /=; field. Qed.

Lemma morph_plus_INR : {morph INR : x y / (x + y)%nat >-> x + y}.
Proof. move=> x y /=; by rewrite plus_INR. Qed.

Lemma morph_mult_INR : {morph INR : x y / (x * y)%nat >-> x * y}.
Proof. move=> x y /=; by rewrite mult_INR. Qed.

Lemma morph_mulRDr a : {morph [eta Rmult a] : x y / x + y}.
Proof. move=> * /=; by rewrite mulRDr. Qed.

Lemma morph_mulRDl a : {morph Rmult^~ a : x y / x + y}.
Proof. move=> x y /=; by rewrite mulRDl. Qed.

Lemma morph_exp2_plus : {morph [eta exp2] : x y / x + y >-> x * y}.
Proof. move=> ? ? /=; by rewrite -ExpD. Qed.

Lemma iter_Rmax a b (Hb : b <= a) k : ssrnat.iter k (Rmax b) a = a.
Proof. elim: k => // k Hk; by rewrite iterS Hk Rmax_right. Qed.

(** Rle, Rlt lemmas for big sums of reals *)

Lemma rsum_setT (A : finType) (f : A -> R) (P : pred A) :
  \rsum_(i in A | P i) f i = \rsum_(i in [set: A] | P i) f i.
Proof. apply eq_bigl => x /=; by rewrite !inE. Qed.

Section ler_ltr_rsum.

Variables (A : finType) (f g : A -> R) (P Q : pred A).

Lemma ler_rsum_support (X : {set A}) :
  (forall i, i \in X -> P i -> f i <= g i) ->
  \rsum_(i in X | P i) f i <= \rsum_(i in X | P i) g i.
Proof.
move=> H.
elim: (index_enum _) => [|h t IH].
- rewrite !big_nil; exact/leRR.
- rewrite !big_cons.
  set K := _ && _; move HK : K => []; subst K => //.
  apply leR_add => //; case/andP : HK; exact: H.
Qed.

Lemma ler_rsum : (forall i, P i -> f i <= g i) ->
  \rsum_(i | P i) f i <= \rsum_(i | P i) g i.
Proof.
move=> H; rewrite rsum_setT [in X in _ <= X]rsum_setT.
apply ler_rsum_support => a _; exact: H.
Qed.

Lemma ler_rsum_l : (forall i, P i -> f i <= g i) ->
  (forall i, Q i -> 0 <= g i) ->
  (forall i, P i -> Q i) ->
  \rsum_(i | P i) f i <= \rsum_(i | Q i) g i.
Proof.
move=> f_g Qg H.
elim: (index_enum _) => [| h t IH].
- rewrite !big_nil; exact/leRR.
- rewrite !big_cons /=; case: ifP => [Ph|Ph].
    rewrite (H _ Ph); apply leR_add => //; exact: f_g.
  case: ifP => // Qh; apply: (leR_trans IH).
  rewrite -{1}[X in X <= _](add0R _); exact/leR_add2r/Qg.
Qed.

Lemma ler_rsum_l_support (R : pred A) :
  (forall a, 0 <= f a) -> (forall i, P i -> Q i) ->
  \rsum_(i in R | P i) f i <= \rsum_(i in R | Q i) f i.
Proof.
move=> Hf P_Q.
elim: (index_enum _) => [|h t IH].
- rewrite !big_nil; exact/leRR.
- rewrite !big_cons.
  set cond := _ \in _; move Hcond : cond => []; subst cond => //=.
  case: ifP => // HP.
  + case: ifP => [HQ|].
    * by apply leR_add2l.
    * by rewrite (P_Q _ HP).
  + case: ifP => // HQ.
    rewrite -[X in X <= _]add0R; exact/leR_add.
Qed.

Lemma ltr_rsum_support (X : {set A}) : (0 < #|X|)%nat ->
  (forall i, i \in X -> f i < g i) ->
  \rsum_(i in X) f i < \rsum_(i in X) g i.
Proof.
move Hn : #|X| => n.
elim: n X Hn => // n IH X Hn _ H.
move: (ltn0Sn n); rewrite -Hn card_gt0; case/set0Pn => a0 Ha0.
rewrite (@big_setD1 _ _ _ _ a0 _ f) //= (@big_setD1 _ _ _ _ a0 _ g) //=.
case: n => [|n] in IH Hn.
  rewrite (_ : X :\ a0 = set0); last first.
    move: Hn.
    by rewrite (cardsD1 a0) Ha0 /= add1n => -[] /eqP; rewrite cards_eq0 => /eqP.
  rewrite !big_set0 2!addR0; exact: H.
apply ltR_add; first exact/H.
apply IH => //.
- move: Hn; rewrite (cardsD1 a0) Ha0 /= add1n; by case.
- move=> a; rewrite in_setD inE => /andP[_ ?]; exact: H.
Qed.

Lemma ltR_rsum : (O < #|A|)%nat -> (forall i, f i < g i) ->
  \rsum_(i in A) f i < \rsum_(i in A) g i.
Proof.
move=> A0 H0.
have : forall i : A, i \in [set: A] -> f i < g i by move=> a _; exact/H0.
move/ltr_rsum_support; rewrite cardsT => /(_ A0).
rewrite big_mkcond /= [in X in _ < X]big_mkcond /=.
rewrite (eq_bigr f) //; last by move=> *; rewrite inE.
rewrite [in X in _ < X](eq_bigr g) //; by move=> *; rewrite inE.
Qed.

End ler_ltr_rsum.

Lemma ler_rsum_Rabs (A : finType) f : `| \rsum_(a : A) f a | <= \rsum_(a : A) `| f a |.
Proof.
elim: (index_enum _) => [|h t IH].
  rewrite 2!big_nil Rabs_R0; exact/leRR.
rewrite 2!big_cons.
apply (@leR_trans (`| f h | + `| \rsum_(j <- t) f j |));
  [exact/Rabs_triang |exact/leR_add2l].
Qed.

Lemma ler_rsum_predU (A : finType) (f : A -> R) (P Q : pred A) :
  (forall a, 0 <= f a) -> \rsum_(i in A | [predU P & Q] i) f i <=
  \rsum_(i in A | P i) f i + \rsum_(i in A | Q i) f i.
Proof.
move=> Hf.
elim: (index_enum _) => [|h t IH /=]; first by rewrite !big_nil /=; fourier.
rewrite !big_cons /=.
case: ifPn => /=.
- case/orP => [hP | hQ].
  + move: hP; rewrite unfold_in => ->.
    case: ifP => // Qh.
    * rewrite -addRA; apply leR_add2l.
      apply (leR_trans IH).
      have : forall a b c, 0 <= c -> a + b <= a + (c + b) by move=> *; fourier.
      apply; by apply Hf.
    * rewrite -addRA; apply leR_add2l.
      exact/(leR_trans IH)/Req_le.
  + move: hQ; rewrite unfold_in => ->.
    case: ifP => // Ph.
    * rewrite -addRA; apply/leR_add2l/(leR_trans IH).
      have : forall a b c, 0 <= c -> a + b <= a + (c + b) by move=> *; fourier.
      apply; by apply Hf.
    * rewrite -(addRC (f h + _)) -addRA; apply/leR_add2l/(leR_trans IH).
      by rewrite addRC; apply Req_le.
- rewrite negb_or.
  case/andP.
  rewrite !unfold_in; move/negbTE => -> /negbTE ->.
  exact/IH.
Qed.

Lemma rsumr_ge0 (A : finType) (P : pred A) f (H : forall i, P i -> 0 <= f i) :
  0 <= \rsum_(i in A | P i) f i.
Proof.
apply (@leR_trans (\rsum_(i | (i \in A) && P i) (fun=> 0) i)).
rewrite big_const iter_addR mulR0 /=; exact/leRR.
exact/ler_rsum.
Qed.

Lemma rsumr_gt0 (A : finType) (f : A -> R) (HA : (0 < #|A|)%nat) :
  (forall i, 0 < f i) -> 0 < \rsum_(i in A) f i.
Proof.
move=> H.
rewrite (_ : \rsum_(i in A) f i = \rsum_(i in [set: A]) f i); last first.
  apply eq_bigl => x /=; by rewrite !inE.
apply: leR_ltR_trans; last first.
  apply ltr_rsum_support with (f := fun=> 0) => //; by rewrite cardsT.
rewrite big_const_seq iter_addR mulR0; exact/leRR.
Qed.

Lemma prsumr_eq0P (A : finType) (P : pred A) f :
  (forall a, P a -> 0 <= f a) ->
  \rsum_(a | P a) f a = 0 <-> (forall a, P a -> f a = 0).
Proof.
move=> Hf; split=> [H a Ha|h]; last first.
  by rewrite (eq_bigr (fun=> 0)) // big_const iter_addR mulR0.
suff : f a = 0 /\ \rsum_(i | P i && (i != a)) f i = 0 by case.
apply: Rplus_eq_R0.
- exact/Hf/Ha.
- apply: rsumr_ge0 => ? /andP[? ?]; by apply Hf.
- rewrite -bigD1 /=; [exact H | exact Ha].
Qed.

(* TODO: factorize? *)
Lemma Rle_big_eq (A : finType) (f g : A -> R) (P : pred A) :
   (forall i : A, P i -> f i <= g i) ->
   \rsum_(i | P i) g i = \rsum_(i | P i) f i ->
   (forall i : A, P i -> g i = f i).
Proof.
move=> H1 H2 i Hi.
apply/eqP; rewrite -subR_eq0; apply/eqP.
move: i Hi.
apply prsumr_eq0P.
- move=> i Hi.
  rewrite leR_subr_addr add0R; exact: H1.
- rewrite big_split /= -(big_morph _ morph_Ropp oppR0).
  by apply/eqP; rewrite subR_eq0 H2.
Qed.

(** Rle, Rlt lemmas for big-mult of reals *)

Section ler_ltr_rprod.

Lemma rprodr_gt0 {A : finType} F : (forall i, 0 < F i) ->
  0 < \rprod_(i : A) F i.
Proof.
move=> H.
elim: (index_enum _) => [| hd tl IH].
rewrite big_nil; fourier.
rewrite big_cons; apply mulR_gt0 => //; by apply H.
Qed.

Lemma rprodr_ge0 {A : finType} F : (forall i, 0 <= F i) ->
  0 <= \rprod_(i : A) F i.
Proof.
move=> H.
elim: (index_enum _) => [| hd tl IH].
  rewrite big_nil; fourier.
rewrite big_cons; apply mulR_ge0 => //; exact H.
Qed.

Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

Lemma rprodr_gt0_inv {B : finType} F (HF: forall a, 0 <= F a) :
  forall n (x : 'rV[B]_n.+1),
  0 < \rprod_(i < n.+1) F (x ``_ i) -> forall i, 0 < F (x ``_ i).
Proof.
elim => [x | n IH].
  rewrite big_ord_recr /= big_ord0 mul1R => Hi i.
  suff : i = ord_max by move=> ->.
  rewrite (ord1 i).
  by apply/val_inj.
move=> x.
set t := \row_(i < n.+1) (x ``_ (lift ord0 i)).
rewrite big_ord_recl /= => H.
apply Rlt_0_Rmult_inv in H; last 2 first.
  exact/HF.
  apply rprodr_ge0 => ?; exact/HF.
case.
case=> [Hi | i Hi].
  rewrite (_ : Ordinal _ = ord0); last exact/val_inj.
  by case: H.
case: H => _ H.
have : 0 < \rprod_(i0 < n.+1) F (t ``_ i0).
  suff : \rprod_(i < n.+1) F (x ``_ (lift ord0 i)) =
         \rprod_(i < n.+1) F (t ``_ i) by move=> <-.
  apply eq_bigr => ? _; by rewrite mxE.
have Hi' : (i < n.+1)%nat by rewrite ltnS in Hi.
move/IH.
move/(_ (Ordinal Hi')).
set o1 := Ordinal _.
set o2 := Ordinal _.
suff : lift ord0 o1 = o2 by move=> <-; rewrite mxE.
by apply val_inj.
Qed.

Lemma rprodr_ge1 {A : finType}  f : (forall i, 1 <= f i) ->
  1 <= \rprod_(i : A) f i.
Proof.
move=> Hf.
elim: (index_enum _) => [| hd tl IH].
- rewrite big_nil; exact/leRR.
- rewrite big_cons -{1}(mulR1 1%R); apply leR_pmul => // ; fourier.
Qed.

Local Open Scope R_scope.

Lemma ler_rprod {A : finType} f g : (forall i, 0 <= f i <= g i) ->
  \rprod_(i : A) f i <= \rprod_(i : A) g i.
Proof.
move=> Hfg.
case/orP : (orbN [forall i, f i != 0%R]) ; last first.
- rewrite negb_forall => /existsP Hf.
  case: Hf => i0 /negPn/eqP Hi0.
  rewrite (bigD1 i0) //= Hi0 mul0R; apply rprodr_ge0.
  move=> i ; move: (Hfg i) => [Hi1 Hi2] ; exact: (leR_trans Hi1 Hi2).
- move=> /forallP Hf.
  have Hprodf : 0 < \rprod_(i : A) f i.
    apply rprodr_gt0 => a.
    move: (Hf a) (Hfg a) => {Hf}Hf {Hfg}[Hf2 _].
    apply/ltRP; rewrite lt0R Hf /=; exact/leRP.
  apply (@leR_pmul2r (1 * / \rprod_(i : A) f i) _ _).
    apply Rlt_mult_inv_pos => //; fourier.
  rewrite mul1R mulRV; last exact/eqP/gtR_eqF.
  set inv_spec := fun r => if r == 0 then 0 else / r.
  rewrite (_ : / (\rprod_(a : A) f a) = inv_spec (\rprod_(a : A) f a)) ; last first.
    rewrite /inv_spec (_ : \rprod_(a : A) f a == 0 = false) //.
    exact/eqP/gtR_eqF.
  rewrite (@big_morph _ _ (inv_spec) R1 Rmult R1 Rmult _); last 2 first.
  - move=> a b /=.
    case/boolP : ((a != 0) && (b != 0)).
    - move=> /andP [/negbTE Ha /negbTE Hb]; rewrite /inv_spec Ha Hb.
      move/negbT in Ha ; move/negbT in Hb.
      have -> : (a * b)%R == 0 = false by rewrite mulR_eq0 (negbTE Ha) (negbTE Hb).
      rewrite invRM //; exact/eqP.
    - rewrite negb_and !negbK => /orP[|]/eqP ->;
        by rewrite /inv_spec !(eqxx,mul0R,mulR0).
  - rewrite /inv_spec ifF ?invR1 //; exact/negbTE/eqP/R1_neq_R0.
  rewrite -big_split /=.
  apply rprodr_ge1 => a.
  move/(_ a) in Hf.
  move: Hfg => /(_ a) [Hf2 Hfg].
  rewrite /inv_spec.
  move/negbTE in Hf; rewrite Hf; move/negbT in Hf.
  rewrite -(mulRV (f a)) //.
  apply leR_wpmul2r => //.
  rewrite -(mul1R (/ f a)).
  apply divR_ge0; [fourier | apply/ltRP; rewrite lt0R Hf; exact/leRP].
Qed.

End ler_ltr_rprod.

Lemma classify_big (A : finType) n (f : A -> 'I_n) (F : 'I_n -> R) :
  \rsum_(s : A) F (f s) = \rsum_(i < n) INR #|f @^-1: [set i]| * F i.
Proof.
transitivity (\rsum_(i < n) \rsum_(s | true && (f s == i)) F (f s)).
  by apply partition_big.
apply eq_bigr => i _ /=.
transitivity (\rsum_(s | f s == i) F i); first by apply eq_bigr => s /eqP ->.
rewrite big_const iter_addR; congr (INR _ * _).
apply eq_card => j /=; by rewrite !inE.
Qed.

Section pascal.

Lemma sum_f_R0_rsum : forall n (f : nat -> R),
  sum_f_R0 f n = \rsum_(i < n.+1) f i.
Proof.
elim => [f|n IH f] /=; first by rewrite big_ord_recl /= big_ord0 addR0.
by rewrite big_ord_recr /= IH.
Qed.

Theorem RPascal k (a b : R) :
  (a + b) ^ k = \rsum_(i < k.+1) INR ('C(k, i))* (a ^ (k - i) * b ^ i).
Proof.
rewrite addRC Binomial.binomial sum_f_R0_rsum.
apply eq_bigr => i _.
rewrite combinaison_Coq_SSR; last by rewrite -ltnS.
rewrite -minusE; field.
Qed.

End pascal.

Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

(* TODO: rename *)
Lemma log_rmul_rsum_mlog {A : finType} k (f : A -> R+) : forall n (ta : 'rV[A]_n.+1),
  (forall i, 0 < f ta ``_ i) ->
  (- Log k (\rprod_(i < n.+1) f ta ``_ i) = \rsum_(i < n.+1) - Log k (f ta ``_ i))%R.
Proof.
elim => [i Hi | n IH].
  by rewrite big_ord_recl big_ord0 mulR1 big_ord_recl big_ord0 addR0.
move=> ta Hi.
rewrite big_ord_recl /= LogM; last 2 first.
  exact/Hi.
  apply rprodr_gt0 => ?; exact/Hi.
set tl := \row_(i < n.+1) ta ``_ (lift ord0 i).
have : forall i0 : 'I_n.+1, 0 < f tl ``_ i0.
  move=> i; rewrite mxE; exact/Hi.
move/IH => {IH}IH.
have -> : \rprod_(i < n.+1) f ta ``_ (lift ord0 i) = \rprod_(i < n.+1) f tl ``_ i.
  apply eq_bigr => i _; by rewrite mxE.
rewrite oppRD [X in _ = X]big_ord_recl IH.
congr (_ + _)%R.
apply eq_bigr => i _; by rewrite mxE.
Qed.

Section bigrmax_sect.

Variables (A : eqType) (F : A -> R) (s : seq A).

Lemma Rle_bigRmax : forall m, m \in s -> F m <= \rmax_(m <- s) (F m).
Proof.
elim: s => // hd tl IH m; rewrite in_cons; case/orP.
- move/eqP => ->; rewrite big_cons; exact/leR_maxl.
- move/IH => H; rewrite big_cons; exact/(leR_trans H)/leR_maxr.
Qed.

Lemma Rle_0_bigRmax : (forall r, r \in s -> 0 <= F r) -> 0 <= \rmax_(m <- s) (F m).
Proof.
case: s => [_ | hd tl Hr].
- rewrite big_nil; exact/leRR.
- apply (@leR_trans (F hd)); last by rewrite big_cons; exact: leR_maxl.
  apply Hr; by rewrite in_cons eqxx.
Qed.

End bigrmax_sect.

Lemma bigrmax_undup (I : eqType) g : forall (s : seq I),
   \rmax_(c <- s) g c = \rmax_(c <- undup s) g c.
Proof.
elim=> // hd tl IH /=.
rewrite big_cons.
case: ifP => Hcase.
- rewrite -IH Rmax_right //; exact: Rle_bigRmax.
- by rewrite big_cons IH.
Qed.

Lemma bigrmax_cat (I : eqType) g : forall (s1 s2 : seq I),
  (forall x, x \in s1 ++ s2 -> 0 <= g x) ->
  \rmax_(c <- s1 ++ s2) g c = Rmax (\rmax_(c <- s1) g c) (\rmax_(c <- s2) g c).
Proof.
elim => [s2 Hg /= | h1 t1 IH s2 Hg /=].
  rewrite big_nil Rmax_right //.
  by apply Rle_0_bigRmax.
rewrite 2!big_cons IH ?maxRA //.
move=> x Hx; apply Hg.
by rewrite /= in_cons Hx orbC.
Qed.

Lemma bigrmax_perm (I : eqType) g : forall (s1 s2 : seq I),
  (forall r, r \in s2 -> 0 <= g r) ->
  perm_eq s1 s2 -> uniq s1 -> uniq s2 ->
  \rmax_(c0 <- s1) g c0 = \rmax_(c0 <- s2) g c0.
Proof.
move=> s1.
move H : (size s1) => n1.
elim: n1 s1 H => //.
  case=> // _ s _ Hs.
  suff -> : s = [::].
    move=> _ _; by rewrite !big_nil.
  destruct s => //.
  move/allP : Hs.
  move/(_ s).
  by rewrite /= inE eqxx /= => /(_ Logic.eq_refl) /= add1n.
move=> n1 IH1 [|h1 t1] // [] H1 s2 Hg Hs2 K1 K2.
rewrite big_cons.
have [h2 [t2 ht2]] : exists h2 t2, s2 = h2 ++ h1 :: t2.
  apply in_cat; by rewrite -(perm_eq_mem Hs2) in_cons eqxx.
have Hs2' : perm_eq t1 (h2 ++ t2).
  rewrite ht2 in Hs2.
  rewrite -(perm_cons h1).
  eapply perm_eq_trans; first by apply Hs2.
  by rewrite perm_catC /= perm_cons perm_catC.
have Hg' r : r \in h2 ++ t2 -> 0 <= g r.
  move=> rs2; apply Hg.
  rewrite ht2 mem_cat in_cons.
  rewrite mem_cat in rs2.
  case/orP : rs2 => [-> // | -> /=].
  by rewrite orbA orbC.
rewrite (IH1 _ H1 _ Hg' Hs2'); last 2 first.
  by case/andP : K1.
  rewrite ht2 cat_uniq /= in K2.
  case/andP : K2 => K2 /andP [] K4 /andP [] _ K3.
  rewrite cat_uniq K2 K3 /= andbC /=.
  rewrite negb_or in K4.
  by case/andP : K4.
rewrite bigrmax_cat // maxRA (maxRC (g h1)) -maxRA ht2 bigrmax_cat; last first.
  move=> x Hx; apply Hg; by rewrite ht2.
by rewrite big_cons.
Qed.

Lemma bigrmax_eqi (I : finType) g : forall (s1 s2 : seq I),
  (forall r : I, r \in s1 -> 0 <= g r) -> s1 =i s2 ->
  \rmax_(c0 <- s1) g c0 = \rmax_(c0 <- s2) g c0.
Proof.
move=> s1 s2 Hg s1s2.
rewrite (bigrmax_undup _ s1) (bigrmax_undup g s2).
apply bigrmax_perm; [ | | by rewrite undup_uniq | by rewrite undup_uniq].
- move=> r Hr; apply Hg.
  rewrite mem_undup in Hr.
  by rewrite s1s2.
- apply uniq_perm_eq; [by rewrite undup_uniq | by rewrite undup_uniq | ].
  move=> i; by rewrite !mem_undup.
Qed.

Lemma rmax_imset' {M : finType} (I : finType) h (g : I -> R) (s : seq M) :
  (forall r : I, r \in enum [set h x | x in s] -> 0 <= g r) ->
  \rmax_(c0 <- enum [set h x | x in s]) g c0 = \rmax_(m <- s) g (h m).
Proof.
elim: s.
  rewrite big_nil.
  set tmp := enum _.
  suff -> : tmp = [::] by rewrite big_nil.
  rewrite /tmp -[in X in _ = X]enum0.
  apply eq_enum => a.
  rewrite !inE.
  apply/imsetP. case => m.
  by rewrite in_nil.
move=> hd tl IH Hg /=.
rewrite big_cons -IH; last first.
  move=> r Hr.
  apply Hg.
  rewrite mem_enum.
  apply/imsetP.
  rewrite mem_enum in Hr.
  case/imsetP : Hr => x xtl Hr.
  exists x => //.
  by rewrite in_cons xtl orbC.
transitivity (\rmax_(c0 <- h hd :: enum [set h x | x in tl]) g c0).
apply bigrmax_eqi => // x.
rewrite inE !mem_enum.
move Hlhs : (x \in [set _ _ | _ in _]) => lhs.
destruct lhs.
  - case/imsetP : Hlhs => x0 Hx0 H.
    rewrite in_cons in Hx0.
    case/orP : Hx0 => Hx0.
      move/eqP : Hx0 => ?; subst x0.
      by rewrite H eqxx.
    symmetry.
    apply/orP; right.
    apply/imsetP; by exists x0.
  - symmetry.
    apply/negbTE.
    move/negbT : Hlhs.
    apply contra.
    case/orP => Hcase.
    + move/eqP in Hcase; subst x.
      apply/imsetP.
      exists hd => //.
      by rewrite inE eqxx.
    + apply/imsetP.
      case/imsetP : Hcase => x0 Hx0 ?; subst x.
      exists x0 => //.
      by rewrite inE Hx0 orbC.
by rewrite big_cons.
Qed.

Lemma rmax_imset {M : finType} (I : finType) h (g : I -> R) :
  (forall r : I, r \in [set h x | x in M] -> 0 <= g r) ->
  \rmax_(c0 in [set h x | x in M]) g c0 = \rmax_(m in M) g (h m).
Proof.
move=> Hg.
eapply trans_eq.
  eapply trans_eq; last first.
    apply (@rmax_imset' _ I h g (enum M)).
    move=> r; rewrite mem_enum; case/imsetP => x; rewrite mem_enum => Hx ->.
    apply Hg; apply/imsetP; by exists x.
  rewrite big_filter /=.
  apply congr_big => //.
  move=> i /=.
  move Hlhs : (i \in _) => lhs.
  destruct lhs.
  - case/imsetP : Hlhs => x Hx ?; subst i.
    symmetry; apply/imsetP.
    exists x => //.
    by rewrite mem_enum.
  - symmetry.
    apply/negbTE.
    move/negbT : Hlhs; apply contra.
    case/imsetP => m Hm ?; subst i.
    apply/imsetP.
    by exists m.
apply congr_big => //; by rewrite enumT.
Qed.

Lemma Rle_bigrmax_R {A : finType} (h : A -> R) (tl : seq A) hd :
  (forall r, 0 <= h r) ->
  (forall c : A, c \in tl -> h c <= h hd) ->
  \rmax_(j <- tl) h j <= h hd.
Proof.
elim: tl hd => [hd Hh _ | hd1 tl2 IH hd Hhpos Hh].
  rewrite big_nil; by apply Hh.
rewrite big_cons.
apply Rmax_lub.
- apply Hh.
  by rewrite in_cons eqxx.
- apply IH => // c0 Hc0; apply Hh.
  by rewrite in_cons Hc0 orbC.
Qed.

Lemma bigrmax_max_seq {A : finType} (h : A -> R) (s : seq A) a :
  a \in s ->
  (forall r, 0 <= h r) ->
  (forall c, c \in s -> h c <= h a) ->
  h a = \rmax_(c <- s) h c.
Proof.
elim: s a => // hd tl IH a; rewrite in_cons; case/orP.
- move/eqP => -> Hhpos Hh.
  rewrite big_cons.
  rewrite Rmax_left //.
  apply Rle_bigrmax_R => //.
  move=> c0 Hc0; apply Hh.
  by rewrite in_cons Hc0 orbC.
- move=> atl Hhpos Hh.
  rewrite big_cons Rmax_right //.
  + apply IH => //.
    move=> c0 Hc0; apply Hh.
    by rewrite in_cons Hc0 orbC.
  + rewrite -(IH a) //.
    * apply Hh.
      by rewrite in_cons eqxx.
    * move=> c0 Hc0.
      apply Hh.
      by rewrite in_cons Hc0 orbC.
Qed.

Lemma bigrmax_max {A : finType} (C : {set A}) a (h : A -> R):
  a \in C ->
  (forall r, 0 <= h r) ->
  (forall c, c \in C -> h c <= h a) ->
  h a = \rmax_(c | c \in C) h c.
Proof.
move=> aC Hhpos Hh.
rewrite -big_filter.
apply bigrmax_max_seq => //.
- by rewrite mem_filter aC /= mem_index_enum.
- move=> c0.
  rewrite mem_filter.
  case/andP => ? ?.
  by apply Hh.
Qed.

Local Open Scope R_scope.

Lemma rmax_distrr I a (apos: 0 <= a) r (Q:pred I) F :
  ((a * \rmax_(i <- r | Q i) F i) = \rmax_(i <- r | Q i) (a * F i)).
Proof.
elim: r => [| h t IH].
  by rewrite 2!big_nil mulR0.
rewrite 2!big_cons.
case: ifP => Qh //.
by rewrite -IH RmaxRmult.
Qed.

Lemma rmax_distrl I a (apos: 0 <= a) r (Q:pred I) F :
  ((\rmax_(i <- r | Q i) F i) * a = \rmax_(i <- r | Q i) (F i * a)).
Proof.
rewrite mulRC rmax_distrr //.
by apply congr_big; auto using mulRC.
Qed.

Notation "\min^ b '_(' a 'in' A ) F" :=
((fun a => F) (arg_min b (fun x => x \in A) (fun a => F))) : min_scope.

Local Open Scope min_scope.

Lemma bigminn_min {A : finType} (C : {set A}) (cnot0 : {c0 | c0 \in C}) a (Ha : a \in C) (h : A -> nat) :
  (\min^ (sval cnot0) _(c in C) h c <= h a)%nat.
Proof.
case: arg_minP.
by destruct cnot0.
move=> a0 a0C H.
by apply H.
Qed.

(* TODO: useless ? *)
Lemma big_rmax_bigminn_helper {A : finType} n (g : nat -> R) :
  (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) ->
  (forall r, 0 <= g r) ->
  forall (C : {set n.-tuple A}) c'' (_ : c'' \in C) (d : n.-tuple A -> nat)
  (_ : forall c, c \in C -> (d c <= n)%nat)
  (cnot0 : {c0 | c0 \in C}),
  d c'' = \min^ (sval cnot0) _(c in C) d c ->
  g (d c'') = \rmax_(c in C) g (d c).
Proof.
move=> Hdecr Hr C c'' Hcc' d Hd cnot0 H.
apply (@bigrmax_max _ C c'' (fun a => g (d a))) => //.
move=> /= c0 c0C.
apply Hdecr.
apply/andP; split.
  rewrite H.
  by apply bigminn_min.
by apply Hd.
Qed.

Lemma big_rmax_bigminn {A M : finType} n (f : {ffun M -> n.-tuple A}) (g : nat -> R)
  (cnot0 : {c0 | c0 \in f @: M } ) :
  (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) ->
  (forall r, 0 <= g r) ->
  forall m'' (d : n.-tuple A -> nat)
  (_ : forall c0 : n.-tuple A, c0 \in [set f x | x : M] -> (d c0 <= n)%nat),
  d (f m'') = \min^ (sval cnot0) _(c in [set f x | x in M]) d c ->
  g (d (f m'')) = \rmax_(m | m \in M) g (d (f m)).
Proof.
move=> n1n2 Hg m'' d H Hd.
transitivity (\rmax_(c in [set f x | x in M]) g (d c)); last by rewrite rmax_imset.
apply big_rmax_bigminn_helper with cnot0 => //.
apply/imsetP.
by exists m''.
Qed.

Lemma big_rmax_bigminn_helper_vec {A : finType} n (g : nat -> R) :
  (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) ->
  (forall r, 0 <= g r) ->
  forall (C : {set 'rV[A]_n}) c'' (_ : c'' \in C) (d : 'rV[A]_n -> nat)
  (_ : forall c, c \in C -> (d c <= n)%nat)
  (cnot0 : {c0 | c0 \in C}),
  d c'' = \min^ (sval cnot0) _(c in C) d c ->
  g (d c'') = \rmax_(c in C) g (d c).
Proof.
move=> Hdecr Hr C c'' Hcc' d Hd cnot0 H.
apply (@bigrmax_max _ C c'' (fun a => g (d a))) => //.
move=> /= c0 c0C.
apply Hdecr.
apply/andP; split.
  rewrite H.
  by apply bigminn_min.
by apply Hd.
Qed.

Lemma big_rmax_bigminn_vec {A M : finType} n (f : {ffun M -> 'rV[A]_n}) (g : nat -> R)
  (cnot0 : {c0 | c0 \in f @: M } ) :
  (forall n1 n2, (n1 <= n2 <= n)%nat -> (g n2 <= g n1)%R) ->
  (forall r, 0 <= g r) ->
  forall m'' (d : 'rV[A]_n -> nat)
  (_ : forall c0 : 'rV[A]_n, c0 \in f @: M -> (d c0 <= n)%nat),
  d (f m'') = \min^ (sval cnot0) _(c in f @: M) d c ->
  g (d (f m'')) = \rmax_(m in M) g (d (f m)).
Proof.
move=> n1n2 Hg m'' d H Hd.
transitivity (\rmax_(c in f @: M) g (d c)); last by rewrite rmax_imset.
apply big_rmax_bigminn_helper_vec with cnot0 => //.
apply/imsetP.
by exists m''.
Qed.


(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                  Chantal Keller                                                 *)
(**                  Eunice-Raquel Martins                                          *)
(**                                                                                *)
(************************************************************************************)

Require Import List NArith.
Require Import BasicFacts ListFacts
        ListSort ListPermut OrderedSet FiniteSet FiniteBag FiniteCollection
        Signatures SeqScan Filter NestedLoop BlockNestedLoop ThetaNestedLoop IndexJoin Group
        HighLevelSpec Adequacy
        Partition FlatData SqlCommon SqlAlgebra.

Set Implicit Arguments.

Section Sec.
Hypothesis T : Tuple.Rcd.

Hypothesis relname : Type.
Hypothesis ORN : Oset.Rcd relname.

Hypothesis predicate : Type.
Hypothesis symb : Type.
Hypothesis aggregate : Type.
Hypothesis OPredicate : Oset.Rcd predicate.
Hypothesis OSymb : Oset.Rcd symb.
Hypothesis OAggregate : Oset.Rcd aggregate.
Hypothesis interp_predicate : predicate -> list (Tuple.value T) -> bool.
Hypothesis interp_symb : symb -> list (Tuple.value T) -> Tuple.value T.
Hypothesis interp_aggregate : aggregate -> list (Tuple.value T) -> Tuple.value T.
Hypothesis basesort : relname -> Fset.set (Tuple.A T).
Hypothesis instance : relname -> Febag.bag (Fecol.CBag (Tuple.CTuple T)).

Import Tuple.

Notation BTupleT := (Fecol.CBag (CTuple T)).
Notation bagT := (Febag.bag BTupleT).
Notation env_t := (env_t (T := T) (OSymb := OSymb) (OAggregate := OAggregate)).
Notation projection_ :=
  (projection (OSymb := OSymb) (OAggregate := OAggregate) interp_symb interp_aggregate).
Notation interp_funterm_ :=
  (interp_funterm_ (OSymb := OSymb) (OAggregate := OAggregate) interp_symb).
Notation interp_aggterm_ :=
  (interp_aggterm_ (OSymb := OSymb) (OAggregate := OAggregate) interp_symb interp_aggregate).
Notation eval_query :=
  (eval_query (OSymb := OSymb) (OAggregate := OAggregate)
                  interp_predicate interp_symb interp_aggregate basesort instance).
Notation eval_formula :=
  (eval_formula (OSymb := OSymb) (OAggregate := OAggregate)
                  interp_predicate interp_symb interp_aggregate basesort instance).
Notation eval_f_eq :=
  (eval_f_eq (OSymb := OSymb) (OAggregate := OAggregate)
                  interp_predicate interp_symb interp_aggregate basesort instance).
Notation "b '=R=' l" :=
  (forall t, Febag.nb_occ BTupleT t b = Oeset.nb_occ (OTuple T) t l) (at level 70, no associativity).

Lemma sup_eq : forall t1 t2 : tuple T, t1 =t= t2 -> support T t1 =S= support T t2.
Proof.
  intros t1 t2 Ht; rewrite tuple_eq in Ht; apply (proj1 Ht).
Qed.

Lemma sup_build :
 forall t1 t2 : tuple T, support T (join_tuple T t1 t2) =S= (support T t1 unionS support T t2).
Proof.
intros t1 t2; unfold join_tuple; apply (support_mk_tuple _ _ _).
Qed.

Lemma sup_proj12 :
 forall s (t : tuple T), support T (mk_tuple T s (dot T t)) =S= s.
Proof.
intros s t; apply support_mk_tuple.
Qed.

Lemma build_proj :
  forall s1 s2 (t : tuple T),
    support T t =S= (s1 unionS s2) ->
    t =t= join_tuple T (mk_tuple T s1 (dot T t)) (mk_tuple T s2 (dot T t)).
Proof.
  intros s1 s2 t Ht; rewrite (split_tuple T s1 s2); repeat split.
  + apply Oeset.compare_eq_refl.
  + apply Oeset.compare_eq_refl.
  + assumption.
  + apply support_mk_tuple.
  + apply support_mk_tuple.
  + rewrite join_compatible_tuple_alt.
    intros a Ha1 Ha2; rewrite 2 dot_mk_tuple; trivial.
    * rewrite (Fset.mem_eq_2 _ _ _ (support_mk_tuple _ _ _)) in Ha2; apply Ha2.
    * rewrite (Fset.mem_eq_2 _ _ _ (support_mk_tuple _ _ _)) in Ha1; apply Ha1.
Qed.

Lemma build_eq :
  forall t1 u1 t2 u2 : tuple T,
    t1 =t= u1 -> t2 =t= u2 -> join_tuple T t1 t2 =t= join_tuple T u1 u2.
Proof.
  - do 6 intro; apply join_tuple_eq; assumption.
Qed.

Lemma build_split_eq_1 :
  forall t1 u1 t2 u2 : tuple T,
    join_tuple T t1 t2 =t= join_tuple T u1 u2 ->
    support T t1 =S= support T u1 -> support T t2 =S= support T u2 -> t1 =t= u1.
Proof.
- intros t1 u1 t2 u2 H Hs1 Hs2.
  rewrite tuple_eq; split; [assumption | ].
  intros a.
  case_eq (a inS? support T t1);
      intro Ha; [ | unfold dot; rewrite <- (Fset.mem_eq_2 _ _ _ Hs1), Ha; trivial].
  rewrite tuple_eq in H.
  apply trans_eq with (dot T (join_tuple T t1 t2) a).
  + unfold join_tuple; rewrite dot_mk_tuple, Ha; trivial.
    rewrite Fset.mem_union, Ha; trivial.
  + rewrite (proj2 H); unfold join_tuple; rewrite dot_mk_tuple, <- (Fset.mem_eq_2 _ _ _ Hs1), Ha; trivial.
    rewrite Fset.mem_union, <- (Fset.mem_eq_2 _ _ _ Hs1), Ha; trivial.
Qed.

Lemma build_split_eq_2 :
  forall s1 s2, (s1 interS s2 =S= (emptysetS)) ->
  forall (t1 u1 t2 u2 : tuple T),
    join_tuple T t1 t2 =t= join_tuple T u1 u2 ->
    support T t1 =S= s1 ->
    support T t1 =S= support T u1 ->
    support T t2 =S= s2 -> support T t2 =S= support T u2 -> t2 =t= u2.
Proof.
- intros s1 s2 Sq t1 u1 t2 u2 H Ht1 Hs1 Ht2 Hs2.
  rewrite tuple_eq; split; [assumption | ].
  intros a.
  case_eq (a inS? support T t2);
      intro Ha; [ | unfold dot; rewrite <- (Fset.mem_eq_2 _ _ _ Hs2), Ha; trivial].
  assert (Ka : a inS? support T t1 = false).
  {
    case_eq (a inS? support T t1); [ | intros; apply refl_equal].
    intro Ka.
    assert (Abs : a inS (Fset.empty (A T))).
    {
      rewrite <- (Fset.mem_eq_2 _ _ _ Sq), Fset.mem_inter.
      rewrite <- (Fset.mem_eq_2 _ _ _ Ht1), Ka, <- (Fset.mem_eq_2 _ _ _ Ht2), Ha.
      apply refl_equal.
    }
    rewrite Fset.empty_spec in Abs; discriminate Abs.
  }
  rewrite tuple_eq in H.
  apply trans_eq with (dot T (join_tuple T t1 t2) a).
  + unfold join_tuple; rewrite dot_mk_tuple, Ka; trivial.
    rewrite Fset.mem_union, Ha, Bool.orb_true_r; trivial.
  + rewrite (proj2 H); unfold join_tuple; rewrite dot_mk_tuple, <- (Fset.mem_eq_2 _ _ _ Hs1), Ka; trivial.
    rewrite Fset.mem_union, <- (Fset.mem_eq_2 _ _ _ Hs2), Ha, Bool.orb_true_r; trivial.
Qed.

Lemma mk_filter_implements_Q_Sigma :
  forall C env f q,
    let F := Filter.build _ (eval_f_eq env f) C in
    forall c,
      eval_query env q =R= Cursor.materialize C c ->
      eval_query env (Q_Sigma f q) =R= Cursor.materialize F (Filter.mk_filter F c).
Proof.
intros C env f q eval_f F c Hc.
apply Q_Sigma_is_computable_by_any_filter_op with (Cursor.materialize C); trivial.
- apply mk_filter_is_a_filter_op.
Qed.

Lemma IS_implements_Q_Sigma :
  forall (IS : Index.Rcd  (OTuple T) (oeset_of_oset (mk_olists (OVal T)))),
    (forall lv1 lv2, Index.P IS lv1 lv2 = Oset.eq_bool (mk_olists (OVal T)) lv1 lv2) ->
    forall la lval env f q ,
    (forall t, eval_formula (env_t env t) f =
               Oset.eq_bool (mk_olists (OVal T)) (map (dot T t) la) lval) ->
    (forall t, Index.proj IS t = map (dot T t) la) ->
    forall c,
      eval_query env q =R= Index.c1 IS c ->
      eval_query env (Q_Sigma f q) =R= Cursor.materialize _ (Index.i IS c lval).
Proof.
intros IS HP la lval env f q Hf Hi c Hq t.
rewrite (Oeset.nb_occ_eq_2 _ _ _ _ (Cursor.materialize_collection _ _ )).
rewrite (Oeset.nb_occ_eq_2 _ _ _ _ (Index.i_collection IS c lval)).
rewrite eval_query_unfold, Febag.nb_occ_filter; [ | intros; apply eval_f_eq; trivial].
rewrite Hf, <- Hi, Hq, Oeset.nb_occ_filter, HP.
- rewrite Oset.eq_bool_sym.
  case (Oset.eq_bool (mk_olists (OVal T)) lval (Index.proj IS t)).
  + rewrite N.mul_1_r; trivial.
  + rewrite N.mul_0_r; trivial.
- intros x1 x2 _ Hx; rewrite tuple_eq in Hx; rewrite 2 Hi.
  apply f_equal; rewrite <- map_eq.
  intros; rewrite (proj2 Hx); trivial.
Qed.

Lemma NL_implements_Q_Join :
  forall C1 C2 env q1 q2, (sort basesort q1 interS sort basesort q2) =S= (emptysetS) ->
    (forall t, t inBE eval_query env q1 -> support T t =S= sort basesort q1) ->
    (forall t, t inBE eval_query env q2 -> support T t =S= sort basesort q2) ->
    let NL := NestedLoop.build (OTuple T) (join_tuple T) (join_tuple_eq_1 T) (join_tuple_eq_2 T) C1 C2 in
    forall c1 c2,
      eval_query env q1 =R= Cursor.materialize C1 c1 ->
      eval_query env q2 =R= Cursor.materialize C2 c2 ->
      eval_query env (Q_Join q1 q2) =R=
      Cursor.materialize NL (NestedLoop.mk_cursor C1 C2 nil c1 c2).
Proof.
intros C1 C2 env q1 q2 Sq Hq1 Hq2 NL c1 c2 Hc1 Hc2.
apply Q_Join_is_computable_by_any_join_op with (Cursor.materialize C1) (Cursor.materialize C2); trivial.
apply NL_is_a_join_op.
- apply sup_eq.
- apply sup_build.
- apply sup_proj12.
- apply sup_proj12.
- apply build_proj.
- apply build_eq.
- apply build_split_eq_1.
- apply build_split_eq_2; trivial.
Qed.

Lemma BNL_implements_Q_Join :
  forall C1 C2 env q1 q2, (sort basesort q1 interS sort basesort q2) =S= (emptysetS) ->
    (forall t, t inBE eval_query env q1 -> support T t =S= sort basesort q1) ->
    (forall t, t inBE eval_query env q2 -> support T t =S= sort basesort q2) ->
    let BNL := BlockNestedLoop.build
                 (OTuple T) (join_tuple T) (join_tuple_eq_1 T) (join_tuple_eq_2 T) C1 C2 in
    forall c1 c2,
      eval_query env q1 =R=  flat_map (fun x => x) (Cursor.materialize C1 c1) ->
      eval_query env q2 =R= flat_map (fun x => x) (Cursor.materialize C2 c2) ->
      eval_query env (Q_Join q1 q2) =R=
      flat_map (fun x => x) (Cursor.materialize BNL (NestedLoop.mk_cursor C1 C2 nil c1 c2)).
Proof.
intros C1 C2 env q1 q2 Sq Hq1 Hq2 BNL c1 c2 Hc1 Hc2.
apply (Q_Join_is_computable_by_any_join_op
         (OSymb := OSymb) (OAggregate := OAggregate)
         interp_predicate interp_symb interp_aggregate basesort instance
         (bagA1 := Cursor.cursor C1) (bagA2 := Cursor.cursor C2) (bagA := Cursor.cursor BNL)
         (elementsA1 := fun c => flat_map (fun x => x) (Cursor.materialize C1 c))
         (elementsA2 := fun c => flat_map (fun x => x) (Cursor.materialize C2 c))
         (elementsA := fun c => flat_map (fun x => x) (Cursor.materialize BNL c))); trivial.
apply (BNL_is_a_join_op (O1 := OTuple T) (O2 := OTuple T) (OTuple T) (join_tuple T)).
- apply sup_eq.
- apply sup_build.
- apply sup_proj12.
- apply sup_proj12.
- apply build_proj.
- apply build_eq.
- apply build_split_eq_1.
- apply build_split_eq_2; trivial.
Qed.

Lemma TNL_implements_Q_Sigma_Join :
  forall C1 C2 env f q1 q2, (sort basesort q1 interS sort basesort q2) =S= (emptysetS) ->
    (forall t, t inBE eval_query env q1 -> support T t =S= sort basesort q1) ->
    (forall t, t inBE eval_query env q2 -> support T t =S= sort basesort q2) ->
    let TNL := ThetaNestedLoop.build
                 (OTuple T) (join_tuple T) (join_tuple_eq_1 T) (join_tuple_eq_2 T)
                 _ (eval_f_eq env f) C1 C2 in
    forall c1 c2,
      eval_query env q1 =R= Cursor.materialize C1 c1 ->
      eval_query env q2 =R= Cursor.materialize C2 c2 ->
      eval_query env (Q_Sigma f (Q_Join q1 q2)) =R=
      Cursor.materialize TNL (NestedLoop.mk_cursor C1 C2 nil c1 c2).
Proof.
intros C1 C2 env f q1 q2 Sq Hq1 Hq2 NL c1 c2 H1 H2.
apply (Q_Sigma_Join_is_computable_by_any_filter_join_op
         (OSymb := OSymb) (OAggregate := OAggregate)
         interp_predicate interp_symb interp_aggregate basesort instance
         (bagA1 := Cursor.cursor C1) (bagA2 := Cursor.cursor C2) (bagA := Cursor.cursor NL)
         (elementsA1 := Cursor.materialize C1)
         (elementsA2 := Cursor.materialize C2)
         (elementsA := Cursor.materialize NL) env f q1 q2); trivial.
apply TNL_is_a_filter_join_op.
- apply sup_eq.
- apply sup_build.
- apply sup_proj12.
- apply sup_proj12.
- apply build_proj.
- apply build_eq.
- apply build_split_eq_1.
- apply build_split_eq_2; trivial.
Qed.

Lemma mk_tuple_eq_2_alt :
  forall s (x1 x2 : tuple T), x1 =t= x2 -> mk_tuple T s (dot T x1) =t= mk_tuple T s (dot T x2).
Proof.
intros s x1 x2 Hx; apply mk_tuple_eq_2.
intros a _; rewrite tuple_eq in Hx; apply (proj2 Hx).
Qed.

Lemma IJ_implements_Q_Sigma_Join :
  forall C1 S2 env f q1 q2, (sort basesort q1 interS sort basesort q2) =S= (emptysetS) ->
    (forall t, t inBE eval_query env q1 -> support T t =S= sort basesort q1) ->
    (forall t, t inBE eval_query env q2 -> support T t =S= sort basesort q2) ->
    let IJ := (IndexJoin.build _ _ _ _ (OTuple T) (OTuple T) (OTuple T)
                 (OTuple T)
                 (fun t => mk_tuple T (sort basesort q1) (dot T t)) (mk_tuple_eq_2_alt _)
                 C1 S2 (join_tuple T) (join_tuple_eq_1 T) (join_tuple_eq_2 T)) in

    forall c1 c2,
      eval_query env q1 =R= Cursor.materialize C1 c1 ->
      eval_query env q2 =R= Index.c1 S2 c2 ->

      let f_index :=
          (fun x : tuple T =>
             Index.P
               S2
               (mk_tuple T (sort basesort q1) (dot T (mk_tuple T (sort basesort q1) (dot T x))))
               (Index.proj S2 (mk_tuple T (sort basesort q2) (dot T x)))) in
      (forall t t1 t2,
          t1 inBE eval_query env q1 -> t2 inBE eval_query env q2 ->
          t =t= join_tuple T t1 t2 ->
          eval_formula (env_t env t) f = f_index t) ->

      eval_query env (Q_Sigma f (Q_Join q1 q2)) =R=
      Cursor.materialize IJ
        (IndexJoin.mk_cursor
           _ _ _ _ (OTuple T) (OTuple T) (OTuple T) C1 S2 nil c1 (Cursor.empty_cursor _) c2).
Proof.
intros C1 S2 env f q1 q2 Sq Hq1 Hq2 IJ c1 c2 H1 H2 f_index Hf t.
assert (H1' : forall t1 : tuple T,
           (BinNat.N.lt 0 (Oeset.nb_occ (OTuple T) t1 (Cursor.materialize C1 c1))) ->
           support T t1 =S= sort basesort q1).
{
  intros t1 Ht1; apply Hq1; apply Febag.nb_occ_mem; rewrite H1, Oeset.nb_occ_diff_0_pos; trivial.
}
assert (H2' : forall t2 : tuple T,
           BinNat.N.lt 0 (Oeset.nb_occ (OTuple T) t2 (Index.c1 S2 c2)) ->
           support T t2 =S= sort basesort q2).
{
  intros t2 Ht2; apply Hq2; apply Febag.nb_occ_mem; rewrite H2, Oeset.nb_occ_diff_0_pos; trivial.
}
assert (H' := IndexJoin_is_a_filter_join_op
                (O1 := OTuple T) (OTuple T) (O2 := OTuple T) (OP := OTuple T)
                _ (mk_tuple_eq_2_alt (sort basesort q1))
                C1 S2 (join_tuple T) (join_tuple_eq_1 T) (join_tuple_eq_2 T) (A T)
                (support T) (support T) (support T)
                (fun t => mk_tuple T (sort basesort q1) (dot T t))
                (fun t => mk_tuple T (sort basesort q2) (dot T t))
                (sort basesort q1) (sort basesort q2)
                sup_eq sup_build (sup_proj12 (sort basesort q1)) (sup_proj12 (sort basesort q2))
                (build_proj _ _) build_eq build_split_eq_1 (build_split_eq_2 _ _ Sq) c1 c2
                H1' H2').
assert (H1'' :
          (forall t1 : tuple T,
              BinNat.N.lt
                0
                (Oeset.nb_occ (OTuple T) t1
                              ((fun q : query T relname predicate OSymb OAggregate =>
                                  Febag.elements BTupleT (eval_query env q)) q1)) ->
              support T t1 =S= sort basesort q1)).
{
  intros t1 Ht1; apply Hq1; apply Febag.nb_occ_mem; rewrite Febag.nb_occ_elements.
  rewrite Oeset.nb_occ_diff_0_pos; trivial.
}
assert (H2'' : (forall t2 : tuple T,
         BinNat.N.lt 0
           (Oeset.nb_occ (OTuple T) t2
              ((fun q : query T relname predicate OSymb OAggregate =>
                Febag.elements BTupleT (eval_query env q)) q2)) ->
         support T t2 =S= sort basesort q2)).
{
  intros t2 Ht2; apply Hq2; apply Febag.nb_occ_mem; rewrite Febag.nb_occ_elements.
  rewrite Oeset.nb_occ_diff_0_pos; trivial.
}
assert (H'' := Q_Join_is_a_join_op (OSymb := OSymb) (OAggregate := OAggregate)
                                    interp_predicate interp_symb interp_aggregate
                                    basesort instance env
                                    (sort basesort q1) (sort basesort q2) q1 q2
                                    H1'' H2'').
destruct H' as [K1' K2']; destruct H'' as [K1'' K2''].
case_eq (support T t =S?= (sort basesort q1 unionS sort basesort q2)); intro Ht.
- unfold IJ; rewrite (K2' _ Ht), eval_query_unfold, Febag.nb_occ_filter;
    [ | intros; apply eval_f_eq; trivial].
  rewrite Febag.nb_occ_elements, (K2'' _ Ht), <- H1, <- H2, <- 2 Febag.nb_occ_elements.
  case_eq (Febag.nb_occ BTupleT (mk_tuple T (sort basesort q1) (dot T t)) (eval_query env q1));
    [intro H0; rewrite 2 N.mul_0_l; trivial | ].
  intros p1 Hp1.
  case_eq (Febag.nb_occ BTupleT (mk_tuple T (sort basesort q2) (dot T t)) (eval_query env q2));
    [intro H0; rewrite 2 N.mul_0_l; trivial | ].
  intros p2 Hp2.
  rewrite (Hf t (mk_tuple T (sort basesort q1) (dot T t))
              (mk_tuple T (sort basesort q2) (dot T t))).
  + apply refl_equal.
  + apply Febag.nb_occ_mem; rewrite Hp1; discriminate.
  + apply Febag.nb_occ_mem; rewrite Hp2; discriminate.
  + apply build_proj; assumption.
- apply trans_eq with 0.
  + case_eq (Febag.nb_occ BTupleT t (eval_query env (Q_Sigma f (Q_Join q1 q2))));
      [intros; trivial | ].
    intros p Hp; rewrite K1'' in Ht; [discriminate Ht | ].
    rewrite eval_query_unfold, Febag.nb_occ_filter in Hp; [ | intros; apply eval_f_eq; trivial].
    destruct (eval_formula (env_t env t) f).
    * rewrite N.mul_1_r, Febag.nb_occ_elements in Hp; rewrite Hp; apply refl_equal.
    * rewrite N.mul_0_r in Hp; discriminate Hp.
  + case_eq (Oeset.nb_occ (OTuple T) t
    (Cursor.materialize IJ
       {|
       IndexJoin.visited := nil;
       IndexJoin.outer := c1;
       IndexJoin.inner := Cursor.empty_cursor (Index.C1 S2);
       IndexJoin.containers2 := c2 |})); [intros; trivial | ].
    intros p Hp; rewrite K1' in Ht; [discriminate Ht | ].
    unfold IJ in Hp; rewrite Hp; apply refl_equal.
Qed.

Lemma group_crit_eq :
  forall env g,
    let group_crit t := map (interp_funterm_ (env_t env t)) g in
    forall e1 e2 : tuple T,
      e1 =t= e2 ->
      Oeset.compare (oeset_of_oset (mk_olists (OVal T))) (group_crit e1) (group_crit e2) = Eq.
Proof.
  intros env g group_crit x1 x2 Hx.
  unfold group_crit; simpl.
  apply comparelA_eq_refl_alt.
  - intros; apply Oset.compare_eq_refl.
  - rewrite <- map_eq; intros; apply interp_funterm_eq.
    constructor 2; simpl; [ | apply equiv_env_refl].
    simpl; repeat split;
      [ | rewrite compare_list_t; simpl; rewrite Hx; trivial].
    rewrite tuple_eq in Hx; apply (proj1 Hx).
Qed.

Lemma projection_g_eq :
  forall env g s,
    let eval_s := fun l => projection_ (env_g env (Group_By g) l) (Select_List s) in
    forall l1 l2 : listT,
      comparelA (Oeset.compare (OTuple T)) l1 l2 = Eq -> eval_s l1 =t= eval_s l2.
Proof.
  intros env g s eval_s l1 l2 Hl; apply projection_eq.
  constructor 2; [ | apply equiv_env_refl].
  assert (H1 : l1 =PE= l2).
  {
    apply permut_refl_alt; assumption.
  }
  assert (H2 := extract_from_groups _ H1).
  repeat split; trivial.
  destruct (quicksort (OTuple T) l1) as [ | t1];
    destruct (quicksort (OTuple T) l2) as [ | t2]; try discriminate H2.
  - apply Fset.equal_refl.
  - simpl in H2.
    case_eq (Oeset.compare (OTuple T) t1 t2); intro Ht; rewrite Ht in H2; try discriminate H2.
    rewrite tuple_eq in Ht; apply (proj1 Ht).
Qed.

Lemma eval_formula_g_eq :
  forall env g f,
    let eval_f := fun l => eval_formula (env_g env (Group_By g) l) f in
    forall l1 l2 : listT,
       comparelA (Oeset.compare (OTuple T)) l1 l2 = Eq -> eval_f l1 = eval_f l2.
Proof.
  intros env g f eval_f l1 l2 Hl; apply eval_formula_eq.
  constructor 2; [ | apply equiv_env_refl].
  assert (H1 : l1 =PE= l2).
  {
    apply permut_refl_alt; assumption.
  }
  assert (H2 := extract_from_groups _ H1).
  repeat split; trivial.
  destruct (quicksort (OTuple T) l1) as [ | t1];
    destruct (quicksort (OTuple T) l2) as [ | t2]; try discriminate H2.
  - apply Fset.equal_refl.
  - simpl in H2.
    case_eq (Oeset.compare (OTuple T) t1 t2); intro Ht; rewrite Ht in H2; try discriminate H2.
    rewrite tuple_eq in Ht; apply (proj1 Ht).
Qed.

Lemma Group_implements_Q_Gamma :
  forall (C : Cursor.Rcd (OTuple T)) env g f s q,
    let group_crit := fun t => map (interp_funterm_ (env_t env t)) g in
    let eval_s := fun l => projection_ (env_g env (Group_By g) l) (Select_List s) in
    let eval_f := fun l => eval_formula (env_g env (Group_By g) l) f in
    forall c,
      eval_query env q =R= Cursor.materialize _ c ->
      eval_query env (Q_Gamma g f s q) =R=
      (SeqScan.collection (group C (oeset_of_oset (mk_olists (OVal T)))
                                 group_crit eval_f eval_s c)).
Proof.
intros C env g f s q group_crit eval_s eval_f c Hc t.
assert (H := Group_is_a_grouping_op
               C (oeset_of_oset (mk_olists (OVal T))) group_crit eval_f eval_s
                (group_crit_eq _ _) (projection_g_eq _ _ _) (eval_formula_g_eq _ _ _) c t).
rewrite (Oeset.nb_occ_eq_2 _ _ _ _ (Cursor.materialize_collection _ _)) in H.
simpl in H; simpl; rewrite H; clear H.
rewrite Febag.nb_occ_elements, Q_Gamma_is_a_grouping_op.
unfold eval_s; apply (Oeset.nb_occ_map_eq_2_3 (OLTuple T)).
- intros l1 l2 Hl; apply projection_eq.
  constructor 2; [ | apply equiv_env_refl].
  simpl; repeat split;
      [apply env_slice_eq_1 | rewrite compare_list_t]; assumption.
- intro l; unfold eval_f; rewrite 2 Oeset.nb_occ_filter.
  + apply if_eq; trivial.
    intros _; apply permut_nb_occ.
    set (_group_crit := map (fun x t => (interp_funterm_ (env_t env t) x)) g) in *.
    assert (Hgc : forall e : tuple T -> value T,
               In e _group_crit -> forall t1 t2 : tuple T, t1 =t= t2 -> e t1 = e t2).
    {
      intros e He; unfold _group_crit in He; rewrite in_map_iff in He.
      destruct He as [x [He Hx]]; subst e.
      intros t1 t2 Ht; apply interp_funterm_eq.
      constructor 2; [ | apply equiv_env_refl].
      split; [rewrite tuple_eq in Ht; apply (proj1 Ht) | ].
      split; [apply refl_equal | ].
      rewrite compare_list_t; simpl; rewrite Ht; apply refl_equal.
    }
    apply permut_trans with
        (map snd
             (map (fun x : list (value T) * listT => let (k, lk) := x in (k, rev lk))
                  (rebuild_keys (FVal T)
                                (Febag.elements BTupleT (eval_query env q)) _group_crit))).
    * unfold rebuild_keys; rewrite 2 map_map.
      set (x := partition_list_expr
                  (FVal T) (Febag.elements BTupleT (eval_query env q)) _group_crit).
      clearbody x.
      induction x as [ | x1 x]; [apply _permut_refl; intros a Ha; contradiction Ha | ].
      simpl map; rewrite <- (permut_cons (OLTuple T)); [apply IHx | ].
      apply extract_from_groups.
      destruct x1; [apply permut_refl | ].
      apply _permut_rev; intros; apply Oeset.compare_eq_refl.
    * {
        apply _permut_map with
            (fun x1 x2 =>
               Oeset.compare (mk_oepairs (oeset_of_oset (mk_olists (OVal T))) (OLA (OTuple T)))
                       x1 x2 = Eq).
        - intros [k1 lk1] [k2 lk2] _ _; simpl.
          destruct (comparelA (Oset.compare (OVal T)) k1 k2); try discriminate.
          exact (fun h => h).
        - rewrite (partition_list_expr_fold_inv (OTuple T)).
          + assert (Aux2 :
                      fold_left
                        (fun (acc : list (list (value T) * listT)) (e : tuple T) =>
                           OrderedSet.group (oeset_of_oset (mk_olists (OVal T))) group_crit e acc)
                        (Cursor.materialize _ c) nil =
                      fold_left
                        (fun (acc : list (list (value T) * listT)) (t : tuple T) =>
                           OrderedSet.group
                             (oeset_of_oset (mk_olists (OVal T)))
                             (fun u : tuple T => map (fun e => e u) _group_crit) t acc)
                        (Cursor.materialize _ c) nil).
            {
              apply fold_left_eq; trivial.
              intros a b H; apply OrderedSet.group_eq_0.
              intro u; unfold group_crit, _group_crit; rewrite map_map, <- map_eq.
              intros; trivial.
            }
            rewrite Aux2; clear Aux2.
            rewrite <- 2 flg_unfold; apply flg_permut.
            * apply Hgc.
            * apply permut_refl.
            * constructor 1.
            * constructor 1.
            * refine (permut_trans _ _ (_permut_rev _ _ _));
                [ | intros; apply Oeset.compare_eq_refl].
              apply permut_sym.
              refine (permut_trans _ _ (_permut_rev _ _ _));
                [ | intros; apply Oeset.compare_eq_refl].
              {
                apply permut_trans with (Febag.elements _ (eval_query env q)).
                - apply nb_occ_permut; intro x.
                  rewrite <- Hc, Febag.nb_occ_elements; apply refl_equal.
                - generalize (proj1 (partition_list_expr_invariant
                            (OTuple T) (FVal T)
                            _ (Febag.elements BTupleT (eval_query env q)) Hgc (refl_equal _))).
                  apply _permut_incl.
                  intros; subst; apply Oeset.compare_eq_refl.
              }
          + apply Hgc.
      }
  + intros l1 l2 _ Hl; apply eval_formula_eq.
    constructor 2; [ | apply equiv_env_refl].
    simpl; repeat split;
      [apply env_slice_eq_1 | rewrite compare_list_t]; assumption.
  + intros l1 l2 _ Hl; apply eval_formula_eq.
    constructor 2; [ | apply equiv_env_refl].
    simpl; repeat split;
      [apply env_slice_eq_1 | rewrite compare_list_t]; assumption.
Qed.

End Sec.


Require Import String.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import SystemF.
Require Import Coq.Program.Equality.
Require Export Subtyping.

Module MDisjointness
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module MSubtyping := MSubtyping(VarTyp)(set).
Export MSubtyping.

(* Disjointness: Implementation *)

Definition hd (p : PTyp) : nat :=
  match p with
  | PInt       => 0
  | Fun t1 t2  => 1
  | ForAll d t => 2
  | Rec l t    => 3
  | Top        => 4
  | PBVarT n   => 5
  | PFVarT v   => 6
  | And t1 t2  => 7
  | Bot        => 8
  end.

Definition OrthoAx (t1 t2 : PTyp) : Prop :=
  (hd t1 < 4 /\ hd t2 < 4 /\ not (hd t1 = hd t2)).

Inductive Ortho : context TyEnvSource -> PTyp -> PTyp -> Prop :=
  | OAnd1 : forall Gamma t1 t2 t3, Ortho Gamma t1 t3 -> Ortho Gamma t2 t3 -> Ortho Gamma (And t1 t2) t3
  | OAnd2 : forall Gamma t1 t2 t3, Ortho Gamma t1 t2 -> Ortho Gamma t1 t3 -> Ortho Gamma t1 (And t2 t3)
  | OFun  : forall Gamma t1 t2 t3 t4, Ortho Gamma t2 t4 -> Ortho Gamma (Fun t1 t2) (Fun t3 t4)
  | OForAll : forall L Gamma d1 d2 t1 t2,
                (forall x, not (In x L) -> Ortho (extend x (TyDis (And d1 d2)) Gamma)
                                           (open_typ_source t1 (PFVarT x))
                                           (open_typ_source t2 (PFVarT x))) ->
                PType (And d1 d2) ->
                Ortho Gamma (ForAll d1 t1) (ForAll d2 t2)
  | OVar : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                       usub A ty ->
                       PType ty ->
                       Ortho Gamma (PFVarT x) ty
  | OVarSym : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                          usub A ty ->
                          PType ty ->
                          Ortho Gamma ty (PFVarT x)
  | OTop1 : forall Gamma t, Ortho Gamma Top t
  | OTop2 : forall Gamma t, Ortho Gamma t Top
  | ORecNeq : forall Gamma l1 l2 t1 t2, l1 <> l2 -> Ortho Gamma (Rec l1 t1) (Rec l2 t2)
  | ORecEq : forall Gamma l t1 t2, Ortho Gamma t1 t2 -> Ortho Gamma (Rec l t1) (Rec l t2)
  | OAx : forall Gamma t1 t2, OrthoAx t1 t2 -> Ortho Gamma t1 t2.

Hint Constructors Ortho.

(* Disjointness: Specification *)

Definition OrthoS (A B : PTyp) := not (exists C, Sub A C /\ Sub B C).

Ltac orthoax_inv H :=
  let H' := fresh in
  let m := fresh in
  let H1 := fresh in
  let H2 := fresh in
  inversion H as [H' | m H1 H2 ]; orthoax_inv H1.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t1 is not part of OrthoAx *)
Ltac orthoax_inv_l :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [H1 _]; orthoax_inv H1
  end.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t2 is not part of OrthoAx *)
Ltac orthoax_inv_r :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [_ [H1 _]]; orthoax_inv H1
  end.

(** Ortho environment properties **)

Lemma ortho_weaken :
  forall G E F t1 t2, Ortho (E ++ G) t1 t2 ->
                 Ortho (E ++ F ++ G) t1 t2.
Proof.
  intros.
  remember (E ++ G) as H'.
  generalize dependent HeqH'.
  generalize dependent E.
  dependent induction H; intros; eauto; subst.
  - apply_fresh OForAll as x.
    unfold open in *; simpl in *.
    subst.
    unfold extend; simpl.
    rewrite app_comm_cons.
    apply H0.
    not_in_L x.
    rewrite <- app_comm_cons.
    unfold extend; simpl; reflexivity.
    auto.
  - apply OVar with (A := A); auto.
    apply in_app_or in H; inversion H; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    apply in_app_or in H; inversion H; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_strengthen : forall z U E F ty1 ty2,
  not (In z (union (fv_ptyp ty1) (fv_ptyp ty2))) ->
  Ortho (E ++ ((z,U) :: nil) ++ F) ty1 ty2 ->
  Ortho (E ++ F) ty1 ty2.
Proof.
  intros.
  remember (E ++ ((z,U) :: nil) ++ F).

  generalize dependent Heql.
  generalize dependent E.

  induction H0; intros; auto.
  - apply OAnd1; [ apply IHOrtho1 | apply IHOrtho2 ];
    simpl in H; not_in_L z; apply Heql.
  - apply OAnd2; [ apply IHOrtho1 | apply IHOrtho2 ];
    simpl in H; not_in_L z; apply Heql.
  - apply OFun;
    apply IHOrtho; simpl in H; not_in_L z; auto.
  - apply_fresh OForAll as x.
    subst; unfold extend; simpl.
    rewrite app_comm_cons.
    eapply H1.
    not_in_L x.
    unfold not; intro HH.
    apply MSetProperties.Dec.F.union_1 in HH.
    destruct HH as [HH | HH]; apply fv_open_rec_typ_source in HH.
    apply MSetProperties.Dec.F.union_1 in HH; simpl in HH; simpl in H.
    destruct HH as [HH | HH].
    apply H.
    apply MSetProperties.Dec.F.union_2.
    apply MSetProperties.Dec.F.union_3.
    assumption.
    not_in_L x.
    apply H16.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in HH.
    now symmetry.
    apply MSetProperties.Dec.F.union_1 in HH; simpl in HH; simpl in H.
    destruct HH as [HH | HH].
    apply H.
    apply MSetProperties.Dec.F.union_3.
    apply MSetProperties.Dec.F.union_3.
    assumption.
    not_in_L x.
    apply H16.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in HH.
    now symmetry.
    unfold extend; now simpl.
    auto.
  - subst.
    apply OVar with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H0; destruct H0; auto.
    destruct H0; auto.
    inversion H0; subst; simpl in H.
    not_in_L x.
    exfalso; apply H3.
    now apply MSetProperties.Dec.F.singleton_2.
  - subst.
    apply OVarSym with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H0; destruct H0; auto.
    destruct H0; auto.
    inversion H0; subst; simpl in H.
    not_in_L x.
    exfalso; apply H4.
    now apply MSetProperties.Dec.F.singleton_2.
  - subst.
    apply ORecEq.
    apply IHOrtho.
    simpl in *; not_in_L z.
    auto.
Qed.

Hint Resolve ortho_weaken ortho_strengthen.

Lemma ortho_extend_comm :
  forall F E x v ty1 ty2,
    Ortho (F ++ E ++ (x, v) :: nil) ty1 ty2 ->
    Ortho (F ++ (x, v) :: nil ++ E) ty1 ty2.
Proof.
  intros F E x v ty1 ty2 HOrtho.
  remember (F ++ E ++ (x, v) :: nil).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    change ((y, TyDis (And d1 d2)) :: F ++ (x, v) :: E) with
           (((y, TyDis (And d1 d2)) :: F) ++ ((x, v) :: nil) ++ E).
    apply H0.
    not_in_L y.
    unfold extend; now simpl.
    auto.
  - apply OVar with (A := A); auto.
    apply in_or_app; rewrite app_comm_cons.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    apply in_or_app; rewrite app_comm_cons.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_extend_comm' :
  forall F E x v ty1 ty2,
    Ortho (F ++ (x, v) :: nil ++ E) ty1 ty2 ->
    Ortho (F ++ E ++ (x, v) :: nil) ty1 ty2.
Proof.
  intros F E x v ty1 ty2 HOrtho.
  remember (F ++ (x, v) :: nil ++ E).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    change ((y, TyDis (And d1 d2)) :: F ++ E ++ (x, v) :: nil) with
           (((y, TyDis (And d1 d2)) :: F) ++ E ++ (x, v) :: nil).
    apply H0.
    not_in_L y.
    unfold extend; now simpl.
    auto.
  - apply OVar with (A := A); auto.
    rewrite app_comm_cons in H.
    apply in_or_app.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    rewrite app_comm_cons in H.
    apply in_or_app.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_app_comm :
  forall E F ty1 ty2, Ortho (F ++ E) ty1 ty2 -> Ortho (E ++ F) ty1 ty2.
Proof.
  intros E F ty1 ty2 HOrtho.
  remember (F ++ E).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    assert (Ha : not (In x L)) by not_in_L x.
    apply H0 with (F0 := extend x (TyDis (And d1 d2)) F) (E0 := E) in Ha.
    apply ortho_extend_comm' in Ha.
    change ((x, TyDis (And d1 d2)) :: E ++ F) with (nil ++ (x, TyDis (And d1 d2)) :: E ++ F).
    apply ortho_extend_comm with (E := E ++ F).
    simpl in *.
    rewrite <- app_assoc.
    apply Ha.
    unfold extend; now simpl.
    auto.
  - apply OVar with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H; destruct H; auto.
  - apply OVarSym with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H; destruct H; auto.
Qed.

Lemma ortho_middle_comm : forall H E F G ty1 ty2,
              Ortho (E ++ F ++ G ++ H) ty1 ty2 ->
              Ortho (E ++ G ++ F ++ H) ty1 ty2.
Proof.
  induction H; intros.
  - rewrite app_nil_r in *.
    rewrite app_assoc.
    apply ortho_app_comm.
    generalize dependent E.
    generalize dependent F.
    induction G; intros.
    + intros; rewrite app_nil_r in *; now apply ortho_app_comm.
    + intros.
      change (F ++ E ++ a :: G) with (F ++ E ++ (a :: nil) ++ G).
      destruct a.
      assert ((F ++ E ++ ((v, t0) :: nil) ++ G) = (F ++ (E ++ ((v, t0) :: nil)) ++ G))
             by now rewrite <- app_assoc.
      rewrite H0; clear H0.
      apply IHG.
      rewrite <- app_assoc.
      apply ortho_extend_comm.
      change (E ++ F ++ (v, t0) :: G) with (E ++ F ++ ((v, t0) :: nil) ++ G) in H.
      rewrite app_assoc in H.
      apply ortho_extend_comm' in H.
      now rewrite <- app_assoc in *.
  - change (E ++ G ++ F ++ a :: H) with (E ++ G ++ F ++ (a :: nil) ++ H).
    destruct a.
    assert ((E ++ G ++ F ++ ((v, t0) :: nil) ++ H) =
            (E ++ G ++ (F ++ ((v, t0) :: nil)) ++ H)) by
    now rewrite <- app_assoc.
    rewrite H1; clear H1.
    apply IHlist.
    rewrite <- app_assoc.
    rewrite app_assoc.
    apply ortho_extend_comm.
    rewrite <- app_assoc.
    rewrite <- app_assoc.
    rewrite app_assoc in H0.
    rewrite app_assoc in H0.
    change (((E ++ F) ++ G) ++ (v, t0) :: H) with
           (((E ++ F) ++ G) ++ ((v, t0) :: nil) ++ H).
    apply ortho_extend_comm' in H0.
    repeat rewrite <- app_assoc in H0.
    apply H0.
Qed.

Hint Resolve in_or_app.
Hint Resolve in_app_or.

Lemma ortho_env_comm :
  forall E F G H ty1 ty2, Ortho (E ++ F ++ G ++ H) ty1 ty2 ->
                     Ortho (E ++ G ++ F ++ H) ty1 ty2.
Proof.
  intros.
  remember (E ++ F ++ G ++ H).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  generalize dependent G.
  dependent induction H0; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl; rewrite app_comm_cons; apply H1.
    not_in_L x.
    reflexivity.
    auto.
  - apply OVar with (A := A); auto.
    repeat (apply in_app_or in H0; destruct H0); auto 10.
  - apply OVarSym with (A := A); auto.
    repeat (apply in_app_or in H0; destruct H0); auto 10.
Qed.

Lemma ortho_weaken_sub :
  forall E G x t1 t2 d1 d2,
    ~ (In x (union (dom E) (dom G))) ->
    Ortho (E ++ extend x (TyDis d1) G) t1 t2 ->
    usub d2 d1  ->
    Ortho (E ++ extend x (TyDis d2) G) t1 t2.
Proof.
  intros E G x t1 t2 d1 d2 HNotIn HOrtho Husub.
  remember (E ++ extend x (TyDis d1) G) as Gamma.
  generalize dependent HeqGamma.
  generalize dependent E.
  induction HOrtho; intros; subst; eauto.
  - apply_fresh OForAll as x.
    assert (extend y (TyDis (And d0 d3)) (E ++ extend x (TyDis d2) G) =
            (extend y (TyDis (And d0 d3)) E) ++ extend x (TyDis d2) G) by
        (unfold extend; now simpl).
    rewrite H2.
    apply H0.
    not_in_L y.
    simpl.
    unfold not; intros; apply HNotIn.
    rewrite MSetProperties.union_add in H3.
    assert (Ha : x <> y).
    not_in_L y; unfold not; intros; subst; apply H16.
    now apply MSetProperties.Dec.F.singleton_iff.
    apply MSetProperties.Dec.F.add_iff in H3.
    destruct H3; auto.
    symmetry in H3; contradiction.
    now simpl.
    auto.
  - destruct (VarTyp.eq_dec x x0); subst.
    assert (Ha : A = d1).
    apply in_app_or in H.
    destruct H.
    not_in_L x0.
    exfalso; apply H2; now apply list_impl_m in H.
    not_in_L x0.
    apply in_app_or in H.
    destruct H.
    inversion H; now inversion H4.
    exfalso; apply H3; now apply list_impl_m in H.
    subst.
    apply OVar with (A := d2); auto.
    apply in_or_app.
    right.
    now left.
    apply usub_trans with (B := d1); auto.
    apply OVar with (A := A); auto.
    apply in_app_or in H.
    destruct H; auto.
    apply in_app_or in H.
    destruct H.
    simpl in H; destruct H.
    inversion H; subst; exfalso; now apply n.
    inversion H.
    apply in_or_app; right.
    apply in_or_app; auto.
  - destruct (VarTyp.eq_dec x x0); subst.
    assert (Ha : A = d1).
    apply in_app_or in H.
    destruct H.
    not_in_L x0.
    exfalso; apply H2; now apply list_impl_m in H.
    not_in_L x0.
    apply in_app_or in H.
    destruct H.
    inversion H; now inversion H4.
    exfalso; apply H3; now apply list_impl_m in H.
    subst.
    apply OVarSym with (A := d2); auto.
    apply in_or_app.
    right.
    now left.
    apply usub_trans with (B := d1); auto.
    apply OVarSym with (A := A); auto.
    apply in_app_or in H.
    destruct H; auto.
    apply in_app_or in H.
    destruct H.
    simpl in H; destruct H.
    inversion H; subst; exfalso; now apply n.
    inversion H.
    apply in_or_app; right.
    apply in_or_app; auto.
Qed.

Lemma ortho_weaken_sub_extend :
  forall Gamma x t1 t2 d1 d2, ~ In x (dom Gamma) ->
                     Ortho (extend x (TyDis d1) Gamma) t1 t2 ->
                     usub d2 d1 ->
                     Ortho (extend x (TyDis d2) Gamma) t1 t2.
Proof.
  intros Gamma x t1 t2 d1 d2 HNotIn HOrtho Husub.
  change (extend x (TyDis d2) Gamma) with (nil ++ extend x (TyDis d2) Gamma).
  apply ortho_weaken_sub with (d1 := d1); auto.
Qed.

Lemma Ortho_sym : forall Gamma t1 t2, Ortho Gamma t1 t2 -> Ortho Gamma t2 t1.
Proof.
  intros Gamma t1 t2 HOrtho.
  induction HOrtho; eauto.
  - inversion H1; subst.
    apply_fresh OForAll as x.
    apply ortho_weaken_sub_extend with (d1 := And d1 d2).
    not_in_L x.
    apply H0.
    not_in_L x.
    apply USAnd1.
    apply USAnd3; auto.
    apply usub_refl; auto.
    apply USAnd2.
    apply usub_refl; auto.
    auto.
    auto.
  - apply OAx; auto.
    destruct H as [H1 [H2 H3]].
    unfold OrthoAx; auto.
Qed.

Lemma Ortho_usub_trans :
  forall Gamma u ty d,
    PType ty ->
    Ortho Gamma u d ->
    usub d ty ->
    Ortho Gamma u ty.
Proof.
  intros Gamma u ty d HWFty HOrtho HSub.
  generalize dependent ty.
  induction HOrtho; intros; eauto.
  - induction ty; try now (inversion HSub; subst; auto);
    inversion HWFty; inversion HSub; subst; auto.
  - induction ty; try now (inversion HSub; subst; auto);
    inversion HWFty; inversion HSub; subst; auto.
  - induction ty; try now (inversion HSub; subst; auto);
    inversion HWFty; inversion HSub; subst; auto.
    inversion H1; subst.
    clear IHty1 IHty2.
    inversion HWFty; subst.
    inversion HSub; subst.
    apply_fresh OForAll as x.
    apply ortho_weaken_sub_extend with (d1 := And d1 d2).
    not_in_L x.
    apply H0.
    not_in_L x.
    apply H7.
    not_in_L x.
    apply H9.
    not_in_L x.
    apply USAnd1.
    apply USAnd2; auto.
    apply usub_refl; auto.
    apply USAnd3; auto.
    auto.
  - pose (usub_trans _ _ _ HWFty H0 HSub).
    apply OVar with (A := A) ; auto.
  - induction ty0; try (now inversion HSub).
    inversion HSub; subst; inversion HWFty; auto.
    inversion HSub; subst; eauto.
  - dependent induction HSub.
    inversion HWFty.
    apply OAnd2; auto.
    auto.
  - induction ty; try now (inversion HSub; subst; auto);
    inversion HWFty; inversion HSub; subst; auto.
  - induction ty; try now (inversion HSub; subst; auto);
    inversion HWFty; inversion HSub; subst; auto.
  - destruct t1; destruct t2;
    try (destruct H0 as [_ [_ H0]]; exfalso; now apply H0);
    try (now orthoax_inv_r H0); try (now orthoax_inv_l H0);
    try now (induction ty; inversion HSub; subst; inversion HWFty; auto).
Qed.

(* Properties concerning substitution and sub/ortho/wf *)

Lemma ortho_subst_not_in :
  forall Gamma z u t1 t2,
    not (In z (union (fv_ptyp t1) (fv_ptyp t2))) ->
    PType u ->
    Ortho Gamma t1 t2 ->
    Ortho (subst_env Gamma z u) t1 t2.
Proof.
  intros Gamma z u t1 t2 HNotIn HWFu HOrtho.
  generalize dependent z.
  induction HOrtho; intros z HNotIn; simpl in HNotIn; auto.
  - apply OAnd1; [ apply IHHOrtho1 | apply IHHOrtho2 ]; auto; not_in_L z;
    now inversion HWFt1.
  - apply OAnd2; [ apply IHHOrtho1 | apply IHHOrtho2 ]; auto; not_in_L z;
    now inversion HWFt2.
  - apply OFun; apply IHHOrtho; auto; not_in_L z.
  - assert (Ha : Ortho (subst_env Gamma z u) (ForAll (subst_typ_source z u d1) t1)
                       (ForAll (subst_typ_source z u d2) t2)).
    apply_fresh OForAll as x. apply H0. not_in_L x.
    unfold not; intros HH; rewrite union_spec in HH; destruct HH as [HH | HH];
    apply fv_open_rec_typ_source in HH; simpl in HH; rewrite union_spec in HH;
    destruct HH as [HH | HH]; try (now not_in_L z);
    not_in_L x; apply H11; apply MSetProperties.Dec.F.singleton_iff;
    apply MSetProperties.Dec.F.singleton_iff in HH; auto.
    apply PType_And.
    apply subst_source_lc; inversion H1; subst; auto.
    apply subst_source_lc; inversion H1; subst; auto.
    assert (Ha1 : d1 = subst_typ_source z u d1) by
        (rewrite subst_typ_source_fresh; auto; not_in_L z).
    assert (Ha2 : d2 = subst_typ_source z u d2) by
        (rewrite subst_typ_source_fresh; auto; not_in_L z).
    now rewrite Ha1, Ha2.
  - apply OVar with (A := subst_typ_source z u A); auto.
    apply in_persists_subst_env; auto.
    apply usub_subst_not_in; auto.
    not_in_L z.
  - apply OVarSym with (A := subst_typ_source z u A); auto.
    apply in_persists_subst_env; auto.
    apply usub_subst_not_in; auto.
    not_in_L z.
  - apply ORecEq.
    apply IHHOrtho.
    not_in_L z.
Qed.

Lemma ortho_subst :
  forall z u Gamma d t1 t2,
    not (In z (fv_ptyp u)) ->
    WFEnv (subst_env Gamma z u) ->
    WFEnv Gamma ->
    MapsTo Gamma z d ->
    Ortho Gamma u d ->
    Ortho Gamma t1 t2 ->
    PType u ->
    PType t1 ->
    PType t2 ->
    Ortho (subst_env Gamma z u) (subst_typ_source z u t1) (subst_typ_source z u t2).
Proof.
  intros z u Gamma d t1 t2 HNotIn HWFEnvS HWFEnv HMapsTo HOrthoud HOrthot1t2 HWFu HWFt1 HWFt2.
  induction HOrthot1t2.
  - simpl; inversion HWFt1; auto.
  - simpl; inversion HWFt2; auto.
  - simpl; inversion HWFt1; inversion HWFt2; subst; auto.
  - simpl; inversion HWFt1; inversion HWFt2; subst.
    apply_fresh OForAll as x.
    repeat rewrite subst_typ_source_open_source_var.
    simpl in H0.
    apply H0.
    not_in_L x.
    apply WFPushV; auto.
    simpl.
    not_in_L x.
    apply fv_subst_source in H6; rewrite union_spec in H6; destruct H6; not_in_L x.
    apply fv_subst_source in H6; rewrite union_spec in H6; destruct H6; not_in_L x.
    rewrite dom_subst_id; not_in_L x.
    apply WFPushV; auto; not_in_L x.
    simpl in H6; rewrite union_spec in H6; destruct H6; not_in_L x.
    apply MapsTo_extend; auto.
    not_in_L x.
    rewrite <- app_nil_l with (l := (extend x (TyDis (And d1 d2)) Gamma)).
    apply ortho_weaken.
    now simpl.
    apply H5.
    not_in_L x.
    apply H9.
    not_in_L x.
    not_in_L x.
    assumption.
    not_in_L x.
    assumption.
    apply PType_And; apply subst_source_lc; auto.
  - assert (Ha : sumbool (x = z) (not (x = z))) by apply VarTyp.eq_dec.
    destruct Ha as [Ha | Ha].
    + assert (HWFEnv' : WFEnv Gamma) by assumption.
      assert (Ha1 : A = d) by (subst; eapply MapsTo_In_eq with (Gamma := Gamma); eauto).
      subst; simpl; rewrite EqFacts.eqb_refl.
      assert (Ha2 : not (In z (fv_ptyp d))) by
          (apply not_in_wfenv with (Gamma := Gamma); auto).
      apply Ortho_usub_trans with (d := subst_typ_source z u d).
      now apply subst_source_lc.
      rewrite subst_typ_source_fresh; auto.
      apply ortho_subst_not_in; auto.
      not_in_L z.
      apply usub_subst; auto.
    + simpl; apply EqFacts.eqb_neq in Ha; rewrite Ha.
      apply OVar with (A := subst_typ_source z u A); auto.
      apply in_persists_subst_env; auto.
      apply usub_subst; auto.
      now apply subst_source_lc.
  - assert (Ha : sumbool (x = z) (not (x = z))) by apply VarTyp.eq_dec.
    destruct Ha as [Ha | Ha].
    + assert (HWFEnv' : WFEnv Gamma) by assumption.
      assert (Ha1 : A = d) by (subst; eapply MapsTo_In_eq with (Gamma := Gamma); eauto).
      subst; simpl; rewrite EqFacts.eqb_refl.
      apply Ortho_sym.
      assert (Ha2 : not (In z (fv_ptyp d))) by
          (apply not_in_wfenv with (Gamma := Gamma); auto).
      apply Ortho_usub_trans with (d := subst_typ_source z u d).
      now apply subst_source_lc.
      rewrite subst_typ_source_fresh; auto.
      apply ortho_subst_not_in; auto.
      not_in_L z.
      apply usub_subst; auto.
    + simpl; apply EqFacts.eqb_neq in Ha; rewrite Ha.
      apply OVarSym with (A := subst_typ_source z u A); auto.
      apply in_persists_subst_env; auto.
      apply usub_subst; auto.
      now apply subst_source_lc.
  - simpl; apply OTop1.
  - simpl; apply OTop2.
  - simpl; inversion HWFt1; inversion HWFt2; subst; auto.
  - simpl; inversion HWFt1; inversion HWFt2; subst; auto.
  - apply OAx; auto.
    assert (Ha : OrthoAx t1 t2) by assumption.
    destruct t1; destruct t2; auto; simpl; try (now orthoax_inv_r H0);
    try now orthoax_inv_l H0.
Qed.

End MDisjointness.