Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e510m290x2e496m1_16limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Module StateSpaceTheorems.

Require Import Setoid.
Require Import New.Complex.
Require Import New.Equiv.
Require Import New.Ring.
Require Import New.RingTheorems.
Require Import New.Field.
Require Import InnerProd.
Require Import InnerProdTheorems.
Require Import Scalars.
Require Import States.
Require Import StateTheorems.
Require Import StateSpace.
Require Import Coq.Sets.Ensembles.

Variable Scalar : Type.
Variable State : Type.

(* Inductive equality for meets and joins.  This, combined with a
 * basis equality lemma, will become the primary proof goal for showing
 * equality. *)
Definition state_meet_join_ind_eq
  {statespace : StateSpace Scalar State}
  (S1 S2 : State) : Prop :=
  (forall (S3 S4 : State),
    <| S3 | S1 |> = <| S3 | S2 |> -> <| S4 | S1 |> = <| S4 | S2 |> ->
      <| join S3 S4 | S1 |> = <| join S3 S4 | S2 |>) /\
  (forall (S3 S4 : State),
    <| S3 | S1 |> = <| S3 | S2 |> -> <| S4 | S1 |> = <| S4 | S2 |> ->
      <| meet S3 S4 | S1 |> = <| meet S3 S4 | S2 |>).

(* Helper for proving that extensional equality on inner products is
 * inductive *)
Definition state_inner_prod_eq
  {statespace : StateSpace Scalar State}
  (S1 S2 : State) (S : State) :=
   <| S | S1 |> = <| S | S2 |>.

(* If we have meet-join inductive equality, we can show that full
 * extensional equality is inductive *)
Lemma state_inner_prod_eq_ind
  {statespace : StateSpace Scalar State}
  (S1 S2 : State) :
  state_meet_join_ind_eq S1 S2 ->
  state_pred_inductive (state_inner_prod_eq S1 S2).
Proof.
  unfold state_meet_join_ind_eq.
  intros (join_ind & meet_ind).
  unfold state_pred_inductive.
  unfold state_inner_prod_eq.
  split.
  assumption.
  split.
  assumption.
  split.
  intros.
  rewrite 2! inner_prod_left_homogeneous.
  apply mul_extensional.
  reflexivity.
  assumption.
  exact innerprod_ss.
  exact innerprod_ss.
  split.
  intros.
  apply inner_prod_conj_ext.
  assumption.
  rewrite 2! inner_prod_left_strict.
  reflexivity.
  exact innerprod_ss.
  exact innerprod_ss.
Qed.

(* Basis equality: Are these two states equal in an inner product with
 * any basis element? *)
Definition state_basis_eq
  {statespace : StateSpace Scalar State}
  (B : Ensemble State) (S1 S2 : State) : Prop :=
  forall (S : State), In State B S -> <| S | S1 |> = <| S | S2 |>.

(* If we have a basis for the entire state space, then meet-join
 * equality and basis equality proves general equality. *)
Lemma state_meet_join_eq_induction_with_basis
  {statespace : StateSpace Scalar State}
  (B : Ensemble State) (S1 S2 : State) :
  (forall (S : State), state_basis B S) ->
  state_meet_join_ind_eq S1 S2 ->
  state_pred_forall_basis B (state_inner_prod_eq S1 S2) ->
  S1 = S2.
Proof.
  intros.
  apply inner_prod_ext_eq.
  intro.
  apply (state_inner_prod_eq_ind S1 S2) in H0.
  apply (state_basis_induction B (state_inner_prod_eq S1 S2)).
  assumption.
  assumption.
  apply H.
Qed.

(* join S1 S2 = join S2 S1 *)
Lemma state_join_comm_meet_join_eq
  {statespace : StateSpace Scalar State} :
  forall (S1 S2 : State), state_meet_join_ind_eq (join S1 S2) (join S2 S1).
Proof.
  intro.
  unfold state_meet_join_ind_eq.
  split.
  intros.
  rewrite 2! inner_prod_join_right.
  rewrite add_comm.
  reflexivity.
  intros.
  rewrite 2! inner_prod_meet_join.
  apply mul_extensional.
  rewrite add_comm.
  reflexivity.
  rewrite add_comm.
  reflexivity.
  exact innerprod_ss.
  exact innerprod_ss.
Qed.

Lemma state_meet_comm_meet_join_eq
  {statespace : StateSpace Scalar State} :
  forall (S1 S2 : State), state_meet_join_ind_eq (meet S1 S2) (meet S2 S1).
Proof.
  intro.
  unfold state_meet_join_ind_eq.
  split.
  intros.
  rewrite 2! inner_prod_right_meet.
  apply mul_comm.
  intros.
  rewrite 2! inner_prod_right_meet.
  apply mul_comm.
Qed.

(*
Lemma state_join_assoc_meet_join_eq
  {statespace : StateSpace Scalar State} :
  forall (S1 S2 S3 : State),
    state_meet_join_ind_eq (join (join S1 S2) S3) (join S1 (join S2 S3)).
Proof.
  intro.
  unfold state_meet_join_ind_eq.
  split.
  intros.
  rewrite 4! inner_prod_join_right.
  rewrite add_assoc.
  reflexivity.
  intros.
  rewrite 2! inner_prod_meet_join.

Lemma state_meet_assoc_meet_join_eq
  {statespace : StateSpace Scalar State} :
  forall (S1 S2 S3 : State),
    state_meet_join_ind_eq (meet (meet S1 S2) S3) (meet S1 (meet S2 S3)).
Proof.
  intro.
  unfold state_meet_join_ind_eq.
  split.
  intros.
*)

(* join null S = S *)
Lemma state_join_bot_meet_join_eq
  {statespace : StateSpace Scalar State} :
  forall (S : State), state_meet_join_ind_eq (join null S) S.
Proof.
  intro.
  unfold state_meet_join_ind_eq.
  split.
  intros.
  rewrite inner_prod_join_right.
  rewrite inner_prod_right_strict.
  rewrite add_comm.
  rewrite add_zero_right.
  reflexivity.
  intros.
  rewrite inner_prod_meet_join.
  rewrite 2! inner_prod_right_strict.
  rewrite add_comm.
  rewrite add_zero_right.
  rewrite add_comm.
  rewrite add_zero_right.
  rewrite inner_prod_left_meet.
  reflexivity.
  exact innerprod_ss.
  exact innerprod_ss.
Qed.

(* meet null S = null *)
Lemma state_meet_bot_meet_join_eq
  {statespace : StateSpace Scalar State} :
  forall (S : State), state_meet_join_ind_eq (meet null S) null.
Proof.
  intro.
  unfold state_meet_join_ind_eq.
  split.
  intros.
  rewrite inner_prod_join_meet.
  rewrite 3! inner_prod_right_strict.
  rewrite add_zero_right.
  rewrite mul_comm.
  rewrite mul_zero_right.
  reflexivity.
  intros.
  rewrite inner_prod_right_meet.
  rewrite inner_prod_right_strict.
  rewrite mul_comm.
  rewrite mul_zero_right.
  reflexivity.
Qed.
(*
Lemma state_join_scalar_meet_join_eq
  {statespace : StateSpace Scalar State} :
  forall (S : State) (a b : Scalar),
    state_meet_join_ind_eq (join (scalar_prod a S) (scalar_prod b S))
                           (scalar_prod (a + b) S).
Proof.
  intro.
  unfold state_meet_join_ind_eq.
  split.
  intros.
  rewrite inner_prod_join_right.
  rewrite 3! inner_prod_right_homogeneous.
  rewrite mul_comm.
  replace (b * <| join S3 S4 | S |>) with (<| join S3 S4 | S |> * b).
  rewrite <- add_mul_dist.
  apply mul_comm.
  apply mul_comm.
  intros.
  rewrite inner_prod_meet_join.
  rewrite 5! inner_prod_right_homogeneous.
*)
End StateSpaceTheorems.


From Coq Require Import List ssreflect.
From Mon Require Import Base.
From Mon.SM Require Export SMSyntax.
From Mon.sprop Require Import SPropBase SPropMonadicStructures.
From Equations Require Equations.

(******************************************************************************)
(**                                                                           *)
(**              Denotation from SM to Gallina                                *)
(**                                                                           *)
(******************************************************************************)

(** Denotation of types (discrete order case) *)

Section ToType.
  Context (M:Type -> Type).

  Fixpoint to_type (c:ctype) {struct c} : Type :=
    match c with
    | CM A => M A
    | CProd C1 C2 => to_type C1 × to_type C2
    | @CArr A C => forall (x:A), to_type (C x)
    | CArrC C1 C2 => to_type C1 -> to_type C2
    end.
End ToType.

Notation "⦑ C | M ⦒" := (to_type M C).

Section ICTermToTerm.
  Context (M:Monad).

  Definition icterm_to_term {Γ c} (ct : icterm Γ c) :
    substitution (to_type M) Γ -> ⦑ c |M⦒.
  Proof.
    induction ct ; intro σ.
    exact ret.
    exact (bind (IHct2 σ) (IHct1 σ)).
    exact (npair (IHct1 σ) (IHct2 σ)).
    destruct c ; inversion H ; exact (nfst (IHct σ)).
    destruct c ; inversion H ; exact (nsnd (IHct σ)).
    intro v ; apply (X v σ).
    destruct c ; inversion H ; exact (IHct σ v).
    exact (Substitution.dlookup _ _ σ H).
    intro x ; exact (IHct (ConsSubst x σ)).
    destruct c ; inversion H ; exact (IHct1 σ (IHct2 σ)).
  Defined.

End ICTermToTerm.

Notation "⦑ t | σ | M ⦒" := (icterm_to_term M t σ).

(** Denotation commutes to substitution *)

