(* -*- mode: coq; mode: visual-line -*- *)

(** * The cumulative hierarchy [V]. *)

Require Import HoTT.Basics HoTT.Types.
Require Import HSet TruncType.
Require Import Colimits.SpanPushout.
Require Import HoTT.Truncations Colimits.Quotient.
Local Open Scope nat_scope.
Local Open Scope path_scope.

(** Bitotal relation *)

Definition bitotal {A B : Type} (R : A -> B -> HProp) :=
   (forall a : A, hexists (fun (b : B) => R a b))
 * (forall b : B, hexists (fun (a : A) => R a b)).

(** ** The cumulative hierarchy V *)

Module Export CumulativeHierarchy.

Private Inductive V@{U' U | U < U'} : Type@{U'} :=
| set {A : Type@{U}} (f : A -> V) : V.

Axiom setext : forall {A B : Type} (R : A -> B -> HProp)
  (bitot_R : bitotal R) (h : SPushout R -> V),
set (h o (spushl R)) = set (h o (spushr R)).

Axiom ishset_V : IsHSet V.
Global Existing Instance ishset_V.

(** The induction principle.  Annotating the universes here greatly reduces the number of universe variables later in the file.  For example, [function] below went from 279 to 3.  If [V_ind] needs to be generalized in the future, check [function] to make sure things haven't exploded again. *)
Fixpoint V_ind@{U' U u | U < U'} (P : V@{U' U} -> Type@{u})
  (H_0trunc : forall v : V@{U' U}, IsTrunc 0 (P v))
  (H_set : forall (A : Type@{U}) (f : A -> V) (H_f : forall a : A, P (f a)), P (set f))
  (H_setext : forall (A B : Type@{U}) (R : A -> B -> HProp@{U}) (bitot_R : bitotal R)
    (h : SPushout R -> V) (H_h : forall x : SPushout R, P (h x)),
    transport@{U' u} _ (setext R bitot_R h) (H_set A (h o spushl R) (H_h oD spushl R))
      = H_set B (h o spushr R) (H_h oD spushr R) )
  (v : V)
: P v
:= (match v with
     | set A f => fun _ _ => H_set A f (fun a => V_ind P H_0trunc H_set H_setext (f a))
    end) H_setext H_0trunc.

(** We don't need to axiomatize the computation rule because we get it for free thanks to 0-truncation *)

End CumulativeHierarchy.

Definition V_comp_setext (P : V -> Type)
  (H_0trunc : forall v : V, IsTrunc 0 (P v))
  (H_set : forall (A : Type) (f : A -> V) (H_f : forall a : A, P (f a)), P (set f))
  (H_setext : forall (A B : Type) (R : A -> B -> HProp) (bitot_R : bitotal R)
    (h : SPushout R -> V) (H_h : forall x : SPushout R, P (h x)),
    (setext R bitot_R h) # (H_set A (h o spushl R) (H_h oD spushl R))
      = H_set B (h o spushr R) (H_h oD spushr R) )
  (A B : Type) (R : A -> B -> HProp) (bitot_R : bitotal R) (h : SPushout R -> V)
: apD (V_ind P H_0trunc H_set H_setext) (setext R bitot_R h)
  = H_setext A B R bitot_R h ((V_ind P H_0trunc H_set H_setext) oD h).
Proof.
  apply path_ishprop.
Defined.

(** The non-dependent eliminator *)

Definition V_rec (P : Type)
  (H_0trunc : IsTrunc 0 P)
  (H_set : forall (A : Type), (A -> V) -> (A -> P) -> P)
  (H_setext : forall (A B : Type) (R : A -> B -> HProp) (bitot_R : bitotal R)
    (h : SPushout R -> V) (H_h : SPushout R -> P),
    H_set A (h o spushl R) (H_h o spushl R) = H_set B (h o spushr R) (H_h o spushr R) )
: V -> P.
Proof.
  refine (V_ind _ _ H_set _).
  intros. exact (transport_const _ _ @ H_setext A B R bitot_R h H_h).
Defined.

Definition V_comp_nd_setext (P : Type)
  (H_0trunc : IsTrunc 0 P)
  (H_set : forall (A : Type), (A -> V) -> (A -> P) -> P)
  (H_setext : forall (A B : Type) (R : A -> B -> HProp) (bitot_R : bitotal R)
    (h : SPushout R -> V) (H_h : SPushout R -> P),
    H_set A (h o spushl R) (H_h o spushl R) = H_set B (h o spushr R) (H_h o spushr R) )
  (A B : Type) (R : A -> B -> HProp) (bitot_R : bitotal R) (h : SPushout R -> V)
: ap (V_rec P H_0trunc H_set H_setext) (setext R bitot_R h)
  = H_setext A B R bitot_R h ((V_rec P H_0trunc H_set H_setext) o h).
Proof.
  apply path_ishprop.
Defined.

(** ** Alternative induction principle (This is close to the one from the book) *)

Definition equal_img {A B C : Type} (f : A -> C) (g : B -> C) :=
   (forall a : A, hexists (fun (b : B) => f a = g b))
 * (forall b : B, hexists (fun (a : A) => f a = g b)).

Definition setext' {A B : Type} (f : A -> V) (g : B -> V) (eq_img : equal_img f g)
: set f = set g.
Proof.
  pose (R := fun a b => Build_HProp (f a = g b)).
  pose (h := SPushout_rec R V f g (fun _ _ r => r)).
  exact (setext R eq_img h).
Defined.

Definition V_rec' (P : Type)
  (H_0trunc : IsTrunc 0 P)
  (H_set : forall (A : Type), (A -> V) -> (A -> P) -> P)
  (H_setext' : forall (A B : Type) (f : A -> V) (g : B -> V), (equal_img f g) ->
    forall (H_f : A -> P) (H_g : B -> P), (equal_img H_f H_g) ->
    (H_set A f H_f) = (H_set B g H_g) )
: V -> P.
Proof.
  refine (V_rec _ _ H_set _).
  intros A B R bitot_R h H_h.
  apply H_setext'.
  - split.
    + intro a. generalize (fst bitot_R a). apply (Trunc_functor (-1)).
      intros [b r]. exists b. exact (ap h (spglue R r)).
    + intro b. generalize (snd bitot_R b). apply (Trunc_functor (-1)).
      intros [a r]. exists a. exact (ap h (spglue R r)).
  - split.
    + intro a. generalize (fst bitot_R a). apply (Trunc_functor (-1)).
      intros [b r]. exists b. exact (ap H_h (spglue R r)).
    + intro b. generalize (snd bitot_R b). apply (Trunc_functor (-1)).
      intros [a r]. exists a. exact (ap H_h (spglue R r)).
Defined.

(** Note that the hypothesis H_setext' differs from the one given in section 10.5 of the HoTT book. *)
Definition V_ind' (P : V -> Type)
  (H_0trunc : forall v : V, IsTrunc 0 (P v))
  (H_set : forall (A : Type) (f : A -> V) (H_f : forall a : A, P (f a)), P (set f))
  (H_setext' : forall (A B : Type) (f : A -> V) (g : B -> V)
    (eq_img: equal_img f g)
    (H_f : forall a : A, P (f a)) (H_g : forall b : B, P (g b))
    (H_eqimg : (forall a : A, hexists (fun (b : B) =>
                  hexists (fun (p:f a = g b) => p # (H_f a) = H_g b)))
             * (forall b : B, hexists (fun (a : A) =>
                  hexists (fun (p:f a = g b) => p # (H_f a) = H_g b))) ),
    (setext' f g eq_img) # (H_set A f H_f) = (H_set B g H_g)
  )
: forall v : V, P v.
Proof.
  apply V_ind with H_set; try assumption.
  intros A B R bitot_R h H_h.
  pose (f := h o spushl R : A -> V ).
  pose (g := h o spushr R : B -> V ).
  pose (H_f := H_h oD spushl R : forall a : A, P (f a)).
  pose (H_g := H_h oD spushr R : forall b : B, P (g b)).
  assert (eq_img : equal_img f g).
  { split.
    - intro a. generalize (fst bitot_R a). apply (Trunc_functor (-1)).
      intros [b r]. exists b. exact (ap h (spglue R r)).
    - intro b. generalize (snd bitot_R b). apply (Trunc_functor (-1)).
      intros [a r]. exists a. exact (ap h (spglue R r)). }
  transitivity (transport P (setext' (h o spushl R) (h o spushr R) eq_img)
      (H_set A (h o spushl R) (H_h oD spushl R))).
  { apply (ap (fun p => transport P p (H_set A (h o spushl R) (H_h oD spushl R)))).
    apply path_ishprop. }
  apply (H_setext' A B f g eq_img H_f H_g).  split.
  - intro a.
    set (truncb := fst bitot_R a). generalize truncb.
    apply (Trunc_functor (-1)).
    intros [b Rab]. exists b.
    apply tr.
    exists (ap h (spglue R Rab)).
    apply (concatR (apD H_h (spglue R Rab))).
    apply inverse. unfold f, g. apply transport_compose.
  - intros b.
    set (trunca := snd bitot_R b). generalize trunca.
    apply (Trunc_functor (-1)).
    intros [a Rab]. exists a.
    apply tr.
    exists (ap h (spglue R Rab)).
    apply (concatR (apD H_h (spglue R Rab))).
    apply inverse. unfold f, g. apply transport_compose.
Defined.

(** Simpler induction principle when the goal is an hprop *)

Definition V_ind_hprop (P : V -> Type)
  (H_set : forall (A : Type) (f : A -> V) (H_f : forall a : A, P (f a)), P (set f))
  (isHProp_P : forall v : V, IsHProp (P v))
  : forall v : V, P v.
Proof.
  refine (V_ind _ _ H_set _).
  intros. apply path_ishprop.
Defined.

Section AssumingUA.
Context `{ua : Univalence}.

(** ** Membership relation *)

Definition mem (x : V) : V -> HProp.
Proof.
  simple refine (V_rec' _ _ _ _).
  - intros A f _.
    exact (hexists (fun a : A => f a = x)).
  - simpl.
    intros A B f g eqimg _ _ _.
    apply path_iff_hprop; simpl.
    + intro H. refine (Trunc_rec _ H).
    intros [a p]. generalize (fst eqimg a). apply (Trunc_functor (-1)).
    intros [b p']. exists b. transitivity (f a); auto with path_hints.
    + intro H. refine (Trunc_rec _ H).
      intros [b p]. generalize (snd eqimg b). apply (Trunc_functor (-1)).
      intros [a p']. exists a. transitivity (g b); auto with path_hints.
Defined.

Declare Scope set_scope.
Notation "x ∈ v" := (mem x v) : set_scope.
Open Scope set_scope.

(** ** Subset relation *)

Definition subset (x : V) (y : V) : HProp
:= Build_HProp (forall z : V, z ∈ x -> z ∈ y).

Notation "x ⊆ y" := (subset x y) : set_scope.

(** ** Bisimulation relation *)
(** The equality in V lives in Type@{U'}. We define the bisimulation relation which is a U-small resizing of the equality in V: it must live in HProp_U : Type{U'}, hence the codomain is HProp@{U}. We then prove that bisimulation is equality (bisim_equals_id), then use it to prove the key lemma monic_set_present. *)

(* We define bisimulation by double induction on V. We first fix the first argument as set(A,f) and define bisim_aux : V -> HProp, by induction. This is the inner of the two inductions. *)
Local Definition bisim_aux (A : Type) (f : A -> V) (H_f : A -> V -> HProp) : V -> HProp.
Proof.
  apply V_rec' with
    (fun B g _ => Build_HProp ( (forall a, hexists (fun b => H_f a (g b)))
                               * forall b, hexists (fun a => H_f a (g b)) )
    ).
  - exact _.
  - intros B B' g g' eq_img H_g H_g' H_img; simpl.
    apply path_iff_hprop; simpl.
    + intros [H1 H2]; split.
      * intro a. refine (Trunc_rec _ (H1 a)).
        intros [b H3]. generalize (fst eq_img b).
        unfold hexists. refine (@Trunc_functor (-1) {b0 : B' & g b = g' b0} {b0 : B' & H_f a (g' b0)} _).
        intros [b' p]. exists b'. exact (transport (fun x => H_f a x) p H3).
      * intro b'. refine (Trunc_rec _ (snd eq_img b')).
        intros [b p]. generalize (H2 b). apply (Trunc_functor (-1)).
        intros [a H3]. exists a. exact (transport (fun x => H_f a x) p H3).
    + intros [H1 H2]; split.
      * intro a. refine (Trunc_rec _ (H1 a)).
        intros [b' H3]. generalize (snd eq_img b'). apply (Trunc_functor (-1)).
        intros [b p]. exists b. exact (transport (fun x => H_f a x) p^ H3).
      * intro b. refine (Trunc_rec _ (fst eq_img b)).
        intros [b' p]. generalize (H2 b'). apply (Trunc_functor (-1)).
        intros [a H3]. exists a. exact (transport (fun x => H_f a x) p^ H3).
Defined.

(* Then we define bisim : V -> (V -> HProp) by induction again *)
Definition bisimulation : V@{U' U} -> V@{U' U} -> HProp@{U}.
Proof.
  refine (V_rec' (V -> HProp) _ bisim_aux _).
  intros A B f g eq_img H_f H_g H_img.
  apply path_forall.
  refine (V_ind_hprop _ _ _).
  intros C h _; simpl.
  apply path_iff_hprop; simpl.
  - intros [H1 H2]; split.
    + intro b. refine (Trunc_rec _ (snd H_img b)).
      intros [a p]. generalize (H1 a). apply (Trunc_functor (-1)).
      intros [c H3]. exists c. exact ((ap10 p (h c)) # H3).
    + intro c. refine (Trunc_rec _ (H2 c)).
      intros [a H3]. generalize (fst H_img a). apply (Trunc_functor (-1)).
      intros [b p]. exists b. exact ((ap10 p (h c)) # H3).
  - intros [H1 H2]; split.
    + intro a. refine (Trunc_rec _ (fst H_img a)).
      intros [b p]. generalize (H1 b). apply (Trunc_functor (-1)).
      intros [c H3]. exists c. exact ((ap10 p^ (h c)) # H3).
    + intro c. refine (Trunc_rec _ (H2 c)).
      intros [b H3]. generalize (snd H_img b). apply (Trunc_functor (-1)).
      intros [a p]. exists a. exact ((ap10 p^ (h c)) # H3).
Defined.

Notation "u ~~ v" := (bisimulation u v) : set_scope.

Global Instance reflexive_bisimulation : Reflexive bisimulation.
Proof.
  refine (V_ind_hprop _ _ _).
  intros A f H_f; simpl. split.
  - intro a; apply tr; exists a; auto.
  - intro a; apply tr; exists a; auto.
Defined.

Lemma bisimulation_equiv_id : forall u v : V, (u = v) <~> (u ~~ v).
Proof.
  intros u v.
  apply equiv_iff_hprop.
  - intro p; exact (transport (fun x => u ~~ x) p (reflexive_bisimulation u)).
  - generalize u v.
    refine (V_ind_hprop _ _ _); intros A f H_f.
    refine (V_ind_hprop _ _ _); intros B g _.
    simpl; intros [H1 H2].
    apply setext'. split.
    + intro a. generalize (H1 a). apply (Trunc_functor (-1)).
      intros [b h]. exists b; exact (H_f a (g b) h).
    + intro b. generalize (H2 b). apply (Trunc_functor (-1)).
      intros [a h]. exists a; exact (H_f a (g b) h).
Defined.

(** ** Canonical presentation of V-sets (Lemma 10.5.6) *)

(** Using the regular kernel would lead to a universe inconsistency in the monic_set_present lemma later. *)
Definition ker_bisim {A} (f : A -> V) (x y : A) := (f x ~~ f y).

Definition ker_bisim_is_ker {A} (f : A -> V)
  : forall (x y : A), f x = f y <~> ker_bisim f x y.
Proof.
  intros; apply bisimulation_equiv_id.
Defined.

Section MonicSetPresent_Uniqueness.
(** Given u : V, we want to show that the representation u = @set Au mu, where Au is an hSet and mu is monic, is unique. *)

Context {u : V} {Au Au': Type} {h : IsHSet Au} {h' : IsHSet Au'} {mu : Au -> V} {mono : IsEmbedding mu}
  {mu' : Au' -> V} {mono' : IsEmbedding mu'} {p : u = set mu} {p' : u = set mu'}.

Lemma eq_img_untrunc : (forall a : Au, {a' : Au' & mu' a' = mu a})
                     * (forall a' : Au', {a : Au & mu a = mu' a'}).
Proof.
  split.
  - intro a. exact (@untrunc_istrunc (-1) _ (mono' (mu a)) (transport (fun x => mu a ∈ x) (p^ @ p') (tr (a; 1)))).
  - intro a'. exact (@untrunc_istrunc (-1) _ (mono (mu' a')) (transport (fun x => mu' a' ∈ x) (p'^ @ p) (tr (a'; 1)))).
Defined.

Let e : Au -> Au' := fun a => pr1 (fst eq_img_untrunc a).
Let inv_e : Au' -> Au := fun a' => pr1 (snd eq_img_untrunc a').

Let hom1 : e o inv_e == idmap.
Proof.
  intro a'.
  apply (isinj_embedding mu' mono').
  transitivity (mu (inv_e a')).
  - exact (pr2 (fst eq_img_untrunc (inv_e a'))).
  - exact (pr2 (snd eq_img_untrunc a')).
Defined.

Let hom2 : inv_e o e == idmap.
Proof.
  intro a.
  apply (isinj_embedding mu mono).
  transitivity (mu' (e a)).
  - exact (pr2 (snd eq_img_untrunc (e a))).
  - exact (pr2 (fst eq_img_untrunc a)).
Defined.

Let path : Au' = Au.
Proof.
  apply path_universe_uncurried.
  apply (equiv_adjointify inv_e e hom2 hom1).
Defined.

Lemma mu_eq_mu' : transport (fun A : Type => A -> V) path^ mu = mu'.
Proof.
  apply path_forall. intro a'.
  transitivity (transport (fun X => V) path^ (mu (transport (fun X : Type => X) path^^ a'))).
  - apply (@transport_arrow Type (fun X : Type => X) (fun X => V) Au Au' path^ mu a').
  - transitivity (mu (transport idmap path^^ a')).
    + apply transport_const.
    + transitivity (mu (inv_e a')).
      2: apply (pr2 (snd eq_img_untrunc a')).
      refine (ap mu _).
      transitivity (transport idmap path a').
      * exact (ap (fun x => transport idmap x a') (inv_V path)).
      * apply transport_path_universe.
Defined.

Lemma monic_set_present_uniqueness : (Au; (mu; (h, mono, p))) = (Au'; (mu'; (h', mono', p'))) :> {A : Type & {m : A -> V & IsHSet A * IsEmbedding m * (u = set m)}}.
Proof.
  apply path_sigma_uncurried; simpl.
  exists path^.
  transitivity (path^ # mu; transportD (fun A => A -> V) (fun A m => IsHSet A * IsEmbedding m * (u = set m)) path^ mu (h, mono, p)).
  - apply (@transport_sigma Type (fun A => A -> V) (fun A m => IsHSet A * IsEmbedding m * (u = set m)) Au Au' path^ (mu; (h, mono, p))).
  - apply path_sigma_hprop; simpl.
    exact mu_eq_mu'.
Defined.

End MonicSetPresent_Uniqueness.

(** This lemma actually says a little more than 10.5.6, i.e., that Au is a hSet *)
Lemma monic_set_present : forall u : V, exists (Au : Type) (m : Au -> V),
  (IsHSet Au) * (IsEmbedding m) * (u = set m).
Proof.
  apply V_ind_hprop.
  - intros A f _.
    destruct (quotient_kernel_factor f (ker_bisim f) (ker_bisim_is_ker f))
      as [Au [eu [mu (((hset_Au, epi_eu), mono_mu), factor)]]].
    exists Au, mu. split;[exact (hset_Au, mono_mu)|].
    apply setext'; split.
    + intro a. apply tr; exists (eu a). exact (ap10 factor a).
    + intro a'. generalize (epi_eu a').
      intros ?; refine (Trunc_functor (-1) _ (center _)).
      intros [a p]. exists a. transitivity (mu (eu a)).
      * exact (ap10 factor a).
      * exact (ap mu p).
  - intro v. apply hprop_allpath.
    intros [Au [mu ((hset, mono), p)]].
    intros [Au' [mu' ((hset', mono'), p')]].
    apply monic_set_present_uniqueness.
Defined.

Definition type_of_members (u : V) : Type := pr1 (monic_set_present u).

Notation "[ u ]" := (type_of_members u) : set_scope.

Definition func_of_members {u : V} : [u] -> V := pr1 (pr2 (monic_set_present u)) : [u] -> V.

Definition is_hset_typeofmembers {u : V} : IsHSet ([u]) := fst (fst (pr2 (pr2 (monic_set_present u)))).

Definition IsEmbedding_funcofmembers {u : V} : IsEmbedding func_of_members := snd (fst (pr2 (pr2 (monic_set_present u)))).

Definition is_valid_presentation (u : V) : u = set func_of_members := snd (pr2 (pr2 (monic_set_present u))).

(** ** Lemmas 10.5.8 (i) & (vii), we put them here because they are useful later *)
Lemma extensionality : forall {x y : V}, (x ⊆ y * y ⊆ x) <-> x = y.
Proof.
  refine (V_ind_hprop _ _ _). intros A f _.
  refine (V_ind_hprop _ _ _). intros B g _.
  split.
  - intros [H1 H2]. apply setext'. split.
    + intro. refine (Trunc_rec _ (H1 (f a) (tr (a;1)))).
      intros [b p]. apply tr. exists b. exact p^.
    + intro. apply (H2 (g b)). apply tr; exists b; reflexivity.
  - intro p; split.
    + intros z Hz. apply (transport (fun x => z ∈ x) p Hz).
    + intros z Hz. apply (transport (fun x => z ∈ x) p^ Hz).
Qed.

Lemma mem_induction (C : V -> HProp)
: (forall v, (forall x, x ∈ v -> C x) -> C v) -> forall v, C v.
Proof.
  intro H.
  refine (V_ind_hprop _ _ _).
  intros A f H_f. apply H. intros x Hx.
  generalize Hx; apply Trunc_rec.
  intros [a p]. exact (transport C p (H_f a)).
Defined.

(** ** Two useful lemmas *)

Global Instance irreflexive_mem : Irreflexive mem.
Proof.
  assert (forall v, IsHProp (complement (fun x x0 : V => x ∈ x0) v v)). (* https://coq.inria.fr/bugs/show_bug.cgi?id=3854 *)
  { intro.
    unfold complement.
    exact _. }
  refine (mem_induction (fun x => Build_HProp (~ x ∈ x)) _); simpl in *.
  intros v H. intro Hv.
  exact (H v Hv Hv).
Defined.

Lemma path_V_eqimg {A B} {f : A -> V} {g : B -> V} : set f = set g -> equal_img f g.
Proof.
  intro p. split.
  - intro a.
    assert (H : f a ∈ set g).
    { apply (snd extensionality p).
      apply tr; exists a; reflexivity. }
    generalize H; apply (Trunc_functor (-1)). intros [b p']. exists b; exact p'^.
  - intro b.
    assert (H : g b ∈ set f).
    { apply (snd extensionality p^).
      apply tr; exists b; reflexivity. }
    generalize H; apply (Trunc_functor (-1)). intros [a p']. exists a; exact p'.
Defined.

(** ** Definitions of particular sets in V *)

(** The empty set *)
Definition V_empty : V := set (Empty_ind (fun _ => V)).

(** The singleton {u} *)
Definition V_singleton (u : V) : V@{U' U} := set (Unit_ind u).

Global Instance isequiv_ap_V_singleton {u v : V}
: IsEquiv (@ap _ _ V_singleton u v).
Proof.
  simple refine (Build_IsEquiv _ _ _ _ _ _ _); try solve [ intro; apply path_ishprop ].
  { intro H. specialize (path_V_eqimg H). intros (H1, H2).
    refine (Trunc_rec _ (H1 tt)). intros [t p]. destruct t; exact p. }
Defined.

(** The pair {u,v} *)
Definition V_pair (u : V) (v : V) : V@{U' U} := set (fun b : Bool => if b then u else v).

Lemma path_pair {u v u' v' : V@{U' U}} : (u = u') * (v = v') -> V_pair u v = V_pair u' v'.
Proof.
  intros (H1, H2). apply setext'. split.
  + apply Bool_ind.
    * apply tr; exists true. assumption.
    * apply tr; exists false; assumption.
  + apply Bool_ind.
    * apply tr; exists true; assumption.
    * apply tr; exists false; assumption.
Defined.

Lemma pair_eq_singleton {u v w : V} : V_pair u v = V_singleton w <-> (u = w) * (v = w).
Proof.
  split.
  + intro H. destruct (path_V_eqimg H) as (H1, H2).
    refine (Trunc_rec _ (H1 true)). intros [t p]; destruct t.
    refine (Trunc_rec _ (H1 false)). intros [t p']; destruct t.
    split; [exact p| exact p'].
  + intros (p1, p2). apply setext'; split.
    * intro a; apply tr; exists tt. destruct a; [exact p1 | exact p2].
    * intro t; apply tr; exists true. destruct t; exact p1.
Defined.

(** The ordered pair (u,v) *)
Definition V_pair_ord (u : V) (v : V) : V := V_pair (V_singleton u) (V_pair u v).

Notation " [ u , v ] " := (V_pair_ord u v) : set_scope.

Lemma path_pair_ord {a b c d : V} : [a, b] = [c, d] <-> (a = c) * (b = d).
Proof.
  split.
  - intro p. assert (p1 : a = c).
    + assert (H : V_singleton a ∈ [c, d]).
      { apply (snd extensionality p). simpl.
        apply tr; exists true; reflexivity. }
      refine (Trunc_rec _ H). intros [t p']; destruct t.
      * apply ((ap V_singleton)^-1 p'^).
      * symmetry; apply (fst pair_eq_singleton p').
    + split.
      * exact p1.
      * assert (H : hor (b = c) (b = d)).
        { assert (H' : V_pair a b ∈ [c, d]).
          { apply (snd extensionality p).
            apply tr; exists false; reflexivity. }
          refine (Trunc_rec _ H'). intros [t p']; destruct t.
          - apply tr; left. apply (fst pair_eq_singleton p'^).
          - destruct (path_V_eqimg p') as (H1, H2).
            generalize (H2 false); apply (Trunc_functor (-1)).
            intros [t p'']; destruct t.
            + left; exact p''^.
            + right; exact p''^. }
        refine (Trunc_rec _ H). intro case; destruct case as [p'| p'].
        2: assumption.
        assert (H' : [a, b] = V_singleton (V_singleton b)).
        { apply (snd pair_eq_singleton).
          split.
          - apply ap; exact (p1 @ p'^).
          - apply (snd pair_eq_singleton).
            split; [exact (p1 @ p'^) | reflexivity]. }
        assert (H'' : V_pair c d = V_singleton b)
          by apply (fst pair_eq_singleton (p^ @ H')).
        symmetry; apply (fst pair_eq_singleton H'').
  - intros (p, p').
    apply path_pair. split.
    + apply ap; exact p.
    + apply path_pair. split; assumption; assumption.
Defined.

(** The cartesian product a × b *)
Definition V_cart_prod (a : V) (b : V) : V
:= set (fun x : [a] * [b] => [func_of_members (fst x), func_of_members (snd x)]).

Notation " a × b " := (V_cart_prod a b) : set_scope.

(** f is a function with domain a and codomain b *)
Definition V_is_func (a : V) (b : V) (f : V) := f ⊆ (a × b)
 * (forall x, x ∈ a -> hexists (fun y => y ∈ b * [x,y] ∈ f))
 * (forall x y y', [x,y] ∈ f * [x,y'] ∈ f -> y = y').

(** The set of functions from a to b *)
Definition V_func (a : V) (b : V) : V
:= @set ([a] -> [b]) (fun f => set (fun x => [func_of_members x, func_of_members (f x)] )).

(** The union of a set Uv *)
Definition V_union (v : V) :=
  @set ({x : [v] & [func_of_members x]}) (fun z => func_of_members (pr2 z)).

(** The ordinal successor x ∪ {x} *)
Definition V_succ : V -> V.
Proof.
  simple refine (V_rec' _ _ _ _).
  - intros A f _.
    exact (set (fun (x : A + Unit) => match x with inl a => f a
                                           | inr tt => set f end)).
  - simpl; intros A B f g eq_img _ _ _. apply setext'. split.
    + intro. destruct a.
      * generalize (fst eq_img a). apply (Trunc_functor (-1)).
        intros [b p]. exists (inl b); exact p.
      * apply tr; exists (inr tt). destruct u. apply setext'; auto.
    + intro. destruct b.
      * generalize (snd eq_img b). apply (Trunc_functor (-1)).
        intros [a p]. exists (inl a); exact p.
      * apply tr; exists (inr tt). destruct u. apply setext'; auto.
Defined.

(** The set of finite ordinals *)
Definition V_omega : V
:= set (fix I n := match n with 0   => V_empty
                              | S n => V_succ (I n) end).

(** ** Axioms of set theory (theorem 10.5.8) *)

Lemma not_mem_Vempty : forall x, ~ (x ∈ V_empty).
Proof.
  intros x Hx. generalize Hx; apply Trunc_rec.
  intros [ff _]. exact ff.
Qed.

Lemma pairing : forall u v, hexists (fun w => forall x, x ∈ w <-> hor (x = u) (x = v)).
Proof.
  intros u v. apply tr. exists (V_pair u v).
  intro; split; apply (Trunc_functor (-1)).
  - intros [[|] p]; [left|right]; exact p^.
  - intros [p | p]; [exists true | exists false]; exact p^.
Qed.

Lemma infinity : (V_empty ∈ V_omega) * (forall x, x ∈ V_omega -> V_succ x ∈ V_omega).
Proof.
  split.
  - apply tr; exists 0; auto.
  - intro. apply (Trunc_functor (-1)).
    intros [n p]. exists (S n). rewrite p; auto.
Qed.

Lemma union : forall v, hexists (fun w => forall x, x ∈ w <-> hexists (fun u => x ∈ u * u ∈ v)).
Proof.
  intro v. apply tr; exists (V_union v).
  intro x; split.
  - intro H. simpl in H. generalize H; apply (Trunc_functor (-1)).
    intros [[u' x'] p]; simpl in p.
    exists (func_of_members u'); split.
    + refine (transport (fun z => x ∈ z) (is_valid_presentation (func_of_members u'))^ _).
      simpl. apply tr; exists x'. exact p.
    + refine (transport (fun z => func_of_members u' ∈ z) (is_valid_presentation v)^ _).
      simpl. apply tr; exists u'; reflexivity.
  - apply Trunc_rec. intros [u (Hx, Hu)].
    generalize (transport (fun z => u ∈ z) (is_valid_presentation v) Hu).
    apply Trunc_rec. intros [u' pu].
    generalize (transport (fun z => x ∈ z) (is_valid_presentation (func_of_members u')) (transport (fun z => x ∈ z) pu^ Hx)).
    apply Trunc_rec. intros [x' px].
    apply tr. exists (u'; x'). exact px.
Qed.

Lemma function : forall u v, hexists (fun w => forall x, x ∈ w <-> V_is_func u v x).
Proof.
  intros u v. apply tr; exists (V_func u v).
  assert (memb_u : u = set (@func_of_members u)) by exact (is_valid_presentation u).
  assert (memb_v : v = set (@func_of_members v)) by exact (is_valid_presentation v).
  intro phi; split.
  - intro H. split;[split|].
    + intros z Hz. simpl in *. generalize H. apply Trunc_rec.
      intros [h p_phi]. generalize (transport (fun x => z ∈ x) p_phi^ Hz). apply (Trunc_functor (-1)).
      intros [a p]. exists (a, h a). assumption.
    + intros x Hx. generalize (transport (fun y => x ∈ y) memb_u Hx).
      apply Trunc_rec. intros [a p]. generalize H; apply (Trunc_functor (-1)).
      intros [h p_phi]. exists (func_of_members (h a)). split.
      * exact (transport (fun z => func_of_members (h a) ∈ z) memb_v^ (tr (h a; 1))).
      * apply (transport (fun y => [x, func_of_members (h a)] ∈ y) p_phi).
        apply tr; exists a. rewrite p; reflexivity.
    + intros x y y' (Hy, Hy'). generalize H; apply Trunc_rec. intros [h p_phi].
      generalize (transport (fun z => [x, y] ∈ z) p_phi^ Hy). apply Trunc_rec. intros [a p].
      generalize (transport (fun z => [x, y'] ∈ z) p_phi^ Hy'). apply Trunc_rec. intros [a' p'].
      destruct (fst path_pair_ord p) as (px, py). destruct (fst path_pair_ord p') as (px', py').
      transitivity (func_of_members (h a)); auto with path_hints. transitivity (func_of_members (h a'));auto with path_hints.
      refine (ap func_of_members _). refine (ap h _).
      apply (isinj_embedding func_of_members IsEmbedding_funcofmembers a a' (px @ px'^)).
  - intros ((H1, H2), H3). simpl.
    assert (h : forall a : [u], {b : [v] & [func_of_members a, func_of_members b] ∈ phi}).
    { intro a. pose (x := func_of_members a).
      transparent assert (H : {y : V & y ∈ v * [x, y] ∈ phi}).
      - refine (@untrunc_istrunc (-1) {y : V & y ∈ v * [x, y] ∈ phi} _
                                 (H2 x (transport (fun z => x ∈ z) memb_u^ (tr (a; 1))))).
        apply hprop_allpath. intros [y (H1_y, H2_y)] [y' (H1_y', H2_y')].
        apply path_sigma_uncurried; simpl.
        exists (H3 x y y' (H2_y, H2_y')).
        apply path_ishprop.
      - destruct H as [y (H1_y, H2_y)].
        destruct (@untrunc_istrunc (-1) _ (IsEmbedding_funcofmembers y) (transport (fun z => y ∈ z) memb_v H1_y)) as [b Hb].
        exists b. exact (transport (fun z => [x, z] ∈ phi) Hb^ H2_y). }
    apply tr; exists (fun a => pr1 (h a)). apply extensionality. split.
    + intros z Hz. generalize Hz; apply Trunc_rec. intros [a Ha].
      exact (transport (fun w => w ∈ phi) Ha (pr2 (h a))).
    + intros z Hz. simpl.
      generalize (H1 z Hz). apply (Trunc_functor (-1)). intros [(a,b) p]. simpl in p.
      exists a. transitivity ([func_of_members a, func_of_members b]); auto with path_hints.
      apply ap.
      apply H3 with (func_of_members a). split.
      * exact (pr2 (h a)).
      * exact (transport (fun w => w ∈ phi) p^ Hz).
Qed.

Lemma replacement : forall (r : V -> V) (x : V),
  hexists (fun w => forall y, y ∈ w <-> hexists (fun z => z ∈ x * (r z = y))).
Proof.
  intro r. refine (V_ind_hprop _ _ _).
  intros A f _. apply tr. exists (set (r o f)). split.
  - apply (Trunc_functor (-1)).
    intros [a p]. exists (f a). split.
    + apply tr; exists a; auto.
    + assumption.
  - apply Trunc_rec.
    intros [z [h p]]. generalize h. apply (Trunc_functor (-1)).
    intros [a p']. exists a. transitivity (r z); auto with path_hints. exact (ap r p').
Qed.

Lemma separation (C : V -> HProp) : forall a : V,
  hexists (fun w => forall x, x ∈ w <-> x ∈ a * (C x)).
Proof.
  refine (V_ind_hprop _ _ _).
  intros A f _. apply tr. exists (set (fun z : {a : A & C (f a)} => f (pr1 z))). split.
  - apply Trunc_rec.
    intros [[a h] p]. split. + apply tr; exists a; assumption. + exact (transport C p h).
  - intros [H1 H2]. generalize H1. apply (Trunc_functor (-1)).
    intros [a p]. exists (a; transport C p^ H2). exact p.
Qed.

End AssumingUA.


Require Import ExtLib.Data.POption.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.Views.FuncView.
Require Import MirrorCore.syms.SymSum.

Section sum.
  Context {typ : Set}.
  Context {RT : @RType typ}.

  Context {T U V : Set}.
  Context {RSt : RSym T} {RSu : RSym U} {RSv : RSym V}.

  (** This is generic to PartialView **)
  Definition PartialView_left (FV_TU : PartialView U T)
  : PartialView (U + V) T :=
  {| f_insert := fun x => inl (f_insert x)
   ; f_view := fun x => match x with
                        | inl x => f_view x
                        | _ => pNone
                        end |}.

  Theorem PartialViewOk_left (FV : PartialView U T) (FVo : FuncViewOk _ _ _)
  : @FuncViewOk _ _ (@PartialView_left FV) _ _ (RSym_sum RSu RSv) _.
  Proof.
    constructor.
    { simpl. destruct f; simpl.
      { intros. rewrite fv_ok. split; congruence. eassumption. }
      { split; inversion 1. } }
    { simpl. intros. red. eapply fv_compat. eassumption. }
  Qed.

  Definition PartialView_right (FV_TU : PartialView U T)
  : PartialView (V + U) T :=
  {| f_insert := fun x => inr (f_insert x)
   ; f_view := fun x => match x with
                        | inr x => f_view x
                        | _ => pNone
                        end |}.

  Theorem PartialViewOk_right (FV : PartialView U T) (FVo : FuncViewOk _ _ _)
  : @FuncViewOk _ _ (@PartialView_right FV) _ _ (RSym_sum RSv RSu) _.
  Proof.
    constructor.
    { simpl. destruct f; simpl.
      { split; inversion 1. }
      { intros. rewrite fv_ok. split; congruence. eassumption. } }
    { simpl. intros. red. eapply fv_compat. eassumption. }
  Qed.

End sum.


From discprob.basic Require Import base order nify.
From discprob.basic Require Export monad.
From discprob.prob Require Import prob countable finite stochastic_order.
Require Import Reals Fourier FunctionalExtensionality Psatz.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype finset finfun bigop.

Record ldist (A: Type) := mklDist {
  outcomes :> list (R * A);
  nonneg : all  (λ r, Rle_dec 0 r) [seq r.1 | r <- outcomes];
  sum1 : \big[Rplus/0]_(a <- map fst outcomes) a == R1
 }.

Arguments outcomes {_}.
Arguments sum1 {_}.
Arguments mklDist {_}.

Lemma ldist_irrel A (l1 l2: ldist A) :
  outcomes l1 = outcomes l2 → l1 = l2.
Proof.
  destruct l1 as [l1 pf1a pf1b].
  destruct l2 as [l2 pf2a pf2b] => //.
  rewrite /outcomes => ?. subst.
  f_equal; auto; exact: bool_irrelevance.
Qed.

Global Instance dist_ret: stdpp.base.MRet ldist.
  refine (λ A x, mklDist [::(R1, x)] _ _).
Proof.
{ abstract (rewrite //= andb_true_r; destruct (Rle_dec) => //=; nra). }
{ abstract (rewrite //= big_cons big_nil; apply /eqP => //=; field). }
Defined.

Definition dist_bind_aux :=
  λ {A B} (f: A → ldist B),
  fix go (l: seq (R * A)) :=
    match l with
      [::] => [::]
    | (r, x) :: l => map (λ py, (r * py.1, py.2)%R) (f x) ++ go l
    end.

Lemma dist_bind_pf1 {A B} (f: A → ldist B) d:
  all [eta (Rle_dec 0)] [seq r.1 | r <- dist_bind_aux f (outcomes d)].
Proof.
  apply /allP => r.
  destruct d as (l, pf1, pf2).
  rewrite //=; clear pf2.
  induction l as [| a l] => //=.
  destruct a as (r'&x) => //=.
  rewrite map_cat mem_cat.
  move /orP => [Hin|Hin].
  - move /allP in pf1. specialize (pf1 r').
    destruct (f x) as [l' pf1' pf2'].
    rewrite //= in Hin; clear pf2'.
    induction l' as [|? l'] => //=.
    rewrite //= in_cons in Hin.
    move /orP in Hin. destruct Hin as [Heq|Hin'].
    * move /eqP in Heq. rewrite Heq. destruct (Rle_dec 0 (_ * _)) as [|Hn] => //=; try nra.
      exfalso; apply Hn.
      apply Rmult_le_0_compat.
      ** cut (is_true (Rle_dec 0 r')); first by destruct (Rle_dec 0 r') => //=.
         apply pf1. rewrite in_cons. apply /orP; by left.
      ** cut (is_true (Rle_dec 0 (fst a))); first by destruct (Rle_dec 0 (fst a)) => //=.
         move /allP in pf1'. apply pf1'. rewrite in_cons. apply /orP; by left.
    * eapply IHl'; eauto; intros.
      rewrite //= in pf1'. move /andP in pf1'. destruct pf1'. auto.
  - eapply IHl; eauto.
      rewrite //= in pf1. move /andP in pf1. destruct pf1. auto.
Qed.

Lemma dist_bind_pf2 {A B} (f: A → ldist B) d:
  \big[Rplus/0]_(a<-[seq i.1 | i <- dist_bind_aux f (outcomes d)]) a == 1.
Proof.
 intros. apply /eqP.  destruct d as (l, pf1, pf2).
 rewrite //=; clear pf1.
 revert pf2.  move /eqP. replace 1 with R1 by auto. generalize R1 as t.
 induction l as [| a l] => t.
 - rewrite big_nil //= => ?.
 - destruct a as (r, x); rewrite //= big_cons => Hsum.
   rewrite map_cat -map_comp big_cat //= big_map //= (IHl (t - r)%R).
   * rewrite -big_distrr //=. specialize (sum1 (f x)). move /eqP. rewrite big_map => ->. field.
   * rewrite -Hsum. ring_simplify. done.
Qed.

Global Instance dist_bind: stdpp.base.MBind ldist :=
  λ A B f d, mklDist (dist_bind_aux f (outcomes d)) (dist_bind_pf1 f d) (dist_bind_pf2 f d).

Global Program Instance dist_join: stdpp.base.MJoin ldist :=
  λ A (lld: ldist (ldist A)),
  let fix go (ls : seq (R * ldist A)) :=
  match ls with [::] => [::] | (r, l) :: ls => [seq (r * i.1, i.2) | i <- l] ++ go ls end in
  mklDist (go lld) _ _.
Next Obligation.
  apply /allP => r.
  destruct lld as (l, pf1, pf2).
  rewrite //=; clear pf2.
  induction l as [| a l] => //=.
  destruct a as (r'&x) => //=.
  rewrite map_cat mem_cat.
  move /orP => [Hin|Hin].
  - assert (0 ≤ r').
    { cut (is_true (Rle_dec 0 r')); first by destruct (Rle_dec 0 r') => //=.
      move /allP in pf1. apply pf1. rewrite in_cons //= eq_refl //. }
    clear pf1.
    destruct x as (l', pf1', pf2').
    rewrite //= in Hin. clear pf2'. induction l' as [| ? l'].
    { rewrite in_nil in Hin; done. }
    rewrite //= in_cons in Hin.
    move /orP in Hin. destruct Hin as [Heq|Hin'].
    * move /eqP in Heq. rewrite Heq.
      destruct (Rle_dec 0 (_ * _)) as [|Hn] => //=.
      contradiction Hn; apply Rmult_le_0_compat.
      ** auto.
      ** cut (is_true (Rle_dec 0 (fst a))); first by destruct (Rle_dec 0 (fst a)) => //=.
         move /allP in pf1'. apply pf1'. rewrite in_cons. apply /orP; by left.
    * eapply IHl'; eauto; intros.
      rewrite //= in pf1'. move /andP in pf1'. destruct pf1'; done.
  - eapply IHl; eauto.
    rewrite //= in pf1. move /andP in pf1. destruct pf1; done.
Qed.
Next Obligation.
 destruct lld as (l, pf1, pf2).
 apply /eqP.
 rewrite //=; clear pf1.
 revert pf2. move /eqP. generalize R1 as t.
 induction l as [| a l] => t.
 - intros. rewrite //=.
 - destruct a as (r, x); rewrite //= big_cons => Hsum.
   rewrite map_cat -map_comp big_cat //= big_map //= (IHl (t - r)%R).
   * rewrite -big_distrr //=. specialize (sum1 (x)). move /eqP. rewrite big_map => ->. field.
   * rewrite -Hsum; ring_simplify; done.
Qed.

Global Program Instance dist_fmap: stdpp.base.FMap ldist :=
  λ A B (f: A → B) (ld: ldist A),
  let fix go (l : seq (R * A)) := match l with [::] => [::] | (r, x) :: l => (r, f x) :: go l end in
  mklDist (go ld) _ _.
Next Obligation.
 apply /allP => r.
 destruct ld as (l, pf1, pf2).
 rewrite //=. clear pf2.
 induction l as [|a l] => //=.
 destruct a as (r', x) => //=.
 rewrite in_cons.
 move /orP => [Heq|Hin].
 - move /eqP in Heq. rewrite Heq.
   move /andP in pf1. apply pf1.
 - apply IHl, Hin. intros. rewrite //= in pf1. move /andP in pf1.
   destruct pf1; auto.
Qed.
Next Obligation.
 apply /eqP.
 destruct ld as (l, pf1, pf2).
 rewrite //=; clear pf1.
 revert pf2. move /eqP. generalize R1 as t.
 induction l as [| a l] => t.
 - intros. rewrite //=.
 - destruct a as (r, x); rewrite //= big_cons => Hsum.
   rewrite big_cons. rewrite (IHl (t - r)%R); first field.
   rewrite -Hsum; ring_simplify; done.
Qed.

Lemma bind_join_fmap {A B} (m: ldist A) (g: A → ldist B):
  outcomes (mbind g m) = outcomes (mjoin (fmap g m)).
Proof.
  rewrite /mbind/mjoin/fmap/dist_bind/dist_join/dist_fmap.
  destruct m as (lm, pf1m, pf2m) => //=.
  clear pf1m pf2m.
  induction lm as [|a l] => //.
  destruct a as (r, x) => //=; f_equal; done.
Qed.

Lemma in_ldist_bind {A B : eqType} (f: A → ldist B) r (x : B) (m: ldist A) :
  (r, x) \in outcomes (x ← m; f x) →
   ∃ r'' r' y, (r'', x) \in outcomes (f y)
               ∧ (r', y) \in outcomes m
               ∧ r = r' * r''.
Proof.
  rewrite /mbind/dist_bind//=.
  destruct m as (l, pf1, pf2) => //=.
  clear pf1 pf2.
  induction l as [|p l IH] => //.
  rewrite //=. destruct p as (r'&y) => //=.
  rewrite mem_cat. move /orP => [Hin1|Hintl].
  - move /mapP in Hin1. destruct Hin1 as [[r'' y'] Hin Heq].
    rewrite //= in Heq. inversion Heq; subst.
    exists r'', r', y; repeat split; auto.
    rewrite in_cons eq_refl //.
  - destruct IH as (r1&r2&y'&?&?&?); auto.
    exists r1, r2, y'; repeat split; auto.
    rewrite in_cons. apply /orP; by right.
Qed.

Lemma in_ldist_bind2 {A B : eqType} (f: A → ldist B) r' r'' (x : B) y (m: ldist A) :
   (r'', x) \in outcomes (f y) →
   (r', y) \in outcomes m →
   (r' * r'', x) \in outcomes (m ≫= f).
Proof.
  rewrite /mbind/dist_bind//=.
  destruct m as (l, pf1, pf2) => //=.
  clear pf1 pf2.
  induction l as [|p l IH] => //.
  rewrite //= => Hin1 Hin2'. destruct p as (?&?) => //=.
  rewrite mem_cat.
  rewrite in_cons in Hin2'. move /orP in Hin2'. destruct Hin2' as [Heq|Htl]; apply /orP.
  - left. move /eqP in Heq. inversion Heq; subst.
    apply /mapP. exists (r'',  x); auto.
  - right. apply IH; eauto.
Qed.

Lemma nth_lt_size {A: eqType} (d: A) m l (Hsize: (m < size l)%N):
  nth d l m \in l.
Proof.
  apply /all_nthP => //.
Qed.

(* Every ldist can be regarded as a random variable *)
Definition dist_of_ldist {A: eqType} (ld: ldist A) : distrib [finType of ordinal (size ld)].
  apply (@mkDistrib _ (λ n, (nth R0 (map fst ld) (nat_of_ord n)))).
  - destruct a as [m Hlt]; destruct ld as (l, pf1, pf2); rewrite //=.
    rewrite //= in Hlt. move /allP in pf1.
    apply Rle_ge.
    cut (is_true (Rle_dec 0 (nth 0 [seq (fst i) | i <- l] m)));
      first by (destruct (Rle_dec) => //=).
    apply /pf1/nth_lt_size. rewrite size_map //.
  - destruct ld as (l, pf1, pf2); rewrite //=. move /eqP in pf2.
    replace 1 with R1 by auto.
    rewrite -pf2 -sum_index_ordinal -SeriesF_big_op.
    apply SeriesF_is_seriesC.
Defined.

Definition ld_def {A} (ld: seq (R *A) ) (n: 'I_(size ld)) : A.
  induction ld as [|(r, x)].
  - destruct n as (n&Hlt). inversion Hlt.
  - exact x.
Qed.

Lemma sum_index_ordinal_Fpair {A: eqType} (l: seq (R * A)) F:
  \big[Rplus/0]_(a in 'I_(size l))
   F (nth 0 [seq i.1 | i <- l] a, nth (ld_def l a) [seq i.2 | i <- l] a) =
  \big[Rplus/0]_(a<- l) F a.
Proof.
    induction l as [| a l].
    * rewrite //= big_nil big_ord0 //.
    * transitivity (\big[Rplus/0%R]_(0<= a' < (size l).+1)
                     F (nth 0 ([seq i.1 | i <- a :: l]) a', (nth (snd a) ([seq i.2 | i <- a :: l]) a'))).
      { rewrite big_mkord. apply eq_bigr => ??. rewrite (set_nth_default (snd a)); first done.
        rewrite size_map. auto. }
      rewrite //= big_cons big_ltn; last auto.
      destruct a; f_equal; rewrite big_add1 //=. rewrite -IHl big_mkord.
      apply eq_bigr => i H. rewrite (set_nth_default (ld_def l i)); first done.
      rewrite size_map. done.
Qed.

Definition rvar_of_ldist {A: eqType} (ld: ldist A) : rvar (dist_of_ldist ld) A :=
  mkRvar (dist_of_ldist ld) (λ n, (nth (ld_def ld n) (map snd ld) (nat_of_ord n))).

(* There must be some nice way to do this... I really need to learn ssreflect better *)
Lemma setP_help {A: finType} (P: A -> bool) (i: A):
  (pred_of_set [set x | P x]) i = P i.
Proof.
  rewrite -in_set.
  transitivity (i \in [set x | P x]); first by rewrite in_set.
  rewrite in_set. done.
Qed.

Lemma pr_rvar_ldist {A: eqType} (ld: ldist A) r :
  pr_eq (rvar_of_ldist ld) r = \big[Rplus/0%R]_(a <- outcomes ld | snd a == r) fst a.
Proof.
  rewrite /pr_eq/pr.
  rewrite SeriesC_fin_big -big_mkcondr.
  rewrite /dist_of_ldist //=.
  apply (sum_index_ordinal_P _ _ (R0, r)) => //= i.
  rewrite (nth_map (nth (0, r) ld i)) //.
  rewrite (set_nth_default (0, r)) //.
Qed.

Lemma pr_gt_rvar_ldist (ld: ldist R) r :
  pr_gt (rvar_of_ldist ld) r = \big[Rplus/0%R]_(a <- outcomes ld | Rgt_dec (snd a) r) fst a.
Proof.
  rewrite /pr_gt/pr.
  rewrite SeriesC_fin_big -big_mkcondr.
  rewrite /dist_of_ldist //=.
  apply (sum_index_ordinal_P _ _ (R0, r)) => //= i.
  rewrite (nth_map (nth (0, r) ld i)) //.
  rewrite (set_nth_default (0, r)) //.
Qed.

Lemma sum_mjoin {B: eqType} (lld: ldist (ldist B)) P:
  \big[Rplus/0]_(a <- outcomes (mjoin lld) | P (snd a)) a.1 =
  \big[Rplus/0]_(ld <- lld) \big[Rplus/0]_(a <- ld.2 | P (snd a)) (ld.1 * a.1).
Proof.
  destruct lld as (lld, pf1, pf2) => //=.
  clear pf1 pf2.
  induction lld as [|[r ld] lld] => //=.
  { rewrite ?big_nil //. }
  rewrite big_cons big_cat //=.
  f_equal; eauto.
  rewrite big_map //=.
Qed.

Lemma sum_fmap {A B} (f: A → B) (ld: ldist A) F:
  \big[Rplus/0]_(x <- outcomes (f <$> ld)) (F (x.1) (x.2)) =
  \big[Rplus/0]_(x <- ld) (F (x.1) (f x.2)).
Proof.
  destruct ld as (ld, pf1, pf2) => //=.
  clear pf1 pf2.
  induction ld as [|[r x] ld] => //=.
  { rewrite ?big_nil //. }
  rewrite ?big_cons //=.
  f_equal; eauto.
Qed.

Lemma nat_of_ord_map_iota {A} n (F: nat → A):
  [seq (F (nat_of_ord i)) | i <- enum 'I_n] =
  [seq (F i) | i <- iota 0%N n].
Proof.
    by rewrite -val_enum_ord map_comp.
Qed.

Lemma nat_of_ord_map_iota' {A} n (F: nat → A):
  [seq (F (nat_of_ord i)) | i <- Finite.enum [finType of 'I_n]] =
  [seq (F i) | i <- iota 0%N n].
Proof.
  rewrite -nat_of_ord_map_iota. f_equal.
  rewrite -enumT//=.
Qed.

Lemma map_nth_iota {A: eqType} (l: seq A) a:
      [seq nth a l i | i <- iota 0 (size l)] = l.
Proof.
  induction l => //=.
  replace 1%nat with (1 + 0)%nat by auto with *.
  rewrite iota_addl -map_comp; f_equal => //=.
Qed.

Lemma img_rvar_of_ldist {A: eqType} (h: ldist A):
  map sval (Finite.enum [finType of (imgT (rvar_of_ldist h))]) = undup [seq i.2 | i <- h].
Proof.
  rewrite {1}[@Finite.enum]unlock //=. rewrite img_fin_enum_sval.
  assert (a: A).
  { destruct h as (l, pf1, pf2). destruct l.
    - rewrite big_nil in pf2. move /eqP in pf2. exfalso.
      rewrite //= in pf2. fourier.
    - exact (snd p).
  }
  f_equal.
  etransitivity.
  - apply (@eq_map _ _ _ (λ n, nth a [seq i.2 | i <- h] (nat_of_ord n))).
    { intro i. erewrite set_nth_default; auto. rewrite size_map. done. }
  - rewrite -enumT. rewrite (nat_of_ord_map_iota (size h) (λ n, nth a [seq (snd i) | i <- h] n)).
  destruct h as (l, pf1, pf2) => //=; clear pf1 pf2.
  rewrite -(size_map snd l) map_nth_iota //.
Qed.

Lemma img_rvar_of_ldist' {A: eqType} (h: ldist A) a:
  a \in img (rvar_of_ldist h) = (a \in undup [seq (snd i) | i <- h]).
Proof.
  apply (introTF (exCP _)); case: ifP.
  - rewrite mem_undup. move /mapP. intros [x Hin Heq]; subst.
    rewrite //=.
    assert (index (snd x) (map snd h) < size h)%nat as Hsize.
    { rewrite -(size_map snd) index_mem. apply /mapP. eexists; eauto. }
    exists (Ordinal Hsize) => //=.
    rewrite nth_index => //=. apply /mapP. eexists; eauto.
  - rewrite mem_undup => Hfalse. intros (x&Heq).
    move /negP in Hfalse. apply Hfalse. move /eqP in Heq.
    rewrite -Heq. rewrite //=. apply nth_lt_size. rewrite size_map. destruct x. auto.
Qed.

(* Lemmas for simplifying monadic expressions *)
Lemma pr_mbind_ldist1 {A B: eqType} (h: ldist A) (f: A → ldist B) (b: B) :
  pr_eq (rvar_of_ldist (mbind f h)) b =
  \big[Rplus/0]_(a : imgT (rvar_of_ldist h))
   (pr_eq (rvar_of_ldist h) (sval a) * pr_eq (rvar_of_ldist (f (sval a))) b).
Proof.
  transitivity (Ex (rvar_comp (rvar_of_ldist h) (λ a, pr_eq (rvar_of_ldist (f a)) b))); last first.
  { rewrite Ex_fin_comp. eapply eq_bigr => ??. field. }
  rewrite pr_rvar_ldist Ex_fin_pt.
  symmetry. etransitivity.
  { apply eq_bigr => ?? /=. rewrite !pr_rvar_ldist. done. }
  rewrite bind_join_fmap.
  rewrite (sum_mjoin _ (λ x, x == b)).
  rewrite (sum_fmap f h (λ x y, \big[Rplus/0]_(a <- y | a.2 == b) (x * a.1))).
  rewrite /index_enum.
  rewrite //= (sum_index_ordinal_Fpair _ (λ xy,
     \big[Rplus/0]_(a <- f (xy.2) | a.2 == b) a.1 * (xy.1))).
  eapply eq_bigr => x _.
  rewrite Rmult_comm.
  rewrite big_distrr //.
Qed.

Lemma pr_mbind_ldist2 {A B: eqType} (h: ldist A) (f: A → ldist B) (b: B) :
  pr_eq (rvar_of_ldist (mbind f h)) b =
  \big[Rplus/0]_(a <- undup [seq i.2 | i <- h])
   (pr_eq (rvar_of_ldist h) a * pr_eq (rvar_of_ldist (f a)) b).
Proof.
  rewrite -img_rvar_of_ldist pr_mbind_ldist1 //.
  rewrite big_map //=.
Qed.

Lemma pr_mret_simpl {A: eqType} (x y: A):
  pr_eq (rvar_of_ldist (mret x)) y = if (x == y) then 1 else 0.
Proof.
  rewrite pr_rvar_ldist big_cons big_nil //=. case: ifP => ?; field.
Qed.

Lemma pr_mbind_mret {A B: eqType} (h: ldist A) (f: A → B) (b: B) :
  pr_eq (rvar_of_ldist (mbind (λ x, mret (f x)) h)) b =
  pr_eq (rvar_comp (rvar_of_ldist h) f) b.
Proof.
  rewrite pr_mbind_ldist1 //.
  symmetry. rewrite {1}/pr_eq pr_eq_alt_comp.
  eapply eq_bigr => a _.
  rewrite pr_mret_simpl.
  case: ifP => ?; rewrite //= ?Rmult_1_r ?Rmult_0_r; done.
Qed.

Lemma pr_mbind_mret_inj {A B: eqType} (h: ldist A) (f: A → B) (a: A) :
  injective f →
  pr_eq (rvar_of_ldist (mbind (λ x, mret (f x)) h)) (f a)=
  pr_eq (rvar_of_ldist h) a.
Proof.
  intros Hinj.
  rewrite pr_mbind_mret //= {1}/pr_eq pr_eq_alt_comp.
  rewrite {2}/pr_eq pr_eq_alt.
  eapply eq_bigr => i _. symmetry.
  case: ifP; move /eqP.
  * intros Heq1. rewrite Heq1 eq_refl. done.
  * intros Hneq. case: ifP; auto. move /eqP. intros Heq.
    apply Hinj in Heq. congruence.
Qed.

Lemma pr_mbind_mret_inj0 {A B: eqType} (h: ldist A) (f: A → B) (b: B) :
  (∀ a, f a ≠ b) →
  pr_eq (rvar_of_ldist (mbind (λ x, mret (f x)) h)) b = 0.
Proof.
  intros Hneq. rewrite pr_mbind_mret {1}/pr_eq pr_eq_alt_comp.
  apply big1 => i _. case: ifP; auto. move /eqP => Heq. exfalso.
  apply (Hneq (sval i)); auto.
Qed.

Lemma pr_gt_mbind_ldist1 {A: eqType} (h: ldist A) (f: A → ldist R) (b: R) :
  pr_gt (rvar_of_ldist (mbind f h)) b =
  \big[Rplus/0]_(a : imgT (rvar_of_ldist h))
   (pr_eq (rvar_of_ldist h) (sval a) * pr_gt (rvar_of_ldist (f (sval a))) b).
Proof.
  transitivity (Ex (rvar_comp (rvar_of_ldist h) (λ a, pr_gt (rvar_of_ldist (f a)) b))); last first.
  { rewrite Ex_fin_comp. eapply eq_bigr => ??. field. }
  rewrite pr_gt_rvar_ldist Ex_fin_pt.
  symmetry. etransitivity.
  { apply eq_bigr => ?? /=. rewrite !pr_gt_rvar_ldist. done. }
  rewrite bind_join_fmap.
  rewrite (sum_mjoin _ (λ x, Rgt_dec x b)).
  rewrite (sum_fmap f h (λ x y, \big[Rplus/0]_(a <- y | Rgt_dec a.2 b) (x * a.1))).
  rewrite /index_enum.
  rewrite //= (sum_index_ordinal_Fpair _ (λ xy,
     \big[Rplus/0]_(a <- f (xy.2) | Rgt_dec a.2 b) a.1 * (xy.1))).
  eapply eq_bigr => x _.
  rewrite Rmult_comm.
  rewrite big_distrr //.
Qed.

Lemma pr_gt_mbind_ldist2 {A: eqType} (h: ldist A) (f: A → ldist R) (b: R) :
  pr_gt (rvar_of_ldist (mbind f h)) b =
  \big[Rplus/0]_(a <- undup [seq i.2 | i <- h])
   (pr_eq (rvar_of_ldist h) a * pr_gt (rvar_of_ldist (f a)) b).
Proof.
  rewrite -img_rvar_of_ldist pr_gt_mbind_ldist1 //.
  rewrite big_map //=.
Qed.

Lemma pr_gt_mret_simpl (x y: R):
  pr_gt (rvar_of_ldist (mret x)) y = if (Rgt_dec x y) then 1 else 0.
Proof.
  rewrite pr_gt_rvar_ldist big_cons big_nil //=.
  destruct Rgt_dec => //=; try fourier; try nra.
Qed.

Lemma pr_gt_mbind_mret {A: eqType} (h: ldist A) (f: A → R) (b: R) :
  pr_gt (rvar_of_ldist (mbind (λ x, mret (f x)) h)) b =
  pr_gt (rvar_comp (rvar_of_ldist h) f) b.
Proof.
  rewrite pr_gt_mbind_ldist1 //.
  symmetry. rewrite {1}/pr_gt pr_gt_alt_comp.
  eapply eq_bigr => a _.
  rewrite pr_gt_mret_simpl.
  destruct Rgt_dec => //=; rewrite ?Rmult_1_r ?Rmult_0_r //=.
Qed.

Lemma Ex_mbind_ldist1 {A: eqType} (h: ldist A) (f: A → ldist R) :
  Ex (rvar_of_ldist (mbind f h)) =
  \big[Rplus/0]_(a : imgT (rvar_of_ldist h))
   (pr_eq (rvar_of_ldist h) (sval a) * Ex (rvar_of_ldist (f (sval a)))).
Proof.
  rewrite /Ex. rewrite SeriesC_fin_big.
  f_equal; etransitivity.
  {eapply eq_bigr => x _. rewrite pr_mbind_ldist1. rewrite big_distrl //. }
  rewrite exchange_big.
  apply eq_bigr => x _.
  rewrite SeriesC_fin_big.
  rewrite big_distrr //=.
  rewrite /index_enum//=.
  rewrite -(big_map sval (λ x, true) (λ i, _ * pr_eq _ i * i)).
  rewrite -(big_map sval (λ x, true) (λ i, _ * (pr_eq _ i * i))).
  rewrite img_rvar_of_ldist.
  rewrite (img_rvar_of_ldist (dist_bind _ _ f h)).
  eapply sum_reidx_map_sym with (h := id).
  - intros; rewrite //=. rewrite //=. rewrite Rmult_assoc. done.
  - intros ? Hin' ? Hnin. rewrite (pr_img_nin (rvar_of_ldist (f (sval x)))); first by ring.
    rewrite img_rvar_of_ldist'. auto.
  - intros ? Hin' ? Hnin. exfalso. apply Hnin.
    destruct x as (x&Hin).
    rewrite //= in Hin'. rewrite img_rvar_of_ldist' in Hin.
    rewrite ?mem_undup in Hin Hin'.
    move /mapP in Hin.
    move /mapP in Hin'.
    destruct Hin as [(r'&x') Hin1 ?]; subst.
    destruct Hin' as [(r''&y'') Hin2 ?]; subst.
    specialize (in_ldist_bind2 f _ _ _ _ h Hin2 Hin1).
    rewrite //= => Hin_comb.
    exists y''.  rewrite mem_undup; split; auto.
    apply /mapP; auto.
    exists (r' * r'', y''); auto.
  - apply undup_uniq.
  - apply undup_uniq.
  - intros ??; done.
Qed.

Lemma Ex_mbind_ldist2 {A: eqType} (h: ldist A) (f: A → ldist R) :
  Ex (rvar_of_ldist (mbind f h)) =
  \big[Rplus/0]_(a <- undup [seq i.2 | i <- h]) (pr_eq (rvar_of_ldist h) a * Ex (rvar_of_ldist (f a))).
Proof.
  rewrite -img_rvar_of_ldist Ex_mbind_ldist1 //.
  rewrite big_map //=.
Qed.

Lemma Ex_mret_simpl (x: R):
  Ex (rvar_of_ldist (mret x)) = x.
Proof.
  rewrite /Ex SeriesC_fin_big /index_enum.
  rewrite -(big_map sval (λ x, true) (λ i, pr_eq _ i * i)).
  rewrite img_rvar_of_ldist //= big_cons big_nil.
  rewrite pr_mret_simpl eq_refl. f_equal; field.
Qed.

Lemma Ex_mbind_mret {A: eqType} (h: ldist A) (f: A → R) :
  Ex (rvar_of_ldist (mbind (λ x, mret (f x)) h)) =
  Ex (rvar_comp (rvar_of_ldist h) f).
Proof.
  rewrite Ex_mbind_ldist1 //.
  rewrite Ex_fin_comp.
  eapply eq_bigr => a _.
  rewrite Ex_mret_simpl.
  f_equal.
Qed.

Lemma outcomes_eq_dist {A: eqType} (r1 r2: ldist A) :
  outcomes r1 = outcomes r2 →
  eq_dist (rvar_of_ldist r1) (rvar_of_ldist r2).
Proof.
  rewrite /eq_dist => Heq x.
  rewrite ?pr_rvar_ldist Heq. done.
Qed.

Lemma ldist_left_id {A B: eqType} (x: A) (f: A → ldist B):
  mbind f (mret x) = f x.
Proof.
  apply ldist_irrel => //=. rewrite cats0.
  rewrite (@eq_map _ _ _ id); first by apply map_id.
  intros (?&?) => //=; f_equal; auto; ring_simplify; done.
Qed.

Lemma ldist_right_id {A: eqType} (m: ldist A) :
  mbind mret m = m.
Proof.
  apply ldist_irrel => //=. induction (outcomes m) as [| a l] => //=.
  destruct a as (?&?) => //=; f_equal; auto.
  rewrite Rmult_1_r. done.
Qed.

Lemma ldist_assoc {A B C: eqType} (m: ldist A) (f: A → ldist B) (g: B → ldist C) :
  mbind g (mbind f m) = mbind (λ x, mbind g (f x)) m.
Proof.
  apply ldist_irrel.
  destruct m as [m pf1 pf2] => //=.
  clear pf1 pf2.
  assert (Haux: ∀ A B (f: A → ldist B) l1 l2, dist_bind_aux f (l1 ++ l2) =
                               dist_bind_aux  f l1 ++ dist_bind_aux f l2).
  { induction l1 as [| a l] => //=.
    intros. destruct a as (r&x).
    rewrite IHl catA. done.
  }
  induction m as [| a l]; first by rewrite //=.
  destruct a as (r&x).
  rewrite //= Haux; eauto.
  f_equal; eauto.
  clear -Haux. induction (outcomes (f x)) as [| a' l'] => //=.
  destruct a' as (r'&x'). rewrite map_cat; f_equal; eauto.
  rewrite -map_comp => //=.
  apply eq_map => c.
  destruct c as (r''&x'') => //=.
  f_equal; auto; field.
Qed.

Lemma ldist_bind_ext {A B: eqType} m (f g: A → ldist B):
  (∀ a, f a = g a) →
  mbind f m = mbind g m.
Proof.
  destruct m as [l pf1 pf2] => Hext //=.
  rewrite /dist_bind.
  apply ldist_irrel => //=.
  clear pf1 pf2. induction l as [| a l] => //=.
  destruct a as (r, x). by rewrite IHl Hext.
Qed.

Lemma ldist_fmap_bind {A B C: eqType} m (h: A → B) (f: B → ldist C):
  mbind f (x ← m; mret (h x)) = mbind (λ x, f (h x)) m.
Proof.
  rewrite ldist_assoc.
  apply ldist_bind_ext => a. rewrite ldist_left_id. done.
Qed.

Lemma eq_dist_ldist_bind_ext {A B: eqType} m (f g: A → ldist B):
  (∀ a, eq_dist (rvar_of_ldist (f a)) (rvar_of_ldist (g a))) →
  eq_dist (rvar_of_ldist (mbind f m)) (rvar_of_ldist (mbind g m)).
Proof.
  rewrite /eq_dist => Heq b. rewrite ?pr_mbind_ldist2.
  eapply eq_bigr => a _. rewrite Heq. done.
Qed.

Lemma le_dist_ldist_bind_ext {A: eqType} m (f g: A → ldist R):
  (∀ a k, pr_gt (rvar_of_ldist (f a)) k <= pr_gt (rvar_of_ldist (g a)) k) →
  (∀ k, pr_gt (rvar_of_ldist (mbind f m)) k <= pr_gt (rvar_of_ldist (mbind g m)) k).
Proof.
  rewrite /eq_dist => Heq b. rewrite ?pr_gt_mbind_ldist2.
  apply Rle_bigr => a _. apply Rmult_le_compat_l.
  * apply Rge_le, pr_eq_ge_0.
  * done.
Qed.

Lemma eq_dist_ldist_bind_congr {A B: eqType} m m' (f g: A → ldist B):
  eq_dist (rvar_of_ldist m) (rvar_of_ldist m') →
  (∀ a, eq_dist (rvar_of_ldist (f a)) (rvar_of_ldist (g a))) →
  eq_dist (rvar_of_ldist (mbind f m)) (rvar_of_ldist (mbind g m')).
Proof.
  rewrite /eq_dist => Hdist Heq b. rewrite ?pr_mbind_ldist2.
  rewrite bigop_cond_non0 [a in _ = a]bigop_cond_non0.
  eapply (sum_reidx_map _ _ _ _ id).
  - intros. rewrite Hdist Heq. done.
  - rewrite //=; intros a Hin Hnon0. rewrite -?img_rvar_of_ldist'; split.
    * apply pr_img. rewrite -Hdist. move /eqP in Hnon0.
      edestruct (ge_pr_0 (rvar_dist (rvar_of_ldist m))) as [|Heq0]; first by eauto.
      rewrite /pr_eq//= in Hnon0. rewrite Heq0 in Hnon0. nra.
    * rewrite -Heq -Hdist. done.
  - rewrite //= => a Hin. rewrite -?img_rvar_of_ldist' => Hnon0 Hfalse.
    exfalso; apply Hfalse. exists a.
    rewrite Heq Hdist; split; auto.
    rewrite -?img_rvar_of_ldist'.
    apply pr_img. rewrite Hdist. move /eqP in Hnon0.
    edestruct (ge_pr_0 (rvar_dist (rvar_of_ldist m'))) as [|Heq0]; first by eauto.
    rewrite /pr_eq in Hnon0. rewrite Heq0 in Hnon0. nra.
  - apply undup_uniq.
  - apply undup_uniq.
  - done.
Qed.

Lemma ldist_bind_swap {A B C: eqType} (m1: ldist A) (m2: ldist B) (f: A → B → ldist C):
  eq_dist (rvar_of_ldist (a ← m1;
                            b ← m2;
                            f a b))
          (rvar_of_ldist (b ← m2;
                            a ← m1;
                            f a b)).
Proof.
  intros c.
  rewrite ?pr_mbind_ldist2.
  etransitivity.
  { eapply eq_bigr. intros. rewrite pr_mbind_ldist2. rewrite big_distrr //. }
  symmetry.
  etransitivity.
  { eapply eq_bigr. intros. rewrite pr_mbind_ldist2. rewrite big_distrr //. }
  rewrite exchange_big.
  do 2 (eapply eq_bigr => ??).
  rewrite //=. nra.
Qed.

Lemma pr_eq_bind_pair {A B: eqType} (m1: ldist A) (m2: ldist B) (a: A) (b: B):
  pr_eq (rvar_of_ldist (a ← m1; b ← m2; mret (a, b))) (a, b) =
  pr_eq (rvar_of_ldist m1) a * pr_eq (rvar_of_ldist m2) b.
Proof.
  rewrite ?pr_mbind_ldist2.
  etransitivity.
  { eapply eq_bigr. intros a' _.
    rewrite pr_mbind_ldist2. apply Rmult_eq_compat_l.
    eapply eq_bigr. intros b' _.
    rewrite pr_mret_simpl.
    transitivity (pr_eq (rvar_of_ldist (mret a')) a *
                     (pr_eq (rvar_of_ldist m2) b' *
                      pr_eq (rvar_of_ldist (mret b')) b)); last done.
    rewrite ?pr_mret_simpl.
    case: ifP; move /eqP => Heq.
    - inversion Heq as [[Heqa Heqb]].
      subst. rewrite ?eq_refl. nra.
    - case: ifP; move /eqP => Heqa.
      { case: ifP; move /eqP => Heqb.
        * subst. congruence.
        * nra.
      }
      nra.
  }
  etransitivity.
  {
    eapply eq_bigr. intros. rewrite -big_distrr.
    rewrite -pr_mbind_ldist2. rewrite -Rmult_assoc. done.
  }
  rewrite -big_distrl. rewrite ldist_right_id //=; f_equal.
  specialize (pr_mbind_ldist2 m1 (λ x, mret x)) => //=. intros <-.
  (* For some reason I cannot just do the appropriate rewrite... *)
  assert (Hfinal: ∀ {A: eqType} (m1: ldist A) a,
             pr_eq (rvar_of_ldist (x ← m1; mret x)) a = pr_eq (rvar_of_ldist m1) a).
  { intros.  rewrite ldist_right_id. done. }
  eapply Hfinal.
Qed.

Lemma eq_dist_bind_rvar_pair {A B: eqType} (m1: ldist A) (m2: ldist B):
  eq_dist (rvar_of_ldist (a ← m1; b ← m2; mret (a, b)))
          (rvar_pair (rvar_of_ldist m1) (rvar_of_ldist m2)).
Proof.
  intros (a&b). rewrite pr_eq_bind_pair pr_eq_rvar_pair //.
Qed.

Program Definition bernoulli (p: R) (Hrange: (0 <= p <= 1)%R) : ldist bool :=
  mklDist [:: (p, true) ; (1 - p, false)%R] _ _.
Next Obligation.
  repeat (apply /andP; split; auto); destruct (Rle_dec) => //. nra.
Qed.
Next Obligation.
  rewrite ?big_cons ?big_nil; apply /eqP => //=; field.
Qed.

Lemma pr_bernoulli_true (p: R) (Hrange: 0 <= p <= 1):
  pr_eq (rvar_of_ldist (bernoulli p Hrange)) true = p.
Proof.
  rewrite pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
Qed.

Lemma pr_bernoulli_false (p: R) (Hrange: 0 <= p <= 1):
  pr_eq (rvar_of_ldist (bernoulli p Hrange)) false = 1 - p.
Proof.
  rewrite pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
Qed.

Module test.

  Program Definition test1 : ldist (bool * bool) :=
    x ← bernoulli (1/2) _ ;
    y ← bernoulli (1/2) _;
    mret (x, y).
  Next Obligation. split; fourier. Qed.
  Next Obligation. split; fourier. Qed.

  (* Eval compute in (outcomes test1). *)

  Definition von_neumann_coin (p: R) (Hrange: 0 <= p <= 1): ldist (option bool) :=
    x ← bernoulli p Hrange;
    y ← bernoulli p Hrange;
    match x, y with
      | true, false => mret (Some true)
      | false, true => mret (Some false)
      | _, _ => mret None
    end.

  Fixpoint von_neumann_repeat (p: R) (Hrange: 0 <= p <= 1) (n: nat): ldist (option bool) :=
    match n with
      | 0 => mret None
      | S n' =>
        res ← von_neumann_coin p Hrange;
        match res with
          | None => von_neumann_repeat p Hrange n'
          | _ => mret res
        end
    end.

  Lemma range_three_fourths: 0 <= 3/4 <= 1. Proof. split; fourier. Qed.
  (* Eval compute in (outcomes (von_neumann_coin (3/4) range_three_fourths)). *)

  Lemma von_neumann_fair (p: R) (Hrange: 0 <= p <= 1) :
    pr_eq (rvar_of_ldist (von_neumann_coin p Hrange)) (Some true) =
    pr_eq (rvar_of_ldist (von_neumann_coin p Hrange)) (Some false).
  Proof.
    rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
  Qed.

  Lemma von_neumann_fail (p: R) (Hrange: 0 <= p <= 1) :
    pr_eq (rvar_of_ldist (von_neumann_coin p Hrange)) None =
    1 - 2 * (p * (1 - p)).
  Proof.
    rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
  Qed.

  (* These are not yet the most efficient ways to prove these;
     mainly ``brute-force'' computation; see below for a way that uses
     facts about monadic operations and a simple 'coupling' argument *)
  Lemma von_neumann_repeat_fair (p: R) (Hrange: 0 <= p <= 1) n :
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) (Some true) =
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) (Some false).
  Proof.
    induction n.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=.
      rewrite ?big_cat //=. f_equal.
      * rewrite ?big_map //= -?big_distrr; f_equal.
        by rewrite ?pr_rvar_ldist in IHn.
      * rewrite ?cats0.
        rewrite ?big_cons //=; f_equal; first field.
        rewrite ?big_map //= -?big_distrr; f_equal.
        by rewrite ?pr_rvar_ldist in IHn.
  Qed.

  Lemma von_neumann_repeat_fail n (p: R) (Hrange: 0 <= p <= 1) :
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) None =
    (1 - 2 * (p * (1 - p)))^n.
  Proof.
    induction n.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=.
      rewrite ?cats0 ?big_cat //=.
      rewrite ?pr_rvar_ldist in IHn.
      rewrite ?big_map -?big_distrr //= IHn.
      rewrite ?big_cons //=.
      rewrite ?big_map //= -?big_distrr //= IHn.
      field.
  Qed.

  Lemma von_neumann_repeat_fair' (p: R) (Hrange: 0 <= p <= 1) n :
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) (Some true) =
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) (Some false).
  Proof.
    induction n.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=.
    - rewrite !pr_mbind_ldist2.
      (* Coupling *)
      eapply (sum_reidx_surj2 _ _ _ _ _ _
                            (λ a, match a with | Some b => Some (negb b) | None => None end )).
      * destruct a => ?.
        ** f_equal; destruct s; rewrite ?von_neumann_fair //=;
          rewrite (pr_rvar_ldist (dist_ret _ (Some true)));
          rewrite (pr_rvar_ldist (dist_ret _ (Some false)));
          rewrite //= ?big_cons ?big_nil //=; try field.
        ** f_equal. eauto.
      * intros [[|]|]; rewrite //=.
      * intros [[|]|]; rewrite //=.
      * apply undup_uniq.
      * apply undup_uniq.
      * intros [[|]|] [[|]|] => //=.
  Qed.

  Lemma von_neumann_repeat_fail' n (p: R) (Hrange: 0 <= p <= 1) :
    pr_eq (rvar_of_ldist (von_neumann_repeat p Hrange n)) None =
    (1 - 2 * (p * (1 - p)))^n.
  Proof.
    induction n.
    - rewrite ?pr_rvar_ldist //= ?big_cons ?big_nil //=. field.
    - rewrite pr_mbind_ldist2.
      rewrite {1}/von_neumann_coin.
      rewrite ?big_cons ?big_nil IHn //=.
      rewrite von_neumann_fail //=.
      rewrite ?pr_mret_simpl //=; field.
  Qed.

End test.


(** Authors: Jianzhou Zhao. *)

Require Export Bang_OParametricity_Pre.
Require Import Bang_Renaming.
Require Import Program.

Module Type IOParametricity.

(* ********************************************************************** *)
(** * Axioms for atoms *)

Axiom typvars_neq_termvars : forall X x E (lE:lenv),
  X `in` ddom_env E ->
  x `in` dom lE ->
  X <> x.

Axiom disjoint_termvars : forall (lEnv:lenv) (gsubst:gamma_subst),
  disjoint lEnv gsubst.

(* ********************************************************************** *)
(** * Wf Relations *)

Definition wfor (E:env) (r : rel) (T T' : typ) : Prop :=
  (wf_typ E T) /\
  (wf_typ E T')
  .

Axiom wfor_inv : forall E r T T',
  wfor E r T T'->
  (wf_typ E T) /\
  (wf_typ E T')
  .

Axiom wfor_left_inv : forall E t t' R,
  wfor E R t t' -> wf_typ E t.

Axiom wfor_right_inv : forall E t t' R,
  wfor E R t t' -> wf_typ E t'.

(* ********************************************************************** *)
(** * Value Relations *)
Program Fixpoint F_Related_ovalues
    (t:typ) (rsubst:rho_subst)
    (dsubst dsubst':delta_subst) (v:exp) (v':exp) (Env:env) (lEnv:lenv) {measure typ_size t} : Prop :=
  match t with
  | typ_fvar X =>
    exists R,
    (binds X R rsubst) /\ (value v) /\ (value v') /\ (R v v')
  | typ_arrow t1 t2 =>
    (value v) /\ (value v') /\
    (forall lEnv1 x x',
       typing Env lEnv1 x (apply_delta_subst_typ dsubst t1) ->
       typing Env lEnv1 x' (apply_delta_subst_typ dsubst' t1) ->
       wf_lenv Env (lEnv1++lEnv) ->
       (exists w, exists w',
        normalize x w /\ normalize x' w' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' w w' Env lEnv1) ->
       (exists u, exists u',
        normalize (exp_app v x) u /\
        normalize (exp_app v' x') u' /\
        F_Related_ovalues t2 rsubst dsubst dsubst' u u' Env (lEnv1++lEnv))
    )
  | typ_all t1 =>
      (
      (value v) /\ (value v') /\
      (exists L,
         (forall (X:atom) t2 t2' R (Fr:X `notin` L),
          wfor Env R t2 t2' ->
          X `notin` ((dom rsubst) `union` (fv_tt t1)) ->
          (exists w, exists w',
          normalize (exp_tapp v t2) w /\
          normalize (exp_tapp v' t2') w' /\
          F_Related_ovalues (open_tt t1 X)
                           ([(X,R)]++rsubst)
                           ([(X,t2)]++dsubst)
                           ([(X,t2')]++dsubst')
                            w w' Env lEnv)
        ))
      )
  | typ_bang t1 =>
    (value v) /\ (value v') /\
    (exists e1, exists e1',
      v = exp_bang e1 /\
      v' = exp_bang e1' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv)
    )
  | typ_with t1 t2 =>
    (value v) /\ (value v') /\
    (exists e1, exists e2, exists e1', exists e2',
      v = exp_apair e1 e2 /\
      v' = exp_apair e1' e2' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv) /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_Related_ovalues t2 rsubst dsubst dsubst' u2 u2' Env lEnv)
    )
  | _ => False
  end
  .
Obligation 1.
  simpl. omega.
Qed.
Next Obligation.
  rewrite <- Heq_t. simpl. omega.
Qed.
Next Obligation.
  simpl.
  assert (typ_size (open_tt t1 X) = typ_size t1). apply open_tt_typ_size_eq.
  omega.
Qed.
Next Obligation.
  simpl.  omega.
Qed.
Next Obligation.
  simpl.  omega.
Qed.
Next Obligation.
  split.
    intros t1 t2. unfold not. intro C. inversion C.
  split.
    intros t1. unfold not. intro C. inversion C.
  split.
    intros t1. unfold not. intro C. inversion C.
  split.
    intros t1 t2. unfold not. intro C. inversion C.
    intros X. unfold not. intro C. inversion C.
Qed.

(** * Term Relations *)
Definition F_Related_oterms t rsubst (dsubst dsubst':delta_subst) e e' Env lEnv: Prop:=
    exists v, exists v',
    typing Env lEnv e (apply_delta_subst_typ dsubst t) /\
    typing Env lEnv e' (apply_delta_subst_typ dsubst' t) /\
    normalize e v /\
    normalize e' v' /\
    F_Related_ovalues t rsubst dsubst dsubst' v v' Env lEnv
  .

(** * Subst Relations *)
Inductive F_Related_osubst : env -> lenv -> gamma_subst -> gamma_subst -> gamma_subst -> gamma_subst -> rho_subst -> delta_subst -> delta_subst -> env -> lenv -> Prop:=
  | F_Related_osubst_empty :
    forall Env,
      wf_env Env ->
      F_Related_osubst nil nil gamma_nil gamma_nil gamma_nil gamma_nil rho_nil delta_nil delta_nil Env nil
  | F_Related_osubst_kind :
    forall (E:env) (lE:lenv) (gsubst gsubst' lgsubst lgsubst':gamma_subst) (rsubst:rho_subst) (dsubst dsubst':delta_subst) Env lEnv X R t t',
      F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
      X `notin` (fv_env E) `union` (fv_lenv lE) `union`  (fv_env Env) `union` (fv_lenv lEnv) ->
      wfor Env R t t' ->
      F_Related_osubst ([(X, bind_kn)]++E) lE gsubst gsubst' lgsubst lgsubst'
                                   ([(X,R)]++rsubst) ([(X,t)]++dsubst) ([(X,t')]++dsubst') Env lEnv
  | F_Related_osubst_typ :
    forall (E:env)(lE:lenv)(gsubst gsubst' lgsubst lgsubst':gamma_subst) (e e':exp) (t:typ) (rsubst:rho_subst) (dsubst dsubst':delta_subst) Env lEnv (x:atom),
      F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
      typing Env lempty e (apply_delta_subst_typ dsubst t) ->
      typing Env lempty e' (apply_delta_subst_typ dsubst' t) ->
      F_Related_oterms t rsubst dsubst dsubst' e e' Env lempty ->
      x `notin` ((fv_env E) `union` (fv_lenv lE) `union` (fv_tt t)) `union`  (fv_env Env) `union` (fv_lenv lEnv) ->
      wf_typ E t ->
      F_Related_osubst ([(x, bind_typ t)]++E) lE
                   ([(x, e)]++gsubst) ([(x, e')]++gsubst') lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv
  | F_Related_osubst_ltyp :
    forall (E:env)(lE:lenv)(gsubst gsubst' lgsubst lgsubst':gamma_subst) (e e':exp) (t:typ) (rsubst:rho_subst) (dsubst dsubst':delta_subst) Env lEnv1 lEnv2 (x:atom),
      F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv1 ->
      typing Env lEnv2 e (apply_delta_subst_typ dsubst t) ->
      typing Env lEnv2 e' (apply_delta_subst_typ dsubst' t) ->
      disjoint E lEnv2 /\ disjoint lE lEnv2 ->
      wf_lenv Env (lEnv2++lEnv1) ->
      F_Related_oterms t rsubst dsubst dsubst' e e' Env lEnv2 ->
      x `notin` ((fv_env E) `union` (fv_lenv lE) `union` (fv_tt t)) `union`  (fv_env Env) `union` (fv_lenv lEnv1) `union` (fv_lenv lEnv2) ->
      wf_typ E t ->
      F_Related_osubst E ([(x, lbind_typ t)]++lE)
                   gsubst gsubst' ([(x, e)]++lgsubst) ([(x, e')]++lgsubst') rsubst dsubst dsubst' Env (lEnv2++lEnv1)
      .

Tactic Notation "F_Related_osubst_cases" tactic(first) tactic(c) :=
  first;
  [ c "F_Related_osubst_empty" |
    c "F_Related_osubst_kind" |
    c "F_Related_osubst_typ" |
    c "F_Related_osubst_ltyp" ].

(** * Relations Subst *)
Inductive F_Rosubst : env-> rho_subst-> delta_subst -> delta_subst -> env -> Prop:=
  | F_Rosubst_empty :
    forall Env,
      wf_env Env ->
      F_Rosubst nil rho_nil delta_nil delta_nil Env
  | F_Rosubst_rel :
    forall (E:env) (rsubst:rho_subst) (dsubst:delta_subst) (dsubst':delta_subst) Env R t t' X,
      F_Rosubst E rsubst dsubst dsubst' Env ->
      wfor Env R t t' ->
      X `notin` (fv_env E) `union` (fv_env Env)->
      F_Rosubst ([(X, bind_kn)]++E) ([(X, R)]++rsubst) ([(X, t)]++dsubst) ([(X, t')]++dsubst') Env
  | F_Rosubst_typ :
    forall (E:env) (rsubst:rho_subst) (dsubst:delta_subst) (dsubst':delta_subst) Env x T,
      F_Rosubst E rsubst dsubst dsubst' Env ->
      wf_typ E T ->
      x `notin` (fv_env E) `union` (fv_env Env)->
      F_Rosubst ([(x, bind_typ T)]++E) rsubst dsubst dsubst' Env
      .

Tactic Notation "F_Rosubst_cases" tactic(first) tactic(c) :=
  first;
  [ c "F_Rosubst_empty" |
    c "F_Rosubst_rel" |
    c "F_Rosubst_typ" ].

(** * SystemF Relations *)
Definition F_ORel t rsubst (dsubst dsubst':delta_subst) Env lEnv v v' :=
   typing Env lEnv v (apply_delta_subst_typ dsubst t) /\
   typing Env lEnv v' (apply_delta_subst_typ dsubst' t) /\
   F_Related_ovalues t rsubst dsubst dsubst' v v' Env lEnv
  .

(** * A Family of SystemF Relations *)
Definition F_FORel t rsubst (dsubst dsubst':delta_subst) Env v v' :=
   exists lEnv, F_ORel t rsubst dsubst dsubst' Env lEnv v v'
  .

Hint Constructors F_Related_osubst F_Rosubst.

(* ********************************************************************** *)
(* Fvalue simplification *)
Axiom F_Related_ovalues_bvar_eq: forall i (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_bvar i) rsubst dsubst dsubst' v v' Env lEnv <-> False.

Axiom F_Related_ovalues_bvar_leq: forall i (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_bvar i) rsubst dsubst dsubst' v v' Env lEnv -> False.

Axiom F_Related_ovalues_bvar_req: forall i (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  False ->
  F_Related_ovalues (typ_bvar i) rsubst dsubst dsubst' v v' Env lEnv.

Axiom F_Related_ovalues_fvar_eq: forall X (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_fvar X) rsubst dsubst dsubst' v v' Env lEnv <->
    exists R,
      (binds X R rsubst) /\ (value v) /\ (value v') /\ (R v v')
  .

Axiom F_Related_ovalues_fvar_leq: forall X  (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_fvar X) rsubst dsubst dsubst' v v' Env lEnv ->
    exists R,
      (binds X R rsubst) /\ (value v) /\ (value v') /\ (R v v')
  .

Axiom F_Related_ovalues_fvar_req: forall X  (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  (exists R,
    (binds X R rsubst) /\ (value v) /\ (value v') /\ (R v v')) ->
  F_Related_ovalues (typ_fvar X) rsubst dsubst dsubst' v v' Env lEnv.

Axiom F_Related_ovalues_arrow_eq: forall (t1 t2:typ)  (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_arrow t1 t2) rsubst dsubst dsubst' v v' Env lEnv
  <->
  (
    (value v) /\ (value v') /\
    (forall lEnv1 x x',
       typing Env lEnv1 x (apply_delta_subst_typ dsubst t1) ->
       typing Env lEnv1 x' (apply_delta_subst_typ dsubst' t1) ->
       wf_lenv Env (lEnv1++lEnv) ->
       (exists w, exists w',
        normalize x w /\ normalize x' w' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' w w' Env lEnv1) ->
       (exists u, exists u',
        normalize (exp_app v x) u /\
        normalize (exp_app v' x') u' /\
        F_Related_ovalues t2 rsubst dsubst dsubst' u u' Env (lEnv1++lEnv))
    )
  )
   .

Axiom F_Related_ovalues_arrow_leq: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_arrow t1 t2) rsubst dsubst dsubst' v v' Env lEnv
  ->
  (
    (value v) /\ (value v') /\
    (forall lEnv1 x x',
       typing Env lEnv1 x (apply_delta_subst_typ dsubst t1) ->
       typing Env lEnv1 x' (apply_delta_subst_typ dsubst' t1) ->
       wf_lenv Env (lEnv1++lEnv) ->
       (exists w, exists w',
        normalize x w /\ normalize x' w' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' w w' Env lEnv1) ->
       (exists u, exists u',
        normalize (exp_app v x) u /\
        normalize (exp_app v' x') u' /\
        F_Related_ovalues t2 rsubst dsubst dsubst' u u' Env (lEnv1++lEnv))
    )
  )
   .

Axiom F_Related_ovalues_arrow_req: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  (
    (value v) /\ (value v') /\
    (forall lEnv1 x x',
       typing Env lEnv1 x (apply_delta_subst_typ dsubst t1) ->
       typing Env lEnv1 x' (apply_delta_subst_typ dsubst' t1) ->
       wf_lenv Env (lEnv1++lEnv) ->
       (exists w, exists w',
        normalize x w /\ normalize x' w' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' w w' Env lEnv1) ->
       (exists u, exists u',
        normalize (exp_app v x) u /\
        normalize (exp_app v' x') u' /\
        F_Related_ovalues t2 rsubst dsubst dsubst' u u' Env (lEnv1++lEnv))
    )
  ) ->
  F_Related_ovalues (typ_arrow t1 t2) rsubst dsubst dsubst' v v' Env lEnv
   .

Axiom F_Related_ovalues_all_eq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_all t1) rsubst dsubst dsubst' v v' Env lEnv
  <->
      (
      (value v) /\ (value v') /\
      (exists L,
         (forall (X:atom) t2 t2' R (Fr:X `notin` L),
         wfor Env R t2 t2' ->
          X `notin` ((dom rsubst) `union` (fv_tt t1)) ->
          (exists w, exists w',
          normalize (exp_tapp v t2) w /\
          normalize (exp_tapp v' t2') w' /\
          F_Related_ovalues (open_tt t1 X)
                           ([(X, R)]++rsubst)
                           ([(X, t2)]++dsubst)
                           ([(X, t2')]++dsubst')
                            w w' Env lEnv)
        ))
      )
  .

Axiom F_Related_ovalues_all_leq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_all t1) rsubst dsubst dsubst' v v' Env lEnv
  ->
      (
      (value v) /\ (value v') /\
      (exists L,
         (forall (X:atom) t2 t2' R (Fr:X `notin` L),
         wfor Env R t2 t2' ->
          X `notin` ((dom rsubst) `union` (fv_tt t1)) ->
          (exists w, exists w',
          normalize (exp_tapp v t2) w /\
          normalize (exp_tapp v' t2') w' /\
          F_Related_ovalues (open_tt t1 X)
                           ([(X, R)]++rsubst)
                           ([(X, t2)]++dsubst)
                           ([(X, t2')]++dsubst')
                            w w' Env lEnv)
        ))
      )
  .

Axiom F_Related_ovalues_all_req: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
      (
      (value v) /\ (value v') /\
      (exists L,
         (forall (X:atom) t2 t2' R (Fr:X `notin` L),
         wfor Env R t2 t2' ->
          X `notin` ((dom rsubst) `union` (fv_tt t1)) ->
          (exists w, exists w',
          normalize (exp_tapp v t2) w /\
          normalize (exp_tapp v' t2') w' /\
          F_Related_ovalues (open_tt t1 X)
                           ([(X, R)]++rsubst)
                           ([(X, t2)]++dsubst)
                           ([(X, t2')]++dsubst')
                            w w' Env lEnv)
        ))
      )
  ->
  F_Related_ovalues (typ_all t1) rsubst dsubst dsubst' v v' Env lEnv
  .

Axiom F_Related_ovalues_bang_eq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_bang t1) rsubst dsubst dsubst' v v' Env lEnv
  <->
    (value v) /\ (value v') /\
    (exists e1, exists e1',
      v = exp_bang e1 /\
      v' = exp_bang e1' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv)
    )
   .

Axiom F_Related_ovalues_bang_leq: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_bang t1) rsubst dsubst dsubst' v v' Env lEnv
  ->
    (value v) /\ (value v') /\
    (exists e1, exists e1',
      v = exp_bang e1 /\
      v' = exp_bang e1' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv)
    )
   .

Axiom F_Related_ovalues_bang_req: forall (t1:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
    (value v) /\ (value v') /\
    (exists e1, exists e1',
      v = exp_bang e1 /\
      v' = exp_bang e1' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv)
    )
  ->
  F_Related_ovalues (typ_bang t1) rsubst dsubst dsubst' v v' Env lEnv
   .

Axiom F_Related_ovalues_with_eq: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_with t1 t2) rsubst dsubst dsubst' v v' Env lEnv
  <->
    (value v) /\ (value v') /\
    (exists e1, exists e2, exists e1', exists e2',
      v = exp_apair e1 e2 /\
      v' = exp_apair e1' e2' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv) /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_Related_ovalues t2 rsubst dsubst dsubst' u2 u2' Env lEnv)
    )
   .

Axiom F_Related_ovalues_with_leq: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
  F_Related_ovalues (typ_with t1 t2) rsubst dsubst dsubst' v v' Env lEnv
  ->
    (value v) /\ (value v') /\
    (exists e1, exists e2, exists e1', exists e2',
      v = exp_apair e1 e2 /\
      v' = exp_apair e1' e2' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv) /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_Related_ovalues t2 rsubst dsubst dsubst' u2 u2' Env lEnv)
    )
   .

Axiom F_Related_ovalues_with_req: forall (t1 t2:typ) (rsubst:rho_subst)(dsubst dsubst':delta_subst)(v v':exp) Env lEnv,
    (value v) /\ (value v') /\
    (exists e1, exists e2, exists e1', exists e2',
      v = exp_apair e1 e2 /\
      v' = exp_apair e1' e2' /\
      (exists u1, exists u1',
       normalize e1 u1 /\
       normalize e1' u1' /\
       F_Related_ovalues t1 rsubst dsubst dsubst' u1 u1' Env lEnv) /\
      (exists u2, exists u2',
       normalize e2 u2 /\
       normalize e2' u2' /\
       F_Related_ovalues t2 rsubst dsubst dsubst' u2 u2' Env lEnv)
    )
  ->
  F_Related_ovalues (typ_with t1 t2) rsubst dsubst dsubst' v v' Env lEnv
   .

(* ********************************************************************** *)
(** * Inversion *)

Axiom F_Related_ovalues_inversion: forall t v v' rsubst dsubst dsubst' Env lEnv,
  F_Related_ovalues t rsubst dsubst dsubst' v v' Env lEnv ->
  ((value v)* (value v'))%type.

Axiom F_Rosubst__wf_osubst:
  forall (E:env) (rsubst:rho_subst) (dsubst:delta_subst) (dsubst':delta_subst) Env,
  F_Rosubst E rsubst dsubst dsubst' Env ->
  ((wf_delta_osubst E dsubst Env) * (wf_delta_osubst E dsubst' Env) * (wf_rho_subst E rsubst))%type.

Axiom Forel_inversion: forall t rsubst dsubst dsubst' v v' Env lEnv,
  F_ORel t rsubst dsubst dsubst' Env lEnv v v' ->
  ((value v)* (value v'))%type.

Axiom Fforel_inversion: forall t rsubst dsubst dsubst' v v' Env,
  F_FORel t rsubst dsubst dsubst' Env v v' ->
  ((value v)* (value v'))%type.

Axiom F_Related_osubst__inversion:
  forall (E:env) (lE:lenv) (rsubst:rho_subst) (dsubst:delta_subst) (dsubst':delta_subst) gsubst gsubst' lgsubst lgsubst' Env lEnv,
  F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
  ((wf_delta_osubst E dsubst Env) * (wf_delta_osubst E dsubst' Env) *
   (wf_lgamma_osubst E lE dsubst gsubst lgsubst Env lEnv)* (wf_lgamma_osubst E lE dsubst' gsubst' lgsubst' Env lEnv) *
   (wf_rho_subst E rsubst) * (wf_env E) * (wf_lenv E lE) * (wf_env Env) * (wf_lenv Env lEnv))%type.

(*******************************************************************************)
(** Dom Equal *)

Axiom Forel_lin_domeq : forall t rsubst dsubst dsubst' e e' Env lEnv lEnv',
  F_Related_ovalues t rsubst dsubst dsubst' e e' Env lEnv ->
  wf_lenv Env lEnv ->
  dom lEnv [=] dom lEnv' ->
  F_Related_ovalues t rsubst dsubst dsubst' e e' Env lEnv'.

(* **************************************** *)
(** * Weaken and Stronger of SystemF Relations *)

Axiom Forel_weaken:  forall t E E' v v' rsubst rsubst' dsubst dsubst' dsubst0 dsubst'0 Env lEnv X R t2 t2',
  ((F_Related_ovalues t (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') v v' Env lEnv ->
  ddom_env E [=] dom dsubst ->
  ddom_env E [=] dom dsubst' ->
  ddom_env E' [=] dom dsubst0 ->
  ddom_env E' [=] dom dsubst'0 ->
  ddom_env E [=] dom rsubst ->
  ddom_env E' [=] dom rsubst' ->
  X `notin` (fv_env E `union` fv_env E' `union` (fv_tt t) `union` fv_env Env `union` fv_lenv lEnv)->
  wf_typ Env t2 ->
  wf_typ Env t2' ->
  wf_rho_subst (E'++E) (rsubst'++rsubst) ->
  wf_delta_osubst (E'++E) (dsubst0++dsubst) Env ->
  wf_delta_osubst (E'++E) (dsubst'0++dsubst') Env ->
  F_Related_ovalues t (rsubst'++[(X, R)]++rsubst) (dsubst0++[(X, t2)]++dsubst) (dsubst'0++[(X, t2')]++dsubst') v v' Env lEnv))
  .

Axiom Forel_weaken_head:  forall t E v v' rsubst dsubst dsubst' Env lEnv X R t2 t2',
  ((F_Related_ovalues t rsubst dsubst dsubst' v v' Env lEnv ->
  ddom_env E [=] dom dsubst ->
  ddom_env E [=] dom dsubst' ->
  ddom_env E [=] dom rsubst ->
  X `notin` (fv_env E `union` (fv_tt t) `union` fv_env Env `union` fv_lenv lEnv)->
  wf_typ Env t2 ->
  wf_typ Env t2' ->
  wf_rho_subst E rsubst ->
  wf_delta_osubst E dsubst Env ->
  wf_delta_osubst E dsubst' Env ->
  F_Related_ovalues t ([(X, R)]++rsubst) ([(X, t2)]++dsubst) ([(X, t2')]++dsubst') v v' Env lEnv))
  .

Axiom Forel_stronger:  forall t E E' v v' rsubst rsubst' dsubst dsubst' dsubst0 dsubst'0 Env lEnv X R t2 t2',
  F_Related_ovalues t (rsubst'++[(X,R)]++rsubst) (dsubst0++[(X,t2)]++dsubst) (dsubst'0++[(X,t2')]++dsubst') v v' Env lEnv ->
  ddom_env E [=] dom dsubst ->
  ddom_env E [=] dom dsubst' ->
  ddom_env E' [=] dom dsubst0 ->
  ddom_env E' [=] dom dsubst'0 ->
  ddom_env E [=] dom rsubst ->
  ddom_env E' [=] dom rsubst' ->
  X `notin` (fv_env E `union` fv_env E' `union` (fv_tt t) `union` fv_env Env `union` fv_lenv lEnv)->
  wf_typ Env t2 ->
  wf_typ Env t2' ->
  wf_rho_subst (E'++[(X,bind_kn)]++E) (rsubst'++[(X,R)]++rsubst) ->
  wf_delta_osubst (E'++[(X,bind_kn)]++E) (dsubst0++[(X,t2)]++dsubst) Env ->
  wf_delta_osubst (E'++[(X,bind_kn)]++E) (dsubst'0++[(X,t2')]++dsubst') Env ->
  F_Related_ovalues t (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') v v' Env lEnv
  .

Axiom bindosgE__bindosgsubst: forall E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv x T,
    F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
    binds x (bind_typ T) E ->
    wf_typ E T ->
    x `notin` dom lgsubst /\ x `notin` dom lgsubst' /\
    (exists e, exists e',
                ((binds x (e) gsubst)
                *(binds x (e') gsubst')
                *(typing Env lempty e (apply_delta_subst_typ dsubst T))*(typing Env lempty e' (apply_delta_subst_typ dsubst' T))
                *(F_Related_oterms T rsubst dsubst dsubst' e e' Env lempty))%type)
    .

Axiom lbindosgE__lbindosgsubst: forall E gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv x T,
    F_Related_osubst E [(x, lbind_typ T)] gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
    wf_typ E T ->
    x `notin` dom gsubst /\ x `notin` dom gsubst' /\
    (exists e, exists e',
                ((binds x (e) lgsubst)
                *(binds x (e') lgsubst')
                *(typing Env lEnv e (apply_delta_subst_typ dsubst T))*(typing Env lEnv e' (apply_delta_subst_typ dsubst' T))
                *(F_Related_oterms T rsubst dsubst dsubst' e e' Env lEnv))%type)
    .

(*******************************************************************************)
(** subst *)

Definition F_ORel__R (t:typ) (E:env) (rsubst:rho_subst) dsubst dsubst' Env lEnv (R:rel) :=
  wf_delta_osubst E dsubst Env /\  wf_delta_osubst E dsubst' Env /\  wf_rho_subst E rsubst /\
  (forall v v',
    ((F_ORel t rsubst dsubst dsubst' Env lEnv v v' -> R v v')
   * (R v v'->F_ORel t rsubst dsubst dsubst' Env lEnv v v')) % type)
  .

Definition F_FORel__R (t:typ) (E:env) (rsubst:rho_subst) dsubst dsubst' Env (R:rel) :=
  wf_delta_osubst E dsubst Env /\  wf_delta_osubst E dsubst' Env /\  wf_rho_subst E rsubst /\
  (forall v v',
    ((F_FORel t rsubst dsubst dsubst' Env v v' -> R v v')
   * (R v v'->F_FORel t rsubst dsubst dsubst' Env v v')) % type)
  .

Axiom F_FORel__R__wfor: forall (E:env) (t:typ) (rsubst:rho_subst) dsubst dsubst' Env (R:rel),
  F_FORel__R t E rsubst dsubst dsubst' Env R ->
  wf_typ E t ->
  wfor Env R (apply_delta_subst_typ dsubst t) (apply_delta_subst_typ dsubst' t).

Axiom oparametricity_subst_value : forall t E E' e e' rsubst rsubst' dsubst dsubst' dsubst0 dsubst'0 Env lEnv X R t2 k,
  wf_typ (E'++[(X, bind_kn)]++E) (open_tt_rec k (typ_fvar X) t) ->
  wf_typ (E'++E) (open_tt_rec k t2 t) ->
  wf_typ (E'++E) t2 ->
  F_FORel__R t2 (E'++E) (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') Env R ->
  X `notin` (fv_env E `union` fv_env E' `union` (fv_tt t) `union` (fv_te e) `union` (fv_te e') `union` fv_env Env `union` fv_lenv lEnv)->
  ddom_env E [=] dom dsubst ->
  ddom_env E [=] dom dsubst' ->
  ddom_env E' [=] dom dsubst0 ->
  ddom_env E' [=] dom dsubst'0 ->
  ddom_env E [=] dom rsubst ->
  ddom_env E' [=] dom rsubst' ->
  (F_Related_ovalues (open_tt_rec k (typ_fvar X) t) (rsubst'++[(X, R)]++rsubst ) (dsubst0++[(X, (apply_delta_subst_typ (dsubst0++dsubst) t2))]++dsubst) (dsubst'0++[(X,(apply_delta_subst_typ (dsubst'0++dsubst') t2))]++dsubst') e e' Env lEnv ->
  typing Env lEnv e (apply_delta_subst_typ (dsubst0++[(X,(apply_delta_subst_typ (dsubst0++dsubst) t2))]++dsubst) (open_tt_rec k (typ_fvar X) t)) ->
  typing Env lEnv e' (apply_delta_subst_typ (dsubst'0++[(X,(apply_delta_subst_typ (dsubst'0++dsubst') t2))]++dsubst') (open_tt_rec k (typ_fvar X) t)) ->
  wf_rho_subst (E'++[(X, bind_kn)]++E) (rsubst'++[(X, R)]++rsubst) ->
  wf_delta_osubst (E'++[(X, bind_kn)]++E) (dsubst0++[(X, (apply_delta_subst_typ (dsubst0++dsubst) t2))]++dsubst) Env ->
  wf_delta_osubst (E'++[(X, bind_kn)]++E) (dsubst'0++[(X, (apply_delta_subst_typ (dsubst'0++dsubst') t2))]++dsubst') Env ->
  F_Related_ovalues (open_tt_rec k t2 t) (rsubst'++rsubst) (dsubst0++dsubst) (dsubst'0++dsubst') e e' Env lEnv)
  .

(*******************************************************************************)
(** F_Related_osubst_split *)

Axiom F_Related_osubst_split: forall E lE lE1 lE2 dsubst dsubst' gsubst gsubst' lgsubst lgsubst' rsubst Env lEnv,
   F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
   lenv_split E lE1 lE2 lE ->
   exists lgsubst1, exists lgsubst1', exists lgsubst2, exists lgsubst2', exists lEnv1, exists lEnv2,
     lgamma_osubst_split E lE dsubst gsubst lgsubst1 lgsubst2 lgsubst Env lEnv1 lEnv2 lEnv /\
     lgamma_osubst_split E lE dsubst' gsubst' lgsubst1' lgsubst2' lgsubst' Env lEnv1 lEnv2 lEnv  /\
     F_Related_osubst E lE1 gsubst gsubst' lgsubst1 lgsubst1' rsubst dsubst dsubst' Env lEnv1 /\
     F_Related_osubst E lE2 gsubst gsubst' lgsubst2 lgsubst2' rsubst dsubst dsubst' Env lEnv2.

(*******************************************************************************)
(** parametricity *)

Axiom oparametricity: forall E lE e t dsubst dsubst' gsubst gsubst' lgsubst lgsubst' rsubst Env lEnv,
   typing E lE e t ->
   F_Related_osubst E lE gsubst gsubst' lgsubst lgsubst' rsubst dsubst dsubst' Env lEnv ->
   F_Rosubst E rsubst dsubst dsubst' Env->
   F_Related_oterms t rsubst dsubst dsubst'
                                 (apply_delta_subst dsubst (apply_gamma_subst gsubst (apply_gamma_subst lgsubst e)))
                                 (apply_delta_subst dsubst' (apply_gamma_subst gsubst' (apply_gamma_subst lgsubst' e)))
                                 Env lEnv
   .

End IOParametricity.

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../../../metatheory" "-I" "../Bang") ***
*** End: ***
 *)


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Floating-point format with abrupt underflow *)

From Coq Require Import Lia.
Require Import Raux Defs Round_pred Generic_fmt.
Require Import Float_prop Ulp FLX.

Section RND_FTZ.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.

Context { prec_gt_0_ : Prec_gt_0 prec }.

Inductive FTZ_format (x : R) : Prop :=
  FTZ_spec (f : float beta) :
    x = F2R f ->
    (x <> 0%R -> Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z ->
    (emin <= Fexp f)%Z ->
    FTZ_format x.

Definition FTZ_exp e := if Zlt_bool (e - prec) emin then (emin + prec - 1)%Z else (e - prec)%Z.

(** Properties of the FTZ format *)
Global Instance FTZ_exp_valid : Valid_exp FTZ_exp.
Proof.
intros k.
unfold FTZ_exp.
generalize (Zlt_cases (k - prec) emin).
case (Zlt_bool (k - prec) emin) ; intros H1.
split ; intros H2.
lia.
split.
generalize (Zlt_cases (emin + prec + 1 - prec) emin).
case (Zlt_bool (emin + prec + 1 - prec) emin) ; intros H3.
lia.
generalize (Zlt_cases (emin + prec - 1 + 1 - prec) emin).
generalize (prec_gt_0 prec).
case (Zlt_bool (emin + prec - 1 + 1 - prec) emin) ; lia.
intros l H3.
generalize (Zlt_cases (l - prec) emin).
case (Zlt_bool (l - prec) emin) ; lia.
split ; intros H2.
generalize (Zlt_cases (k + 1 - prec) emin).
case (Zlt_bool (k + 1 - prec) emin) ; lia.
generalize (prec_gt_0 prec).
split ; intros ; lia.
Qed.

Theorem FLXN_format_FTZ :
  forall x, FTZ_format x -> FLXN_format beta prec x.
Proof.
intros x [[xm xe] Hx1 Hx2 Hx3].
eexists.
exact Hx1.
exact Hx2.
Qed.

Theorem generic_format_FTZ :
  forall x, FTZ_format x -> generic_format beta FTZ_exp x.
Proof.
intros x Hx.
cut (generic_format beta (FLX_exp prec) x).
apply generic_inclusion_mag.
intros Zx.
destruct Hx as [[xm xe] Hx1 Hx2 Hx3].
simpl in Hx2, Hx3.
specialize (Hx2 Zx).
assert (Zxm: xm <> Z0).
contradict Zx.
rewrite Hx1, Zx.
apply F2R_0.
unfold FTZ_exp, FLX_exp.
rewrite Zlt_bool_false.
apply Z.le_refl.
rewrite Hx1, mag_F2R with (1 := Zxm).
cut (prec - 1 < mag beta (IZR xm))%Z.
clear -Hx3 ; lia.
apply mag_gt_Zpower with (1 := Zxm).
apply Hx2.
apply generic_format_FLXN.
now apply FLXN_format_FTZ.
Qed.

Theorem FTZ_format_generic :
  forall x, generic_format beta FTZ_exp x -> FTZ_format x.
Proof.
intros x Hx.
destruct (Req_dec x 0) as [->|Hx3].
exists (Float beta 0 emin).
apply sym_eq, F2R_0.
intros H.
now elim H.
apply Z.le_refl.
unfold generic_format, scaled_mantissa, cexp, FTZ_exp in Hx.
destruct (mag beta x) as (ex, Hx4).
simpl in Hx.
specialize (Hx4 Hx3).
generalize (Zlt_cases (ex - prec) emin) Hx. clear Hx.
case (Zlt_bool (ex - prec) emin) ; intros Hx5 Hx2.
elim Rlt_not_ge with (1 := proj2 Hx4).
apply Rle_ge.
rewrite Hx2, <- F2R_Zabs.
rewrite <- (Rmult_1_l (bpow ex)).
unfold F2R. simpl.
apply Rmult_le_compat.
now apply IZR_le.
apply bpow_ge_0.
apply IZR_le.
apply (Zlt_le_succ 0).
apply lt_IZR.
apply Rmult_lt_reg_r with (bpow (emin + prec - 1)).
apply bpow_gt_0.
rewrite Rmult_0_l.
change (0 < F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (emin + prec - 1))))) (emin + prec - 1)))%R.
rewrite F2R_Zabs, <- Hx2.
now apply Rabs_pos_lt.
apply bpow_le.
lia.
rewrite Hx2.
eexists ; repeat split ; simpl.
apply le_IZR.
rewrite IZR_Zpower.
apply Rmult_le_reg_r with (bpow (ex - prec)).
apply bpow_gt_0.
rewrite <- bpow_plus.
replace (prec - 1 + (ex - prec))%Z with (ex - 1)%Z by ring.
change (bpow (ex - 1) <= F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)))%R.
rewrite F2R_Zabs, <- Hx2.
apply Hx4.
apply Zle_minus_le_0.
now apply (Zlt_le_succ 0).
apply lt_IZR.
rewrite IZR_Zpower.
apply Rmult_lt_reg_r with (bpow (ex - prec)).
apply bpow_gt_0.
rewrite <- bpow_plus.
replace (prec + (ex - prec))%Z with ex by ring.
change (F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)) < bpow ex)%R.
rewrite F2R_Zabs, <- Hx2.
apply Hx4.
now apply Zlt_le_weak.
now apply Z.ge_le.
Qed.

Theorem FTZ_format_satisfies_any :
  satisfies_any FTZ_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FTZ_exp)).
intros x.
split.
apply FTZ_format_generic.
apply generic_format_FTZ.
Qed.

Theorem FTZ_format_FLXN :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  FLXN_format beta prec x -> FTZ_format x.
Proof.
intros x Hx Fx.
apply FTZ_format_generic.
apply generic_format_FLXN in Fx.
revert Hx Fx.
apply generic_inclusion_ge.
intros e He.
unfold FTZ_exp.
rewrite Zlt_bool_false.
apply Z.le_refl.
lia.
Qed.

Theorem ulp_FTZ_0 :
  ulp beta FTZ_exp 0 = bpow (emin+prec-1).
Proof with auto with typeclass_instances.
unfold ulp; rewrite Req_bool_true; trivial.
case (negligible_exp_spec FTZ_exp).
intros T; specialize (T (emin-1)%Z); contradict T.
apply Zle_not_lt; unfold FTZ_exp; unfold Prec_gt_0 in prec_gt_0_.
rewrite Zlt_bool_true; lia.
assert (V:(FTZ_exp (emin+prec-1) = emin+prec-1)%Z).
unfold FTZ_exp; rewrite Zlt_bool_true; lia.
intros n H2; rewrite <-V.
apply f_equal, fexp_negligible_exp_eq...
lia.
Qed.

Section FTZ_round.

(** Rounding with FTZ *)
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Definition Zrnd_FTZ x :=
  if Rle_bool 1 (Rabs x) then rnd x else Z0.

Global Instance valid_rnd_FTZ : Valid_rnd Zrnd_FTZ.
Proof with auto with typeclass_instances.
split.
(* *)
intros x y Hxy.
unfold Zrnd_FTZ.
case Rle_bool_spec ; intros Hx ;
  case Rle_bool_spec ; intros Hy.
4: easy.
(* 1 <= |x| *)
now apply Zrnd_le.
rewrite <- (Zrnd_IZR rnd 0).
apply Zrnd_le...
apply Rle_trans with (-1)%R. 2: now apply IZR_le.
destruct (Rabs_ge_inv _ _ Hx) as [Hx1|Hx1].
exact Hx1.
elim Rle_not_lt with (1 := Hx1).
apply Rle_lt_trans with (2 := Hy).
apply Rle_trans with (1 := Hxy).
apply RRle_abs.
(* |x| < 1 *)
rewrite <- (Zrnd_IZR rnd 0).
apply Zrnd_le...
apply Rle_trans with 1%R.
now apply IZR_le.
destruct (Rabs_ge_inv _ _ Hy) as [Hy1|Hy1].
elim Rle_not_lt with (1 := Hy1).
apply Rlt_le_trans with (2 := Hxy).
apply (Rabs_def2 _ _ Hx).
exact Hy1.
(* *)
intros n.
unfold Zrnd_FTZ.
rewrite Zrnd_IZR...
case Rle_bool_spec.
easy.
rewrite <- abs_IZR.
intros H.
generalize (lt_IZR _ 1 H).
clear.
now case n ; trivial ; simpl ; intros [p|p|].
Qed.

Theorem round_FTZ_FLX :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  round beta FTZ_exp Zrnd_FTZ x = round beta (FLX_exp prec) rnd x.
Proof.
intros x Hx.
unfold round, scaled_mantissa, cexp.
destruct (mag beta x) as (ex, He). simpl.
assert (Hx0: x <> 0%R).
intros Hx0.
apply Rle_not_lt with (1 := Hx).
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
specialize (He Hx0).
assert (He': (emin + prec <= ex)%Z).
apply (bpow_lt_bpow beta).
apply Rle_lt_trans with (1 := Hx).
apply He.
replace (FTZ_exp ex) with (FLX_exp prec ex).
unfold Zrnd_FTZ.
rewrite Rle_bool_true.
apply refl_equal.
rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow (- FLX_exp prec ex))).
change 1%R with (bpow 0).
rewrite <- (Zplus_opp_r (FLX_exp prec ex)).
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rle_trans with (2 := proj1 He).
apply bpow_le.
unfold FLX_exp.
generalize (prec_gt_0 prec).
clear -He' ; lia.
apply bpow_ge_0.
unfold FLX_exp, FTZ_exp.
rewrite Zlt_bool_false.
apply refl_equal.
clear -He' ; lia.
Qed.

Theorem round_FTZ_small :
  forall x : R,
  (Rabs x < bpow (emin + prec - 1))%R ->
  round beta FTZ_exp Zrnd_FTZ x = 0%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0.
apply round_0...
unfold round, scaled_mantissa, cexp.
destruct (mag beta x) as (ex, He). simpl.
specialize (He Hx0).
unfold Zrnd_FTZ.
rewrite Rle_bool_false.
apply F2R_0.
rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow (- FTZ_exp ex))).
change 1%R with (bpow 0).
rewrite <- (Zplus_opp_r (FTZ_exp ex)).
rewrite bpow_plus.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
unfold FTZ_exp.
generalize (Zlt_cases (ex - prec) emin).
case Zlt_bool.
intros _.
apply Z.le_refl.
intros He'.
elim Rlt_not_le with (1 := Hx).
apply Rle_trans with (2 := proj1 He).
apply bpow_le.
lia.
apply bpow_ge_0.
Qed.

End FTZ_round.

End RND_FTZ.


Require Import extraInv.
Local Open Scope Z.

Definition cond2 :=
 ctrlState1.[of_Z timer1]=ctrlWaiting /\ hands1.[of_Z timer1]=ON /\ dryer2=dryer1.[of_Z timer1 <- ON] /\ ctrlTimer2=0 /\
ctrlState2=ctrlState1.[of_Z timer1 <- ctrlDrying].