(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

Require Import Ensembles.
Require Import Constructive_sets.
Require Import Relations_1.
Require Import Partial_Order.
Require Import Cpo.
Require Import algpodefs.
Require Import Powerset.
Require Import Powerset_facts.
Require Import Finite_sets.
Require Import Finite_sets_facts.
Require Import lpo.
Require Import lpo1.
Require Import alpo.
Require Import newfil.
Section Second_inductive_lemma.
Variable U : Type.
Variable C : Cpo U.

Definition D : PO U := PO_of_cpo U C.

Theorem Triples_are_enough_finite_case :
 (forall x y z : U,
  Consistent U D (Triple U x y z) ->
  ex (fun bsup : U => Lub U D (Triple U x y z) bsup)) ->
 forall X : Ensemble U,
 Finite U X ->
 Included U X (Carrier_of U D) ->
 Consistent U D X -> ex (fun bsup : U => Lub U D X bsup).
Proof.
intro H'; try assumption.
intros X H'0; try assumption.
elim H'0 using Generalized_induction_on_finite_sets.
clear H'0.
clear X.
intros X H'0; elim H'0.
unfold D at 6 in |- *; auto with sets.
clear H'0 X.
intros A H'0; elim H'0.
intros H'1 x H'2 H'3 H'4 H'5; try assumption.
rewrite (Empty_set_zero' U x).
exists x; auto with sets.
clear H'0 A.
intros A H'0; elim H'0.
intros H'1 x H'2 H'3 x0 H'4 H'5 H'6 H'7; try assumption.
2: clear H'0 A.
2: intros A H'0 H'1 x H'2 H'3 x0 H'4 H'5 x1 H'6 H'7 H'8 H'9; try assumption.
clear H'5 H'3 H'1.
rewrite (Empty_set_zero' U x).
unfold Add at 1 in |- *.
rewrite (Couple_as_union U x x0).
rewrite (Triple_as_Couple U x x0).
apply H'.
rewrite <- (Triple_as_union U x x x0).
rewrite (Union_idempotent U (Singleton U x)).
generalize H'7.
rewrite (Empty_set_zero' U x).
unfold Add at 1 in |- *; auto with sets.
clear H'5 H'3 H'1 H'0.
cut
 (forall X : Ensemble U,
  Included U X (Add U (Add U (Add U A x) x0) x1) ->
  Included U X (Carrier_of U D)); auto with sets.
intro L1.
cut
 (forall X : Ensemble U,
  Included U X (Add U (Add U (Add U A x) x0) x1) -> Consistent U D X);
 auto with sets.
2: intros X H'0.
2: apply
    Consistent_downward_stable with (B := Add U (Add U (Add U A x) x0) x1);
    auto with sets.
intro L2.
cut (Included U (Add U A x) (Add U (Add U (Add U A x) x0) x1)); auto with sets.
intro F1.
cut (Included U (Add U A x0) (Add U (Add U (Add U A x) x0) x1));
 auto with sets.
2: apply (Inclusion_is_transitive U) with (Add U (Add U A x) x0);
    auto with sets.
intro F2.
cut (Included U (Add U A x1) (Add U (Add U (Add U A x) x0) x1));
 auto with sets.
intro F3.
cut (Included U (Add U (Add U A x) x0) (Add U (Add U (Add U A x) x0) x1));
 auto with sets.
intro F4.
cut (Included U (Add U (Add U A x) x1) (Add U (Add U (Add U A x) x0) x1));
 auto with sets.
intro F5.
cut (Included U (Add U (Add U A x0) x1) (Add U (Add U (Add U A x) x0) x1));
 auto with sets.
intro F6.
cut
 (Strict_Included U (Add U (Add U A x) x0) (Add U (Add U (Add U A x) x0) x1)).
2: split; auto with sets.
2: red in |- *; simpl in |- *; intro H'0.
2: lapply
    (Extension U (Add U (Add U A x) x0) (Add U (Add U (Add U A x) x0) x1));
    [ intro H'10; elim H'10 | idtac ]; auto with sets.
intro G1.
cut
 (Strict_Included U (Add U (Add U A x) x1) (Add U (Add U (Add U A x) x0) x1)).
2: split; auto with sets.
2: red in |- *; simpl in |- *; intro H'0.
2: lapply
    (Extension U (Add U (Add U A x) x1) (Add U (Add U (Add U A x) x0) x1));
    [ intro H'10; elim H'10 | idtac ]; auto with sets.
2: intros H'1 H'3; try assumption.
2: apply H'4.
2: lapply (incl_add_x U (Add U (Add U A x) x0) (Add U A x) x1);
    [ intro H'14; lapply H'14;
       [ intro H'15; try exact H'15; clear H'14 | clear H'14 ]
    | idtac ]; auto with sets.
intro G2.
cut
 (Strict_Included U (Add U (Add U A x0) x1) (Add U (Add U (Add U A x) x0) x1)).
2: split; auto with sets.
2: red in |- *; simpl in |- *; intro H'0.
2: lapply
    (Extension U (Add U (Add U A x0) x1) (Add U (Add U (Add U A x) x0) x1));
    [ intro H'10; elim H'10 | idtac ]; auto with sets.
2: intros H'1 H'3; try assumption.
2: apply H'2.
2: lapply (incl_add_x U (Add U (Add U A x) x0) (Add U A x0) x1);
    [ intro H'14; lapply H'14;
       [ intro H'15; try exact H'15; clear H'14 | clear H'14 ]
    | idtac ]; auto with sets.
2: lapply (incl_add_x U (Add U A x) A x0);
    [ intro H'14; lapply H'14;
       [ intro H'16; try exact H'16; clear H'14 | clear H'14 ]
    | idtac ]; auto with sets.
intro G3; try assumption.
cut (Strict_Included U (Add U A x0) (Add U (Add U (Add U A x) x0) x1)).
2: apply
    Strict_inclusion_is_transitive_with_inclusion_left
     with (y := Add U (Add U A x0) x1); auto with sets.
intro G4; try assumption.
cut (Strict_Included U (Add U A x1) (Add U (Add U (Add U A x) x0) x1)).
2: apply
    Strict_inclusion_is_transitive_with_inclusion_left
     with (y := Add U (Add U A x) x1); auto with sets.
intro G5; try assumption.
cut (Strict_Included U (Add U A x) (Add U (Add U (Add U A x) x0) x1)).
2: apply
    Strict_inclusion_is_transitive_with_inclusion_left
     with (y := Add U (Add U A x) x0); auto with sets.
intro G6; try assumption.
elim (H'7 (Add U A x));
 [ intros bsup E; try exact E | idtac | idtac | idtac ];
 auto with sets.
elim (H'7 (Add U A x0));
 [ intros bsup0 E0; try exact E0 | idtac | idtac | idtac ];
 auto with sets.
elim (H'7 (Add U A x1));
 [ intros bsup1 E1; try exact E1 | idtac | idtac | idtac ];
 auto with sets.
elim (H'7 (Add U (Add U A x) x0));
 [ intros bsup2 E2; try exact E2 | idtac | idtac | idtac ];
 auto with sets.
elim (H'7 (Add U (Add U A x) x1));
 [ intros bsup3 E3; try exact E3 | idtac | idtac | idtac ];
 auto with sets.
elim (H'7 (Add U (Add U A x0) x1));
 [ intros bsup4 E4; try exact E4 | idtac | idtac | idtac ];
 auto with sets.
elim (H' bsup bsup0 bsup1); [ intros bsup5 E5; try exact E5 | idtac ];
 auto with sets.
exists bsup5; try assumption.
2: apply Consistent_triple_intro.
2: apply
    Compatible_lubs
     with
       (A := Add U A x)
       (B := Add U A x0)
       (C := Add U (Add U A x) x0)
       (c := bsup2); auto with sets.
2: apply
    Compatible_lubs
     with
       (A := Add U A x0)
       (B := Add U A x1)
       (C := Add U (Add U A x0) x1)
       (c := bsup4); auto with sets.
2: apply
    Compatible_lubs
     with
       (A := Add U A x)
       (B := Add U A x1)
       (C := Add U (Add U A x) x1)
       (c := bsup3); auto with sets.
generalize E5.
clear E5.
rewrite (Triple_as_Couple_Singleton U bsup bsup0 bsup1).
intro E5; try assumption.
unfold Add at 1 in |- *.
cut
 (Union U (Add U (Add U A x) x0) (Singleton U x1) =
  Union U (Add U (Add U A x) x0) (Add U A x1)).
intro H'0; rewrite H'0.
clear H'0.
apply LUaux2 with (a := bsup2) (b := bsup1); auto with sets.
apply LUaux with (A := Couple U bsup bsup0) (B := Singleton U bsup1);
 auto with sets.
3: apply Singleton_has_lub.
clear E5 E4 E3 G6 G5 G4 G3 G2 G1 H'9 H'7 bsup5 bsup4 bsup3 H'6 H'4 H'2 H'.
red in |- *; simpl in |- *.
intros x2 H'; elim H'; auto with sets.
intros x3 H'0; elim H'0; auto with sets.
apply Lub_is_in_Carrier with (X := Add U A x); auto with sets.
apply Lub_is_in_Carrier with (X := Add U A x0); auto with sets.
intros x3 H'0; elim H'0; auto with sets.
apply Lub_is_in_Carrier with (X := Add U A x1); auto with sets.
2: apply Lub_is_in_Carrier with (X := Add U A x1); auto with sets.
apply LUaux with (A := Add U A x) (B := Add U A x0); auto with sets.
cut (Add U (Add U A x) x0 = Union U (Add U A x) (Add U A x0)).
intro H'0; rewrite <- H'0; auto with sets.
cut (Add U (Add U A x) x0 = Union U (Add U A x) (Add U A x0) :>Ensemble U).
clear E5.
(* Rewrite (Triple_as_Couple_Singleton U bsup bsup0 bsup1). *)
intro E5; try assumption.
cut (Lub U D (Couple U bsup bsup0) bsup2).
intro H'1; try assumption.
apply Add_distributes; auto with sets.
apply LUaux with (A := Add U A x) (B := Add U A x0); auto with sets.
rewrite <- (Add_distributes U A A x x0); auto with sets.
cut
 (Union U (Add U (Add U A x) x0) (Singleton U x1) =
  Add U (Add U (Add U A x) x0) x1 :>Ensemble U).
intro H'0; rewrite H'0.
rewrite (Add_distributes U (Add U A x) A x0 x1); auto with sets.
unfold Add at 3 in |- *; auto with sets.
Qed.
Hint Resolve Triples_are_enough_finite_case.

Theorem Triples_are_enough :
 (forall x y z : U,
  Consistent U D (Triple U x y z) ->
  ex (fun bsup : U => Lub U D (Triple U x y z) bsup)) ->
 Coherent U D.
intro H'; red in |- *; simpl in |- *.
intros X H'0 K; try assumption.
cut (Complete U D).
2: exact (Cpo_cond U C).
unfold D at 1 in |- *.
intro H'3; elim H'3; intros H'6 H'7.
elim (H'7 (Lubs_of_finite_parts U C X));
 [ intros bsup0 E0 | apply LFP_directed ]; auto with sets.
exists bsup0; unfold D at 1 in |- *; auto with sets.
intros Y H'1 H'2; try assumption.
change (ex (fun bsup : U => Lub U D Y bsup)) in |- *.
apply Triples_are_enough_finite_case; auto with sets.
apply Consistent_downward_stable with (B := X); auto with sets.
Qed.
End Second_inductive_lemma.


Require Import propInv5.
Local Open Scope Z.

Definition _timer1 :=36000.
Definition _timer0 := _timer1-1.
Definition _logvar := ON.
Definition _hands0 :=
 (make (of_Z (_timer1+1)) ON).[of_Z (_timer1-10) <- OFF].[of_Z (_timer1-9) <- OFF].[of_Z (_timer1- 8) <-OFF]
.[of_Z (_timer1-7) <- OFF].[of_Z (_timer1-6) <-OFF].[of_Z (_timer1-5)<- OFF].[of_Z (_timer1-4) <-OFF]
.[of_Z (_timer1-3)<-OFF].[of_Z (_timer1-2) <-OFF].[of_Z (_timer1-1)<-OFF].

Definition _hands1 := _hands0.[of_Z _timer1 <- _logvar].
Definition _dryer0 := make (of_Z (_timer1+1)) ON.
Definition _dryer1 := _dryer0.[of_Z _timer1 <- _dryer0.[of_Z (_timer1-1)]].
Definition _ctrlState0 := (make (of_Z (_timer1+1)) ctrlDrying).[of_Z (_timer1-1) <- ctrlWaiting].
Definition _ctrlState1 := _ctrlState0.[of_Z _timer1 <- _ctrlState0.[of_Z (_timer1-1)]].
Definition _ctrlTimer0 :=0.
Definition _ctrlTimer1 := _ctrlTimer0 + 1.
Definition _dryer2 := _dryer1.[of_Z _timer1 <- ON].
Definition _ctrlState2 := _ctrlState1.[of_Z _timer1 <- ctrlDrying].
Definition _ctrlTimer2 := 0.

Theorem proof5_2 :
 exists hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1 dryer2 ctrlState2 ctrlTimer2
(logvar : bool),
 ~((startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1 logvar) /\
    ctrlState1.[of_Z timer1]=ctrlWaiting /\ hands1.[of_Z timer1]=ON /\ dryer2=dryer1.[of_Z timer1 <- ON] /\ ctrlTimer2=0 /\
    ctrlState2=ctrlState1.[of_Z timer1 <- ctrlDrying] ->
    (inv hands1 dryer2 ctrlState2 ctrlTimer2 timer1)).

Proof.
exists _hands0.
exists _hands1.
exists _dryer0.
exists _dryer1.
exists _ctrlState0.
exists _ctrlState1.
exists _ctrlTimer0.
exists _ctrlTimer1.
exists _timer0.
exists _timer1.
exists _dryer2.
exists _ctrlState2.
exists _ctrlTimer2.
exists _logvar.
unfold not.
intros.
assert (Hcond :
 (startnewloop _hands0 _hands1 _dryer0 _dryer1 _ctrlState0 _ctrlState1 _ctrlTimer0 _ctrlTimer1 _timer0 _timer1 _logvar) /\
    _ctrlState1.[of_Z _timer1]=ctrlWaiting /\ _hands1.[of_Z _timer1]=ON /\ _dryer2=_dryer1.[of_Z _timer1 <- ON] /\
     _ctrlTimer2=0 /\ _ctrlState2=_ctrlState1.[of_Z _timer1 <- ctrlDrying]).

split.
split.
split.
(*proving propInv for timer0*)
unfold propInv5.
intros.
unfold _timer0 in H0.
unfold _timer1 in H0.
elimtype False.
auto with zarith.
(*proving extraInv for timer0*)
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
unfold _timer0.
unfold _timer1.
auto with zarith.
split.
unfold _ctrlTimer0.
auto with zarith.
split.
intros.
elim Zle_lt_or_eq with i _timer0.
intros.
right.

replace _ctrlState0.[of_Z i] with (make (of_Z (_timer1+1)) ctrlDrying).[of_Z i].

apply get_make.
 apply arr_same_before_upd with ctrlWaiting _timer0.
split.
assumption.
reflexivity.
intros.
rewrite H1.
left.
apply get_set_same.
rewrite length_make.
unfold _timer0.
unfold _timer1.
auto.
apply H0.
intros.
unfold _ctrlState0 in H0.
rewrite get_set_same in H0.
contradict H0.
discriminate.
unfold _timer0.
unfold _timer1.
auto.
split.
symmetry.
apply Zeq_plus_swap.
reflexivity.
repeat split.
repeat split.
unfold _ctrlState1.
rewrite get_set_same.
unfold _ctrlState0.
apply get_set_same.
auto.
auto.

(*proving negating requirement for timer1*)
apply H in Hcond.
inversion_clear Hcond.
unfold propInv5 in H0.
specialize (H0 (_timer1-(36000-1))).
assert (Hpremise :
   0<(_timer1-(36000-1)) /\ (_timer1-(36000-1))<=(_timer1-(36000-1)) /\ _dryer2.[of_Z (_timer1-(36000-1))]=ON).
unfold _timer1.
auto with zarith.
apply H0 in Hpremise.
elim Hpremise.
intros.
inversion_clear H2.
inversion_clear H4.
inversion_clear H5.
replace _dryer2.[of_Z x] with _dryer0.[of_Z x] in H6.
unfold _dryer0 in H6.
rewrite get_make in H6.
contradict H6.
discriminate.
auto.
Qed.


From FOL Require Import FullSyntax Arithmetics.
Require Import FOL.Incompleteness.Axiomatisations.
Require Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.Undecidability.
From Undecidability.Synthetic Require Import Definitions EnumerabilityFacts.
From Undecidability.FOL.Reductions Require Import H10p_to_FA.
From Undecidability.H10 Require Import H10p H10p_undec.
Require Import List Lia.
Section Arithmetic.

  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.

  Section Model.

    Variable D : Type.
    Variable I : @interp PA_funcs_signature _ D.
    Variable ext_I : @interp PA_funcs_signature extended_preds D.

    Lemma Fr_exists_eq N s t :
      forall rho, sat ext_I rho (Fr (exist_times N (s == t))) <-> rho ⊨ (dn FriedmanTranslation.Q (cast (exist_times N (s == t)))).
    Proof.
      induction N; cbn; intros ?.
      - tauto.
      - setoid_rewrite IHN. firstorder.
    Qed.

    Corollary Fr_embed E :
      forall rho, sat ext_I rho (Fr (embed E)) <-> rho ⊨ (dn FriedmanTranslation.Q (cast (embed E))).
    Proof.
      unfold embed, embed_problem; destruct E as [a b].
      apply Fr_exists_eq.
    Qed.

    Definition ext_nat := extend_interp interp_nat.

    Lemma cast_extists_eq N s t P rho :
      sat (extend_interp I P) rho (cast (exist_times N (s == t))) -> sat rho (exist_times N (s == t)).
    Proof.
      revert rho. induction N.
      - tauto.
      - cbn. intros rho [d Hd]. exists d.
        eapply IHN. unfold exist_times. apply Hd.
    Qed.

    Corollary cast_embed E P rho :
      sat (extend_interp I P) rho (cast (embed E)) -> sat I rho (embed E).
    Proof.
      unfold embed, embed_problem; destruct E as [a b].
      apply cast_extists_eq.
    Qed.

    Lemma sat_Fr_formula {P} phi rho :
      I ⊨=T Q' -> Q' phi -> sat (extend_interp I P) rho (Fr phi).
    Proof.
      intros axioms H.
      specialize (axioms phi). revert axioms.
      repeat (destruct H as [<-|H]).
      all: cbn -[FAeq]; refine (fun A => let F := A _ rho in _); intuition.
      destruct H.
      Unshelve. all: cbn; try tauto.
    Qed.

    Lemma sat_Fr_context {P} Gamma rho :
      I ⊨=T Q' -> (forall psi : form, In psi Gamma -> Q' psi) -> (forall psi, In psi (Fr_ Gamma) -> sat (extend_interp I P) rho psi).
    Proof.
      intros axioms.
      induction Gamma as [| alpha Gamma IH]; cbn -[FAeq].
      - tauto.
      - intros H beta [<-| [phi [<- ]] % in_map_iff ].
        + specialize (H alpha (or_introl eq_refl)).
          now apply sat_Fr_formula.
        + apply IH; [|now apply in_map].
          intros psi Hp. apply H; tauto.
    Qed.

  End Model.

  Theorem sat_embed Gamma (E : H10p_PROBLEM) D (I : interp D) :
    I ⊨=T Q' -> (forall psi : form, In psi Gamma -> Q' psi) -> Gamma ⊢C embed E -> I ⊨= embed E.
  Proof.
    intros HI Hg H % Fr_cl_to_min % soundness rho.
    refine (let H' := H D (extend_interp I _) rho _ in _).
    apply Fr_embed in H'.
    simpl in H'. apply H'.
    apply cast_embed. exact I.
    Unshelve.
    apply sat_Fr_context; auto.
  Qed.

  Theorem class_Q_to_H10p Gamma (E : H10p_PROBLEM) :
    (forall psi : form, In psi Gamma -> Q' psi) -> Gamma ⊢C embed E -> H10p E.
  Proof.
    intros Hg H. apply nat_H10.
    eapply sat_embed; eauto.
    clear H; intros alpha H rho.
    repeat (destruct H as [<-|H]; cbn; intuition).
    destruct H.
  Qed.

  Corollary T_class_Q_to_H10p (T : form -> Prop) (E : H10p_PROBLEM) :
    T <<= Q' -> T ⊢TC embed E -> H10p E.
  Proof.
    intros ? [Gamma []]. eapply class_Q_to_H10p; intuition.
  Qed.

  Lemma H10p_to_class_Q :
    reduction embed H10p (tprv_class Q').
  Proof.
    intros E; split.
    + intros H. exists FAeq. split; [intuition|].
      now apply H10p_to_FA_prv'.
    + intros H. eapply T_class_Q_to_H10p.
      2 : apply H. auto.
   Qed.

  Lemma undec_class_Q :
    undecidable (tprv_class Q').
  Proof.
    refine (undecidability_from_reducibility _ _).
    2 : exists embed; apply H10p_to_class_Q.
    apply H10p_undec.
  Qed.

  Definition Fr_pres T :=
    forall D (I : interp D) P,
      I ⊨=T T ->
      forall Gamma, (forall psi, In psi Gamma -> T psi) ->
                    (extend_interp I P) ⊫= Fr_ Gamma.

  Section Theory.

    Variable T : form -> Prop.
    Variable Incl : Q' <<= T.
    Variable Std :
      forall Gamma P, (forall psi, In psi Gamma -> T psi) -> (extend_interp interp_nat P) ⊫= Fr_ Gamma.

    Lemma extract_from_class E :
      T ⊢TC embed E -> interp_nat ⊨= embed E.
    Proof.
      intros [Gamma [H2 H % Fr_cl_to_min % soundness]] rho.
      refine (let H' := H nat (extend_interp interp_nat _) rho _ in _).
      apply Fr_embed in H'.
      simpl in H'. apply H'.
      apply cast_embed. exact interp_nat.
      Unshelve.
      now apply Std.
    Qed.

    Lemma reduction_theorem :
      reduction embed H10p (tprv_class T).
    Proof.
      intros E; split.
      - intros H % (@H10p_to_FA_prv' class).
        exists FAeq; split; [intros ?|auto].
        apply Incl.
      - intros H. apply nat_H10.
        now apply extract_from_class.
    Qed.

    Lemma undec_class_T :
      undecidable (tprv_class T).
    Proof.
      refine (undecidability_from_reducibility H10p_undec _).
      exists embed. apply reduction_theorem.
    Qed.

    Lemma std_T_consistent :
      ~ T ⊢TC ⊥.
    Proof.
      intros [Gamma [H2 H % Fr_cl_to_min % soundness]].
      specialize (H nat (ext_nat False) (fun _ => 0)).
      apply H. eapply Std; eauto.
    Qed.

    Theorem incompleteness_Q :
      enumerable T -> complete T -> computational_explosion.
    Proof.
      intros HE HC. apply H10p_undec.
      apply (@complete_reduction PA_funcs_signature PA_preds_signature enumerable_PA_funcs _ enumerable_PA_preds _ T HE) with embed.
      - now apply std_T_consistent.
      - apply HC.
      - now apply reduction_theorem.
      - apply embed_is_closed.
    Qed.

  End Theory.

End Arithmetic.


Require Import Coq.Reals.Reals.
Require Import ChargeCore.Tactics.Lemmas.
Require Import Logic.Logic.
Require Import Logic.EnabledLemmas.
Require Import Logic.ProofRules.
Require Import Logic.ArithFacts.
Require Import Examples.System.
Require Import Examples.UtilPosition.
Require Import Examples.Position.
Require Import Examples.Velocity.

Local Open Scope string_scope.
Local Open Scope HP_scope.

Module Type IntervalParams.
  Parameter ub : R.
  Parameter d : R.
  Parameter d_gt_0 : (d > 0)%R.
  Parameter amin : R.
  Parameter amin_lt_0 : (amin < 0)%R.
  Parameter ubv : R.
  Axiom ubv_gt_amin_d : (ubv >= -amin*d)%R.
  Parameter ubv_gt_0 : (ubv > 0)%R.
  Parameter ub_ubv :
    (ubv*d + ubv*ubv*(0 - /2)*(/amin) <= ub)%R.
End IntervalParams.

Module IntervalShim (Import P : IntervalParams).

  Module X_Params <: PositionShimParams.
    Definition ub := P.ub.
    Definition d := P.d.
    Definition d_gt_0 := P.d_gt_0.
    Definition amin := P.amin.
    Definition amin_lt_0 := P.amin_lt_0.
    Definition ubv := P.ubv.
    Definition ub_ubv := P.ub_ubv.
  End X_Params.

  Module X := PositionShim X_Params.

  Module V_Params <: VelocityShimParams.
    Definition ub := P.ubv.
    Definition d := P.d.
    Definition d_gt_0 := P.d_gt_0.
  End V_Params.

  Module V := VelocityShim V_Params.

  Module SdistUtil := SdistUtil(X_Params).
  Import SdistUtil.

  Let mirror : RenameList :=
    {{ "y" ~> --"y" & "v" ~> --"v" & "a" ~> --"a" }}%rn.

  Definition mirroredX : ActionFormula :=
    SysRename mirror (deriv_term_RenameList mirror) X.Next.

  Definition mirroredV : ActionFormula :=
    SysRename mirror (deriv_term_RenameList mirror) V.Next.

  Definition Next : ActionFormula :=
    SysCompose (SysCompose X.Next mirroredX)
               (SysCompose V.Next mirroredV).

  Definition IndInv : StateFormula :=
    (X.IndInv //\\ Rename mirror X.IndInv) //\\
    (V.IndInv //\\ Rename mirror V.IndInv).

  Lemma TimedPreserves_Next :
    |-- TimedPreserves d IndInv Next.
  Proof with (refine _).
    unfold IndInv, X.IndInv, V.IndInv, Next, X.SafeAcc.
    unfold SysCompose.
    repeat ((try simple apply TimedPreserves_intro);
      rewrite SysCompose_simpl;
      rewrite <- TimedPreserves_And by tlaIntuition;
      charge_split).
      { apply TimedPreserves_intro. rewrite <- X.TimedPreserves_Next.
        charge_tauto. }
      { apply TimedPreserves_intro.
        rewrite Sys_rename_formula by eauto with rw_rename.
        rewrite SysRename_rule by eauto with rw_rename.
        rewrite TimedPreserves_Rename by eauto with rw_rename.
        rewrite <- X.TimedPreserves_Next. rewrite Rename_True.
        charge_tauto. }
      { apply TimedPreserves_intro. rewrite <- V.TimedPreserves_Next.
        charge_tauto. }
      { apply TimedPreserves_intro.
        rewrite Sys_rename_formula by eauto with rw_rename.
        rewrite SysRename_rule by eauto with rw_rename.
        rewrite TimedPreserves_Rename by eauto with rw_rename.
        rewrite <- V.TimedPreserves_Next. rewrite Rename_True.
        charge_tauto. }
  Qed.

  Lemma velocity_refinement :
    "v" <= ubv //\\
    "v" + "a"!*d <= ubv //\\
    ("y" > 0 -->> X.SafeAccZeroOrder "a"! d)
    |-- X.SafeAccZeroOrder "a"! d.
  Proof.
    pose proof d_gt_0 as d_gt_0. pose proof amin_lt_0 as amin_lt_0.
    pose proof ubv_gt_0 as ubv_gt_0. pose proof ub_ubv as ub_ubv.
    intros. reason_action_tac.
    destruct H as [Hubv1 [Hubv2 Hctrl]].
    destruct (Rgt_dec (pre "y") R0).
    { auto. }
    { clear Hctrl. split; intros.
      { eapply Rle_trans; eauto.
        pose proof (sdist_incr (pre "v" + post "a" * d)
                               ubv (Stream.forever (fun _ => R0))).
        breakAbstraction. specialize_arith_hyp H0. rewrite H0.
        assert ((pre "v" * d + / 2 * post "a" * (d * (d * 1))) <=
                ubv * d)%R.
        { clear - Hubv1 Hubv2 H d_gt_0. solve_nonlinear. }
        { unfold X_Params.amin, X_Params.ub in *. solve_linear. } }
      { unfold X_Params.ub. transitivity (ubv*d)%R.
        { field_simplify; [ | solve_nonlinear ].
          apply Rmult_le_algebra_neg; [ solve_nonlinear | ].
          unfold Rdiv. rewrite RMicromega.Rinv_1. simpl.
          clear - Hubv1 d_gt_0 H n. solve_nonlinear. }
        { assert ((0 - / 2) < 0)%R by solve_linear.
          assert (/amin < 0)%R by solve_linear.
          generalize dependent (/amin)%R.
          generalize dependent (0-/2)%R. intros.
          clear -H0 H1 ubv_gt_0 ub_ubv0. solve_nonlinear. } } }
  Qed.

  Definition Constraint :=
    amin <= "a" <= --amin.

   Lemma SysNeverStuck_Discr :
     IndInv //\\ "T" = 0
     |-- Enabled ((0 <= "T"! <= d //\\ Sys_D Next) //\\
                     next Constraint).
   Proof.
     unfold Sys_D, IndInv, X.IndInv. repeat rewrite Rename_ok by eauto with rw_rename.
     rewrite <- velocity_refinement.
     charge_assert (X.SafeAcc "a" 0).
     { rewrite <- (X.SafeAcc_downclock "a" 0 "T"). solve_linear. }
     charge_assert (Rename mirror (X.SafeAcc "a" 0)).
     { rewrite <- (X.SafeAcc_downclock "a" 0 "T").
       repeat rewrite <- Rename_ok by eauto with rw_rename. solve_linear. }
     charge_assert ("v" <= ubv).
     { reason_action_tac. assert (pre "a" < 0 \/ pre "a" >= 0)%R by solve_linear.
       destruct H. rewrite H1 in *. rewrite_real_zeros. solve_linear. }
     charge_assert (--"v" <= ubv).
     { repeat rewrite <- Rename_ok by eauto with rw_rename.
       reason_action_tac. assert (0 - pre "a" < 0 \/ 0 - pre "a" >= 0)%R by solve_linear.
       destruct H. rewrite H1 in *. rewrite_real_zeros. solve_linear. }
     charge_assert ("y" <= ub).
     { rewrite <- (X.SafeAcc_Safe "a" "T"). solve_linear. }
     charge_assert (Rename mirror ("y" <= ub)).
     { rewrite <- (X.SafeAcc_Safe "a" "T").
       repeat rewrite <- Rename_ok by eauto with rw_rename. solve_linear. }
     rewrite X.SafeAcc_ZeroOrder_amin. charge_clear. charge_intros.
     repeat rewrite <- Rename_ok by eauto with rw_rename. enable_ex_st'.
     pose proof P.amin_lt_0. pose proof P.d_gt_0.
     pose proof P.ubv_gt_amin_d.
     unfold V_Params.ub, V_Params.d, X_Params.ub, X_Params.amin, X_Params.d in *.
     destruct (Rgt_dec (st "y") R0);
       destruct (Rgt_dec (st "v") R0).
     { exists amin; do 2 eexists; exists d; solve_nonlinear. }
     { exists R0; do 2 eexists; exists d; intuition; try solve [solve_linear].
       rewrite_real_zeros. destruct H11; [ solve_linear | rewrite <- H11 ].
       rewrite_real_zeros. solve_linear. exfalso. solve_linear. }
     { exists R0; do 2 eexists; exists d; intuition; try solve [solve_linear].
       exfalso. solve_linear. }
     { exists (-amin)%R; do 2 eexists; exists d; solve_linear.
       solve_nonlinear. rewrite_real_zeros. repeat rewrite Ropp_involutive. solve_linear. }
   Qed.

   Require Import Examples.Quadcopter.

   Variable g : R.
   Hypothesis amin_lt_g : (amin > -g)%R.
   Variable angle_min : R.
   Hypothesis angle_min_le_0 : (angle_min < 0)%R.

   (* Map the interval onto the vertical dimension of
      the quadcopter. *)
   Let rename_quad : RenameList :=
    {{ "a" ~> "A"*cos("pitch")*cos("roll") - g &
       "y" ~> "z" & "v" ~> "vz" }}%rn.

  Let quad_inv : RenameList :=
    {{ "roll" ~> 0 & "pitch" ~> 0 & "A" ~> "a" + g &
       "z" ~> "y" & "vz" ~> "v" }}%rn.

  Let small_angle := small_angle angle_min.

  Lemma Constraint_small_angle :
    Constraint |-- Rename quad_inv small_angle.
  Proof.
    rewrite <- Rename_ok by eauto with rw_rename.
    breakAbstraction. intros. pose proof amin_lt_g.
    pose proof angle_min_le_0. solve_linear.
  Qed.

  Lemma quad_inv_ok :
    forall xs,
      List.forallb (fun x => if String.string_dec x "A"
                             then false else true) xs =
      true ->
      List.forallb (fun x => if String.string_dec x "roll"
                             then false else true) xs =
      true ->
      List.forallb (fun x => if String.string_dec x "pitch"
                             then false else true) xs =
      true ->
      List.forallb (fun x => if String.string_dec x "z"
                             then false else true) xs =
      true ->
      List.forallb (fun x => if String.string_dec x "vz"
                             then false else true) xs =
      true ->
      forall st x,
        List.In x xs ->
        eval_formula Constraint (Stream.forever st) ->
        subst_state rename_quad
                    (subst_state quad_inv st) x = st x.
  Proof.
    simpl. unfold Value, subst_state. simpl. intros.
    repeat destruct_ite; subst; simpl in *; try reflexivity.
    { rewrite cos_0. solve_linear. }
    { rewrite List.forallb_forall in *. specialize (H "A").
      specialize (H0 "roll"). specialize (H1 "pitch").
      specialize (H2 "z"). specialize (H3 "vz").
      repeat destruct_ite; subst; simpl; try reflexivity;
        try match goal with
        | [ H : ?X -> _ |- _ ] =>
            match type of H4 with
            | X => specialize (H H4); simpl in *; discriminate
            end
        end. }
  Qed.

  Definition Next_quad : ActionFormula :=
    SysCompose
      (SysRename rename_quad
                 (deriv_term_RenameList rename_quad) Next)
      (Sys (next small_angle) ltrue P.d).

  Definition IndInv_quad := Rename rename_quad IndInv.

  Transparent ILInsts.ILFun_Ops.

  Lemma TimedPreserves_Next_quad :
    |-- TimedPreserves P.d IndInv_quad Next_quad.
  Proof with eauto with rw_rename.
    unfold IndInv_quad, Next_quad.
    rewrite SysCompose_abstract. unfold SysRename.
    rewrite Sys_rename_formula... rewrite SysRename_rule...
    rewrite TimedPreserves_Rename...
    rewrite <- TimedPreserves_Next. rewrite Rename_True.
    charge_tauto.
  Qed.

  Opaque ILInsts.ILFun_Ops.

  Lemma SysNeverStuck_Discr_quad :
    IndInv_quad //\\ "T" = 0 |-- Enabled (Sys_D Next_quad).
  Proof.
    unfold Sys_D, IndInv_quad.
    rewrite_rename_equiv ("T" = 0) rename_quad.
    rewrite <- Rename_and.
    rewrite Rename_ok by eauto with rw_rename.
    eapply subst_enabled_full
    with (R:=Constraint) (Q:=small_angle).
    { tlaIntuition. }
    { tlaIntuition. }
    { apply is_action_formula_ok; simpl; tauto. }
    { apply get_vars_next_state_vars; reflexivity. }
    { intros. eapply quad_inv_ok. 6: apply H.
      reflexivity. reflexivity. reflexivity. reflexivity.
      reflexivity. auto. }
    { apply Constraint_small_angle. }
    { pose proof SysNeverStuck_Discr. unfold Sys_D in H.
      rewrite Rename_ok in * by eauto with rw_rename.
      rewrite H. apply Proper_Enabled_lentails.
      charge_tauto. }
  Qed.

  Theorem SysNeverStuck_Next :
    |-- SysNeverStuck P.d IndInv_quad Next_quad.
  Proof.
    eapply SysNeverStuck_Sys;
    [ pose proof P.d_gt_0 ; solve_linear | | ].
    { rewrite <- disjoint_state_enabled.
      { charge_split.
        { charge_clear. apply Enabled_TimeBound.
          pose proof P.d_gt_0. assumption. }
        { apply SysNeverStuck_Discr_quad. } }
      { apply formulas_disjoint_state; reflexivity. } }
    { admit. (** Provable, but we won't worry about it *) }
  Admitted.

  Definition Safe : StateFormula :=
    (X.Safe //\\ Rename mirror X.Safe) //\\
    ("v" <= V_Params.ub //\\ Rename mirror ("v" <= V_Params.ub)).

  Definition Safe_quad : StateFormula :=
    Rename rename_quad Safe.

  Lemma IndInv_impl_Safe : IndInv //\\ TimeBound d |-- Safe.
  Proof with (eauto with rw_rename).
    unfold Safe. charge_split.
    { charge_split.
      { rewrite <- X.IndInv_impl_Safe. charge_tauto. }
      { rewrite <- X.IndInv_impl_Safe. rewrite Rename_and.
        unfold IndInv. charge_split; [ charge_assumption | ].
        rewrite <- (Rename_ok (TimeBound X_Params.d))...
        solve_linear. } }
    { charge_split.
      { rewrite <- V.IndInv_impl_Inv. charge_tauto. }
      { rewrite <- V.IndInv_impl_Inv. rewrite Rename_and.
        unfold IndInv. charge_split; [ charge_assumption | ].
        rewrite <- (Rename_ok (TimeBound X_Params.d))...
        solve_linear. } }
  Qed.

  Lemma IndInv_impl_Safe_quad :
    IndInv_quad //\\ TimeBound P.d |-- Safe_quad.
  Proof with (eauto with rw_rename).
    unfold Safe, TimeBound, IndInv_quad.
    rewrite_rename_equiv (0 <= "T" <= P.d) rename_quad.
    rewrite <- Rename_and.
    apply Proper_Rename_lentails; try reflexivity.
    apply IndInv_impl_Safe.
  Qed.

  Lemma W_quad_refines :
    W_quad g |-- Sys_w Next_quad.
  Proof.
    (* Mechanical reasoning about abstractions of
       differential equations. *)
  Admitted.

  (* Our main safety theorem. *)
  Theorem Interval_safe :
    |-- (IndInv_quad //\\ TimeBound P.d) //\\
        []SysSystem (Quadcopter P.d g angle_min
                                (Sys_D Next_quad))
        -->> []Safe_quad.
  Proof.
    rewrite Inductively.Preserves_Inv_simple.
    { rewrite IndInv_impl_Safe_quad.
      charge_tauto. }
    { compute; tauto. }
    { apply SafeAndReactive_TimedPreserves.
      eapply Quadcopter_refine.
      { apply P.d_gt_0. }
      { pose proof angle_min_le_0. solve_linear. }
      { apply TimedPreserves_Next_quad. }
      { apply SysNeverStuck_Next. }
      { unfold Sys_D. unfold small_angle. charge_assumption. }
      { apply W_quad_refines. } }
  Qed.

End IntervalShim.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B O1 A1 B1 O2 A2 B2 A1prime A2prime B1prime B2prime : Universe, ((wd_ O A /\ (wd_ A B /\ (wd_ O B /\ (wd_ O1 A1 /\ (wd_ A1 B1 /\ (wd_ O1 B1 /\ (wd_ O2 A2 /\ (wd_ A2 B2 /\ (wd_ O2 B2 /\ (wd_ O1 A1prime /\ (wd_ O1 A1 /\ (wd_ O2 A2prime /\ (wd_ O2 A2 /\ (wd_ O1 B1prime /\ (wd_ O1 B1 /\ (wd_ O2 B2prime /\ (wd_ O2 B2 /\ (col_ O1 A1 A1prime /\ (col_ O2 A2 A2prime /\ (col_ O1 B1 B1prime /\ (col_ O2 B2 B2prime /\ col_ O1 A1prime B1prime))))))))))))))))))))) -> col_ O1 A1 B1)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q R Cprime Aprime Bprime X Y Bprimeprime : Universe, ((wd_ Q C /\ (wd_ P C /\ (wd_ Q R /\ (wd_ R B /\ (wd_ P Q /\ (wd_ Aprime Bprime /\ (wd_ C Cprime /\ (wd_ A Aprime /\ (wd_ B Bprime /\ (wd_ X Y /\ (wd_ Aprime B /\ (wd_ Bprime A /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprimeprime Bprime /\ (wd_ Q A /\ (wd_ P B /\ (wd_ R A /\ (wd_ X Aprime /\ (wd_ X Bprime /\ (wd_ Aprime Bprimeprime /\ (wd_ Q B /\ (wd_ P A /\ (wd_ Aprime Y /\ (wd_ Bprime Y /\ (col_ P Q Cprime /\ (col_ Aprime Cprime Q /\ (col_ Bprime Cprime P /\ (col_ Aprime Bprime P /\ (col_ Aprime Bprime Q /\ (col_ Aprime Bprime Cprime /\ (col_ C Aprime Bprime /\ (col_ X Aprime Bprime /\ (col_ R A B /\ (col_ Q A C /\ col_ P B C)))))))))))))))))))))))))))))))))))) -> col_ P Q C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(**************************************************************************)
(*  Mechanised Framework for Local Interactions & Distributed Algorithms  *)
(*  T. Balabonski, P. Courtieu, L. Rieg, X. Urbain                        *)
(*  PACTOLE project                                                       *)
(*                                                                        *)
(*  This file is distributed under the terms of the CeCILL-C licence.     *)
(*                                                                        *)
(**************************************************************************)

(**************************************************************************)
(** Mechanised Framework for Local Interactions & Distributed Algorithms

    T. Balabonski, P. Courtieu, L. Rieg, X. Urbain

    PACTOLE project

    This file is distributed under the terms of the CeCILL-C licence.
                                                                          *)
(**************************************************************************)

Set Implicit Arguments.
Require Import Utf8.
Require Import SetoidDec.
Require Import Reals.
Require Import Pactole.Util.Preliminary.
Require Import Pactole.Setting.
Require Import Pactole.Spaces.RealMetricSpace.
Require Import Pactole.Spaces.Similarity.
Require Import Pactole.Models.Similarity.

Typeclasses eauto := (bfs).

About path.

(** Flexible demons are a special case of demons with the additional property that
    the updated location of the robot is not necessarily the one chosen by the robogram,
    but lies on the segment delimited by the current and target locations.
    To avoid Zenon-based paradoxes, we require the robot to move at least a given distance δ. *)
Section FlexibleFormalism.

Context `{Observation}.
Context {VS : RealVectorSpace location}.
Context {RMS : RealMetricSpace location}. (* for dist *)
Variable Tactive : Type.
Context {Robot : robot_choice (path location)}.
(* Context {Frame : frame_choice Tframe}. *)
(* we lose the generality because the <= test must have a zoom *)
Instance Frame : frame_choice (similarity location) := FrameChoiceSimilarity.

Class FlexibleChoice `{update_choice Tactive} := {
  move_ratio : Tactive -> ratio;
  move_ratio_compat :> Proper (@equiv Tactive update_choice_Setoid ==> @equiv _ (sig_Setoid _)) move_ratio }.

(** Flexible moves are parametrized by a minimum distance [delta] that robots must move when they are activated. *)
Class FlexibleSetting `{FlexibleChoice}
                       {Update : update_function (path location) (similarity location) Tactive}
                       (delta : R) := {
  (** [move_ratio] is the ratio between the achieved and the planned move distances. *)
  ratio_spec : forall (config : configuration) g sim (trajectory : path location) choice,
    let pt := get_location (config (Good g)) in
    let pt' := get_location (update config g sim trajectory choice) in
    (* either we reach the target *)
    pt' == trajectory ratio_1
    (* or we only move part of the way but the robot has moved a distance at least [delta]. *)
    \/ pt' == trajectory (move_ratio choice)
       /\ (zoom sim) * delta <= dist pt pt' }.

(** If the robot is not trying to move, then it does not, no matter what the demon chooses. *)
Lemma update_no_move `{FlexibleSetting} : forall config g sim pt choice,
  get_location (update config g sim (straight_path pt pt) choice) == pt.
Proof using .
intros config g sim pt choice.
destruct (ratio_spec config g sim (straight_path pt pt) choice) as [Heq | [Heq Hle]];
rewrite Heq; simpl; now rewrite add_opp, mul_origin, add_origin.
Qed.

End FlexibleFormalism.

Section OnlyFlexibleSetting.

Context `{Location}.
Context {VS : RealVectorSpace location}.
Context {RMS : RealMetricSpace location}. (* for dist *)
Context `{Names}.
Instance Robot : robot_choice (path location) := { robot_choice_Setoid := path_Setoid location }.

Instance St : State location := OnlyLocation (fun _ => True).

(** Specialized definition where the only choice made by the demon is the movement ratio. *)
Instance OnlyFlexible : update_choice ratio := {|
  update_choice_Setoid := ratio_Setoid;
  update_choice_EqDec := _ |}.

Global Instance OnlyFlexibleChoice : @FlexibleChoice _ OnlyFlexible := {| move_ratio := Datatypes.id |}.

Instance FlexibleUpdate (delta : R) : update_function (path location) (similarity location) ratio.
refine {| update := fun config g sim (traj : path location) ρ =>
                      if Rle_bool ((zoom sim) * delta)
                                  (dist (get_location (config (Good g))) (get_location (traj ρ)))
                      then traj ρ else traj ratio_1 |}.
Proof.
intros config1 config2 Hconfig gg g ? sim1 sim2 Hsim traj1 traj2 Htraj ρ1 ρ2 Hρ. subst gg.
assert (Heq : get_location (traj1 ρ1) == get_location (traj2 ρ2)).
{ apply get_location_compat. now f_equiv. }
destruct_match_eq Hle; destruct_match_eq Hle'; rewrite Heq, ?Hsim in *;
solve [ reflexivity
      | now f_equiv
      | rewrite Hconfig, Htraj, Hρ in *; now rewrite Hle in Hle' ].
Unshelve. all:autoclass.
Defined.

Global Instance FlexibleChoiceFlexibleUpdate delta : FlexibleSetting (Update := FlexibleUpdate delta) delta.
Proof using . split.
intros config g traj choice pt pt'.
simpl update in *. unfold pt'. destruct_match_eq Hle.
- rewrite Rle_bool_true_iff in Hle. now right.
- now left.
Qed.

End OnlyFlexibleSetting.

(*
 *** Local Variables: ***
 *** coq-prog-name: "coqtop" ***
 *** fill-column: 117 ***
 *** End: ***
 *)


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^512 - 491*2^496 - 1
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 64;
    bitwidth := 64;
    s := 2^512;
    c := [(1, 1); (491, 2^496)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra finmap.
From mathcomp.analysis
  Require Import boolp classical_sets ereal reals realseq realsum distr xfinmap.
(* ------- *) Require Import xbigops misc maxflow elift.

Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

Import GRing.Theory Num.Theory Order.Theory.

Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
Local Notation edge T := (vertex T * vertex T)%type.

Local Notation "← x" := (inl x) (at level 2).
Local Notation "→ x" := (inr x) (at level 2).

Local Notation "⇐ x" := (inl (Some x)) (at level 2).
Local Notation "⇒ x" := (inr (Some x)) (at level 2).

(* ==================================================================== *)
Local Notation distr T := {distr T / R}.

(* -------------------------------------------------------------------- *)
Lemma nbounded_sub_mono (u : nat -> R) : nbounded u ->
  {α : nat -> nat & {b : bool |
    {homo α : x y / (x < y)%N} &
    {homo ((-1) ^+ b \*o (u \o α)) : x y / (x <= y)%N >-> (x <= y)} } }.
Proof.
move=> bnd_u; pose E n := `[<forall m, (n < m)%N -> (u m < u n)%R>].
case: (discrete.existsTP (fun s : seq nat => {subset E <= s})) => /=; last first.
+ case/natpred_finiteN => α homo_α Eα; exists α, true => //.
  move=> m n le_mn; rewrite expr1 /= !mulN1r ler_oppr opprK.
  move: le_mn; rewrite leq_eqVlt => /orP[/eqP->//|lt_mn].
  by have /asboolP := Eα m => /(_ (α n) (homo_α _ _ lt_mn)) /ltW.
case=> s sub_sE; pose N := \max_(i <- s) i.+1.
have h k : (N <= k)%N -> exists k', (k < k')%N && (u k <= u k').
+ move=> le_Nk; case/boolP: (E k).
  * move/sub_sE => k_in_s; move: le_Nk; rewrite /N.
    rewrite (perm_big _ (perm_to_rem (k_in_s))) /=.
    by rewrite big_cons geq_max ltnn.
  case/existsp_asboolPn=> k' /asboolPn /imply_asboolPn.
  case=> lt_kk' /negP; rewrite -leNgt => le_ukuk'.
  by exists k'; rewrite lt_kk' le_ukuk'.
pose α := fix α n := if n is n.+1
  then xchoose (h _ (leq_addr (α n - N) N))
  else N%N.
have geN_α n : (N <= α n)%N.
+ elim: n => //= n ih; have := xchooseP (h _ (leq_addr (α n - N) N)).
  case/andP; rewrite {1}subnKC // => /(leq_trans _) h' _.
  by apply/h'; apply/(leq_trans ih).
have homo_α : {homo α : x y / (x < y)%N}.
+ apply/homoS_lt => -[|n] /=.
  * have := xchooseP (h _ (leq_addr (N - N) N)).
    by case/andP; rewrite subnn {1}addn0.
  set m := xchoose _; have := xchooseP (h _ (leq_addr (m - N) N)).
  case/andP; rewrite {1}subnKC //.
  have := xchooseP (h _ (leq_addr (α n - N) N)).
  rewrite {1}subnKC ?geN_α // => /andP[h' _].
  by apply/(leq_trans _ h')/ltnW/geN_α.
exists (fun n => α n.+1), false => //.
+ by move=> m n; rewrite -ltnS => /homo_α.
apply/homoS_ler=> n; rewrite expr0 /= !mul1r.
set m := xchoose _; have := xchooseP (h _ (leq_addr (m - N) N)).
set k := xchoose _ => /andP[]; rewrite subnKC //.
have := xchooseP (h _ (leq_addr (α n - N) N)); rewrite -/m.
by rewrite subnKC ?geN_α // => /andP[/ltnW /(leq_trans (geN_α _))].
Qed.

(* -------------------------------------------------------------------- *)
Lemma BW (u : nat -> R) : nbounded u ->
  {α : nat -> nat | {homo α : x y / (x < y)%N} & iscvg (u \o α)}.
Proof.
move=> bnd; have bndcp f : nbounded (u \o f).
+ by case: bnd => v hv; exists v => n; apply/hv.
case/nbounded_sub_mono: (bnd) => [α] [[]] homo_α homo_uα; last first.
+ exists α => //; have /ncvg_mono_bnd: nbounded (u \o α) by apply/bndcp.
  case=> [x y /homo_uα|]; first by rewrite !expr0 /= !mul1r.
  by move=> l cvl; exists l.
exists α => //; have /ncvg_mono_bnd: nbounded ((\- u) \o α).
+ case: bnd; elim/nbh_finW => e gt0_e /= h.
  exists (NFin _ gt0_e) => n /=; move: (h (α n)); rewrite !inE.
  by rewrite !subr0 normrN.
case=> [x y /homo_uα|]; first by rewrite !expr1 /= !mulN1r.
move=> l cvl; exists (- l) => /=; apply/(ncvg_eq (v := \- (\- u \o α))).
+ by move=> x /=; rewrite opprK.
+ by apply/(@ncvgN _ _ l%:E).
Qed.

(* -------------------------------------------------------------------- *)
Axiom DCT : forall {T: choiceType} (un : nat -> T -> R) (u g : T -> R),
     (forall x, ncvg (un^~ x) (u x)%:E)
  -> (forall n x, `|un n x| <= g x)
  -> summable g
  -> summable u /\ ncvg (fun n => psum (un n)) (psum u)%:E.

(* -------------------------------------------------------------------- *)
Lemma DCT_swap {T: choiceType} (un : nat -> T -> R) (u g : T -> R) :
     (forall x, ncvg (un^~ x) (u x)%:E)
  -> (forall n x, `|un n x| <= g x)
  -> summable g
  -> real_of_er (nlim (fun n => psum (un n)))
     = psum (fun a => (real_of_er (nlim (un^~ a)))).
Proof.
move=> h1 h2 h3; case: (DCT h1 h2 h3) => _ /nlimE ->.
by apply/eq_psum => x /=; rewrite (nlimE (h1 x)).
Qed.

(* -------------------------------------------------------------------- *)
Lemma DCT_ncvg {T: choiceType} (un : nat -> T -> R) (u g : T -> R) :
     (forall x, ncvg (un^~ x) (u x)%:E)
  -> (forall n x, `|un n x| <= g x)
  -> summable g
  -> ncvg (fun n => psum (un n)) (psum u)%:E.
Proof. by move=> h1 h2 h3; case: (@DCT T un u g). Qed.

(* ==================================================================== *)
Section CountableSeqCompacityForDistr.
Context {A : countType} (μ : nat -> distr A).

(* -------------------------------------------------------------------- *)
Lemma strcvg :
  {Ω : nat -> nat | {homo Ω : x y / (x < y)%N} &
    forall a : A, iscvg (fun n => μ (Ω n) a)}.
Proof.
have α a θ: {α : nat -> nat |
  {homo α : x y / (x < y)%N} & iscvg (μ^~ a \o θ \o α)}.
+ case: (@BW (μ^~ a \o θ)) => [|α mono_α cvg_μα]; last by exists α.
  apply/asboolP/nboundedP; exists 2%:R => // n.
  by rewrite (@le_lt_trans _ _ 1) ?ltr1n // ger0_norm //= le1_mu1.
have homo_α a θ : {homo tag (α a θ) : x y / (x < y)%N} by case: (α a θ).
pose ω θ n := odflt idfun (omap (fun a => tag (α a θ)) (choice.unpickle n)).
have homo_ω k θ: {homo θ : m n / (m < n)%N} -> {homo ω θ k : m n / (m < n)%N}.
+ move=> homo_θ m n lt_mn; rewrite /ω; case: choice.unpickle => //=.
  * by move=> a; apply/homo_α.
pose Ω := fix Ω k :=
  if k is k'.+1 then
    let σ := ω (Ω k').2 k' in (σ, (Ω k').2 \o σ)
  else (idfun, idfun).
have Ω1SE i: (Ω i.+1).1 =1 ω (Ω i).2 i by [].
have Ω2E i: (Ω i).2 =1 \big[comp/idfun]_(0 <= j < i) (Ω j.+1).1.
+ elim: i => /= [|i ih] n; first by rewrite big_geq.
  by rewrite big_nat_recr //= -ih.
have ΩD2E n m: (Ω (n + m)%N).2 =1
  (Ω n).2 \o \big[comp/idfun]_(0 <= j < m) (Ω (n.+1+j)%N).1 => [k /=|].
+ rewrite !Ω2E -addnE (big_cat_nat _ (n := n)) ?leq_addr //=.
  congr (_ _); rewrite -{1}[n]add0n big_addn addKn.
  by apply/eq_bigcomp => {}k _; rewrite addnC.
have homoΩ2 n: {homo (Ω n).2 : x y / (x < y)%N}.
+ by elim: n => //= n ih; apply/homo_comp => //=; apply/homo_ω.
have homoΩ1 n: {homo (Ω n).1 : x y / (x < y)%N}.
+ by case: n => //= n; apply/homo_ω/homoΩ2.
exists (fun n => (Ω n).2 n) => [|a].
+ move=> m n lt_mn; rewrite -{1}[n](subnK (ltnW lt_mn)) addnC.
  rewrite ΩD2E (@leq_trans ((Ω m).2 n)) //; first by apply/homoΩ2.
  rewrite (misc.homo_leq_mono (homoΩ2 _)) homo_geidfun //.
  by apply/homo_bigcomp => k _; apply/homoΩ1.
have [p pE]: exists p, p = (choice.pickle a).+1 by exists (choice.pickle a).+1.
rewrite (iscvg_shift p); pose T n := (Ω (n + p)%N).2 (n + p)%N.
have h: exists2 σ, {homo σ : x y / (x < y)%N} & T =1 (Ω p).2 \o σ.
+ exists (fun n => (\big[comp/idfun]_(0 <= j < n) (Ω (p.+1+j)%N).1) (n+p)%N).
  * move=> x y ltxy; rewrite -(homo_ltn_mono (homoΩ2 p)).
    have /=<- := ΩD2E p x (x+p)%N; have /=<- := ΩD2E p y (y+p)%N.
    rewrite (leq_trans (homoΩ2 _ (x+p)%N (y+p)%N _)) ?ltn_add2r //.
    rewrite -{2}[y](@subnK x) ?[(x <= y)%N]ltnW // addnA addnAC.
    rewrite [in X in (_ <= X)%N]ΩD2E (misc.homo_leq_mono (homoΩ2 _)).
    by apply/homo_geidfun/homo_bigcomp => k _; apply/homoΩ1.
  * by move=> n /=; rewrite /T addnC ΩD2E.
case: h => σ homoσ TE; pose X := ((μ^~ a) \o (Ω p).2) \o σ.
apply/(@iscvg_eq _ _ X); first by move=> k /=; rewrite -/(T _) TE.
apply/iscvg_sub => //; rewrite {p T TE X}pE /=; set ξ := Ω _.
by rewrite /ω choice.pickleK /=; case: (α a ξ.2).
Qed.
End CountableSeqCompacityForDistr.

(* -------------------------------------------------------------------- *)
Lemma strcvg2
  {A B : countType} (μ1 : nat -> distr A) (μ2 : nat -> distr B)
:
  { Ω : nat -> nat | {homo Ω : x y / (x < y)%N} &
     [/\ forall a : A, iscvg (fun n => μ1 (Ω n) a)
       & forall b : B, iscvg (fun n => μ2 (Ω n) b) ] }.
Proof.
case: (strcvg μ1) => ω1 mono1 cvg1.
case: (strcvg (μ2 \o ω1)) => ω2 mono2 cvg2.
(exists (ω1 \o ω2); last split) => // [m n|a].
+ by move/mono2/mono1.
+ by apply/(iscvg_sub (u := (μ1 \o ω1)^~ a) (σ := ω2)).
Qed.

(* ==================================================================== *)
Section RevStrassen.
Context {A B : finType}.
Context (ε δ : R) (μ1 : distr A) (μ2 : distr B) (S : pred (A * B)).

Hypothesis (ge0_ε : 0 <= ε) (ge0_δ : 0 <= δ).
Hypothesis alift : elift ε δ μ1 μ2 S.

Theorem StrassenI X :
  \P_[μ1] X <= Ω ε * \P_[μ2] (fun y => [exists x in X, S (x, y)]) + δ.
Proof.
case: alift => /= -[μL μR] [EL ER RμL RμR /edist_le -/(_ ge0_ε) /= leδ].
pose T := [pred ab : option A * option B
  | if ab is (Some a, _) then X a else false].
move/(_ T): leδ; rewrite !pr_dmargin => /le_trans.
rewrite -(eqr_pr _ EL) -(eqr_pr _ ER) !pr_dmargin; apply.
rewrite ler_add2r ler_pmul2l ?gt0_Ω //; apply/le_in_pr => /=.
case=> [[a|] b] // /RμR /=; rewrite !inE /= => Sab aX.
by apply/existsP; exists a; rewrite Sab andbT.
Qed.
End RevStrassen.

(* ==================================================================== *)
Section FinStrassen.
Context {A B : finType}.
Context (ε δ : R) (μ1 : distr A) (μ2 : distr B) (S : pred (A * B)).

Hypothesis (ge0_ε : 0 <= ε) (ge0_δ : 0 <= δ).

Hypothesis mono : forall X,
  \P_[μ1] X <= Ω ε * \P_[μ2] (fun y => [exists x in X, S (x, y)]) + δ.

Local Notation ω := (dweight μ2 + Ω (- ε) * δ).
Local Notation N := (option A + option B)%type.

Lemma ge0_ω : 0 <= ω.
Proof. by apply/addr_ge0/mulr_ge0 => //; rewrite ?(ge0_pr, ge0_Ω). Qed.

Local Hint Immediate ge0_ω : core.

Local Notation ge0 := (ler01, ge0_Ω, ge0_ω, ge0_ε, ge0_δ, ge0_mu, ler0n).

(* -------------------------------------------------------------------- *)
Section VertexCase.
Context (P : vertex N -> Prop).

Hypothesis Psrc : P ⊤.
Hypothesis Pdst : P ⊥.
Hypothesis PLN  : P (↓ (← None)).
Hypothesis PL   : forall a, P (↓ (⇐ a)).
Hypothesis PRN  : P (↓ (→ None)).
Hypothesis PR   : forall b, P (↓ (⇒ b)).

Lemma vtx_ind v : P v.
Proof. by case: v => -[[|]|[[a|]|[b|]]]. Qed.
End VertexCase.

(* -------------------------------------------------------------------- *)
Definition c (e : edge N) : R :=
  match e.1, e.2 return R with
  | ⊤, ↓ (← (None  )) => ω - Ω (- ε) * (dweight μ1)
  | ⊤, ↓ (⇐ a       ) => Ω (- ε) * μ1 a

  | ↓ (→ (None  )), ⊥ => Ω (- ε) * δ
  | ↓ (⇒ b       ), ⊥ => μ2 b

  | ↓ (← None), ↓ (→ _   ) => ω
  | ↓ (← _   ), ↓ (→ None) => ω

  | ↓ (⇐ a), ↓ (⇒ b) => (S (a, b))%:R * ω

  | _, _ => 0
  end.

(* -------------------------------------------------------------------- *)
Lemma isnetwork_c : isnetwork (finfun c).
Proof.
apply/networkP=> /= -[a b]; elim/vtx_ind: b; elim/vtx_ind: a => *;
  rewrite ?ffunE /c //=; try by rewrite ?mulr_ge0 1?ge0.
rewrite -addrA -mulrBr -(@pmulr_rge0 _ (Ω ε)) ?gt0_Ω //.
rewrite [X in _ <= X]mulrDr mulrA -ΩD subrr Ω0 mul1r addrA.
rewrite subr_ge0 (le_trans (mono _)) // ler_add2r ler_pmul2l ?gt0_Ω //.
by apply/le_in_pr.
Qed.

Local Notation NF  := (Network isnetwork_c).
Local Notation cut := (pred N).

(* -------------------------------------------------------------------- *)
Lemma enum_VN_perm :
  perm_eq
    (enum {: vertex N})
    (⊤ :: ⊥ :: ↓ (← None) :: ↓ (→ None)
       :: [seq ↓ (⇐ a) | a : A]
       ++ [seq ↓ (⇒ b) | b : B]).
Proof.
have h: perm_eql (enum {: vertex N}) [seq Vertex x | x : bool + N].
+ apply/permPl; apply/uniq_perm; rewrite ?enum_uniq //.
  - by rewrite map_inj_uniq ?enum_uniq // => ?? [].
  by case=> v; rewrite mem_enum; apply/esym/map_f; rewrite enumT.
rewrite /image_mem [X in _ ++ X]map_comp [X in X ++ _]map_comp.
rewrite -map_cat -!map_cons {}h; apply/perm_map.
set s1 := (X in X ++ _); set s2 := (X in _ ++ X).
rewrite (permPl enum_sum_perm) /=.
rewrite (perm_cat2rE _ (perm_map _ enum_bool_perm)) /=.
rewrite !perm_cons [X in _ ++ X]map_comp [X in X ++ _]map_comp.
rewrite -map_cat -!map_cons; apply/perm_map => {s1 s2}.
rewrite (permPl enum_sum_perm) /=.
rewrite (perm_cat2rE _ (perm_map _ enum_option_perm)) /= perm_cons.
rewrite perm_sym -cat1s -perm_catCA /= perm_cat //.
+ by rewrite -[X in perm_eq _ X]map_comp; apply/perm_map.
rewrite perm_sym map_comp -map_cons perm_map //.
by apply/enum_option_perm.
Qed.

(* -------------------------------------------------------------------- *)
Lemma sum_cLE : \sum_(a : A) c (⊤, ↓ (⇐ a)) = Ω (-ε) * dweight μ1.
Proof.
rewrite pr_predT psum_fin mulr_sumr; apply/eq_bigr.
by move=> a _; rewrite ger0_norm.
Qed.

(* -------------------------------------------------------------------- *)
Lemma sum_cRE : \sum_(b : B) c (↓ (⇒ b), ⊥) = dweight μ2.
Proof.
rewrite pr_predT psum_fin; apply/eq_bigr.
by move=> b _; rewrite ger0_norm.
Qed.

(* -------------------------------------------------------------------- *)
Lemma sum_cLSE : \sum_(a : option A) c (⊤, ↓ (← a)) = ω.
Proof.
rewrite big_option /= sum_cLE /c /=; set ω := ω.
by rewrite addrAC -addrA subrr addr0.
Qed.

(* -------------------------------------------------------------------- *)
Lemma sum_cRSE : \sum_(b : option B) c (↓ (→ b), ⊥) = ω.
Proof.
by rewrite big_option /= sum_cRE /c /= addrC.
Qed.

(* -------------------------------------------------------------------- *)
Lemma le_NFfc (f : flow NF) e : f e <= c e.
Proof. by have /(_ e) /= := flow_lecp f; rewrite ffunE. Qed.

(* -------------------------------------------------------------------- *)
Lemma ge0_flowNF (f : flow NF) (a : option A) (b : option B):
  0 <= f (↓ (← a), ↓ (→ b)).
Proof.
by apply/flow_ge0; rewrite ffunE; case: a b => [a|] [b|].
Qed.

(* -------------------------------------------------------------------- *)
Lemma sum_flowNFL (f : flow NF) (a : option A) :
  \sum_v f (↓ (← a), v) = \sum_b f (↓ (← a), ↓ (→ b)) - f (⊤, ↓ (← a)).
Proof.
pose XB : {set vertex N} := [set ↓ (→ b) | b : option B].
rewrite (bigID (mem XB)) big_imset /= => [b1 b2 _ _ [//]|].
rewrite (eq_bigl xpredT) //; congr +%R; rewrite (bigD1 ⊤) /=.
+ by apply/imsetP; case.
rewrite flow_antisym big1 ?addr0 // => v /andP[h1 h2].
apply/flow_eq0; rewrite ffunE.
+ elim/vtx_ind: v h1 h2 => //=; try by case: a.
  * by move/imsetP=> []; exists None.
  * by move=> b /imsetP[]; exists (Some b).
+ by elim/vtx_ind: {h1} v h2.
Qed.

(* -------------------------------------------------------------------- *)
Lemma sum_flowNFR (f : flow NF) (b : option B) :
  \sum_v f (↓ (→ b), v) = \sum_a f (↓ (→ b), ↓ (← a)) - f (⊥, ↓ (→ b)).
Proof.
pose XA : {set vertex N} := [set ↓ (← a) | a : option A].
rewrite (bigID (mem XA)) big_imset /= => [a1 a2 _ _ [//]|].
rewrite (eq_bigl xpredT) //; congr +%R; rewrite (bigD1 ⊥) /=.
+ by apply/imsetP; case.
rewrite flow_antisym big1 ?addr0 // => v /andP[h1 h2].
apply/flow_eq0; rewrite ffunE.
+ by elim/vtx_ind: v h1 h2; case: b.
+ elim/vtx_ind: v h1 h2 => //.
  * by move/imsetP=> []; exists None.
  * by move=> a /imsetP[]; exists (Some a).
Qed.

(* -------------------------------------------------------------------- *)
Lemma kcf_flowNFL (f : flow NF) (a : option A) :
  f (⊤, ↓ (← a)) = \sum_b f (↓ (← a), ↓ (→ b)).
Proof.
apply/esym/eqP; rewrite -subr_eq0 -sum_flowNFL.
by apply/eqP/flow_kirchnoff.
Qed.

(* -------------------------------------------------------------------- *)
Lemma kcf_flowNFR (f : flow NF) (b : option B) :
  f (↓ (→ b), ⊥) = \sum_a f (↓ (← a), ↓ (→ b)).
Proof.
apply/eqP; rewrite -subr_eq0 -(rwP eqP) -[RHS](flow_kirchnoff f (→ b)).
rewrite sum_flowNFR [RHS]addrC -flow_antisym; congr +%R.
by rewrite -sumrN; apply/eq_bigr=> /= a _; rewrite -flow_antisym.
Qed.

(* -------------------------------------------------------------------- *)
Lemma cweightE (C : cut) : cweight C NF =
    (if C ← None then \sum_(b | ~~ C (⇒ b)) ω else ω - Ω (-ε) * dweight μ1)
  + (if C → None then Ω (-ε) * δ else \sum_(a | C (⇐ a)) ω)
  + ((C ← None && ~~ C → None)%:R * ω)
  + Ω (-ε) * \P_[μ1] [pred a | ~~ C ⇐ a]
  + \P_[μ2] [pred b | C ⇒ b]
  + \sum_(ab | C ⇐ (ab.1) && ~~ C ⇒ (ab.2)) (S ab)%:R * ω.
Proof.
set c1 := IFP; set c2 := IFP.
set Pμ1 := \P_[μ1] _; set Pμ2 := \P_[μ2] [pred b | C ⇒ b].
pose XA : {set vertex N} := [set ↓ (⇐ x) | x in A].
pose XB : {set vertex N} := [set ↓ (⇒ x) | x in B].
rewrite /cweight {1} /index_enum -enumT /=.
rewrite (perm_big _ enum_VN_perm) /= 2!big_cons /=.
rewrite (bigID (mem XA)) /= -addrA addrCA big_mkcond /=.
rewrite (bigD1 (↓ (← None))) //= !ffunE /= big1 ?addr0.
+ move=> v; rewrite ffunE; case: ifP=> // /andP[].
  by elim/vtx_ind: v => // a _ /imsetP[]; exists a.
rewrite cut_grdE (_ : _ \notin XA = true) ?andbT.
+ by apply/imsetP; case.
rewrite {1}/c /= if_neg addrCA; set c1a := IFP.
rewrite big_andbC big_mkcondr big_imset /= => [a1 a2 _ _ [//]|].
rewrite (eq_bigl xpredT) // [X in X + _ = _](_ : _  = Ω (-ε) * Pμ1).
+ rewrite /Pμ1 pr_finE mulr_sumr; apply/eq_bigr=> a _.
  rewrite !cut_grdE ffunE /c /= if_neg; case: ifP=> //= _.
  - by rewrite !(mul0r, mulr0). - by rewrite !(mul1r, mulr1).
rewrite [_ + (_ * Pμ1)]addrC -!addrA; congr +%R.
rewrite addrC big_mkcond /= big_cons -big_mkcond /= cut_grdE.
rewrite (bigID (mem XB)) /= -[IFF]addr0 -fun2_if; set c1b := IFP.
rewrite [LHS]addrC -(_ : c1a + c1b = c1) -?addrA.
+ rewrite {}/c1a {}/c1b fun2_if !(addr0, add0r); congr IFP.
  rewrite big_mkcondl big_imset /= => [b1 b2 _ _ [//]|].
  rewrite (eq_bigl xpredT) // [RHS]big_mkcond /=.
  by apply/eq_bigr=> b _; rewrite cut_grdE ffunE.
do 2! congr +%R; move=> {c1 c1a c1b}.
rewrite big_mkcond (bigD1 (↓ (→ None))) //= big1 ?addr0.
+ move=> v; rewrite ffunE; case: ifP=> // /andP[].
  by elim/vtx_ind: v => // b _ /imsetP[]; exists b.
rewrite cut_grdE [X in _ && X](_ : _ = true) ?andbT.
+ by apply/imsetP; case.
rewrite ffunE {1}/c /= [RHS]addrCA; congr +%R.
+ by do 2? case: ifP; rewrite !Monoid.simpm.
rewrite big_cons cut_grdE -[IFF]add0r -fun2_if if_same.
rewrite (bigD1 ⊥) //= ffunE {1}/c /= big1 ?addr0.
+ by move=> v; rewrite ffunE => /andP[_]; elim/vtx_ind: v.
set c2a := IFP; rewrite big_cat /= !addrA [RHS]addrAC.
congr +%R; last rewrite big_mkcond /= big_map /Pμ2; last first.
+ rewrite pr_finE [in RHS]/index_enum -enumT; apply/eq_bigr=> b _.
  rewrite cut_grdE /=; case: ifP=> _; rewrite Monoid.simpm //.
  rewrite (bigD1 ⊥) //= ffunE {1}/c /= big1 ?addr0 //.
  by move=> v /andP[_]; rewrite ffunE; elim/vtx_ind: v.
rewrite exchange_big big_mkcond (bigD1 (↓ (→ None))) //=.
rewrite cut_grdE if_neg; set c2b := IFP; rewrite -(_ : c2a + c2b = c2).
+ rewrite {}/c2a {}/c2b /c2 fun2_if ?(addr0, add0r); congr IFP.
  rewrite big_mkcond big_map [RHS]big_mkcond /=.
  rewrite [in RHS]/index_enum -enumT; apply/eq_bigr=> a _.
  by rewrite cut_grdE ffunE; case: ifP.
rewrite -!addrA; do 2! congr +%R; move=> {c2a c2b c2}.
rewrite -big_mkcondl (bigID (mem XB)) /= addrC big1 ?add0r.
+ move=> v; rewrite -andbA => /and3P [_ h1 h2]; rewrite big_map.
  rewrite big1 // => a _; rewrite ffunE; move: h1 h2.
  by elim/vtx_ind: v => // b _ /imsetP[]; exists b.
rewrite big_andbC big_mkcondr big_imset /= => [b1 b2 _ _ [//]|].
rewrite (eq_bigl xpredT) // -big_mkcond big_andbC /=.
rewrite exchange_big big_map enumT pair_big /=; apply/eq_big.
+ by move=> ab; rewrite !cut_grdE.
by case=> [a b] /=; rewrite !cut_grdE ffunE.
Qed.

(* -------------------------------------------------------------------- *)
Lemma cweightE_cutL : cweight pred0 NF = \sum_a c (⊤, ↓ (← a)).
Proof.
rewrite cweightE /= !(pr_pred0, pr_predT, big_pred0_eq).
rewrite !Monoid.simpm -addrA addNr addr0 big_option /=.
rewrite {1}/c /= !pr_predT -[LHS]addr0 -!addrA.
do 2! congr+%R; apply/esym/eqP; rewrite addrC subr_eq0.
rewrite psum_fin mulr_sumr; apply/eqP/eq_bigr.
by move=> a _; rewrite /c /= ger0_norm.
Qed.

(* -------------------------------------------------------------------- *)
Lemma cweight_cutL : cweight pred0 NF = ω.
Proof. by rewrite cweightE_cutL -sum_cLSE. Qed.

(* -------------------------------------------------------------------- *)
Lemma cweightE_cutR : cweight predT NF = \sum_b c (↓ (→ b), ⊥).
Proof.
rewrite cweightE /= !(pr_pred0, pr_predT, big_pred0_eq).
rewrite !Monoid.simpm big_option /=; congr +%R.
by rewrite psum_fin; apply/eq_bigr=> b _; rewrite ger0_norm.
Qed.

(* -------------------------------------------------------------------- *)
Lemma cweight_cutR : cweight predT NF = ω.
Proof. by rewrite cweightE_cutR -sum_cRSE. Qed.

(* -------------------------------------------------------------------- *)
Lemma geω_cut (C : cut) : ω <= cweight C NF.
Proof.
rewrite cweightE; set ω := ω.
set sL := C ← None; set sR := C → None;
  set i1 := IFP; set i2 := IFP;
  set s4 := (X in _ <= _ + X); set s3 := (X in _ + X + s4);
  set s2 := (X in _ + X + s3); set s1 := (X in _ + X + s2).
have h: forall (I : finType) P, 0 <= \sum_(i : I | P i) ω.
+ by move=> I P; apply/sumr_ge0=> i _; apply/ge0_ω.
have [h1 h2 h3 h4]: [/\ 0 <= s1, 0 <= s2, 0 <= s3 & 0 <= s4];
  first (split; try by rewrite 1?mulr_ge0 ?(ge0, ge0_pr)).
+ by apply/sumr_ge0=> /= ab _; rewrite mulr_ge0 ?ge0.
have [hi1 hi2]: [/\ 0 <= i1 & 0 <= i2]; first split.
+ rewrite /i1; case: ifP=> // _; move/forallP: isnetwork_c=> /=.
  by move/(_ (⊤, ↓ (← None))); rewrite ffunE /c /=.
+ by rewrite /i2; case: ifP=> // _; rewrite mulr_ge0 ?ge0.
rewrite /i2; case/boolP: {+}sR => hR; last first.
+ case/boolP: [exists a, C ⇐ a] => [/existsP /= [a Ca]|].
  * by rewrite (bigD1 a) //= !addrA 5?ler_paddr // -addrA ler_paddl.
  rewrite negb_exists => /forallP /= NCA; rewrite /s1 hR andbT.
  case/boolP: {+}sL; rewrite !Monoid.simpm /= => hL.
  * by rewrite 3?ler_paddr // -!addrA 2?ler_paddl.
  rewrite /i1 -if_neg hL /s2 2?ler_paddr // [X in _ <= X]addrAC.
  rewrite ler_paddr // addrAC -addrA -mulrBr ler_paddr //.
  rewrite mulr_ge0 ?ge0_Ω // subr_ge0; apply/le_in_pr.
  by move=> a _ _; apply/NCA.
rewrite /i1; case/boolP: {+}sL => hL.
+ case/boolP: [forall b, C ⇒ b] => [/forallP /=|]; last first.
  * rewrite negb_forall => /existsP [b CNb]; rewrite (bigD1 b) //=.
    by rewrite -6!addrA ler_paddr // !addr_ge0 // mulr_ge0 1?ge0.
  move=> CB; rewrite -![in X in _ <= X]addrA ler_paddl //.
  rewrite /ω [X in X <= _]addrC ler_add2l 2?ler_paddl //.
  by rewrite ler_paddr //; apply/le_in_pr=> b _ _; apply/CB.
case/boolP: [exists ab : A * B, C ⇐ (ab.1) && ~~ C ⇒ (ab.2) && (S ab)].
+ set s := ω - _; rewrite /s4 => /existsP[ab /andP [hCab hab]].
  rewrite (bigD1 ab) ?hCab //= hab mul1r [ω + _]addrC addrA.
  rewrite ler_paddl // addr_ge0 //; last first.
  * by apply/sumr_ge0=> ? _; rewrite mulr_ge0 ?ge0.
  do 4! rewrite addr_ge0 //.
  * by have := hi1; rewrite /i1 -if_neg hL.
  * by rewrite mulr_ge0 ?ge0.
rewrite negb_exists => /forallP /= hS; rewrite ler_paddr //.
rewrite /s1 hR !Monoid.simpm -4!addrA ler_addl addrC.
rewrite subr_ge0 !addrA addrAC; set s := _ + s3.
apply/(@le_trans _ _ (Ω (-ε) * \P_[μ1] [pred a | C ⇐ a] + s2)).
+ rewrite /s2 -mulrDr ler_pmul2l ?gt0_Ω // -pr_or_indep.
  * by move=> a; rewrite !inE negbK.
  by apply/le_in_pr=> a _ _; rewrite 2!inE orbN.
rewrite ler_add2r /s addrC -(@ler_pmul2l _ (Ω ε)) ?gt0_Ω //.
rewrite mulrDr !mulrA -ΩD subrr Ω0 !Monoid.simpm /s3.
pose Pa := [pred a | C ⇐ a].
pose Pb := [pred b | [exists a in Pa, S (a, b)]].
apply/(@le_trans _ _ (Ω ε * \P_[μ2] Pb + δ)); first by apply/mono.
rewrite ler_add2r ler_pmul2l ?gt0_Ω //; apply/le_in_pr.
move=> b _ /existsP[a /andP[Pa_a Sab]]; move/(_ (a, b)): hS => /=.
by rewrite inE in Pa_a; rewrite Pa_a Sab !Monoid.simpm negbK.
Qed.

(* -------------------------------------------------------------------- *)
Lemma mincut_ω : { C : cut | cweight C NF = ω }.
Proof. by exists predT; rewrite cweight_cutR. Qed.

(* -------------------------------------------------------------------- *)
Definition StrassenC := nosimpl (proj1_sig mincut_ω).

(* -------------------------------------------------------------------- *)
Lemma weight_StrassenC : cweight StrassenC NF = ω.
Proof. by rewrite /StrassenC; case: mincut_ω. Qed.

(* -------------------------------------------------------------------- *)
Lemma min_StrassenC (C : cut) : cweight StrassenC NF <= cweight C NF.
Proof. by rewrite weight_StrassenC; apply/geω_cut. Qed.

(* -------------------------------------------------------------------- *)
Section StrassenUnderMaxFlow.
Variable (f : flow NF) (fmax : fmass f = ω).

(* -------------------------------------------------------------------- *)
Lemma fLE (a : option A) : f (⊤, ↓ (← a)) = c (⊤, ↓ (← a)).
Proof.
have := cweightE_cutL; rewrite sum_cLSE -fmax cweightE_cutL fmassE.
pose XA : {set vertex N} := [set ↓ (← a) | a : option A].
move/esym; rewrite (bigID (mem XA)) big_imset /= => [a1 a2 _ _ [//]|].
rewrite (eq_bigl xpredT) // addrC big1 ?add0r.
+ move=> v vXA; apply/flow_eq0; rewrite ffunE.
  * by elim/vtx_ind: v vXA => // [|a'] /imsetP[]; eexists.
  * by elim/vtx_ind: {vXA} v.
move/eqP; rewrite eq_le =>/andP[_ h]; apply/eqP.
apply/contraLR: h; rewrite eq_le le_NFfc -!ltNge => lt.
rewrite !(bigD1 (P := predT) a) //= ltr_le_add //.
by apply/ler_sum=> a' _; apply/le_NFfc.
Qed.

(* -------------------------------------------------------------------- *)
Lemma fRE (b : option B) : f (↓ (→ b), ⊥) = c (↓ (→ b), ⊥).
Proof.
have := cweightE_cutR; rewrite sum_cRSE -fmax cweightE_cutR fmass_snkE.
pose XB : {set vertex N} := [set ↓ (→ b) | b : option B].
move/esym; rewrite (bigID (mem XB)) big_imset /= => [b1 b2 _ _ [//]|].
rewrite (eq_bigl xpredT) // addrC big1 ?add0r.
+ move=> v vXB; apply/flow_eq0; rewrite ffunE.
  * by elim/vtx_ind: v vXB => // [|b'] /imsetP[]; eexists.
  * by elim/vtx_ind: {vXB} v.
move/eqP; rewrite eq_le =>/andP[_ h]; apply/eqP.
apply/contraLR: h; rewrite eq_le le_NFfc -!ltNge => lt.
rewrite !(bigD1 (P := predT) b) //= ltr_le_add //.
by apply/ler_sum=> b' _; apply/le_NFfc.
Qed.

(* -------------------------------------------------------------------- *)
Definition SμL_r (ab : A * option B) : R :=
  Ω ε * f (↓ (⇐ (ab.1)), ↓ (→ (ab.2))).

Definition SμR_r (ab : option A * B) : R :=
  f (↓ (← (ab.1)), ↓ (⇒ (ab.2))).

(* -------------------------------------------------------------------- *)
Lemma dweight_SμL : \sum_ab SμL_r ab = dweight μ1.
Proof.
rewrite /SμL_r; pose F a b := Ω ε * f (↓ (⇐ a), ↓ (→ b)).
rewrite -(pair_big xpredT xpredT F) /= {}/F pr_predT psum_fin.
apply/eq_bigr=> a _; rewrite ger0_norm // -mulr_sumr.
by rewrite -kcf_flowNFL fLE /c /= mulrA -ΩD subrr Ω0 mul1r.
Qed.

(* -------------------------------------------------------------------- *)
Lemma dweight_SμR : \sum_ab SμR_r ab = dweight μ2.
Proof.
rewrite /SμR_r; pose F a b := f (↓ (← a), ↓ (⇒ b)).
rewrite -(pair_big xpredT xpredT F) /= {}/F pr_predT psum_fin.
rewrite exchange_big; apply/eq_bigr=> b _ /=; rewrite ger0_norm //.
by rewrite -kcf_flowNFR fRE.
Qed.

(* -------------------------------------------------------------------- *)
Lemma isdistr_SμL : isdistr SμL_r.
Proof.
apply/isdistr_finP=> /=; split => [ab|].
+ by rewrite mulr_ge0 ?(ge0, ge0_flowNF).
+ by rewrite dweight_SμL le1_pr.
Qed.

(* -------------------------------------------------------------------- *)
Lemma isdistr_SμR : isdistr SμR_r.
Proof.
apply/isdistr_finP=> /=; split => [ab|].
+ by rewrite ge0_flowNF.
+ by rewrite dweight_SμR le1_pr.
Qed.

(* -------------------------------------------------------------------- *)
Definition SμL := nosimpl (mkdistr isdistr_SμL).
Definition SμR := nosimpl (mkdistr isdistr_SμR).

(* -------------------------------------------------------------------- *)
Lemma FinWeakStrassen : elift ε δ μ1 μ2 S.
Proof.
exists (SμL, SμR) => /=; split.
+ move=> a; rewrite dfstE psum_fin /= /SμL_r /=.
  have ->: μ1 a = Ω ε * c (⊤, ↓ (⇐ a)).
  - by rewrite /c /= mulrA -ΩD subrr Ω0 mul1r.
  rewrite -fLE kcf_flowNFL mulr_sumr; apply/eq_bigr.
  by move=> b _; rewrite normrM !ger0_norm // (ge0, ge0_flowNF).
+ move=> b; rewrite dsndE psum_fin /= /SμR_r /=.
  have ->: μ2 b = c (↓ (⇒ b), ⊥) by [].
  rewrite -fRE kcf_flowNFR; apply/eq_bigr.
  by move=> a _; rewrite ger0_norm // ge0_flowNF.
+ move=> a b /dinsuppP /=; rewrite /SμL_r /= => /eqP.
  rewrite mulf_eq0 gt_eqF ?gt0_Ω //=; set e := (X in f X).
  move=> nz_fe; have := le_NFfc f e; rewrite /c /=.
  case: S => //; rewrite mul0r le_eqVlt (negbTE (nz_fe)) /=.
  by rewrite ltNge ge0_flowNF.
+ move=> a b /dinsuppP /=; rewrite /SμR_r /= => /eqP.
  set e := (X in f X) => nz_fe; have := le_NFfc f e; rewrite /c /=.
  case: S => //; rewrite mul0r le_eqVlt (negbTE (nz_fe)) /=.
  by rewrite ltNge ge0_flowNF.
apply/edist_le=> //= X; rewrite !pr_dmargin.
pose P1 := [pred x | ((Some x.1, None) \in X) && (x.2 == None :> option B)].
pose P2 := [pred x | ((Some x.1, x.2 ) \in X) && (x.2 != None)].
set P := (X in X <= _); have {P}->: P = \P_[SμL] P1 + \P_[SμL] P2.
+ rewrite /P (prID _ (fun ab => ab.2 == None)) /=; congr +%R.
  apply/eq_in_pr=> /= -[a b] _; rewrite !inE /in_mem /=.
  by case: (b =P None) => [->|_]; rewrite !(andbT, andbF).
pose Q1 := [pred x | ((None, Some x.2) \in X) && (x.1 == None :> option A)].
pose Q2 := [pred x | ((x.1 , Some x.2) \in X) && (x.1 != None)].
set Q := (X in _ * X); have {Q}->: Q = \P_[SμR] Q1 + \P_[SμR] Q2.
+ rewrite /Q (prID _ (fun ab => ab.1 == None)) /=; congr +%R.
  apply/eq_in_pr=> /= -[a b] _; rewrite !inE /in_mem /=.
  by case: (a =P None) => [->|_]; rewrite !(andbT, andbF).
pose g a b := f (↓ (← a), ↓ (→ b)).
have {P1}->: \P_[SμL] P1 =
  Ω ε * \sum_(a : A | (Some a, None) \in X) g (Some a) None.
+ pose F a b := (P1 (a, b))%:R * SμL (a, b).
  rewrite pr_finE -(pair_big xpredT xpredT F) exchange_big /=.
  rewrite (bigD1 None) //= [X in _ + X]big1 ?addr0.
  - case=> // b _; rewrite {}/F /P1 big1 //.
    by move=> a _; rewrite inE /= andbF mul0r.
  rewrite mulr_sumr [RHS]big_mkcond {}/F /P1; apply/eq_bigr=> a _.
  by rewrite !inE /= eqxx andbT; case: ifP; rewrite !Monoid.simpm.
have {P2}->: \P_[SμL] P2 =
  Ω ε * \sum_(ab | (Some ab.1, Some ab.2) \in X) g (Some ab.1) (Some ab.2).
+ pose F a b := (P2 (a, b))%:R * SμL (a, b).
  rewrite pr_finE -(pair_big xpredT xpredT F) /=.
  rewrite exchange_big big_option big1 /= ?add0r.
  - by move=> a _; rewrite {}/F /P2; rewrite inE andbF mul0r.
  rewrite exchange_big pair_big mulr_sumr [RHS]big_mkcond /=.
  apply/eq_bigr=> -[a b] _ /=; rewrite /F /P2 !inE /=.
  by case: ifP=> //= _; rewrite !Monoid.simpm.
have {Q1}->: \P_[SμR] Q1 =
  \sum_(b : B | (None, Some b) \in X) g None (Some b).
+ pose F a b := (Q1 (a, b))%:R * SμR (a, b).
  rewrite pr_finE -(pair_big xpredT xpredT F) /=.
  rewrite (bigD1 None) //= [X in _ + X]big1 ?addr0.
  - case=> // a _; rewrite {}/F /Q1 big1 //.
    by move=> b _; rewrite inE /= andbF mul0r.
  rewrite [RHS]big_mkcond {}/F /Q1; apply/eq_bigr=> b _.
  by rewrite !inE /= eqxx andbT; case: ifP; rewrite !Monoid.simpm.
have {Q2}->: \P_[SμR] Q2 =
  \sum_(ab | (Some ab.1, Some ab.2) \in X) g (Some ab.1) (Some ab.2).
+ pose F a b := (Q2 (a, b))%:R * SμR (a, b).
  rewrite pr_finE -(pair_big xpredT xpredT F) big_option /= big1.
  - by move=> b _; rewrite {}/F /Q2 /= andbF mul0r.
  rewrite add0r pair_big [RHS]big_mkcond /=.
  apply/eq_bigr=> -[a b] _ /=; rewrite /F /Q2 !inE /=.
  by case: ifP=> //= _; rewrite !Monoid.simpm.
rewrite -ler_subl_addl -mulrDr -mulrBr opprD addrACA subrr addr0.
rewrite mulrBr ler_subl_addr ler_paddr //.
+ rewrite mulr_ge0 ?ge0_Ω //; apply/sumr_ge0.
  by move=> b _; apply/ge0_flowNF.
apply/(@le_trans _ _ (Ω ε * \sum_a g a None)).
+ rewrite ler_pmul2l ?gt0_Ω // big_mkcond /=.
  rewrite big_option ler_paddl //; first by apply/ge0_flowNF.
  by apply/ler_sum=> a _; case: ifP=> // _; apply/ge0_flowNF.
by rewrite /g -kcf_flowNFR fRE /c /= mulrA -ΩD subrr Ω0 mul1r.
Qed.
End StrassenUnderMaxFlow.

(* -------------------------------------------------------------------- *)
Theorem FinStrassen : elift ε δ μ1 μ2 S.
Proof.
case: (maxflow_mincut NF)=> f [hf fmax]; apply/(@FinWeakStrassen f).
case: fmax => /= C fmE; rewrite fmE (rwP eqP) eq_le geω_cut andbT.
by rewrite -fmE -cweight_cutR hf.
Qed.
End FinStrassen.

(* -------------------------------------------------------------------- *)
Section RLift.
Context {T : choiceType} {U : Type}.
Context (c : {fset T}) (f : c -> U) (x0 : U).

Definition rlift := fun x =>
  if @idP (x \in c) is ReflectT h then f [`h]%fset else x0.

Lemma rlift_val x : rlift (fsval x) = f x.
Proof.
rewrite /rlift; case: {-}_ / idP => // h; congr f.
by apply/eqP; rewrite eqE /= eqxx.
Qed.
End RLift.

Section DistrFinRestr.
Context {A : choiceType} (c : {fset A}) (μ : distr A).

Definition mfinrestr (x : c) := μ (val x).

Lemma mfinrestr_is_distr : isdistr mfinrestr.
Proof.
apply/isdistr_finP; split=> [x|]; first by apply/ge0_mu.
have /gerfin_psum -/(_ c) := summable_mu μ.
move/le_trans => /(_ _ (le1_mu μ)) /(le_trans _); apply.
by apply/ler_sum=> /= x _; rewrite ger0_norm.
Qed.

Definition dfinrestr := locked (mkdistr (mfinrestr_is_distr)).

Lemma dfinrestrE x : dfinrestr x = μ (val x).
Proof. by unlock dfinrestr. Qed.

Lemma pr_dfinrestr (X : pred c) :
  \P_[dfinrestr] X = \P_[μ] (rlift X false).
Proof.
rewrite [in RHS]/pr (psum_finseq (r := (enum_fset c))).
+ by apply/fset_uniq.
+ move=> x; rewrite {1}/in_mem /= mulf_eq0 negb_or => /andP[].
  by rewrite /rlift; case: {-}_ / idP => //; rewrite eqxx.
rewrite -big_fset_seq /= /pr psum_fin; apply/eq_bigr => /= x _.
by rewrite dfinrestrE rlift_val.
Qed.
End DistrFinRestr.

(* -------------------------------------------------------------------- *)
Section FinSuppStrassen.
Context {A B : choiceType}.
Context (ε δ : R) (μ1 : distr A) (μ2 : distr B).
Context (c1 : {fset A}) (c2 : {fset B}) (S : pred (A * B)).

Hypothesis (ge0_ε : 0 <= ε) (ge0_δ : 0 <= δ).
Hypothesis (hc1 : {subset dinsupp μ1 <= mem c1}).
Hypothesis (hc2 : {subset dinsupp μ2 <= mem c2}).

Hypothesis mono : forall X, \P_[μ1] X <=
  Ω ε * \P_[μ2] (fun y => `[< exists2 x, x \in X & S (x, y) >]) + δ.

(* FIXME: factor out facts about dfinrestr *)
Theorem FinSuppStrassen : elift ε δ μ1 μ2 S.
Proof.
pose ν1 : distr c1 := dfinrestr c1 μ1.
pose ν2 : distr c2 := dfinrestr c2 μ2.
pose p (x : c1 * c2) := S (val x.1, val x.2).
have h (X : pred c1) : \P_[ν1] X <=
  Ω ε * \P_[ν2] (fun y : c2 => [exists x in X, p (x, y)]) + δ.
+ rewrite pr_dfinrestr (le_trans (mono _)) // ler_add2r.
  rewrite ler_wpmul2l ?ge0_Ω // pr_dfinrestr.
  apply/le_in_pr=> b bsupp; rewrite /in_mem /=.
  case/asboolP=> a; rewrite {1}/rlift; case: {-}_ / idP => //.
  move=> ha Xa Sab; rewrite /rlift; case: {-}_ / idP; last first.
  * by move: bsupp; rewrite {1}/in_mem /= => /hc2.
  by move=> hb; apply/existsP; exists [`ha]%fset; rewrite Xa.
case: (FinStrassen (S := p) ge0_ε ge0_δ h) => {h} /=.
move=> -[η1 η2] /= [ν1E ν2E hs1 hs2 hed].
pose T1 := (A  * option  B)%type; pose T2 := (option  A *  B)%type.
pose U1 := (c1 * option c2)%type; pose U2 := (option c1 * c2)%type.
pose U  := (option c1 * option c2)%type.
pose f1 (xy : U1) := (val xy.1, omap val xy.2).
pose f2 (xy : U2) := (omap val xy.1, val xy.2).
pose ζ1 : distr T1 := dmargin f1 η1.
pose ζ2 : distr T2 := dmargin f2 η2.
exists (ζ1, ζ2) => /=; split.
+ move=> a; rewrite dlet_dlet; set fa := fun xy : U1 => dlet _ _.
  rewrite (eq_in_dlet (g := fun xy => dunit (val xy.1)) (nu := η1)) //=.
  * by move=> xy _ {}a; rewrite dlet_unit.
  case/boolP: (a \in c1) => ac1; last first.
  * rewrite dlet_eq0 => /= [[a' b'] _ /=|].
    - by apply/contra: ac1 => /eqP<-.
    apply/esym; apply/(dinsuppPn μ1); rewrite /in_mem.
    by apply/contra: ac1 => /hc1.
  have := ν1E [`ac1]%fset; rewrite dfinrestrE /= => <-.
  rewrite dmarginE !dletE /=; apply/eq_psum=> /=.
  by case=> [a' b'] /=; rewrite !dunit1E /=.
+ move=> b; rewrite dlet_dlet; set fb := fun xy : U2 => dlet _ _.
  rewrite (eq_in_dlet (g := fun xy => dunit (val xy.2)) (nu := η2)) //=.
  * by move=> xy _ {}b; rewrite dlet_unit.
  case/boolP: (b \in c2) => ac2; last first.
  * rewrite dlet_eq0 => /= [[a' b'] _ /=|].
    - by apply/contra: ac2 => /eqP<-.
    apply/esym; apply/(dinsuppPn μ2); rewrite /in_mem.
    by apply/contra: ac2 => /hc2.
  have := ν2E [`ac2]%fset; rewrite dfinrestrE /= => <-.
  rewrite dmarginE !dletE /=; apply/eq_psum=> /=.
  by case=> [a' b'] /=; rewrite !dunit1E /=.
+ move=> a b /dinsupp_dlet[/=] [] ha [hb|] h /=; last first.
  * by rewrite dunit1E [X in (_ (X _))%:R]eqE /= andbF eqxx.
  rewrite dunit1E  [X in (_ (X _))%:R]eqE /=; case: andP.
  * by case=> /eqP<- /eqP[<-] _; move/hs1: h.
  * by rewrite eqxx.
+ move=> a b /dinsupp_dlet[/=] [] [ha|] hb h /=; last first.
  * by rewrite dunit1E [X in (_ (X _))%:R]eqE /= eqxx.
  rewrite dunit1E  [X in (_ (X _))%:R]eqE /=; case: andP.
  * by case=> /eqP[<-] /eqP<- _; move/hs2: h.
  * by rewrite eqxx.
+ move: hed; rewrite /edist; case: ltrP => // _.
  set v1 : R := sup _; set v2 : R := sup _; suff ->: v1 = v2 by [].
  congr (sup _); rewrite predeqE => /= z; split; last first.
  * case=> /= q ->; pose rq (xy : U) := q (omap val xy.1, omap val xy.2).
    exists rq => /=; congr (_ - _ * _).
    - by rewrite !pr_dmargin; apply/eq_in_pr.
    - by rewrite !pr_dmargin; apply/eq_in_pr.
  case=> /= q ->; pose qr (xy : option A * option B) :=
    let a : option c1 := obind (rlift some None) xy.1 in
    let b : option c2 := obind (rlift some None) xy.2 in
    q (a, b).
  exists qr; congr (_ - _ * _).
  - rewrite !pr_dmargin; apply/eq_in_pr=> /= -[a b] _ //=.
    rewrite /in_mem /qr /= rlift_val; case: b => //= b.
    by rewrite rlift_val.
  - rewrite !pr_dmargin; apply/eq_in_pr => /= -[a b] _ //=.
    rewrite /in_mem /qr /= rlift_val; case: a => //= a.
    by rewrite rlift_val.
Qed.

End FinSuppStrassen.

(* -------------------------------------------------------------------- *)
Section CountableStrassen.
Context {A B : countType}.
Context (ε δ : R) (μ1 : distr A) (μ2 : distr B) (S : pred (A * B)).

Hypothesis (ge0_ε : 0 <= ε) (ge0_δ : 0 <= δ).

Definition E {T : countType} i : {fset T} :=
  seq_fset tt (pmap choice.unpickle (iota 0 i)).

Definition imS (X : pred A) :=
  [pred y | `[< exists2 x, x \in X & S (x, y) >]].

Hypothesis mono :
  forall X, \P_[μ1] X <= Ω ε * \P_[μ2] (imS X) + δ.

Let η1 n := (drestr (mem (E n)) μ1).
Let η2 n := (drestr (mem (E n)) μ2).
Let Δ  n := (Ω ε * \P_[μ2] (predC (mem (E n))) + δ).

Lemma ge0_Δ n : 0 <= Δ n.
Proof. by rewrite addr_ge0 // mulr_ge0 ?(ge0_Ω, ge0_pr). Qed.

Lemma mono_drestr n X :
  \P_[η1 n] X <= Ω ε * \P_[η2 n] (imS X) + Δ n.
Proof.
apply/(@le_trans _ _ (\P_[μ1] X)).
+ apply/le_mu_pr => a _ _; rewrite drestrE.
  by case: ifP => // _; rewrite ge0_mu.
apply/(le_trans (mono X)); rewrite addrA ler_add2r.
rewrite -mulrDr ler_wpmul2l ?ge0_Ω // pr_drestr.
rewrite -pr_or_indep => [b /andP[/=]|]; first by rewrite !inE negbK.
by apply/le_in_pr=> b _; rewrite !inE => ->; rewrite andbT orbN.
Qed.

Local Notation T := (distr (A * option B) * distr (option A * B))%type.

Local Notation elift_r n η :=
 [/\ dfst η.1 =1 η1 n, dsnd η.2 =1 η2 n
   , (forall a b, (a, Some b) \in dinsupp η.1 -> S (a, b))
   , (forall a b, (Some a, b) \in dinsupp η.2 -> S (a, b))
   & edist ε (deliftL η.1) (deliftR η.2) <= Δ n].

Local Notation R η := (forall a b,
  η.2 (Some a, b) <= η.1 (a, Some b) <= Ω ε * η.2 (Some a, b)).

Lemma elift_dfinrestr n : { η : T | elift_r n η /\ R η }.
Proof.
suff: elift ε (Δ n) (η1 n) (η2 n) S by move/(elift_bnd ge0_ε).
apply/(FinSuppStrassen (c1 := E n) (c2 := E n)) => //.
+ by apply/ge0_Δ.
+ by move=> x; rewrite dinsupp_restr => /andP[].
+ by move=> x; rewrite dinsupp_restr => /andP[].
+ by apply/mono_drestr.
Qed.

Let ηL n : distr (A * option B) := (tag (elift_dfinrestr n)).1.
Let ηR n : distr (option A * B) := (tag (elift_dfinrestr n)).2.

Let ω : nat -> nat := tag (strcvg2 ηL ηR).

Local Lemma homo_ω : {homo ω : x y / (x < y)%N}.
Proof. by rewrite /ω; case: strcvg2. Qed.

Let ξL : distr (A * option B) := dlim (ηL \o ω).
Let ξR : distr (option A * B) := dlim (ηR \o ω).

Local Lemma iscvg_ηL x : iscvg (fun n => ηL (ω n) x).
Proof. by rewrite /ω; case: strcvg2 => /= h _ []. Qed.

Local Lemma iscvg_ηR x : iscvg (fun n => ηR (ω n) x).
Proof. by rewrite /ω; case: strcvg2 => /= h _ []. Qed.

Lemma Strassen : elift ε δ μ1 μ2 S.
Proof.
pose GL a := if a is Some a then       μ1 a else 1.
pose GR b := if b is Some b then Ω ε * μ2 b else 1.
have sblGl: summable GL by apply/summable_option/summable_mu.
have sblGR: summable GR by apply/summable_option/summableZ.
have le_μ1 n a : η1 n a <= μ1 a.
+ by rewrite drestrE; case: ifP => // _; apply/ge0_mu.
have le_μ2 n b : η2 n b <= μ2 b.
+ by rewrite drestrE; case: ifP => // _; apply/ge0_mu.
have hLL n a : psum (fun b => ηL n (a, b)) <= μ1 a.
+ by rewrite -dfstE exlift_dfstL le_μ1.
have hRR n b : psum (fun a => ηR n (a, b)) <= μ2 b.
+ by rewrite -dsndE exlift_dsndR le_μ2.
have hLR n a (b : option B) : ηL n (a, b) <= GR b.
+ case: b => /= [b|]; last by apply/le1_mu1.
  apply/(le_trans (exlift_leLR _ _ _)).
  rewrite ler_wpmul2l ?ge0_Ω // (le_trans _ (le_μ2 n _)) //.
  rewrite -(exlift_dsndR (elift_dfinrestr _)) -!/(ηR _) dsndE /=.
  rewrite (le_trans _ (gerfinseq_psum (r := [:: Some a]) _ _)) //.
  - by rewrite big_seq1 ler_norm. - by apply/summable_snd.
have hRL n (a : option A) b : ηR n (a, b) <= GL a.
+ case: a => /= [a|]; last by apply/le1_mu1.
  rewrite (le_trans (exlift_leRL _ _ _)) 1?(le_trans _ (le_μ1 n _)) //.
  rewrite -(exlift_dfstL (elift_dfinrestr _)) -!/(ηL _) dfstE /=.
  rewrite (le_trans _ (gerfinseq_psum (r := [:: Some b]) _ _)) //.
  - by rewrite big_seq1 ler_norm. - by apply/summable_fst.
pose FL a n (b : option B) := ηL (ω n) (a, b).
pose FR b n (a : option A) := ηR (ω n) (a, b).
exists (ξL, ξR) => /=; split => [a|b|||].
+ rewrite dfstE (eq_psum (F2 := fun b => real_of_er (nlim ((FL a)^~ b)))) /=.
  * by move=> b; rewrite [in LHS]dlimE.
  transitivity (real_of_er (nlim (fun n => psum (FL a n)))).
  * rewrite (@DCT_swap _ _ (fun b => ξL (a, b)) GR) => //=.
    - move=> b; rewrite dlimE /FL; case: (iscvg_ηL (a, b)).
      by move=> l hl; rewrite (nlimE hl).
    - by move=> n b; rewrite ger0_norm // (ge0_mu, hLR).
  pose pa := choice.pickle a; have ->: μ1 a = real_of_er (nlim (fun n => η1 (ω n) a)).
  * rewrite -(nlim_lift _ pa.+1) (eq_nlim (v := (μ1 a)%:S)) ?nlimC //.
    move=> n /=; rewrite drestrE /E /= sort_keysE mem_pmap.
    case: mapP => // -[]; exists pa; rewrite ?choice.pickleK //.
    rewrite mem_iota leq0n add0n (@leq_trans (n + pa.+1)) //.
    - by rewrite leq_addl.
    - by apply/homo_geidfun/homo_ω.
  congr real_of_er; apply/eq_nlim => n /=.
  by rewrite -(exlift_dfstL (elift_dfinrestr _)) dfstE.
+ rewrite dsndE (eq_psum (F2 := fun a => real_of_er (nlim ((FR b)^~ a)))) /=.
  * by move=> a; rewrite [in LHS]dlimE.
  transitivity (real_of_er (nlim (fun n => psum (FR b n)))).
  * rewrite (@DCT_swap _ _ (fun a => ξR (a, b)) GL) => //=.
    - move=> a; rewrite dlimE /FR; case: (iscvg_ηR (a, b)).
      by move=> l hl; rewrite (nlimE hl).
    - by move=> n a; rewrite ger0_norm // (ge0_mu, hRL).
  pose pb := choice.pickle b; have ->: μ2 b = real_of_er (nlim (fun n => η2 (ω n) b)).
  * rewrite -(nlim_lift _ pb.+1) (eq_nlim (v := (μ2 b)%:S)) ?nlimC //.
    move=> n /=; rewrite drestrE /E /= sort_keysE mem_pmap.
    case: mapP => // -[]; exists pb; rewrite ?choice.pickleK //.
    rewrite mem_iota leq0n add0n (@leq_trans (n + pb.+1)) //.
    - by rewrite leq_addl.
    - by apply/homo_geidfun/homo_ω.
  congr real_of_er; apply/eq_nlim => n /=.
  by rewrite -(exlift_dsndR (elift_dfinrestr _)) dsndE.
+ by move=> a b /dinsupp_dlim [K] /(_ _ (leqnn _)) /exlift_dsuppL.
+ by move=> a b /dinsupp_dlim [K] /(_ _ (leqnn _)) /exlift_dsuppR.
apply/edist_le_supp => //= X subX.
pose L n : elift.R := \P_[deliftL (ηL (ω n))] X.
pose R n : elift.R := \P_[deliftR (ηR (ω n))] X.
have cvgL: ncvg L (\P_[deliftL ξL] X)%:E.
* pose F n a b := (X (a, b))%:R * (deliftL (ηL (ω n)) (a, b)).
  pose G n := psum (fun a => psum (fun b => F n a b)).
  apply/(ncvg_eq (v := G)); rewrite {}/L {}/G /=.
  - by move=> n; rewrite /pr psum_pair //=; apply/summable_condl.
  pose G (a : option A) b := (X (a, b))%:R * deliftL ξL (a, b).
  rewrite /pr psum_pair /=; first by apply/summable_condl.
  move=> [: hcv1]; apply/(@DCT_ncvg _ _ (fun a => (psum (G a))) GL) => //=.
  - abstract: hcv1 => a /=; apply (@DCT_ncvg _ _ (G a) GR) => //=.
    + move=> b; apply/ncvgZ; case: a => /= [a|].
      * apply/(@ncvg_eq _ (fun n => ηL (ω n) (a, b))).
        - by move=> n /=; rewrite deliftLE.
        rewrite deliftLE /ξL; case: (iscvg_ηL (a, b)).
        by move=> l hl; rewrite dlimE (nlimE hl).
      * apply/(@ncvg_eq _ 0%:S) => [n|].
        - by rewrite deliftLE.
        - by rewrite deliftLE; apply/ncvgC.
    + move=> n b; rewrite ger0_norm ?mulr_ge0 ?(ler0n, ge0_mu) //.
      rewrite (@le_trans _ _ (deliftL (ηL (ω n)) (a, b))) //.
      * by rewrite ler_pimull ?ge0_mu // lern1 leq_b1.
      case: a => /= [a|]; first by rewrite deliftLE hLR.
      rewrite deliftLE /= /GR; case: b => /= [b|].
      * by rewrite mulr_ge0 ?(ge0_mu, ge0_Ω).
      * by rewrite ler01.
  - move=> n a; rewrite ger0_norm ?ge0_psum //; case: a => /=.
    + move=> a; apply/(le_trans _ (hLL (ω n) _))/le_psum => /=.
      * move=> b; rewrite /F deliftLE mulr_ge0 //= ?ler0n //.
        by rewrite ler_pimull // lern1 leq_b1.
      * by apply/summable_fst.
    + by rewrite psum_eq0 ?ler01 //= => b; rewrite /F deliftLE mulr0.
have cvgR: ncvg R (\P_[deliftR ξR] X)%:E.
* pose F n a b := (X (a, b))%:R * (deliftR (ηR (ω n)) (a, b)).
  pose G n := psum (fun b => psum (fun a => F n a b)).
  apply/(ncvg_eq (v := G)); rewrite {}/R  {}/G /=.
  - by move=> n; rewrite /pr psum_pair_swap //=; apply/summable_condl.
  rewrite /pr psum_pair_swap /=; first by apply/summable_condl.
  pose G (b : option B) a := (X (a, b))%:R * deliftR ξR (a, b).
  move=> [: hcv1]; apply/(@DCT_ncvg _ _ (fun b => (psum (G b))) GR) => //=.
  - abstract: hcv1 => b /=; apply (@DCT_ncvg _ _ (G b) GL) => //=.
    + move=> a; apply/ncvgZ; case: b => /= [b|].
      * apply/(@ncvg_eq _ (fun n => ηR (ω n) (a, b))).
        - by move=> n /=; rewrite deliftRE.
        rewrite deliftRE /ξR; case: (iscvg_ηR (a, b)).
        by move=> l hl; rewrite dlimE (nlimE hl).
      * apply/(@ncvg_eq _ 0%:S) => [n|].
        - by rewrite deliftRE.
        - by rewrite deliftRE; apply/ncvgC.
    + move=> n a; rewrite ger0_norm ?mulr_ge0 ?(ler0n, ge0_mu) //.
      rewrite (@le_trans _ _ (deliftR (ηR (ω n)) (a, b))) //.
      * by rewrite ler_pimull ?ge0_mu // lern1 leq_b1.
      case: b => /= [b|]; first by rewrite deliftRE hRL.
      rewrite deliftRE /= /GL; case: a => /= [a|].
      * by rewrite ge0_mu. * by rewrite ler01.
  - move=> n b; rewrite ger0_norm ?ge0_psum //; case: b => /=.
    + move=> b; apply/(@le_trans _ _ (μ2 b)); last first.
      * by rewrite ler_pemull // Ω_ge1.
      apply/(le_trans _ (hRR (ω n) _))/le_psum => /=.
      * move=> a; rewrite /F deliftRE mulr_ge0 //= ?ler0n //.
        by rewrite ler_pimull // lern1 leq_b1.
      * by apply/summable_snd.
    + by rewrite psum_eq0 ?ler01 //= => b; rewrite /F deliftRE mulr0.
rewrite addrC -ler_subl_addr; set V := (X in X <= _).
suff cvgΔ: ncvg Δ δ%:E.
* move/(ncvg_sub homo_ω)/ncvg_le: cvgΔ => /(_ (L \- Ω ε \*o R) V%:E) /=.
  apply=> [n|]; last by apply/ncvgB/ncvgZ.
  rewrite ler_subl_addr addrC /L /R.
  have := exlift_edist (elift_dfinrestr (ω n)) => /edist_le.
  by move/(_ ge0_ε X); rewrite -/(ηL _) -/(ηR _).
rewrite -[δ]add0r -[X in (X + _)%:E](mulr0 (Ω ε)).
apply/ncvgD/ncvgC/ncvgZ; rewrite -[X in X%:E](@psum0 _ B).
apply/(DCT_ncvg (g := μ2)) => //; last first.
* move=> n b; rewrite ger0_norm ?mulr_ge0 ?ler0n //.
  by rewrite ler_pimull // lern1 leq_b1.
move=> b; apply/ncvgMl; last first.
* apply/asboolP/nboundedP; exists 2%:R => // _.
  apply/(@le_lt_trans _ _ 1) => //; last by rewrite (@ltr_nat _ 1).
  by rewrite ger0_norm // le1_mu1.
elim/nbh_finW => /= e gt0_e; exists (choice.pickle b).+1 => n le_bn.
rewrite inE subr0; apply/(le_lt_trans _ gt0_e).
rewrite normr_le0 pnatr_eq0 eqb0 negbK /E seq_fsetE.
rewrite mem_pmap; apply/mapP; exists (choice.pickle b).
* by rewrite mem_iota /= add0n.
* by rewrite choice.pickleK.
Qed.
End CountableStrassen.