Section ICTermToTermSubst.
  Import DepElim.
  Context (M:Monad).

  Lemma map_subst_comp : forall {Γ var1 var2 var3} (σ : substitution var1 Γ) (f : forall c, var1 c -> var2 c) (g: forall c, var2 c -> var3 c),
      map_subst g (map_subst f σ) = map_subst (fun c x => g c (f c x)) σ.
  Proof.
    unfold map_subst.
    intros.
    rewrite <- Substitution.dmap_compose.
    reflexivity.
  Qed.

  (* Lemma to_term_weaken0 {Γ1 Γ2 c} (t:icterm (Γ1++Γ2) c) : *)
  (*   forall c0 (x:⦑c0|M⦒) (σ1 : substitution (to_type M) Γ1) *)
  (*     (σ2 : substitution (to_type M) Γ2), *)
  (*     ⦑ rename0 t (weaken_renaming c0) | appSubst σ1 (ConsSubst x σ2) |M⦒ *)
  (*     = ⦑ t | appSubst σ1 σ2 |M⦒. *)
  Import Equations.
  Import EqNotations.
  Import Substitution.

  Import FunctionalExtensionality.
  Lemma to_term_rename {Γ1 c} (t:icterm Γ1 c) :
    forall Γ2 (σ : substitution (to_type M) Γ2) (ρ : irenaming Γ2 Γ1),
      ⦑ rename0 t ρ | σ |M⦒ = ⦑ t | renaming_subst_act ρ σ  |M⦒.
  Proof.
    induction t ; intros Γ2 σ ρ ; simpl.
    reflexivity.
    f_equal ; [apply IHt2 | apply IHt1].
    f_equal ; [apply IHt1 | apply IHt2].
    destruct c ; inversion H ; destruct H ; erewrite IHt ; reflexivity.
    destruct c ; inversion H ; destruct H ; erewrite IHt ; reflexivity.
    extensionality v ; apply H.
    destruct c ; inversion H ; destruct H ; erewrite IHt ; reflexivity.
    rewrite dlookup_renaming_subst_act.
    set (z := dlookup n Γ ρ H).
    destruct z as [n' [Hn Hlkp]].
    simpl.
    symmetry.
    change (rew ?H in ?x = ?y) with (x =⟨H⟩ y).
    apply (fun_app_above ctype _ _ Hlkp (icterm Γ2) (to_type M)(fun c ct => @icterm_to_term M Γ2 c ct σ) (ICVar n' (StrictProp.unbox Hn))).
    extensionality x.
    move: renaming_weaken (IHt  _ (ConsSubst x σ) (cons_renaming c1 ρ)).
    unfold renaming_subst_act ; unfold cons_renaming.
    simp dmap; unfold lkp_tyvar_subst ; simp_dlookup.
    move=> -> //.
    destruct c ; inversion H ; destruct H; erewrite IHt1 ; erewrite IHt2 ; reflexivity.
    Qed.

  Lemma to_term_weaken {Γ c} (t:icterm Γ c) :
  forall c0 (x:⦑c0|M⦒) (σ : substitution (to_type M) Γ),
    ⦑ ↑ t | ConsSubst x σ |M⦒ = ⦑ t |σ  |M⦒.
  Proof.
    intros ;
      move: (to_term_rename t (c0::Γ) (ConsSubst x σ)
                            (@weaken_renaming c0 nil _)) ;
      unfold weaken_renaming=> //.
    rewrite renaming_weaken renaming_subst_act_id //.
  Qed.

  Import FunctionalExtensionality.
  Lemma to_term_isubst {Γ c} (t:icterm Γ c) :
    forall Γ' (σ : substitution (to_type M) Γ') (ρ : isubstitution Γ' Γ),
      ⦑ isubst t ρ | σ |M⦒ = ⦑ t | map_subst (fun c m => ⦑ m | σ |M⦒) ρ |M⦒.
  Proof.
    induction t ; simpl ; intros Γ' σ ρ.
    reflexivity.
    f_equal ; auto.
    f_equal ; auto.
    destruct c ; destruct H ; rewrite IHt ; reflexivity.
    destruct c ; destruct H ; rewrite IHt ; reflexivity.
    extensionality x ; auto.
    destruct c ; destruct H ; rewrite IHt ; reflexivity.
    rewrite dlookup_dmap ; reflexivity.
    extensionality x; rewrite IHt; simpl;
      rewrite map_subst_comp; unfold ConsSubst ;
        do 2 f_equal ; unfold map_subst; apply dmap_ext=> // ? ?;
        rewrite to_term_weaken; reflexivity.
    destruct c ; destruct H ; rewrite IHt1; rewrite IHt2; reflexivity.
  Qed.

End ICTermToTermSubst.

(** Denotation preserves the equational theory *)

Section ICeqToEq.
  Import DepElim.
  Context (M:Monad).

  Let var_eq c := {p:⦑c |M⦒ × ⦑c|M⦒ ⫳ nfst p = nsnd p}.
  Let efst c (m:var_eq c) := nfst (dfst m).
  Let esnd c (m:var_eq c) := nsnd (dfst m).
  (* Let eeq c (m:var_eq c) := dsnd m. *)

  Import FunctionalExtensionality.
  Definition icterm_diagonal {Γ c} (ct : icterm Γ c) : forall (σ : substitution var_eq Γ), ⦑ct | map_subst efst σ |M⦒ = ⦑ ct | map_subst esnd σ |M⦒.
  Proof.
    induction ct ; simpl ; intros σ.
    reflexivity.
    f_equal ; auto.
    f_equal ; auto.
    destruct c ; destruct H ; erewrite IHct ; [reflexivity|..] ; eassumption.
    destruct c ; destruct H ; erewrite IHct ; [reflexivity|..] ; eassumption.
    extensionality v ; auto.
    destruct c ; destruct H ; simpl;
      erewrite IHct ; [reflexivity|..] ; eassumption.
    rewrite !Substitution.dlookup_dmap ; exact (dsnd (Substitution.dlookup n Γ σ H)).
    extensionality x;
      exact (IHct (ConsSubst (dpair _ ⟨x, x⟩ eq_refl) σ)).
    destruct c ; destruct H ; rewrite IHct1 ; rewrite IHct2 ; reflexivity.
  Qed.

  Import Substitution.
  Lemma map_subst_id Γ σ :
    map_subst (fun c m => @icterm_to_term M Γ c m σ) (id_isubst Γ) = σ.
  Proof.
    apply (dlist_extensionality _ _ _ eq_refl _) => n.
    revert Γ σ; induction n; move=> ? σ H ; dependent elimination σ ; simp_dlookup.
    simp dmap ; simp_dlookup; by [].
    simpl in IHn |- *.
    rewrite dlookup_dmap. simp_dlookup.
    rewrite <- IHn.
    rewrite !dlookup_dmap. apply to_term_weaken.
  Qed.

  Definition iceq_to_eq {Γ c} {ct1 ct2 : icterm Γ c} (Heq : ct1 ≅ ct2) :
    forall (σ : substitution var_eq Γ),
      ⦑ct1 | map_subst efst σ |M⦒ = ⦑ ct2 | map_subst esnd σ |M⦒.
  Proof.
    induction Heq ; simpl ; intros σ.
    1-3:unfold bind ; unfold ret.
    rewrite monad_law1 ; rewrite icterm_diagonal ; reflexivity.
    rewrite monad_law2 ; rewrite icterm_diagonal ; reflexivity.
    rewrite monad_law3 ; rewrite 3!icterm_diagonal ; reflexivity.
    f_equal ; auto.
    destruct H ; apply icterm_diagonal.
    destruct H ; apply icterm_diagonal.
    destruct H ; rewrite icterm_diagonal ; reflexivity.
    f_equal ; auto.
    destruct c ; destruct H ; rewrite IHHeq ; reflexivity.
    destruct c ; destruct H ; rewrite IHHeq ; reflexivity.
    destruct H ; rewrite icterm_diagonal ; reflexivity.
    destruct H ; extensionality v ; rewrite icterm_diagonal; reflexivity.
    extensionality v ; auto.
    destruct c ; destruct H ; dependent destruction Heq ; rewrite IHHeq ; reflexivity.
    destruct H ; unfold isubst_one; rewrite to_term_isubst; simpl; rewrite map_subst_id;
      pose (hd := dpair _
                        ⟨⦑ct2 | map_subst efst σ |M⦒, ⦑ct2 | map_subst esnd σ |M⦒⟩
                        (icterm_diagonal ct2 σ) : var_eq _);
      apply (icterm_diagonal ct1 (ConsSubst hd σ)).

    destruct H ; extensionality x; cbn; rewrite to_term_weaken; rewrite icterm_diagonal; reflexivity.
    extensionality x; apply (IHHeq (ConsSubst (dpair _ ⟨x,x⟩ eq_refl) σ)).
    destruct c ; destruct H ; rewrite IHHeq1 ; rewrite IHHeq2 ; reflexivity.
    apply icterm_diagonal.
    symmetry ; rewrite icterm_diagonal ; rewrite <- (icterm_diagonal ct1) ; apply IHHeq.
    transitivity ⦑ ct2 | map_subst esnd σ |M⦒ ; [|rewrite <- (icterm_diagonal ct2)] ; auto.
  Qed.
End ICeqToEq.

(******************************************************************************)
(**                                                                           *)
(**              Logical relation on the denotation                           *)
(**                                                                           *)
(******************************************************************************)

(** Relational interpretation of types *)

Section ToRel.
  Context (M1 M2 : Type -> Type).
  Context (R : forall A, M1 A -> M2 A -> Type).

  Fixpoint to_rel (c:ctype) : ⦑ c |M1⦒ -> ⦑ c |M2⦒ -> Type :=
    match c with
    | CM A => R A
    | CProd c1 c2 =>
      fun '⟨x11, x21⟩ '⟨x12, x22⟩ => to_rel c1 x11 x12 × to_rel c2 x21 x22
    | CArr c => fun f1 f2 => forall x, to_rel (c x) (f1 x) (f2 x)
    | CArrC c1 c2 => fun f1 f2 => forall x1 x2, to_rel c1 x1 x2 -> to_rel c2 (f1 x1) (f2 x2)
    end.

End ToRel.

(** Covariance restriction on SM types *)

Fixpoint covariant (c:ctype) : Prop :=
  match c with
  | CM _ => True
  | CProd c1 c2 => covariant c1 /\ covariant c2
  | CArr Cs => forall x, covariant (Cs x)
  | CArrC _ _ => False
  end.

(** (Functional) Special case when the SM type is covariant *)

Section ToFunction.
  Context (M1 M2 : Type -> Type).
  Context (θ : forall A, M1 A -> M2 A).
  Context (c:ctype) (c_cov : covariant c).

  Definition to_function : ⦑ c |M1⦒ -> ⦑ c |M2⦒.
  Proof.
    induction c as [A| | |].
    exact (θ A).
    intros [] ; destruct c_cov ; simpl ; intuition ; auto.
    intros ? x ; simpl in c_cov ; specialize c_cov with x; auto.
    contradiction c_cov.
  Defined.

End ToFunction.

Section ToFunctionLemmas.
  Context (M1 M2 M3 : Type -> Type).
  Context (c:ctype) (c_cov : covariant c).

  Import FunctionalExtensionality.
  Lemma to_function_id : forall m, to_function M1 M1 (fun A => id) c c_cov m = m.
  Proof.
    induction c ; simpl.
    intros ; reflexivity.
    intros [? ?] ; destruct c_cov ; f_equal ; auto.
    intros ? ; extensionality x; auto.
    inversion c_cov.
  Qed.

  Context (f : forall A, M1 A -> M2 A) (g: forall A, M2 A -> M3 A).

  Lemma to_function_comp :
    forall m, to_function M2 M3 g c c_cov (to_function M1 M2 f c c_cov m) = to_function M1 M3 (fun _ x => g _ (f _ x)) c c_cov m.
  Proof.
    induction c ; simpl.
    intros ; reflexivity.
    intros [? ?] ; destruct c_cov ; f_equal ; auto.
    intros ? ; extensionality x; auto.
    inversion c_cov.
  Qed.

End ToFunctionLemmas.

(** Compatibility of the special case to the general case *)

Section ToRelToFunction.
  Context (M1 M2 : Type -> Type).
  Context (θ : forall A, M1 A -> M2 A).

  Let R := fun A (m1: M1 A) (m2 : M2 A) => θ A m1 = m2.

  Import FunctionalExtensionality.

  Fixpoint to_rel_to_function (c:ctype) : forall (c_cov : covariant c) x1 x2,
      to_rel M1 M2 R c x1 x2 -> to_function M1 M2 θ c c_cov x1 = x2
  with to_function_to_rel (c:ctype) : forall (c_cov : covariant c) x1 x2,
      to_function M1 M2 θ c c_cov x1 = x2 -> to_rel M1 M2 R c x1 x2.
  Proof.
    all:destruct c ; simpl.
    intros ? ? ? ; trivial.
    intros [] [] [] [] ; f_equal ; auto.
    intros ? ? ? ? ; extensionality x ; auto.
    intros [].

    intros ? ? ? ; trivial.
    intros [] [] [] H ; injection H ; clear H ; intros ? ? ; split ;
      eapply to_function_to_rel ; eassumption.
    intros ? ? ? H ? ; apply (f_equal (fun f => f x)) in H;
      eapply to_function_to_rel; eassumption.
    intros [].
  Defined.

End ToRelToFunction.

(** Relational interpretation of terms
    (aka. fundamental lemma of logical relations)*)

Section ICTermToRel.
  Import DepElim.
  Context (M1 M2 : Monad).
  Context (R : forall A, M1 A -> M2 A -> Prop).
  Context (Runit : forall A (x:A), R A (ret x) (ret x)).
  Context (Rbind : forall A B (m1 : M1 A) (m2 : M2 A) (f1 : A -> M1 B) (f2 : A -> M2 B), R A m1 m2 -> (forall x:A, R B (f1 x) (f2 x)) -> R B (bind m1 f1) (bind m2 f2)).

  Let MR := to_rel M1 M2 R.
  Record rel_val (c:ctype) :=
    MkRelVal { fst : to_type M1 c ; snd : to_type M2 c ; rel : MR c fst snd }.

  Definition icterm_to_rel_witness {Γ c} (ct:icterm Γ c) :
    forall σ : substitution rel_val Γ,
      to_rel M1 M2 R c ⦑ ct | map_subst fst σ |M1⦒ ⦑ ct | map_subst snd σ |M2⦒.
  Proof.
    induction ct ; simpl.
    - intros ? ; apply Runit.
    - intros σ ; apply Rbind ; [ apply IHct2 | apply IHct1 ].
    - intro σ ; constructor; [apply IHct1| apply IHct2].
    - intro σ; destruct c ; destruct H ; exact (nfst (IHct σ)).
    - intro σ; destruct c ; destruct H ; exact (nsnd (IHct σ)).
    - intros σ x ; apply (X x).
    - intro σ.
      destruct c ; destruct H ; apply (IHct σ).
    - intros σ ; rewrite /map_subst ;
        erewrite 2!Substitution.dlookup_dmap ;
          apply rel.
    - intros σ x1 x2 r.
      apply (IHct (ConsSubst (MkRelVal c1 x1 x2 r) σ)).
    - intros σ; destruct c ; destruct H ; apply IHct1; apply IHct2.
  Defined.

End ICTermToRel.

(** Functional interpretation of terms
    (in the special case where our types are covariant) *)

Section ICTermToFunction.
  Context (M1 M2 : Monad).
  Context (F : forall A, M1 A -> M2 A).
  Context (Funit : forall A (x:A), F A (ret x) = (ret x)).
  Context (Fbind : forall A B (m : M1 A) (f : A -> M1 B),
              F B (bind m f) = bind (F A m) (fun x => F B (f x))).

  Let R := fun A (m1 : M1 A) (m2: M2 A) => F A m1 = m2.
  Let MF := to_function M1 M2 F.
  Let val_cov (c:ctype) :=to_type M1 c × covariant c.

  Definition val_cov_to_rel_val (c:ctype) (p : val_cov c) : rel_val M1 M2 R c
    := MkRelVal M1 M2 R c (nfst p) (MF c (nsnd p) (nfst p))
                (to_function_to_rel M1 M2 F c (nsnd p) _ _ eq_refl).

  Import FunctionalExtensionality.

  Program Definition icterm_to_fun_witness {Γ c} (ct:icterm Γ c) (Hcov : covariant c)  :=
    fun (σ : substitution val_cov Γ) =>
      let ρ := map_subst val_cov_to_rel_val σ in
      to_rel_to_function M1 M2 F c Hcov _ _ (icterm_to_rel_witness M1 M2 R (Funit) _ ct ρ).
  Next Obligation.
    assert ((fun x => F _ (f1 x)) = f2) as <- by (extensionality x ; apply H0).
    apply Fbind.
  Qed.

  Eval cbn in icterm_to_fun_witness.

  (* TODO : give the following type to icterm_to_fun_witness *)
    (* forall (σ : substitution val_cov Γ), *)
    (*   MF c Hcov ⦑ ct [map_subst (fun c => nfst) σ] |M1⦒ = *)
    (*   ⦑ ct [map_subst (fun c p => MF c (nsnd p) (nfst p)) σ] |M2⦒. *)

End ICTermToFunction.

(******************************************************************************)
(**                                                                           *)
(**              Algebra structure on the denotation                          *)
(**                                                                           *)
(******************************************************************************)

(** Special case for the algebra structure on the dependent product
    that was not given in general *)
Set Primitive Projections.

Section AlgStruct.
  Context (M:Monad).
  Record AlgStruct A :=
    mkAlgStruct
      { algstr_map :> M A -> A
      ; algstr_ret : forall a, algstr_map (monad_ret M a) = a
      ; algstr_bind : forall X (m : M X) f,
          algstr_map (monad_bind m (fun x => monad_ret _ (algstr_map (f x)))) = algstr_map (monad_bind m f)
      }.

  Definition homomorphism {A B}
           (αA : AlgStruct A) (αB : AlgStruct B) (f : A -> B) :=
    forall m, f (αA m) = αB (f <$> m).

  Lemma homormorphism_comp {A B C} (HA : AlgStruct A) (HB : AlgStruct B) (HC : AlgStruct C) (f : A -> B) (g: B -> C) (Hf : homomorphism HA HB f) (Hg : homomorphism HB HC g) : homomorphism HA HC (fun x => g (f x)).
  Proof. move=> m ; rewrite Hf Hg map_functorial //. Qed.

  Lemma homomorphism_id {A} (HA:AlgStruct A) : homomorphism HA HA id.
  Proof. move=> m ; rewrite map_id //. Qed.
End AlgStruct.

Section FreeAlgStruct.
  Context (M:Monad).
  Import FunctionalExtensionality.
  Program Definition freeAlgStruct A : AlgStruct M (M A) :=
    mkAlgStruct _ _ (fun mm => bind mm id) _ _.
  Next Obligation. cbv ; rewrite monad_law1 ; reflexivity. Qed.
  Next Obligation.
    cbv. rewrite !monad_law3.
    f_equal ; extensionality x. rewrite monad_law1 ; reflexivity.
  Qed.

  Section Homomorphism.
    Context {A B} (αB : AlgStruct M B) (f: A -> B).
    Definition free_extension (m:M A) : B := αB (f <$> m).
    Lemma free_extension_homomorphism :
      homomorphism M (freeAlgStruct A) αB free_extension.
    Proof.
      move=> m /=. rewrite /free_extension /map /bind monad_law3 algstr_bind //.
    Qed.
  End Homomorphism.
End FreeAlgStruct.

Section NProductAlgStruct.
  Context M A B (HA : AlgStruct M A) (HB : AlgStruct M B).
  Import FunctionalExtensionality.

  Program Definition nprodAlgStruct : AlgStruct M (A × B) :=
    mkAlgStruct _ _ (fun m => npair (HA (nfst <$> m)) (HB (nsnd <$> m))) _ _.
  Next Obligation.
    cbv ; destruct a ; f_equal ; rewrite monad_law1 ; rewrite algstr_ret ; reflexivity.
  Qed.

  Next Obligation.
   f_equal ;
   cbv ; rewrite !monad_law3 ;
    match goal with
    | [|- _ = ?t ] =>
      match t with
      | context c [monad_bind m ?f] => rewrite <- (algstr_bind _ _ _ _ _ f)
      end
    end ;
    do 2 f_equal ; extensionality x ; rewrite monad_law1 ; reflexivity.
  Qed.

  Lemma proj1_homomorphism : homomorphism M nprodAlgStruct HA nfst.
  Proof.
    move=> m ; rewrite /nprodAlgStruct //.
  Qed.

  Lemma proj2_homomorphism : homomorphism M nprodAlgStruct HB nsnd.
  Proof.
    move=> m ; rewrite /nprodAlgStruct //.
  Qed.

  Section PairingHomomorphism.
    Context {C} (HC : AlgStruct M C) (fA : C -> A) (fB : C -> B)
            (HfA : homomorphism M HC HA fA)
            (HfB : homomorphism M HC HB fB).
    Definition pairing (c:C) : A × B := ⟨fA c, fB c⟩.
    Lemma pairing_homomorphism : homomorphism M HC nprodAlgStruct pairing.
    Proof.
      move=> m. rewrite /pairing /nprodAlgStruct /= 2!map_functorial HfA HfB //.
    Qed.
  End PairingHomomorphism.

End NProductAlgStruct.

Section DependentProductAlgebra.
  Context (M:Monad) A B (HB : forall a:A, AlgStruct M (B a)).

  Import FunctionalExtensionality.
  Program Definition DepProdAlg : AlgStruct M (forall a, B a) :=
    mkAlgStruct _ _ (fun m x => HB x (bind m (fun f => ret (f x)))) _ _.
  Next Obligation.
    intros ; simpl; extensionality x.
    cbv ; rewrite monad_law1. rewrite algstr_ret. reflexivity.
  Qed.
  Next Obligation.
    intros ; extensionality a.
    cbv; rewrite !monad_law3.
    match goal with
    | [|- _ = ?t ] =>
      match t with
      | context c [monad_bind m ?f] => rewrite <- (algstr_bind _ _ _ _ _ f)
      end
    end.
    f_equal. f_equal. extensionality x.
    cbv. rewrite monad_law1. reflexivity.
  Qed.

  Section EvalHomomorphism.
    Context (a:A).
    Definition eval (f:forall a, B a) : B a := f a.
    Lemma eval_homorphism : homomorphism M DepProdAlg (HB a) eval.
    Proof. move=> ? //. Qed.
  End EvalHomomorphism.

  Section AbsHomomorphism.
    Context {C} (HC : AlgStruct M C) (f : forall a, C -> B a)
            (Hf : forall a, homomorphism M HC (HB a) (f a)).
    Lemma abs_homomorphism : homomorphism M HC DepProdAlg (fun c a => f a c).
    Proof.
      move=> x ; rewrite /homomorphism /DepProdAlg /= ;
              extensionality a; rewrite (Hf a) /map /bind monad_law3.
      do 2 f_equal ; extensionality a0 ; rewrite monad_law1 //.
    Qed.
  End AbsHomomorphism.

End DependentProductAlgebra.

(** Algebra structure on the denotation *)

Section ToAlgebra.
  Context (M:Monad) (c : ctype).

  Definition ctype_alg : AlgStruct M ⦑ c  |M⦒.
  Proof.
    induction c as [A| c1 IHc1 c2 IHc2 | |].
    apply freeAlgStruct.
    apply (nprodAlgStruct _ _ _ IHc1 IHc2).
    apply (DepProdAlg _ _ _ X).
    apply (DepProdAlg _ _ _ (fun _ => IHc0_2)).
  Defined.

End ToAlgebra.


Require Import String.
From AC Require Import nvalue.
Require Import PeanoNat.
Require Import List.

Inductive value_tree: Type :=
| empty : list value_tree -> value_tree
| some (B:Type) (A:nvalue B): list value_tree  -> value_tree.

Definition extract_l (v:value_tree) : list value_tree:=
match v with
| empty l => l
| some _ _ l => l
end.

(*return empty value_tree if pos dowsn't exists*)
Fixpoint pi (pos:nat) (v:value_tree): value_tree :=
let ll := extract_l v in
match pos , ll with
| (S n) ,(cons _ l) => pi n (empty l)
| 0 , (cons vt _) => vt
| (S n) , (nill) => empty nill
| 0 , (nill) => empty nill
end.

Inductive value_tree_env: Type :=
| vt_el (id:nat) (v1:value_tree) : value_tree_env -> value_tree_env
| vt_end : value_tree_env.

Fixpoint pi_env (pos:nat) (v_env:value_tree_env): value_tree_env :=
match v_env with
| (vt_end) => vt_end
| (vt_el id vt vt_next) => vt_el id (pi pos vt) (pi_env pos vt_next)
end.


(** Theory of Flow Interface *)

(* This formalization builds on the paper:

   Local Reasoning for Global Graph Properties: Siddharth Krishna and Alexander J. Summers and Thomas Wies, ESOP'20.
*)

(*From iris.heap_lang Require Import proofmode.*)
Require Export VST.veric.bi.
Require Import VST.concurrency.ghosts.

From stdpp Require Export gmap.
From stdpp Require Import mapset finite.
From bst Require Export ccm gmap_more.
Require Import Coq.Setoids.Setoid.
Require Import bst.sepalg_ext.

Class Valid (A : Type) := valid : A → Prop.
#[global] Hint Mode Valid ! : typeclass_instances.
Instance: Params (@valid) 2 := {}.
Notation "✓ x" := (valid x) (at level 20) : stdpp_scope.

(* The set of nodes over which graphs are built. *)
(* Definition Node := nat. *)

Section flowint.

  Context `{HC: Countable Node}.

  (* The underlying flow domain. *)
  Context `{CCM flowdom}.

  Open Scope ccm_scope.

  (* Representation of flow interfaces:

     - The domain of the interface is the domain of its inflow infR.

     - The outflow function is defined using nzmap so that interface
       composition is cancelable.*)

  Record flowintR := {
    infR : gmap Node flowdom;
    outR : nzmap Node flowdom; }.

  (* The empty interface *)
  Definition I_emptyR := {| infR := ∅; outR := ∅ |}.
  Global Instance flowint_empty : Empty flowintR := I_emptyR.

  Definition inf (I: flowintR) (n: Node) := default 0 (infR I !! n).
  Definition out (I: flowintR) (n: Node) := outR I ! n.

  Global Instance flowint_dom : Dom flowintR (gset Node) :=
    λ I, dom (gset Node) (infR I).
  Definition domm (I : flowintR) := dom (gset Node) I.

  Global Instance flowint_elem_of : ElemOf Node flowintR := λ n I, n ∈ domm I.

  (* Some useful implicit type classes *)

  Canonical Structure flowintRAC := leibnizO flowintR.

  Global Instance int_eq_dec: EqDecision flowintR.
  Proof.
    unfold EqDecision.
    unfold Decision.
    repeat decide equality.
    - apply nzmap_eq_eq.
    - apply gmap_eq_eq.
  Qed.

  (** Interface validity *)

  Global Instance flowint_valid : Valid flowintR :=
    λ Ir, infR Ir ##ₘ nzmap_car (outR Ir) ∧ (infR Ir = ∅ → outR Ir = ∅).

  Global Instance flowint_valid_dec : ∀ I: flowintR, Decision (✓ I).
  Proof.
    intros.
    unfold valid; unfold flowint_valid.
    destruct I.
    all: solve_decision.
  Qed.

  (** Predicate that holds true iff two interfaces are composable *)

  Definition intComposable (I1: flowintR) (I2: flowintR) :=
    ✓ I1 ∧ ✓ I2 ∧
    domm I1 ## domm I2 ∧
    map_Forall (λ (n: Node) (m: flowdom), m = out I2 n +
                                              (inf I1 n - out I2 n)) (infR I1) ∧
    map_Forall (λ (n: Node) (m: flowdom), m = out I1 n +
                                              (inf I2 n - out I1 n)) (infR I2).

  Global Instance intComposable_dec (I1 I2: flowintR) : Decision (intComposable I1 I2).
  Proof. solve_decision. Qed.

  (** Interface composition *)

  (* Function to compute outflow of composite interface *)
  Definition outComp_op I1 I2 n (m1 m2 : flowdom) :=
    if decide (n ∈ domm I1 ∪ domm I2) then 0 else m1 + m2.

  Global Instance outComp_unit_id : ∀ n I1 I2, UnitId _ _ (outComp_op I1 I2 n).
  Proof.
    intros.
    unfold UnitId, outComp_op.
    destruct (decide _).
    all: auto using ccm_right_id.
  Qed.

  Definition outComp I1 I2 :=
    nzmap_imerge (outComp_op I1 I2) (outR I1) (outR I2).

  Lemma outComp_inv I1 I2 :
    ∀ n, n ∉ domm I1 ∪ domm I2 → outComp I1 I2 ! n = out I1 n + out I2 n.
  Proof.
    intros n D.
    unfold outComp.
    rewrite nzmap_lookup_imerge.
    unfold outComp_op.
    destruct (decide _).
    - contradiction.
    - unfold out.
      reflexivity.
  Qed.

  (* Function to compute inflow of composite interface *)
  Definition infComp_op I1 I2 n (o1 o2 : option flowdom) :=
    match o1, o2 with
    | Some m1, _ => Some (m1 - out I2 n)
    | _, Some m2 => Some (m2 - out I1 n)
    | _, _ => None
    end.

  Lemma infComp_diag_none : ∀ I1 I2 n,
      infComp_op I1 I2 n None None = None.
  Proof.
    intros.
    unfold infComp_op.
    auto.
  Qed.

  Definition infComp I1 I2 := gmap_imerge (infComp_op I1 I2) (infR I1) (infR I2).

  Definition intComp (I1 I2: flowintR): option flowintR :=
    if decide (intComposable I1 I2) then
      Some {| infR := infComp I1 I2 ; outR := outComp I1 I2 |}
    else if decide (I1 = ∅) then Some I2
         else if decide (I2 = ∅) then Some I1
              else None.

  Global Instance intJoin: sepalg.Join flowintR :=
    λ I1 I2 I3, intComp I1 I2 = Some I3.

  (** Assorted auxiliary lemmas. These are used, in particular, to
  prove that flow interfaces form a ghost. *)

  (* The empty interface has no outflow. *)
  Lemma intEmp_out : ∀ n, out I_emptyR n = 0.
  Proof.
    intros.
    unfold out, I_emptyR.
    simpl.
    apply nzmap_lookup_empty.
  Qed.

  (* Valid interfaces don't give outflow to nodes in their domain. *)
  Lemma intValid_in_dom_not_out : ∀ I n, ✓ I → n ∈ domm I → out I n = 0.
  Proof.
    intros ? ? V D.
    unfold valid, flowint_valid in V.
    destruct V as (Disj & _).
    assert (dom (gset Node) (infR I) ## dom (gset Node) (nzmap_car (outR I))). {
      apply map_disjoint_dom. trivial. }
    unfold domm, dom, flowint_dom in D.
    assert (n ∉ dom (gset Node) (outR I)). {
      unfold dom, nzmap_dom.
      set_solver. }
    rewrite nzmap_elem_of_dom_total in H1 *.
    intros.
    apply dec_stable in H1.
    trivial.
  Qed.

  (* The empty interface is valid. *)
  Lemma intEmp_valid : ✓ I_emptyR.
  Proof.
    unfold valid.
    unfold flowint_valid.
    simpl.
    split.
    refine (map_disjoint_empty_l _).
    trivial.
  Qed.

  (* The empty interface is the unique valid interface whose domain is empty. *)
  Lemma intEmp_unique I : ✓ I → domm I ≡ ∅ → I = ∅.
  Proof.
    intros V D.
    unfold valid, flowint_valid in V.
    destruct V as (? & V).
    unfold domm, dom, flowint_dom in D.
    unfold empty, flowint_empty.
    unfold I_emptyR.
    destruct I as [Iinf Iout].
    simpl in V.
    simpl in D.
    apply (dom_empty_inv Iinf) in D.
    pose proof (V D) as O.
    rewrite D.
    rewrite O.
    reflexivity.
  Qed.

  Lemma intEmp_domm: domm ∅ = ∅.
  Proof.
    unfold empty at 1. unfold flowint_empty. unfold I_emptyR.
    unfold domm, dom, flowint_dom. simpl. apply dom_empty_L.
  Qed.

  (* Invalid interfaces are not composable. *)
  Lemma intComposable_invalid : ∀ I1 I2, ¬ ✓ I1 → ¬ (intComposable I1 I2).
  Proof.
    intros.
    unfold intComposable.
    unfold not.
    intros H_false.
    destruct H_false as [H_false _].
    now contradict H_false.
  Qed.

  (* Composing with an invalid interface yields an invalid interface. *)
  Lemma intJoin_invalid : ∀ I1 I2 I3: flowintR,
      intJoin I1 I2 I3 -> ¬ ✓ I1 → ¬ ✓ I3.
  Proof.
    intros.
    unfold intJoin, intComp in H0.
    rewrite decide_False in H0; last by apply intComposable_invalid.
    rewrite decide_False in H0; last first.
    - unfold not. intros H_false.
      contradict H1. rewrite H_false. apply intEmp_valid.
    - destruct (decide (I2 = ∅)); inversion H0. now subst.
  Qed.

  (* The empty interface is the right identity of interface composition. *)
  Lemma intJoin_unit : ∀ (I: flowintR), intJoin I I_emptyR I.
  Proof.
    intros.
    unfold intJoin, intComp, outComp.
    simpl.
    destruct (decide (intComposable I I_emptyR)).
    - (* True *)
      unfold infComp.
      rewrite gmap_imerge_empty.
      + f_equal.
        destruct I.
        f_equal.
        apply nzmap_eq.
        intros.
        rewrite nzmap_lookup_imerge.
        unfold outComp_op.
        destruct (decide _).
        * unfold domm in e.
          rewrite elem_of_union in e *.
          intros.
          destruct e.
          -- unfold intComposable in i.
             destruct i as (V & _).
             unfold valid, flowint_valid in V.
             destruct V as (V & _).
             simpl in V.
             assert (dom (gset Node) infR0 ## dom (gset Node) (nzmap_car outR0)). {
               rewrite <- map_disjoint_dom. trivial. }
             unfold flowint_dom in H0.
             simpl in H0.
             unfold nzmap_total_lookup.
             destruct (outR0 !! k) eqn:?.
             ++ assert (k ∈ dom (gset Node) outR0). {
                  unfold dom, nzmap_dom.
                  rewrite elem_of_dom.
                  unfold is_Some.
                  exists f.
                  unfold lookup, nzmap_lookup in Heqo.
                  destruct outR0.
                  simpl.
                  trivial. }
                assert (k ∉ dom (gset Node) outR0). {
                  set_solver. }
                contradiction.
             ++ trivial.
          -- unfold dom, flowint_dom, I_emptyR in H0. simpl in H0.
             rewrite dom_empty in H0 *.
             intros.
             rewrite elem_of_empty in H0 *.
             naive_solver.
        * rewrite nzmap_lookup_empty.
          rewrite ccm_right_id. auto.
      + intros.
        case y.
        * intros.
          unfold infComp_op.
          rewrite intEmp_out.
            by rewrite ccm_pinv_unit.
        * auto.
    - (* False *)
      destruct (decide _).
      unfold empty, flowint_empty in e.
      rewrite e.
      reflexivity.
      destruct (decide _).
      reflexivity.
      unfold empty, flowint_empty in n1.
      contradiction.
  Qed.

  (* The intComposable predicate is commutative. *)
  Lemma intComposable_comm_1 : ∀ (I1 I2 : flowintR),
      intComposable I1 I2 → intComposable I2 I1.
  Proof.
    intros.
    unfold intComposable.
    repeat split.
    5: apply disjoint_intersection; rewrite intersection_comm_L;
      apply disjoint_intersection.
    unfold intComposable in H0.
    all: try apply H0.
  Qed.

  Lemma intComposable_comm : ∀ (I1 I2 : flowintR),
      intComposable I1 I2 ↔ intComposable I2 I1.
  Proof.
    intros. split. all: refine (intComposable_comm_1 _ _).
  Qed.

  (* The domain of a composite interface is the union of the domain of
  its component interfaces. *)

  Lemma infComp_dom : ∀ I1 I2, dom (gset Node) (infComp I1 I2) = domm I1 ∪ domm I2.
  Proof.
    intros.
    unfold domm.
    set_unfold.
    intros.
    rewrite ?elem_of_dom.
    unfold infComp.
    rewrite gmap_imerge_prf.
    unfold dom, flowint_dom.
    repeat rewrite elem_of_dom.
    unfold infComp_op.
    case_eq (infR I1 !! x).
    + intros ? H1.
      (*rewrite H1.*)
      rewrite ?is_Some_alt; simpl.
      naive_solver.
    + intros H1.
      (*rewrite H1.*)
      case_eq (infR I2 !! x).
      * intros ? H2.
        (*rewrite H2.*)
        rewrite ?is_Some_alt; simpl.
        naive_solver.
      * intros H2.
        (*rewrite H2.*)
        split.
        apply or_introl.
        intros.
        destruct H.
        all: clear - H0; firstorder.
    + intros. apply infComp_diag_none.
  Qed.

  Lemma intJoin_dom : ∀ I1 I2 I3,
      intJoin I1 I2 I3 -> ✓ I3 → domm I3 = domm I1 ∪ domm I2.
  Proof.
    intros I1 I2 I3 Hi H_valid.
    unfold intJoin, intComp in Hi.
    destruct (decide (intComposable I1 I2)).
    - inversion Hi. subst I3. clear Hi.
      unfold domm at 1, dom, flowint_dom. simpl.
        by rewrite infComp_dom.
    - unfold domm.
      set_unfold.
      intros.
      unfold dom.
      rewrite ?elem_of_dom.
      destruct (decide (I1 = ∅)).
      + inversion Hi. subst I3. clear Hi. subst I1.
        simpl.
        rewrite lookup_empty.
        split; intros.
        * now apply or_intror.
        * destruct H0 as [H_false | H2]; [|easy].
          contradict H_false. exact is_Some_None.
      + destruct (decide (I2 = ∅)).
        * inversion Hi. subst I3 I2. clear Hi. simpl.
          rewrite lookup_empty.
          split; intros.
          -- now apply or_introl.
          -- destruct H0; [easy|].
             contradict H0. exact is_Some_None.
        * inversion Hi.
  Qed.

  (* Interface composition is commutative. *)
  Lemma intJoin_comm : ∀ (I1 I2 I3: flowintR), intJoin I1 I2 I3 -> intJoin I2 I1 I3.
  Proof.
    intros.
    unfold intJoin, intComp, infComp, outComp in *.
    destruct (decide (intComposable I1 I2)) as [H_comp | H_not_comp].
    - (* if composable *)
      inversion H0. subst I3. clear H0.
      rewrite decide_True; last rewrite intComposable_comm; auto.
      f_equal.
      f_equal.
      + (* infR equality *)
        rewrite map_eq_iff.
        intros.
        repeat rewrite gmap_imerge_prf; auto.
        case_eq (infR I1 !! i).
        all: case_eq (infR I2 !! i).
        * (* i in both *)
          intros f1 H_lookup2 f2 H_lookup1.
          exfalso.
          generalize H_comp.
          unfold intComposable.
          intros (_ & _ & H_false & _).
          unfold domm, dom, flowint_dom in H_false.
          simpl in *.
          rewrite <- map_disjoint_dom in H_false.
          generalize H_false. clear H_false.
          rewrite map_disjoint_alt.
          intros H_false.
          assert (H_contra := H_false i).
          destruct H_contra.
          contradict H0.
          now rewrite H_lookup1.
          contradict H0.
          now rewrite H_lookup2.
        * (* in I1 but not in I2 *)
          intros H_lookup2 f1 H_lookup1.
          (*rewrite H_lookup1. rewrite H_lookup2.*)
          auto.
        * (* in I2 but not in I1 *)
          intros f2 H_lookup2 H_lookup1.
          (*rewrite H_lookup1. rewrite H_lookup2.*)
          auto.
        * (* in neither *)
          intros H_lookup2 H_lookup1.
          (*rewrite H_lookup1. rewrite H_lookup2.*)
          auto.
      + (* outR equality *)
        apply nzmap_eq.
        intros.
        repeat rewrite nzmap_lookup_imerge.
        unfold outComp_op.
        pose proof (union_comm (domm I1) (domm I2)).
        repeat destruct (decide (k ∈ _)); try auto;
          try (rewrite H0 in e *; naive_solver).
        try (rewrite H0 in n *; naive_solver).
          by rewrite ccm_comm.
    - (* if not composable *)
      rewrite decide_False; last by rewrite intComposable_comm.
      rewrite <- H0.
      case_eq (decide (I2 = ∅)).
      case_eq (decide (I1 = ∅)).
      all: auto.
      intros.
      now rewrite e e0.
  Qed.

  (* The empty interface is also a left identity of interface composition. *)
  Lemma intJoin_left_unit : ∀ I : flowintR, intJoin I_emptyR I I.
  Proof.
    intros.
    apply intJoin_comm.
    now apply intJoin_unit.
  Qed.

  (* The components of valid composite interfaces are valid. *)
  Lemma intJoin_valid_proj1 : ∀ (I1 I2 I3: flowintR),
      intJoin I1 I2 I3 -> ✓ I3 → ✓ I1.
  Proof.
    intros I1 I2 I3 ?.
    rewrite <- Decidable.contrapositive.
    intros. apply intJoin_invalid in H0; auto.
    unfold Decidable.decidable.
    generalize (flowint_valid_dec I1).
    unfold Decision.
    intros.
    destruct H1.
    all: auto.
  Qed.

  Lemma intJoin_valid_proj2 : ∀ (I1 I2 I3: flowintR),
      intJoin I1 I2 I3 -> ✓ I3 → ✓ I2.
  Proof.
    intros I1 I2 I3 ?.
    apply intJoin_comm in H0.
    intros; now apply intJoin_valid_proj1 in H0.
  Qed.

  (* If a composite interface is empty then its components must have been empty. *)
  Lemma intJoin_positive_1 : ∀ (I1 I2: flowintR), intJoin I1 I2 ∅ → I1 = ∅.
  Proof.
    intros ? ? C.
    pose proof intEmp_valid as V.
    unfold empty, flowint_empty in C.
    pose proof (intJoin_valid_proj1 _ _ _ C V) as V1.
    pose proof (intJoin_valid_proj2 _ _ _ C V) as V2.
    assert (infR I1 = ∅) as D1. {
      apply map_eq.
      intros n.
      unfold intJoin, intComp in C.
      destruct (decide (intComposable I1 I2)).
      - inversion C.
        assert (infComp I1 I2 !! n = infR I_emptyR !! n) as CL. {
          rewrite H1. now simpl. } simpl in CL.
        rewrite gmap_imerge_prf in CL.
        + rewrite H1 lookup_empty.
          rewrite lookup_empty in CL.
          destruct (infR I1 !! n);
            destruct (infR I2 !! n);
            inversion CL.
          reflexivity.
        + intros. apply infComp_diag_none.
      - destruct (decide (I1 = ∅)).
        + rewrite e.
          unfold empty at 1, flowint_empty, I_emptyR.
          simpl. reflexivity.
        + destruct (decide (I2 = ∅)).
          * unfold empty, flowint_empty in n1.
            exfalso. apply n1. now inversion C.
          * inversion C. }
    assert (domm I1 ≡ ∅).
    unfold domm, dom, flowint_dom.
    rewrite D1.
    rewrite dom_empty.
    reflexivity.
    pose proof (intEmp_unique _ V1 H0).
    trivial.
  Qed.

  Lemma intJoin_positive_2 : ∀ (I1 I2: flowintR), intJoin I1 I2 ∅ → I2 = ∅.
  Proof.
    intros ? ? C.
    apply intJoin_comm in C.
    now apply intJoin_positive_1 in C.
  Qed.

  (* The empty interface is composable with any valid interface. *)
  Lemma intComposable_empty : ∀ I: flowintR, ✓ I → intComposable ∅ I.
  Proof.
    intros I IV.
    unfold intComposable. destruct IV.
    repeat split; auto.
    - unfold domm, dom, flowint_dom, empty, flowint_empty, I_emptyR. simpl.
      rewrite dom_empty.
      apply disjoint_empty_l.
    - unfold map_Forall.
      intros n x.
      unfold empty, flowint_empty, I_emptyR. simpl.
      rewrite lookup_empty.
      intros.
      inversion H2.
    - unfold map_Forall.
      intros n x.
      intros.
      unfold out, empty, flowint_empty, I_emptyR. simpl.
      rewrite nzmap_lookup_empty.
      rewrite ccm_left_id.
      rewrite ccm_pinv_unit.
      unfold inf.
      rewrite H2.
      auto.
  Qed.

  (* The components of valid composite interfaces are composable. *)
  Lemma intComposable_valid : ∀ (I1 I2 I3: flowintR),
      intJoin I1 I2 I3 -> ✓ I3 → intComposable I1 I2.
  Proof.
    intros I1 I2 I3 Hj IV.
    pose proof (intJoin_valid_proj1 I1 I2 _ Hj IV) as I1V.
    pose proof (intJoin_valid_proj2 I1 I2 _ Hj IV) as I2V.
    unfold intJoin, intComp in Hj.
    destruct (decide (intComposable I1 I2)). 1: trivial.
    destruct (decide (I1 = ∅)).
    - subst I1. now apply intComposable_empty.
    - destruct (decide (I2 = ∅)).
      + subst I2. rewrite intComposable_comm. now apply intComposable_empty.
      + inversion Hj.
  Qed.

  (* The composition of composable interfaces is valid. *)
  Lemma intValid_composable : ∀ (I1 I2 I3: flowintR),
      intJoin I1 I2 I3 -> intComposable I1 I2 → ✓ I3.
  Proof.
    intros ? ? ? Hj V.
    unfold intJoin, intComp in Hj.
    destruct (decide (intComposable I1 I2)).
    - unfold valid, flowint_valid. inversion Hj. subst I3. clear Hj.
      simpl. split.
      + assert (dom (gset Node) (infComp I1 I2) ##
                    dom (gset Node) (nzmap_car (outComp I1 I2))). {
          apply elem_of_disjoint.
          intros n Hin Hout.
          rewrite infComp_dom in Hin.
          rewrite nzmap_elem_of_dom_total in Hout *.
          unfold outComp in Hout.
          rewrite nzmap_lookup_imerge in Hout.
          unfold outComp_op in Hout.
          destruct (decide _).
          all: contradiction. }
        apply map_disjoint_dom in H0. trivial.
      + intros.
        assert (dom (gset Node) (infComp I1 I2) ≡
                    dom (gset Node) (∅ : gmap Node flowdom)).
        rewrite H0. auto.
        apply nzmap_eq.
        intros n.
        unfold outComp.
        rewrite nzmap_lookup_imerge.
        unfold outComp_op.
        rewrite nzmap_lookup_empty.
        rewrite infComp_dom in H1.
        rewrite dom_empty in H1 *.
        intros.
        destruct (decide _). auto.
        assert (domm I1 ≡ ∅) by set_solver.
        assert (domm I2 ≡ ∅) by set_solver.
        destruct V as (V1 & V2 & _).
        unfold valid, flowint_valid in V1,V2.
        destruct V1 as (_ & E1).
        destruct V2 as (_ & E2).
        unfold domm, dom, flowint_dom in H2, H3.
        apply dom_empty_inv in H2.
        apply dom_empty_inv in H3.
        apply E1 in H2.
        apply E2 in H3.
        rewrite H2.
        rewrite H3.
        rewrite nzmap_lookup_empty.
          by rewrite ccm_right_id.
    - contradiction.
  Qed.

  (* Characterization of inflows of composite interfaces. *)
  Lemma intJoin_unfold_inf_1 : ∀ (I1 I2 I3: flowintR),
      intJoin I1 I2 I3 -> ✓ I3 →
      ∀ n, n ∈ domm I1 → inf I1 n = inf I3 n + out I2 n.
  Proof.
    intros I1 I2 I3 Hj V n D.
    unfold domm, dom, flowint_dom in D.
    apply elem_of_dom in D.
    unfold is_Some in D.
    destruct D as [x D].
    pose proof (intComposable_valid I1 I2 _ Hj V).
    assert (IC := H0).
    unfold intComposable in H0.
    destruct H0 as (I1v & I2v & Disjoint & I1inf & I2inf).
    unfold map_Forall in I1inf.
    pose proof (I1inf n (inf I1 n)).
    unfold inf in H0.
    rewrite D in H0.
    unfold default, id in H0.
    assert (Some x = Some x) by reflexivity.
    apply H0 in H1.
    unfold valid, flowint_valid in V.
    unfold intJoin, intComp in Hj.
    destruct (decide (intComposable I1 I2)).
    - unfold inf. inversion Hj. simpl.
      rewrite gmap_imerge_prf.
      + rewrite D.
        unfold default, id.
        rewrite ccm_comm in H1.
        trivial.
      + intros. apply infComp_diag_none.
    - contradiction.
  Qed.

  Lemma intJoin_unfold_inf_2 : ∀ (I1 I2 I3: flowintR),
      intJoin I1 I2 I3 -> ✓ I3 →
      ∀ n, n ∈ domm I2 → inf I2 n = inf I3 n + out I1 n.
  Proof.
    intros.
    apply intJoin_comm in H0.
    now apply intJoin_unfold_inf_1.
  Qed.

  (* Characterization of outflow of composed interfaces. *)
  Lemma intJoin_unfold_out I1 I2 I3:
    intJoin I1 I2 I3 -> ✓ I3 → (∀ n, n ∉ domm I3 → out I3 n = out I1 n + out I2 n).
  Proof.
    intros Hj ? ? ?.
    apply (intJoin_dom _ _ _ Hj) in H0 as D.
    rewrite D in H1.
    pose proof (outComp_inv I1 I2 n H1).
    apply (intComposable_valid _ _ _ Hj) in H0.
    unfold intJoin, intComp in Hj.
    unfold out at 1.
    destruct (decide (intComposable I1 I2)); last first. 1: contradiction.
    inversion Hj. simpl.
    trivial.
  Qed.

  (* Characterization of inflow of composed interfaces. *)
  Lemma intJoin_inf_1 I1 I2 I3:
    intJoin I1 I2 I3 -> ✓ I3 →
    (∀ n, n ∈ domm I1 → inf I3 n = inf I1 n - out I2 n).
  Proof.
    intros Hj V n D.
    apply (intComposable_valid _ _ _ Hj) in V.
    unfold intJoin, intComp in Hj.
    destruct (decide (intComposable I1 I2)); last first. 1: contradiction.
    inversion Hj. subst I3. clear Hj.
    unfold inf at 1.
    simpl.
    rewrite gmap_imerge_prf. 2: apply infComp_diag_none.
    unfold domm, dom, flowint_dom in D.
    apply elem_of_dom in D.
    unfold is_Some in D.
    destruct D as [x D].
    unfold inf at 1.
    rewrite D.
    simpl.
    reflexivity.
  Qed.

  Lemma intJoin_inf_2 I1 I2 I3:
    intJoin I1 I2 I3 -> ✓ I3 →
    (∀ n, n ∈ domm I2 → inf I3 n = inf I2 n - out I1 n).
  Proof.
    intros Hj. intros.
    apply intJoin_comm in Hj.
    generalize H1.
    generalize n.
    now apply intJoin_inf_1.
  Qed.

  (* Characterization of interface composition as defined in ESOP'20. *)
  Lemma intJoin_fold I1 I2 I :
    ✓ I1 → ✓ I2 →
    domm I1 ## domm I2 →
    domm I = domm I1 ∪ domm I2 →
    (∀ n, n ∈ domm I1 → inf I1 n = out I2 n + inf I n) →
    (∀ n, n ∈ domm I2 → inf I2 n = out I1 n + inf I n) →
    outR I = outComp I1 I2 →
    intJoin I1 I2 I ∧ ✓ I.
  Proof.
    intros V1 V2 Disj D Inf1 Inf2 Out.
    assert (intComposable I1 I2) as C.
    { unfold intComposable.
      split; [|split; [|split; [|split]]]; try trivial.
      - unfold map_Forall.
        intros n x xDef.
        unfold domm, dom, flowint_dom in Inf1.
        pose proof (Inf1 n).
        rewrite elem_of_dom in H0 *.
        apply mk_is_Some in xDef as H1.
        apply H0 in H1.
        rewrite H1.
        rewrite (ccm_comm _ (inf I n)).
        rewrite ccm_pinv.
        unfold inf at 1 in H1.
        rewrite xDef in H1.
        simpl in H1.
        rewrite H1.
        reflexivity.
      - unfold map_Forall.
        intros n x xDef.
        unfold domm, dom, flowint_dom in Inf2.
        pose proof (Inf2 n).
        rewrite elem_of_dom in H0 *.
        apply mk_is_Some in xDef as H1.
        apply H0 in H1.
        rewrite H1.
        rewrite (ccm_comm _ (inf I n)).
        rewrite ccm_pinv.
        unfold inf at 1 in H1.
        rewrite xDef in H1.
        simpl in H1.
        rewrite H1.
        reflexivity.
    }
    cut (intJoin I1 I2 I). {
      intros; split; auto.
      now apply (intValid_composable _ _ _ H0) in C. }
    unfold intJoin, intComp, infComp, infComp_op.
    destruct (decide (intComposable I1 I2)).
    - f_equal.
      case_eq I.
      intros.
      f_equal.
      + apply map_eq.
        intros n.
        rewrite gmap_imerge_prf.
        case_eq (infR I1 !! n).
        * intros x xDef.
          assert (n ∈ domm I1) as nI1. {
            apply mk_is_Some in xDef.
            unfold domm, dom, flowint_dom.
            apply elem_of_dom.
            trivial. }
          assert (n ∈ domm I) as nI. {
            set_solver. }
          unfold domm, dom, flowint_dom in nI.
          apply elem_of_dom in nI.
          unfold is_Some in nI.
          destruct nI as [y nI].
          rewrite H0 in nI.
          simpl in nI.
          rewrite nI.
          f_equal.
          pose proof (Inf1 _ nI1) as In1n.
          unfold inf in In1n.
          rewrite xDef in In1n.
          simpl in In1n.
          rewrite ccm_comm in In1n.
          rewrite In1n.
          rewrite H0.
          simpl.
          rewrite nI.
          rewrite ccm_pinv.
          auto.
        * intros.
          assert (n ∉ domm I1). {
            unfold domm, dom, flowint_dom.
            rewrite elem_of_dom.
            rewrite H1.
            apply is_Some_None. }
          case_eq (infR I2 !! n).
          -- intros x xDef.
             assert (n ∈ domm I2) as nI2. {
               apply mk_is_Some in xDef.
               unfold domm, dom, flowint_dom.
               apply elem_of_dom.
               trivial. }
             assert (n ∈ domm I) as nI. {
               set_solver. }
             unfold domm, dom, flowint_dom in nI.
             apply elem_of_dom in nI.
             unfold is_Some in nI.
             destruct nI as [y nI].
             rewrite H0 in nI.
             simpl in nI.
             rewrite nI.
             f_equal.
             pose proof (Inf2 _ nI2) as In2n.
             unfold inf in In2n.
             rewrite xDef in In2n.
             simpl in In2n.
             rewrite ccm_comm in In2n.
             rewrite In2n.
             rewrite H0.
             simpl.
             rewrite nI.
             auto using ccm_pinv.
          -- intros.
             assert (n ∉ domm I2). {
               unfold domm, dom, flowint_dom.
               rewrite elem_of_dom.
               rewrite H3.
               apply is_Some_None. }
             assert (n ∉ domm I). {
               set_solver. }
             unfold domm, dom, flowint_dom in H5.
             rewrite elem_of_dom in H5 *.
             intros.
             rewrite H0 in H5.
             simpl in H5.
             rewrite <- eq_None_not_Some in H5. symmetry.
             trivial.
        * now intros.
      + rewrite H0 in Out.
        simpl in Out. easy.
    - contradiction.
  Qed.

  (* Interface composition is associative (valid case). *)
  Lemma intJoin_assoc_valid (F1 F2 F3 F12 I : flowintR) :
    intJoin F1 F2 F12 -> intJoin F12 F3 I -> ✓ I →
    {F23 : flowintR & intJoin F2 F3 F23 /\ intJoin F1 F23 I}.
  Proof.
    intros HeqI23 HeqI V. apply intJoin_comm in HeqI23. apply intJoin_comm in HeqI.
    rename F1 into I3. rename F2 into I2. rename F12 into I23. rename F3 into I1.
    remember (outComp I1 I2) as out12.
    remember (λ n (o1 o2 : option flowdom),
              match o1, o2 with
              | Some _, _ => Some (inf I n + out I3 n)
              | _, Some _ => Some (inf I n + out I3 n)
              | None, None => None
              end) as f_inf.
    assert (∀ n, f_inf n None None = None) as H_diag.
    { intros. rewrite Heqf_inf. trivial. }
    remember (gmap_imerge f_inf (*(infComp_op I I3)*)
                          (infR I1) (infR I2)) as inf12.
    remember {| infR := inf12; outR := out12 |} as I12.
    apply (intJoin_valid_proj1 _ _ _ HeqI) in V as V1.
    apply (intJoin_valid_proj2 _ _ _ HeqI) in V as V23.
    apply (intJoin_valid_proj1 _ _ _ HeqI23) in V23 as V2.
    apply (intJoin_valid_proj2 _ _ _ HeqI23) in V23 as V3.
    apply (intComposable_valid _ _ _ HeqI) in V as C.
    apply (intComposable_valid _ _ _ HeqI23) in V23 as C23.
    assert (CU := C).
    unfold intComposable in CU.
    destruct CU as (_ & _ & Disj & Inf1 & Inf23).
    assert (CU23 := C23).
    unfold intComposable in CU23.
    destruct CU23 as (_ & _ & Disj23 & Inf2 & Inf3).
    apply (intJoin_dom _ _ _ HeqI) in V as D.
    apply (intJoin_dom _ _ _ HeqI23) in V23 as D23.
    rewrite D23 in Disj.
    unfold map_Forall in Inf1.
    unfold map_Forall in Inf23.
    unfold map_Forall in Inf2.
    unfold map_Forall in Inf3.
    assert (intJoin I1 I2 I12 ∧ ✓ I12) as I12Def.
    { apply intJoin_fold.
      - trivial.
      - trivial.
      - set_solver.
      - rewrite set_eq.
        intros n.
        rewrite elem_of_union.
        split.
        * intros nD.
          unfold domm, dom, flowint_dom in nD.
          rewrite HeqI12 in nD.
          simpl in nD.
          rewrite Heqinf12 in nD.
          rewrite elem_of_dom in nD *.
          rewrite gmap_imerge_prf in nD. 2: apply H_diag.
          unfold domm, dom, flowint_dom.
          repeat rewrite elem_of_dom.
          destruct (infR I1 !! n).
          unfold is_Some.
          left.
          exists f.
          reflexivity.
          destruct (infR I2 !! n).
          right.
          exists f.
          reflexivity.
          rewrite Heqf_inf in nD.
          apply is_Some_None in nD.
          contradiction.
        * intros nD.
          unfold domm, dom, flowint_dom.
          rewrite HeqI12.
          simpl.
          rewrite Heqinf12.
          rewrite elem_of_dom.
          rewrite gmap_imerge_prf. 2: apply H_diag.
          rewrite Heqf_inf.
          destruct nD as [nD | nD];
            unfold domm, dom, flowint_dom in nD;
            rewrite elem_of_dom in nD *;
            unfold is_Some in nD;
            destruct nD as [x nD];
            rewrite nD;
            destruct (infR I1 !! n);
            apply not_eq_None_Some;
            auto.
      - intros ? n_in_I1.
        assert (n_in_I11 := n_in_I1).
        unfold domm, dom, flowint_dom in n_in_I11.
        apply elem_of_dom in n_in_I11.
        unfold is_Some in n_in_I11.
        destruct n_in_I11 as [x n_inf].
        apply Inf1 in n_inf as xDef.
        unfold inf at 2.
        rewrite HeqI12.
        simpl.
        rewrite Heqinf12.
        rewrite gmap_imerge_prf. 2: apply H_diag.
        rewrite n_inf.
        rewrite Heqf_inf.
        simpl.
        pose proof (intJoin_inf_1 _ _ _ HeqI V _ n_in_I1).
        rewrite H0.
        unfold inf at 2.
        rewrite n_inf.
        simpl.
        rewrite xDef.
        rewrite (ccm_comm (out I23 n)).
        rewrite ccm_pinv.
        rewrite ccm_comm.
        rewrite <- ccm_assoc.
        rewrite (ccm_comm (out I3 n)).
        assert (n ∉ domm I23).
        rewrite D23.
        set_solver.
        apply (intJoin_unfold_out _ _ _ HeqI23) in H1.
        unfold inf at 1.
        rewrite n_inf.
        simpl.
        rewrite xDef.
        rewrite ccm_comm.
        rewrite <- H1.
        reflexivity.
        trivial.
      - intros ? n_in_I2.
        assert (n_in_I21 := n_in_I2).
        unfold domm, dom, flowint_dom in n_in_I21.
        apply elem_of_dom in n_in_I21.
        unfold is_Some in n_in_I21.
        destruct n_in_I21 as [x n_inf].
        apply Inf2 in n_inf as xDef.
        unfold inf at 2.
        rewrite HeqI12.
        simpl.
        rewrite Heqinf12.
        rewrite gmap_imerge_prf. 2: apply H_diag.
        rewrite n_inf.
        rewrite Heqf_inf.
        assert (n ∈ domm I2 ∪ domm I3) as n_in_I23.
        set_solver.
        rewrite <- D23 in n_in_I23.
        unfold inf at 2.
        assert (n ∉ domm I1) as n_nin_I1.
        set_solver.
        unfold domm, dom, flowint_dom in n_nin_I1.
        rewrite elem_of_dom in n_nin_I1 *.
        rewrite <- eq_None_not_Some in n_nin_I1.
        rewrite n_nin_I1.
        simpl.
        rewrite ccm_comm.
        rewrite <- ccm_assoc.
        rewrite (ccm_comm (out I3 n)).
        rewrite ccm_assoc.
        pose proof (intJoin_unfold_inf_2 I1 I23 _ HeqI V n n_in_I23).
        rewrite <- H0.
        pose proof (intJoin_unfold_inf_1 I2 I3 _ HeqI23 V23 n n_in_I2).
        rewrite H1.
        reflexivity.
      - rewrite HeqI12.
        auto. }
    destruct I12Def as (I12Def & V12).
    assert (intJoin I12 I3 I) as IDef.
    { apply intJoin_fold.
      - trivial.
      - trivial.
      - rewrite (intJoin_dom _ _ _ I12Def V12).
        set_solver.
      - rewrite (intJoin_dom _ _ _ I12Def V12).
        rewrite D.
        rewrite D23.
        set_solver.
      - intros n nI12.
        rewrite HeqI12.
        unfold inf at 1.
        simpl.
        rewrite Heqinf12.
        rewrite gmap_imerge_prf. 2: apply H_diag.
        rewrite (intJoin_dom _ _ _ I12Def V12) in nI12.
        rewrite elem_of_union in nI12 *.
        destruct nI12 as [nI1 | nI2].
        + unfold domm, dom, flowint_dom in nI1.
          apply elem_of_dom in nI1.
          unfold is_Some in nI1.
          destruct nI1 as [x nI1].
          rewrite nI1.
          simpl.
          rewrite Heqf_inf.
          simpl.
          auto using ccm_comm.
        + destruct (infR I1 !! n).
          * rewrite Heqf_inf. simpl.
            auto using ccm_comm.
          * unfold domm, dom, flowint_dom in nI2.
            apply elem_of_dom in nI2.
            unfold is_Some in nI2.
            destruct nI2 as [x nI2].
            rewrite nI2.
            rewrite Heqf_inf.
            simpl.
            auto using ccm_comm.
      - intros n nI3.
        assert (n ∉ domm I1 ∪ domm I2) as n_not_I12.
        set_solver.
        rewrite <- (intJoin_dom _ _ _ I12Def V12) in n_not_I12.
        pose proof (intJoin_unfold_out I1 I2 _ I12Def V12 n n_not_I12).
        rewrite H0.
        assert (n ∈ domm I23) as nI23.
        set_solver.
        pose proof (intJoin_unfold_inf_2 I1 I23 _ HeqI V n nI23).
        rewrite ccm_comm.
        rewrite ccm_assoc.
        rewrite <- H1.
        pose proof (intJoin_unfold_inf_2 I2 I3 _ HeqI23 V23 n nI3).
        rewrite <- H2.
        reflexivity.
      - unfold intJoin, intComp in HeqI.
        destruct (decide (intComposable I1 I23)); last first. 1: contradiction.
        inversion HeqI. rename H1 into HI. simpl.
        apply nzmap_eq.
        intros n.
        unfold outComp.
        repeat rewrite nzmap_lookup_imerge.
        unfold outComp_op.
        pose proof (intJoin_unfold_out I1 I2 _ I12Def V12 n).
        pose proof (intJoin_unfold_out I2 I3 _ HeqI23 V23 n).
        unfold out in H0.
        unfold out in H1.
        rewrite D23.
        pose proof (intJoin_dom _ _ _ I12Def V12) as D12.
        rewrite D12.
        destruct (decide _), (decide _); try auto.
        set_solver. set_solver.
        rewrite not_elem_of_union in n0.
        rewrite not_elem_of_union in n1.
        destruct n0 as (_ & n0).
        destruct n1 as (n1 & _).
        rewrite <- D12 in n1.
        rewrite <- D23 in n0.
        apply H0 in n1.
        apply H1 in n0.
        rewrite n0 n1.
          by rewrite ccm_assoc. }
    exists I12. split; now apply intJoin_comm.
  Qed.

  (* Interface composition is associative (invalid case). *)
  Lemma intJoin_assoc_invalid (F1 F2 F3 F12 I : flowintR) :
    intJoin F1 F2 F12 -> intJoin F12 F3 I -> ¬ (✓ I) →
    {F23 : flowintR & intJoin F2 F3 F23 /\ intJoin F1 F23 I}.
  Proof.
    intros HeqI12 HeqI IV.
    pose proof (intValid_composable _ _ _ HeqI12) as NC1.
    pose proof (intValid_composable _ _ _ HeqI) as NC2.
    assert (HI := HeqI).
    unfold intJoin, intComp in HeqI.
    destruct (decide (intComposable F12 F3)). 1: now apply NC2 in i. clear NC2.
    destruct (decide (F12 = ∅)).
    - inversion HeqI. subst.
      apply intJoin_positive_1 in HeqI12 as E1.
      apply intJoin_positive_2 in HeqI12 as E2.
      subst. exists I. split; apply intJoin_left_unit.
    - destruct (decide (F3 = ∅)). 2: inversion HeqI. inversion HeqI. subst.
      exists F2. split; auto. apply intJoin_unit.
  Qed.

  (* Interface composition is associative. *)
  Lemma intJoin_assoc (I1 I2 I3 I12 I : flowintR) :
    intJoin I1 I2 I12 -> intJoin I12 I3 I ->
    {I23 : flowintR & intJoin I2 I3 I23 /\ intJoin I1 I23 I}.
  Proof.
    intros.
    destruct (decide (✓ I)).
    - eapply intJoin_assoc_valid; eauto.
    - eapply intJoin_assoc_invalid; eauto.
  Qed.

  (** Auxiliary definitions for setting up flow interface camera. *)

  Lemma flowint_valid_unfold (I : flowintR) :
    ✓ I → infR I ##ₘ nzmap_car (outR I) ∧ (infR I = ∅ → outR I = ∅).
  Proof.
    intros.
    unfold valid in H0.
    now unfold flowint_valid in H0.
  Qed.

  (* Flow interface composition is cancelable. *)
  Lemma intJoin_cancelable (I1 I2 I3 I: flowintR) :
    ✓ I → intJoin I1 I2 I -> intJoin I1 I3 I → I2 = I3.
  Proof.
    intros V12 HeqI12 HeqI13.
    pose proof (intComposable_valid _ _ _ HeqI13 V12) as C13.
    pose proof (intComposable_valid _ _ _ HeqI12 V12) as C12.
    pose proof (intJoin_valid_proj1 _ _ _ HeqI12 V12) as V1.
    pose proof (intJoin_valid_proj2 _ _ _ HeqI12 V12) as V2.
    pose proof (intJoin_valid_proj2 _ _ _ HeqI13 V12) as V3.
    pose proof (flowint_valid_unfold _ V1) as (Disj1 & _).
    pose proof (flowint_valid_unfold _ V2) as (Disj2 & _).
    pose proof (flowint_valid_unfold _ V3) as (Disj3 & _).
    assert (C12' := C12).
    assert (C13' := C13).
    destruct C12' as (_ & _ & Disj12 & Inf12 & Inf2).
    unfold map_Forall in Inf2.
    destruct C13' as (_ & _ & Disj13 & Inf13 & Inf3).
    assert (domm I2 = domm I3) as D23.
    { pose proof (intJoin_dom _ _ _ HeqI12 V12).
      pose proof (intJoin_dom _ _ _ HeqI13 V12).
      set_solver. }
    case_eq I2.
    intros infR2 outR2 Ir2_def.
    case_eq I3.
    intros infR3 outR3 Ir3_def.
    f_equal.
    - apply map_eq.
      intros n.
      unfold intJoin, intComp in HeqI12, HeqI13.
      destruct (decide (intComposable I1 I2)); last first. contradiction.
      destruct (decide (intComposable I1 I3)); last first. contradiction.
      assert (infComp I1 I2 !! n = infComp I1 I3 !! n) as Eqinf. {
        rewrite <- HeqI12 in HeqI13. inversion HeqI13. now rewrite H1. }
      unfold infComp, infComp_op in Eqinf.
      repeat rewrite gmap_imerge_prf in Eqinf; [| now intros..].
      unfold out at 1, out at 2 in Eqinf.
      destruct (decide (n ∈ domm I1)) as [n_in_I1 | n_nin_I1].
      + assert (n ∉ domm I2) as n_nin_I2 by set_solver.
        assert (n ∉ domm I3) as n_nin_I3 by set_solver.
        unfold domm, dom, flowint_dom in n_nin_I2.
        rewrite not_elem_of_dom in n_nin_I2 *.
        unfold domm, dom, flowint_dom in n_nin_I3.
        rewrite not_elem_of_dom in n_nin_I3 *.
        rewrite Ir2_def in n_nin_I2.
        simpl in n_nin_I2.
        rewrite Ir3_def in n_nin_I3.
        simpl in n_nin_I3.
        rewrite n_nin_I2.
        rewrite n_nin_I3.
        reflexivity.
      + unfold domm, dom, flowint_dom in n_nin_I1.
        rewrite not_elem_of_dom in n_nin_I1 *.
        rewrite n_nin_I1 in Eqinf.
        rewrite Ir2_def in Eqinf.
        rewrite Ir3_def in Eqinf.
        simpl in Eqinf.
        destruct (decide (n ∈ domm I2)) as [n_in_I2 | n_nin_I2].
        * assert (n ∈ domm I3) as n_in_I3.
          { rewrite <- D23. trivial. }
          unfold domm, dom, flowint_dom in n_in_I2, n_in_I3.
          rewrite elem_of_dom in n_in_I2 *.
          rewrite elem_of_dom in n_in_I3 *.
          unfold is_Some in n_in_I2, n_in_I3.
          destruct n_in_I2 as [x2 n_in_I2].
          destruct n_in_I3 as [x3 n_in_I3].
          rewrite Ir2_def in n_in_I2. simpl in n_in_I2.
          rewrite Ir3_def in n_in_I3. simpl in n_in_I3.
          rewrite n_in_I2 in Eqinf.
          rewrite n_in_I3 in Eqinf.
          pose proof (Inf2 n x2).
          rewrite Ir2_def in H0.
          unfold inf in H0.
          rewrite n_in_I2 in H0.
          simpl in H0.
          rewrite H0 in n_in_I2.
          pose proof (Inf3 n x3).
          rewrite Ir3_def in H1.
          unfold inf in H1.
          rewrite n_in_I3 in H1.
          simpl in H1.
          rewrite H1 in n_in_I3.
          assert (x2 - out I1 n = x3 - out I1 n) by naive_solver.
          rewrite H2 in n_in_I2.
          rewrite n_in_I3.
          rewrite n_in_I2.
          all: reflexivity.
        * assert (n ∉ domm I3) as n_nin_I3.
          { rewrite <- D23. trivial. }
          unfold domm, dom, flowint_dom in n_nin_I2, n_nin_I3.
          rewrite not_elem_of_dom in n_nin_I2 *.
          rewrite not_elem_of_dom in n_nin_I3 *.
          rewrite Ir2_def in n_nin_I2. simpl in n_nin_I2.
          rewrite Ir3_def in n_nin_I3. simpl in n_nin_I3.
          rewrite n_nin_I2.
          rewrite n_nin_I3.
          reflexivity.
    - apply nzmap_eq.
      intros n. assert (HeqI12' := HeqI12). assert (HeqI13' := HeqI13).
      unfold intJoin, intComp in HeqI12', HeqI13'.
      destruct (decide (intComposable I1 I2)); last first. contradiction.
      destruct (decide (intComposable I1 I3)); last first. contradiction.
      assert (outComp I1 I2 ! n = outComp I1 I3 ! n) as Eqout. {
        rewrite <- HeqI12' in HeqI13'. inversion HeqI13'. now rewrite H2. }
      unfold outComp in Eqout.
      repeat rewrite nzmap_lookup_imerge in Eqout.
      unfold outComp_op in Eqout.
      unfold map_Forall in Inf13, Inf12, Inf3, Inf2.
      destruct (decide _), (decide _).
      + destruct (decide (n ∈ domm I1)).
        * unfold domm, dom, flowint_dom in e1.
          pose proof (intJoin_inf_1 I1 I2 _ HeqI12 V12 n e1).
          pose proof (intJoin_inf_1 I1 I3 _ HeqI13 V12 n e1).
          rewrite elem_of_dom in e1 *.
          unfold is_Some in e1.
          destruct e1 as [x e1].
          pose proof (Inf13 _ _ e1).
          pose proof (Inf12 _ _ e1).
          rewrite <- H0 in H3.
          rewrite <- H1 in H2.
          rewrite H3 in H2.
          repeat rewrite (ccm_comm (out _ _)) in H2.
          apply ccm_cancel in H2.
          rewrite Ir2_def in H2.
          rewrite Ir3_def in H2.
          unfold out in H2.
          simpl in H2.
            by rewrite H2.
        * assert (n ∈ domm I2) by set_solver.
          assert (n ∈ domm I3) by set_solver.
          pose proof (intValid_in_dom_not_out I2 n V2 H0).
          pose proof (intValid_in_dom_not_out I3 n V3 H1).
          rewrite Ir2_def in H2.
          rewrite Ir3_def in H3.
          unfold out in H2, H3.
          simpl in H2,H3.
          rewrite H2.
          rewrite H3.
          reflexivity.
      + rewrite D23 in e. contradiction.
      + rewrite D23 in n0. contradiction.
      + apply ccm_cancel in Eqout.
        rewrite Ir2_def in Eqout.
        rewrite Ir3_def in Eqout.
        simpl in Eqout.
          by rewrite Eqout.
  Qed.

  Global Instance flowintPerm: sepalg.Perm_alg flowintR.
  Proof.
    constructor; unfold sepalg.join; intros.
    - unfold intJoin in *. rewrite H0 in H1. now inversion H1.
    - eapply intJoin_assoc; eauto.
    - now apply intJoin_comm.
    - destruct (intJoin_assoc _ _ _ _ _ H0 H1) as [ab' [? ?]].
      pose proof (intJoin_unit a).
      destruct (decide (✓ a)).
      + pose proof (intJoin_cancelable _ _ _ _ v H3 H4). subst ab'.
        apply intJoin_positive_1 in H2. subst a'. clear H1 H4.
        unfold intJoin in *. rewrite H0 in H3. now inversion H3.
      + apply (intComposable_invalid a a') in n as IC1.
        apply (intJoin_invalid _ _ _ H0) in n as IV2.
        unfold intJoin, intComp in H0. destruct (decide (intComposable a a')). 1: easy.
        destruct (decide (a = ∅)).
        * subst a. pose proof intEmp_valid. easy.
        * destruct (decide (a' = ∅)); inversion H0. easy.
  Qed.

  Global Instance flowintSep: sepalg.Sep_alg flowintR.
  Proof.
    exists (fun x => I_emptyR).
    - repeat intro. red. red. apply intJoin_left_unit.
    - now intros.
  Defined.

  Global Instance flowintSing: sepalg.Sing_alg flowintR.
  Proof. exists I_emptyR. intros. easy. Defined.

  Lemma list_join_unfold_out: forall (l: list flowintR) (c: flowintR),
      list_join l c -> ✓ c ->
      forall n, n ∉ domm c -> out c n = fold_right (fun x v => out x n + v) 0 l.
  Proof.
    induction l; intros; inversion H0; subst; simpl. 1: apply intEmp_out.
    red in H7. assert (✓ lj) by (eapply intJoin_valid_proj2; eauto).
    assert (n ∉ domm lj). {
      pose proof (intJoin_dom _ _ _ H7 H1). rewrite H4 in H2. intro. apply H2.
      now apply elem_of_union_r. }
    specialize (IHl _ H5 H3 _ H4). rewrite <- IHl. now apply intJoin_unfold_out.
  Qed.

  Lemma list_join_dom: forall (l: list flowintR) (c: flowintR),
      list_join l c -> ✓ c -> forall x, In x l -> domm x ⊆ domm c.
  Proof.
    induction l; intros. 1: inversion H2. inversion H0; subst; clear H0. red in H7.
    pose proof (intJoin_dom _ _ _ H7 H1). rewrite H0. clear H0.
    simpl in H2. destruct H2.
    - subst. apply union_subseteq_l.
    - apply intJoin_valid_proj2 in H7; auto. specialize (IHl _ H5 H7 _ H0).
      rewrite elem_of_subseteq. intros. apply elem_of_union_r.
      revert x0 H2. now rewrite <- elem_of_subseteq.
  Qed.

  Lemma list_join_nonempty_nodup: forall (l: list flowintR) (c: flowintR),
      list_join l c -> ✓ c -> (forall x, In x l -> domm x ≠ ∅) -> List.NoDup l.
  Proof.
    induction l; intros; inversion H0; subst; clear H0; constructor.
    - red in H7. pose proof (intComposable_valid _ _ _ H7 H1). intro.
      destruct H0 as [_ [_ [? _]]]. apply intJoin_valid_proj2 in H7; auto.
      pose proof (list_join_dom _ _ H5 H7 _ H3). hnf in H0.
      assert (In a (a :: l)) by (now left). apply H2 in H6.
      hnf in H4. apply set_choose_L in H6. destruct H6 as [x ?]. apply (H0 x); auto.
    - apply (IHl lj); auto.
      + red in H7. now apply intJoin_valid_proj2 in H7.
      + intros. apply H2. now right.
  Qed.

  Global Program Instance flowintGhost : Ghost :=
    { G := flowintR; valid := flowint_valid; Join_G := intJoin }.
  Next Obligation.
    eapply intJoin_valid_proj1; eauto.
  Qed.

End flowint.

Section ghost.

  Context `{HC: Countable Node}.

  Context (flowdom: Type) `{CCM flowdom}.

  Open Scope ccm_scope.

  (* Contextual extension of flow interfaces. *)
  Definition contextualLeq (I1 I2: @flowintR Node EqDecision0 HC flowdom H) : Prop :=
    ✓ I1 ∧ ✓ I2 ∧ domm I1 ⊆ domm I2 ∧
    (∀ (n: Node), n ∈ domm(I1) → inf I1 n = inf I2 n) ∧
    (∀ (n: Node), n ∉ domm(I2) → out I1 n = out I2 n).

End ghost.


Require Import QArith.
Require Import Psatz.
Require Import ClassicalRealizability.Kbase.
Require Import ClassicalRealizability.Rationals.
Require Import ClassicalRealizability.Real_definitions.
Require Import ClassicalRealizability.Real_relations.

(*********************************)
(** *  Arithmetical operations  **)
(*********************************)

(** Definitions are given in the file [Real_defintions.v].  **)

(** **  Stability of relativisations  **)

(** ***  Addition  **)

Definition addℝ_Total := λ"Tx" λ"Ty" λ"ε" λ"f"
  Qq 2 @ (ℚdiv @ "ε") @ λ"ε/2" (* shared computation *)
  "Tx" @ "ε/2" @ (λ"qx" λ"X"
  "Ty" @ "ε/2" @ (λ"qy" λ"Y"
  ℚadd @ "qx" @ "qy" @ "f" @ (λ"g"
  "g" @ "ε/2" @ "ε/2" @ "qx" @ "qy" @ "X" @ "Y"))).

Theorem addℝ_Total_realizer : forall e, addℝ_Total↓e ⊩ ∀x, ∀y, Total x → Total y → Total (x + y).
Proof.
unfold Total. intro e. start.
apply Qq_realizer. exists (ℚ (ε/2)). find. start. apply ℚdiv_realizer. find.
assert (0 < ε / 2) by now apply half_pos.
do 3 Ksolve.
unfold addℝ. Ksolve. now apply eq_half.
Qed.

Definition addℝ_proper := λ"eqx" λ"eqy" λ"ε₁" λ"ε₂" λ"q₁" λ"q₂" λ"XY₁" λ"XY₂"
  "XY₁" @ (λ"ε₁₁" λ"ε₁₂" λ"q₁₁" λ"q₁₂" λ"X₁" λ"Y₁"
  "XY₂" @ (λ"ε₂₁" λ"ε₂₂" λ"q₂₁" λ"q₂₂" λ"X₂" λ"Y₂"
  ("eqx" @ "ε₁₁" @ "ε₂₁" @ "q₁₁" @ "q₂₁" @ "X₁" @ "X₂") @
  ("eqy" @ "ε₁₂" @ "ε₂₂" @ "q₁₂" @ "q₂₂" @ "Y₁" @ "Y₂"))).

Theorem addℝ_proper_realizer : forall e, addℝ_proper↓e ⊩ ∀x₁ x₂ y₁ y₂, (x₁ ≡ x₂ → y₁ ≡ y₂ → x₁ + y₁ ≡ x₂ + y₂)%Re.
Proof.
do 2 Ksolve. startn 7.
(* Guard conditions *)
eapply prop_guard. Kmove. exists ε₁0, ε₁1. Ksolve; now apply Qclt_le_weak. intro Hle₁.
Kmove. repeat eexists; try eok || now apply Qclt_le_weak. apply (prop_subst_stack Hπ).
(* Arithmetical proof *)
clear_realizers. subst. intro Hle₂.
replace (q₁0 + q₂0 - (q₁1 + q₂1)) with (q₁0 - q₁1 + (q₂0 - q₂1)) by ring.
replace (ε₁0 + ε₂0 + (ε₁1 + ε₂1)) with (ε₁0 + ε₁1 + (ε₂0 + ε₂1)) by ring.
etransitivity. apply Qcabs_triangle. now apply Qcplus_le_compat.
Qed.

Definition addℝ_Cauchy := addℝ_proper.

Theorem addℝ_Cauchy_realizer : forall e, addℝ_Cauchy↓e ⊩ ∀x y, Cauchy x → Cauchy y → Cauchy (x + y)%Re.
Proof. intro e. startn 0. apply addℝ_proper_realizer. unfold Cauchy in *. do 4 eexists. split. eok. split; eok. Qed.

Definition addℝ_Rle_compat := addℝ_proper.

Theorem addℝ_Rle_compat_realizer :
  forall e, addℝ_Rle_compat↓e ⊩ ∀ x₁ x₂ y₁ y₂, (x₁ <= x₂ → y₁ <= y₂ → x₁ + y₁ <= x₂ + y₂)%Re.
Proof.
do 2 Ksolve. startn 7.
(* Guard conditions *)
eapply prop_guard. Kmove. exists ε₁0, ε₁1. Ksolve; now apply Qclt_le_weak. intro Hle₁.
Kmove. repeat eexists; try eok || now apply Qclt_le_weak. apply (prop_subst_stack Hπ).
(* Arithmetical proof *)
clear_realizers. revert Hle₁. subst. Qcunfold. lra.
Qed.

Definition addℝ_shift := λ"P" λ"f"
  "P" @ (λ"εx" λ"ε" λ"qx" λ"q" λ"X" λ"YZ" "YZ" @ (λ"εy" λ"εz" λ"qy" λ"qz" λ"Y" λ"Z"
  ℚadd @ "qx" @ "qy" @ (ℚadd @ "εx" @ "εy" @ "f" @ "εz") @ "qz"
       @ (λ"h" "h" @ "εx" @ "εy" @ "qx" @ "qy" @ "X" @ "Y")
       @ "Z")).

Lemma addℝ_shift_realizer : forall e, addℝ_shift↓e ⊩ ∀x y z ε q, ((x + (y + z)) ε q → ((x + y) + z) ε q)%Re.
Proof.
unfold addℝ. Kmove. exists Z. split; [| ok]. Ksolve. Kmove. exists (ε₁ + ε₁0). find.
  rewrite <- Qcplus_0_l at 1. now apply Qcplus_lt_compat.
  subst. ring.
  subst. ring.
  Kmove. exists ε₁, ε₁0. find.
Qed.

Definition addℝ_assoc := λ"Cx" λ"Cy" λ"Cz" λ"ε₁" λ"ε₂" λ"q₁" λ"q₂" λ"X+(Y+Z)" λ"(X+Y)+Z"
  addℝ_Cauchy @ (addℝ_Cauchy @ "Cx" @ "Cy") @ "Cz"
              @ "ε₁" @ "ε₂" @ "q₁" @ "q₂" @ (addℝ_shift @ "X+(Y+Z)") @ "(X+Y)+Z".

Theorem addℝ_assoc_realizer :
  forall e, addℝ_assoc↓e ⊩ ∀x y z, Cauchy x → Cauchy y → Cauchy z → (x + (y + z) ≡ (x + y) + z)%Re.
Proof.
intro e. startn 17. apply addℝ_Cauchy_realizer. do 2 eexists.
repeat split. startn 2. apply addℝ_Cauchy_realizer. find. eok.
exists ε₁, ε₂. find.
startn 1. apply addℝ_shift_realizer. exists x, y, z, ε₁, q₁. split; assumption.
Qed.

Definition addℝ_0_l := λ"Cx" λ"ε₁" λ"ε₂" λ"q₁" λ"q₂" λ"X+0" λ"X"
  "X+0" @ (λ"εx" λ"ε₀" λ"qx" λ"q₀" λ"X+" λ"0+"
  "0+" @ "Cx" @ "εx" @ "ε₂" @ "qx" @ "q₂" @ "X+" @ "X").

Theorem addℝ_0_l_realizer : forall e, addℝ_0_l↓e ⊩ ∀x, Cauchy x → (x + 0 ≡ x)%Re.
Proof.
Ksolve. start.
(* Guard conditions *)
apply (prop_guard Ht3). intros [_ ?].
(* Real proof *)
Kmove. exists ε₁0. find. now apply Qclt_le_weak. apply (prop_subst_stack Hπ).
(* Arithmetical proof *)
clear_realizers. subst. intro Hle. rewrite Qcplus_0_r. etransitivity. eassumption. revert Hc2. Qcunfold. lra.
Qed.

Definition addℝ_switch := λ"XY" "XY" @ λ"ε₁" λ"ε₂" λ"q₁" λ"q₂" λ"X" λ"Y"
  λ"f" "f" @ "ε₂" @ "ε₁" @ "q₂" @ "q₁" @ "Y" @ "X".

Lemma addℝ_switch_realizer : forall e, addℝ_switch↓e ⊩ ∀x y ε q, (x + y)%Re ε q → (y + x)%Re ε q.
Proof. unfold addℝ at 1. Ksolve. unfold addℝ. Kmove. exists ε₂, ε₁. find; now rewrite Qcplus_comm. Qed.

Definition addℝ_Eeq_comm := λ"ε" λ"q" λ"f" "f" @ addℝ_switch @ addℝ_switch.

Theorem addℝ_Eeq_comm_realizer : forall e, addℝ_Eeq_comm↓e ⊩ ∀x y, (x + y ≡≡ y + x)%Re.
Proof. Ksolve; startn 0; apply addℝ_switch_realizer; find. Qed.

Definition addℝ_Req_comm := λ"Cx" λ"Cy" λ"ε₁" λ"ε₂" λ"q₁" λ"q₂" λ"X+Y" λ"Y+X"
  addℝ_Cauchy @ "Cx" @ "Cy" @ "ε₁" @ "ε₂" @ "q₁" @ "q₂" @ "X+Y" @ (addℝ_switch @ "Y+X").

Theorem addℝ_Req_comm_realizer : forall e, addℝ_Req_comm↓e ⊩ ∀x y, Cauchy x → Cauchy y → (x + y ≡ y + x)%Re.
Proof.
intro e. startn 16. apply addℝ_Cauchy_realizer. exists x, y. repeat split; try ok.
exists ε₁, ε₂, q₁, q₂. find. startn 1. apply addℝ_switch_realizer. find.
Qed.

Definition addℝ_resp_Rlt := λ"Tz" λ"Lt" "Lt" @ λ"ε₁" λ"ε" λ"ε₂" λ"q₁" λ"q₂" λ"X" λ"Y"
  Qq 3 @ (ℚdiv @ "ε") @ λ"ε/3" (* shared computation *)
  "Tz" @ "ε/3" @ λ"q₃" λ"Z"
  λ"f" ℚadd @ "q₂" @ "q₃" @ (ℚadd @ "q₁" @ "q₃" @ (ℚadd @ "ε₂" @ "ε/3" @ (ℚadd @ "ε₁" @ "ε/3" @ "f" @ "ε/3")))
  @ (λ"h" "h" @ "ε₁" @ "ε/3" @ "q₁" @ "q₃" @ "X" @ "Z")
  @ (λ"h" "h" @ "ε₂" @ "ε/3" @ "q₂" @ "q₃" @ "Y" @ "Z").

Theorem addℝ_resp_Rlt_realizer : forall e, addℝ_resp_Rlt↓e ⊩ ∀x y z, Total z → (x << y → x + z << y + z)%Re.
Proof.
intro. unfold Rlt at 1. Opaque Rlt. Ksolve.
Ksolve. apply Qq_realizer. find. start. apply ℚdiv_realizer. find. find.
assert (0 < ε/3) by now apply third_pos.
start. apply Ht. find. Transparent Rlt.
Kmove. exists (ε₁ + ε / 3), (ε / 3), (ε₂ + ε / 3). find.
  change 0 with (0 + 0). apply Qcplus_lt_compat; ok.
  change 0 with (0 + 0). apply Qcplus_lt_compat; ok.
  replace (q₁ + q + (ε₁ + ε / 3) + ε / 3 + (ε₂ + ε / 3)) with (q₁ + ε₁ + ε + ε₂ + q) by (Qcunfold; qc; field).
    now apply Qcplus_le_compat.
  unfold addℝ. Kmove. exists ε₁, (ε / 3%Z). find.
  unfold addℝ. Kmove. exists ε₂, (ε / 3%Z). find.
Qed.

(** ***  Opposite **)

Definition oppℝ_Total := λ"Tx" λ"ε" "Tx" @ "ε" @ (λ"q" λ"X" λ"f" ℚopp @ "q" @ "f" @ "X").

Theorem oppℝ_Total_realizer : forall e, oppℝ_Total↓e ⊩ ∀x, Total x → Total (- x).
Proof. unfold Total,oppℝ. Kmove. findn 3. eexists (_ → Z). find. Ksolve. now rewrite Qcopp_involutive. Qed.

Definition oppℝ_Req_proper := λ"eq" λ"ε₁" λ"ε₂" λ"q₁" λ"q₂" λ"X" λ"Y"
  ℚopp @ "q₂" @ (ℚopp @ "q₁" @ ("eq" @ "ε₁" @ "ε₂")) @ "X" @ "Y".

Theorem oppℝ_Req_proper_realizer : forall e, oppℝ_Req_proper↓e ⊩ ∀x y, (x ≡ y → -x ≡ -y)%Re.
Proof.
unfold oppℝ. Kmove. exists ε₁. find.
replace (- q₁ - - q₂) with (-(q₁ - q₂)) by ring.
now rewrite Qcabs_opp.
Qed.

Definition oppℝ_Cauchy := oppℝ_Req_proper.

Theorem oppℝ_Cauchy_realizer : forall e, oppℝ_Cauchy↓e ⊩ ∀x, Cauchy x → Cauchy (- x).
Proof. intro e. startn 0. apply oppℝ_Req_proper_realizer. do 2 exists x. Ksolve. Qed.

Definition oppℝ_Eeq_proper := λ"eq" λ"ε" λ"q" ℚopp @ "q" @ ("eq" @ "ε").

Theorem oppℝ_Eeq_proper_realizer : forall e, oppℝ_Eeq_proper↓e ⊩ ∀x y, (x ≡≡ y → -x ≡≡ -y)%Re.
Proof. unfold Eeq. Ksolve. Qed.

Definition oppℝ_Eeq_involutive := Eeq_refl.

Theorem oppℝ_Eeq_involutive_realizer : forall e, oppℝ_Eeq_involutive↓e ⊩ ∀x, (--x ≡≡ x)%Re.
Proof. unfold Eeq, oppℝ. Ksolve; rewrite Qcopp_involutive; Ksolve. Qed.

Definition oppℝ_Req_involutive :=
  λ"Cx" Eeq_implies_Req @ (oppℝ_Cauchy @ (oppℝ_Cauchy @ "Cx")) @ oppℝ_Eeq_involutive.

Opaque Req oppℝ_Cauchy oppℝ_Eeq_involutive Eeq_implies_Req.
Corollary oppℝ_Req_involutive_realizer : forall e, oppℝ_Req_involutive↓e ⊩ ∀x, Cauchy x → (- - x ≡ x)%Re.
Proof.
intro e. start. apply Eeq_implies_Req_realizer. find.
  now do 2 (start; apply oppℝ_Cauchy_realizer; find).
start. apply oppℝ_Eeq_involutive_realizer. find.
Qed.

Transparent Req.
Definition oppℝ_addℝ := λ"Cx" λ"ε" λ"ε₀" λ"q" λ"q₀" λ"X+(-X)" λ"0"
  "0" @ "X+(-X)" @ (λ"ε₁" λ"ε₂" λ"q₁" λ"q₂"
  ℚopp @ "q₂" @ ("Cx" @ "ε₁" @ "ε₂" @ "q₁")).

Theorem oppℝ_addℝ_realizer : forall e, oppℝ_addℝ↓e ⊩ ∀x, Cauchy x → (x + (- x) ≡ embed_ℚ_ℝ 0)%Re.
Proof.
intro e. start.
(* Guard conditions *)
apply (prop_guard Ht1). intros [_ ?]. subst.
(* Decompose q₀ ∈ x+(-x)[ε₀] *)
apply Ht0. eexists; split; [| eok].
(* using Cauchy property of x *)
Kmove. exists ε₁0, ε₂0. Ksolve; try now apply Qclt_le_weak. subst. apply (prop_subst_stack Hπ).
(* Arithmetical proof *)
clear_realizers. intro Hle. rewrite <- Qcplus_0_r at 1. apply Qcplus_le_compat.
  now replace (q₁0 + q₂ - 0) with (q₁0 - - q₂) by ring.
  ok.
Qed.

(** ***  Multiplication  **)

(** [mulℝ_Total] and [mulℝ_Total_realizer] are missing. **)

Definition mulℝ_proper := λ"eqx" λ"eqy" λ"ε₁" λ"ε₂" λ"q₁" λ"q₂" λ"XY₁" λ"XY₂"
  "XY₁" @ λ"ε'₁" λ"ε''₁" λ"q'₁" λ"q''₁" λ"X₁" λ"Y₁"
  "XY₂" @ λ"ε'₂" λ"ε''₂" λ"q'₂" λ"q''₂" λ"X₂" λ"Y₂"
  ("eqx" @ "ε'₁" @ "ε'₂" @ "q'₁" @ "q'₂" @ "X₁" @ "X₂") @
  ("eqy" @ "ε''₁" @ "ε''₂" @ "q''₁" @ "q''₂" @ "Y₁" @ "Y₂").

Theorem mulℝ_proper_realizer : forall e, mulℝ_proper↓e ⊩ ∀x₁ x₂ y₁ y₂, (x₁ ≡ x₂ → y₁ ≡ y₂ → x₁ * y₁ ≡ x₂ * y₂)%Re.
Proof.
do 2 Ksolve. startn 7.
(* Guard conditions *)
(* Using the equality premises as guard conditions *)
eapply prop_guard. Kmove. exists ε₁0, ε₁1. Ksolve; now apply Qclt_le_weak. intro Hlex.
Kmove. exists ε₂0, ε₂1, q₂0, q₂1; find; (now apply Qclt_le_weak) || apply (prop_subst_stack Hπ).
(* Arithmetical proof *)
clear_realizers. subst. intro Hley.
destruct (Qclt_le_dec ε₁0 ε₁1); destruct (Qclt_le_dec ε₂0 ε₂1).
+ replace (q₁0 * q₂0 - q₁1 * q₂1) with (q₁0 * (q₂0 - q₂1) + (q₁0 - q₁1) * q₂1) by ring.
  transitivity (0 + ε₂).
  - rewrite Qcplus_0_l. etransitivity. now apply Qcabs_triangle. etransitivity; [| eok].
    do 2 rewrite Qcabs_mult. apply Qcplus_le_compat.
    * apply Qcmult_le_compat.
        now apply Qcabs_nonneg.
        now apply Qcabs_nonneg.
        rewrite Qcle_minus_iff. replace (|q₁1| + (ε₁1 + ε₁1) + - |q₁0|) with (ε₁1 + ε₁1 + - (|q₁0| - |q₁1|)) by ring.
        rewrite <- Qcle_minus_iff. etransitivity. apply Qcabs_triangle_reverse.
        etransitivity. eok. apply Qcplus_le_compat. now apply Qclt_le_weak. reflexivity.
        etransitivity. eok. apply Qcplus_le_compat. now apply Qclt_le_weak. reflexivity.
    * rewrite Qcmult_comm. apply Qcmult_le_compat.
        now apply Qcabs_nonneg.
        now apply Qcabs_nonneg.
        rewrite <- Qcplus_0_r at 1. apply Qcplus_le_compat. reflexivity. revert Hc6. Qcunfold. lra.
        etransitivity. eok. apply Qcplus_le_compat. now apply Qclt_le_weak. reflexivity.
  - apply Qcplus_le_compat; ok || reflexivity.
+ replace (q₁0 * q₂0 - q₁1 * q₂1) with (q₁0 * (q₂0 - q₂1) + (q₁0 - q₁1) * q₂1) by ring.
  etransitivity. apply Qcabs_triangle. do 2 rewrite Qcabs_mult. apply Qcplus_le_compat.
  - etransitivity; [| eok]. rewrite <- Qcplus_0_r at 1. apply Qcplus_le_compat.
    * apply Qcmult_le_compat.
        now apply Qcabs_nonneg.
        now apply Qcabs_nonneg.
        rewrite <- Qcplus_0_r at 1. apply Qcplus_le_compat. reflexivity. revert Hc1. Qcunfold. lra.
        etransitivity. eok. apply Qcplus_le_compat. reflexivity. assumption.
    * apply Qcmult_resp_nonneg.
        change 0 with (0 + 0). apply Qcplus_le_compat. now apply Qcabs_nonneg. revert Hc2. Qcunfold. lra.
        revert Hc1. Qcunfold. lra.
  - etransitivity; [| eok]. rewrite <- Qcplus_0_l at 1. apply Qcplus_le_compat.
    * apply Qcmult_resp_nonneg.
        change 0 with (0 + 0). apply Qcplus_le_compat. now apply Qcabs_nonneg. revert Hc5. Qcunfold. lra.
        revert Hc6. Qcunfold. lra.
    * rewrite Qcmult_comm. apply Qcmult_le_compat.
        now apply Qcabs_nonneg.
        now apply Qcabs_nonneg.
        rewrite <- Qcplus_0_r at 1. apply Qcplus_le_compat. reflexivity. revert Hc6. Qcunfold. lra.
        etransitivity. eok. apply Qcplus_le_compat. now apply Qclt_le_weak. reflexivity.
+ rewrite Qcabs_minus. replace (q₁1 * q₂1 - q₁0 * q₂0) with (q₁1 * (q₂1 - q₂0) + (q₁1 - q₁0) * q₂0) by ring.
  etransitivity. apply Qcabs_triangle. do 2 rewrite Qcabs_mult. rewrite Qcplus_comm. apply Qcplus_le_compat.
  - etransitivity; [| eok]. rewrite <- Qcplus_0_l at 1. apply Qcplus_le_compat.
    * apply Qcmult_resp_nonneg.
        change 0 with (0 + 0). apply Qcplus_le_compat. now apply Qcabs_nonneg. revert Hc1. Qcunfold. lra.
        revert Hc2. Qcunfold. lra.
    * rewrite Qcmult_comm. apply Qcmult_le_compat.
        now apply Qcabs_nonneg.
        now apply Qcabs_nonneg.
        rewrite <- Qcplus_0_r at 1. apply Qcplus_le_compat. reflexivity. revert Hc2. Qcunfold. lra.
        etransitivity. rewrite Qcabs_minus. eok. apply Qcplus_le_compat. reflexivity. assumption.
  - etransitivity; [| eok]. rewrite <- Qcplus_0_r at 1. apply Qcplus_le_compat.
    * apply Qcmult_le_compat.
        now apply Qcabs_nonneg.
        now apply Qcabs_nonneg.
        rewrite <- Qcplus_0_r at 1. apply Qcplus_le_compat. reflexivity. revert Hc5. Qcunfold. lra.
        etransitivity. rewrite Qcabs_minus. eok. apply Qcplus_le_compat. now apply Qclt_le_weak. reflexivity.
    * apply Qcmult_resp_nonneg.
        change 0 with (0 + 0). apply Qcplus_le_compat. now apply Qcabs_nonneg. revert Hc6. Qcunfold. lra.
        revert Hc5. Qcunfold. lra.
+ rewrite Qcabs_minus. replace (q₁1 * q₂1 - q₁0 * q₂0) with (q₁1 * (q₂1 - q₂0) + (q₁1 - q₁0) * q₂0) by ring.
  transitivity (ε₁ + 0).
  - rewrite Qcplus_0_r. etransitivity. now apply Qcabs_triangle. etransitivity; [| eok].
    do 2 rewrite Qcabs_mult. apply Qcplus_le_compat.
    * apply Qcmult_le_compat.
        now apply Qcabs_nonneg.
        now apply Qcabs_nonneg.
        rewrite Qcle_minus_iff. replace (|q₁0| + (ε₁0 + ε₁0) + - |q₁1|) with (ε₁0 + ε₁0 + - (|q₁1| - |q₁0|)) by ring.
        rewrite <- Qcle_minus_iff. etransitivity. apply Qcabs_triangle_reverse.
        etransitivity. rewrite Qcabs_minus. eok. apply Qcplus_le_compat. reflexivity. assumption.
        etransitivity. rewrite Qcabs_minus. eok. apply Qcplus_le_compat. reflexivity. assumption.
    * rewrite Qcmult_comm. apply Qcmult_le_compat.
        now apply Qcabs_nonneg.
        now apply Qcabs_nonneg.
        rewrite <- Qcplus_0_r at 1. apply Qcplus_le_compat. reflexivity. revert Hc2. Qcunfold. lra.
        etransitivity. rewrite Qcabs_minus. eok. apply Qcplus_le_compat. reflexivity. assumption.
  - apply Qcplus_le_compat; ok || reflexivity.
Qed.

Definition mulℝ_Cauchy := mulℝ_proper.

Theorem mulℝ_Cauchy_realizer : forall e, mulℝ_Cauchy↓e ⊩ ∀x y, Cauchy x → Cauchy y → Cauchy (x * y)%Re.
Proof. intro e. startn 0. apply mulℝ_proper_realizer. unfold Cauchy in *. do 4 eexists. split. eok. split; eok. Qed.

Definition mulℝ_switch := addℝ_switch.
(*λ"XY" "XY" @ λ"ε₁" λ"ε₂" λ"q₁" λ"q₂" λ"eqε" λ"eqq" λ"X" λ"Y"
  λ"f" "f" @ "ε₂" @ "ε₁" @ "q₂" @ "q₁" @ "eqε" @ "eqq" @ "Y" @ "X".*)

Lemma mulℝ_switch_realizer : forall e, mulℝ_switch↓e ⊩ ∀x y ε q, (x * y)%Re ε q → (y * x)%Re ε q.
Proof.
unfold mulℝ at 1. Ksolve. unfold mulℝ. Kmove.
exists ε₂, ε₁; find; now rewrite Qcplus_comm || rewrite Qcmult_comm.
Qed.

Definition mulℝ_Eeq_comm := λ"ε" λ"q" λ"f" "f" @ mulℝ_switch @ mulℝ_switch.

Theorem mulℝ_Eeq_comm_realizer : forall e, mulℝ_Eeq_comm↓e ⊩ ∀x y, (x * y ≡≡ y * x)%Re.
Proof. Ksolve; startn 0; apply mulℝ_switch_realizer; find. Qed.

Definition mulℝ_Req_comm := λ"Cx" λ"Cy" λ"ε₁" λ"ε₂" λ"q₁" λ"q₂" λ"X+Y" λ"Y+X"
  mulℝ_Cauchy @ "Cx" @ "Cy" @ "ε₁" @ "ε₂" @ "q₁" @ "q₂" @ "X+Y" @ (mulℝ_switch @ "Y+X").

Theorem mulℝ_Req_comm_realizer : forall e, mulℝ_Req_comm↓e ⊩ ∀x y, Cauchy x → Cauchy y → (x * y ≡ y * x)%Re.
Proof.
intro e. startn 16. apply mulℝ_Cauchy_realizer. exists x, y. repeat split; try ok.
exists ε₁, ε₂, q₁, q₂. repeat (split; trivial). find.
startn 1. apply mulℝ_switch_realizer. find.
Qed.

(*
Theorem mulℝ_assoc_realizer :
  forall e, mulℝ_assoc↓e ⊩ ∀x y z, Cauchy x → Cauchy y → Cauchy z → x * (y * z) ≡ (x * y) * z.
Theorem mulℝ_1_l_realizer : forall e, mulℝ_1_l↓e ⊩ ∀x, Cauchy x → 1 * x ≡ x.
Theorem distr_realizer :
  forall e, distr↓e ⊩ ∀ x y z, Cauchy x → Cauchy y → Cauchy z → x * (y + z) ≡ (x * y) + (x *z).
*)

(** ***  Inverse  **)

Definition invℝ_Total := λ"Tx" λ"Cx" λ"n0x" λ"ε" λ"f" "n0x" @ λ"ε₁" λ"ε₀" λ"ε₂" λ"q₁" λ"q₂" λ"X" λ"0"
  (* Guard condition *)
  "0" @
  (* Shared computation *)
  Qq 2 @ (ℚdiv @ "ε₀") @ λ"ε₀/2"
  (* Getting the value q *)
  (* -- computing q' := 1 / (|q₁| - ε₁ - ε₀/2) *)
  absℚ @ "q₁" @ ℚsub @ "ε₁" @ ℚsub @ "ε₀/2" @ (Qq 1 @ ℚdiv) @ λ"q'"
  (* -- computing the bound := min(ε / (q'² = |q'| * ε), ε₀ / 2) *)
  absℚ @ "q'" @ ℚmul @ "ε" @ (ℚmul @ "q'" @ "q'" @ ℚadd) @ (ℚdiv @ "ε") @ minℚ @ "ε₀/2" @ λ"res"
  (* Making the proof *)
  "Tx" @ "res" @ (λ"q" λ"X'" Qq 1 @ ℚdiv @ "q" @ "f" @ λ"f" "f" @ "res" @ "X'").

Conjecture conjecture1 : forall (x : Re) (ε ε₁ ε0 ε₂ q₁ q : Qc),
  0 < ε -> 0 < ε₁ -> 0 < ε0 -> 0 < ε₂ -> ε₁ + ε0 + ε₂ <= |q₁| ->
  forall (q' := 1 / (|q₁| - ε₁ - ε0 / 2)) (bound := Qcmin (ε / (q' * q' + |q'| * ε)) (ε0 / 2)),
  0 < q' -> 0 < bound ->
  forall t t0 t1 t3 t5 : Λ,
    t ⊩ (∀₁ ε∈ℚ+*, ∃₁ q ∈ ℚ, x ε q) -> t0 ⊩ Cauchy x -> t3 ⊩ x ε₁ q₁ -> t5 ⊩ x bound q -> t1 ⊩ x ≠ (embed_ℚ_ℝ 0)
  -> bound < |q|.

Conjecture conjecture2 : forall ε ε₁ ε0 ε₂ q₁ q : Qc,
  0 < ε -> 0 < ε₁ -> 0 < ε0 -> 0 < ε₂ -> ε₁ + ε0 + ε₂ <= |q₁| ->
  forall (q' := 1 / (|q₁| - ε₁ - ε0 / 2))
         (bound := Qcmin (ε / (q' * q' + |q'| * ε)) (ε0 / 2)),
  0 < q' -> 0 < bound -> bound < |q| -> |1 / q| <= |q'|.

Theorem invℝ_Total_realizer : forall e, invℝ_Total↓e ⊩ ∀x, Total x → Cauchy x → x ≠ (embed_ℚ_ℝ 0) → Total (/ x).
Proof.
unfold Total, apartℝ. Ksolve. start.
(* Guard condition *)
apply (prop_guard Ht4). intros [_ ?]. subst.
(* Shared computation *)
apply Qq_realizer. find. start. apply ℚdiv_realizer. find. find.
(* Give the bound for the precision *)
pose (q' := 1 / (Qcabs q₁ - ε₁ - ε0 / 2)).
pose (bound := Qcmin (ε / (q' * q' + Qcabs q' * ε)) (ε0 / 2)).
(* Prove that the bound is positive *)
assert (Hq' : 0 < q').
{ unfold q'. replace (q₁ - 0) with q₁ in Hc3 by ring. apply Qclt_shift_div_l.
  + replace ((|q₁|) - ε₁ - ε0 / 2) with ((|q₁|) + - (ε₁ + ε0 / 2)) by ring.
    rewrite <- Qclt_minus_iff. apply Qclt_le_trans with (ε₁ + ε0 + ε₂); trivial.
    rewrite Qclt_minus_iff. replace (ε₁ + ε0 + ε₂ + - (ε₁ + ε0 / 2)) with (ε0 - ε0 / 2 + ε₂) by ring.
    rewrite <- Qcplus_0_l at 1. apply Qcplus_lt_compat; trivial.
    unfold Qcminus. rewrite <- Qclt_minus_iff. apply Qclt_shift_div_r. now compute.
    simpl. replace (ε0 * 2%Z) with (ε0 + ε0). rewrite Qclt_minus_iff. ring_simplify. assumption.
    rewrite Qcmult_comm. Qcunfold. simpl. ring.
  + rewrite Qcmult_0_l. now compute. }
assert (Hmin : 0 < bound).
{ apply Qc.min_glb_lt.
  * apply Qclt_shift_div_l.
    + replace 0 with (0 * q' + q' * 0) by ring. apply Qcplus_lt_compat.
      - apply Qcmult_lt_compat_r; assumption.
      - rewrite Qcabs_pos. apply Qcmult_lt_compat_l; assumption. apply Qclt_le_weak; assumption.
    + rewrite Qcmult_0_l. assumption.
  * apply half_pos; ok. }
(* Prove that the bound is a rational number *)
start. apply absℚ_realizer. find. start. apply ℚsub_realizer. find.
  find. start. apply ℚsub_realizer. find. find.
start. apply Qq_realizer. find. start. apply ℚdiv_realizer. find. find. find.
start. apply absℚ_realizer. find. start. apply ℚmul_realizer. find.
find. start. apply ℚadd_realizer. find. find. start. apply ℚdiv_realizer. find.
find. start. apply minℚ_realizer. find. find.
change 2%Z with (Z.of_nat 2). fold q'. fold bound.
(* Introduce the bound *)
start. apply Ht. find.
(* Prove that it is a valid approximation *)
start. apply Qq_realizer. find. start. apply ℚdiv_realizer. find. find. Ksolve. find.
assert (Hq : bound < |q|).
{ replace (q₁ - 0) with q₁ in Hc3 by ring. eapply (conjecture1 x ε ε₁ ε0 ε₂ q₁ q); eassumption. }
unfold invℝ. Ksolve.
* unfold Qcdiv. rewrite Qcmult_1_l. rewrite Qcabs_inv. rewrite Qcinv_involutive. ok.
* clear_realizers.
  assert (Hqq' : |1 / q| <= |q'|).
  { assert (Heq : q₁ - 0 = q₁) by ring. rewrite Heq in *. apply (conjecture2 ε ε₁ ε0 ε₂ q₁ q); assumption. }
  etransitivity. apply Qc.le_min_l.
  assert (0 < q' * q' + |q'| * ε).
  { change 0 with (0 + 0). apply Qcplus_lt_compat. apply Qcsquare_pos. symmetry. apply Qclt_not_eq; ok.
    replace 0 with (0 * ε) by ring. apply Qcmult_lt_compat_r. ok. rewrite Qcabs_pos. ok. apply Qclt_le_weak; ok. }
  apply Qcmult_le_compat.
  + apply Qclt_le_weak; ok.
  + rewrite Qcinv_nonneg. apply Qclt_le_weak. ok.
  + reflexivity.
  + apply Qcinv_pos_le_compat.
    - assert (0 < |1 / q|).
      { unfold Qcdiv. rewrite Qcmult_1_l. rewrite Qcabs_inv. rewrite Qcinv_pos. transitivity bound; ok. }
      change 0 with (0 + 0). apply Qcplus_lt_compat.
        rewrite <- Qcabs_pos.
          rewrite Qcabs_mult. apply Qcsquare_pos. symmetry. apply Qclt_not_eq. ok.
          now apply Qcsquare_nonneg.
        replace 0 with (0 * ε) by ring. apply Qcmult_lt_compat_r; ok.
    - apply Qcplus_le_compat.
        setoid_rewrite <- Qcabs_pos at 1 2; try now apply Qcsquare_nonneg.
        do 2 rewrite Qcabs_mult. apply Qcmult_le_compat; apply Qcabs_nonneg || ok.
        apply Qcmult_le_compat_r. ok. apply Qclt_le_weak. ok.
* unfold Qcdiv. rewrite Qcmult_1_l. rewrite Qcinv_involutive. ok.
Qed.


Require Import FP.Data.String.
Require Import FP.Data.Ascii.
Require Import FP.Data.AsciiRelations.
Require Import FP.Data.List.
Require Import FP.Data.ListRelations.
Require Import FP.Structures.EqDec.
Require Import FP.Structures.Eqv.
Require Import FP.Structures.Ord.
Require Import FP.Data.Function.
Require Import FP.Relations.RelDec.

Import FunctionNotation.

Section EqDec.
  Definition string_eq_dec := eq_dec `on` string2list.

  Global Instance string_EqDec : EqDec string := { eq_dec := string_eq_dec }.
  Global Instance string_Eq_RelDecCorrect : RelDecCorrect string eq eq_dec.
  Admitted.
End EqDec.

Section Eqv.
  Global Instance string_Eqv : Eqv string := { eqv := eq }.
End Eqv.

Section EqvDec.
  Global Instance string_EqvDec : EqvDec string := { eqv_dec := eq_dec }.
  Global Instance string_Eqv_RelDecCorrect : RelDecCorrect string eqv eqv_dec.
  Admitted.
End EqvDec.

Section Ord.
  Definition string_lt := lt `on` string2list.

  Global Instance string_Ord : Ord string := { lt := string_lt }.
End Ord.

Section OrdDec.
  Definition string_ord_dec := ord_dec `on` string2list.

  Global Instance string_OrdDec : OrdDec string := { ord_dec := string_ord_dec  }.
End OrdDec.