From Hammer Require Import Hammer.

Require Import DecidableTypeEx.
Require Export FSetInterface.
Set Implicit Arguments.
Unset Strict Implicit.

Module WFacts_fun (Import E : DecidableType)(Import M : WSfun E).

Notation eq_dec := E.eq_dec.
Definition eqb x y := if eq_dec x y then true else false.

Section IffSpec.
Variable s s' s'' : t.
Variable x y z : elt.

Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s).
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.In_eq_iff".
split; apply In_1; auto.
Qed.

Lemma mem_iff : In x s <-> mem x s = true.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.mem_iff".
split; [apply mem_1|apply mem_2].
Qed.

Lemma not_mem_iff : ~In x s <-> mem x s = false.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.not_mem_iff".
rewrite mem_iff; destruct (mem x s); intuition.
Qed.

Lemma equal_iff : s[=]s' <-> equal s s' = true.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.equal_iff".
split; [apply equal_1|apply equal_2].
Qed.

Lemma subset_iff : s[<=]s' <-> subset s s' = true.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.subset_iff".
split; [apply subset_1|apply subset_2].
Qed.

Lemma empty_iff : In x empty <-> False.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.empty_iff".
intuition; apply (empty_1 H).
Qed.

Lemma is_empty_iff : Empty s <-> is_empty s = true.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.is_empty_iff".
split; [apply is_empty_1|apply is_empty_2].
Qed.

Lemma singleton_iff : In y (singleton x) <-> E.eq x y.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.singleton_iff".
split; [apply singleton_1|apply singleton_2].
Qed.

Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.add_iff".
split; [ | destruct 1; [apply add_1|apply add_2]]; auto.
destruct (eq_dec x y) as [E|E]; auto.
intro H; right; exact (add_3 E H).
Qed.

Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s)  <-> In y s).
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.add_neq_iff".
split; [apply add_3|apply add_2]; auto.
Qed.

Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.remove_iff".
split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto.
intro.
apply (remove_1 H0 H).
Qed.

Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s).
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.remove_neq_iff".
split; [apply remove_3|apply remove_2]; auto.
Qed.

Lemma union_iff : In x (union s s') <-> In x s \/ In x s'.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.union_iff".
split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto.
Qed.

Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.inter_iff".
split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto.
Qed.

Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.diff_iff".
split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto.
Qed.

Variable f : elt->bool.

Lemma filter_iff :  compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true).
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.filter_iff".
split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto.
Qed.

Lemma for_all_iff : compat_bool E.eq f ->
(For_all (fun x => f x = true) s <-> for_all f s = true).
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.for_all_iff".
split; [apply for_all_1 | apply for_all_2]; auto.
Qed.

Lemma exists_iff : compat_bool E.eq f ->
(Exists (fun x => f x = true) s <-> exists_ f s = true).
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.exists_iff".
split; [apply exists_1 | apply exists_2]; auto.
Qed.

Lemma elements_iff : In x s <-> InA E.eq x (elements s).
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.elements_iff".
split; [apply elements_1 | apply elements_2].
Qed.

End IffSpec.

Ltac set_iff :=
repeat (progress (
rewrite add_iff || rewrite remove_iff || rewrite singleton_iff
|| rewrite union_iff || rewrite inter_iff || rewrite diff_iff
|| rewrite empty_iff)).

Section BoolSpec.
Variable s s' s'' : t.
Variable x y z : elt.

Lemma mem_b : E.eq x y -> mem x s = mem y s.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.mem_b".
intros.
generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H).
destruct (mem x s); destruct (mem y s); intuition.
Qed.

Lemma empty_b : mem y empty = false.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.empty_b".
generalize (empty_iff y)(mem_iff empty y).
destruct (mem y empty); intuition.
Qed.

Lemma add_b : mem y (add x s) = eqb x y || mem y s.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.add_b".
generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb.
destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition.
Qed.

Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.add_neq_b".
intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H).
destruct (mem y s); destruct (mem y (add x s)); intuition.
Qed.

Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y).
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.remove_b".
generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb.
destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition.
Qed.

Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.remove_neq_b".
intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H).
destruct (mem y s); destruct (mem y (remove x s)); intuition.
Qed.

Lemma singleton_b : mem y (singleton x) = eqb x y.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.singleton_b".
generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb.
destruct (eq_dec x y); destruct (mem y (singleton x)); intuition.
Qed.

Lemma union_b : mem x (union s s') = mem x s || mem x s'.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.union_b".
generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x).
destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition.
Qed.

Lemma inter_b : mem x (inter s s') = mem x s && mem x s'.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.inter_b".
generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x).
destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition.
Qed.

Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s').
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.diff_b".
generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x).
destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition.
Qed.

Lemma elements_b : mem x s = existsb (eqb x) (elements s).
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.elements_b".
generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)).
rewrite InA_alt.
destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros.
symmetry.
rewrite H1.
destruct H0 as (H0,_).
destruct H0 as (a,(Ha1,Ha2)); [ intuition |].
exists a; intuition.
unfold eqb; destruct (eq_dec x a); auto.
rewrite <- H.
rewrite H0.
destruct H1 as (H1,_).
destruct H1 as (a,(Ha1,Ha2)); [intuition|].
exists a; intuition.
unfold eqb in *; destruct (eq_dec x a); auto; discriminate.
Qed.

Variable f : elt->bool.

Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.filter_b".
intros.
generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H).
destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition.
Qed.

Lemma for_all_b : compat_bool E.eq f ->
for_all f s = forallb f (elements s).
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.for_all_b".
intros.
generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s).
unfold For_all.
destruct (forallb f (elements s)); destruct (for_all f s); auto; intros.
rewrite <- H1; intros.
destruct H0 as (H0,_).
rewrite (H2 x0) in H3.
rewrite (InA_alt E.eq x0 (elements s)) in H3.
destruct H3 as (a,(Ha1,Ha2)).
rewrite (H _ _ Ha1).
apply H0; auto.
symmetry.
rewrite H0; intros.
destruct H1 as (_,H1).
apply H1; auto.
rewrite H2.
rewrite InA_alt; eauto.
Qed.

Lemma exists_b : compat_bool E.eq f ->
exists_ f s = existsb f (elements s).
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.exists_b".
intros.
generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s).
unfold Exists.
destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros.
rewrite <- H1; intros.
destruct H0 as (H0,_).
destruct H0 as (a,(Ha1,Ha2)); auto.
exists a; split; auto.
rewrite H2; rewrite InA_alt; eauto.
symmetry.
rewrite H0.
destruct H1 as (_,H1).
destruct H1 as (a,(Ha1,Ha2)); auto.
rewrite (H2 a) in Ha1.
rewrite (InA_alt E.eq a (elements s)) in Ha1.
destruct Ha1 as (b,(Hb1,Hb2)).
exists b; auto.
rewrite <- (H _ _ Hb1); auto.
Qed.

End BoolSpec.

Instance E_ST : Equivalence E.eq.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.E_ST".
constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans].
Qed.

Instance Equal_ST : Equivalence Equal.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.Equal_ST".
constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans].
Qed.

Instance In_m : Proper (E.eq ==> Equal ==> iff) In.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.In_m".
unfold Equal; intros x y H s s' H0.
rewrite (In_eq_iff s H); auto.
Qed.

