(* Distributed under the terms of the MIT license. *)
From Coq Require Import ssreflect.
From MetaCoq.Template Require Import config utils.
From MetaCoq.PCUIC Require Import PCUICTyping PCUICEquality PCUICAst PCUICAstUtils
  PCUICWeakeningConv PCUICWeakeningTyp PCUICSubstitution PCUICGeneration PCUICArities
  PCUICWcbvEval PCUICSR PCUICInversion
  PCUICUnivSubstitutionConv PCUICUnivSubstitutionTyp
  PCUICElimination PCUICSigmaCalculus PCUICContextConversion
  PCUICUnivSubst PCUICWeakeningEnvConv PCUICWeakeningEnvTyp
  PCUICCumulativity PCUICConfluence
  PCUICInduction PCUICLiftSubst PCUICContexts PCUICSpine
  PCUICConversion PCUICValidity PCUICInductives PCUICConversion
  PCUICInductiveInversion PCUICNormal PCUICSafeLemmata
  PCUICParallelReductionConfluence
  PCUICWcbvEval PCUICClosed PCUICClosedTyp
  PCUICReduction PCUICCSubst PCUICOnFreeVars PCUICWellScopedCumulativity PCUICCanonicity PCUICWcbvEval.

From Equations Require Import Equations.

Lemma eval_tCase {cf : checker_flags} {Σ : global_env_ext}  ci p discr brs res T :
  wf Σ ->
  Σ ;;; [] |- tCase ci p discr brs : T ->
  eval Σ (tCase ci p discr brs) res ->
  ∑ c u args, red Σ [] (tCase ci p discr brs) (tCase ci p ((mkApps (tConstruct ci.(ci_ind) c u) args)) brs).
Proof.
  intros wf wt H. depind H; try now (cbn in *; congruence).
  - eapply inversion_Case in wt as (? & ? & ? & ? & cinv & ?); eauto.
    eexists _, _, _. eapply red_case_c. eapply wcbeval_red. 2: eauto. eapply cinv.
  - eapply inversion_Case in wt as wt'; eauto. destruct wt' as (? & ? & ? & ? & cinv & ?).
    assert (Hred1 : Σ;;; [] |- tCase ip p discr brs ⇝* tCase ip p (mkApps fn args) brs). {
      etransitivity. { eapply red_case_c. eapply wcbeval_red. 2: eauto. eapply cinv. }
      econstructor. econstructor.
      rewrite closed_unfold_cofix_cunfold_eq. eauto.
      enough (closed (mkApps (tCoFix mfix idx) args)) as Hcl by (rewrite closedn_mkApps in Hcl; solve_all).
      eapply eval_closed. eauto.
      2: eauto. eapply @subject_closed with (Γ := []); eauto. eapply cinv. tea.
    }
    edestruct IHeval2 as (c & u & args0 & IH); eauto using subject_reduction.
    exists c, u, args0. etransitivity; eauto.
Qed.

Local Existing Instance config.extraction_checker_flags.

Inductive typing_spine_pred {cf : checker_flags} Σ (Γ : context) (P : forall t T (H : Σ ;;; Γ |- t : T), Type) : term -> list term -> term -> Type :=
| type_spine_pred_nil ty ty' (* s s' *) :
    isType Σ Γ ty ->
    isType Σ Γ ty' ->
    (* forall H : Σ ;;; Γ |- ty : tSort s,
    P ty (tSort s) H ->
    forall H' : Σ ;;; Γ |- ty' : tSort s',
    P ty' (tSort s') H' ->
     *) Σ ;;; Γ ⊢ ty ≤ ty' ->
    typing_spine_pred Σ Γ P ty [] ty'

| type_spine_pred_cons ty hd tl na A B B' s' :
    isType Σ Γ ty ->
    forall H' : Σ ;;; Γ |- tProd na A B : tSort s',
    P (tProd na A B) (tSort s') H' ->
    Σ ;;; Γ ⊢ ty ≤ tProd na A B ->
    forall H : Σ ;;; Γ |- hd : A,
    P hd A H ->
    typing_spine_pred Σ Γ P (subst10 hd B) tl B' ->
    typing_spine_pred Σ Γ P ty (hd :: tl) B'.

Section WfEnv.
  Context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}.

  Lemma typing_spine_pred_strengthen {Γ P T args U} :
    typing_spine_pred Σ Γ P T args U ->
    isType Σ Γ T ->
    forall T',
    isType Σ Γ T' ->
    Σ ;;; Γ ⊢ T' ≤ T ->
    typing_spine_pred Σ Γ P T' args U.
  Proof using wfΣ.
    induction 1 in |- *; intros T' isTy redT.
    - constructor; eauto. transitivity ty; auto.
    - specialize IHX with (T' := (B {0 := hd})).
      assert (isType Σ Γ (B {0 := hd})) as HH. {
        clear p.
        eapply inversion_Prod in H' as (? & ? & ? & ? & ?); tea.
        eapply isType_subst. econstructor. econstructor. rewrite subst_empty; eauto.
        econstructor; cbn; eauto.
      }
      do 3 forward IHX by pcuic.
      intros Hsub.
      eapply type_spine_pred_cons; eauto.
      etransitivity; eauto.
  Qed.

End WfEnv.

Lemma inversion_mkApps {cf : checker_flags} {Σ} {wfΣ :  wf Σ.1} {Γ f u T} s :
  forall (H : Σ ;;; Γ |- mkApps f u : T) (HT : Σ ;;; Γ |- T : tSort s),
  { A : term & { Hf : Σ ;;; Γ |- f : A & {s' & {HA : Σ ;;; Γ |- A : tSort s' &
   typing_size Hf <= typing_size H ×
   typing_size HA <= max (typing_size H) (typing_size HT) ×
  typing_spine_pred Σ Γ (fun x ty Hx => typing_size Hx <= typing_size H) A u T}}}}.
Proof.
  revert f T.
  induction u; intros f T. simpl. intros.
  { exists T, H, s, HT. intuition pcuic.
    econstructor. eexists; eauto. eexists; eauto. eapply isType_ws_cumul_pb_refl. eexists; eauto. }
  intros Hf Ht. simpl in Hf.
  specialize (IHu (tApp f a) T).
  epose proof (IHu Hf) as (T' & H' & s' & H1 & H2 & H3 & H4); tea.
  edestruct @inversion_App_size with (H := H') as (na' & A' & B' & s_ & Hf' & Ha & HA & Hs1 & Hs2 & Hs3 & HA'''); tea.
  exists (tProd na' A' B'). exists Hf'. exists s_. exists HA.
  split. rewrite <- H2. lia.
  split. rewrite <- Nat.le_max_l, <- H2. lia.

  unshelve econstructor.
  5: eauto. 1: eauto.
  3:eapply isType_ws_cumul_pb_refl; eexists; eauto.
  1: eexists; eauto.
  1, 2: rewrite <- H2; lia.
  eapply typing_spine_pred_strengthen; tea.
  eexists; eauto. clear Hs3.
  eapply inversion_Prod in HA as (? & ? & ? & ? & ?); tea.
  eapply isType_subst. econstructor. econstructor. rewrite subst_empty; eauto.
  econstructor;  cbn; eauto.
  Unshelve. eauto.
Qed.

Lemma typing_ind_env_app_size `{cf : checker_flags} :
forall (P : global_env_ext -> context -> term -> term -> Type)
       (Pdecl := fun Σ Γ wfΓ t T tyT => P Σ Γ t T)
       (PΓ : global_env_ext -> context -> Type),

  (forall Σ (wfΣ : wf Σ.1)  (Γ : context) (wfΓ : wf_local Σ Γ),
       All_local_env_over typing Pdecl Σ Γ wfΓ -> PΓ Σ Γ) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : nat) decl,
      nth_error Γ n = Some decl ->
      PΓ Σ Γ ->
      P Σ Γ (tRel n) (lift0 (S n) decl.(decl_type))) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : Universe.t),
      PΓ Σ Γ ->
      wf_universe Σ u ->
      P Σ Γ (tSort u) (tSort (Universe.super u))) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (t b : term) (s1 s2 : Universe.t),
      PΓ Σ Γ ->
      Σ ;;; Γ |- t : tSort s1 ->
      P Σ Γ t (tSort s1) ->
      Σ ;;; Γ,, vass n t |- b : tSort s2 ->
      P Σ (Γ,, vass n t) b (tSort s2) -> P Σ Γ (tProd n t b) (tSort (Universe.sort_of_product s1 s2))) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (t b : term)
          (s1 : Universe.t) (bty : term),
      PΓ Σ Γ ->
      Σ ;;; Γ |- t : tSort s1 ->
      P Σ Γ t (tSort s1) ->
      Σ ;;; Γ,, vass n t |- b : bty -> P Σ (Γ,, vass n t) b bty -> P Σ Γ (tLambda n t b) (tProd n t bty)) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (b b_ty b' : term)
          (s1 : Universe.t) (b'_ty : term),
      PΓ Σ Γ ->
      Σ ;;; Γ |- b_ty : tSort s1 ->
      P Σ Γ b_ty (tSort s1) ->
      Σ ;;; Γ |- b : b_ty ->
      P Σ Γ b b_ty ->
      Σ ;;; Γ,, vdef n b b_ty |- b' : b'_ty ->
      P Σ (Γ,, vdef n b b_ty) b' b'_ty -> P Σ Γ (tLetIn n b b_ty b') (tLetIn n b b_ty b'_ty)) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t : term) T B L s,
      PΓ Σ Γ ->
      Σ ;;; Γ |- T : tSort s -> P Σ Γ T (tSort s) ->
      forall (Ht : Σ ;;; Γ |- t : T), P Σ Γ t T ->

      (* Give a stronger induction hypothesis allowing to crawl under applications *)
      (forall t' T' (Ht' : Σ ;;; Γ |- t' : T'), typing_size Ht' <= typing_size Ht -> P Σ Γ t' T') ->
      typing_spine_pred Σ Γ (fun u ty H => Σ ;;; Γ |- u : ty × P Σ Γ u ty) T L B ->

      P Σ Γ (mkApps t L) B) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) cst u (decl : constant_body),
      Forall_decls_typing P Σ.1 ->
      PΓ Σ Γ ->
      declared_constant Σ.1 cst decl ->
      consistent_instance_ext Σ decl.(cst_universes) u ->
      P Σ Γ (tConst cst u) (subst_instance u (cst_type decl))) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) u
        mdecl idecl (isdecl : declared_inductive Σ.1 ind mdecl idecl),
      Forall_decls_typing P Σ.1 ->
      PΓ Σ Γ ->
      consistent_instance_ext Σ mdecl.(ind_universes) u ->
      P Σ Γ (tInd ind u) (subst_instance u (ind_type idecl))) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) (i : nat) u
          mdecl idecl cdecl (isdecl : declared_constructor Σ.1 (ind, i) mdecl idecl cdecl),
      Forall_decls_typing P Σ.1 ->
      PΓ Σ Γ ->
      consistent_instance_ext Σ mdecl.(ind_universes) u ->
      P Σ Γ (tConstruct ind i u) (type_of_constructor mdecl cdecl (ind, i) u)) ->

    (forall (Σ : global_env_ext) (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ),
     forall (ci : case_info) p c brs indices ps mdecl idecl
       (isdecl : declared_inductive Σ.1 ci.(ci_ind) mdecl idecl),
       Forall_decls_typing P Σ.1 ->
       PΓ Σ Γ ->
       mdecl.(ind_npars) = ci.(ci_npar) ->
       eq_context_upto_names p.(pcontext) (ind_predicate_context ci.(ci_ind) mdecl idecl) ->
       let predctx := case_predicate_context ci.(ci_ind) mdecl idecl p in
       wf_predicate mdecl idecl p ->
       consistent_instance_ext Σ (ind_universes mdecl) p.(puinst) ->
       forall pret : Σ ;;; Γ ,,, predctx |- p.(preturn) : tSort ps,
       P Σ (Γ ,,, predctx) p.(preturn) (tSort ps) ->
       wf_local Σ (Γ ,,, predctx) ->
       PΓ Σ (Γ ,,, predctx) ->
       is_allowed_elimination Σ idecl.(ind_kelim) ps ->
       PCUICTyping.ctx_inst (Prop_conj typing P) Σ Γ (p.(pparams) ++ indices)
         (List.rev (subst_instance p.(puinst) (mdecl.(ind_params) ,,, idecl.(ind_indices)))) ->
       Σ ;;; Γ |- c : mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices) ->
       P Σ Γ c (mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices)) ->
       isCoFinite mdecl.(ind_finite) = false ->
       let ptm := it_mkLambda_or_LetIn predctx p.(preturn) in
       wf_branches idecl brs ->
       All2i (fun i cdecl br =>
         (eq_context_upto_names br.(bcontext) (cstr_branch_context ci mdecl cdecl)) ×
         let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in
         (PΓ Σ (Γ ,,, brctxty.1) ×
         (Prop_conj typing P Σ (Γ ,,, brctxty.1) br.(bbody) brctxty.2) ×
         (Prop_conj typing P Σ (Γ ,,, brctxty.1) brctxty.2 (tSort ps)))) 0 idecl.(ind_ctors) brs ->
       P Σ Γ (tCase ci p c brs) (mkApps ptm (indices ++ [c]))) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (p : projection) (c : term) u
        mdecl idecl cdecl pdecl (isdecl : declared_projection Σ.1 p mdecl idecl cdecl pdecl) args,
      Forall_decls_typing P Σ.1 -> PΓ Σ Γ ->
      Σ ;;; Γ |- c : mkApps (tInd p.(proj_ind) u) args ->
      P Σ Γ c (mkApps (tInd p.(proj_ind) u) args) ->
      #|args| = ind_npars mdecl ->
      P Σ Γ (tProj p c) (subst0 (c :: List.rev args) (pdecl.(proj_type)@[u]))) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (mfix : list (def term)) (n : nat) decl,
      let types := fix_context mfix in
      fix_guard Σ Γ mfix ->
      nth_error mfix n = Some decl ->
      PΓ Σ (Γ ,,, types) ->
      All (on_def_type (lift_typing2 typing P Σ) Γ) mfix ->
      All (on_def_body (lift_typing2 typing P Σ) types Γ) mfix ->
      wf_fixpoint Σ.1 mfix ->
      P Σ Γ (tFix mfix n) decl.(dtype)) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (mfix : list (def term)) (n : nat) decl,
      let types := fix_context mfix in
      cofix_guard Σ Γ mfix ->
      nth_error mfix n = Some decl ->
      PΓ Σ (Γ ,,, types) ->
      All (on_def_type (lift_typing2 typing P Σ) Γ) mfix ->
      All (on_def_body (lift_typing2 typing P Σ) types Γ) mfix ->
      wf_cofixpoint Σ.1 mfix ->
      P Σ Γ (tCoFix mfix n) decl.(dtype)) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (p : prim_val) prim_ty cdecl,
    PΓ Σ Γ ->
    primitive_constant Σ.1 (prim_val_tag p) = Some prim_ty ->
    declared_constant Σ.1 prim_ty cdecl ->
    primitive_invariants cdecl ->
    P Σ Γ (tPrim p) (tConst prim_ty [])) ->

  (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t A B : term) s,
      PΓ Σ Γ ->
      Σ ;;; Γ |- t : A ->
      P Σ Γ t A ->
      Σ ;;; Γ |- B : tSort s ->
      P Σ Γ B (tSort s) ->
      Σ ;;; Γ |- A <=s B ->
      P Σ Γ t B) ->

     env_prop P PΓ.
Proof.
 intros P Pdecl PΓ.
 intros XΓ X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 Σ wfΣ Γ t T H.
 eapply typing_ind_env_app_size; eauto. clear Σ wfΣ Γ t T H.
 intros Σ wfΣ Γ wfΓ t na A B u s HΓ Hprod IHprod Ht IHt IH Hu IHu.
 pose proof (mkApps_decompose_app t).
 destruct (decompose_app t) as [t1 L].
 subst. rename t1 into t. cbn in *.
 replace (tApp (mkApps t L) u) with (mkApps t (L ++ [u])) by now rewrite mkApps_app.

 pose proof (@inversion_mkApps cf) as Happs. specialize Happs with (H := Ht).
 forward Happs; eauto.
 destruct (Happs _ Hprod) as (A' & Hf & s' & HA & sz_f & sz_A & HL).
 destruct @inversion_Prod_size with (H := Hprod) as (s1 & s2 & H1 & H2 & Hs1 & Hs2 & Hsub); [ eauto | ].
 eapply X4. 6:eauto. 4: exact HA. all: eauto.
 - intros. eapply (IH _ _ Hf). lia.
 - Unshelve. 2:exact Hf. intros. eapply (IH _ _ Ht'). lia.
 - clear sz_A. induction L in A', Hf, (* HA, sz_A, *) Ht, HL, t, Hf, IH (*, s' *) |- *.
   + inversion HL; subst. inversion X13. econstructor. econstructor; eauto. eauto. eauto. eauto. eauto. eauto.
     econstructor. 1,2: eapply isType_apply; eauto. eapply ws_cumul_pb_refl.
     eapply typing_closed_context; eauto. eapply type_is_open_term.
     eapply type_App; eauto.
   + cbn. inversion HL. subst. clear HL.
     eapply inversion_Prod in H' as Hx; eauto. destruct Hx as (? & ? & ? & ? & ?).
     econstructor.
     7: unshelve eapply IHL.
     now eauto. now eauto. split. now eauto. unshelve eapply IH. eauto. lia.
     now eauto. now eauto. split. now eauto. unshelve eapply IH. eauto. lia.
     2: now eauto. eauto.
     econstructor; eauto. econstructor; eauto. now eapply cumulAlgo_cumulSpec in X14.
     eauto.
Qed.

Lemma typing_ind_env `{cf : checker_flags} :
  forall (P : global_env_ext -> context -> term -> term -> Type)
         (Pdecl := fun Σ Γ wfΓ t T tyT => P Σ Γ t T)
         (PΓ : global_env_ext -> context -> Type),

    (forall Σ (wfΣ : wf Σ.1)  (Γ : context) (wfΓ : wf_local Σ Γ),
         All_local_env_over typing Pdecl Σ Γ wfΓ -> PΓ Σ Γ) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : nat) decl,
        nth_error Γ n = Some decl ->
        PΓ Σ Γ ->
        P Σ Γ (tRel n) (lift0 (S n) decl.(decl_type))) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (u : Universe.t),
        PΓ Σ Γ ->
        wf_universe Σ u ->
        P Σ Γ (tSort u) (tSort (Universe.super u))) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (t b : term) (s1 s2 : Universe.t),
        PΓ Σ Γ ->
        Σ ;;; Γ |- t : tSort s1 ->
        P Σ Γ t (tSort s1) ->
        Σ ;;; Γ,, vass n t |- b : tSort s2 ->
        P Σ (Γ,, vass n t) b (tSort s2) -> P Σ Γ (tProd n t b) (tSort (Universe.sort_of_product s1 s2))) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (t b : term)
            (s1 : Universe.t) (bty : term),
        PΓ Σ Γ ->
        Σ ;;; Γ |- t : tSort s1 ->
        P Σ Γ t (tSort s1) ->
        Σ ;;; Γ,, vass n t |- b : bty -> P Σ (Γ,, vass n t) b bty -> P Σ Γ (tLambda n t b) (tProd n t bty)) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (n : aname) (b b_ty b' : term)
            (s1 : Universe.t) (b'_ty : term),
        PΓ Σ Γ ->
        Σ ;;; Γ |- b_ty : tSort s1 ->
        P Σ Γ b_ty (tSort s1) ->
        Σ ;;; Γ |- b : b_ty ->
        P Σ Γ b b_ty ->
        Σ ;;; Γ,, vdef n b b_ty |- b' : b'_ty ->
        P Σ (Γ,, vdef n b b_ty) b' b'_ty -> P Σ Γ (tLetIn n b b_ty b') (tLetIn n b b_ty b'_ty)) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t : term) T B L s,
        PΓ Σ Γ ->
        Σ ;;; Γ |- T : tSort s -> P Σ Γ T (tSort s) ->
        forall (Ht : Σ ;;; Γ |- t : T), P Σ Γ t T ->

        (* Give a stronger induction hypothesis allowing to crawl under applications *)
        typing_spine_pred Σ Γ (fun u ty H => Σ ;;; Γ |- u : ty × P Σ Γ u ty) T L B ->

        P Σ Γ (mkApps t L) B) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) cst u (decl : constant_body),
        Forall_decls_typing P Σ.1 ->
        PΓ Σ Γ ->
        declared_constant Σ.1 cst decl ->
        consistent_instance_ext Σ decl.(cst_universes) u ->
        P Σ Γ (tConst cst u) (subst_instance u (cst_type decl))) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) u
          mdecl idecl (isdecl : declared_inductive Σ.1 ind mdecl idecl),
        Forall_decls_typing P Σ.1 ->
        PΓ Σ Γ ->
        consistent_instance_ext Σ mdecl.(ind_universes) u ->
        P Σ Γ (tInd ind u) (subst_instance u (ind_type idecl))) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (ind : inductive) (i : nat) u
            mdecl idecl cdecl (isdecl : declared_constructor Σ.1 (ind, i) mdecl idecl cdecl),
        Forall_decls_typing P Σ.1 ->
        PΓ Σ Γ ->
        consistent_instance_ext Σ mdecl.(ind_universes) u ->
        P Σ Γ (tConstruct ind i u) (type_of_constructor mdecl cdecl (ind, i) u)) ->

    (forall (Σ : global_env_ext) (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ),
    forall (ci : case_info) p c brs indices ps mdecl idecl
      (isdecl : declared_inductive Σ.1 ci.(ci_ind) mdecl idecl),
      Forall_decls_typing P Σ.1 ->
      PΓ Σ Γ ->
      mdecl.(ind_npars) = ci.(ci_npar) ->
      eq_context_upto_names p.(pcontext) (ind_predicate_context ci.(ci_ind) mdecl idecl) ->
      let predctx := case_predicate_context ci.(ci_ind) mdecl idecl p in
      wf_predicate mdecl idecl p ->
      consistent_instance_ext Σ (ind_universes mdecl) p.(puinst) ->
      forall pret : Σ ;;; Γ ,,, predctx |- p.(preturn) : tSort ps,
      P Σ (Γ ,,, predctx) p.(preturn) (tSort ps) ->
      wf_local Σ (Γ ,,, predctx) ->
      PΓ Σ (Γ ,,, predctx) ->
      is_allowed_elimination Σ idecl.(ind_kelim) ps ->
      PCUICTyping.ctx_inst (Prop_conj typing P) Σ Γ (p.(pparams) ++ indices)
        (List.rev (subst_instance p.(puinst) (mdecl.(ind_params) ,,, idecl.(ind_indices)))) ->
      Σ ;;; Γ |- c : mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices) ->
      P Σ Γ c (mkApps (tInd ci.(ci_ind) p.(puinst)) (p.(pparams) ++ indices)) ->
      isCoFinite mdecl.(ind_finite) = false ->
      let ptm := it_mkLambda_or_LetIn predctx p.(preturn) in
      wf_branches idecl brs ->
      All2i (fun i cdecl br =>
        (eq_context_upto_names br.(bcontext) (cstr_branch_context ci mdecl cdecl)) ×
        let brctxty := case_branch_type ci.(ci_ind) mdecl idecl p br ptm i cdecl in
        (PΓ Σ (Γ ,,, brctxty.1) ×
          (Prop_conj typing P Σ (Γ ,,, brctxty.1) br.(bbody) brctxty.2) ×
          (Prop_conj typing P) Σ (Γ ,,, brctxty.1) brctxty.2 (tSort ps))) 0 idecl.(ind_ctors) brs ->
      P Σ Γ (tCase ci p c brs) (mkApps ptm (indices ++ [c]))) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (p : projection) (c : term) u
          mdecl idecl cdecl pdecl (isdecl : declared_projection Σ.1 p mdecl idecl cdecl pdecl) args,
        Forall_decls_typing P Σ.1 -> PΓ Σ Γ ->
        Σ ;;; Γ |- c : mkApps (tInd p.(proj_ind) u) args ->
        P Σ Γ c (mkApps (tInd p.(proj_ind) u) args) ->
        #|args| = ind_npars mdecl ->
        P Σ Γ (tProj p c) (subst0 (c :: List.rev args) (subst_instance u pdecl.(proj_type)))) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (mfix : list (def term)) (n : nat) decl,
        let types := fix_context mfix in
        fix_guard Σ Γ mfix ->
        nth_error mfix n = Some decl ->
        PΓ Σ (Γ ,,, types) ->
        All (on_def_type (lift_typing2 typing P Σ) Γ) mfix ->
        All (on_def_body (lift_typing2 typing P Σ) types Γ) mfix ->
        wf_fixpoint Σ.1 mfix ->
        P Σ Γ (tFix mfix n) decl.(dtype)) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (mfix : list (def term)) (n : nat) decl,
        let types := fix_context mfix in
        cofix_guard Σ Γ mfix ->
        nth_error mfix n = Some decl ->
        PΓ Σ (Γ ,,, types) ->
        All (on_def_type (lift_typing2 typing P Σ) Γ) mfix ->
        All (on_def_body (lift_typing2 typing P Σ) types Γ) mfix ->
        wf_cofixpoint Σ.1 mfix ->
        P Σ Γ (tCoFix mfix n) decl.(dtype)) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (p : prim_val) prim_ty cdecl,
        PΓ Σ Γ ->
        primitive_constant Σ.1 (prim_val_tag p) = Some prim_ty ->
        declared_constant Σ.1 prim_ty cdecl ->
        primitive_invariants cdecl ->
        P Σ Γ (tPrim p) (tConst prim_ty [])) ->

    (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t A B : term) s,
        PΓ Σ Γ ->
        Σ ;;; Γ |- t : A ->
        P Σ Γ t A ->
        Σ ;;; Γ |- B : tSort s ->
        P Σ Γ B (tSort s) ->
        Σ ;;; Γ |- A <=s B ->
        P Σ Γ t B) ->

       env_prop P PΓ.