Instance is_empty_m : Proper (Equal==> Logic.eq) is_empty.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.is_empty_m".
unfold Equal; intros s s' H.
generalize (is_empty_iff s)(is_empty_iff s').
destruct (is_empty s); destruct (is_empty s');
unfold Empty; auto; intros.
symmetry.
rewrite <- H1; intros a Ha.
rewrite <- (H a) in Ha.
destruct H0 as (_,H0).
exact (H0 Logic.eq_refl _ Ha).
rewrite <- H0; intros a Ha.
rewrite (H a) in Ha.
destruct H1 as (_,H1).
exact (H1 Logic.eq_refl _ Ha).
Qed.

Instance Empty_m : Proper (Equal ==> iff) Empty.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.Empty_m".
repeat red; intros; do 2 rewrite is_empty_iff; rewrite H; intuition.
Qed.

Instance mem_m : Proper (E.eq ==> Equal ==> Logic.eq) mem.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.mem_m".
unfold Equal; intros x y H s s' H0.
generalize (H0 x); clear H0; rewrite (In_eq_iff s' H).
generalize (mem_iff s x)(mem_iff s' y).
destruct (mem x s); destruct (mem y s'); intuition.
Qed.

Instance singleton_m : Proper (E.eq ==> Equal) singleton.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.singleton_m".
unfold Equal; intros x y H a.
do 2 rewrite singleton_iff; split; intros.
apply E.eq_trans with x; auto.
apply E.eq_trans with y; auto.
Qed.

Instance add_m : Proper (E.eq==>Equal==>Equal) add.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.add_m".
unfold Equal; intros x y H s s' H0 a.
do 2 rewrite add_iff; rewrite H; rewrite H0; intuition.
Qed.

Instance remove_m : Proper (E.eq==>Equal==>Equal) remove.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.remove_m".
unfold Equal; intros x y H s s' H0 a.
do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition.
Qed.

Instance union_m : Proper (Equal==>Equal==>Equal) union.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.union_m".
unfold Equal; intros s s' H s'' s''' H0 a.
do 2 rewrite union_iff; rewrite H; rewrite H0; intuition.
Qed.

Instance inter_m : Proper (Equal==>Equal==>Equal) inter.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.inter_m".
unfold Equal; intros s s' H s'' s''' H0 a.
do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition.
Qed.

Instance diff_m : Proper (Equal==>Equal==>Equal) diff.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.diff_m".
unfold Equal; intros s s' H s'' s''' H0 a.
do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition.
Qed.

Instance Subset_m : Proper (Equal==>Equal==>iff) Subset.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.Subset_m".
unfold Equal, Subset; firstorder.
Qed.

Instance subset_m : Proper (Equal ==> Equal ==> Logic.eq) subset.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.subset_m".
intros s s' H s'' s''' H0.
generalize (subset_iff s s'') (subset_iff s' s''').
destruct (subset s s''); destruct (subset s' s'''); auto; intros.
rewrite H in H1; rewrite H0 in H1; intuition.
rewrite H in H1; rewrite H0 in H1; intuition.
Qed.

Instance equal_m : Proper (Equal ==> Equal ==> Logic.eq) equal.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.equal_m".
intros s s' H s'' s''' H0.
generalize (equal_iff s s'') (equal_iff s' s''').
destruct (equal s s''); destruct (equal s' s'''); auto; intros.
rewrite H in H1; rewrite H0 in H1; intuition.
rewrite H in H1; rewrite H0 in H1; intuition.
Qed.

Lemma Subset_refl : forall s, s[<=]s.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.Subset_refl".   red; auto. Qed.

Lemma Subset_trans : forall s s' s'', s[<=]s'->s'[<=]s''->s[<=]s''.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.Subset_trans".   unfold Subset; eauto. Qed.

Add Relation t Subset
reflexivity proved by Subset_refl
transitivity proved by Subset_trans
as SubsetSetoid.

Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> Basics.impl) In | 1.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.In_s_m".
simpl_relation. eauto with set.
Qed.

Add Morphism Empty with signature Subset --> Basics.impl as Empty_s_m.
Proof.
unfold Subset, Empty, Basics.impl; firstorder.
Qed.

Add Morphism add with signature E.eq ==> Subset ++> Subset as add_s_m.
Proof.
unfold Subset; intros x y H s s' H0 a.
do 2 rewrite add_iff; rewrite H; intuition.
Qed.

Add Morphism remove with signature E.eq ==> Subset ++> Subset as remove_s_m.
Proof.
unfold Subset; intros x y H s s' H0 a.
do 2 rewrite remove_iff; rewrite H; intuition.
Qed.

Add Morphism union with signature Subset ++> Subset ++> Subset as union_s_m.
Proof.
unfold Equal; intros s s' H s'' s''' H0 a.
do 2 rewrite union_iff; intuition.
Qed.

Add Morphism inter with signature Subset ++> Subset ++> Subset as inter_s_m.
Proof.
unfold Equal; intros s s' H s'' s''' H0 a.
do 2 rewrite inter_iff; intuition.
Qed.

Add Morphism diff with signature Subset ++> Subset --> Subset as diff_s_m.
Proof.
unfold Subset; intros s s' H s'' s''' H0 a.
do 2 rewrite diff_iff; intuition.
Qed.

Lemma filter_equal : forall f, compat_bool E.eq f ->
forall s s', s[=]s' -> filter f s [=] filter f s'.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.filter_equal".
unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto.
Qed.

Lemma filter_ext : forall f f', compat_bool E.eq f -> (forall x, f x = f' x) ->
forall s s', s[=]s' -> filter f s [=] filter f' s'.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.filter_ext".
intros f f' Hf Hff' s s' Hss' x. do 2 (rewrite filter_iff; auto).
rewrite Hff', Hss'; intuition.
repeat red; intros; rewrite <- 2 Hff'; auto.
Qed.

Lemma filter_subset : forall f, compat_bool E.eq f ->
forall s s', s[<=]s' -> filter f s [<=] filter f s'.
Proof. hammer_hook "FSetFacts" "FSetFacts.WFacts_fun.filter_subset".
unfold Subset; intros; rewrite filter_iff in *; intuition.
Qed.

End WFacts_fun.

Module WFacts (M:WS) := WFacts_fun M.E M.
Module Facts := WFacts.


Require Export Basics.

Require Export EnvListAux7.
Require Export EnvListAuxT1.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import Coq.Logic.ProofIrrelevance.

Require Import TPipStaticM2.
Require Import TPipDynamicM2.
Require Import TRInductM2.
Require Import WeakM2.
Require Import TSoundnessM2.
Require Import IdModType.
Require Import Hardware_Deep_v2.
Require Import Coq.Logic.EqdepFacts.
Require Import IdModA_M2.

Module Hoare_Test_state <: IdModType.

Module HardwareC := Hardware IdMod.
Export HardwareC.

Definition Id := HardwareC.Id.
Definition IdEqDec := HardwareC.IdEqDec.
Definition IdEq := HardwareC.IdEq.
Definition W := HardwareC.W.
Definition Loc_PI := HardwareC.Loc_PI.
Definition BInit := HardwareC.BInit.
Definition WP := HardwareC.WP.

(**************************************************)

Open Scope state_scope.

Fixpoint findD {K V: Type} {h: DEq K} (m: list (K * V)) (d: V) (k: K) : V :=
  match m with
     | nil => d
     | cons (k', x) ls => match (dEq k k') with
                            | left _ => x
                            | right _ => findD ls d k
                            end
    end.

Fixpoint update1 {K V: Type} {h: DEq K} (m: list (K * V)) (k: K) (v: V) :
  list (K * V) :=
  match m with
     | nil => [(k,v)]
     | cons (k', x) ls => match (dEq k k') with
                            | left _ => (k',v):: ls
                            | right _ => (k',x) :: update1 ls k v
                            end
    end.

Lemma findUpdate {K V: Type} {h: DEq K} :
forall (m: list (K * V)) (x: K) (v v': V), findD(update1 m x v) v' x = v.
Proof.
intros.
induction m.
simpl.
destruct dEq.
auto.
contradiction.
induction a.
unfold update1.
destruct dEq.
apply symmetry in e.
rewrite e.
simpl.
destruct dEq.
auto.
contradiction.
simpl.
destruct dEq.
contradiction.
auto.
Qed.

Definition xf_read : XFun Id nat := {|
   b_mod := fun s x => (s, findD s 0 x)
|}.

Definition xf_write : XFun (Id * nat) unit := {|
   b_mod := fun s x => (update1 s (fst x) (snd x), tt)
|}.

(*
Definition xf_reset : XFun (PState W) unit := {|
   b_mod := fun x _ => (b_init, tt)
|}.
*)

Instance VT_Id : ValTyp Id.

Instance VT_IdNat : ValTyp (Id * nat).

Definition Read (x: Id) : Exp :=
  Modify Id nat VT_Id NatV xf_read (QV (cst Id x)).

Definition Write (x: Id) (v: nat) : Exp :=
  Modify (Id * nat) unit VT_IdNat UnitV xf_write (QV (cst (Id * nat) (x,v))).

(*Definition Reset (VW: ValTyp (PState W)) : Exp :=
  Modify (PState W) unit VW UnitV xf_reset
         (QV (cst (PState nat) pstate_nat)).*)

(** 1 *)

Lemma write_entry_1 (P0: W -> Prop)
           (fenv: funEnv) (env: valEnv) (x: Id) (v: nat):
  forall (s s': W) (e: Exp),
    EStep fenv env (Conf Exp s (Write x v))
                      (Conf Exp s' e) ->
  P0 (update1 s x v) -> P0 s'.
Proof.
intros s s' e H1 H2.
inversion H1; subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
rewrite H9.
rewrite H7.
unfold b_exec.
unfold b_mod.
unfold xf_write.
simpl.
auto.
inversion X.
Qed.

Definition WriteEntry1SHT (P0: W -> Prop)
                       (fenv: funEnv) (env: valEnv) (x: Id) (v: nat):=
  HoareTriple_Step (fun s => P0 (update1 s x v)) (fun _ s => P0 s) fenv env (Write x v).

Lemma write_entry_1_sht (P0: W -> Prop)
           (fenv: funEnv) (env: valEnv) (x: Id) (v: nat):
  forall (s s': W) (e: Exp),
    WriteEntry1SHT P0 fenv env x v.
Proof.
intros s s' e.
unfold WriteEntry1SHT.
unfold HoareTriple_Step.
apply write_entry_1.
Qed.

(** 2 *)

Lemma write_entry_2 (P0: W -> Prop)
           (fenv: funEnv) (env: valEnv) (x: Id) (v: nat):
  forall (s s': W) (e: Exp),
    EStep fenv env (Conf Exp s (Write x v))
                      (Conf Exp s' e) ->
  P0 (update1 s x v) -> P0 s' /\ s' = update1 s x v.
Proof.
intros s s' e H1 H2.
split.
eapply write_entry_1.
eauto. auto.
inversion H1;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
rewrite H7.
rewrite H9.
unfold b_exec.
unfold xf_write.
unfold b_mod.
simpl.
reflexivity.
inversion X.
Qed.

Definition WriteEntry2SHT (P0: W -> Prop)
                       (fenv: funEnv) (env: valEnv) (x: Id) (v: nat):=
  HoareTriple_Step (fun s => P0 (update1 s x v)) (fun _ s => P0 s)
                   fenv env (Write x v).

Lemma write_Entry_2_sht (P0: W -> Prop)
           (fenv: funEnv) (env: valEnv) (x: Id) (v: nat):
  forall (s s': W) (e: Exp),
    WriteEntry2SHT P0 fenv env x v.
intros s s' e.
unfold WriteEntry2SHT.
unfold HoareTriple_Step.
eapply write_entry_2.
Qed.

(** 3 *)

Lemma read_entry_1 (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: Id):
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s (Read x))
             (Conf Exp s' (Val v)) ->
    P0 (cst nat (findD s 0 x)) -> P0 v.
Proof.
intros s s' v H1 H2.
inversion H1;subst.
inversion X;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
rewrite H7 in X.
rewrite H9 in X.
unfold xf_read in X.
unfold b_exec in X.
unfold b_eval in X.
unfold b_mod in X.
simpl in *.
rewrite H7 in X0.
rewrite H9 in X0.
unfold xf_read in X0.
unfold b_exec in X0.
unfold b_eval in X0.
unfold b_mod in X0.
simpl in *.
destruct v.
destruct v.
unfold cst in *.
inversion X0;subst.
apply inj_pair2 in H10.
eauto.
inversion X1;subst.
inversion X1.
Qed.

Definition ReadEntry1SHT (P0: Value -> Prop)
                       (fenv: funEnv) (env: valEnv) (x: Id):=
  HoareTriple_Step (fun s => P0 (cst nat (findD s 0 x)))
                   (fun e _ => forall v: Value,
                                 e = Val v -> P0 v) fenv env (Read x).

Definition ReadEntry1VHT (P0: Value -> Prop)
                       (fenv: funEnv) (env: valEnv) (x: Id) :=
  HoareTriple_Eval (fun s => P0 (cst nat (findD s 0 x)))
                   (fun v _ => P0 v) fenv env (Read x).

(** 4 *)

Lemma read_entry_2 (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: Id):
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s (Read x))
             (Conf Exp s' (Val v)) ->
    P0 (cst nat (findD s 0 x)) -> P0 v /\ v = (cst nat (findD s' 0 x)).
Proof.
intros s s' v H1 H2.
eauto.
split.
eapply read_entry_1.
eauto. auto.
destruct v.
destruct v.
unfold cst in *.
inversion H1;subst.
inversion X;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
rewrite H7 in X.
rewrite H9 in X.
unfold xf_read in X.
unfold b_exec in X.
unfold b_eval in X.
unfold b_mod in X.
simpl in *.
rewrite H7 in X0.
rewrite H9 in X0.
unfold xf_read in X0.
unfold b_exec in X0.
unfold b_eval in X0.
unfold b_mod in X0.
simpl in *.
inversion X0;subst.
auto.
inversion X;subst.
inversion X1.
inversion X1.
Qed.

Definition ReadEntry2SHT (P0: Value -> Prop)
                       (fenv: funEnv) (env: valEnv) (x: Id):=
  HoareTriple_Step (fun s => P0 (cst nat (findD s 0 x)))
                   (fun e s => forall v: Value,
                          e = Val v -> P0 v /\ v = cst nat (findD s 0 x)) fenv env (Read x).

Definition ReadEntry2VHT (P0: Value -> Prop)
                       (fenv: funEnv) (env: valEnv) (x: Id):=
  HoareTriple_Eval (fun s => P0 (cst nat (findD s 0 x)))
                   (fun v s => P0 v /\ v = cst nat (findD s 0 x)) fenv env (Read x).

(** 5 *)

Lemma wread_entry_1 (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: Id) (n: nat):
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s (BindN (Write x n) (Read x)))
                      (Conf Exp s' (Val v)) ->
  P0 (cst nat n) -> P0 v.
Proof.
intros s s' v H1 H2.
inversion H1;subst.
inversion X;subst.
inversion X1;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
rewrite H7 in X.
rewrite H9 in X.
unfold xf_write in X.
unfold b_exec in X.
unfold b_eval in X.
unfold b_mod in X.
simpl in *.
rewrite H7 in X0.
rewrite H9 in X0.
unfold xf_write in X0.
unfold b_exec in X0.
unfold b_eval in X0.
unfold b_mod in X0.
simpl in *.
rewrite H7 in X1.
rewrite H9 in X1.
unfold xf_write in X1.
unfold b_exec in X1.
unfold b_eval in X1.
unfold b_mod in X1.
simpl in *.
destruct v.
destruct v.
unfold cst in *.
inversion X0;subst.
inversion X2;subst.
inversion X3;subst.
inversion X4;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H10.
rewrite H7 in X5.
rewrite H10 in X5.
unfold b_exec in X5.
unfold b_eval in X5.
unfold xf_read in X5.
unfold b_mod in X5.
simpl in *.
rewrite H7 in X4.
rewrite H10 in X4.
unfold b_exec in X4.
unfold b_eval in X4.
unfold xf_read in X4.
unfold b_mod in X4.
simpl in *.
inversion X5;subst.
eauto.
rewrite findUpdate.
auto.
inversion X6.
inversion X6.
inversion X4.
inversion X2.
Qed.

Definition WReadEntry1EHT (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: Id) (n:nat) :=
  HoareTriple_ExtendedStep (fun _ => P0 (cst nat n))
                           (fun e _ => forall v: Value, e = Val v -> P0 v)
                           fenv env (BindN (Write x n) (Read x)).

Lemma wread_nat_1_eht (P0: Value -> Prop)
      (fenv: funEnv) (env: valEnv) (x: Id) (n:nat):
    WReadEntry1EHT P0 fenv env x n.
Proof.
unfold WReadEntry1EHT.
unfold HoareTriple_ExtendedStep.
intros s s' e' H1 H2 v H3.
eapply wread_entry_1.
rewrite <- H3.
eauto. auto.
Qed.

Definition WReadEntry1VHT (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: Id) (n:nat):=
  HoareTriple_Eval (fun _ => P0 (cst nat n))
                    (fun v _ => P0 v)
                    fenv env (BindN (Write x n) (Read x)).

Lemma wread_entry_1_vht (P0: Value -> Prop)
      (fenv: funEnv) (env: valEnv) (x: Id) (n:nat):
    WReadEntry1VHT P0 fenv env x n.
Proof.
unfold WReadEntry1VHT.
unfold HoareTriple_Eval.
eapply wread_entry_1.
Qed.

(** 6 *)

Lemma wread_entry_2 (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: Id) (n:nat):
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s (BindN (Write x n) (Read x)))
                      (Conf Exp s' (Val v)) ->
  P0 (cst nat n) -> P0 v /\ (update1 s x n) = s' /\ v = cst nat n.
Proof.
intros s s' v H1 H2.
split.
eapply wread_entry_1.
eauto. auto.
split.
-inversion H1;subst.
 inversion X;subst.
 inversion X1;subst.
 repeat apply inj_pair2 in H7.
 apply inj_pair2 in H9.
 rewrite H7 in X.
 rewrite H9 in X.
 unfold b_exec in X.
 unfold b_eval in X.
 unfold xf_write in X.
 unfold b_mod in X.
 simpl in *.
 rewrite H7 in X0.
 rewrite H9 in X0.
 unfold b_exec in X0.
 unfold b_eval in X0.
 unfold xf_write in X0.
 unfold b_mod in X0.
 simpl in *.
 rewrite H7 in X1.
 rewrite H9 in X1.
 unfold b_exec in X1.
 unfold b_eval in X1.
 unfold xf_write in X1.
 unfold b_mod in X1.
 simpl in *.
 inversion X0;subst.
 inversion X2;subst.
 inversion X3;subst.
 inversion X4;subst.
 repeat apply inj_pair2 in H7.
 apply inj_pair2 in H10.
 rewrite H7 in X5.
 rewrite H10 in X5.
 unfold b_exec in X5.
 unfold b_eval in X5.
 unfold xf_write in X5.
 unfold b_mod in X5.
 simpl in *.
 inversion X5;subst.
 auto.
 inversion X6.
 inversion X6.
 inversion X4.
 inversion X2.
-destruct v.
 destruct v.
 unfold cst in *.
 inversion H1;subst.
 inversion X;subst.
 inversion X1;subst.
 repeat apply inj_pair2 in H7.
 apply inj_pair2 in H9.
 rewrite H7 in X1.
 rewrite H9 in X1.
 unfold b_eval in X1.
 unfold b_exec in X1.
 unfold xf_write in X1.
 unfold b_mod in X1.
 simpl in *.
 rewrite H7 in X0.
 rewrite H9 in X0.
 unfold b_eval in X0.
 unfold b_exec in X0.
 unfold xf_write in X0.
 unfold b_mod in X0.
 simpl in *.
 rewrite H7 in X.
 rewrite H9 in X.
 unfold b_eval in X.
 unfold b_exec in X.
 unfold xf_write in X.
 unfold b_mod in X.
 simpl in *.
 inversion X1;subst.
 repeat apply inj_pair2 in H10.
 apply inj_pair2 in H12.
 apply inj_pair2 in H15.
 inversion H1;subst.
 inversion X2;subst.
 inversion X3;subst.
 inversion X4;subst.
 repeat apply inj_pair2 in H7.
 apply inj_pair2 in H10.
 rewrite H7 in X4.
 rewrite H10 in X4.
 unfold b_eval in X4.
 unfold b_exec in X4.
 unfold xf_write in X4.
 unfold b_mod in X4.
 simpl in *.
 rewrite H7 in X3.
 rewrite H10 in X3.
 unfold b_eval in X3.
 unfold b_exec in X3.
 unfold xf_write in X3.
 unfold b_mod in X3.
 simpl in *.
 rewrite H7 in X2.
 rewrite H10 in X2.
 unfold b_eval in X2.
 unfold b_exec in X2.
 unfold xf_write in X2.
 unfold b_mod in X2.
 simpl in *.
 inversion X5;subst.
 inversion X6;subst.
 inversion X7;subst.
 repeat apply inj_pair2 in H7.
 rewrite H7 in X8.
 rewrite H13 in X8.
 unfold b_eval in X8.
 unfold b_exec in X8.
 unfold xf_write in X8.
 unfold xf_read in X8.
 unfold b_mod in X8.
 simpl in *.
 rewrite H7 in X7.
 rewrite H13 in X7.
 unfold b_eval in X7.
 unfold b_exec in X7.
 unfold xf_write in X7.
 unfold xf_read in X7.
 unfold b_mod in X7.
 simpl in *.
 inversion X8;subst.
 repeat apply inj_pair2 in H12.
 apply symmetry in H12.
 rewrite H12.
 rewrite findUpdate.
 auto.
 inversion X9;subst.
 inversion X9.
 inversion X7;subst.
 inversion X7.
 inversion X2.
Qed.

Definition WReadEntry2VHT (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: Id) (n:nat):=
  HoareTriple_Eval (fun _ => P0 (cst nat n))
                    (fun v s => P0 v /\ v = cst nat n)
                    fenv env (BindN (Write x n) (Read x)).

Lemma wread_entry_2_vht (P0: Value -> Prop)
      (fenv: funEnv) (env: valEnv) (x: Id) (n:nat):
    WReadEntry2VHT P0 fenv env x n.
Proof.
unfold WReadEntry2VHT.
unfold HoareTriple_Eval.
intros.
split.
eapply wread_entry_2.
eauto.
auto.
eapply wread_entry_2.
eauto.
eauto.
Qed.

(** 7 *)

Lemma bindn_congruence1 (P: W -> Prop)
      (fenv: funEnv) (env: valEnv) (e: Exp) :
    HoareTriple_Step P (fun _ => P) fenv env e ->
    forall e1: Exp,
       HoareTriple_Step P (fun _ => P) fenv env (BindN e e1).
Proof.
intros H1 e1.
unfold HoareTriple_Step.
intros s s' e' H2 H3.
unfold HoareTriple_Step in H1.
inversion H2;subst.
assumption.
eapply H1.
eauto.
assumption.
Qed.

Lemma bindn_congruence2 (P P1: W -> Prop)
      (fenv: funEnv) (env: valEnv) (e e': Exp) :
    HoareTriple_Step P (fun _ => P1) fenv env e ->
    (forall (e1: Exp) (v: Value),
       HoareTriple_Step P (fun _ => P1) fenv env (BindN (Val v) e1)) ->
    forall e1: Exp,
       HoareTriple_Step P (fun _ => P1) fenv env (BindN e e1).
Proof.
intros.
unfold HoareTriple_Step.
intros.
unfold HoareTriple_Step in H.
unfold HoareTriple_Step in H0.
inversion X;subst.
eapply H0.
eauto.
assumption.
eapply H.
eauto.
assumption.
Qed.

Lemma BindN_BStep1 (fenv: funEnv) (env: valEnv)
      (e1 e2: Exp) (v: Value) (s s': W) :
  (forall (e:Exp) (s: W), sigT (fun v: Value =>
                 sigT (fun s': W =>
      EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v))))) ->
  (forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
      EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
      EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
        (s1 = s2) /\ (v1 = v2)) ->
  EClosure fenv env (Conf Exp s (BindN e1 e2)) (Conf Exp s' (Val v)) ->
  (sigT2 (fun s1 : W =>
            (sigT (fun v1: Value =>
                     EClosure fenv env (Conf Exp s e1) (Conf Exp s1 (Val v1)))))
         (fun s1 : W =>
            EClosure fenv env (Conf Exp s1 e2) (Conf Exp s' (Val v)))).
Proof.
intros k1 k2 H.
specialize k1 with e1 s as k.
destruct k.
destruct s0.
specialize k1 with e2 x0 as k.
destruct k.
destruct s0.
econstructor.
econstructor.
eauto.
eapply BindN_extended_congruence in e as H1.
instantiate (1:=e2) in H1.
eapply EClosConcat in e0 as H2.
instantiate (1:=(Conf Exp x0 (BindN (Val x) e2))) in H2.
eapply EClosConcat in H2.
instantiate (1:=(Conf Exp s (BindN e1 e2))) in H2.
specialize k2 with (BindN e1 e2) s s' x2 v x1.
apply k2 in H.
destruct H.
rewrite H.
rewrite H0.
auto.
auto.
auto.
econstructor.
econstructor.
econstructor.
Qed.

Lemma BindN_VHT1 (P0 P1: W -> Prop) (P2: Value -> W -> Prop)

(fenv: funEnv) (env: valEnv) (e1 e2: Exp)

      (k1: forall (e:Exp) (s: W), sigT (fun v: Value =>
                 sigT (fun s': W =>
             EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)))))

      (k2: forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
          EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
          EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
                (s1 = s2) /\ (v1 = v2)) :

  HoareTriple_Eval P0 (fun _ => P1) fenv env e1 ->
  HoareTriple_Eval P1 P2 fenv env e2 ->
  HoareTriple_Eval P0 P2 fenv env (BindN e1 e2).
Proof.
intros H1 H2.
unfold HoareTriple_Eval in *.
intros s s' v H3 H4.
eapply BindN_BStep1 in H3.
destruct H3.
destruct s0.
eapply H2.
eauto.
eapply H1.
eauto.
auto.
auto.
auto.
Qed.

Lemma simpl_BindMS :
forall (fenv fenv': funEnv) (env env': valEnv) (v : Value) (s : W),
  EClosure fenv env (Conf Exp s (BindMS fenv' env' (Val v))) (Conf Exp s (Val v)).
Proof.
intros.
econstructor.
econstructor.
econstructor.
Qed.

Lemma BindS_BStep1 (fenv: funEnv) (env: valEnv)
      (e1 e2: Exp) (x: Id) (v: Value) (s s': W)
  (k1: forall (fenv: funEnv) (env: valEnv) (e:Exp) (s: W),
       sigT (fun v: Value =>
                 sigT (fun s': W =>
             EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)))))
  (k2: forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
          EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
          EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
                (s1 = s2) /\ (v1 = v2))  :
  EClosure fenv env (Conf Exp s (BindS x e1 e2)) (Conf Exp s' (Val v)) ->
  (sigT (fun s1 : W =>
            (sigT2 (fun v1: Value =>
                     EClosure fenv env (Conf Exp s e1) (Conf Exp s1 (Val v1)))
                   (fun v1: Value =>
                     EClosure fenv ((x,v1)::env) (Conf Exp s1 e2) (Conf Exp s' (Val v)))))).
Proof.
intros H.
specialize k1 with fenv env e1 s as k.
destruct k.
destruct s0.
specialize k1 with fenv ((x,x0)::env) e2 x1 as k.
destruct k.
destruct s0.
econstructor.
econstructor.
eauto.
clear k1.
eapply BindS_extended_congruence in e as H2.
instantiate (1:=e2) in H2.
instantiate (1:=x) in H2.
specialize BindS_EStep with fenv env x1 x x0 e2 as X.
unfold singleE in X.
unfold emptyE in X.
apply StepIsEClos in X.
eapply BindMS_extended_congruence in e0 as H3.
instantiate (1:=[(x,x0)]) in H3.
instantiate (1:=[]) in H3.
instantiate (1:=env) in H3.
instantiate (1:=fenv) in H3.
eapply EClosConcat in H3 as H4.
instantiate (1:=(Conf Exp s (BindS x e1 e2))) in H4.
specialize simpl_BindMS with fenv emptyE env [(x, x0)] x2 x3 as X0.
eapply EClosConcat in X0 as X1.
instantiate (1:=(Conf Exp s (BindS x e1 e2))) in X1.
specialize k2 with (BindS x e1 e2) s s' x3 v x2.
apply k2 in H.
clear k2.
destruct H.
rewrite H.
rewrite H0.
auto.
auto.
auto.
eapply EClosConcat in X as X1.
instantiate (1:=(Conf Exp s (BindS x e1 e2))) in X1.
auto.
auto.
auto.
auto.
Qed.

Lemma BindS_VHT1 (P0: W -> Prop) (P1 P2: Value -> W -> Prop)

(fenv: funEnv) (env: valEnv) (e1 e2: Exp) (x: Id)

 (k1: forall (fenv: funEnv) (env: valEnv) (e:Exp) (s: W),
       sigT (fun v: Value =>
                 sigT (fun s': W =>
             EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)))))
 (k2: forall (e:Exp) (s s1 s2: W) (v1 v2: Value),
          EClosure fenv env (Conf Exp s e) (Conf Exp s1 (Val v1)) ->
          EClosure fenv env (Conf Exp s e) (Conf Exp s2 (Val v2)) ->
                (s1 = s2) /\ (v1 = v2)) :

  HoareTriple_Eval P0 P1 fenv env e1 ->
  (forall v, HoareTriple_Eval (P1 v) P2 fenv ((x,v)::env) e2) ->
  HoareTriple_Eval P0 P2 fenv env (BindS x e1 e2).
Proof.
intros.
unfold HoareTriple_Eval in *.
intros.
eapply BindS_BStep1 in X.
destruct X.
destruct s0.
eapply H0.
eauto.
eapply H.
eauto.
auto.
auto.
auto.
Qed.

End Hoare_Test_state.


From discprob.basic Require Import base sval order monad bigop_ext nify seq_ext.
Require Import Reals Psatz Omega.

Require ClassicalEpsilon.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice.
Global Set Bullet Behavior "Strict Subproofs".
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype finset finfun bigop.

Local Open Scope R_scope.
From discprob.idxval Require Import fin_ival pival fin_ival_dist pival_dist.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.idxval Require extrema.

Import List.

Definition Ex_ival {X} (f: X → R) (I: ival X) : R :=
  \big[Rplus/0]_(i in idx I)
              (f (ind I i) * val I i).

Section Ex_ival_properties.

  Lemma Ex_ival_mret {X} f (r: X):
    Ex_ival f (mret r) = f r.
  Proof.
    rewrite /Ex_ival/index_enum {1}[@Finite.enum]unlock //= big_cons big_nil //=.
    nra.
  Qed.

  Lemma Ex_ival_iplus {X} f (I1 I2: ival X) :
    Ex_ival f (iplus I1 I2) = (Ex_ival f I1) + (Ex_ival f I2).
  Proof.
    rewrite /Ex_ival/index_enum {1}[@Finite.enum]unlock
            /sum_enum big_cat ?big_map //= -?big_distrr //=.
  Qed.

  Lemma Ex_ival_iscale {X} f p (I: ival X) :
    Ex_ival f (iscale p I) =  Rabs p * (Ex_ival f I).
  Proof.
    rewrite /Ex_ival big_distrr //=.
    apply eq_bigr => i ?; nra.
  Qed.

  Lemma Ex_ival_negate {X} f (I: ival X) :
    Ex_ival (λ x, - f x) I = - Ex_ival f I.
  Proof.
    replace (- Ex_ival f I) with (-1 * Ex_ival f I); last by nra.
    rewrite /Ex_ival big_distrr //=.
    apply eq_bigr => ?. nra.
  Qed.

  Lemma Ex_ival_sum_support' {X} (I: ival X) f P :
    \big[Rplus/0]_(i : idx I | P i) (f i * val I i)
      = \big[Rplus/0]_(i : support (val I) | P (sval i)) (f (sval i) * val I (sval i)).
  Proof.
    symmetry.  rewrite /index_enum. apply sum_reidx_map with (h := sval) => //=.
    * intros (a&Hgt) ?? => //=. rewrite -enumT mem_enum //=.
    * intros b _ HP Hneq. specialize (val_nonneg I b).
      destruct 1 as [Hgt|Heq0]; auto.
      exfalso. apply Hneq.
      exists (coerce_supp _ _ Hgt); repeat split; auto.
      rewrite -enumT mem_enum //=.
      rewrite Heq0. nra.
    * rewrite -enumT. apply enum_uniq.
    * rewrite -enumT. apply enum_uniq.
    * intros. by apply sval_inj_pred.
  Qed.

  Lemma Ex_ival_sum_support {X} f (I: ival X) :
    Ex_ival f I
      = \big[Rplus/0]_(i : support (val I)) (f (ind I (sval i)) * val I (sval i)).
  Proof.
    rewrite /Ex_ival. apply (Ex_ival_sum_support' I (λ x, f (ind I x)) (λ x, true)).
  Qed.

  Lemma Ex_ival_sum_support_pred {X} f (I: ival X) :
    Ex_ival f I
      = \big[Rplus/0]_(i | Rgt_dec (val I i) 0) (f (ind I i) * val I i).
  Proof.
    rewrite /Ex_ival.
    rewrite bigop_cond_non0.
    symmetry.
    rewrite bigop_cond_non0.
    apply eq_bigl => //=.
    intros i. destruct Rgt_dec => //=.
    destruct (val_nonneg I i) as [Hgt|Heq] => //=; try nra.
    rewrite Heq Rmult_0_r eq_refl //=.
  Qed.

  Lemma Ex_ival_mono {X} f1 f2 (I: ival X):
    (∀ x, f1 x ≤ f2 x) →
    Ex_ival f1 I ≤ Ex_ival f2 I.
  Proof.
    intros Hf.
    rewrite /Ex_ival; apply Rle_bigr => i Hin.
    specialize (val_nonneg I i) => ?.
    specialize (Hf (ind I i)). nra.
  Qed.

  Lemma Ex_ival_mono_support {X} f1 f2 (I: ival X):
    (∀ x, val I x > 0 → f1 (ind I x) ≤ f2 (ind I x)) →
    Ex_ival f1 I ≤ Ex_ival f2 I.
  Proof.
    intros Hf.
    rewrite /Ex_ival; apply Rle_bigr => i Hin.
    destruct (val_nonneg I i) as [Hgt|Heq0].
    * specialize (Hf i Hgt); nra.
    * rewrite Heq0. nra.
  Qed.

  Lemma Ex_ival_proper' {X} f1 f2 (I1 I2: ival X):
    (∀ x, f1 x = f2 x) →
    eq_ival I1 I2 →
    Ex_ival f1 I1 = Ex_ival f2 I2.
  Proof.
    intros Hext Heq.
    rewrite ?Ex_ival_sum_support.
    destruct Heq as (h1&h2&Hinv&?&Hind&Hval).
    apply (sum_reidx_surj1 _ _ _ _ _ _ (h1)).
    - intros. by rewrite Hext ?Hind ?Hval.
    - intros. split; auto.
      rewrite /index_enum -enumT mem_enum //=.
    - intros b. exists (h2 b). split; auto.
      rewrite /index_enum -enumT mem_enum //=.
    - rewrite /index_enum -enumT. apply enum_uniq.
    - rewrite /index_enum -enumT. apply enum_uniq.
    - intros x1 x2.  intros Heq%(f_equal h2).
      by rewrite ?Hinv in Heq.
  Qed.

  Lemma Ex_ival_proper {X} f (I1 I2: ival X):
    eq_ival I1 I2 →
    Ex_ival f I1 = Ex_ival f I2.
  Proof. intros; by apply Ex_ival_proper'. Qed.

  Global Instance Ex_ival_proper_instance:
    ∀ (X : Type), Proper ((pointwise_relation _ eq) ==> @eq_ival X ==> eq) (Ex_ival).
  Proof.
    intros X f1 f2 ? I1 I2 Heq.
    by apply Ex_ival_proper'.
  Qed.

  Lemma Ex_ival_bind_irrel {X Y} f (I: ival X) (m: ival Y):
    \big[Rplus/0]_i (val m i) = 1 →
    Ex_ival f (mbind (λ x, I) (m: ival Y)) = Ex_ival f I.
  Proof.
    intros Hsum1.
    rewrite {1}/Ex_ival//=.
    rewrite /index_enum {1}[@Finite.enum]unlock //=.
    rewrite /tag_enum big_flatten //= big_map.
    etransitivity.
    eapply eq_bigr => i ?.
    { rewrite ?big_map /=.
      etransitivity; first eapply eq_bigr => j ?.
      {
        rewrite -Rmult_assoc Rmult_comm -Rmult_assoc.
        done.
      }
      rewrite /= -big_distrl /= .
      rewrite (eq_bigl (λ x, true)); first done.
      intros j => //=.
    }
    rewrite //=.
    rewrite -big_distrr //=.
    rewrite -[a in _ = a]Rmult_1_r.
    f_equal.
    { rewrite /Ex_ival/index_enum//=. apply congr_big; auto.
      intros; nra. }
    apply Hsum1.
  Qed.

  Lemma Ex_ival_bind_le {X Y1 Y2} f1 f2 (I: ival X) (h1 : X → ival Y1) (h2: X → ival Y2):
    (∀ a, (∃ x, val I x > 0 ∧ ind I x = a) →
                Ex_ival f1 (h1 a) ≤ Ex_ival f2 (h2 a)) →
    Ex_ival f1 (mbind h1 I) ≤ Ex_ival f2 (mbind h2 I).
  Proof.
    intros Hh.
    rewrite ?Ex_ival_sum_support_pred.
    rewrite /index_enum {1}[@Finite.enum]unlock //=.
    rewrite /tag_enum big_flatten //= big_map.
    rewrite /index_enum {3}[@Finite.enum]unlock //=.
    rewrite /tag_enum big_flatten //= big_map.
    eapply Rle_bigr => i ?.
    rewrite ?big_map //=.
    destruct (val_nonneg I i) as [Hgt|Heq]; last first.
    { rewrite Heq //=. transitivity 0; right.
      * rewrite big1 //= => i'. rewrite Rmult_0_l. destruct Rgt_dec => //=; nra.
      * rewrite big1 //= => i'. rewrite Rmult_0_l. destruct Rgt_dec => //=; nra.
    }
    assert ( val I i * Ex_ival f1 (h1 (ind I i)) ≤ val I i * Ex_ival f2 (h2 (ind I i))) as Hle'.
    { apply Rmult_le_compat_l; first apply Rge_le, val_nonneg.
      eapply Hh; eauto.
    }
    etransitivity; first (etransitivity; last eapply Hle').
    - rewrite Ex_ival_sum_support_pred.
      rewrite big_distrr.
      rewrite //=.
      right. apply congr_big  => //=.
      * intros i' => //=. repeat destruct Rgt_dec => //=; nra.
      * intros i' Hgt'. nra.
    - rewrite Ex_ival_sum_support_pred.
      rewrite big_distrr.
      rewrite //=.
      right. apply congr_big  => //=.
      * intros i' => //=. repeat destruct Rgt_dec => //=; nra.
      * intros i' Hgt'. nra.
  Qed.

  Lemma Ex_ival_bind_eq {X Y1 Y2} f1 f2 (I: ival X) (h1: X → ival Y1) (h2: X → ival Y2):
    (∀ a, (∃ x, val I x > 0 ∧ ind I x = a) →
                Ex_ival f1 (h1 a) = Ex_ival f2 (h2 a)) →
    Ex_ival f1 (mbind h1 I) = Ex_ival f2 (mbind h2 I).
  Proof.
    intros Hcontinue; apply Rle_antisym; apply Ex_ival_bind_le.
    - intros a (?&?&?).
      right; apply Hcontinue; eauto.
    - intros a (?&?&?).
      right; symmetry; apply Hcontinue; eauto.
  Qed.

  Lemma Ex_ival_ivdplus {X} f p Hpf (I1 I2: ivdist X) :
    Ex_ival f (ivdplus p Hpf I1 I2 : ival X) = p * Ex_ival f I1 + (1 - p) * Ex_ival f I2.
  Proof.
    rewrite /ivdplus//= Ex_ival_iplus !Ex_ival_iscale.
    rewrite ?Rabs_right //=; nra.
  Qed.

  Lemma Ex_ival_bind_post {X Y} f (I: ival X) (h: X → ival Y):
    Ex_ival f (x ← I; h x) = Ex_ival (λ x, Ex_ival f (h x)) I.
  Proof.
    rewrite /Ex_ival//=.
    rewrite /index_enum {1}[@Finite.enum]unlock //=.
    rewrite /tag_enum big_flatten //= big_map.
    apply eq_bigr => i Hin.
    rewrite big_map => //=.
    rewrite big_distrl => //=.
    apply eq_bigr => ??.
    nra.
  Qed.

End Ex_ival_properties.

Definition Ex_ivd {X} (f: X → R) (I: ivdist X) : R := Ex_ival f I.

Section Ex_ivd_properties.

  Lemma Ex_ivd_plus {X} f p Hpf (I1 I2: ivdist X) :
    Ex_ivd f (ivdplus p Hpf I1 I2) = p * Ex_ivd f I1 + (1 - p) * Ex_ivd f I2.
  Proof. apply Ex_ival_ivdplus. Qed.

  Lemma Ex_ivd_bind_irrel {X Y} f (I: ivdist X) (m: ivdist Y):
    Ex_ivd f (mbind (λ x, I) m) = Ex_ivd f I.
  Proof.
    rewrite /Ex_ivd//=.
    apply Ex_ival_bind_irrel, val_sum1.
  Qed.

  Lemma Ex_ivd_plus_const {X} f (I: ivdist X) k:
    Ex_ivd (λ x, f x + k) I = Ex_ivd f I + k.
  Proof.
    rewrite /Ex_ival.
    etransitivity.
    { eapply eq_bigr => i Hin.
      rewrite Rmult_plus_distr_r. done.
    }
    rewrite big_split => //=; f_equal.
    rewrite -big_distrr.
    rewrite val_sum1 => //=. nra.
  Qed.

  Lemma Ex_ivd_scale_const {X} f (I: ivdist X) k:
    Ex_ivd (λ x, k * (f x)) I = k * (Ex_ivd f I).
  Proof.
    rewrite /Ex_ivd/Ex_ival//=.
    rewrite big_distrr => //=.
    apply eq_bigr => ??; nra.
  Qed.

  Lemma Ex_ivd_const {X} (I: ivdist X) k:
    Ex_ivd (λ x, k) I = k.
  Proof.
    rewrite /Ex_ivd/Ex_ival//=.
    rewrite -big_distrr val_sum1 => //=; nra.
  Qed.

  Lemma Ex_ivd_ivdplus {X} f p Hpf (I1 I2: ivdist X) :
    Ex_ivd f (ivdplus p Hpf I1 I2) = p * Ex_ivd f I1 + (1 - p) * Ex_ivd f I2.
  Proof.
    rewrite /Ex_ivd. rewrite Ex_ival_ivdplus //=.
  Qed.

  Lemma Ex_ivd_sum {X} (f1 f2: X → R) (I: ivdist X):
    Ex_ivd (λ x, f1 x + f2 x) I = Ex_ivd f1 I + Ex_ivd f2 I.
  Proof.
    rewrite /Ex_ivd/Ex_ival. etransitivity.
    { eapply eq_bigr => i ?. ring_simplify. done. }
    rewrite //=. apply big_split.
  Qed.

  Global Instance Ex_ivd_proper_instance:
    ∀ (X : Type), Proper ((pointwise_relation _ eq) ==> @eq_ivd X ==> eq) (Ex_ivd).
  Proof.
    intros X f1 f2 ? I1 I2 Heq.
    by apply Ex_ival_proper'.
  Qed.

End Ex_ivd_properties.

From discprob.idxval Require Import pidist_fin_singleton.

Lemma ex_Ex_extrema_singleton {X} f (I: ivdist X):
  extrema.ex_Ex_extrema f (singleton I).
Proof.
  intros I' <-.
  rewrite /extrema.ex_Ex_ival.
  rewrite //=. eexists. apply SeriesF_is_seriesC.
Qed.

Lemma is_Ex_ival_fin {X} f (I: ival X):
  extrema.is_Ex_ival f (fin_coerce I) (Ex_ival f I).
Proof.
  rewrite /extrema.is_Ex_ival/extrema.ex_Ex_ival.
  split.
  * rewrite //=. eexists. apply SeriesF_is_seriesC.
  * rewrite //=. apply Series_correct'.
    ** rewrite SeriesC_SeriesF SeriesF_big_op //=.
    ** eexists; apply SeriesF_is_seriesC.
Qed.

Import Lub Rbar.

Lemma Ex_min_singleton {X} f (I: ivdist X):
  extrema.Ex_min f (singleton I) = Finite (Ex_ival f I).
Proof.
  rewrite fin_singleton_equiv_singleton extrema.Ex_min_singleton.
  * rewrite //=. f_equal. apply extrema.is_Ex_ival_unique.
    apply is_Ex_ival_fin.
  * rewrite //=. eapply extrema.is_Ex_ival_ex. apply is_Ex_ival_fin.
Qed.

Lemma Ex_max_singleton {X} f (I: ivdist X):
  extrema.Ex_max f (singleton I) = Finite (Ex_ival f I).
Proof.
  rewrite fin_singleton_equiv_singleton extrema.Ex_max_singleton.
  * rewrite //=. f_equal. apply extrema.is_Ex_ival_unique.
    apply is_Ex_ival_fin.
  * rewrite //=. eapply extrema.is_Ex_ival_ex. apply is_Ex_ival_fin.
Qed.


Require Import List.
Import ListNotations.

Require Import term.

Fixpoint Vr (v:Type) (t:P v) : list v :=
    match t with
    | Var x         => [x]
    | App t1 t2     => Vr v t1 ++ Vr v t2
    | Lam x t1      => x :: Vr v t1
    end.

Arguments Vr {v} _.


Require Import Reals Psatz Lra RelationClasses List.
From Coquelicot Require Import Continuity
  Rcomplements Derive Hierarchy AutoDerive Rbar Complex
  RInt RInt_analysis Derive_2d Compactness.
From Coq Require Import ssreflect ssrfun ssrbool.
Close Scope boolean_if_scope.
Require Import Program.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Require Import complex_core helpers.

Section UniformOn.

Context {U:Type} {V: UniformSpace}.

Definition uniformly_on (E: U -> Prop) f (P: (U -> V) -> Prop) :=
  exists (del: posreal), forall g,
    (forall x, E x -> (ball (f x) del (g x))) ->
    P g.
Lemma uniformly_on_self: forall E f P,
  uniformly_on E f P -> P f.
Proof.
  move => E f P [del H].
  apply H.
  move =>*.
  apply: ball_center.
Qed.

Lemma filterlim_uniformly_on {T:Type}:
  forall {F} {FF : Filter F} (E: U -> Prop) (f: T -> U -> V) g,
  filterlim f F (uniformly_on E g) <->
  (forall eps : posreal, F (fun t => forall u, E u -> ball (g u) eps (f t u))).
Proof.
intros F FF E f g.
split.
- move=> + eps.
  move => /(_ (fun h => forall u, E u ->  ball (g u) eps (h u))).
  apply.
  now exists eps.
- intros Cf P [eps He].
  apply: filter_imp (Cf eps).
  intros t.
  apply He.
Qed.

Global Instance uniformly_on_filter: forall E f,
  ProperFilter (uniformly_on E f).
Proof.
  move => D f .
  constructor;[| constructor].
  - move => *.
    exists f.
    apply: uniformly_on_self.
    eauto.
  - move => *.
    exists pos_half.
    auto.
  - move => P Q [del1 H1] [del2 H2].
    exists (mkposreal _ (Rmin_stable_in_posreal del1 del2 )).
    move => g gbd.
    split.
    + apply: H1 => x Dx.
      apply: ball_le; last apply gbd; simpl; auto.
      apply: Rmin_l.
    + apply: H2 => x Dx.
      apply: ball_le; last apply gbd; simpl; auto.
      apply: Rmin_r.
  - move => P Q impl [del H].
    exists del => g gbd.
    apply: impl.
    apply H.
    auto.
Qed.

Lemma uniformly_on_subset : forall (E1 E2: U -> Prop) f ,
  (forall z, E1 z -> E2 z) ->
  filter_le (uniformly_on E2 f) (uniformly_on E1 f).
Proof.
  move => E1 E2 f sub P [del H].
  exists del => g gbd.
  apply: H.
  move => x E1x.
  apply gbd.
  apply sub.
  auto.
Qed.

Lemma uniformly_on_ext: forall f g (E: U -> Prop),
  (forall z, E z -> f z = g z) ->
    filter_le (uniformly_on E f) (uniformly_on E g).
Proof.
  move => f g E ext P [del H].
  exists del => h hball.
  apply H => u Eu.
  rewrite -ext; auto.
Qed.

Lemma uniformly_on_filterlim_ext {T:Type}: forall
  (f g: T -> U -> V) (E: U -> Prop) l F {FF: Filter F},
  (forall u z, E z -> f u z = g u z) ->
    filterlim f F (uniformly_on E l) -> filterlim g F (uniformly_on E l).
Proof.
  move => f g E l F FF ext + P [del H].

  move => /(_ (fun h => (forall h', (forall u, E u -> h u = h' u) -> P h'))).
  set p := (uniformly_on _ _ _).
  have: p. {
    rewrite /p.
    exists del.
    move => h I.
    move => h' h'ext.
    apply H.
    move => x Ex.
    rewrite -h'ext; auto.
  }
  move => I /(_ I).
  rewrite /filtermap => {}I.
  apply: filter_imp I.
  move => x.
  apply.
  auto.
Qed.

Lemma filter_locally_le_uniformly : forall (E: U -> Prop) f ,
  filter_le (locally f) (uniformly_on E f).
Proof.
  move => E1 f P [del H].
  exists del => g gbd.
  rewrite /ball /= /fct_ball in gbd.
  apply: H => *.
  apply gbd.
Qed.

Lemma filter_uniformly_global_local : forall f ,
  filter_le (uniformly_on (fun => True) f) (locally f).
Proof.
  move => f P [del H].
  exists del => g gbd.
  apply: H => *.
  rewrite /ball /= /fct_ball.
  move => *.
  apply gbd.
  auto.
Qed.

Lemma uniformly_on_union : forall (E1 E2: U -> Prop) f P Q,
  uniformly_on E1 f P ->
  uniformly_on E2 f Q ->
  uniformly_on (fun q => E1 q \/ E2 q) f (fun g => P g /\ Q g).
Proof.
  move => E1 E2 f P Q [del1 UE1] [del2 UE2].

  exists (mkposreal _ (Rmin_stable_in_posreal del1 del2 )).
  move => g gbd.
  split.
  + apply UE1 => *.
    apply: ball_le; last apply gbd; simpl; auto.
    apply: Rmin_l.
  + apply UE2 => *.
    apply: ball_le; last apply gbd; simpl; auto.
    apply: Rmin_r.
Qed.

Definition uniformly_on_family
  (Fam: ((U -> Prop) -> Prop)) f (P:(U -> V) -> Prop): Prop :=
  exists (l: list ({ (E, P):(_ * _) |
            Fam E /\ (uniformly_on E f P) } )),
    forall g,
      List.Forall (fun z => (snd (proj1_sig z)) g ) l -> P g.

Instance uniformly_on_family_filter: forall (Fam: (U -> Prop) -> Prop) f,
  (exists E, Fam E) ->
  ProperFilter (uniformly_on_family Fam f).
Proof.
  move => Fam f [E0 FamE0].
  constructor;[|constructor].
  - move => P //= [l H] .
    exists f.
    apply H.
    apply/ Forall_forall.
    case => [[??][??]] *.
    apply: uniformly_on_self.
    eauto.
  - have H: Fam E0 /\ (uniformly_on E0 f (fun => True)) by
      split; [apply FamE0| apply filter_true ].
    exists [exist _ (E0,(fun => True)) H] .
    auto.
  - move => P Q [lP Hp] [lQ Hq].
    exists (lP ++ lQ).
    move => g /Forall_forall Hg.
    split.
    + apply Hp.
      apply/Forall_forall => x xIn.
      apply Hg.
      apply in_or_app.
      auto.
    + apply Hq.
      apply/Forall_forall => x xIn.
      apply Hg.
      apply in_or_app.
      auto.
  - move => P Q impl [l H].
    exists l.
    move => *.
    apply impl.
    auto.
Qed.

Lemma family_le_on_one : forall E f (Fam:(U -> Prop) -> Prop), Fam E ->
  filter_le (uniformly_on_family Fam f) (uniformly_on E f).
Proof.
  move => E f Fam FamE P H.
  have H': Fam E /\ uniformly_on E f P by split; auto.
  exists [exist _ (E,P) H'].
  move => g /Forall_forall.
  move => /(_ (exist _ (E,P) H')).
  apply.
  constructor.
  auto.
Qed.

Lemma filterlim_on_family {T: Type}:
  forall (Fam: (U -> Prop) -> Prop) (f_: T -> U -> V) flim F {FF: Filter F},
  (forall (E: U -> Prop), Fam E -> filterlim (f_) F (uniformly_on E flim)) <->
  filterlim (f_) F (uniformly_on_family Fam flim) .
Proof.
  move => Fam f_ flim F FF.
  split.
  {
    move => all P [l+].
    move: l P.
    elim.
    - move => ? H.
      apply: filter_imp; last by apply filter_true.
      move => *.
      apply H.
      apply Forall_nil.
    - move => a l IH P H.
      have {}H: forall g : U -> V,
            ((`a).2 g) /\ (List.Forall (fun z => (` z).2 g) l) ->
            P g by
         move => *; apply H; apply Forall_cons; tauto.
      apply (filter_imp _ P H).
      apply filter_and.
      + clear H. move: a => [[??][??]].
        apply: all; eauto.
      + apply IH; auto.
  }
  {
    move => H E FamE.
    apply: filterlim_filter_le_2; last by apply H.
    apply family_le_on_one.
    auto.
  }
Qed.

Definition fam_union (Fam :(U -> Prop ) -> Prop) (P: U -> Prop): Prop :=
  exists l, List.Forall Fam l /\
  (forall u, P u <-> List.Exists (fun E => E u) l).

Lemma fam_union_aux: forall (Fam :(U -> Prop ) -> Prop) f r E Q ,
  (exists E , Fam E) ->
  uniformly_on E f Q ->
  List.Forall Fam r /\ (forall u : U, E u <-> Exists (@^~ u) r) ->
  uniformly_on_family Fam f Q.
Proof.
  move => Fam  f +++ [E0 FamE0].
  have?:Filter (uniformly_on_family (Fam) f). {
    apply uniformly_on_family_filter.
    exists E0.
    auto.
  }
  elim. {
    move => E  Q unifQ [_  H'].
    case: unifQ => [? R].
    apply: (filter_imp _ _ R).
    apply: (filter_imp (fun=> True)_ ); last by apply filter_true.
    move => x _ y .
    rewrite H' Exists_nil; tauto.
  }
  move => E l IH E' Q [del H] [fams Eunion].
  have Hunion:forall g : U -> V,
    ((forall x : U, E x -> ball (f x) del (g x)) /\
     (forall x : U, (Exists (@^~x) l) -> ball (f x) del (g x))) ->
     Q g. {
       move => g [HE HE'].
       apply H => x.
       rewrite Eunion.
       rewrite Exists_cons.
       case => ?; auto.
  }
  apply: (filter_imp _ _ Hunion).
  inversion fams.
  subst.
  apply: filter_and.
  - apply: family_le_on_one.
    apply H2.
    exists del => *; auto.
  - apply (IH (fun u => Exists (@^~ u) l)).
    + exists del => *; auto.
    + repeat split; auto.
Qed.
Lemma fam_union_singleton: forall (Fam :(U -> Prop ) -> Prop) E,
  Fam E -> fam_union Fam E.
Proof.
  move => Fam E FamE.
  exists [E].
  split; auto.
  move => *; split; auto.
  rewrite Exists_cons Exists_nil.
  move => [|]; tauto.
Qed.

Lemma fam_union_equiv:
  forall (Fam: (U -> Prop) -> Prop) (f: U -> V) P,
  (exists E , Fam E) ->
  uniformly_on_family Fam f P <->
  uniformly_on_family (fam_union Fam) f P .
Proof.
  move => Fam  f P [E0 FamE0].
  have?:Filter (uniformly_on_family (fam_union Fam) f). {
    apply uniformly_on_family_filter.
    exists E0.
    by apply fam_union_singleton.
  }
  have?:Filter (uniformly_on_family (Fam) f). {
    apply uniformly_on_family_filter.
    exists E0.
    auto.
  }
  split. {
    case => l +.
    move:P.
    elim: l; first
      by (move => *; exists []; auto).
    move => a l IH P H.
    have {}H: forall g : U -> V,
          ((`a).2 g) /\ (List.Forall (fun z => (` z).2 g) l) ->
          P g by
       move => *; apply H; apply Forall_cons; tauto.
    apply: (filter_imp _ _ H).
    apply: filter_and; last by apply IH.
    move: a H => [[E Q][FamE unifQ]] H.
    simpl in *.
    have Hf: fam_union Fam E /\ uniformly_on E f Q by
      split; [apply fam_union_singleton| ].

    exists [exist _ ( E , Q ) Hf].
    move => g /Forall_forall.
    move => /(_ (exist _ (E,Q) Hf)).
    apply.
    constructor.
    auto.
  }
  {
    move => [l +].
    move: P.
    elim:l; first by
      move => *; exists []; auto.
    move => a l IH P H.
    have {}H: forall g : U -> V,
          ((`a).2 g) /\ (List.Forall (fun z => (` z).2 g) l) ->
          P g by
       move => *; apply H; apply Forall_cons; tauto.
    apply: (filter_imp _ _ H).
    apply: filter_and; last by apply IH.
    move: a H => [[E Q][[r Famr] unifQ]] H.
    simpl in *.
    apply: fam_union_aux.
    exists E0; auto.
    apply unifQ.
    apply Famr.
  }

Qed.

Lemma filterlim_compose_aux {T: Type} {T': Type}:
  forall (Fam: (U -> Prop) -> Prop) (f_: T -> U -> V) flim F {FF: Filter F} (g: T' -> U),
  filterlim (f_) F (uniformly_on_family Fam flim) ->
  (exists E, Fam E /\ (forall t':T', E (g t'))) ->
  filterlim (fun t u => f_ t (g u)) F (@locally (fct_UniformSpace T' V) (fun u => flim (g u))) .
Proof.
  move => Fam f_ flim F FF g + [E [Efam gcover]] P loc.
  move => /(_ (fun h => P(fun t => h (g t) ))).
  apply.
  set P' := fun h => P (fun t => h (g t)).
  have Ef: uniformly_on E flim P'. {
    move: loc => [del H].
    exists del.
    move => h hball.
    apply H.
    rewrite /ball /= /fct_ball in hball .
    rewrite /ball /= /fct_ball => t.
    apply hball.
    apply gcover.
  }
  apply: family_le_on_one; eauto.
Qed.

Lemma filterlim_compose_fam {T T': Type}:
  forall (Fam: (U -> Prop) -> Prop) (f_: T -> U -> V) flim F {FF: Filter F} (g: T' -> U),
  (exists E , Fam E) ->
  filterlim (f_) F (uniformly_on_family Fam flim) ->
  (exists E, fam_union Fam E /\ (forall t':T', E (g t'))) ->
  filterlim (fun t u => f_ t (g u)) F (@locally (fct_UniformSpace T' V) (fun u => flim (g u))) .
Proof.
  move => Fam *.
  apply (@filterlim_compose_aux _ _ (fam_union Fam)); auto.
  apply: filterlim_filter_le_2; last by eauto.
  move => P.
  apply fam_union_equiv.
  auto.
Qed.

End UniformOn.

Open Scope C.

Lemma uniformly_bounded_mult {T:Type} {U:UniformSpace}:
  forall F {FF: Filter F} (E: U -> Prop) (f: T -> U -> C) (g: U -> C) flim,
  (exists (M:posreal), forall z, E z -> norm(g z) < M  ) ->
  filterlim (fun u z=> f u z ) F (uniformly_on E flim) ->
  filterlim (fun u z=> f u z * g z ) F
    (uniformly_on E (fun z => flim z * g z)).
Proof.
  move => F FF E f g flim [M bd] /filterlim_uniformly_on H.
  have?:= cond_pos M.
  apply/ filterlim_uniformly_on => eps.
  have?:= cond_pos eps.
  have delpos : 0 < eps/(2*M) by apply Rdiv_lt_0_compat;  lra.
  pose del := mkposreal _ delpos.
  move:H => /(_ (del )) H.
  apply: filter_imp H.
  move => t.
  unfold_alg.
  rewrite /fct_ball /= .
  move => H.
  move => z.
  move: H => /(_ z).
  rewrite /ball /= /prod_ball => + Ez.
  move => /(_ Ez) => H.

  case: H => [+ +].
  unfold_alg.
  rewrite -?/(Rminus _ _).
  Open Scope R.
  have bd1 : Rabs((g z).1) < M. {
    move: bd=> /(_ z).
    unfold_alg => bd.
    apply: Rle_lt_trans.
    2: apply bd.
    case e: (g z).
    apply Cmod_Rabs_real.
    auto.
  }
  have bd2 : Rabs((g z).2) < M. {
    move: bd=> /(_ z).
    unfold_alg => bd.
    apply: Rle_lt_trans.
    2: apply bd.
    case e: (g z).
    apply Cmod_Rabs_imaginary.
    auto.
  }
  move => H1 H2.
  replace (pos eps) with ((eps/(2*M)) *M + (eps/(2*M)) * M )%R;
    last field_simplify_eq; auto.
  2: apply Rlt_0_neq_0; lra.
  unfold_ball; unfold_alg.
  split.
  - set p := ( x in Rabs x).
    replace p with (((f t z).1 - (flim z).1) * (g z).1 -
                    ((f t z).2 - (flim z).2) * (g z).2).
    2: rewrite /p; field_simplify_eq;
       rewrite [(flim z).2*_]Rmult_comm;
       apply Rplus_eq_compat_r;
       rewrite [(flim z).1*_]Rmult_comm;
       auto.
    apply: Rle_lt_trans; first by apply Rabs_triang.
    rewrite Rabs_Ropp ?Rabs_mult;
    apply Rplus_lt_compat;
    apply Rmult_le_0_lt_compat; auto;
      try apply Rabs_pos.
  - set p := ( x in Rabs x).
    replace p with (((f t z).1 - (flim z).1) * (g z).2 +
                    ((f t z).2 - (flim z).2) * (g z).1).
    2: rewrite /p; field_simplify_eq;
       rewrite [(flim z).2*_]Rmult_comm;
       apply Rplus_eq_compat_r;
       rewrite [(flim z).1*_]Rmult_comm;
       auto.
    apply: Rle_lt_trans; first by apply Rabs_triang.
    rewrite ?Rabs_mult;
    apply Rplus_lt_compat;
    apply Rmult_le_0_lt_compat; auto;
      try apply Rabs_pos.
Qed.

Definition square_in (D: C -> Prop) (P:C -> Prop) : Prop :=
  (forall z, P z -> D z) /\
  (exists a (del: posreal),
    (forall z, P z <-> a.1-del <= z.1 <= a.1+del /\ a.2-del<= z.2 <= a.2+del)).

Definition compactly D (f: C -> C) := uniformly_on_family (square_in D) f.

Lemma compactly_non_trivial: forall D, open D ->
  (exists z0, D z0) ->
  exists E, square_in D E.
Proof.
  move => D openD [z0 Dz0].
  have := openD z0 Dz0.
  move => [del H].
  have?:= cond_pos del.
  pose P := fun z => z0.1 - del/2 <= z.1 <= z0.1 + del/2 /\
                     z0.2 - del/2 <= z.2 <= z0.2 + del/2.
  exists P.
  split.
  - move => z [/Rabs_le_between' ? /Rabs_le_between' ?].
    apply H.
    unfold_alg.
    rewrite -?/(Rminus _ _).
    split; apply: Rle_lt_trans; eauto; lra.
  - exists z0; exists (pos_div_2 del).
    move => z.
    rewrite /P.
    simpl.
    tauto.
Qed.

Instance compactly_filter: forall (D: C -> Prop) f,
  open D ->
  (exists z0, D z0) ->
  ProperFilter (compactly D f).
Proof.
  move => D f op ex.
  apply uniformly_on_family_filter.
  apply compactly_non_trivial;
  auto.
Qed.

Lemma not_not_impl : forall (P Q:Prop), (P -> Q) -> (~ ~ P -> ~ ~ Q).
move => P Q.
tauto.
Qed.

Lemma path_in_circles: forall (g: R -> C) D a b,
  open D ->
  a < b ->
  (forall z, D z \/ ~D z) ->
  (forall t, a <= t <= b -> D (g t)) ->
  (forall t, a <= t <= b -> continuous g t) ->
  (~ ~ exists l,
   (List.Forall (square_in D) l ) /\
   (forall t, a <= t <= b -> List.Exists (fun E => E (g t)) l)).
Proof.
  move => g D a b openD aleb decD inD cts.

  have inlocD: forall t, ~t < a -> ~ b < t -> locally (g t) D by
    ( move => *; apply openD; apply inD; lra).

  have eps: forall t,
     {d: posreal | a <= t <= b -> forall y, ball (g t) d y -> D y }. {
      move => t.
      have := locally_ex_dec (g t) D decD.
      destruct (Rlt_dec t a); first by
        move => _; exists pos_half; lra.
      destruct (Rlt_dec b t); first by
        move => _; exists pos_half; lra.
      case;first by (apply openD; apply inD; lra).
      move => del H.
      exists del.
      move => *.
      by apply H.
  }

  have: {delta: R -> posreal | forall t, a <= t <= b ->
      (forall t', a <= t' <= b -> ball t (delta t) t' ->
         ball_norm (g t) (pos_div_2 (` (eps t))) (g t')) /\
      (forall z, ball (g t) (` (eps t)) z -> D z)
  }. {

    pose delta := (unifcont_normed_1d g a b cts (pos_div_2 (` (eps _)))).

    exists (fun t => (proj1_sig (delta t))).
    move => t tbd.
    split.
    - move => t' t'bd H.
      apply (proj2_sig (delta t)); auto.
    - move => z zball.
      apply (proj2_sig (eps t)); auto.
  }
  case => delta H.
  have := compactness_list 1 (a, tt) (b, tt) (fun t => delta (fst t)).
  apply not_not_impl.
  case.
  move => l H'.

  pose del_sqr := fun t z =>
    let eps' := pos_div_2 (proj1_sig (eps t)) in
    (g t).1 - eps' <= z.1 <= (g t).1 + eps' /\
    (g t).2 - eps' <= z.2 <= (g t).2 + eps'.
  exists (map (compose del_sqr fst)
         (filter (fun l => Rle_dec a l.1 && Rle_dec l.1 b)l)).
  split. {
    apply/Forall_forall => P.
    move => /in_map_iff [t0 [<- /filter_In [int0
      /andP [/RleP ? /RleP ?]]]].
    rewrite/compose //=.
    split.
    - move => z [/Rabs_le_between' P1 /Rabs_le_between' P2].
      move: H => /(_ t0.1 (ltac:(lra))) H.
      apply H.
      split.
      + apply: Rle_lt_trans; first by apply P1.
        simpl.
        rewrite Rlt_div_l; try lra.
        rewrite -[x in x < _]Rmult_1_r.
        apply Rmult_lt_compat_l; try lra.
        apply cond_pos.
      + apply: Rle_lt_trans; first by apply P2.
        simpl.
        rewrite Rlt_div_l; try lra.
        rewrite -[x in x < _]Rmult_1_r.
        apply Rmult_lt_compat_l; try lra.
        apply cond_pos.
    - do 2 eexists.
      move => z.
      rewrite /del_sqr.
      reflexivity.
  }

  move => x xbd.
  apply/ Exists_exists.
  move: H' => /(_ (x,tt)).
  case; first by simpl.
  move => t0 [t0In [t0bd t0close]].
   destruct t0. simpl in *.
  exists (del_sqr r).
  split.
  - apply/ in_map_iff.
    exists (r,t).
    split; first by simpl.
    apply/ filter_In.
    split; first by tauto.
    apply /andP. split; apply/RleP; simpl; apply t0bd.
  - rewrite /del_sqr -?Rabs_le_between'.
    have: (Rmax (Rabs (g x - g r)%C.1) (Rabs (g x - g r)%C.2) <= ` (eps r) /2).
    2: {
      move => Hmax.
      split.
      + apply: Rle_trans; last apply Hmax.
        apply Rmax_l.
      + apply: Rle_trans; last apply Hmax.
        apply Rmax_r.
    }
    apply: Rle_trans; first by apply Rmax_Cmod.
  move: H => /(_ r (ltac:(lra))) [/(_ x xbd) H _].
  left.
  apply H.
  apply t0close.
Qed.


Require Import msl.msl_standard.
Require Import msl.Coqlib2.

Set Implicit Arguments.

Lemma share_lemma87:
  forall a b, Share.glb a b = Share.bot -> Share.glb (Share.comp a) b = b.
Proof.
intros.
rewrite <- (Share.glb_top b) at 2.
rewrite (Share.glb_commute b).
rewrite <- (Share.comp1 a).
rewrite (Share.glb_commute (Share.lub _ _)).
rewrite Share.distrib1.
rewrite (Share.glb_commute b).
rewrite H.
rewrite (Share.lub_commute Share.bot), Share.lub_bot.
apply Share.glb_commute.
Qed.

Lemma join_top_comp:
  forall a b, join a b Share.top -> Share.comp a = b.
Proof.
intros.
destruct H.
pose proof (share_lemma87 H).
rewrite <- H1.
rewrite Share.glb_commute.
symmetry.
rewrite <- (Share.comp_inv b).
apply share_lemma87.
rewrite <- Share.demorgan1.
rewrite Share.lub_commute, H0.
clear.
pose proof (Share.comp1 Share.bot).
rewrite Share.lub_commute, Share.lub_bot in H.
rewrite <- H.
rewrite Share.comp_inv.
auto.
Qed.

Lemma comp_bot: Share.comp Share.bot = Share.top.
Proof.
apply join_top_comp.
apply bot_join_eq.
Qed.

Lemma share_distrib1':
      forall w x y z : Share.t,
       Share.glb (Share.lub w x) (Share.lub y z) =
       Share.lub (Share.lub (Share.glb w y)  (Share.glb x y))
                     (Share.lub (Share.glb w z) (Share.glb x z)).
Proof.
intros.
rewrite Share.distrib1.
rewrite <- (Share.glb_commute y), <- (Share.glb_commute z).
rewrite !Share.distrib1.
f_equal; f_equal; apply Share.glb_commute.
Qed.

Lemma share_distrib2':
   forall w x y z : Share.t,
       Share.lub (Share.glb w x) (Share.glb y z) =
       Share.glb (Share.glb (Share.lub w y) (Share.lub x y))
                      (Share.glb (Share.lub w z) (Share.lub x z)).
Proof.
intros.
rewrite Share.distrib2.
rewrite <- (Share.lub_commute y), <- (Share.lub_commute z).
rewrite !Share.distrib2.
f_equal; f_equal; apply Share.lub_commute.
Qed.

Lemma lub_bot_e:
  forall x y, Share.lub x y = Share.bot -> x = Share.bot /\ y = Share.bot.
Proof.
intros.
pose proof (Share.lub_upper1 x y).
pose proof (Share.lub_upper2 x y).
rewrite H in H0,H1.
split; apply Share.ord_antisym; auto; apply Share.bot_correct.
Qed.

Lemma glb_less_both:
  forall a L b R,
   Share.Ord a L -> Share.Ord b R ->
   Share.Ord (Share.glb a b) (Share.glb L R).
Proof.
 intros.
 generalize (Share.glb_lower1 a b);intro.
 generalize (Share.glb_lower2 a b);intro.
 generalize (Share.ord_trans _ _ _ H1 H);intro.
 generalize (Share.ord_trans _ _ _ H2 H0);intro.
 eapply Share.glb_greatest;auto.
Qed.

Lemma comp_Lsh_Rsh:
  Share.comp Share.Lsh = Share.Rsh.
Proof.
 unfold Share.Lsh, Share.Rsh.
 destruct (Share.split Share.top) eqn:?H; simpl.
 apply split_join in H.
 apply join_top_comp; auto.
Qed.

Lemma share_lemma88:
   forall sh, Share.glb sh Share.Rsh = Share.bot ->
                 join_sub sh Share.Lsh.
Proof.
 intros.
 exists (Share.glb (Share.comp sh) Share.Lsh).
 rewrite <- (Share.comp_inv Share.Lsh) at 1.
 rewrite comp_Lsh_Rsh.
 split.
*
 rewrite <- Share.glb_assoc.
 rewrite Share.comp2. rewrite Share.glb_commute. apply Share.glb_bot.
*
 rewrite <- Share.demorgan1.
 rewrite <- Share.comp_inv; symmetry; rewrite <- Share.comp_inv; symmetry.
 f_equal.
 rewrite comp_Lsh_Rsh.
 rewrite <- (Share.comp_inv sh) at 1.
 rewrite <- Share.demorgan2.
 rewrite Share.comp_inv.
 rewrite Share.distrib1.
 rewrite Share.glb_commute.
 rewrite Share.comp2.
 rewrite Share.lub_commute,  Share.lub_bot.
 forget Share.Rsh as b.
 apply share_lemma87; auto.
Qed.

Definition Tsh : share := Share.top.

Definition nonempty_share (sh: share) :=
       sepalg.nonidentity sh.
Definition readable_share (sh: share) :=
       nonempty_share (Share.glb Share.Rsh sh).
Definition writable_share (sh: share) :=
    join_sub Share.Rsh sh.

Lemma lub_Lsh_Rsh:
 Share.lub Share.Lsh Share.Rsh = Share.top.
Proof.
unfold Share.Lsh, Share.Rsh.
destruct (Share.split Share.top) eqn:H; simpl.
apply Share.split_together; auto.
Qed.

Lemma glb_Lsh_Rsh:
 Share.glb Share.Lsh Share.Rsh = Share.bot.
Proof.
unfold Share.Lsh, Share.Rsh.
destruct (Share.split Share.top) eqn:H; simpl.
apply (Share.split_disjoint _ _ _ H).
Qed.

Lemma readable_share_dec:
  forall sh, {readable_share sh}+{~ readable_share sh}.
Proof.
intros.
unfold readable_share, nonempty_share.
unfold nonidentity.
destruct (dec_share_identity (Share.glb Share.Rsh sh)); [ right | left]; auto.
Defined.

Lemma writable_share_dec: forall sh, {writable_share sh} + {~ writable_share sh}.
Proof.
  unfold writable_share. intros.
  destruct (Share.EqDec_share (Share.glb Share.Rsh sh) Share.Rsh); [left|right].
*
  exists (Share.glb Share.Lsh sh).
  split.
  -
  rewrite <- Share.glb_assoc.
  rewrite (Share.glb_commute Share.Rsh).
  unfold Share.Rsh, Share.Lsh.
  destruct (Share.split Share.top) eqn:?. simpl.
  apply Share.split_disjoint in Heqp. rewrite Heqp.
  rewrite Share.glb_commute, Share.glb_bot. auto.
  -
  apply Share.distrib_spec with Share.Rsh.
  rewrite <- Share.lub_assoc. rewrite Share.lub_idem.
  rewrite Share.distrib2.
  rewrite Share.lub_commute.
  destruct (Share.split Share.top) eqn:?.
  unfold Share.Lsh, Share.Rsh at 1.
  rewrite Heqp. simpl.
  rewrite (Share.split_together _ _ _ Heqp).
  rewrite Share.glb_commute, Share.glb_top. auto.
  rewrite Share.glb_absorb. rewrite e. auto.
*
  contradict n.
  destruct n as [a [? ?]].
  subst sh.
  rewrite Share.glb_absorb. auto.
Qed.

Lemma writable_readable:
 forall sh, writable_share sh -> readable_share sh.
Proof.
unfold writable_share, readable_share.
intros.
intro.
destruct H as [a ?].
destruct H.
subst sh.
rewrite Share.glb_absorb in H0.
clear - H0. unfold Share.Rsh in H0.
destruct (Share.split Share.top) eqn:?. simpl in H0.
apply split_nontrivial' in Heqp; auto.
apply top_share_nonidentity in Heqp. auto.
Qed.

Lemma readable_share_top:
  readable_share Share.top.
Proof.
hnf. intros.
rewrite Share.glb_top in H.
unfold Share.Rsh in H.
destruct (Share.split Share.top) eqn:?.
apply split_nontrivial' in Heqp.
apply identity_share_bot in Heqp.
apply Share.nontrivial; auto.
simpl in H; auto.
Qed.
Hint Resolve writable_readable.

Lemma top_pfullshare: forall psh, pshare_sh psh = Share.top -> psh = pfullshare.
Proof.
intros psh H.
apply lifted_eq; auto.
Qed.

Lemma fst_split_fullshare_not_bot: fst (Share.split fullshare) <> Share.bot.
Proof.
intro.
case_eq (Share.split fullshare); intros.
rewrite H0 in H. simpl in H. subst.
apply Share.split_nontrivial in H0; auto.
apply Share.nontrivial in H0. contradiction.
Qed.

Lemma fst_split_fullshare_not_top: fst (Share.split fullshare) <> Share.top.
Proof.
case_eq (Share.split fullshare); intros.
simpl; intro. subst.
apply nonemp_split_neq1 in H.
apply H; auto.
apply top_share_nonidentity.
Qed.

Lemma glb_Rsh_not_top:
   forall sh, Share.glb Share.Rsh sh <> Share.top.
Proof.
 intros.
 intro.
 unfold Share.Rsh in H.
 destruct (Share.split Share.top) eqn:?H.
  pose proof (Share.split_disjoint _ _ _ H0).
 simpl in H.
  pose proof (Share.glb_lower1 t0 sh).
  rewrite H in H2.
  apply leq_join_sub in H2.
  destruct H2. destruct H2.
  rewrite Share.lub_commute, Share.lub_top in H3.
  subst.
  clear - H0.
  apply nonemp_split_neq2 in H0; auto.
  intro. apply identity_share_bot in H.
  contradiction Share.nontrivial.
Qed.
Arguments glb_Rsh_not_top sh _ : clear implicits.

Lemma writable_share_top: writable_share Tsh.
Proof.
red.
exists Share.Lsh.
apply join_comm.
unfold Share.Lsh, Share.Rsh, Tsh.
destruct (Share.split Share.top) eqn:?. simpl.
apply split_join; auto.
Qed.
Hint Resolve writable_share_top.

Lemma writable_readable_share:
 forall sh, writable_share sh -> readable_share sh.
Proof.
apply writable_readable; auto.
Qed.
Hint Resolve writable_readable_share.

Definition extern_retainer := fst (Share.split Share.Lsh).

Definition Ews (* extern_write_share *) :=
  Share.lub extern_retainer Share.Rsh.

Lemma writable_Ews: writable_share Ews.
Proof.
unfold writable_share, Ews.
apply leq_join_sub.
apply Share.lub_upper2.
Qed.

Lemma writable_Rsh: writable_share Share.Rsh.
Proof.
  unfold writable_share.
  apply join_sub_refl.
Qed.

Hint Resolve writable_Ews.

Definition Ers (* Extern read share *) :=
  Share.lub extern_retainer (fst (Share.split Share.Rsh)).

Lemma readable_nonidentity: forall sh, readable_share sh -> sepalg.nonidentity sh.
Proof.
intros.
do 2 red in H.
red in H|-*. contradict H.
apply identity_share_bot in H. subst.
rewrite Share.glb_bot.
apply bot_identity.
Qed.

Hint Resolve readable_nonidentity.

Lemma sub_glb_bot:
  forall r a c : share,
   sepalg.join_sub a c ->
   Share.glb r c = Share.bot ->
   Share.glb r a = Share.bot.
Proof.
intros.
apply leq_join_sub in H.
apply Share.ord_spec1 in H.
rewrite H. rewrite <- Share.glb_assoc.
rewrite (Share.glb_commute r).
rewrite Share.glb_assoc. rewrite H0.
apply Share.glb_bot.
Qed.

Lemma glb_split: forall sh,
 Share.glb (fst (Share.split sh)) (snd (Share.split sh)) = Share.bot.
Proof.
intros.
destruct (Share.split sh) eqn:?H.
simpl.
apply split_join in H.
destruct H.
auto.
Qed.

Lemma Lsh_nonidentity:   sepalg.nonidentity Share.Lsh.
Proof.
unfold Share.Lsh.
destruct (Share.split Share.top) eqn:?. simpl; intro.
apply identity_share_bot in H. subst.
pose proof (Share.split_nontrivial _ _ _ Heqp).
spec H;[auto | ].
apply Share.nontrivial in H. auto.
Qed.

Lemma Rsh_nonidentity:   sepalg.nonidentity Share.Rsh.
Proof.
unfold Share.Rsh.
destruct (Share.split Share.top) eqn:?. simpl; intro.
apply identity_share_bot in H. subst.
pose proof (Share.split_nontrivial _ _ _ Heqp).
spec H;[auto | ].
apply Share.nontrivial in H. auto.
Qed.

Lemma nonidentity_extern_retainer: ~identity extern_retainer.
Proof.
unfold extern_retainer.
intro.
destruct (Share.split Share.Lsh) eqn:?H.
simpl in H.
apply split_nontrivial' in H0; auto.
apply Lsh_nonidentity.
auto.
Qed.

Lemma glb_split_x:
  forall a, Share.glb a (fst (Share.split a)) = fst (Share.split a).
Proof.
intros.
destruct (Share.split a) eqn:H; simpl in *.
destruct (split_join _ _ _ H).
subst a.
rewrite Share.glb_commute, Share.distrib1.
rewrite H0.
rewrite Share.glb_idem.
rewrite Share.lub_bot.
auto.
Qed.

Lemma readable_Ers: readable_share Ers.
Proof.
hnf; intros.
unfold Ers in H.
unfold extern_retainer in H.
rewrite Share.distrib1 in H.
apply identity_share_bot in H.
match type of H with Share.lub ?A _ = _ => forget A as a end.
rewrite glb_split_x in H.
pose proof (Share.lub_upper2 a (fst (Share.split Share.Rsh))).
rewrite H in H0.
apply leq_join_sub in H0.
destruct H0.
apply split_identity in H0; auto.
clear - H0.
destruct (Share.split Share.Rsh) eqn:?. simpl in *.
apply identity_share_bot in H0. subst.
pose proof (Share.split_nontrivial _ _ _ Heqp).
spec H;[auto | ].
assert (identity Share.Rsh) by (rewrite H; auto).
contradiction Rsh_nonidentity.
Qed.

Lemma join_sub_readable:
  forall sh sh', sepalg.join_sub sh sh' -> readable_share sh -> readable_share sh'.
Proof.
unfold readable_share;
intros.
hnf in H0|-*.
contradict H0.
apply identity_share_bot in H0.
eapply sub_glb_bot in H0; eauto.
rewrite H0.
apply bot_identity.
Qed.

Lemma join_unreadable_shares:
 forall sh1 sh2 sh,
  sepalg.join sh1 sh2 sh ->
  ~ readable_share sh1 ->
  ~ readable_share sh2 ->
 ~ readable_share sh.
Proof.
unfold readable_share; intros.
unfold nonempty_share in *.
unfold sepalg.nonidentity in *.
contradict H0. contradict H1. contradict H0.
destruct H.
subst sh.
apply identity_share_bot in H1.
apply identity_share_bot in H0.
rewrite Share.distrib1, H0,H1.
rewrite Share.lub_bot.
apply bot_identity.
Qed.

Lemma readable_share_join_left:
  forall sh1 sh2 sh,
    sepalg.join sh1 sh2 sh ->
    readable_share sh1 -> readable_share sh.
Proof.
intros.
unfold readable_share, nonempty_share, nonidentity in *.
contradict H0.
destruct H.
subst sh.
rewrite Share.distrib1 in H0.
pose proof (Share.lub_upper1 (Share.glb Share.Rsh sh1) (Share.glb Share.Rsh sh2)).
apply identity_share_bot in H0. rewrite H0 in H1.
pose proof Share.bot_correct (Share.glb Share.Rsh sh1).
pose proof (Share.ord_antisym _ _ H1 H2).
rewrite H3.
apply bot_identity.
Qed.

Lemma readable_share_join:
  forall sh1 sh2 sh,
    sepalg.join sh1 sh2 sh ->
    readable_share sh1 \/ readable_share sh2 -> readable_share sh.
Proof.
  intros.
  destruct H0.
  + eapply readable_share_join_left; eauto.
  + apply join_comm in H.
    eapply readable_share_join_left; eauto.
Qed.

Lemma Lsh_bot_neq: Share.Lsh <> Share.bot.
Proof.
  pose proof Lsh_nonidentity.
  pose proof bot_identity.
  intro.
  rewrite <- H1 in H0.
  apply H; auto.
Qed.

Lemma not_nonunit_bot: forall sh, ~ nonunit sh <-> sh = Share.bot.
Proof.
  intros; split; intros.
  + destruct (dec_share_identity sh).
    - apply identity_share_bot; auto.
    - exfalso; apply H.
      apply nonidentity_nonunit.
      auto.
  + subst.
    intro.
    apply nonunit_nonidentity in H.
    apply H.
    apply bot_identity.
Qed.

Lemma join_readable1:
  forall sh1 sh2 sh3,
    join sh1 sh2 sh3 ->
    readable_share sh1 -> readable_share sh3.
Proof.
intros.
eapply readable_share_join; eauto.
Qed.

Lemma join_readable2:
  forall sh1 sh2 sh3,
    join sh1 sh2 sh3 ->
    readable_share sh2 -> readable_share sh3.
Proof.
intros.
eapply readable_share_join; eauto.
Qed.

Lemma bot_unreadable: ~readable_share Share.bot.
Proof.
intro.
unfold readable_share, nonempty_share, nonidentity in H.
apply H; clear H.
rewrite Share.glb_bot. apply bot_identity.
Qed.

Definition pure_readable_share (sh: Share.t) :=
  Share.glb Share.Lsh sh = Share.bot /\ readable_share sh.

Definition rshare := sig pure_readable_share.

Definition readable_part: forall (sh: Share.t) (rsh: readable_share sh), rshare.
intros.
exists (Share.glb Share.Rsh sh).
split.
rewrite <- Share.glb_assoc. rewrite glb_Lsh_Rsh.
rewrite Share.glb_commute. apply Share.glb_bot.
unfold readable_share.
rewrite <- Share.glb_assoc.
rewrite Share.glb_idem.
apply rsh.
Defined.

Lemma readable_not_identity: forall sh P,
  readable_share sh -> identity sh -> P.
Proof.
 intros.
 unfold readable_share in H.
 unfold nonempty_share, nonidentity in H. contradiction H.
 apply identity_share_bot in H0; subst.
 rewrite Share.glb_bot. apply bot_identity.
Qed.
Arguments readable_not_identity sh P _ _ : clear implicits.

Lemma comp_parts:
  forall L R : Share.t,
  Share.comp L = R ->
  forall sh: Share.t, sh = Share.lub (Share.glb L sh) (Share.glb R sh).
Proof.
intros.
subst R.
rewrite <- !(Share.glb_commute sh).
rewrite <- Share.distrib1.
rewrite Share.comp1.
rewrite Share.glb_top. auto.
Qed.

Lemma join_comp_parts:
  forall L R : Share.t,
  Share.comp L = R ->
  forall a b c : Share.t,
  join a b c ->
  (join (Share.glb L a) (Share.glb L b) (Share.glb L c) /\
   join (Share.glb R a) (Share.glb R b) (Share.glb R c)).
Proof.
intros.
split; split.
*
rewrite (comp_parts H a) in H0.
rewrite (comp_parts H b) in H0.
rewrite (comp_parts H c) in H0.
destruct H0 as [H0 _].
pose proof (@glb_less_both
             (Share.glb L a) (Share.lub (Share.glb L a) (Share.glb R a))
             (Share.glb L b) (Share.lub (Share.glb L b) (Share.glb R b))).
apply Share.ord_antisym; [ | apply Share.bot_correct].
eapply Share.ord_trans; try apply H1; try apply Share.lub_upper1.
rewrite H0. apply Share.ord_refl.
*
destruct H0 as [_ H0].
subst c.
rewrite <- Share.distrib1. auto.
*
rewrite (comp_parts H a) in H0.
rewrite (comp_parts H b) in H0.
rewrite (comp_parts H c) in H0.
destruct H0 as [H0 _].
pose proof (@glb_less_both
             (Share.glb R a) (Share.lub (Share.glb L a) (Share.glb R a))
             (Share.glb R b) (Share.lub (Share.glb L b) (Share.glb R b))).
apply Share.ord_antisym; [ | apply Share.bot_correct].
eapply Share.ord_trans; try apply H1; try apply Share.lub_upper2.
rewrite H0. apply Share.ord_refl.
*
destruct H0 as [_ H0].
subst c.
rewrite <- Share.distrib1. auto.
Qed.

Lemma join_pure_readable:
  forall sh1 sh2 sh3,
    join sh1 sh2 sh3 ->
    pure_readable_share sh1 ->
    pure_readable_share sh2 ->
    pure_readable_share sh3.
Proof.
intros.
destruct H0,H1.
split.
destruct (join_comp_parts comp_Lsh_Rsh H).
rewrite H0,H1 in *. apply join_unit1_e in H4; auto.
eapply readable_share_join; eauto.
Qed.

Instance Join_rshare: Join rshare :=
  fun a b c => join (proj1_sig a) (proj1_sig b) (proj1_sig c).

Instance Perm_rshare: Perm_alg rshare. (* move me! *)
Proof.
  unfold rshare.
  constructor; intros.
*
  destruct z, z'. apply exist_ext.
  do 2 red in H, H0. simpl in *. eapply join_eq; eauto.
*
  destruct a,b,c,d,e; do 2 red in H,H0. simpl in *.
  destruct (join_assoc H H0) as [a [? ?]].
  assert (pure_readable_share a).
  eapply join_pure_readable; eauto.
  exists (exist pure_readable_share _ H3).
  split; eassumption.
*
  destruct a,b,c; do 2 red in H|-*; simpl in *. apply join_comm; auto.
*
  destruct a,a',b,b'; do 2 red in H,H0; simpl in *.
  apply exist_ext.
  eapply join_positivity; eauto.
Qed.

Lemma dec_readable sh : {readable_share sh}+{~readable_share sh}.
Proof.
unfold readable_share, nonempty_share, nonidentity.
destruct (dec_share_identity (Share.glb Share.Rsh sh));[right|left].
intro. contradiction.
auto.
Defined.

Lemma dec_pure_readable sh : {pure_readable_share sh}+{~pure_readable_share sh}.
Proof.
unfold pure_readable_share.
apply sumbool_dec_and.
apply eq_dec.
unfold readable_share, nonempty_share, nonidentity.
destruct (dec_share_identity (Share.glb Share.Rsh sh));[right|left].
intro. contradiction.
auto.
Defined.

Lemma dec_share_identity': forall sh: Share.t, Decidable.decidable (identity sh).
Proof.
intros.
destruct (dec_share_identity sh); [left|right]; auto.
Qed.

Lemma not_not_share_identity: forall sh: Share.t,
  ~ ~ (identity sh) -> identity sh.
Proof.
intros.
 apply (Decidable.not_not _ (dec_share_identity' _)). auto.
Qed.

Lemma join_readable_part_eq:
  forall sh1 (rsh1: readable_share sh1)
         sh2 (nsh2: ~readable_share sh2)
         sh3 (rsh3: readable_share sh3),
        join sh1 sh2 sh3 ->
        readable_part rsh1 = readable_part rsh3.
Proof.
 intros.
 apply exist_ext.
 apply not_not_share_identity in nsh2.
 destruct H. subst sh3.
 apply identity_share_bot in nsh2.
 rewrite Share.distrib1. rewrite nsh2. rewrite Share.lub_bot.
 auto.
Qed.

Lemma join_readable_part:
  forall sh1 (rsh1: readable_share sh1) sh2 (rsh2: readable_share sh2) sh3 (rsh3: readable_share sh3),
   join sh1 sh2 sh3 ->
  join (readable_part rsh1) (readable_part rsh2)(readable_part rsh3).
Proof.
intros.
red. red. simpl.
destruct H. subst.
split.
rewrite Share.glb_assoc. rewrite (Share.glb_commute sh1).
rewrite <- Share.glb_assoc.
rewrite <- (Share.glb_assoc Share.Rsh).
rewrite Share.glb_idem. rewrite Share.glb_assoc.
rewrite (Share.glb_commute sh2). rewrite H.
apply Share.glb_bot.
rewrite <- Share.distrib1. auto.
Qed.

Lemma share_self_join_bot:
  forall sh: Share.t, join sh sh sh -> sh = Share.bot.
Proof.
 intros.
  destruct H.
  rewrite Share.glb_idem in H. auto.
Qed.

Definition retainer_part (sh: Share.t) := Share.glb Share.Lsh sh.

Lemma retainer_part_nonreadable:
  forall sh, ~readable_share (retainer_part sh).
Proof.
 intros.
 unfold readable_share, retainer_part, nonempty_share, nonidentity.
 intro. apply H; clear H.
 rewrite <- Share.glb_assoc.
 rewrite (Share.glb_commute Share.Rsh).
 rewrite glb_Lsh_Rsh.
 rewrite Share.glb_commute, Share.glb_bot.
 apply bot_identity.
Qed.
Arguments retainer_part_nonreadable: clear implicits.

Lemma readable_share_lub:
 forall a b: Share.t, readable_share b -> readable_share (Share.lub a b).
Proof.
intros.
do 3 red in H|-*.
contradict H.
apply identity_share_bot in H.
rewrite Share.distrib1 in H.
apply lub_bot_e in H. destruct H.
rewrite H0.
apply bot_identity.
Qed.

Lemma retainer_part_join: forall sh1 sh2 sh3,
  join sh1 sh2 sh3 -> join (retainer_part sh1) (retainer_part sh2) (retainer_part sh3).
Proof.
intros.
 unfold retainer_part.
 destruct H; subst; simpl  in *; split.
 rewrite Share.glb_assoc. rewrite (Share.glb_commute sh1).
 rewrite <- Share.glb_assoc. rewrite <- Share.glb_assoc. rewrite Share.glb_idem.
 rewrite Share.glb_assoc. rewrite (Share.glb_commute sh2). rewrite H.
 apply Share.glb_bot.
 rewrite <- Share.distrib1. auto.
Qed.

Lemma not_readable_Rsh_part:
 forall sh, ~ readable_share sh -> Share.glb Share.Rsh sh = Share.bot.
Proof.
intros.
apply not_not_share_identity in H.
apply identity_share_bot in H. auto.
Qed.

Lemma join_parts1:
  forall L R (HC: Share.comp L = R) sh1 sh2 sh,
         join sh1 sh2 (Share.glb L sh) ->
         Share.glb L sh1 = sh1 /\
         Share.glb R sh1 = Share.bot.
Proof.
intros.
cut (Share.glb L sh1 = sh1).
*
intro. split; auto.
rewrite <- H0.
rewrite <- Share.glb_assoc.
rewrite (Share.glb_commute R).
subst R. rewrite Share.comp2.
rewrite Share.glb_commute.
apply Share.glb_bot.
*
assert (Share.Ord sh1 L).
apply Share.ord_trans with (Share.glb L sh).
apply leq_join_sub.
exists sh2; auto.
apply Share.glb_lower1.
clear H.
apply Share.ord_spec1 in H0.
symmetry.
rewrite Share.glb_commute.
auto.
Qed.

Lemma join_parts:
  forall L R (HC: Share.comp L = R) sh1 sh2 sh,
         join sh1 sh2 (Share.glb L sh) ->
         Share.glb L sh1 = sh1 /\
         Share.glb R sh1 = Share.bot /\
         Share.glb L sh2 = sh2 /\
         Share.glb R sh2 = Share.bot.
Proof.
intros.
destruct (join_parts1 HC H).
destruct (join_parts1 HC (join_comm H)).
split3; auto.
Qed.

Lemma comp_Rsh_Lsh: Share.comp Share.Rsh = Share.Lsh.
Proof.
rewrite <- (Share.comp_inv Share.Lsh).
f_equal. symmetry. apply comp_Lsh_Rsh.
Qed.

Lemma glb_twice: forall a b, Share.glb a (Share.glb a b) = Share.glb a b.
Proof.
intros. rewrite <- Share.glb_assoc. rewrite Share.glb_idem; auto.
Qed.

Lemma glb_Lsh_Rsh':
  forall sh, Share.glb Share.Lsh (Share.glb Share.Rsh sh) = Share.bot.
Proof.
intros.
rewrite <- Share.glb_assoc. rewrite glb_Lsh_Rsh.
rewrite Share.glb_commute; apply Share.glb_bot.
Qed.

Lemma comp_parts_join:
 forall L R (HC: Share.comp L = R) a b c,
  join (Share.glb L a) (Share.glb L b) (Share.glb L c) ->
  join (Share.glb R a) (Share.glb R b) (Share.glb R c) ->
  join a b c.
Proof.
intros.
subst R.
split.
*
destruct H,H0.
clear H1 H2.
rewrite <- (Share.glb_top a), <- (Share.glb_commute Share.top).
rewrite <- (Share.comp1 L).
rewrite !(Share.glb_commute (Share.lub _ _)).
rewrite !Share.distrib1.
rewrite <- (Share.glb_top b), <- (Share.glb_commute Share.top).
rewrite <- (Share.comp1 L).
rewrite !(Share.glb_commute _ b).
rewrite (Share.distrib1 b).
rewrite !(Share.glb_commute a).
rewrite !(Share.glb_commute b).
pose proof (Share.glb_lower1 L a).
pose proof (Share.glb_lower1 L b).
pose proof (Share.glb_lower2 a (Share.comp L)). rewrite Share.glb_commute in H3.
pose proof (Share.glb_lower2 b (Share.comp L)). rewrite Share.glb_commute in H4.
forget (Share.glb L a) as al.
forget (Share.glb (Share.comp L) a) as ar.
forget (Share.glb L b) as bl.
forget (Share.glb (Share.comp L) b) as br.
rewrite Share.distrib1.
rewrite (Share.glb_commute _ bl).
rewrite Share.distrib1.
rewrite Share.glb_commute. rewrite H.
rewrite (Share.lub_commute Share.bot), Share.lub_bot.
rewrite (Share.glb_commute _ br).
rewrite Share.distrib1.
rewrite (Share.glb_commute br ar). rewrite H0.
rewrite Share.lub_bot.
apply Share.ord_spec1 in H1.
apply Share.ord_spec1 in H2.
apply Share.ord_spec1 in H3.
apply Share.ord_spec1 in H4.
rewrite H1,H2,H3,H4.
clear.
rewrite Share.glb_assoc. rewrite (Share.glb_commute ar). rewrite <- (Share.glb_assoc L).
rewrite (Share.comp2 L).
rewrite (Share.glb_commute Share.bot). rewrite Share.glb_bot.
rewrite Share.glb_bot.
rewrite (Share.lub_commute Share.bot). rewrite Share.lub_bot.
rewrite Share.glb_assoc. rewrite (Share.glb_commute al).
rewrite <- (Share.glb_assoc (Share.comp L)).
rewrite (Share.glb_commute (Share.comp L)).
rewrite (Share.comp2 L). rewrite (Share.glb_commute Share.bot). rewrite Share.glb_bot.
apply Share.glb_bot.
*
destruct H,H0.
clear H H0.
rewrite <- (Share.glb_top c).
rewrite <- (Share.comp1 L).
rewrite Share.distrib1.
rewrite !(Share.glb_commute c).
rewrite <- H1. rewrite <- H2.
rewrite Share.lub_assoc.
rewrite <- (Share.lub_assoc (Share.glb L b)).
rewrite (Share.lub_commute (Share.glb L b)).
rewrite Share.lub_assoc.
rewrite <- Share.lub_assoc.
f_equal.
rewrite !(Share.glb_commute _ a).
rewrite <- Share.distrib1.
rewrite (Share.comp1 L).
rewrite Share.glb_top.
auto.
rewrite !(Share.glb_commute _ b).
rewrite <- Share.distrib1.
rewrite (Share.comp1 L).
rewrite Share.glb_top.
auto.
Qed.

Lemma left_right_join:
 forall a b c,
  join (Share.glb Share.Lsh a) (Share.glb Share.Lsh b) (Share.glb Share.Lsh c) ->
  join (Share.glb Share.Rsh a) (Share.glb Share.Rsh b) (Share.glb Share.Rsh c) ->
  join a b c.
Proof.
apply comp_parts_join.
apply comp_Lsh_Rsh.
Qed.

Lemma lub_bot': forall sh, Share.lub Share.bot sh = sh.
Proof.
intros.
rewrite Share.lub_commute.
apply Share.lub_bot.
Qed.

Lemma glb_Rsh_Lsh: Share.glb Share.Rsh Share.Lsh = Share.bot.
Proof.
rewrite Share.glb_commute.
apply glb_Lsh_Rsh.
Qed.

Lemma join_writable1: forall sh1 sh2 sh,
   join sh1 sh2 sh -> writable_share sh1 -> writable_share sh.
Proof.
intros.
red in H0|-*.
eapply join_sub_trans; [apply H0 | ].
exists sh2; auto.
Qed.

Lemma join_writable_readable:
  forall {sh1 sh2 sh},
   join sh1 sh2 sh -> writable_share sh1 -> readable_share sh2 -> False.
Proof.
intros.
red in H0,H1.
destruct H0 as [a ?].
destruct (join_assoc (join_comm H0) H) as [f [? ?]].
destruct H2.
rewrite H2 in H1.
apply H1; auto.
Qed.

Lemma writable_share_glb_Rsh:
  forall sh, writable_share sh -> writable_share (Share.glb Share.Rsh sh).
Proof.
intros.
unfold writable_share in *.
apply leq_join_sub in H.
apply leq_join_sub.
apply Share.ord_spec1.
apply Share.ord_spec1 in H.
rewrite <- H.
rewrite Share.glb_idem; auto.
Qed.

Lemma glb_split_lemma1:
  forall a b, Share.glb Share.Rsh a = Share.glb Share.Rsh b ->
     Share.glb Share.Rsh (fst (Share.split a)) =
     Share.glb Share.Rsh (fst (Share.split b)).
Proof.
intros.
destruct (Share.split a) as [a1 a2] eqn:Ha.
destruct (Share.split b) as [b1 b2] eqn:Hb.
simpl.
pose proof (Share.split_together _ _ _ Ha).
pose proof (Share.split_disjoint _ _ _ Ha).
pose proof (Share.split_together _ _ _ Hb).
pose proof (Share.split_disjoint _ _ _ Hb).
subst a b.
clear Ha Hb.
assert (H4 := f_equal (Share.glb a1) H).
assert (H5 := f_equal (Share.glb b1) H).
rewrite !Share.distrib1 in H4.
rewrite !(Share.glb_commute Share.Rsh) in H4.
rewrite glb_twice in H4.
rewrite <- Share.glb_assoc in H4.
rewrite H1 in H4.
rewrite (Share.glb_commute Share.bot), Share.glb_bot in H4.
rewrite Share.lub_bot in H4.
rewrite Share.glb_commute in H4.
symmetry in H5.
rewrite <- Share.glb_assoc in H5.
rewrite (Share.glb_commute b1) in H5.
rewrite Share.glb_assoc in H5.
rewrite Share.glb_absorb in H5.
rewrite H4,H5; clear H4 H5.
rewrite !Share.distrib1.
f_equal.
rewrite (Share.glb_commute Share.Rsh).
rewrite <- !Share.glb_assoc.
f_equal. rewrite Share.glb_commute; auto.
rewrite (Share.glb_commute Share.Rsh).
rewrite <- !Share.glb_assoc.
Admitted.

Lemma glb_split_lemma2:
  forall a b, Share.glb Share.Rsh a = Share.glb Share.Rsh b ->
     Share.glb Share.Rsh (snd (Share.split a)) =
     Share.glb Share.Rsh (snd (Share.split b)).
Admitted.

Lemma fst_split_glb_orthogonal: forall sh : share,
identity (Share.glb Share.Rsh (fst (Share.split sh))) ->
identity (Share.glb Share.Rsh sh).
Proof.
Admitted.

Lemma snd_split_glb_orthogonal: forall sh : share,
identity (Share.glb Share.Rsh (snd (Share.split sh))) ->
identity (Share.glb Share.Rsh sh).
Admitted.


Require Export Pig.Base.

Module Logical.

Inductive tm: Set :=
| t_filter: id -> id -> tm
| t_foreach: id -> id -> tm
| t_group: id -> col -> tm
| t_join: id -> col -> id -> col -> tm
| t_load: id -> ty -> tm
| t_assign: id -> tm -> tm
| t_store: id -> tm
| t_seq: tm -> tm -> tm.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=

  | T_Filter : forall Gamma x y S,
      Gamma x = Some (TSchema S) ->
      Gamma y = Some (TPred S) ->
      Gamma |- t_filter x y \in TSchema S

  | T_ForEach : forall Gamma x y S S',
      Gamma x = Some(TSchema S) ->
      Gamma y = Some(TFn S S') ->
      Gamma |- t_foreach x y \in TSchema S'

  | T_Group : forall Gamma x c S,
      Gamma x = Some (TSchema S) ->
      can_group_by S c ->
      Gamma |- t_group x c \in TSchema (group_schema S)

  | T_Join : forall Gamma x y cx cy S1 S2 S3,
      Gamma x = Some(TSchema S1) ->
      Gamma y = Some(TSchema S2) ->
      can_join_by S1 cx ->
      can_join_by S2 cy ->
      concatenated_schema S1 S2 S3 ->
      Gamma |- t_join x cx y cx \in TSchema S3

  | T_Load : forall Gamma x T,
      Gamma x = None ->
      loadable_ty T ->
      Gamma |- t_load x T \in TUnit

  | T_Assign : forall Gamma x q S,
      Gamma x = None ->
      Gamma |- q \in TSchema S ->
      Gamma |- t_assign x q \in TUnit

  | T_Store : forall Gamma x S,
      Gamma x = Some (TSchema S) ->
      Gamma |- t_store x \in TUnit

  | T_SeqLoad : forall Gamma x T s1 s2,
      s1 = t_load x T ->
      Gamma |- s1 \in TUnit ->
      (extend Gamma x T) |- s2 \in TUnit ->
      Gamma |- t_seq s1 s2 \in TUnit

  | T_SeqAssign : forall Gamma x q s1 s2 S,
      s1 = t_assign x q ->
      Gamma |- q \in TSchema S ->
      Gamma |- s1 \in TUnit ->
      extend Gamma x (TSchema S) |- s2 \in TUnit ->
      Gamma |- t_seq s1 s2 \in TUnit

  | T_SeqStore : forall Gamma x s1 s2 S,
      s1 = t_store x ->
      Gamma x = Some (TSchema S) ->
      Gamma |- s1 \in TUnit ->
      Gamma |- s2 \in TUnit ->
      Gamma |- t_seq s1 s2 \in TUnit

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

End Logical.