Proof.
  intros P Pdecl PΓ; unfold env_prop.
  intros XΓ X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 Σ wfΣ Γ t T H.
  apply typing_ind_env_app_size; eauto.
Qed.

Local Hint Constructors value red1 : wcbv.

Definition axiom_free Σ :=
  forall c decl, declared_constant Σ c decl -> cst_body decl <> None. (* TODO: consolidate with PCUICConsistency *)

Lemma value_stuck_fix Σ mfix idx args : isStuckFix (tFix mfix idx) args -> All (value Σ) args -> value Σ (mkApps (tFix mfix idx) args).
Proof.
  unfold isStuckFix; intros isstuck vargs.
  eapply value_app => //.
  destruct cunfold_fix as [[rarg fn]|] eqn:cunf => //.
  econstructor; tea. now eapply Nat.leb_le.
Qed.

Lemma typing_spine_length {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} Γ Δ ind u args args' T' :
  typing_spine Σ Γ (it_mkProd_or_LetIn Δ (mkApps (tInd ind u) args)) args' T' ->
  #|args'| <= context_assumptions Δ.
Proof.
  intros hsp.
  pose proof (typing_spine_more_inv _ _ _ _ _ _ _ _ hsp).
  destruct (Compare_dec.le_dec #|args'| (context_assumptions Δ)). lia. lia.
Qed.

Lemma declared_constructor_ind_decl {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind c} {mdecl idecl cdecl} :
  declared_constructor Σ (ind, c) mdecl idecl cdecl ->
  inductive_ind ind < #|ind_bodies mdecl|.
Proof.
  intros [[hm hi] hc]. now eapply nth_error_Some_length in hi.
Qed.

Import PCUICGlobalEnv.

Lemma typing_constructor_arity_exact {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind c u u' args}
  {mdecl idecl cdecl indices} :
  declared_constructor Σ (ind, c) mdecl idecl cdecl ->
  Σ ;;; [] |- mkApps (tConstruct ind c u) args : mkApps (tInd ind u') indices ->
  #|args| = cstr_arity mdecl cdecl.
Proof.
  intros declc hc.
  eapply Construct_Ind_ind_eq in hc; tea.
  intuition auto.
Qed.

Lemma typing_constructor_arity {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {ind c u args T} {mdecl idecl cdecl} :
  declared_constructor Σ (ind, c) mdecl idecl cdecl ->
  Σ ;;; [] |- mkApps (tConstruct ind c u) args : T ->
  #|args| <= cstr_arity mdecl cdecl.
Proof.
  intros declc hc.
  pose proof (validity hc).
  eapply PCUICSpine.inversion_mkApps_direct in hc as [A' [u' [s' [hs hsp]]]]; eauto.
  eapply inversion_Construct in s' as [mdecl' [idecl' [cdecl' [wf [declc' [cu cum]]]]]]; tea.
  destruct (PCUICGlobalEnv.declared_constructor_inj declc declc') as [? []]. subst mdecl' idecl' cdecl'.
  clear declc'.
  eapply typing_spine_strengthen in hsp. 3:exact cum.
  2:{ eapply validity. econstructor; tea. }
  unfold type_of_constructor in hsp.
  destruct (on_declared_constructor declc) as [[] [cunivs [_ onc]]].
  rewrite onc.(cstr_eq) in hsp.
  rewrite <-it_mkProd_or_LetIn_app in hsp.
  rewrite subst_instance_it_mkProd_or_LetIn subst_it_mkProd_or_LetIn in hsp.
  epose proof (subst_cstr_concl_head ind u mdecl (cstr_args cdecl) (cstr_indices cdecl)). cbn in H.
  unfold cstr_concl in hsp. cbn in hsp. len in hsp. rewrite H in hsp. clear H.
  eapply (declared_constructor_ind_decl declc). clear H.
  eapply typing_spine_length in hsp. len in hsp. unfold cstr_arity.
  now rewrite (PCUICGlobalEnv.declared_minductive_ind_npars declc).
Qed.

Lemma value_mkApps_inv' Σ f args :
  negb (isApp f) ->
  value Σ (mkApps f args) ->
  atom f × All (value Σ) args.
Proof.
  intros napp. move/value_mkApps_inv => [] => //.
  - intros [-> hf]. split => //.
  - intros []. split; auto. destruct v; now constructor.
Qed.

Global Hint Resolve All_app_inv : pcuic.

Lemma red1_mkApps_left {Σ f f' args} : red1 Σ f f' -> red1 Σ (mkApps f args) (mkApps f' args).
Proof.
  induction args using rev_ind.
  - auto.
  - intros. rewrite !mkApps_app.
    eapply red_app_left. now apply IHargs.
Qed.

Lemma typing_spine_sort {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} Γ s args T :
  typing_spine Σ Γ (tSort s) args T -> args = [].
Proof.
  induction args => //.
  intros sp. depelim sp.
  now eapply ws_cumul_pb_Sort_Prod_inv in w.
Qed.

Lemma typing_spine_axiom {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} Γ cst u cdecl args T :
  declared_constant Σ cst cdecl ->
  cdecl.(cst_body) = None ->
  typing_spine Σ Γ (tConst cst u) args T -> args = [].
Proof.
  intros hdecl hb.
  induction args => //.
  intros sp. depelim sp.
  now eapply invert_cumul_axiom_prod in w.
Qed.

Lemma typing_value_head_napp {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} fn args hd T :
  negb (isApp fn) ->
  Σ ;;; [] |- mkApps fn (args ++ [hd]) : T ->
  value Σ hd -> closed hd ->
  value Σ (mkApps fn args) ->
  (∑ t' : term, red1 Σ (mkApps fn (args ++ [hd])) t') +
  value Σ (mkApps fn (args ++ [hd])).
Proof.
  intros napp ht vhd clhd vapp.
  pose proof ht as ht'.
  destruct (value_mkApps_inv' _ _ _ napp vapp).
  eapply PCUICSpine.inversion_mkApps_direct in ht' as [A' [u [hfn [hhd hcum]]]]; tea.
  2:{ now eapply validity. }
  destruct fn => //.
  * eapply inversion_Sort in hfn as [? [? cu]]; tea.
    eapply typing_spine_strengthen in hcum. 3:tea. 2:{ eapply validity; econstructor; eauto. }
    now eapply typing_spine_sort, app_tip_nil in hcum.
  * eapply inversion_Prod in hfn as [? [? [? [? cu]]]]; tea.
    eapply typing_spine_strengthen in hcum. 3:tea. 2:{ eapply validity. econstructor; eauto. }
    now eapply typing_spine_sort, app_tip_nil in hcum.
  * (* Lambda *) left. destruct args.
    - cbn. eexists. now eapply red_beta.
    - eexists. rewrite mkApps_app. rewrite (mkApps_app _ [t] args). do 2 eapply red1_mkApps_left.
      cbn. eapply red_beta. now depelim a.
  * (* Inductive *)
    eapply inversion_Ind in hfn as [? [? [? [? [? cu]]]]]; tea.
    eapply typing_spine_strengthen in hcum. 3:tea. 2:{ eapply validity. econstructor; eauto. }
    right. eapply value_app. constructor. eauto with pcuic.
  * (* constructor *)
    right. eapply value_app; auto. 2:{ eapply All_app_inv; eauto. }
    pose proof hfn as hfn'.
    eapply inversion_Construct in hfn' as [mdecl [idecl [cdecl [wf [declc _]]]]]; tea.
    eapply (typing_constructor_arity declc) in ht.
    econstructor; tea.
  * (* fix *)
    destruct (isStuckFix (tFix mfix idx) (args ++ [hd])) eqn:E.
    + right. eapply value_stuck_fix; eauto with pcuic.
    + cbn in E.
      eapply inversion_Fix in hfn as ([] & ? & Efix & ? & ? & ?); eauto.
      unfold cunfold_fix in E. rewrite Efix in E. cbn in E.
      len in E. cbn in E. assert (rarg = #|args|).
      eapply stuck_fix_value_args in vapp; tea. 2:{ unfold cunfold_fix. now rewrite Efix. }
      cbn in vapp. apply Nat.leb_gt in E. lia. subst rarg.
      left. eexists. rewrite mkApps_app /=. eapply red_fix. eauto. eauto.
      unfold unfold_fix. now rewrite Efix.
      eapply fix_app_is_constructor in ht.
      2:{ unfold unfold_fix. now rewrite Efix. }
      cbn in ht. rewrite nth_error_app_ge // /= in ht.
      replace (#|args| - #|args|) with 0 in ht by lia. cbn in ht. apply ht.
      eapply value_axiom_free; eauto.
      eapply value_whnf; eauto.
  * (* cofix *)
    right. eapply value_app; eauto with pcuic.
    now constructor.
  * (* primitive *)
    cbn.
    eapply inversion_Prim in hfn as [prim_ty [cdecl [hwf hp hdecl [s []]]]]; tea.
    eapply typing_spine_strengthen in hcum. 3:tea. 2:{ eapply validity; econstructor; eauto. now exists s. }
    now eapply typing_spine_axiom, app_tip_nil in hcum.
Qed.

Lemma typing_value_head {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} fn args hd T :
  Σ ;;; [] |- mkApps fn (args ++ [hd]) : T ->
  value Σ hd -> closed hd ->
  value Σ (mkApps fn args) ->
  (∑ t' : term, red1 Σ (mkApps fn (args ++ [hd])) t') +
  value Σ (mkApps fn (args ++ [hd])).
Proof.
  destruct (decompose_app fn) eqn:da.
  pose proof (decompose_app_notApp _ _ _ da).
  rewrite (decompose_app_inv da).
  rewrite -mkApps_app app_assoc.
  intros; eapply typing_value_head_napp; tea. now rewrite H.
  rewrite mkApps_app //.
Qed.

Lemma cstr_branch_context_assumptions ci mdecl cdecl :
  context_assumptions (cstr_branch_context ci mdecl cdecl) =
  context_assumptions (cstr_args cdecl).
Proof.
  rewrite /cstr_branch_context /PCUICEnvironment.expand_lets_ctx
    /PCUICEnvironment.expand_lets_k_ctx.
  now do 2 rewrite !context_assumptions_subst_context ?context_assumptions_lift_context.
Qed.

Lemma progress `{cf : checker_flags}:
  env_prop (fun Σ Γ t T => axiom_free Σ -> Γ = [] -> Σ ;;; Γ |- t : T -> {t' & red1 Σ t t'} + (value Σ t))
           (fun _ _ => True).
Proof with eauto with wcbv; try congruence.
  eapply typing_ind_env...
  - intros Σ wfΣ Γ wfΓ n decl Hdecl _ Hax -> Hty.
    destruct n; inv Hdecl.
  - intros Σ wfΣ Γ _ n b b_ty b' s1 b'_ty _ Hb_ty IHb_ty Hb IHb Hb' IHb' Hax -> H.
    destruct (IHb Hax eq_refl) as [ [t' IH] | IH]; eauto with wcbv.
  - intros Σ wfΣ Γ _ t T B L s _ HT IHT Ht IHt HL Hax -> H.
    clear HT IHT.
    induction HL in H, t, Ht, IHt |- *.
    + cbn. eauto.
    + cbn. eapply IHHL.
      2:{ do 2 (econstructor; eauto). now eapply cumulAlgo_cumulSpec in w. }
      intros _ Happ.
      destruct (IHt Hax eq_refl Ht) as [[t' IH] | IH]; eauto with wcbv.
      assert (Ht' : Σ ;;; [] |- t : tProd na A B) by (econstructor; eauto; now eapply cumulAlgo_cumulSpec in w).
      destruct p0 as [_ [[t' Hstep] | Hval]]; eauto using red1.
      intros htapp.
      pose proof (typing_value_head t [] hd _ htapp Hval).
      forward X. now eapply subject_closed in H0. cbn in X.
      specialize (X IH). exact X.
      now cbn in H.
  - intros Σ wf Γ _ cst u decl Hdecls _ Hdecl Hcons Hax -> H.
    destruct (decl.(cst_body)) as [body | ] eqn:E.
    + eauto with wcbv.
    + red in Hax. eapply Hax in E; eauto.
  - intros Σ wfΣ Γ _ ci p c brs indices ps mdecl idecl Hidecl Hforall _ Heq Heq_context predctx Hwfpred Hcon Hreturn IHreturn Hwfl _.
    intros Helim Hctxinst Hc IHc Hcof ptm Hwfbranches Hall Hax -> H.
    specialize (IHc Hax eq_refl) as [[t' IH] | IH]; eauto with wcbv.
    pose proof IH as IHv.
    eapply PCUICCanonicity.value_canonical in IH; eauto.
    unfold head in IH.
    rewrite (PCUICInduction.mkApps_decompose_app c) in H, Hc, IHv |- *.
    destruct (decompose_app c) as [h l].
    cbn - [decompose_app] in *.
    destruct h; inv IH.
    + eapply invert_Case_Construct in H as H_; sq; eauto. destruct H_ as (Eq & H_); subst.
      left.
      destruct (nth_error brs n) as [br | ] eqn:E.
      2:{ exfalso. destruct H_ as [? []]; congruence. }
      assert (#|l| = ci_npar ci + context_assumptions (bcontext br)) as Hl.
      { destruct H_ as [? []]; auto. now noconf H0. }
      clear H_. eapply Construct_Ind_ind_eq' in Hc as (? & ? & ? & ? & _); eauto.
      eexists.
      destruct (declared_inductive_inj d.p1 Hidecl); subst x x0.
      eapply All2i_nth_error in Hall as [eqctx _]; tea; [|eapply d].
      eapply PCUICCasesContexts.alpha_eq_context_assumptions in eqctx.
      rewrite cstr_branch_context_assumptions in eqctx.
      eapply red_iota; eauto.
      { rewrite /cstr_arity Hl. rewrite -Heq. lia. }
      eapply value_mkApps_inv in IHv as [[-> ]|[]]; eauto.

    + eapply inversion_Case in H as (? & ? & ? & ? & [] & ?); eauto.
      eapply PCUICValidity.inversion_mkApps in scrut_ty as (? & ? & ?); eauto.
      eapply inversion_CoFix in t as (? & ? & ? & ? & ? & ? & ?); eauto.
      left. eexists. eapply red_cofix_case. unfold cunfold_cofix. rewrite e. reflexivity.
      eapply value_mkApps_inv in IHv as [[-> ]|[]]; eauto.
  - intros Σ wfΣ Γ _ p c u mdecl idecl cdecl pdecl Hcon args Hargs _ Hc IHc
           Hlen Hax -> H.
    destruct (IHc Hax eq_refl) as [[t' IH] | IH]; eauto with wcbv; clear IHc.
    pose proof IH as Hval.
    eapply PCUICCanonicity.value_canonical in IH; eauto.
    unfold head in IH.
    rewrite (PCUICInduction.mkApps_decompose_app c) in H, Hc, Hval |- *.
    destruct (decompose_app c) as [h l].
    cbn - [decompose_app] in *.
    destruct h; inv IH.
    + eapply invert_Proj_Construct in H as H_; sq; eauto. destruct H_ as (<- & -> & Hl).
      left. eapply nth_error_Some' in Hl as [x Hx].
      eexists.
      eapply red_proj; eauto.
      now eapply (typing_constructor_arity_exact Hcon) in Hc.
      eapply value_mkApps_inv in Hval as [[-> Hval] | [? ? Hval]]; eauto.
    + left. eapply inversion_Proj in H as (? & ? & ? & ? & ? & ? & ? & ? & ? & ?); eauto.
      eapply PCUICValidity.inversion_mkApps in t as (? & ? & ?); eauto.
      eapply inversion_CoFix in t as (? & ? & ? & ? & ? & ? & ?); eauto.
      eexists. eapply red_cofix_proj. unfold cunfold_cofix. rewrite e0. reflexivity.
      eapply value_mkApps_inv in Hval as [[-> ]|[]]; eauto.
Qed.

Lemma red1_closed {cf : checker_flags} {Σ t t'} :
  wf Σ ->
  closed t -> red1 Σ t t' -> closed t'.
Proof.
  intros Hwf Hcl Hred. induction Hred; cbn in *; solve_all.
  all: eauto using closed_csubst, closed_def.
  - eapply closed_iota; eauto. solve_all. unfold test_predicate_k in H. solve_all.
    now rewrite e0 /cstr_arity -e1 -e2.
  - eauto using closed_arg.
  - rewrite !closedn_mkApps in H |- *. solve_all.
    eapply closed_unfold_fix; tea.
  - rewrite !closedn_mkApps in Hcl |- *. solve_all.
    unfold cunfold_cofix in e. destruct nth_error as [d | ] eqn:E; inversion e.
    eapply closed_unfold_cofix with (narg := narg); eauto.
    unfold unfold_cofix. rewrite E. subst. repeat f_equal.
    eapply closed_cofix_substl_subst_eq; eauto.
  - rewrite !closedn_mkApps in H1 |- *. solve_all.
    unfold cunfold_cofix in e. destruct nth_error as [d | ] eqn:E; inversion e.
    eapply closed_unfold_cofix with (narg := narg); eauto.
    unfold unfold_cofix. rewrite E. subst. repeat f_equal.
    eapply closed_cofix_substl_subst_eq; eauto.
Qed.

Lemma red1_incl {cf : checker_flags} {Σ t t' } :
  closed t ->
  red1 Σ t t' -> PCUICReduction.red1 Σ [] t t'.
Proof.
  intros Hcl Hred.
  induction Hred. all: cbn in *; solve_all.
  1-10: try econstructor; eauto using red1_closed.
  1,2: now rewrite closed_subst; eauto; econstructor; eauto.
  - now rewrite e0 /cstr_arity -e1 -e2.
  - rewrite !tApp_mkApps -!mkApps_app. econstructor. eauto.
    unfold is_constructor. now rewrite nth_error_app2 // Nat.sub_diag.
  - unfold cunfold_cofix in e. destruct nth_error as [d | ] eqn:E; try congruence.
    inversion e; subst.
    econstructor. unfold unfold_cofix. rewrite E. repeat f_equal.
    eapply closed_cofix_substl_subst_eq; eauto. rewrite closedn_mkApps in Hcl. solve_all.
  - unfold cunfold_cofix in e. destruct nth_error as [d | ] eqn:E; try congruence.
    inversion e; subst.
    econstructor. unfold unfold_cofix. rewrite E. repeat f_equal.
    eapply closed_cofix_substl_subst_eq; eauto. rewrite closedn_mkApps in H1. solve_all.
Qed.

Global Hint Constructors value eval : wcbv.
Global Hint Resolve value_final : wcbv.

(* Lemma eval_tApp_Construct {Σ a b ind c u args a'}
  eval Σ a
eval Σ (tApp a b) (mkApps (tConstruct ind c u) (args ++ [a']))
 *)

Lemma red1_eval {Σ : global_env_ext } t t' v : wf Σ ->
  closed t ->
  red1 Σ t t' -> eval Σ t' v -> eval Σ t v.
Proof.
  intros Hwf Hty Hred Heval.
  induction Hred in Heval, v, Hty |- *; eauto with wcbv.
  - inversion Heval; subst; clear Heval. all:cbn in Hty; solve_all. 1-3,6:now econstructor; eauto with wcbv.
    eapply eval_construct; tea. eauto. eapply eval_app_cong; eauto with wcbv.
  - inversion Heval; subst; clear Heval. all:cbn in Hty; solve_all. 1-3,6: now econstructor; eauto with wcbv.
    eapply eval_construct; tea. eauto. eapply eval_app_cong; eauto with wcbv.
  - inversion Heval; subst; clear Heval. all:cbn in Hty; solve_all. all: now econstructor; eauto with wcbv.
  - inversion Heval; subst; clear Heval. all:cbn in Hty; solve_all. all: try now econstructor; eauto with wcbv.
  - eapply eval_iota. eapply eval_mkApps_Construct; tea. now econstructor. unfold cstr_arity. rewrite e0.
    rewrite (PCUICGlobalEnv.declared_minductive_ind_npars d).
    now rewrite -(declared_minductive_ind_npars d) /cstr_arity.
    all:tea. eapply All_All2_refl. solve_all. now eapply value_final.
  - inversion Heval; subst; clear Heval. all:cbn in Hty; solve_all. all: now econstructor; eauto with wcbv.
  - all:cbn in Hty; solve_all. eapply eval_proj; tea.
    eapply value_final. eapply value_app; auto. econstructor; tea. eapply d.
    rewrite e; lia.
  - eapply eval_fix; eauto.
    + eapply value_final. eapply value_app; auto. econstructor.
      rewrite <- closed_unfold_fix_cunfold_eq, e. reflexivity. 2:eauto.
      cbn in Hty. rewrite closedn_mkApps in Hty. solve_all.
    + eapply value_final; eauto.
    + rewrite <- closed_unfold_fix_cunfold_eq, e. reflexivity.
      cbn in Hty. rewrite closedn_mkApps in Hty. solve_all.
      Unshelve. all: now econstructor.
  - destruct p as [[] ?]. eapply eval_cofix_proj; tea.
    eapply value_final, value_app. now constructor. auto.
  - eapply eval_cofix_case; tea.
    eapply value_final, value_app. now constructor. auto.
Qed.

From MetaCoq Require Import PCUICSN.

Lemma WN {no:normalizing_flags} {Σ} {normalisation:NormalisationIn Σ} {t} : wf_ext Σ -> axiom_free Σ ->
  welltyped Σ [] t  -> exists v, squash (eval Σ t v).
Proof.
  intros Hwf Hax Hwt.
  eapply PCUICSN.normalisation_in in Hwt as HSN; eauto.
  induction HSN as [t H IH].
  destruct Hwt as [A HA].
  edestruct progress as [_ [_ [[t' Ht'] | Hval]]]; eauto.
  - eapply red1_incl in Ht' as Hred. 2:{ change 0 with (#|@nil context_decl|). eapply subject_closed. eauto. }
    edestruct IH as [v Hv]. econstructor. eauto.
    econstructor. eapply subject_reduction; eauto.
    exists v. sq. eapply red1_eval; eauto.
    now eapply subject_closed in HA.
  - exists t. sq. eapply value_final; eauto.
Qed.

From MetaCoq Require Import PCUICFirstorder.

Lemma firstorder_value_irred Σ t t' :
  firstorder_value Σ [] t ->
  PCUICReduction.red1 Σ [] t t' -> False.
Proof.
  intros H.
  revert t'. pattern t. revert t H.
  eapply firstorder_value_inds.
  intros i n ui u args pandi Hty Hargs IH Hprop t' Hred.
  eapply red1_mkApps_tConstruct_inv in Hred as (x & -> & Hone).
  solve_all.
  clear - IH Hone. induction IH as [ | ? ? []] in x, Hone |- *.
  - invs Hone.
  - invs Hone; eauto.
Qed.

Definition ws_empty f : ws_context f.
Proof.
  unshelve econstructor.
  exact nil.
  reflexivity.
Defined.

Lemma irred_equal Σ Γ t t' :
  Σ ;;; Γ ⊢ t ⇝ t' ->
  (forall v', PCUICReduction.red1 Σ Γ t v' -> False) ->
  t = t'.
Proof.
  intros Hred Hirred. destruct Hred.
  clear clrel_ctx clrel_src.
  induction clrel_rel.
  - edestruct Hirred; eauto.
  - reflexivity.
  - assert (x = y) as <- by eauto. eauto.
Qed.

Lemma ws_wcbv_standardization {no:normalizing_flags} {Σ} {normalisation:NormalisationIn Σ} {i u args mind} {t v : ws_term (fun _ => false)} : wf_ext Σ -> axiom_free Σ ->
  Σ ;;; [] |- t : mkApps (tInd i u) args ->
  lookup_env Σ (i.(inductive_mind)) = Some (InductiveDecl mind) ->
  @firstorder_ind Σ (firstorder_env Σ) i ->
  closed_red Σ [] t v ->
  (forall v', PCUICReduction.red1 Σ [] v v' -> False) ->
  squash (eval Σ t v).
Proof.
  intros Hwf Hax Hty Hdecl Hfo Hred Hirred.
  destruct (@WN no Σ normalisation t) as (v' & Hv'); eauto.
  1:{ eexists; eauto. }
  sq.
  assert (Σ;;; [] |- t ⇝* v') as Hred' by now eapply wcbeval_red.
  eapply closed_red_confluence in Hred as Hred_. destruct Hred_ as (v'' & H1 & H2).
  2:{ econstructor; eauto. eapply subject_is_open_term. eauto. }
  destruct v as [v Hv].
  assert (v = v'') as <- by (eapply irred_equal; eauto).
  assert (firstorder_value Σ [] v'). {
    eapply firstorder_value_spec; eauto.
    eapply subject_reduction_eval; eauto.
    eapply eval_to_value. eauto.
  }
  enough (v' = v) as -> by eauto.
  eapply irred_equal. eauto.
  intros. eapply firstorder_value_irred; eauto.
Qed.

Lemma wcbv_standardization {no:normalizing_flags} {Σ} {normalisation:NormalisationIn Σ} {i u args mind} {t v : term} : wf_ext Σ -> axiom_free Σ ->
  Σ ;;; [] |- t : mkApps (tInd i u) args ->
  lookup_env Σ (i.(inductive_mind)) = Some (InductiveDecl mind) ->
  @firstorder_ind Σ (firstorder_env Σ) i ->
  red Σ [] t v ->
  (forall v', PCUICReduction.red1 Σ [] v v' -> False) ->
  ∥ eval Σ t v ∥.
Proof.
  intros Hwf Hax Hty Hdecl Hfo Hred Hirred.
  unshelve edestruct @ws_wcbv_standardization.
  1-6: shelve.
  1: exists t; shelve.
  1: exists v; shelve.
  all: sq; eauto.
  cbn.
  econstructor; eauto.
  eapply subject_is_open_term. eauto.
  Unshelve.
  all: rewrite -closed_on_free_vars_none.
  - now eapply subject_closed in Hty.
  - eapply @subject_closed with (Γ := []); eauto.
    eapply subject_reduction; eauto.
Qed.


Set Implicit Arguments.

Require Import Platform.Facade.DFModule.
Require Import Platform.Facade.CompileDFacade.
Require Import Platform.Facade.DFacade.

Section ADTValue.

  Variable ADTValue : Type.

  Variable module : DFModule ADTValue.

  Definition compile_func (f : DFFun) : FModule.FFunction := FModule.Build_FFunction (compile_op f) (compiled_syntax_ok f).

  Require Import Platform.Cito.StringMap.
  Import StringMap.
  Require Import Platform.Cito.StringMapFacts.

  Definition compile_to_fmodule : FModule.FModule ADTValue := FModule.Build_FModule (Imports module) (StringMap.map compile_func (Funs module)).

  Require Import Coq.Strings.String.

  Variable name : string.

  Require Import Platform.Cito.NameDecoration.

  Hypothesis good_name : is_good_module_name name = true.

  Require Platform.Facade.CompileModule.

  Definition compile_to_gmodule : GoodModule.GoodModule := CompileModule.compile_to_gmodule compile_to_fmodule name good_name.

End ADTValue.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import String.
Require Import List.
Require Import Prelude.

Extraction Blacklist Prelude.

Extract Inductive bool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ].
Extract Inductive option => "Prelude.Maybe" [ "Prelude.Just" "Prelude.Nothing" ].

Extract Inductive unit => "()" [ "()" ].

Extract Inductive string => "[Prelude.Char]" [ "([])" "(:)" ].
Extract Inlined Constant String.length => "((\l -> Prelude.toInteger (Prelude.length l)))".
Extract Inlined Constant String.get => "(\i l -> if i Prelude.< Prelude.toInteger (Prelude.length l) then Prelude.Just (l Prelude.!! (Prelude.fromIntegral i)) else Prelude.Nothing)".
Extract Inlined Constant string_dec => "(Prelude.==)".

Extract Inductive ascii => "Prelude.Char" [ "\b0 b1 b2 b3 b4 b5 b6 b7 -> let s b = Prelude.flip (if b then Data.Bits.setBit else Data.Bits.clearBit) in castCCharToChar (s b0 0 (s b1 1 (s b2 2 (s b3 3 (s b4 4 (s b5 5 (s b6 6 (s b7 7 zeroBits))))))))" ].
Extract Inlined Constant ascii_dec => "(Prelude.==)".

Extract Inductive list => "([])" [ "([])" "(:)" ].
Extract Inlined Constant app => "(Prelude.++)".
Extract Inlined Constant length => "((\l -> Prelude.toInteger (Prelude.length l)))".
Extract Inlined Constant rev => "Prelude.reverse".

Extract Inductive prod => "(,)" [ "(,)" ].
Extract Inlined Constant fst => "Prelude.fst".
Extract Inlined Constant snd => "Prelude.snd".

Extract Inductive sumbool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ].
Extract Inductive sum => "Prelude.Either" [ "Prelude.Left" "Prelude.Right" ].

Extract Inlined Constant andb => "(Prelude.&&)".
Extract Inlined Constant orb => "(Prelude.||)".
Extract Inlined Constant negb => "Prelude.not".

Extract Inductive positive => "Prelude.Integer" [
  "((\x -> 2 Prelude.* x Prelude.+ 1))"
  "((\x -> 2 Prelude.* x))"
  "1"
].

Extract Inductive nat => "Prelude.Integer" ["0" "(Prelude.+ 1)"].

Extract Inlined Constant Init.Nat.sub => "(\n m -> Prelude.max (n Prelude.- m) 0)".

Extract Inductive Z => "Prelude.Integer" ["0" "" "Prelude.negate"].
Extract Constant Z.succ => "Prelude.succ".
Extract Constant Z.pred => "Prelude.pred".
Extract Inlined Constant Z.eq_dec => "(Prelude.==)".
Extract Inlined Constant Z.eqb => "(Prelude.==)".
Extract Inlined Constant Z.add => "(Prelude.+)".
Extract Inlined Constant Z.sub => "(Prelude.-)".
Extract Inlined Constant Z.mul => "(Prelude.*)".
Extract Inlined Constant Z.opp => "Prelude.negate".
Extract Inlined Constant Z.abs => "Prelude.abs".
Extract Inlined Constant Z.ltb => "(Prelude.<)".
Extract Inlined Constant Z.leb => "(Prelude.<=)".
Extract Inlined Constant Z.gtb => "(Prelude.>)".
Extract Inlined Constant Z.geb => "(Prelude.>=)".
Extract Inlined Constant Z.min => "Prelude.min".
Extract Inlined Constant Z.max => "Prelude.max".
Extract Inlined Constant Z.div => "((\x y -> if y Prelude.== 0 then 0 else Prelude.div x y))".
Extract Inlined Constant Z.modulo => "((\x y -> if y Prelude.== 0 then 0 else Prelude.mod x y))".

Extract Inlined Constant Z.land => "(Data.Bits..&.)".
Extract Inlined Constant Z.lor => "(Data.Bits..|.)".

(* Just keep x for {x | P x }. *)
Extraction Inline Specif.proj1_sig.


Require Import oeuf.Common.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.
Require Import oeuf.ListLemmas.
Require Import oeuf.Metadata.
Require Import oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.
Require oeuf.StepLib.

Definition function_name := nat.

(* List containing a flag for each argument, `true` if Elim should recurse on
   that argument, `false` if it shouldn't.  The length gives the number of
   arguments. *)
Definition rec_info := list bool.

Inductive expr :=
| Value (v : value)
| Arg
| UpVar (idx : nat)
| Call (f : expr) (a : expr)
| MkConstr (tag : nat) (args : list expr)
| Elim (loop : expr) (cases : list (expr * rec_info)) (target : expr)
| MkClose (f : function_name) (free : list expr)
| OpaqueOp (op : opaque_oper_name) (args : list expr)
.

Inductive is_value : expr -> Prop :=
| IsValue : forall v, is_value (Value v).

Definition env := list expr.

Fixpoint unroll_elim (case : expr)
                     (args : list value)
                     (rec : rec_info)
                     (mk_rec : expr -> expr) : option expr :=
    match args, rec with
    | [], [] => Some case
    | arg :: args, r :: rec =>
            let case := Call case (Value arg) in
            let case := if r then Call case (mk_rec (Value arg)) else case in
            unroll_elim case args rec mk_rec
    | _, _ => None
    end.

Inductive state :=
| Run (e : expr) (l : list value) (k : value -> state)
| Stop (v : value).

Inductive sstep (E : env) : state -> state -> Prop :=
| SArg : forall l k v,
        nth_error l 0 = Some v ->
        sstep E (Run Arg l k) (k v)
| SUpVar : forall n l k v,
        nth_error l (S n) = Some v ->
        sstep E (Run (UpVar n) l k) (k v)

| SCloseStep : forall tag vs e es l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep E (Run (MkClose tag (vs ++ [e] ++ es)) l k)
                (Run e l (fun v => Run (MkClose tag (vs ++ [Value v] ++ es)) l k))
| SCloseDone : forall tag vs l k,
        let es := map Value vs in
        sstep E (Run (MkClose tag es) l k) (k (Close tag vs))

| SConstrStep : forall fname vs e es l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep E (Run (MkConstr fname (vs ++ [e] ++ es)) l k)
                (Run e l (fun v => Run (MkConstr fname (vs ++ [Value v] ++ es)) l k))
| SConstrDone : forall fname vs l k,
        let es := map Value vs in
        sstep E (Run (MkConstr fname es) l k) (k (Constr fname vs))

| SOpaqueOpStep : forall op vs e es l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep E (Run (OpaqueOp op (vs ++ [e] ++ es)) l k)
                (Run e l (fun v => Run (OpaqueOp op (vs ++ [Value v] ++ es)) l k))
| SOpaqueOpDone : forall op vs l k v,
        let es := map Value vs in
        opaque_oper_denote_higher op vs = Some v ->
        sstep E (Run (OpaqueOp op es) l k) (k v)

| SCallL : forall e1 e2 l k,
        ~ is_value e1 ->
        sstep E (Run (Call e1 e2) l k)
                (Run e1 l (fun v => Run (Call (Value v) e2) l k))
| SCallR : forall e1 e2 l k,
        is_value e1 ->
        ~ is_value e2 ->
        sstep E (Run (Call e1 e2) l k)
                (Run e2 l (fun v => Run (Call e1 (Value v)) l k))
| SMakeCall : forall fname free arg l k body,
        nth_error E fname = Some body ->
        sstep E (Run (Call (Value (Close fname free)) (Value arg)) l k)
                (Run body (arg :: free) k)

| SElimStepLoop : forall loop cases target l k,
        ~ is_value loop ->
        sstep E (Run (Elim loop cases target) l k)
                (Run loop l (fun v => Run (Elim (Value v) cases target) l k))
| SElimStep : forall loop cases target l k,
        is_value loop ->
        ~ is_value target ->
        sstep E (Run (Elim loop cases target) l k)
                (Run target l (fun v => Run (Elim loop cases (Value v)) l k))
| SEliminate : forall loop cases tag args l k case rec e',
        is_value loop ->
        nth_error cases tag = Some (case, rec) ->
        unroll_elim case args rec (fun x => Call loop x) = Some e' ->
        sstep E (Run (Elim loop cases (Value (Constr tag args))) l k)
                (Run e' l k)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

(* Proofs *)

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition expr_rect_mut
        (P : expr -> Type)
        (Pl : list expr -> Type)
        (Pp : expr * rec_info -> Type)
        (Plp : list (expr * rec_info) -> Type)
    (HValue :   forall v, P (Value v))
    (HArg :     P Arg)
    (HUpVar :   forall n, P (UpVar n))
    (HCall :    forall f a, P f -> P a -> P (Call f a))
    (HConstr :  forall tag args, Pl args -> P (MkConstr tag args))
    (HElim :    forall loop cases target,
        P loop -> Plp cases -> P target -> P (Elim loop cases target))
    (HClose :   forall f free, Pl free -> P (MkClose f free))
    (HOpaqueOp : forall o args, Pl args -> P (OpaqueOp o args))
    (Hnil :     Pl [])
    (Hcons :    forall e es, P e -> Pl es -> Pl (e :: es))
    (Hpair :    forall e r, P e -> Pp (e, r))
    (Hnil_p :   Plp [])
    (Hcons_p :  forall p ps, Pp p -> Plp ps -> Plp (p :: ps))
    (e : expr) : P e :=
    let fix go e :=
        let fix go_list es :=
            match es as es_ return Pl es_ with
            | [] => Hnil
            | e :: es => Hcons e es (go e) (go_list es)
            end in
        let go_pair p :=
            let '(e, r) := p in
            Hpair e r (go e) in
        let fix go_pair_list ps :=
            match ps as ps_ return Plp ps_ with
            | [] => Hnil_p
            | p :: ps => Hcons_p p ps (go_pair p) (go_pair_list ps)
            end in
        match e as e_ return P e_ with
        | Value v => HValue v
        | Arg => HArg
        | UpVar n => HUpVar n
        | Call f a => HCall f a (go f) (go a)
        | MkConstr tag args => HConstr tag args (go_list args)
        | Elim loop cases target =>
                HElim loop cases target (go loop) (go_pair_list cases) (go target)
        | MkClose f free => HClose f free (go_list free)
        | OpaqueOp o args => HOpaqueOp o args (go_list args)
        end in go e.

Definition expr_rect_mut'
        (P : expr -> Type)
        (Pl : list expr -> Type)
        (Pp : expr * rec_info -> Type)
        (Plp : list (expr * rec_info) -> Type)
    HValue HArg HUpVar HCall HConstr HElim HClose HOpaqueOp Hnil Hcons Hpair Hnil_p Hcons_p
    : (forall e, P e) * (forall es, Pl es) * (forall p, Pp p) * (forall ps, Plp ps) :=
    let go := expr_rect_mut P Pl Pp Plp
        HValue HArg HUpVar HCall HConstr HElim HClose HOpaqueOp Hnil Hcons Hpair Hnil_p Hcons_p
    in
    let fix go_list es :=
        match es as es_ return Pl es_ with
        | [] => Hnil
        | e :: es => Hcons e es (go e) (go_list es)
        end in
    let go_pair p :=
        let '(e, r) := p in
        Hpair e r (go e) in
    let fix go_pair_list ps :=
        match ps as ps_ return Plp ps_ with
        | [] => Hnil_p
        | p :: ps => Hcons_p p ps (go_pair p) (go_pair_list ps)
        end in
    (go, go_list, go_pair, go_pair_list).

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition expr_ind' (P : expr -> Prop) (Pp : (expr * rec_info) -> Prop)
    (HValue :   forall v, P (Value v))
    (HArg :     P Arg)
    (HUpVar :   forall n, P (UpVar n))
    (HCall :    forall f a, P f -> P a -> P (Call f a))
    (HConstr :  forall c args, Forall P args -> P (MkConstr c args))
    (HElim :    forall loop cases target,
        P loop -> Forall Pp cases -> P target -> P (Elim loop cases target))
    (HClose :   forall f free, Forall P free -> P (MkClose f free))
    (HOpaqueOp : forall o args, Forall P args -> P (OpaqueOp o args))
    (Hpair :    forall e r, P e -> Pp (e, r))
    (e : expr) : P e :=
    ltac:(refine (@expr_rect_mut P (Forall P) Pp (Forall Pp)
        HValue HArg HUpVar HCall HConstr HElim HClose HOpaqueOp _ _ Hpair _ _ e); eauto).

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition expr_ind'' (P : expr -> Prop)
    (HValue :   forall v, P (Value v))
    (HArg :     P Arg)
    (HUpVar :   forall n, P (UpVar n))
    (HCall :    forall f a, P f -> P a -> P (Call f a))
    (HConstr :  forall c args, Forall P args -> P (MkConstr c args))
    (HElim :    forall loop cases target,
        P loop ->
        Forall (fun c => P (fst c)) cases ->
        P target ->
        P (Elim loop cases target))
    (HClose :   forall f free, Forall P free -> P (MkClose f free))
    (HOpaqueOp : forall o args, Forall P args -> P (OpaqueOp o args))
    (e : expr) : P e :=
    ltac:(refine (@expr_rect_mut P (Forall P) (fun c => P (fst c)) (Forall (fun c => P (fst c)))
        HValue HArg HUpVar HCall HConstr HElim HClose HOpaqueOp _ _ _ _ _ e); eauto).

(*
 * Misc lemmas
 *)

Lemma unroll_elim_length : forall case args rec mk_rec,
    length args = length rec <-> unroll_elim case args rec mk_rec <> None.
first_induction args; destruct rec; intros; split; simpl;
  try solve [intro; congruence].

- intro Hlen. simpl. eapply IHargs. congruence.
- intro Hcall. f_equal. apply <- IHargs. eauto.
Qed.

Lemma length_unroll_elim : forall case args rec mk_rec,
    length args = length rec ->
    exists e, unroll_elim case args rec mk_rec = Some e.
first_induction args; destruct rec; intros0 Hlen; simpl in Hlen; try discriminate Hlen.
- eexists. reflexivity.
- inv Hlen.
  fwd eapply IHargs; try eassumption.
Qed.

Require oeuf.Semantics.

Definition prog_type : Type := list expr * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Definition initial_env (prog : prog_type) : env := fst prog.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body,
        nth_error (fst prog) fname = Some body ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body (av :: free) Stop).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).


Require ClassicalEpsilon.
Require Import Reals Psatz.
From stdpp Require Import tactics.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice bigop.
From discprob.basic Require Import base sval order monad bigop_ext nify.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad.idxval Require Import pival_dist pival ival_dist ival ival_pair pidist_singleton idist_pidist_pair extrema.

Import Lub.

(* This is an inductive characterization of eq_ivd_prob, as is proved later *)
Inductive irrel_ivd : ∀ X, ivdist X → ivdist X → Prop :=
  | irrel_ivd_refl X : ∀ (I: ivdist X), irrel_ivd X I I
  | irrel_ivd_sym X : ∀ I1 I2, irrel_ivd X I1 I2 → irrel_ivd X I2 I1
  | irrel_ivd_trans X : ∀ I1 I2 I3, irrel_ivd X I1 I2 → irrel_ivd X I2 I3 → irrel_ivd X I1 I3
  | irrel_ivd_proper X :
      ∀ I1 I1' I2 I2', eq_ivd I1 I1' → eq_ivd I2 I2' → irrel_ivd X I1 I2 → irrel_ivd X I1' I2'
  | irrel_ivd_irrel X : ∀ {Y} I1 (I0: ivdist Y), irrel_ivd X I1 (x ← I0; I1)
  | irrel_ivd_bind X Y: ∀ (I1 I2: ivdist X) (f1 f2: X → ivdist Y),
      irrel_ivd X I1 I2 →
      (∀ x, irrel_ivd Y (f1 x) (f2 x)) →
      irrel_ivd Y (x ← I1; f1 x) (x ← I2; f2 x).

Arguments irrel_ivd {_}.

Definition le_pidist_irrel :=
  λ {X : Type} (Is1 Is2 : pidist X), ∀ I : ivdist X, In (I: ival X) Is1 → ∃ I' : ivdist X, irrel_ivd I I' ∧ In (I': ival X) Is2.

Lemma le_pidist_irrel_refl {X: Type} (Is1: pidist X):
  le_pidist_irrel Is1 Is1.
Proof.
  intros I Hin. exists I; split; eauto. apply irrel_ivd_refl.
Qed.

Lemma irrel_ivd_support_coerce {X} (I1 I2: ivdist X) :
  irrel_ivd I1 I2 →
  ∀ x, (∃ i2, ind I2 i2 = x ∧ val I2 i2 > 0) ↔ (∃ i1, ind I1 i1 = x ∧ val I1 i1 > 0).
Proof.
  induction 1.
  - split; intros; auto.
  - intros. by rewrite (IHirrel_ivd x).
  - intros. by rewrite (IHirrel_ivd2 x).
  - intros.
    rewrite (eq_ival_support_coerce I1 I1'); eauto.
    rewrite (eq_ival_support_coerce I2 I2'); eauto.
  - intros.
    * split.
      ** intros ((i0&i1)&Heq&Hgt). exists i1.
         rewrite //= in Heq Hgt.
         split; auto. specialize (val_nonneg I0 i0); nra.
      ** intros (i1&Heq&Hgt).
         edestruct (ivd_support_idx I0) as (i0&Hgt').
         exists (existT i0 i1); split => //=; nra.
  - intros x. split.
    * intros ((i2&if2)&Hind&Hval).
      rewrite //= in Hind.
      edestruct (IHirrel_ivd (ind I2 i2)) as (HI2&_).
      edestruct (HI2) as (i1&Hindeq&?).
      { eexists.  split; eauto. rewrite //= in Hval. specialize (val_nonneg (f2 (ind I2 i2)) if2).
        nra. }
      edestruct (H1 (ind I2 i2)) as (Hf2&_).
      edestruct Hf2 as (if1&?&?).
      { eexists.  split; eauto. rewrite //= in Hval.
        specialize (val_nonneg I2 i2); nra. }
      unshelve (eexists).
      { exists i1. rewrite Hindeq; exact if1.  }
      split => //=; destruct Hindeq.
      ** rewrite /eq_rect_r//=.
      ** rewrite /eq_rect_r//=. nra.
    * intros ((i2&if2)&Hind&Hval).
      rewrite //= in Hind.
      edestruct (IHirrel_ivd (ind I1 i2)) as (_&HI2).
      edestruct (HI2) as (i1&Hindeq&?).
      { eexists.  split; eauto. rewrite //= in Hval. specialize (val_nonneg (f1 (ind I1 i2)) if2).
        nra. }
      edestruct (H1 (ind I1 i2)) as (_&Hf2).
      edestruct Hf2 as (if1&?&?).
      { eexists.  split; eauto. rewrite //= in Hval.
        specialize (val_nonneg I1 i2); nra. }
      unshelve (eexists).
      { exists i1. rewrite Hindeq; exact if1.  }
      split => //=; destruct Hindeq.
      ** rewrite /eq_rect_r//=.
      ** rewrite /eq_rect_r//=. nra.
Qed.

Lemma le_pidist_irrel_support_coerce_aux {X} (Is1 Is2: pidist X) :
  le_pidist_irrel Is2 Is1 →
  ∀ x, In_psupport x Is2 → In_psupport x Is1.
Proof.
  intros Hle x (I2&i2&Hin2&?&Hval).
  destruct (Hle {| ivd_ival := I2; val_sum1 := all_sum1 Is2 _ Hin2|}) as (I1&Heq&Hin1); eauto.
  exists I1. edestruct (irrel_ivd_support_coerce _ _ Heq) as (i1&?&?).
  { eauto. }
  eexists; split; eauto.
Qed.

Global Instance irrel_ivd_proper_instance {X} : Proper (@eq_ivd X ==> @eq_ivd X ==> iff) (@irrel_ivd X).
Proof.
  intros I1 I1' Heq1 I2 I2' Heq2.
  split; intros; eapply irrel_ivd_proper; eauto; try by symmetry.
Qed.

Global Instance irrel_ivd_Transitivite {X}: Transitive (@irrel_ivd X).
Proof. intros ???. apply irrel_ivd_trans. Qed.
Global Instance irrel_ivd_Reflexive {X}: Reflexive (@irrel_ivd X).
Proof. intros ?. apply irrel_ivd_refl. Qed.
Global Instance irrel_ivd_Symmetry {X}: Symmetric (@irrel_ivd X).
Proof. intros ??. apply irrel_ivd_sym. Qed.

Lemma is_Ex_ival_irrel_proper_bind {X Y} f (f1 f2: X → ivdist Y) (I1 I2: ivdist X) v
      (Hirrel_ivd : irrel_ivd I1 I2)
      (Hall_irrel : ∀ x : X, irrel_ivd (f1 x) (f2 x))
      (IHinner : ∀ (x : X) (f : Y → R) (v : R), is_Ex_ival f (f1 x) v ↔ is_Ex_ival f (f2 x) v)
      (IHirrel_ivd : ∀ (f : X → R) (v : R), is_Ex_ival f I1 v ↔ is_Ex_ival f I2 v):
  is_Ex_ival f (ivd_bind _ _ f1 I1) v → is_Ex_ival f (ivd_bind _ _ f2 I2) v.
Proof.
  intros His.
  assert (ex_Ex_ival f (ivd_bind _ _ f1 I1)).
  { eapply is_Ex_ival_ex; eauto. }
  rewrite -(is_Ex_ival_unique _ _ _ His).
  feed pose proof (ex_Ex_ival_bind_post (λ x, Rabs (f x)) I1 f1) as Hex_I1.
  { eapply ex_Ex_ival_to_Rabs, is_Ex_ival_ex. eauto. }
  feed pose proof (ex_Ex_ival_bind_post f I1 f1) as Hex_I1'.
  { eapply is_Ex_ival_ex. eauto. }
  rewrite Ex_ival_bind_post //=.
  assert (ex_Ex_ival f (ivd_bind _ _ f2 I2)).
  {
    apply ex_Ex_ival_from_Rabs, ex_Ex_ival_bind_post_inv; eauto using Rabs_pos, Rle_ge.
    ** intros.
       apply is_Ex_ival_ex, ex_Ex_ival_to_Rabs in His.
       edestruct (irrel_ivd_support_coerce I1 I2) as (Hlr&Hrl); eauto.
       edestruct Hlr as (i1&Heqi1&Hvali1); eauto.
       eapply ex_Ex_ival_bind_inv in His; eauto.
       eapply ex_Ex_ival_is in His as (v'&His).
       rewrite -Heqi1.
       eapply is_Ex_ival_ex. eapply IHinner; eauto.
    ** apply ex_Ex_ival_is in Hex_I1 as (v'&His').
       eapply is_Ex_ival_ex; eapply IHirrel_ivd.
       eapply is_Ex_ival_proper_fun_support; eauto.
       intros x Hsupport => //=.
       symmetry.
       apply is_Ex_ival_unique.
       eapply IHinner.
       eapply Ex_ival_correct. eapply (ex_Ex_ival_bind_inv (λ x, Rabs (f x)) f1 I1); eauto.
       apply ex_Ex_ival_to_Rabs. eapply is_Ex_ival_ex; eauto.
  }
  cut (Ex_ival f (ivd_bind _ _ f2 I2) = (Ex_ival (λ x, Ex_ival f (f1 x)) I1)).
  { intros HEx. rewrite -HEx. apply Ex_ival_correct; eauto. }
  rewrite Ex_ival_bind_post //=.
  apply is_Ex_ival_unique.
  eapply IHirrel_ivd.
  eapply is_Ex_ival_proper_fun_support; last first.
  { eapply Ex_ival_correct. eauto. }
  intros => //=.
  symmetry.
  apply is_Ex_ival_unique.
  eapply IHinner.
  eapply Ex_ival_correct. eapply (ex_Ex_ival_bind_inv f f1 I1); eauto.
Qed.

Lemma is_Ex_ival_irrel_proper {A} f (I I': ivdist A) v :
  irrel_ivd I I' →
  is_Ex_ival f I v ↔
  is_Ex_ival f I' v.
Proof.
  intros irrel_ivd.
  revert v.
  induction irrel_ivd; auto; intros.
  - symmetry.  eapply IHirrel_ivd.
  - rewrite IHirrel_ivd1. auto.
  - rewrite /eq_ivd in H.
    etransitivity; first etransitivity; try eapply IHirrel_ivd.
    { split; apply is_Ex_ival_proper; eauto. by symmetry. }
    { split; apply is_Ex_ival_proper; eauto. by symmetry. }
  - split. apply is_Ex_ival_bind_irrel, val_sum1.
    intros His. cut (ex_Ex_ival f I1).
    { intros Hex. apply Ex_ival_correct in Hex.
      cut (Ex_ival f I1 = v); intros; subst; eauto.
      eapply is_Ex_ival_unique'; last eassumption.
      apply is_Ex_ivd_bind_irrel; eauto.
    }
    apply is_Ex_ival_ex in His.
    unshelve (eapply ex_Ex_ival_bind_inv in His; eauto).
    { exact (sval (ivd_support_idx I0)). }
    destruct (ivd_support_idx _) => //=.
  - split; eapply is_Ex_ival_irrel_proper_bind; eauto; try (intros; by symmetry).
Qed.

Lemma ex_Ex_ival_irrel_proper {A} f (I I': ivdist A) :
  irrel_ivd I I' →
  ex_Ex_ival f I →
  ex_Ex_ival f I'.
Proof.
  intros Hirrel (v&His)%ex_Ex_ival_is.
  eapply is_Ex_ival_ex.
  eapply is_Ex_ival_irrel_proper; eauto.
    by symmetry.
Qed.

Lemma Ex_ival_irrel_proper {A} f (I I': ivdist A) :
  irrel_ivd I I' →
  ex_Ex_ival f I →
  Ex_ival f I = Ex_ival f I'.
Proof.
  intros. symmetry. apply is_Ex_ival_unique.
  eapply is_Ex_ival_irrel_proper; eauto.
  * symmetry. eauto.
  * apply Ex_ival_correct; eauto.
Qed.

Lemma irrel_ivd_to_eq_ivd_prob {X} (I1 I2: ivdist X):
  irrel_ivd I1 I2 →
  eq_ivd_prob I1 I2.
Proof.
  intros Hirrel.
  apply eq_ivd_prob_alt.
  intros x.
  transitivity ((Pr (λ v, v = x) I1)).
  { rewrite /Ex_ival/idx_eq_ind//=. eapply SeriesC_ext; intros.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; nra.
  }
  transitivity ((Pr (λ v, v = x) I2)); last first.
  { rewrite /Ex_ival/idx_eq_ind//=. eapply SeriesC_ext; intros.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; nra.
  }
  apply Ex_ival_irrel_proper; eauto.
  apply ex_Pr.
Qed.

Lemma In_isupport_pr_gt_0 {X: Type} (I: ivdist X) (x: X):
  In_isupport x I →
  0 < Pr (eq ^~ x) I.
Proof.
  rewrite /Pr/Ex_ival => Hin.
  destruct Hin as (i&?&?).
  eapply (Series_strict_pos _ (pickle i)).
  { intros.  rewrite /countable_sum/oapp.
    destruct pickle_inv; try nra.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra.
    rewrite Rmult_1_l. apply val_nonneg.
  }
  { intros.  rewrite /countable_sum/oapp.
    rewrite pickleK_inv.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra.
  }
  feed pose proof (ex_Pr (eq^~ x) I).
  apply ex_Ex_ival_is in H1 as (v&?).
  rewrite /is_Ex_ival in H1.
  destruct H1 as (Hex&His).
  eexists. eauto.
Qed.

Lemma pr_gt_0_In_isupport {X: Type} (I: ivdist X) (x: X):
  0 < Pr (eq ^~ x) I →
  In_isupport x I.
Proof.
  rewrite /Pr/Ex_ival => Hin.
  eapply (Series_strict_pos_inv) in Hin as (n&?).
  {
   destruct (@pickle_inv (idx I) n) as [i|] eqn:Heq.
   - exists i. rewrite  //=/countable_sum//= Heq //= in H.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra.
    * rewrite //= in H. split; eauto. nra.
    * rewrite //= in H. nra.
   - rewrite //=/countable_sum//= Heq //= in H ; nra.
  }
  intros n. rewrite /countable_sum. destruct pickle_inv => //=; last nra.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra.
    rewrite Rmult_1_l. apply val_nonneg.
Qed.

(* This is a kind of conditional distribution *)
Lemma ival_slice_proof1 (X : Type) (I : ivdist X) (x : X):
  ∀ i : idx I, (if ClassicalEpsilon.excluded_middle_informative (In_isupport x I)
                then
                 (if ClassicalEpsilon.excluded_middle_informative (ind I i = x) then val I i else 0) /
                 Pr (eq^~ x) I
                else val I i) ≥ 0.
Proof.
  intros i.
  destruct ClassicalEpsilon.excluded_middle_informative; eauto; last apply val_nonneg.
  apply Rle_ge, Rdiv_le_0_compat.
  { destruct ClassicalEpsilon.excluded_middle_informative => //=; eauto; try nra.
    apply Rge_le, val_nonneg. }
  { apply In_isupport_pr_gt_0; eauto. }
Qed.

Definition ival_slice {X} (I: ivdist X) (x: X) : ival X.
  refine {| idx := idx I;
            ind := ind I;
            val := λ i,
                   if ClassicalEpsilon.excluded_middle_informative (In_isupport x I) then
                   (if ClassicalEpsilon.excluded_middle_informative (ind I i = x) then
                          val I i
                        else
                          0) / Pr (λ i, i = x) I
                   else
                     val I i|}.
  apply ival_slice_proof1.
Defined.

Lemma ival_slice_proof2 (X : Type) (I : ivdist X) (x : X):
  is_series (countable_sum (val (ival_slice I x))) 1.
Proof.
  rewrite //=. destruct ClassicalEpsilon.excluded_middle_informative; last apply val_sum1.
  replace 1 with (Pr (eq^~ x) I */ Pr (eq^~ x) I); last first.
  { field. apply Rgt_not_eq, In_isupport_pr_gt_0; auto. }
  apply is_seriesC_scal_r.
  rewrite /Pr/Ex_ival.
  apply (is_seriesC_ext _ (λ i0 : idx I, (if is_left (ClassicalEpsilon.excluded_middle_informative (ind I i0 = x))
                          then 1
                          else 0) * val I i0)).
  { intros.  destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra. }

  {
  feed pose proof (ex_Pr (eq^~ x) I) as Hpr.
  apply ex_Ex_ival_is in Hpr as (v&Hpr).
  rewrite /is_Ex_ival in Hpr.
  destruct Hpr as (Hex&His).
  eapply Series_correct; eexists; eauto. }
Qed.

Definition ivdist_slice {X} (I: ivdist X) (x: X) : ivdist X.
Proof.
  exists (ival_slice I x).
  apply ival_slice_proof2.
Defined.

Lemma eq_ivd_prob_Pr_eq {X} (I1 I2: ivdist X) x:
  eq_ivd_prob I1 I2 →
  Pr (eq^~ x) I1 = Pr (eq^~ x) I2.
Proof.
  rewrite /Pr/Ex_ival => Heq.
  unshelve (eapply eq_ivd_prob_alt in Heq); first exact x.
  rewrite /idx_eq_ind in Heq.
  setoid_rewrite Rmult_if_distrib.
  setoid_rewrite Rmult_0_l.
  setoid_rewrite Rmult_1_l.
  eauto.
Qed.

Lemma eq_ivd_prob_In_isupport {X: Type} I1 I2 (x: X):
  eq_ivd_prob I1 I2 →
  In_isupport x I1 →
  In_isupport x I2.
Proof.
  intros Heq Hin%In_isupport_pr_gt_0.
  apply pr_gt_0_In_isupport.
  erewrite <-eq_ivd_prob_Pr_eq; last eassumption.
  eauto.
Qed.

Lemma eq_ivd_prob_to_irrel_ivd {X} (I1 I2: ivdist X):
  eq_ivd_prob I1 I2 →
  irrel_ivd I1 I2.
Proof.
  intros Heq.
  transitivity (x ← I1; _ ← ivdist_slice I2 x; mret x).
  { transitivity (x ← I1; mret x).
    { rewrite ivd_right_id. reflexivity. }
    apply irrel_ivd_bind; first reflexivity.
    intros x. apply irrel_ivd_irrel.
  }
  transitivity (x ← I2; _ ← ivdist_slice I1 x; mret x); last first.
  { symmetry.
    transitivity (x ← I2; mret x).
    { rewrite ivd_right_id. reflexivity. }
    apply irrel_ivd_bind; first reflexivity.
    intros x. apply irrel_ivd_irrel.
  }
  cut (eq_ivd (I1 ≫= (λ x : X, ivdist_slice I2 x ≫= (λ _ : X, mret x)))
    (I2 ≫= (λ x : X, ivdist_slice I1 x ≫= (λ _ : X, mret x)))).
  { intros ->.  reflexivity. }

  apply eq_ival_nondep_inj_surj_suffice.
  apply eq_ival_nondep_inj_surj'_helper.
  unshelve eexists.
  { intros (i1&i2&?). exists i2. exists i1. exact tt. }
  rewrite //=.
  split_and!.
  * intros (i1&i2&[]) (i1'&i2'&[]) _ _ => //=.
    inversion 1; subst. auto.
  * intros (i2&i1&[]).
    unshelve (eexists).
    { exists i1.  exists i2. exact tt. }
    split_and!; eauto => //=.
    repeat  destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra; try congruence.
    ** intros Hgt. eapply Rge_gt_trans; last  eassumption.
       right. rewrite //=.
       cut (Pr (eq^~ (ind I2 i2)) I1 = Pr (eq^~ (ind I1 i1)) I2).
       { intros ->.  nra. }
       rewrite e0; eapply eq_ivd_prob_Pr_eq; eauto.
    ** intros; exfalso. eapply n. rewrite e.
       eapply eq_ivd_prob_In_isupport; eauto.
    ** intros; exfalso. eapply n. rewrite e.
       eapply eq_ivd_prob_In_isupport; eauto.
       by symmetry.
    ** cut (val I2 i2 = 0).
       { intros ->. nra. }
       destruct (val_nonneg I2 i2); last auto.
       exfalso. eapply n.
       eapply eq_ivd_prob_In_isupport; eauto.
       { by symmetry. }
       eexists; eauto.
  * intros (i1&i2&[]) => //=.
    repeat  destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra; try congruence.
    cut (val I1 i1 = 0).
    { intros ->.  nra. }
    destruct (val_nonneg I1 i1); last auto.
    exfalso. eapply n.
    eapply eq_ivd_prob_In_isupport; eauto.
    eexists; eauto.
  * intros (i1&i2&[]) => //=.
    repeat  destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra; try congruence.
    ** intros Hgt.
       cut (Pr (eq^~ (ind I2 i2)) I1 = Pr (eq^~ (ind I1 i1)) I2).
       { intros ->.  nra. }
       rewrite e0; eapply eq_ivd_prob_Pr_eq; eauto.
    ** intros; exfalso. eapply n. rewrite e.
       eapply eq_ivd_prob_In_isupport; eauto.
       by symmetry.
    ** intros; exfalso. eapply n. rewrite e.
       eapply eq_ivd_prob_In_isupport; eauto.
    ** cut (val I1 i1 = 0).
       { intros ->. nra. }
       destruct (val_nonneg I1 i1); last auto.
       exfalso. eapply n.
       eapply eq_ivd_prob_In_isupport; eauto.
       eexists; eauto.
Qed.

Lemma irrel_ivd_choice {X} (I1 I1' I2 I2': ivdist X) p Hpf Hpf':
      irrel_ivd I1 I2 →
      irrel_ivd I1' I2' →
      irrel_ivd (ivdplus p Hpf I1 I1') (ivdplus p Hpf' I2 I2').
Proof.
  intros Hirrel1 Hirrel2.
  transitivity (b ← ivdplus p Hpf (mret true) (mret false);
                if (b: bool) then I1 else I1').
  { rewrite ivd_plus_bind ?ivd_left_id. reflexivity. }
  transitivity (b ← ivdplus p Hpf' (mret true) (mret false);
                if (b: bool) then I2 else I2'); last first.
  { rewrite ivd_plus_bind ?ivd_left_id. reflexivity. }
  apply irrel_ivd_bind.
  { cut (eq_ivd (ivdplus p Hpf (mret true) (mret false)) (ivdplus p Hpf' (mret true) (mret false))).
    { intros ->; reflexivity. }
    apply ivdist_plus_proper; reflexivity.
  }
  intros [|]; eauto.
Qed.

Definition irrel_pidist {X: Type} (Is1 Is2: pidist X) :=
  ∀ f, bounded_fun f → Rbar_le (Ex_min f Is2) (Ex_min f Is1).

Lemma irrel_pidist_Ex_max {X: Type} (Is1 Is2: pidist X) :
    irrel_pidist Is1 Is2 → ∀ f, bounded_fun f → Rbar_le (Ex_max f Is1) (Ex_max f Is2).
Proof.
  intros Hirrel f Hb.
  rewrite ?Ex_max_neg_min.
  apply Rbar_opp_le.
  apply Hirrel.
  destruct Hb as (c&?).
  exists c => x. rewrite Rabs_Ropp; eauto.
Qed.

Lemma Ex_max_irrel_pidist {X: Type} (Is1 Is2: pidist X) :
  (∀ f, bounded_fun f → Rbar_le (Ex_max f Is1) (Ex_max f Is2)) →
  irrel_pidist Is1 Is2.
Proof.
  intros Hirrel f Hb.
  specialize (Hirrel (λ x, (- f x))).
  rewrite ?Ex_max_neg_min in Hirrel.
  apply Rbar_opp_le.
  setoid_rewrite Ropp_involutive in Hirrel.
  eapply Hirrel. destruct Hb as (c&?). exists c.
  intros x. rewrite Rabs_Ropp; eauto.
Qed.

Lemma irrel_pidist_refl {X} : ∀ I, @irrel_pidist X I I.
Proof. intros f Hb; reflexivity. Qed.

Lemma irrel_pidist_trans {X} :
   ∀ I1 I2 I3, @irrel_pidist X I1 I2 → @irrel_pidist X I2 I3 → @irrel_pidist X I1 I3.
Proof.
  intros I1 I2 I3 Hi1 Hi2 f Hb.
  specialize (Hi1 f Hb).
  specialize (Hi2 f Hb).
  etransitivity; eauto.
Qed.

Lemma bounded_supp_fun_le_pidist {A} f (Is Is': pidist A):
  le_pidist Is Is' →
  bounded_fun_on f (λ x, In_psupport x Is') →
  bounded_fun_on f (λ x, In_psupport x Is).
Proof.
  intros Hle Hbf.
  eapply bounded_fun_on_anti; try eassumption.
  intros a. eapply le_pidist_support_coerce_aux; eauto.
Qed.

Lemma Ex_min_le_pidist_irrel {X} (f: X → R) Is1 Is2:
  le_pidist_irrel Is1 Is2 →
  Rbar_le (Ex_min f Is2) (Ex_min f Is1).
Proof.
  intros Hle.
  rewrite /Ex_min.
  destruct (Glb_Rbar_correct (Ex_pidist f Is1)) as (Hlb&Hglb).
  apply Hglb. intros r Hex. destruct Hex as (I&Hin&Hex).
  edestruct (Hle {| ivd_ival := I; val_sum1 := all_sum1 Is1 _ Hin |}) as (I2&Heq&Hin2).
  { rewrite //=. }
  { eapply (is_Ex_ival_irrel_proper f) in Heq; last eauto.
    destruct (Glb_Rbar_correct (Ex_pidist f Is2)) as (Hlb2&Hglb2).
    eapply Hlb2. eexists; split; eauto.
    eapply Heq => //=.
  }
Qed.

Lemma Ex_max_le_pidist_irrel {X} (f: X → R) Is1 Is2:
  le_pidist_irrel Is1 Is2 →
  Rbar_le (Ex_max f Is1) (Ex_max f Is2).
Proof.
  rewrite ?Ex_max_neg_min.
  intros Hle.
  apply Rbar_opp_le.
  apply Ex_min_le_pidist_irrel; eauto.
Qed.

Lemma irrel_pidist_proper_irrel {X} :
  ∀ I1 I1' I2 I2', le_pidist_irrel I1' I1 → le_pidist_irrel I2 I2' →
                   @irrel_pidist X I1 I2 → @irrel_pidist X I1' I2'.
Proof.
  intros I1 I1' I2 I2' Hle1 Hle2 Hirrel12.
  intros f Hb.
  etransitivity.
  { apply Ex_min_le_pidist_irrel; eauto. }
  etransitivity.
  { eapply Hirrel12; eauto. }
  { apply Ex_min_le_pidist_irrel; eauto. }
Qed.

Lemma irrel_pidist_bind1 {X Y}: ∀ (I1 I2: pidist X) (f: X → pidist Y),
      @irrel_pidist X I1 I2 →
      @irrel_pidist Y (x ← I1; f x) (x ← I2; f x).
Proof.
  intros I1 I2 f Hirrel.
  intros g Hb.
  rewrite ?Ex_min_bind_post;
    eauto using Ex_min_bounded_is_bounded, ex_Ex_extrema_bounded_fun,
    Ex_min_bounded_fun_finite.
Qed.

Lemma irrel_pidist_bind {X Y}: ∀ (I1 I2: pidist X) (f1 f2: X → pidist Y),
      @irrel_pidist X I1 I2 →
      (∀ x, @irrel_pidist Y (f1 x) (f2 x)) →
      @irrel_pidist Y (x ← I1; f1 x) (x ← I2; f2 x).
Proof.
  intros I1 I2 f1 f2 Hirrel Hirrelfun.
  eapply irrel_pidist_trans.
  { eapply irrel_pidist_bind1; eauto. }
  intros f Hb. eapply Ex_min_bind_le;
    eauto using Ex_min_bounded_is_bounded, ex_Ex_extrema_bounded_fun,
    Ex_min_bounded_fun_finite.
  intros a ?. eapply Hirrelfun; eauto.
Qed.

Lemma irrel_pidist_proper X :
  ∀ (I1 I1' I2 I2': pidist X), le_pidist I1' I1 → le_pidist I2 I2'
                               → irrel_pidist I1 I2 → irrel_pidist I1' I2'.
Proof.
  intros ???? Hle1 Hle2. eapply irrel_pidist_proper_irrel.
  { intros x Hin. edestruct (Hle1 x) as (x'&Heq&Hin'); eauto.
    exists {| ivd_ival := x'; val_sum1 := all_sum1 I1 _ Hin'|}; split; auto.
    eapply irrel_ivd_proper; eauto; last apply irrel_ivd_refl.
    reflexivity.
  }
  { intros x Hin. edestruct (Hle2 x) as (x'&Heq&Hin'); eauto.
    exists {| ivd_ival := x'; val_sum1 := all_sum1 I2' _ Hin'|}; split; auto.
    eapply irrel_ivd_proper; eauto; last apply irrel_ivd_refl.
    reflexivity.
  }
Qed.

Global Instance irrel_pidist_mono_instance {X} : Proper (@le_pidist X --> @le_pidist X ==> Coq.Program.Basics.impl) (@irrel_pidist X).
Proof.
  intros I1 I1' Heq1 I2 I2' Heq2.
  intros Hirrel. eapply irrel_pidist_proper; eauto.
Qed.

Global Instance irrel_pidist_proper_instance {X} : Proper (@eq_pidist X ==> @eq_pidist X ==> iff) (@irrel_pidist X).
Proof.
  intros I1 I1' Heq1 I2 I2' Heq2.
  split; intros Hirrel; eapply irrel_pidist_proper; eauto;
    try (setoid_rewrite Heq1; reflexivity);
    try (setoid_rewrite Heq2; reflexivity).
Qed.

Global Instance irrel_pidist_Transitivite {X}: Transitive (@irrel_pidist X).
Proof. intros ???. apply irrel_pidist_trans. Qed.
Global Instance irrel_pidist_Reflexive {X}: Reflexive (@irrel_pidist X).
Proof. intros ?. apply irrel_pidist_refl. Qed.

Record irrel_couplingP {A1 A2} (I1: ivdist A1) (Is2: pidist A2) (P: A1 → A2 → Prop) : Type :=
  { irrel_I : ivdist A1;
    irrel_Is : pidist A2;
    irrel_rel_I : irrel_ivd I1 irrel_I;
    irrel_rel_Is : irrel_pidist irrel_Is Is2;
    irrel_couple_wit :> idist_pidist_couplingP irrel_I irrel_Is P
  }.

Definition lsupport {A1 A2 Is1 Is2 P} (Icouple: irrel_couplingP Is1 Is2 P) (y: A2) :=
  { x : A1 |  ∃ i Hpf, ival.ind Icouple i = (exist _ (x, y) Hpf) ∧ ival.val Icouple i > 0 }.
Definition rsupport {A1 A2 Is1 Is2 P} (Icouple: irrel_couplingP Is1 Is2 P) (x: A1) :=
  { y : A2 |  ∃ i Hpf, ival.ind Icouple i = (exist _ (x, y) Hpf) ∧ ival.val Icouple i > 0 }.

Definition irrel_coupling_propP {A1 A2} (I1: ivdist A1) (Is2: pidist A2) P : Prop :=
  ∃ (ic: irrel_couplingP I1 Is2 P), True.

Lemma ic_wit_to_prop {A1 A2} (I1 : ivdist A1) (Is2: pidist A2) P :
  irrel_couplingP I1 Is2 P →
  irrel_coupling_propP I1 Is2 P.
Proof.
  intros; eexists; eauto.
Qed.

Lemma ic_prop_to_wit {A1 A2} (I1 : ivdist A1) (Is2: pidist A2) P :
  irrel_coupling_propP I1 Is2 P →
  irrel_couplingP I1 Is2 P.
Proof.
  intros (?&_)%ClassicalEpsilon.constructive_indefinite_description; auto.
Qed.

Lemma irrel_pidist_support_coerce {X} (I1 I2: pidist X) :
  irrel_pidist I2 I1 →
  ∀ x, In_psupport x I2 → In_psupport x I1.
Proof.
  intros Hirrel x Hin.
  destruct Hin as (I&i&Hin&Hind&Hval).
  assert (0 < Pr (eq ^~ x) {| ivd_ival := I; val_sum1 := all_sum1 _ _ Hin|}).
  {  eapply In_isupport_pr_gt_0.
     eexists; eauto. }
  assert (Rbar_lt 0 (Pr_max (eq^~ x) I1)) as Hmax.
  {
    apply (Rbar_lt_le_trans _ (Pr_max (eq^~ x) I2)); last first.
    { eapply irrel_pidist_Ex_max; eauto.
      exists 1. intros. destruct (is_left); rewrite Rabs_right; nra.
    }
    apply (Rbar_lt_le_trans _ (Pr (eq^~ x) {| ivd_ival := I; val_sum1 := all_sum1 I2 I Hin |}));
      first done.
    apply Ex_max_spec1' => //=.
    eapply (ex_Pr (eq^~x) {| ivd_ival := I; val_sum1 := all_sum1 I2 I Hin |}).
  }
  assert (∃ I' : ivdist X, In (I': ival X) I1 ∧ 0 < Pr (eq^~x) I') as (I'&Hin'&Hpr').
  {
    apply Classical_Pred_Type.not_all_not_ex. intros Hneg.
    apply Rbar_lt_not_le in Hmax. apply Hmax.
    apply Ex_max_spec2.
    intros r' (I'&Hin'&Heq).
    apply Rbar_not_lt_le. intros Hlt.
    exfalso; eapply (Hneg {| ivd_ival := I'; val_sum1 := all_sum1 _ _ Hin'|}).
    split; first done.
    rewrite /Pr. erewrite is_Ex_ival_unique; last eassumption.
    auto.
  }
  exists I'. apply pr_gt_0_In_isupport in Hpr'.
  destruct Hpr' as (?&?&?). eexists; split_and!; eauto.
Qed.

Lemma irrel_pidist_choice {X} (I1 I1' I2 I2': pidist X) p Hpf Hpf':
      irrel_pidist I1 I2 →
      irrel_pidist I1' I2' →
      irrel_pidist (pidist_plus p Hpf I1 I1') (pidist_plus p Hpf' I2 I2').
Proof.
  intros Hirrel1 Hirrel2.
  transitivity (b ← pidist_plus p Hpf (mret true) (mret false);
                if (b: bool) then I1 else I1').
  { rewrite pidist_plus_bind ?pidist_left_id. reflexivity. }
  transitivity (b ← pidist_plus p Hpf' (mret true) (mret false);
                if (b: bool) then I2 else I2'); last first.
  { rewrite pidist_plus_bind ?pidist_left_id. reflexivity. }
  apply irrel_pidist_bind.
  { cut (eq_pidist (pidist_plus p Hpf (mret true) (mret false))
                   (pidist_plus p Hpf' (mret true) (mret false))).
    { intros ->; reflexivity. }
    apply pidist_plus_proper; reflexivity.
  }
  intros [|]; eauto.
Qed.

Lemma irrel_pidist_irrel {X Y}: ∀ I1 (I0: pidist Y), @irrel_pidist X (x ← I0; I1) I1.
Proof.
  intros. intros f Hbounded.
  rewrite Ex_min_bind_irrel //=; try reflexivity;
    eauto using Ex_min_bounded_is_bounded, ex_Ex_extrema_bounded_fun,
    Ex_min_bounded_fun_finite.
Qed.

Lemma irrel_coupling_proper {A1 A2} (I1 I2 : ivdist A1) (Is1 Is2: pidist A2) P:
  eq_ivd I1 I2 →
  eq_pidist Is1 Is2 →
  irrel_couplingP I1 Is1 P →
  irrel_couplingP I2 Is2 P.
Proof.
  intros HeqI HeqIs [I1' Is1' HeqI1 HeqIs1 Hcouple].
  exists I1' Is1'.
  - setoid_rewrite <-HeqI. done.
  - setoid_rewrite <-HeqIs. done.
  - done.
Qed.

Lemma irrel_coupling_mono {A1 A2} (I1 I2 : ivdist A1) (Is1 Is2: pidist A2) P:
  eq_ivd I1 I2 →
  le_pidist Is1 Is2 →
  irrel_couplingP I1 Is1 P →
  irrel_couplingP I2 Is2 P.
Proof.
  intros HeqI HeqIs [I1' Is1' HeqI1 HeqIs1 Hcouple].
  exists I1' Is1'.
  - setoid_rewrite <-HeqI. done.
  - setoid_rewrite <-HeqIs. done.
  - done.
Qed.

Lemma irrel_coupling_mono_irrel {A1 A2} (I1 I2 : ivdist A1) (Is1 Is2: pidist A2) P:
  eq_ivd I1 I2 →
  irrel_pidist Is1 Is2 →
  irrel_couplingP I1 Is1 P →
  irrel_couplingP I2 Is2 P.
Proof.
  intros HeqI HeqIs [I1' Is1' HeqI1 HeqIs1 Hcouple].
  exists I1' Is1'.
  - setoid_rewrite <-HeqI. done.
  - setoid_rewrite <-HeqIs. done.
  - done.
Qed.

Lemma irrel_coupling_mono_irrel' {A1 A2} (I1 I2 : ivdist A1) (Is1 Is2: pidist A2) P:
  irrel_ivd I1 I2 →
  irrel_pidist Is1 Is2 →
  irrel_couplingP I1 Is1 P →
  irrel_couplingP I2 Is2 P.
Proof.
  intros HeqI HeqIs [I1' Is1' HeqI1 HeqIs1 Hcouple].
  exists I1' Is1'.
  - setoid_rewrite <-HeqI. done.
  - setoid_rewrite <-HeqIs. done.
  - done.
Qed.

Global Instance irrel_coupling_prop_Proper {A1 A2}:
  Proper (@eq_ivd A1 ==> @le_pidist A2 ==> eq ==> impl) irrel_coupling_propP.
Proof.
  intros ?? Heq ?? Hle ?? ->.
  intros H%ic_prop_to_wit.
  apply ic_wit_to_prop.
  eapply irrel_coupling_mono; eauto.
Qed.

Global Instance irrel_coupling_prop_irrel_Proper {A1 A2}:
  Proper (@eq_ivd A1 ==> @irrel_pidist A2 ==> eq ==> impl) irrel_coupling_propP.
Proof.
  intros ?? Heq ?? Hle ?? ->.
  intros H%ic_prop_to_wit.
  apply ic_wit_to_prop.
  eapply irrel_coupling_mono_irrel; eauto.
Qed.

Lemma irrel_coupling_mret {A1 A2} (P: A1 → A2 → Prop) x y:
  P x y →
  irrel_couplingP (mret x) (mret y) P.
Proof.
  intros HP. exists (mret x) (mret y); try reflexivity.
  by apply ip_coupling_mret.
Qed.

Lemma irrel_coupling_prop_mret {A1 A2} (P: A1 → A2 → Prop) x y:
  P x y →
  irrel_coupling_propP (mret x) (mret y) P.
Proof.
  intros; apply ic_wit_to_prop, irrel_coupling_mret; auto.
Qed.

Lemma irrel_coupling_bind {A1 A2 B1 B2} P (f1: A1 → ivdist B1) (f2: A2 → pidist B2)
      I1 Is2 Q (Ic: irrel_couplingP I1 Is2 P):
  (∀ x y, P x y → irrel_couplingP (f1 x) (f2 y) Q) →
  irrel_couplingP (mbind f1 I1) (mbind f2 Is2) Q.
Proof.
  intros Hfc.
  destruct Ic as [I1' Is2' HeqI HeqIs Hcouple].
  destruct Hcouple as [I2' ? [Ic ? ?]%ic_coupling_to_id].
  unshelve (eexists).
  - refine (xy ← Ic; _).
     destruct xy as ((x&y)&HP).
     destruct (Hfc _ _ HP).
     exact irrel_I0.
  - refine (xy ← singleton Ic; _).
    destruct xy as ((x&y)&HP).
    destruct (Hfc x y HP).
    exact irrel_Is0.
  - etransitivity.
    { eapply irrel_ivd_bind.  eauto. reflexivity. }
    etransitivity.
    { eapply irrel_ivd_bind. setoid_rewrite idc_proj1. reflexivity. reflexivity.  }
    setoid_rewrite ivd_assoc. eapply irrel_ivd_bind; first reflexivity.
    intros ((x&y)&HP).
    destruct (Hfc _ _ _) as [? ? ?]. rewrite /irrel_I.
    rewrite /sval.  setoid_rewrite ivd_left_id. done.
  - etransitivity; last first.
    { eapply irrel_pidist_bind.
      - etransitivity; last by eauto. eapply irrel_pidist_proper; first by eauto.
        reflexivity. reflexivity.
      - intros; reflexivity.
    }
    setoid_rewrite idc_proj2. setoid_rewrite singleton_bind.
    setoid_rewrite pidist_assoc.
    eapply irrel_pidist_bind; first reflexivity.
    intros ((x&y)&HP).
    destruct (Hfc _ _ _) as [? ? ?]. rewrite /irrel_I.
    rewrite /sval. setoid_rewrite singleton_mret. setoid_rewrite pidist_left_id.
    eauto.
  - eapply (ip_coupling_bind _ _ _ _ (λ x y, x = y)).
    * apply ip_coupling_singleton.
    * intros ((?&?)&HP1) ((x&y)&HP2).
      inversion 1; subst.
      rewrite //=.
      assert (HP1 = HP2). { apply classical_proof_irrelevance. }
      subst.
      destruct (Hfc x y HP2). eauto.
Qed.

Lemma irrel_coupling_prop_bind {A1 A2 B1 B2} P (f1: A1 → ivdist B1) (f2: A2 → pidist B2)
      I1 Is2 Q (Ic: irrel_coupling_propP I1 Is2 P):
  (∀ x y, P x y → irrel_coupling_propP (f1 x) (f2 y) Q) →
  irrel_coupling_propP (mbind f1 I1) (mbind f2 Is2) Q.
Proof.
  intros; eapply ic_wit_to_prop, irrel_coupling_bind; intros; apply ic_prop_to_wit; eauto.
Qed.

Lemma irrel_coupling_trivial {A1 A2} (I: ivdist A1) (Is: pidist A2):
  irrel_couplingP I Is (λ x y, True).
Proof.
  assert ({ I' : ivdist A2 | In (I': ival A2) Is}) as (I'&Hin).
  { destruct Is as [(Is&Hne) Hall] => //=.
    rewrite //= in Hall.
    apply ClassicalEpsilon.constructive_indefinite_description in Hne as (I'&His).
    exists {| ivd_ival := I'; val_sum1 := Hall _ His |}.
    auto.
  }
  exists (x ← I'; I) (singleton (x ← I; I')).
  { eapply irrel_ivd_irrel. }
  { eapply irrel_pidist_proper_irrel; [| apply le_pidist_irrel_refl | reflexivity ].
    intros I0 Hin'. inversion Hin' as [Heq].
    exists I'; split; auto.
    eapply (irrel_ivd_proper _ (x ← I; I')).
    { rewrite /eq_ivd. rewrite -Heq //=. }
    { reflexivity. }
    symmetry. apply irrel_ivd_irrel.
  }
  exists (x ← I; I').
  { intros ?. eapply In_pidist_le_singleton. eexists; split; first reflexivity.
    rewrite /In/singleton//=. }
  unshelve (eexists).
  { refine (ivd_ival (x ← I; y ← I'; mret _)).
    exists (x, y); done. }
  - setoid_rewrite ival_bind_comm. setoid_rewrite ival_assoc.
    eapply ival_bind_congr; first reflexivity.
    intros.  setoid_rewrite ival_bind_mret_mret. setoid_rewrite ival_right_id. reflexivity.
  - setoid_rewrite ival_assoc.
    eapply ival_bind_congr; first reflexivity.
    intros.  setoid_rewrite ival_bind_mret_mret. setoid_rewrite ival_right_id. reflexivity.
Qed.

Lemma irrel_coupling_prop_trivial {A1 A2} (I: ivdist A1) (Is: pidist A2):
  irrel_coupling_propP I Is (λ x y, True).
Proof.
  apply ic_wit_to_prop, irrel_coupling_trivial.
Qed.

Lemma irrel_coupling_conseq {A1 A2} (P1 P2: A1 → A2 → Prop) (I: ivdist A1) (Is: pidist A2):
  (∀ x y, P1 x y → P2 x y) →
  irrel_couplingP I Is P1 →
  irrel_couplingP I Is P2.
Proof.
  intros HP Hirrel.
  destruct Hirrel as [I0 Is0 ? ? ?].
  exists I0 Is0; auto.
  eapply ip_coupling_conseq; eauto.
Qed.

Lemma irrel_coupling_plus {A1 A2} p Hpf p' Hpf'
      (P : A1 → A2 → Prop) (Is1 Is1': ivdist A1) (Is2 Is2': pidist A2) :
  p = p' →
  irrel_couplingP Is1 Is2 P →
  irrel_couplingP Is1' Is2' P →
  irrel_couplingP (ivdplus p Hpf Is1 Is1') (pidist_plus p' Hpf' Is2 Is2') P.
Proof.
  intros Hpeq Hic Hic'. subst.
  destruct Hic as [I1i Is2i Hirrel1i Hirrel2i Hwit].
  destruct Hic' as [I1i' Is2i' Hirrel1i' Hirrel2i' Hwit'].
  exists (ivdplus p' Hpf I1i I1i') (pidist_plus p' Hpf' Is2i Is2i').
  { eapply irrel_ivd_choice; eauto. }
  { eapply irrel_pidist_choice; eauto. }
  apply ip_coupling_plus; eauto.
Qed.

Lemma irrel_coupling_bind_condition {A1 B1 B2} (f1: A1 → ivdist B1) (f2: A1 → pidist B2)
      I Is Q x:
  (le_pidist (singleton I) Is ) →
  (irrel_couplingP (f1 x) (f2 x) Q) →
  irrel_couplingP (x ← I; y ← f1 x; mret (x, y))
                  (x ← Is; y ← f2 x; mret (x, y))
                  (λ xy1 xy2, fst xy1 = x → fst xy2 = x → Q (snd xy1) (snd xy2)).
Proof.
  intros Hle Hc.
  eapply (irrel_coupling_bind (λ x y, x = y)).
  { exists I Is; try reflexivity.
    exists I; eauto. apply ival_coupling_refl.
  }
  intros ? y ?; subst.
  destruct (ClassicalEpsilon.excluded_middle_informative (x = y)).
  - intros; subst. eapply irrel_coupling_bind; eauto.
    intros. apply irrel_coupling_mret => ? //=.
  - intros. eapply irrel_coupling_bind.
    * apply irrel_coupling_trivial.
    * intros. apply irrel_coupling_mret => ? //=. intros. congruence.
Qed.

Lemma irrel_coupling_support {X Y} I1 I2 (P: X → Y → Prop):
  ∀ (Ic: irrel_couplingP I1 I2 P),
  irrel_couplingP I1 I2 (λ x y, ∃ Hpf: P x y,  In_isupport x I1 ∧ In_psupport y I2 ∧
                        In_isupport (exist _ (x, y) Hpf) Ic).
Proof.
  intros [? ? Heq1 Heq2 Ic].
  specialize (ip_coupling_support _ _ _ Ic).
  eexists; eauto.
  eapply ip_coupling_conseq; eauto.
  intros x y (Hpf&Hin1&Hin2&?); exists Hpf; repeat split; auto.
  -  edestruct Hin1 as (i&?&?).
     edestruct (irrel_ivd_support_coerce _ _ Heq1) as (Hcoerce&_).
     apply Hcoerce; eauto.
  - eapply irrel_pidist_support_coerce; eauto.
Qed.

Lemma irrel_coupling_support_wit {X Y} I1 I2 (P: X → Y → Prop):
  ∀ (Ic: irrel_couplingP I1 I2 P),
    { xy : X * Y | ∃ Hpf : P (fst xy) (snd xy),
        In_isupport (fst xy) I1 ∧ In_psupport (snd xy) I2 ∧ In_isupport (exist _ xy Hpf) Ic }.
Proof.
  intros [? ? Heq1 Heq2 Ic].
  specialize (ip_coupling_support_wit _ _ _ Ic).
  rewrite //=.
  intros ((x&y)&Hpf).
  exists (x, y).
  destruct Hpf as (Hpf&Hin1&Hin2&?).
  exists Hpf; repeat split; auto.
  -  edestruct Hin1 as (i&?&?).
     edestruct (irrel_ivd_support_coerce _ _ Heq1) as (Hcoerce&_).
     apply Hcoerce; eauto.
  - eapply irrel_pidist_support_coerce; eauto.
Qed.

Lemma rsupport_support_right {X Y} (Ix: ivdist X) (x: X) Is (P: X → Y → Prop)
      (Ic: irrel_couplingP Ix Is P)  (c: rsupport Ic x) :
  In_psupport (proj1_sig c) Is.
Proof.
  destruct c as (y'&ic&HP&Hind&Hgt).
  rewrite //=. destruct Ic as [Ix' Is' Hirrel_ivd Hirrel_pidist Ic].
  eapply irrel_pidist_support_coerce; eauto.
  destruct Ic as [Iy Hle Ic].
  rewrite //= in ic Hind Hgt.
  clear Hirrel_pidist.

  destruct (irrel_ivd_support_coerce _ _ Hirrel_ivd x) as (Hcoerce&_).
  destruct (Hle Iy) as (Iy'&Heq&Hin); first by auto.
  destruct Ic as [Ic Hproj1 Hproj2].
  rewrite //= in ic Hind Hgt.

  symmetry in Hproj2.
  setoid_rewrite Heq in Hproj2.
  destruct Hproj2 as (h1&h2&?&?&Hindic&Hvalic).

  assert (val (x0 ← Ic; mret (sval x0).2) (existT ic tt) > 0) as Hgt'.
  { rewrite //= Rmult_1_r //=. }
  specialize (Hindic (coerce_supp _ _ Hgt')).
  specialize (Hvalic (coerce_supp _ _ Hgt')).
  rewrite //= in Hindic Hvalic.

  exists Iy'.
  exists (sval (h1 (coerce_supp _ _ Hgt'))).
  repeat split; auto.
  - rewrite Hindic Hind //=.
  - rewrite Hvalic //=.
Qed.

Lemma rsupport_post {X Y} (Ix: ivdist X) (x: X) Is (P: X → Y → Prop)
      (Ic: irrel_couplingP Ix Is P)  (c: rsupport Ic x) :
  P x (proj1_sig c).
Proof.
  destruct c as (y&I&i&Hind&?).
  rewrite //=.
Qed.

Transparent pidist_ret.
Lemma rsupport_mret_right {X Y} (Ix: ivdist X) (x: X) (y: Y) (P: X → Y → Prop)
      (Ic: irrel_couplingP Ix (mret y) P)  (c: rsupport Ic x) :
  proj1_sig c = y.
Proof.
  edestruct (rsupport_support_right _ _ _ _ Ic c) as (Iy&iy&Hin&Hind&?).
  subst; rewrite -Hind //=.
  rewrite /In/mret/base.mret//= in Hin.
  subst. destruct iy => //=.
Qed.
Opaque pidist_ret.

Lemma ip_irrel_coupling {A1 A2} (I: ivdist A1) (Is: pidist A2) (P: A1 → A2 → Prop):
  idist_pidist_couplingP I Is P →
  irrel_couplingP I Is P.
Proof.
  intros.
  exists I Is; try reflexivity; eauto.
Qed.

Lemma irrel_bounded_supp_fun {A} f (Is Is': pidist A):
  irrel_pidist Is Is' →
  bounded_fun_on f (λ x, In_psupport x Is') →
  bounded_fun_on f (λ x, In_psupport x Is).
Proof.
  intros Hle Hbf.
  eapply bounded_fun_on_anti; try eassumption.
  eapply irrel_pidist_support_coerce; eauto.
Qed.

Lemma irrel_pidist_bounded_supp_Ex_max {A} f (Is Is': pidist A):
  irrel_pidist Is Is' →
  bounded_fun_on f (λ x, In_psupport x Is') →
  Rbar_le (Ex_max f Is) (Ex_max f Is').
Proof.
  intros Hi Hb1.
  feed pose proof (irrel_bounded_supp_fun f Is Is') as Hb2; eauto.
  assert (bounded_fun_on f (λ x, In_psupport x Is ∨ In_psupport x Is')) as Hb.
  { destruct Hb1 as (c1&?).
    destruct Hb2 as (c2&?).
    exists (Rmax c1 c2).
    intros x [Hin1|Hin2]; rewrite Rmax_Rle; intuition.
  }
  clear Hb1. clear Hb2.
  edestruct (bounded_fun_on_to_bounded f) as (g'&Hb'&Heq); eauto.
  feed pose proof (irrel_pidist_Ex_max Is Is' Hi g' Hb'); eauto.
  erewrite (Ex_max_eq_ext_supp f g' Is'); eauto.
  etransitivity; eauto.
  erewrite (Ex_max_eq_ext_supp f g' Is); eauto; first reflexivity.
Qed.

Lemma Ex_min_irrel_anti {A} f (Is Is': pidist A) :
  irrel_pidist Is Is' →
  bounded_fun f →
  Rbar_le (Ex_min f Is') (Ex_min f Is).
Proof. eauto. Qed.

Lemma irrel_coupling_eq_ex_Ex {A1 A2} f g (I: ivdist A1) (Is: pidist A2) :
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun g →
  ex_Ex_ival f I.
Proof.
  intros [Is1_irrel Is2_irrel Hirrel_ivd Hirrel_pidst Ic] Hex.
  assert (idist_pidist_couplingP (x ← Is1_irrel; mret (f x))
                                 (x ← Is2_irrel; mret (g x))
                                 (λ x y, x = y)) as Ic'.
  { eapply ip_coupling_bind; eauto => ???.
    apply ip_coupling_mret; auto. }

  destruct Ic' as [I2 Hmem Ic'].
  apply ival_coupling_eq in Ic'.
  eapply ex_Ex_ival_irrel_proper.
  { symmetry; eauto. }

  rewrite (ex_Ex_ival_fmap id f).
  setoid_rewrite Ic'.
  cut (ex_Ex_extrema id (x ← Is2_irrel; mret (g x))).
  { intros Hex'. edestruct (Hmem I2) as (I2'&Heq'&?); first done.
    rewrite Heq'. eapply Hex'; eauto. }
  rewrite -ex_Ex_extrema_fmap. eauto.
  eapply ex_Ex_extrema_bounded_fun.
  eauto.
Qed.

Lemma irrel_coupling_eq_Ex_min {A1 A2} f g (I: ivdist A1) (Is: pidist A2) :
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun g →
  Rbar_le (Ex_min g Is) (Ex_ival f I).
Proof.
  intros Hirrel Hb.
  feed pose proof (irrel_coupling_eq_ex_Ex f g I Is) as Hex; eauto.
  destruct Hirrel as [Is1_irrel Is2_irrel Hirrel_ivd Hirrel_pidst Ic].
  assert (idist_pidist_couplingP (x ← Is1_irrel; mret (f x))
                                 (x ← Is2_irrel; mret (g x))
                                 (λ x y, x = y)) as Ic'.
  { eapply ip_coupling_bind; eauto => ???.
    apply ip_coupling_mret; auto. }

  destruct Ic' as [I2 Hmem Ic'].
  apply ival_coupling_eq in Ic'.

  etransitivity; first apply Ex_min_irrel_anti; eauto.
  erewrite Ex_ival_irrel_proper; eauto.

  transitivity (Ex_min (λ x, Ex_min id (mret (g x))) Is2_irrel).
  { apply Ex_min_le_ext.
    * intros. rewrite Ex_min_mret. reflexivity.
    * eapply ex_Ex_extrema_bounded_fun; eauto.
  }
  assert (ex_Ex_ival f Is1_irrel).
  { eapply ex_Ex_ival_irrel_proper; eauto. }
  etransitivity; first eapply Ex_min_bind_post_aux2; last first.
  - transitivity (Ex_ival (λ x, Ex_ival id (mret (f x))) Is1_irrel); last first.
    { apply Ex_ival_mono.
      * intros. rewrite Ex_ival_mret. reflexivity.
      * setoid_rewrite Ex_ival_mret.
        eapply ex_Ex_ival_irrel_proper; eauto.
      * eapply ex_Ex_ival_irrel_proper; eauto.
    }
    rewrite -Ex_ival_bind_post; last first.
    { rewrite -ex_Ex_ival_fmap. eauto. }
    transitivity (Ex_ival id I2); last first.
    { refl_right. f_equal. symmetry. eapply Ex_ival_proper; eauto.
      rewrite -ex_Ex_ival_fmap. eauto. }

    apply In_pidist_le_singleton in Hmem.
    destruct Hmem as (I2'&Heq22'&?).
    transitivity (Ex_ival id I2'); last first.
    { refl_right. f_equal. symmetry. eapply Ex_ival_proper; eauto.
      eapply ex_Ex_ival_proper; eauto.
      rewrite -ex_Ex_ival_fmap. eauto. }
    apply Ex_min_spec1'; auto.
    eapply ex_Ex_ival_proper; eauto.
    eapply ex_Ex_ival_proper; eauto.
    rewrite -ex_Ex_ival_fmap. eauto.
  - setoid_rewrite Ex_min_mret.
    apply ex_Ex_extrema_bounded_fun; eauto.
  - intros. setoid_rewrite Ex_min_mret. rewrite //=.
  - apply Ex_min_bounded_fun_finite.
    setoid_rewrite Ex_min_mret. eauto.
Qed.

Lemma irrel_coupling_eq_Ex_min' {A1 A2 A3} f g (h : A3 → R) (I: ivdist A1) (Is: pidist A2) :
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun (λ x, h (g x)) →
  Rbar_le (Ex_min (λ x, h (g x)) Is) (Ex_ival (λ x, h (f x)) I).
Proof.
  intros Hic Hb.
  eapply irrel_coupling_eq_Ex_min; eauto.
  eapply irrel_coupling_conseq; eauto.
  rewrite //=. intros x y ->. done.
Qed.

Lemma irrel_coupling_eq_Ex_max {A1 A2} f g (I: ivdist A1) (Is: pidist A2):
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun g →
  Rbar_le (Ex_ival f I) (Ex_max g Is).
Proof.
  intros HIc Hb.
  apply Rbar_opp_le.
  rewrite Ex_max_neg_min Rbar_opp_involutive.
  rewrite /Rbar_opp//=.
  rewrite -Ex_ival_negate.
  apply irrel_coupling_eq_Ex_min; eauto.
  - eapply irrel_coupling_conseq; eauto => x y ?.
    nra.
  - destruct Hb as (c&Hb). exists c; intros x. specialize (Hb x).
    move: Hb. do 2 apply Rabs_case; nra.
Qed.

Lemma irrel_coupling_eq_ex_Ex_supp {A1 A2} f g (I: ivdist A1) (Is: pidist A2) :
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun_on g (λ x, In_psupport x Is) →
  ex_Ex_ival f I.
Proof.
  intros Hi Hex.
  edestruct (bounded_fun_on_to_bounded g) as (g'&?Hb&Heq); eauto.
  feed pose proof (irrel_coupling_eq_ex_Ex f g' I Is); eauto.
  eapply irrel_coupling_conseq; last first.
  { unshelve (eapply @irrel_coupling_support); last eapply Hi. }
  rewrite //=. intros x y (Hpf&Hin&Hinp&?).
  rewrite -Heq; eauto.
Qed.

Lemma irrel_coupling_eq_Ex_min_supp {A1 A2} f g (I: ivdist A1) (Is: pidist A2) :
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun_on g (λ x, In_psupport x Is) →
  Rbar_le (Ex_min g Is) (Ex_ival f I).
Proof.
  intros Hi Hex.
  edestruct (bounded_fun_on_to_bounded g) as (g'&?Hb&Heq); eauto.
  feed pose proof (irrel_coupling_eq_Ex_min f g' I Is); eauto.
  eapply irrel_coupling_conseq; last first.
  { unshelve (eapply @irrel_coupling_support); last eapply Hi. }
  rewrite //=. intros x y (Hpf&Hin&Hinp&?).
  rewrite -Heq; eauto.
  etransitivity; last eassumption.
  refl_right.
  eapply Ex_min_eq_ext_supp.
  eauto.
Qed.

Lemma irrel_coupling_eq_Ex_max_supp {A1 A2} f g (I: ivdist A1) (Is: pidist A2):
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun_on g (λ x, In_psupport x Is) →
  Rbar_le (Ex_ival f I) (Ex_max g Is).
Proof.
  intros HIc Hb.
  apply Rbar_opp_le.
  rewrite Ex_max_neg_min Rbar_opp_involutive.
  rewrite /Rbar_opp//=.
  rewrite -Ex_ival_negate.
  apply irrel_coupling_eq_Ex_min_supp; eauto.
  - eapply irrel_coupling_conseq; eauto => x y ?.
    nra.
  - destruct Hb as (c&Hb). exists c; intros x Hin. specialize (Hb x Hin).
    move: Hb. do 2 apply Rabs_case; nra.
Qed.