(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import Compopts.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Op.
Require Import ValueDomain.
Require Import RTL.

(** Value analysis for ARM operators *)

Definition eval_static_shift (s: shift) (v: aval): aval :=
  match s with
  | Slsl x => shl v (I x)
  | Slsr x => shru v (I x)
  | Sasr x => shr v (I x)
  | Sror x => ror v (I x)
  end.

Definition eval_static_condition (cond: condition) (vl: list aval): abool :=
  match cond, vl with
  | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2
  | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2
  | Ccompshift c s, v1 :: v2 :: nil => cmp_bool c v1 (eval_static_shift s v2)
  | Ccompushift c s, v1 :: v2 :: nil => cmpu_bool c v1 (eval_static_shift s v2)
  | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n)
  | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n)
  | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2
  | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2)
  | Ccompfzero c, v1 :: nil => cmpf_bool c v1 (F Float.zero)
  | Cnotcompfzero c, v1 :: nil => cnot (cmpf_bool c v1 (F Float.zero))
  | _, _ => Bnone
  end.

Definition eval_static_addressing (addr: addressing) (vl: list aval): aval :=
  match addr, vl with
  | Aindexed n, v1::nil => add v1 (I n)
  | Aindexed2, v1::v2::nil => add v1 v2
  | Aindexed2shift s, v1::v2::nil => add v1 (eval_static_shift s v2)
  | Ainstack ofs, nil => Ptr(Stk ofs)
  | _, _ => Vbot
  end.

Definition eval_static_operation (op: operation) (vl: list aval): aval :=
  match op, vl with
  | Omove, v1::nil => v1
  | Ointconst n, nil => I n
  | Ofloatconst n, nil => if propagate_float_constants tt then F n else ftop
  | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs)
  | Oaddrstack ofs, nil => Ptr (Stk ofs)
  | Ocast8signed, v1 :: nil => sign_ext 8 v1
  | Ocast16signed, v1 :: nil => sign_ext 16 v1
  | Oadd, v1::v2::nil => add v1 v2
  | Oaddshift s, v1::v2::nil => add v1 (eval_static_shift s v2)
  | Oaddimm n, v1::nil => add v1 (I n)
  | Osub, v1::v2::nil => sub v1 v2
  | Osubshift s, v1::v2::nil => sub v1 (eval_static_shift s v2)
  | Orsubshift s, v1::v2::nil => sub (eval_static_shift s v2) v1
  | Orsubimm n, v1::nil => sub (I n) v1
  | Omul, v1::v2::nil => mul v1 v2
  | Omla, v1::v2::v3::nil => add (mul v1 v2) v3
  | Omulhs, v1::v2::nil => mulhs v1 v2
  | Omulhu, v1::v2::nil => mulhu v1 v2
  | Odiv, v1::v2::nil => divs v1 v2
  | Odivu, v1::v2::nil => divu v1 v2
  | Oand, v1::v2::nil => and v1 v2
  | Oandshift s, v1::v2::nil => and v1 (eval_static_shift s v2)
  | Oandimm n, v1::nil => and v1 (I n)
  | Oor, v1::v2::nil => or v1 v2
  | Oorshift s, v1::v2::nil => or v1 (eval_static_shift s v2)
  | Oorimm n, v1::nil => or v1 (I n)
  | Oxor, v1::v2::nil => xor v1 v2
  | Oxorshift s, v1::v2::nil => xor v1 (eval_static_shift s v2)
  | Oxorimm n, v1::nil => xor v1 (I n)
  | Obic, v1::v2::nil => and v1 (notint v2)
  | Obicshift s, v1::v2::nil => and v1 (notint (eval_static_shift s v2))
  | Onot, v1::nil => notint v1
  | Onotshift s, v1::nil => notint (eval_static_shift s v1)
  | Oshl, v1::v2::nil => shl v1 v2
  | Oshr, v1::v2::nil => shr v1 v2
  | Oshru, v1::v2::nil => shru v1 v2
  | Oshift s, v1::nil => eval_static_shift s v1
  | Oshrximm n, v1::nil => shrx v1 (I n)
  | Onegf, v1::nil => negf v1
  | Oabsf, v1::nil => absf v1
  | Oaddf, v1::v2::nil => addf v1 v2
  | Osubf, v1::v2::nil => subf v1 v2
  | Omulf, v1::v2::nil => mulf v1 v2
  | Odivf, v1::v2::nil => divf v1 v2
  | Osingleoffloat, v1::nil => singleoffloat v1
  | Ointoffloat, v1::nil => intoffloat v1
  | Ointuoffloat, v1::nil => intuoffloat v1
  | Ofloatofint, v1::nil => floatofint v1
  | Ofloatofintu, v1::nil => floatofintu v1
  | Omakelong, v1::v2::nil => longofwords v1 v2
  | Olowlong, v1::nil => loword v1
  | Ohighlong, v1::nil => hiword v1
  | Ocmp c, _ => of_optbool (eval_static_condition c vl)
  | _, _ => Vbot
  end.

Section SOUNDNESS.

Variable bc: block_classification.
Variable ge: genv.
Hypothesis GENV: genv_match bc ge.
Variable sp: block.
Hypothesis STACK: bc sp = BCstack.

Lemma eval_static_shift_sound:
  forall s v a,
  vmatch bc v a ->
  vmatch bc (eval_shift s v) (eval_static_shift s a).
Proof.
  intros. unfold eval_shift, eval_static_shift. destruct s; eauto with va.
Qed.

Hint Resolve eval_static_shift_sound: va.

Theorem eval_static_condition_sound:
  forall cond vargs m aargs,
  list_forall2 (vmatch bc) vargs aargs ->
  cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs).
Proof.
  intros until aargs; intros VM.
  inv VM.
  destruct cond; auto with va.
  inv H0.
  destruct cond; simpl; eauto with va.
  inv H2.
  destruct cond; simpl; eauto with va.
  destruct cond; auto with va.
Qed.

Lemma symbol_address_sound:
  forall id ofs,
  vmatch bc (symbol_address ge id ofs) (Ptr (Gl id ofs)).
Proof.
  intros; apply symbol_address_sound; apply GENV.
Qed.

Hint Resolve symbol_address_sound: va.

Ltac InvHyps :=
  match goal with
  | [H: None = Some _ |- _ ] => discriminate
  | [H: Some _ = Some _ |- _] => inv H
  | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ ,
     H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps
  | _ => idtac
  end.

Theorem eval_static_addressing_sound:
  forall addr vargs vres aargs,
  eval_addressing ge (Vptr sp Int.zero) addr vargs = Some vres ->
  list_forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_addressing addr aargs).
Proof.
  unfold eval_addressing, eval_static_addressing; intros;
  destruct addr; InvHyps; eauto with va.
  rewrite Int.add_zero_l; auto with va.
Qed.

Theorem eval_static_operation_sound:
  forall op vargs m vres aargs,
  eval_operation ge (Vptr sp Int.zero) op vargs m = Some vres ->
  list_forall2 (vmatch bc) vargs aargs ->
  vmatch bc vres (eval_static_operation op aargs).
Proof.
  unfold eval_operation, eval_static_operation; intros;
  destruct op; InvHyps; eauto with va.
  destruct (propagate_float_constants tt); constructor.
  rewrite Int.add_zero_l; eauto with va.
  fold (Val.sub (Vint i) a1). auto with va.
  apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
Qed.

End SOUNDNESS.


Require Import GLS_PSGLS_calcs.
Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import ddT.
Require Import gen_tacs.
Require Import gen_seq.
Require Import List_lemmasT.
Require Import existsT.
Require Import univ_gen_ext.
Require Import GLS_PSGLS_list_lems.
Require Import dd_fc.
Require Import PeanoNat.
Require Import strong_inductionT.
Require Import PSGLS_termination_measure.
Require Import PSGLS_termination.
Require Import GLS_exch.
Require Import GLS_ctr.
Require Import GLS_wkn.
Require Import GLS_PSGLS_remove_list.
Require Import GLS_PSGLS_dec.
Require Import GLS_inv_ImpR_ImpL.
Require Import GLS_additive_cut.
Require Import Lia.

Inductive CutRule : rlsT Seq :=
  | CutRule_I : forall A Γ0 Γ1 Δ0 Δ1,
          CutRule [(Γ0 ++ Γ1, Δ0 ++ A :: Δ1) ; (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)]
                    (Γ0 ++ Γ1, Δ0 ++ Δ1)
.

Inductive GLS_cut_rules : rlsT  Seq :=
  | GLS_woc : forall ps c, GLS_rules ps c -> GLS_cut_rules ps c
  | iGLS_cut : forall ps c, CutRule ps c -> GLS_cut_rules ps c
.

Definition GLS_cut_prv s := derrec GLS_cut_rules (fun _ => False) s.
Definition GLS_cut_drv s := derrec GLS_cut_rules (fun _ => True) s.

Theorem GLS_cut_elimination : forall s, (GLS_cut_prv s) -> (GLS_prv s).
Proof.
intros s D.
apply derrec_all_rect with
(Q:= fun x => (GLS_prv x))
in D ; auto.
- intros. inversion H.
- intros ps concl rule ders IH. inversion rule.
  * subst. apply derI with (ps:=ps) ; auto. apply dersrec_forall. intros. apply ForallTD_forall with (x:=ps) (x0:=c) in IH ; auto.
  * subst. inversion H. subst. apply GLS_cut_adm with (A:=A).
    apply ForallTD_forall with (x:=[(Γ0 ++ Γ1, Δ0 ++ A :: Δ1); (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)]) (x0:=(Γ0 ++ Γ1, Δ0 ++ A :: Δ1)) in IH ; auto.
    apply InT_eq.
    apply ForallTD_forall with (x:=[(Γ0 ++ Γ1, Δ0 ++ A :: Δ1); (Γ0 ++ A :: Γ1, Δ0 ++ Δ1)]) (x0:=(Γ0 ++ A :: Γ1, Δ0 ++ Δ1)) in IH ; auto.
    apply InT_cons ; apply InT_eq.
Defined.


From iris.program_logic Require Export weakestpre adequacy prob_adequacy.
From iris.heap_lang Require Export lifting.
From iris.algebra Require Import auth.
From iris.heap_lang Require Import proofmode notation.
From iris.proofmode Require Import tactics.
From discprob.idxval Require Import pival pival_dist irrel_equiv.
Set Default Proof Using "Type".
From iris.program_logic Require prob_adequacy.

Class heapPreG Σ := HeapPreG {
  heap_preG_iris :> invPreG Σ;
  heap_preG_heap :> gen_heapPreG loc val Σ;
  heap_probG_inG : prob_adequacy.probPreG heap_ectxi_lang Σ
}.

Definition heapΣ : gFunctors := #[invΣ; gen_heapΣ loc val;
                                  GFunctor (authUR (optionUR (exclR (discreteC prob_state))))].
Instance subG_heapPreG {Σ} : subG heapΣ Σ → heapPreG Σ.
Proof. split; solve_inG. Qed.

Instance heap_proj_heapPreG {Σ} : heapPreG Σ → prob_adequacy.probPreG heap_ectxi_lang Σ.
Proof. intros [? ? ?]. eauto.  Qed.

Definition heap_adequacy Σ `{heapPreG Σ} {X} (Is: pidist X) s e σ φ :
  (∀ `{heapG Σ} `{H: probG Σ},
      @ownProb _ H X Is ⊢ WP e @ s; ⊤ {{ v, ⌜φ v⌝ }}%I) →
  adequate s e σ φ.
Proof.
  intros Hwp; eapply prob_adequacy.wp_prob_safety_adequacy.
  { eapply heap_preG_iris. }
  iIntros (?) "".
  iMod (own_alloc (● to_gen_heap σ)) as (γ) "Hh".
  { apply: auth_auth_valid. exact: to_gen_heap_valid. }
  iModIntro. iExists (λ σ, own γ (● to_gen_heap σ)); iFrame; iIntros.
  set (Hheap := GenHeapG loc val Σ _ _ _ γ).
  iApply (Hwp (HeapG _ _ _) with "[$]").
Qed.

Definition heap_adequacy' Σ `{heapPreG Σ} s e σ φ :
  (∀ `{heapG Σ} `{probG Σ}, WP e @ s; ⊤ {{ v, ⌜φ v⌝ }}%I) →
  adequate s e σ φ.
Proof.
  intros Hwp. apply (heap_adequacy _  (mret tt)) => Hh Hp.
  iIntros; iApply Hwp.
Qed.

Definition heap_prob_adequacy Σ `{heapPreG Σ} {X} Is e σ φ sch n:
  terminates sch [([e], σ)] n →
  (∀ `{heapG Σ} `{H: probG Σ},
      ownProb Is ⊢ WP e {{ v, ∃ v' : X, ownProb (mret v') ∗ ⌜φ v v'⌝ }}%I) →
  irrel_couplingP (ivdist_tpool_stepN sch [e] σ n)
                  Is
                  (prob_adequacy.coupling_post φ).
Proof.
  intros Hsch Hwp.
  eapply prob_adequacy.wp_prob_adequacy'; eauto.
  iIntros (?) "".
  iMod (own_alloc (● to_gen_heap σ)) as (γ) "Hh".
  { apply: auth_auth_valid. exact: to_gen_heap_valid. }
  iModIntro. iExists (λ σ, own γ (● to_gen_heap σ)); iFrame; iIntros.
  set (Hheap := GenHeapG loc val Σ _ _ _ γ).
  iApply (Hwp (HeapG _ _ _) with "[$]").
Qed.

Require Import Reals.
Import Rbar.
From discprob.idxval Require Import extrema ival_dist.

Definition heap_prob_adequacy_Ex_max Σ `{heapPreG Σ} {X} (Is: pidist X) e σ sch n f g d:
  terminates sch [([e], σ)] n →
  (∀ `{heapG Σ} `{H: probG Σ},
      ownProb Is ⊢ WP e {{ v, ∃ (v' : X), ownProb (mret v') ∗ ⌜f v = g v'⌝ }}%I) →
  bounded_fun_on g (λ x, In_psupport x Is) →
  Rbar_le (extrema.Ex_ival (coerce_cfg f d) (ivdist_tpool_stepN sch [e] σ n))
          (extrema.Ex_max g Is).
Proof.
  rewrite /coerce_cfg.
  intros. apply irrel_coupling_eq_Ex_max_supp; eauto.
  eapply irrel_coupling_conseq; last eapply heap_prob_adequacy with (φ := λ x y, f x = g y); eauto.
  intros x y. rewrite /prob_adequacy.coupling_post.
  destruct x as (l&?). destruct l => //=.
  destruct to_val => //=.
Qed.

Definition heap_prob_adequacy_Ex_min Σ `{heapPreG Σ} {X} Is e σ sch n f g d:
  terminates sch [([e], σ)] n →
  (∀ `{heapG Σ} `{H: probG Σ},
      ownProb Is ⊢ WP e {{ v, ∃ (v' : X), ownProb (mret v') ∗ ⌜f v = g v'⌝ }}%I) →
  bounded_fun_on g (λ x, In_psupport x Is) →
  Rbar_le (extrema.Ex_min g Is)
          (extrema.Ex_ival (coerce_cfg f d) (ivdist_tpool_stepN sch [e] σ n))%R.
Proof.
  rewrite /coerce_cfg.
  intros. apply irrel_coupling_eq_Ex_min_supp; eauto.
  eapply irrel_coupling_conseq; last eapply heap_prob_adequacy with (φ := λ x y, f x = g y); eauto.
  intros x y. rewrite /prob_adequacy.coupling_post.
  destruct x as (l&?). destruct l => //=.
  destruct to_val => //=.
Qed.


(***************************************************************************
* Functional Translation of a Calculus of Capabilities - Definitions       *
* Arthur Charguéraud, January 2009, Coq v8.1                               *
***************************************************************************)

Set Implicit Arguments.
Require Export Eff_Infrastructure.
Implicit Types x : var.

Axiom subset_notin : forall (E F : locs) x,
  F << E -> x \notin E -> x \notin F.

Axiom subset_trans : forall (F E G : locs),
  E << F -> F << G -> E << G.

Axiom disjoint_in_notin : forall (E F : locs) x,
  disjoint E F -> x \in E -> x \notin F.

(* todo: le applys in doit marcher modulo unfold *)
(* todo: forwards sur pattern *)

(* ********************************************************************** *)
(** ** Facts about preservation *)

Lemma shp_kept_refl : forall S,
  shp_kept S S.
Proof. intros_all~. Qed.

Lemma shp_kept_trans : forall S2 S1 S3,
  shp_kept S1 S2 ->
  shp_kept S2 S3 ->
  shp_kept S1 S3.
Proof. intros_all~. Qed.

Lemma sto_kept_refl : forall M L,
  sto_kept M M L.
Proof. intros_all~. Qed.

Lemma sto_kept_subset : forall M1 M2 L L',
  sto_kept M1 M2 L ->
  L' << L ->
  sto_kept M1 M2 L'.
Proof. intros_all~. Qed.

Lemma sto_modif_refl : forall M L1 L2,
  L2 << L1 ->
  sto_modif M M L1 L2.
Proof. intros_all~. autos* subset_notin. Qed.

Lemma sto_modif_trans : forall M2 L2 M1 L1 M3 L3,
  sto_modif M1 M2 L1 L2 ->
  sto_modif M2 M3 L2 L3 ->
  sto_modif M1 M3 L1 L3.
Proof. introv H1 H2 N B. forwards* [? ?]: (H1 l). Qed.

Lemma sto_modif_extend : forall M1 M2 L1 L2 L',
  sto_modif M1 M2 L1 L2 ->
  sto_modif M1 M2 (L1 \u L') (L2 \u L').
Proof. introv M N B. forwards* [? ?]: (M l). Qed.

Lemma sto_kept_outside_modif : forall M1 M2 L1 L2 L',
  disjoint L' L1 ->  (* disjoint L' L2 -> *)
  sto_modif M1 M2 L1 L2 ->
  sto_kept M1 M2 L'.
Proof.
  introv D M N B. forwards* [? ?]: (M l).
  apply* disjoint_in_notin.
Qed.

(* ********************************************************************** *)
(** ** Weakening and substitution *)

Hint Constructors tval ttrm.

Ltac go := unfold ltac_tag_subst in *|-.

Hint Extern 1 (ok _) => skip.
Hint Extern 1 (lnv _) => skip.
Hint Extern 1 (dnv _) => skip.

Ltac introz :=
  match goal with
  | |- (ltac_tag_subst (?x = ?y) -> ?Q) =>
     let H := fresh "Aux" in
     intro H; unfold ltac_tag_subst in H;
     try subst x; introz
  | |- ?P -> ?Q =>
     let H := fresh "Hyp" in
     intro H; unfold ltac_tag_subst in H; introz
  | |- forall _, _ =>
     intro; introz
  | |- _ => idtac
  end.

Lemma weaken_val_trm :
  (forall S D1 D2 D3 v tau V,
  tval S (D1 & D3) v tau V ->
  dnv (D1 & D2 & D3) ->
  tval S (D1 & D2 & D3) v tau V)
  /\
  (forall S E1 E2 E3 t chi T,
  ttrm S (E1 & E3) t chi T->
  lnv (E1 & E2 & E3) ->
  ttrm S (E1 & E2 & E3) t chi T).
Proof.
  sets P: (fun S D v tau V (Typ: tval S D v tau V) =>
    forall D1 D2 D3,
    ltac_tag_subst (D = D1 & D3) ->
    dnv (D1 & D2 & D3) ->
    tval S (D1 & D2 & D3) v tau V).
  sets Q: (fun S E t chi T (Typ: ttrm S E t chi T) =>
    forall E1 E2 E3,
    ltac_tag_subst (E = E1 & E3) ->
    lnv (E1 & E2 & E3) ->
    ttrm S (E1 & E2 & E3) t chi T).
  (* lets: (@tval_ttrm_induct P Q).*)
  cuts [H1 H2]: ((forall S D v tau V (Typ: tval S D v tau V), P S D v tau V Typ)
     /\ (forall S E t chi T (Typ: ttrm S E t chi T), Q S E t chi T Typ)).
   subst P Q. unfolds ltac_tag_subst. simpls*.
   subst P Q.
  apply tval_ttrm_induct; go; introz.
  auto.
  auto.
  auto.
  apply* tval_var. apply* binds_weaken.
  auto.
  apply_fresh* tval_abs. apply_ih_bind* Hyp2.
  auto.
  apply* ttrm_app. skip. (* env lemma *)
  eauto.
  skip. (* env lemma *)
  skip. (* env lemma *)
Qed.

Parameter subst_val : forall x S D1 D2 v tau V v1 tau1 V1,
  tval S D1 v1 tau1 V1 ->
  tval S (D1 & x ~ tau1 & D2) v tau V ->
  tval S (D1 & D2) (val_subst x v1 v) tau (Val_subst x V1 V).

Parameter subst_trm : forall x S D1 E2 T chi v1 tau1 V1 t,
  tval S D1 v1 tau1 V1 ->
  ttrm S (D1 & x ~ tau1 & E2) t chi T ->
  ttrm S (D1 & E2) (trm_subst x v1 t) chi (Trm_subst x V1 T).

Parameter subst_out : forall m S x chi t chi' T L v V,
  ttrm S (x ~ chi) t chi' T ->
  tout m S v chi L V ->
  exist S' L' T',
     texe m S (trm_subst x v t) chi' L' T'
  /\ star Red (Trm_subst x V T) T'
  /\ shp_kept S S'
  /\ sto_modif m m L L'.

(* ********************************************************************** *)
(** ** Type substitution *)

  (* -- type substitution preserves all judgments... *)

(* ********************************************************************** *)
(** ** Stability *)

Parameter stable_val : forall S S' D v tau V,
  tval S D v tau V ->
  shp_kept S S' ->
  tval S' D v tau V.

Parameter stable_trm : forall S S' E t chi T,
  tval S E t chi T ->
  shp_kept S S' ->
  tval S' E t chi T.

Parameter stable_cap : forall m m' S S' C L V,
  tcap m S C L V ->
  shp_kept S S' ->
  sto_kept m m' L ->
  tcap m' S' C L V.

Parameter stable_mem : forall m m' S S' v tta L V,
  tmem m S v tta L V ->
  shp_kept S S' ->
  sto_kept m m' L ->
  tmem m' S' v tta L V.

(* ********************************************************************** *)
(** ** Subtyping *)

Parameter mem_to_val : forall m S v tau V,
   tmem m S v tau {} V ->
   tval S empty v tau V.

Parameter reduce_sub_val : forall tau1 tau2 V S v V1,
  sub tau1 tau2 V ->
  tval S empty v tau1 V1 ->
  exists V2',
     plus Red (Trm_app V V1) (Trm_val V2')
  /\ tval S empty v tau2 V2'.

Parameter reduce_sub_cap : forall C1 C2 V m S V1 L,
  sub C1 C2 V ->
  tcap m S C1 L V1 ->
  exist S' L' V2',
     plus Red (Trm_app V V1) (Trm_val V2')
  /\ tcap m S' C2 L' V2'
  /\ shp_kept S S'
  /\ sto_modif m m L L'.

Parameter reduce_sub_mem : forall tta1 tta2 V m S v V1 L,
  sub tta1 tta2 V ->
  tmem m S v tta1 L V1 ->
  exist S' L' V2',
     plus Red (Trm_app V V1) (Trm_val V2')
  /\ tmem m S' v tta2 L' V2'
  /\ shp_kept S S'
  /\ sto_modif m m L L'.

Parameter reduce_sub_out : forall chi1 chi2 V m S v V1 L,
  sub chi1 chi2 V ->
  tout m S v chi1 L V1 ->
  exist S' L' V2',
     plus Red (Trm_app V V1) (Trm_val V2')
  /\ texe m S' v chi2 L' V2'
  /\ shp_kept S S'
  /\ sto_modif m m L L'.

(* ********************************************************************** *)
(** ** Reduction *)

Parameter reduction : forall m m' t' S L v1 v2 V1 V2 chi1 chi2,
  red (trm_app v1 (\v2), m) (t', m') ->
  tval S empty v1 (obj_arrow chi1 chi2) V1 ->
  tout m S v2 chi1 L V2 ->
  exist S' L' T',
     star Red (Trm_app V1 V2) T'
  /\ texe m' S' t' chi2 L' T'
  /\ shp_kept S S'
  /\ sto_modif m m' L L'.

Parameter termination : forall m v S L T chi,
  texe m S v chi L T ->
  exist S' L' V',
     plus Red T V'
  /\ texe m S' v chi L' V'
  /\ shp_kept S S'
  /\ sto_modif m m L L'.

Parameter simulation : forall m m' t t' S L T chi,
  red (t, m) (t', m') ->
  texe m S t chi L T ->
  exist S' L' T',
     plus Red T T'
  /\ texe m' S' t' chi L' T'
  /\ shp_kept S S'
  /\ sto_modif m m' L L'.


From Coq Require extraction.Extraction.
Require Import Coq.extraction.ExtrOcamlBasic.
Require Import Coq.extraction.ExtrOcamlNativeString.

(** Extraction of [nat] to [Zarith]'s [Z.t]. *)
Extract Inductive nat => "Z.t" ["Z.zero" "Z.succ"].

Extract Inlined Constant plus => "Z.add".
Extract Inlined Constant mult => "Z.mul".
Extract Inlined Constant pred => "(fun n -> Z.max Z.zero (Z.pred n))".
Extract Inlined Constant minus => "(fun n m -> Z.max Z.zero (Z.sub n m))".
Extract Inlined Constant max => "Z.max".
Extract Inlined Constant min => "Z.min".

Extract Inlined Constant EqNat.beq_nat => "Z.equal".
Extract Inlined Constant EqNat.eq_nat_decide => "Z.equal".
Extract Inlined Constant Peano_dec.eq_nat_dec => "Z.equal".

Extract Inlined Constant Compare_dec.leb => "Z.leq".
Extract Inlined Constant Compare_dec.le_lt_dec => "Z.leq".
Extract Inlined Constant Compare_dec.lt_eq_lt_dec =>
"(fun n m -> if Z.lt n m then Some true else if Z.equal n m then Some false else None)".

Require CoqRecon.Util.Base
        CoqRecon.Util.EqDecInst CoqRecon.Util.ListLib
        CoqRecon.Util.Sets CoqRecon.Util.Env
        CoqRecon.Util.Maybe CoqRecon.Util.Pair
        CoqRecon.Syntax.Typ CoqRecon.Syntax.Term
        CoqRecon.Semantics.TypEnv
        CoqRecon.Semantics.Reduce
        CoqRecon.Mono.Computes
        CoqRecon.Unify.Unify.

Separate Extraction CoqRecon.Util.Base
         CoqRecon.Util.EqDecInst CoqRecon.Util.ListLib
         CoqRecon.Util.Sets CoqRecon.Util.Env
         CoqRecon.Util.Maybe CoqRecon.Util.Pair
         CoqRecon.Syntax.Typ CoqRecon.Syntax.Term
         CoqRecon.Semantics.TypEnv
         CoqRecon.Semantics.Reduce
         CoqRecon.Mono.Computes
         CoqRecon.Unify.Unify.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

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

  Velisarios is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export PBFT_A_1_9_misc2.

Section PBFT_A_1_9_misc3.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pbft_context : PBFTcontext      }.
  Context { pbft_auth    : PBFTauth         }.
  Context { pbft_keys    : PBFTinitial_keys }.
  Context { pbft_hash    : PBFThash         }.

  Lemma low_water_mark_increases_with_new_views :
    forall (eo : EventOrdering) (e : Event) i st nv maxV,
      state_sm_on_event (PBFTreplicaSM i) e = Some st
      -> new_view_in_log nv (view_change_state st)
      -> view_change_cert2max_seq (new_view2cert nv) = Some maxV
      -> maxV <= low_water_mark st.
  Proof.
    introv eqst nvil mv.

    revert dependent st.
    induction e as [? ind] using predHappenedBeforeInd_local_pred;[].

    introv eqst nvil.

    dup eqst as eqst_At_e.
    rewrite state_sm_on_event_unroll2 in eqst.

    match goal with
      | [ H : context[map_option _ ?s] |- _ ] =>
        remember s as sop; symmetry in Heqsop; destruct sop; simpl in *;[|ginv];op_st_some m eqtrig
    end.

    unfold PBFTreplica_update in eqst.

    destruct m;
      simpl in *; ginv; subst; tcsp;
        try smash_handlers; try (smash_pbft_ind ind).

    (* 3 subgoals *)

    {
      (* checkpoint *)

      assert (maxV <= low_water_mark p) by (smash_pbft_ind ind).
      rename_hyp_with add_new_checkpoint2cp_state add.
      apply add_new_checkpoint2cp_state_preserves_sn_stable in add; rewrite add.
      fold (low_water_mark p) in *; try omega.
    }

    {
      (* check_bcast_new_view *)

      rename_hyp_with update_state_new_view upd.
      rename_hyp_with check_broadcast_new_view check.
      rename_hyp_with CheckBCastNewView2entry cb.

      apply CheckBCastNewView2entry_some_implies in cb.

      applydup update_state_new_view_preserves_wf in upd; simpl; eauto 4 with pbft;[].

      assert (correct_new_view nv = true) as cornv1 by eauto 2 with pbft.
      applydup check_broadcast_new_view_generates in check as cornv2.

      eapply update_state_new_view_preserves_new_view_in_log in nvil;[|eauto].
      simpl in *.

      applydup check_broadcast_new_view_implies in check; exrepnd.
      unfold update_state_new_view in upd.
      unfold view_change_cert2max_seq in *; smash_pbft.

      - match goal with
        | [ H : new_view2cert _ = _ |- _ ] => rewrite <- H in *
        end.

        match goal with
        | [ H1 : ?a = _, H2 : ?a = _ |- _ ] => rewrite H1 in H2; ginv
        end.

        match goal with
        | [ H : view_change_cert2max_seq_vc _ = Some (maxV0, _) |- _ ] =>
          applydup view_change_cert2_max_seq_vc_some_in in H;
            applydup sn_of_view_change_cert2max_seq_vc in H; subst
        end.

        dup cornv2 as corvc.
        eapply correct_new_view_implies_correct_view_change in corvc;[|eauto].

        rename_hyp_with log_checkpoint_cert_from_new_view lchk.
        eapply log_checkpoint_cert_from_new_view_preserves_low_water_mark2 in lchk;
          [| |eauto];simpl; autorewrite with pbft; auto;[].

        applydup check_broadcast_new_view_implies_eq_views in check;[|eauto 3 with pbft];[].

        applydup log_new_view_and_entry_preserves_new_view_in_log in nvil;
          simpl in *; autorewrite with pbft in *; auto;[].

        repndors;[| |].

        + assert (maxV <= low_water_mark p) as xx by (smash_pbft_ind ind).
          rewrite lchk; omega.

        + subst x2.

          match goal with
          | [ H1 : view_change_cert2max_seq_vc ?a = _, H2 : view_change_cert2max_seq_vc ?a = _ |- _ ]
            => rewrite H1 in H2; ginv
          end.

        + assert (new_view_in_log nv (view_change_state p)) as nvinlog2 by (eauto 3 with pbft).
          assert (maxV <= low_water_mark p) as xx by (smash_pbft_ind ind).
          rewrite lchk; omega.

      - match goal with
        | [ H : new_view2cert _ = _ |- _ ] => rewrite <- H in *
        end.

        match goal with
        | [ H1 : ?a = _, H2 : ?a = _ |- _ ] => rewrite H1 in H2; ginv
        end.

        match goal with
        | [ H : view_change_cert2max_seq_vc _ = Some (maxV0, _) |- _ ] =>
          applydup view_change_cert2_max_seq_vc_some_in in H;
            applydup sn_of_view_change_cert2max_seq_vc in H; subst
        end.

        dup cornv2 as corvc.
        eapply correct_new_view_implies_correct_view_change in corvc;[|eauto].

        applydup check_broadcast_new_view_implies_eq_views in check;[|eauto 3 with pbft];[].

        applydup log_new_view_and_entry_preserves_new_view_in_log in nvil;
          simpl in *; autorewrite with pbft in *; auto;[].

        repndors;[| |].

        + assert (maxV <= low_water_mark p) as xx by (smash_pbft_ind ind).
          omega.

        + subst x2.

          match goal with
          | [ H1 : view_change_cert2max_seq_vc  ?a = _,
                   H2 : view_change_cert2max_seq_vc ?a = _ |- _ ] => rewrite H1 in H2; ginv
          end.

        + assert (new_view_in_log nv (view_change_state p)) as nvinlog2 by (eauto 3 with pbft).
          assert (maxV <= low_water_mark p) as xx by (smash_pbft_ind ind).
          omega.
    }

    {
      (* new-view *)

      rename_hyp_with update_state_new_view upd.
      rename_hyp_with add_prepares_to_log_from_new_view_pre_prepares add.
      rename_hyp_with correct_new_view cornv2.
      rename_hyp_with has_new_view hnv.

      applydup add_prepares_to_log_from_new_view_pre_prepares_preserves_wf in add;
        simpl; autorewrite with pbft; eauto 3 with pbft;[].
      applydup update_state_new_view_preserves_wf in upd; simpl; eauto 3 with pbft;[].

      assert (correct_new_view nv = true) as cornv1 by eauto 2 with pbft.

      applydup add_prepares_to_log_from_new_view_pre_prepares_preserves_low_water_mark in add.
      autorewrite with pbft in *.
      applydup add_prepares_to_log_from_new_view_pre_prepares_preserves_view_change_state in add.
      simpl in *.

      clear add.

      unfold update_state_new_view in upd.
      unfold view_change_cert2max_seq in *; smash_pbft.

      - simpl in *.

        match goal with
        | [ H : view_change_cert2max_seq_vc _ = Some (x4, _) |- _ ] =>
          applydup view_change_cert2_max_seq_vc_some_in in H;
            applydup sn_of_view_change_cert2max_seq_vc in H; subst
        end.

        dup cornv2 as corvc.
        eapply correct_new_view_implies_correct_view_change in corvc;[|eauto].

        rename_hyp_with log_checkpoint_cert_from_new_view lchk.
        applydup log_checkpoint_cert_from_new_view_preserves_view_change_state in lchk.
        eapply log_checkpoint_cert_from_new_view_preserves_low_water_mark2 in lchk;
          [| |eauto];simpl; autorewrite with pbft; auto;[].
        rewrite lchk0 in *.

        applydup log_new_view_preserves_new_view_in_log in nvil;
          simpl in *; autorewrite with pbft in *; auto;[].

        rewrite add2 in *.
        rewrite lchk in *.

        repndors;[|].

        + assert (maxV <= low_water_mark p) as xx by (smash_pbft_ind ind).
          rewrite add1 in *.
          omega.

        + subst v.

          match goal with
          | [ H1 : view_change_cert2max_seq_vc ?a = _, H2 : view_change_cert2max_seq_vc ?a = _ |- _ ]
            => rewrite H1 in H2; ginv
          end.

      - rewrite <- add1 in *.
        rewrite add2 in *.

        applydup log_new_view_preserves_new_view_in_log in nvil;
          simpl in *; autorewrite with pbft in *; auto;[].

        repndors;[|].

        + assert (maxV <= low_water_mark p) as xx by (smash_pbft_ind ind).
          omega.

        + subst v.

          match goal with
          | [ H1 : view_change_cert2max_seq_vc ?a = _, H2 : view_change_cert2max_seq_vc ?a = _ |- _ ]
            => rewrite H1 in H2; ginv
          end.

      - rewrite <- add1 in *.
        rewrite add2 in *.

        applydup log_new_view_preserves_new_view_in_log in nvil;
          simpl in *; autorewrite with pbft in *; auto;[].

        repndors;[|].

        + assert (maxV <= low_water_mark p) as xx by (smash_pbft_ind ind).
          omega.

        + subst v.

          match goal with
          | [ H1 : view_change_cert2max_seq_vc ?a = _, H2 : view_change_cert2max_seq_vc ?a = _ |- _ ]
            => rewrite H1 in H2; ginv
          end.
    }
  Qed.
  Hint Resolve low_water_mark_increases_with_new_views : pbft.

End PBFT_A_1_9_misc3.

Hint Resolve low_water_mark_increases_with_new_views : pbft.


(** * EqThInv.v : Decision procedures for determining program equivalence and
   invariants *)

Set Implicit Arguments.

Require Export While_loop.
Require Export EqTh.

Module Make (Sem:SEM).

 Module EqT := EqTh.Make Sem.
 Export EqT.

 (* Information for two different environments *)

 Record dproc_eq_inv_info (E1 E2:env) (t:T.type) (f:Proc.proc t) : Type := {
  dpi_eq_refl1 : proc_eq_refl_info E1 f;
  dpi_eq_refl2 : proc_eq_refl_info E2 f;
  dpii_input : Vset.t;  (* global variables *)
  dpii_params : Vset.t; (* local variables  *)
  dpii_output : Vset.t (* global variables *)
 }.

 Record sproc_eq_inv_info (inv : mem_rel) (E1 E2:env) (t:T.type) (f:Proc.proc t)
   (data : dproc_eq_inv_info E1 E2 f) : Prop := {
  siinput_global : forall x, Vset.mem x data.(dpii_input) -> Var.is_global x;
  sparams_subset1 : data.(dpii_params) [<=] Vset_of_var_decl (proc_params E1 f);
  sparams_subset2 : data.(dpii_params) [<=] Vset_of_var_decl (proc_params E2 f);
  spii_output_global : forall x, Vset.mem x data.(dpii_output) -> Var.is_global x;
  spii_spec :
   exists ls,
    (forall x, Vset.mem x ls -> Var.is_local x) /\
    EqObsInv inv (Vset.union data.(dpii_input) data.(dpii_params))
     E1 (proc_body E1 f) E2 (proc_body E2 f) (Vset.union ls data.(dpii_output)) /\
     EqObs_e
     (Vset.union (Vset.union ls data.(dpii_output))
      (Vset.diff data.(dpii_input)
        (Vset.union (pi_mod data.(dpi_eq_refl1)) (pi_mod data.(dpi_eq_refl2)))))
     (proc_res E1 f) (proc_res E2 f)
 }.

 Record proc_eq_inv_info (inv : mem_rel) (E1 E2:env) (t:T.type) (f:Proc.proc t) : Type := {
  dpii : dproc_eq_inv_info E1 E2 f;
  spii : sproc_eq_inv_info inv dpii
 }.

 Definition pi_eq_refl1 inv E1 E2 t f (pii:@proc_eq_inv_info inv E1 E2 t f) :=
    pii.(dpii).(dpi_eq_refl1).

 Definition pi_eq_refl2 inv E1 E2 t f (pii:@proc_eq_inv_info inv E1 E2 t f) :=
    pii.(dpii).(dpi_eq_refl2).

 Definition pii_input inv E1 E2 t f (pii:@proc_eq_inv_info inv E1 E2 t f) :=
    pii.(dpii).(dpii_input).

 Definition pii_params inv E1 E2 t f (pii:@proc_eq_inv_info inv E1 E2 t f) :=
    pii.(dpii).(dpii_params).

 Definition pii_output inv E1 E2 t f (pii:@proc_eq_inv_info inv E1 E2 t f) :=
    pii.(dpii).(dpii_output).

 Definition iinput_global inv E1 E2 t f (pii:@proc_eq_inv_info inv E1 E2 t f) :
   forall x, Vset.mem x (pii_input pii) -> Var.is_global x :=
  pii.(spii).(siinput_global).

 Definition params_subset1 inv E1 E2 t f (pii:@proc_eq_inv_info inv E1 E2 t f) :
   (pii_params pii) [<=] Vset_of_var_decl (proc_params E1 f):=
  pii.(spii).(sparams_subset1).

 Definition params_subset2 inv E1 E2 t f (pii:@proc_eq_inv_info inv E1 E2 t f) :
   (pii_params pii) [<=] Vset_of_var_decl (proc_params E2 f):=
  pii.(spii).(sparams_subset2).

 Definition pii_output_global inv E1 E2 t f (pii:@proc_eq_inv_info inv E1 E2 t f) :
   forall x, Vset.mem x (pii_output pii) -> Var.is_global x :=
  pii.(spii).(spii_output_global).

 Definition pii_spec inv E1 E2 t f (pii:@proc_eq_inv_info inv E1 E2 t f) :
    exists ls,
    (forall x, Vset.mem x ls -> Var.is_local x) /\
    EqObsInv inv (Vset.union (pii_input pii) (pii_params pii))
     E1 (proc_body E1 f) E2 (proc_body E2 f) (Vset.union ls (pii_output pii)) /\
     EqObs_e
     (Vset.union (Vset.union ls (pii_output pii))
      (Vset.diff (pii_input pii)
        (Vset.union (pi_mod (pi_eq_refl1 pii)) (pi_mod (pi_eq_refl2 pii)))))
     (proc_res E1 f) (proc_res E2 f) :=
  pii.(spii).(spii_spec).

 Definition eq_inv_info_o inv (E1 E2:env) :=
  forall t (f:Proc.proc t), option (proc_eq_inv_info inv E1 E2 f).

 Record eq_inv_info (inv:mem_rel) (E1 E2:env) : Type := {
  pii_inv_X1 : Vset.t;
  pii_inv_X2 : Vset.t;
  pii_inv_dep : depend_only_rel inv pii_inv_X1 pii_inv_X2;
  pii_inv_global : forall x,
   Vset.mem x (Vset.union pii_inv_X1 pii_inv_X2) -> Var.is_global x;
  pii_inv_dec : decMR inv;
  pii_info : eq_inv_info_o inv E1 E2
 }.

 Definition refl1_info inv E1 E2 (pii:eq_inv_info inv E1 E2) : eq_refl_info E1:=
  fun t f =>
   match pii.(pii_info) f with
   | Some pif => Some (pi_eq_refl1 pif)
   | None => None
   end.

 Definition refl2_info inv E1 E2 (pii:eq_inv_info inv E1 E2) : eq_refl_info E2:=
  fun t f =>
   match pii.(pii_info) f with
   | Some pif => Some (pi_eq_refl2 pif)
   | None => None
   end.

 Section EqObsInv_IN_NM.

  Variable n : positive.
  Variable inv : mem_rel.
  Variables E1 E2 : env.
  Variables X1 X2 : Vset.t.
  Variable pii : eq_inv_info_o inv E1 E2.

  Hypothesis inv_dep : depend_only_rel inv X1 X2.
  Hypothesis inv_global : forall x,
   Vset.mem x (Vset.union X1 X2) -> Var.is_global x.
  Hypothesis inv_dec : decMR inv.

  Definition eqobsinv_in_b_nm (i:I.baseInstr) O :=
   match i with
   | I.Assign t x e =>
     if Vset.mem x X1 then None
     else if Vset.mem x X2 then None
     else if Vset.mem x O then Some (fv_expr_extend e (Vset.remove x O))
     else Some O
   | I.Random t x e =>
     if Vset.mem x X1 then None
     else if Vset.mem x X2 then None
     else if Vset.mem x O then  Some (Vset.union (fv_distr e) (Vset.remove x O))
     else Some O
   | I.IAssert e => None
   end.

  Fixpoint eqobsinv_in_i (i:I.instr) (O:Vset.t) {struct i} : option Vset.t :=
   match i with
   | I.Instr ib => eqobsinv_in_b_nm ib O
   | I.Cond e c1 c2 =>
     let oI1 := List.fold_right (fun i => opt_app (eqobsinv_in_i i)) (Some O) c1 in
     let oI2 := List.fold_right (fun i => opt_app (eqobsinv_in_i i)) (Some O) c2 in
      match oI1, oI2 with
      | Some I1, Some I2 =>
        Some (fv_expr_extend e (Vset.union I1 I2))
      | _, _ => None
      end
   | I.While e c =>
     let loop O :=
     let oI := List.fold_right (fun i => opt_app (eqobsinv_in_i i)) (Some O) c in
      match oI with
      | Some II =>
        if II [<=?] O then Result Vset.t (Some O)
        else Continue (option Vset.t) (Vset.union II O)
      | None => Result Vset.t None
      end in
      let Oe := fv_expr_extend e O in
       match While_loop.while loop n Oe with
       | Continue _ => None
       | Result r => r
       end
   | I.Call t d f arg =>
     if Vset.mem d X1 then None
     else if Vset.mem d X2 then None
     else
     let lv1 := proc_params E1 f in
     let lv2 := proc_params E2 f in
      match pii f with
      | Some pif =>
        let fout := Vset.add d (pii_output pif) in
        let other := Vset.diff O fout in
         if Vset.disjoint other
           (Vset.union (pi_mod (pi_eq_refl1 pif)) (pi_mod (pi_eq_refl2 pif))) then
         let gif := Vset.union (pii_input pif) other in
          match needed_args lv1 arg lv2 arg (pii_params pif) gif with
          | None => None
          | Some Ifun => Some Ifun
          end
         else None
      | _ => None
      end
   end.

  Lemma eqobsinv_in_b_nm_correct : forall (i:I.baseInstr) O I,
   eqobsinv_in_b_nm i O = Some I ->
   EqObsInv inv I E1 [I.Instr i] E2 [I.Instr i] O.
  Proof.
   destruct i; simpl; intros O I.
   case_eq (Vset.mem v X1); intro; try (intros; discriminate).
   case_eq (Vset.mem v X2); intro; try (intros; discriminate).
   case_eq  (Vset.mem v O); intros H1 H2; unfold EqObsInv; inversion H2; clear H2; subst.
   eapply equiv_strengthen;[ | apply equiv_assign].
   unfold req_mem_rel, kreq_mem, andR; intros k m1 m2 (H3,H4); split.
   rewrite union_fv_expr_spec in H3.
   apply req_mem_weaken with (Vset.add v (Vset.remove v O)).
   rewrite VsetP.add_remove; auto with set.
   rewrite (@EqObs_e_fv_expr t e k m1 m2).
   apply req_mem_update.
   apply req_mem_weaken with (2:= H3); auto with set.
   apply req_mem_weaken with (2:= H3); auto with set.
   apply inv_dep with (m1 := m1) (m2 := m2); auto using req_mem_upd_disjoint.
   apply  equiv_lossless_Modify with (X1 := Vset.union I X1) (X2:=Vset.union I X2)
    (M1 := Vset.singleton v) (M2:=Vset.singleton v);
   auto using lossless_assign, Modify_assign, depend_only_req_mem_rel.
   apply disjoint_singleton.
   case_eq (Vset.mem v (Vset.union I X1)); intros; trivial.
   change (is_true (Vset.mem v (Vset.union I X1))) in H2.
   rewrite VsetP.union_spec, H, H1 in H2; destruct H2; trivialb.
   apply disjoint_singleton.
   case_eq (Vset.mem v (Vset.union I X2)); intros; trivial.
   change (is_true (Vset.mem v (Vset.union I X2))) in H2.
   rewrite VsetP.union_spec, H1, H0 in H2; destruct H2; trivialb.

   case_eq (Vset.mem v X1); intro; try (intros; discriminate).
   case_eq (Vset.mem v X2); intro; try (intros; discriminate).
   case_eq  (Vset.mem v O); intros H1 H2; unfold EqObsInv; inversion H2; clear H2; subst.
   eapply equiv_strengthen;[ | apply equiv_random].
   unfold req_mem_rel, kreq_mem, andR; intros k m1 m2 (H3,H4); split.
   unfold eq_support.
   apply EqObs_d_fv_expr.
   apply req_mem_weaken with (2:= H3); auto with set.
   intros; split.
   apply req_mem_weaken with (Vset.add v (Vset.remove v O)).
   rewrite VsetP.add_remove; auto with set.
   apply req_mem_update.
   apply req_mem_weaken with (2:= H3); auto with set.
   apply inv_dep with (m1 := m1) (m2 := m2); auto using req_mem_upd_disjoint.
   apply  equiv_lossless_Modify with (X1 := Vset.union I X1) (X2:=Vset.union I X2)
    (M1 := Vset.singleton v) (M2:=Vset.singleton v);
   auto using lossless_random, Modify_random, depend_only_req_mem_rel.
   apply disjoint_singleton.
   case_eq (Vset.mem v (Vset.union I X1)); intros; trivial.
   change (is_true (Vset.mem v (Vset.union I X1))) in H2.
   rewrite VsetP.union_spec, H, H1 in H2; destruct H2; trivialb.
   apply disjoint_singleton.
   case_eq (Vset.mem v (Vset.union I X2)); intros; trivial.
   change (is_true (Vset.mem v (Vset.union I X2))) in H2.
   rewrite VsetP.union_spec, H1, H0 in H2; destruct H2; trivialb.

   intro; discriminate.
  Qed.

 Lemma eqobsinv_in_i_correct_aux :
  (forall i O I,
   eqobsinv_in_i i O = Some I -> EqObsInv inv I E1 [i] E2 [i] O) /\
  forall c O I,
   List.fold_right (fun i => opt_app (eqobsinv_in_i i)) (Some O) c = Some I ->
   EqObsInv inv I E1 c E2 c O.
 Proof.
  apply I.cmd_ind2; simpl.
  intros; apply eqobsinv_in_b_nm_correct; trivial.
  (* Cond *)
  intros.
  assert (IH1 := H O); assert (IH2 := H0 O).
  destruct (fold_right (fun i : I.instr => opt_app (eqobsinv_in_i i)) (Some O) c1); try discriminate.
  destruct (fold_right (fun i : I.instr => opt_app (eqobsinv_in_i i)) (Some O) c2); try discriminate.
  inversion H1; clear H1; subst.
  red; apply equiv_cond.
  apply equiv_strengthen with (2:= IH1 _ (refl_equal _)).
  intros k m1 m2 (W1, (W2, W3)).
  eapply req_mem_rel_weaken; eauto.
  rewrite union_fv_expr_spec; auto with set.
  unfold Basics.flip; trivial.
  apply equiv_strengthen with (2:= IH2 _ (refl_equal _)).
  intros k m1 m2 (W1, (W2, W3)).
  eapply req_mem_rel_weaken; eauto.
  rewrite union_fv_expr_spec; auto with set.
  unfold Basics.flip; trivial.
  intros k m1 m2 (W1, W2).
  unfold kreq_mem in W1; rewrite union_fv_expr_spec in W1.
  apply EqObs_e_fv_expr.
  apply req_mem_weaken with (2:= W1); auto with set.
  (* While *)
  intros b c IH O I H0.
   set (P1 := fun X => Vset.union O (fv_expr b) [<=] X).
   set (P2 := fun res =>
    match res with
     | Continue X => P1 X
     | Result None => True
     | Result (Some X) => Vset.union O (fv_expr b) [<=] X /\  EqObsInv inv X E1 c E2 c X
    end).
   match type of H0 with
    | match ?t with
       | Result _ => _
       | Continue _ => _
      end = _ => cut (P2 t); [destruct t; try discriminate|]
   end.
   destruct o; [injection H0; clear H0; intro; subst | discriminate].
   unfold P2; clear P2 P1; intros [H1 H2].
   red; apply equiv_weaken with (req_mem_rel I inv).
    intros k m1 m2 W; apply req_mem_rel_weaken with (3:= W); auto.
    apply VsetP.subset_trans with (Vset.union O (fv_expr b)); auto with set.
   unfold Basics.flip; trivial.
   eapply equiv_strengthen;[ | eapply equiv_weaken;[ | apply equiv_while;
     [ | eapply equiv_strengthen; [ | apply H2 ] ] ] ]; unfold andR; try (simpl; tauto); intros.
   apply EqObs_e_fv_expr.
   destruct H as (W1, _); apply req_mem_weaken with (2:= W1); auto with set.
   apply VsetP.subset_trans with (Vset.union O (fv_expr b)); auto with set.

   (* Body of the loop *)
   apply while_P with P1; intros.
   unfold P1 in *; generalize (IH a); clear P1 IH; intros.
   destruct (fold_right (fun i : I.instr => opt_app (eqobsinv_in_i i)) (Some a)).
   assert (U:=H1 _ (refl_equal _)); clear H1.
   case_eq (t [<=?] a); intros; simpl.
   change (t [<=] a) in H1; split; auto.
   unfold EqObsInv in *; eapply equiv_strengthen;[ | apply U].
    intros k m1 m2 W1; apply req_mem_rel_weaken with (3:= W1); auto with set.
   unfold Basics.flip; trivial.
   apply VsetP.subset_trans with a; auto with set.
   simpl; trivial.
   exact H.
   unfold P1; auto with set.
   rewrite union_fv_expr_spec, VsetP.union_sym; auto with set.

  (* Call *)
  intros t0 x f a O I.
  case_eq (Vset.mem x X1); intro; try (intros; discriminate).
  case_eq (Vset.mem x X2); intro; try (intros; discriminate).
  destruct (pii f); try (intros; discriminate).
  case_eq (Vset.disjoint (Vset.diff O (Vset.add x (pii_output p)))
            (Vset.union (pi_mod (pi_eq_refl1 p)) (pi_mod (pi_eq_refl2 p)))); intro;
  try (intros; discriminate).
  case_eq (needed_args (proc_params E1 f) a (proc_params E2 f) a (pii_params p)
    (Vset.union (pii_input p) (Vset.diff O (Vset.add x (pii_output p))))); intros;
  try discriminate.
  inversion H3; clear H3; subst.
  destruct (needed_args_correct _ _ _ _ _ _ H2) as (W1, W2).
  red.
  apply equiv_call with
     (Pf:= req_mem_rel (Vset.union (pii_params p) (get_globals I)) inv)
     (Qf :=
       req_mem_rel (Vset.union (pii_output p)
              (Vset.diff (get_globals I)
                  (Vset.union (pi_mod (pi_eq_refl1 p))
                              (pi_mod (pi_eq_refl2 p)))))
        (inv /-\ (fun k m1 m2 => E.eval_expr (proc_res E1 f) m1 = E.eval_expr (proc_res E2 f) m2))).
  (* init *)
  unfold req_mem_rel, kreq_mem, andR; simpl; intros k m1 m2 (W3, W4).
  assert (init_mem E1 f a m1 =={ Vset.union (pii_params p) (get_globals I)} init_mem E2 f a m2).
  eapply EqObs_args_correct; eauto.
  split; trivial.
  unfold depend_only_rel in inv_dep.
  apply inv_dep with m1 m2; trivial; red; intros;
  rewrite init_mem_global; trivial; apply inv_global; rewrite VsetP.union_spec; auto.
  (* post *)
  unfold req_mem_rel, kreq_mem, andR; simpl; intros k m1 m1' m2 m2' (W3, W4) (W5, (W6, W7)); split.
  red; intros.
  destruct (Vset.ET.eq_dec x x0).
  inversion e; subst.
  apply T.inj_pair2 in H6; subst.
  repeat rewrite return_mem_dest; trivial.
  change (Var.mkV x <> x0) in n0.
  case_eq (Var.is_global x0); intros.
  repeat rewrite return_mem_global; trivial.
  apply W5.
  rewrite VsetP.union_spec, VsetP.diff_spec.
  case_eq (Vset.mem x0 (pii_output p)); intros; auto.
  assert (Vset.mem x0 (Vset.diff O (Vset.add x (pii_output p)))).
   rewrite VsetP.diff_spec, VsetP.add_spec, H5; intuition.
  right; split.
  apply get_globals_complete; auto.
  apply Vset.subset_correct with (1:= W2); auto with set.
  eapply VsetP.disjoint_mem_not_mem; eauto; trivial.
  repeat rewrite return_mem_local; unfold Var.is_local; try rewrite H4; trivial.
  apply W3.
  apply Vset.subset_correct with (1:= W2).
  rewrite VsetP.union_spec, VsetP.diff_spec, VsetP.add_spec.
  right; intuition.
  assert (U:= pii_output_global p _ H6); rewrite H4 in U; discriminate.
  red in inv_dep.
  apply inv_dep with m1' m2'; trivial; red; intros; rewrite return_mem_global; trivial.
  intros Heq; rewrite <-Heq, H in H3; discriminate.
  auto with set.
  intros Heq; rewrite <-Heq, H0 in H3; discriminate.
  auto with set.

  (* Body *)
  destruct (mod_spec (pi_eq_refl1 p)) as (L1, (T1,T2)).
  destruct (mod_spec (pi_eq_refl2 p)) as (L2, (T3,T4)).
  destruct (pii_spec p) as (ls, (H3,(H4,H5))).
  apply Modify_Modify_pre with (P := fun _ _ => True)in T2.
  apply Modify_Modify_pre with (P := fun _ _ => True)in T4.
  apply equiv_union_Modify_pre2 with (4:= T2) (5:= T4)
   (Q:= req_mem_rel (Vset.union ls (pii_output p)) inv); intros.
  auto.
  tauto.
  destruct H6; destruct H7; unfold kreq_mem in *.
  assert (m1' =={
            Vset.diff (get_globals I)
              (Vset.union (pi_mod (pi_eq_refl1 p)) (pi_mod (pi_eq_refl2 p)))}m2').
   red; intros.
   rewrite VsetP.diff_spec, VsetP.union_spec in H12.
   destruct H12.
   rewrite <- H8.
   rewrite <- H9.
   apply H6; rewrite VsetP.union_spec; tauto.
   rewrite VsetP.union_spec; intros [W | W]; try tauto.
   assert (V1 := T3 _ W); unfold Var.is_local in V1; rewrite (get_globals_spec _ _ H12) in V1;
    discriminate.
   rewrite VsetP.union_spec; intros [W | W]; try tauto.
   assert (V1 := T1 _ W); unfold Var.is_local in V1; rewrite (get_globals_spec _ _ H12) in V1;
    discriminate.
  split.
   unfold kreq_mem.
   apply req_mem_union; trivial.
   apply req_mem_weaken with (2:= H7); auto with set.
  split; trivial.
   apply H5.
   apply req_mem_union; trivial.
   apply req_mem_weaken with (2:= H12).
   apply VsetP.diff_le_compat; auto with set.
   apply Vset.subset_complete; intros.
   apply get_globals_complete.
   apply Vset.subset_correct with (1:= W2); auto with set.
   apply (iinput_global p); trivial.
  eapply equiv_strengthen;[ | apply H4].
  intros k m1 m2 (W3, W4); split; trivial.
  unfold kreq_mem; rewrite VsetP.union_sym.
  apply req_mem_weaken with (2:= W3).
  apply VsetP.subset_union_ctxt; auto with set.
   apply Vset.subset_complete; intros.
   apply get_globals_complete.
   apply Vset.subset_correct with (1:= W2); auto with set.
   apply (iinput_global p); trivial.

  (* nil and cons *)
  intros O I H; inversion H; red; apply equiv_nil.
  unfold EqObsInv; intros.
  generalize (H0 O); clear H0;
   destruct(fold_right (fun i : I.instr => opt_app (eqobsinv_in_i i)) (Some O) c);
   simpl in H1; try discriminate; intros.
  apply equiv_cons with (req_mem_rel t inv); auto.
 Qed.

 Lemma eqobsinv_in_i_correct : forall i O I,
  eqobsinv_in_i i O = Some I ->
  EqObsInv inv I E1 [i] E2 [i] O.
 Proof.
  destruct eqobsinv_in_i_correct_aux; trivial.
 Qed.

 (* [eqobsinv_out_i I i] computes the largest [O] such that [EqObs_i I i i O] *)
 Definition eqobsinv_out_b I (i:I.baseInstr) :=
  match i with
  | I.Assign t x e =>
    if Vset.mem x X1 then None
    else if Vset.mem x X2 then None
    else Some (if fv_expr e [<=?] I then Vset.add x I else Vset.remove x I)
  | I.Random t x d =>
    if Vset.mem x X1 then None
    else if Vset.mem x X2 then None
    else Some (if fv_distr d [<=?] I then Vset.add x I else Vset.remove x I)
  | I.IAssert e => None
  end.

 Section OUT.

  Variable eqobsinv_out_i : Vset.t -> I.instr -> option Vset.t.

  Fixpoint eqobsinv_out_aux (I:Vset.t) (c:cmd) {struct c} : option Vset.t :=
   match c with
   | nil => Some I
   | i::c =>
     match eqobsinv_out_i I i with
     | Some OI => eqobsinv_out_aux OI c
     | _ => None
     end
   end.

 End OUT.

 Fixpoint eqobsinv_out_i (I:Vset.t) (i:I.instr) {struct i}: option Vset.t :=
  match i with
  | I.Instr i => eqobsinv_out_b I i
  | I.Cond e c1 c2 =>
    if fv_expr e [<=?] I then
     match eqobsinv_out_aux eqobsinv_out_i I c1, eqobsinv_out_aux eqobsinv_out_i I c2 with
     | Some O1, Some O2 => Some (Vset.inter O1 O2)
     | _, _ => None
     end
     else None
  | I.While e c =>
    if fv_expr e [<=?] I then
     match eqobsinv_out_aux eqobsinv_out_i I c with
     | Some O' => if I [<=?] O' then Some I else None
     | _ => None
     end
    else None
  | I.Call t d f args =>
    if Vset.mem d X1 then None
     else if Vset.mem d X2 then None
     else
     let lv1 := proc_params E1 f in
     let lv2 := proc_params E2 f in
     match pii f with
     | Some pif =>
       match needed_args lv1 args lv2 args (pii_params pif) Vset.empty with
       | None => None
       | Some Ia =>
         if Ia [<=?] I then
          if (pii_input pif) [<=?] I then
           Some
             (Vset.union
                  (Vset.add d (pii_output pif))
                  (Vset.diff
                    (Vset.diff I (pi_mod (pi_eq_refl1 pif)))
                                  (pi_mod (pi_eq_refl2 pif))))
          else None
         else None
       end
     | None => None
     end
   end.

  Lemma eqobsinv_out_correct_aux :
   (forall i I O, eqobsinv_out_i I i = Some O ->
    EqObsInv inv I E1 [i] E2 [i] O) /\
   (forall c I O, eqobsinv_out_aux eqobsinv_out_i I c = Some O ->
    EqObsInv inv I E1 c E2 c O).
  Proof.
   unfold EqObsInv; apply I.cmd_ind2; simpl; intros.

   (* baseInstr *)
   generalize H; clear H.
   destruct i as [t x e | t x d | e]; simpl.

   case_eq (Vset.mem x X1); intro H1;
    [  intros; discriminate |
       case_eq (Vset.mem x X2); intros H2 H3; inversion H3; clear H3; subst].
   case_eq (fv_expr e[<=?]I); intros.
   eapply equiv_strengthen;[ | apply equiv_assign].
   unfold req_mem_rel, kreq_mem; intros k m1 m2 (H3, H4); split.
   rewrite (@EqObs_e_fv_expr t e k m1 m2).
   apply req_mem_update; trivial.
   apply req_mem_weaken with (2:= H3); auto with set.
   apply inv_dep with (m1 := m1) (m2 := m2); auto using req_mem_upd_disjoint.
   eapply equiv_strengthen;[ | apply equiv_lossless_Modify with
    (X1 := Vset.union (Vset.remove x I) X1) (X2:=Vset.union (Vset.remove x I) X2)
    (M1 := Vset.singleton x) (M2:=Vset.singleton x);
    auto using lossless_assign, Modify_assign, depend_only_req_mem_rel].
   intros k m1 m2 H3; apply req_mem_rel_weaken with (3 := H3); auto with set.
   unfold Basics.flip; trivial.
   apply disjoint_singleton.
   case_eq (Vset.mem x (Vset.union (Vset.remove x I) X1)); intros; trivial.
   change (is_true (Vset.mem x (Vset.union (Vset.remove x I) X1))) in H0.
   rewrite VsetP.union_spec, VsetP.remove_spec, H1 in H0.
   intuition.
   elim H4; trivial.
   apply disjoint_singleton.
   case_eq (Vset.mem x (Vset.union (Vset.remove x I) X2)); intros; trivial.
   change (is_true (Vset.mem x (Vset.union (Vset.remove x I) X2))) in H0.
   rewrite VsetP.union_spec, VsetP.remove_spec, H2 in H0.
   intuition.
   elim H4; trivial.

   case_eq (Vset.mem x X1); intro H1;
    [  intros; discriminate |
       case_eq (Vset.mem x X2); intros H2 H3; inversion H3; clear H3; subst].
   case_eq (fv_distr d[<=?]I); intros.
   eapply equiv_strengthen;[ | apply equiv_random].
   unfold req_mem_rel, kreq_mem; intros k m1 m2 (H3, H4); split.
   unfold eq_support.
   apply EqObs_d_fv_expr.
   apply req_mem_weaken with (2:= H3); auto with set.
   intros; split.
   apply req_mem_update.
   apply req_mem_weaken with (2:= H3); auto with set.
   apply inv_dep with (m1 := m1) (m2 := m2); auto using req_mem_upd_disjoint.
   eapply equiv_strengthen ;
    [ | apply equiv_lossless_Modify with (X1 := Vset.union (Vset.remove x I) X1)
    (X2:=Vset.union  (Vset.remove x I) X2)
    (M1 := Vset.singleton x) (M2:=Vset.singleton x);
   auto using lossless_random, Modify_random, depend_only_req_mem_rel].
   intros k m1 m2 H3; apply req_mem_rel_weaken with (3 := H3); auto with set.
   unfold Basics.flip; trivial.
   apply disjoint_singleton.
   case_eq (Vset.mem x (Vset.union (Vset.remove x I) X1)); intros; trivial.
   change (is_true (Vset.mem x (Vset.union (Vset.remove x I) X1))) in H0.
   rewrite VsetP.union_spec, VsetP.remove_spec, H1 in H0.
   intuition.
   elim H4; trivial.
   apply disjoint_singleton.
   case_eq (Vset.mem x (Vset.union (Vset.remove x I) X2)); intros; trivial.
   change (is_true (Vset.mem x (Vset.union (Vset.remove x I) X2))) in H0.
   rewrite VsetP.union_spec, VsetP.remove_spec, H2 in H0.
   intuition.
   elim H4; trivial.

   intro; discriminate.
   (* cond *)
   case_eq (fv_expr b[<=?]I); intro Heq; rewrite Heq in H1; try discriminate.
   generalize (H I) (H0 I).
   destruct (eqobsinv_out_aux eqobsinv_out_i I c1); try discriminate.
   destruct (eqobsinv_out_aux eqobsinv_out_i I c2); try discriminate.
   inversion H1; clear H1; subst; intros.
   apply equiv_cond.
   eapply equiv_strengthen;[ | eapply equiv_weaken; [ | apply H1; reflexivity] ].
   unfold andR; tauto.
   intros; eapply req_mem_rel_weaken; eauto; auto with set.
   unfold Basics.flip; trivial.
   eapply equiv_strengthen;[ | eapply equiv_weaken; [ | apply H2; reflexivity] ].
   unfold andR; tauto.
   intros; eapply req_mem_rel_weaken; eauto; auto with set.
   unfold Basics.flip; trivial.
   intros k m1 m2 (H3, H4); apply EqObs_e_fv_expr.
   apply req_mem_weaken with (2:= H3); trivial.
   (* While *)
   case_eq (fv_expr b[<=?]I); intro Heq; rewrite Heq in H0; try discriminate.
   generalize (H I);   destruct (eqobsinv_out_aux eqobsinv_out_i I c); try discriminate.
   case_eq (I[<=?]t); intro Heq2; rewrite Heq2 in H0; try discriminate.
   inversion H0; clear H0; subst; intros.
   eapply equiv_weaken;[ | apply equiv_while].
   unfold andR; tauto.
   intros k m1 m2 (H3, H4); apply EqObs_e_fv_expr.
   apply req_mem_weaken with (2:= H3); trivial.
   eapply equiv_strengthen;[ | eapply equiv_weaken; [ | apply H0; reflexivity] ].
   unfold andR; tauto.
   change (O[<=]t) in Heq2; intros; eapply req_mem_rel_weaken; eauto with set.
   unfold Basics.flip; trivial.
   (* Function *)
   generalize H; clear H.
   case_eq (Vset.mem x X1); intro; try (intros; discriminate).
   case_eq (Vset.mem x X2); intro; try (intros; discriminate).
   destruct (pii f); try (intros; discriminate).
   case_eq (needed_args (proc_params E1 f) a (proc_params E2 f) a (pii_params p)
     Vset.empty); try (intros; discriminate).
   intros Ia H1; case_eq (Ia[<=?]I); intro; try (intros; discriminate).
   destruct (needed_args_correct _ _ _ _ _ _ H1) as (W1, W2).
   case_eq (pii_input p[<=?]I); intros; try discriminate.
   inversion H4; clear H4; subst.
   apply equiv_call with
     (Pf:= req_mem_rel (Vset.union (pii_params p) (get_globals I)) inv)
     (Qf :=
       req_mem_rel (Vset.union (pii_output p)
              (Vset.diff (get_globals I)
                  (Vset.union (pi_mod (pi_eq_refl1 p))
                              (pi_mod (pi_eq_refl2 p)))))
       (inv  /-\ (fun k m1 m2 =>
       E.eval_expr (proc_res E1 f) m1 = E.eval_expr (proc_res E2 f) m2))).
  (* init *)
  unfold req_mem_rel, kreq_mem, andR; simpl; intros k m1 m2 (W3, W4).
  assert (init_mem E1 f a m1 =={ Vset.union (pii_params p) (get_globals I)} init_mem E2 f a m2).
    eapply EqObs_args_correct; eauto.
    eapply EqObs_args_strengthen with Ia; eauto; trivial.
  unfold depend_only_rel in inv_dep.
  split; trivial.
  apply inv_dep with m1 m2; trivial; red; intros;
  rewrite init_mem_global; trivial; apply inv_global; rewrite VsetP.union_spec; auto.
  (* post *)
  unfold req_mem_rel, kreq_mem, andR; simpl; intros k m1 m1' m2 m2' (W3, W4) (W5, (W6, W7)); split.
  red; intros.
  destruct (Vset.ET.eq_dec x x0).
  inversion e; subst; simpl.
  repeat rewrite return_mem_dest; trivial.
  change (Var.mkV x <> x0) in n0.
  case_eq (Var.is_global x0); intros.
  repeat rewrite return_mem_global; trivial.
  apply W5.
  rewrite VsetP.union_spec, VsetP.diff_spec in H4 |- *.
  destruct H4.
  rewrite VsetP.add_spec in H4; destruct H4; auto.
  elim (n0 H4).
  rewrite VsetP.diff_spec in H4; rewrite VsetP.union_spec; right; intuition.
  apply get_globals_complete; trivial.
  repeat rewrite return_mem_local; unfold Var.is_local; try rewrite H4; trivial.
  apply W3.
  rewrite VsetP.union_spec, VsetP.add_spec, VsetP.diff_spec in H4; intuition.
  rewrite (pii_output_global p _ H4) in H5; discriminate.
  rewrite VsetP.diff_spec in H4; intuition.
  rewrite H5; trivial. rewrite H5; trivial.
  red in inv_dep.
  apply inv_dep with m1' m2'; trivial; red; intros; rewrite return_mem_global; trivial.
  intros Heq; rewrite <-Heq, H in H4; discriminate.
  auto with set.
  intros Heq; rewrite <-Heq, H0 in H4; discriminate.
  auto with set.
  (* body *)
  destruct (mod_spec (pi_eq_refl1 p)) as (L1, (T1,T2)).
  destruct (mod_spec (pi_eq_refl2 p)) as (L2, (T3,T4)).
  destruct (pii_spec p) as (ls, (H6,(H4,H5))).
  apply Modify_Modify_pre with (P := fun _ _ => True)in T2.
  apply Modify_Modify_pre with (P := fun _ _ => True)in T4.
  apply equiv_union_Modify_pre2 with (4:= T2) (5:= T4)
   (Q:= req_mem_rel (Vset.union ls (pii_output p)) inv); intros.
  auto.
  tauto.
  destruct H7; destruct H8; unfold kreq_mem in *.
  assert (m1' =={
            Vset.diff (get_globals I)
              (Vset.union (pi_mod (pi_eq_refl1 p)) (pi_mod (pi_eq_refl2 p)))}m2').
   red; intros.
   rewrite VsetP.diff_spec, VsetP.union_spec in H13.
   destruct H13.
   rewrite <- H9.
   rewrite <- H10.
   apply H7; rewrite VsetP.union_spec; tauto.
   rewrite VsetP.union_spec; intros [W | W]; try tauto.
   assert (V1 := T3 _ W); unfold Var.is_local in V1; rewrite (get_globals_spec _ _ H13) in V1;
    discriminate.
   rewrite VsetP.union_spec; intros [W | W]; try tauto.
   assert (V1 := T1 _ W); unfold Var.is_local in V1; rewrite (get_globals_spec _ _ H13) in V1;
    discriminate.
  split.
   unfold kreq_mem; apply req_mem_union; trivial.
   apply req_mem_weaken with (2:= H8); auto with set.
  split; trivial; apply H5.
   apply req_mem_union; trivial.
   apply req_mem_weaken with (2:= H13).
   apply VsetP.diff_le_compat; auto with set.
   apply Vset.subset_complete; intros.
   apply get_globals_complete.
   apply Vset.subset_correct with (1:= H3); auto with set.
   apply (iinput_global p); trivial.
  eapply equiv_strengthen;[ | apply H4].
  intros k m1 m2 (W3, W4); split; trivial.
  unfold kreq_mem; rewrite VsetP.union_sym.
  apply req_mem_weaken with (2:= W3).
  apply VsetP.subset_union_ctxt; auto with set.
   apply Vset.subset_complete; intros.
   apply get_globals_complete.
   apply Vset.subset_correct with (1:= H3); auto with set.
   apply (iinput_global p); trivial.

  (* nil and cons *)
  inversion H; apply equiv_nil.
  unfold EqObsInv; intros.
  generalize (H I); clear H; destruct(eqobsinv_out_i I i); simpl in H1; try discriminate; intros.
  apply equiv_cons with (req_mem_rel t inv); auto.
 Qed.

 Lemma eqobsinv_out_i_correct: forall i I O,
  eqobsinv_out_i I i = Some O ->
  EqObsInv inv I E1 [i] E2 [i] O.
 Proof.
  destruct eqobsinv_out_correct_aux; trivial.
 Qed.

 (* Reducing the context *)
 Fixpoint eqobsinv_context_rev_n (n:nat) (cr cr':cmd) (O:Vset.t) {struct n} :
  triple cmd cmd Vset.t :=
  match n, cr, cr' with
  | S n, i::cr1, i'::cr1' =>
    if I.eqb i i' then
     match eqobsinv_in_i i O with
     | Some IO => eqobsinv_context_rev_n n cr1 cr1' IO
     | None => Triple (List.rev' cr) (List.rev' cr') O
     end
     else Triple (List.rev' cr) (List.rev' cr') O
  | _, _, _ => Triple (List.rev' cr) (List.rev' cr') O
  end.

 Definition eqobsinv_context_tail_n n (c c':cmd) O :=
  eqobsinv_context_rev_n n (List.rev' c) (List.rev' c') O.

 Fixpoint eqobsinv_context_head_n (n:nat) (I:Vset.t) (c c':cmd) {struct n} :
  triple Vset.t cmd cmd :=
  match n, c, c' with
  | S n, i::c1, i'::c1' =>
    if I.eqb i i' then
     match eqobsinv_out_i I i with
     | Some OI => eqobsinv_context_head_n n OI c1 c1'
     | _ => Triple I c c'
     end
    else Triple I c c'
  | _, _, _ => Triple I c c'
  end.

 Lemma eqobsinv_context_rev_n_correct : forall n1 cr1 cr2 O h1 h2 IO,
  eqobsinv_context_rev_n n1 cr1 cr2 O = Triple h1 h2 IO ->
  exists t,
   (rev cr1) = h1++t /\
   (rev cr2) = h2++t /\
   EqObsInv inv IO E1 t E2 t O.
 Proof.
   induction n1; simpl.
   (* 0 *)
   intros cr1 cr2 O h1 h2 IO Heq; inversion_clear Heq.
   exists (@nil I.t); repeat split; auto.
   rewrite <- app_nil_end; exact (rev_alt cr1).
   rewrite <- app_nil_end; exact (rev_alt cr2).
   red; apply equiv_nil.

   (* S n1 *)
   destruct cr1 as [ |a cr1].

   (* nil, c2 *)
   intros cr2 nO h1 h2 IO Heq; inversion_clear Heq.
   exists (@nil I.t); repeat split; auto.
   rewrite <- app_nil_end; exact (rev_alt cr2).
   red; apply equiv_nil.

   destruct cr2; simpl; intros O h1 h2 IO.
   (* _, nil *)
   intros Heq; inversion_clear Heq.
   exists (@nil I.t); repeat split; auto.
   rewrite <- app_nil_end.
   change (rev cr1 ++ [a]) with (rev (a::cr1)).
   rewrite rev_alt; trivial.
   red; apply equiv_nil.

   (* a::c1, t::c2 *)
   case_eq (I.eqb a i); intro Heq'.
   case_eq (eqobsinv_in_i a O).
   intros I' Heq1 Heq2.
   destruct (IHn1 _ _ _ _ _ _ Heq2) as (tl, (V1, (V2, V3))); subst.
   exists (tl ++ [a]); repeat split.
   rewrite V1; apply app_ass.
   assert (W:= I.eqb_spec a i); rewrite Heq' in W; rewrite W, V2; apply app_ass.
   red; apply equiv_app with (req_mem_rel I' inv); trivial.
   apply (@eqobsinv_in_i_correct _ _ _ Heq1).
   intros H1 H2; inversion H2; clear H2; subst.

   exists (@nil I.t); repeat split; auto.
   rewrite <- app_nil_end.
   change (rev cr1 ++ [a]) with (rev (a::cr1)).
   rewrite rev_alt; trivial.
   rewrite <- app_nil_end.
   change (rev cr2 ++ [i]) with (rev (i::cr2)).
   rewrite rev_alt; trivial.
   red; apply equiv_nil.

   intros Heq; inversion Heq; clear Heq; subst.
   exists (@nil I.t); repeat split; auto.
   rewrite <- app_nil_end.
   change (rev cr1 ++ [a]) with (rev (a::cr1)).
   rewrite rev_alt; trivial.
   rewrite <-app_nil_end.
   change (rev cr2 ++ [i]) with (rev (i::cr2)).
   rewrite rev_alt; trivial.
   red; apply equiv_nil.
  Qed.

  Lemma eqobsinv_context_tail_n_correct :  forall n1 P c1 c2 O h1 h2 IO,
   eqobsinv_context_tail_n n1 c1 c2 O = Triple h1 h2 IO ->
   equiv P E1 h1 E2 h2 (req_mem_rel IO inv) ->
   equiv P E1 c1 E2 c2 (req_mem_rel O inv).
  Proof.
   intros.
   destruct (eqobsinv_context_rev_n_correct  _ _ _ _ H) as [t [H1 [H2 H3] ] ].
   unfold rev' in H1, H2.
   rewrite <- rev_alt in H1, H2.
   rewrite rev_involutive in H1, H2; subst.
   red; apply equiv_app with (req_mem_rel IO inv); trivial.
  Qed.

  Lemma eqobsinv_context_head_n_correct_aux : forall N I c1 c2 t1 t2 IO,
   eqobsinv_context_head_n N I c1 c2 = Triple IO t1 t2 ->
   exists h, c1 = h ++ t1 /\ c2 = h ++ t2 /\ EqObsInv inv I E1 h E2 h IO.
  Proof.
   induction N; simpl; intros I c1 c2 t1 t2 IO.
   (* 0 *)
   intros Heq; inversion Heq; exists (@nil I.t); repeat split.
   red; apply equiv_nil.
   (* S n *)
   destruct c1.
   intros Heq; inversion Heq; exists (@nil I.t); repeat split.
   red; apply equiv_nil.
   destruct c2.
   intros Heq; inversion Heq; exists (@nil I.t); repeat split.
   red; apply equiv_nil.
   (* t::c1, t0::c2 *)
   case_eq (I.eqb i i0); intros H.
   assert (H0 := I.eqb_spec i i0); rewrite H in H0; clear H; subst.
   case_eq (eqobsinv_out_i I i0); [intros OI Heqi | intros Heqi].
   intros Heq; destruct (IHN _ _ _ _ _ _ Heq) as [h [H1 [H2 H3] ] ]; subst.
   exists (i0::h); repeat split; auto.
   red; apply equiv_cons with (req_mem_rel OI inv); auto.
   apply eqobsinv_out_i_correct; trivial.
   intros Heq; inversion Heq; exists (@nil I.t); repeat split.
   red; apply equiv_nil.
   intros Heq; inversion Heq; exists (@nil I.t); repeat split.
   red; apply equiv_nil.
  Qed.

  Lemma eqobsinv_context_head_n_correct : forall n I Q c1 c2 t1 t2 IO,
   eqobsinv_context_head_n n I c1 c2 = Triple IO t1 t2 ->
   equiv (req_mem_rel IO inv) E1 t1 E2 t2 Q->
   equiv (req_mem_rel I inv) E1 c1 E2 c2 Q.
  Proof.
   intros.
   destruct (eqobsinv_context_head_n_correct_aux _ _ _ _ H) as [h [H1 [H2 H3] ] ].
   subst; red; apply equiv_app with (req_mem_rel IO inv); auto.
  Qed.

 End EqObsInv_IN_NM.

 Section WRAPPER.

  Variable n : positive.
  Variable inv : mem_rel.
  Variables E1 E2 : env.
  Variable pii : eq_inv_info inv E1 E2.

  (* [eqobsinv_in i O] compute the smallest [I] such that [Eqobsinv_i I i i O] *)
  Definition eqobsinv_in c O :=
    match pii with
    | Build_eq_inv_info X1 X2 _ _ _ pio =>
      List.fold_right
       (fun i => opt_app (@eqobsinv_in_i n inv E1 E2 X1 X2 pio i)) (Some O) c
    end.

  Lemma eqobsinv_in_correct : forall c O I,
   eqobsinv_in c O = Some I ->
   EqObsInv inv I E1 c E2 c O.
  Proof.
   unfold eqobsinv_in; destruct pii.
   destruct (eqobsinv_in_i_correct_aux n pii_info0 pii_inv_dep0 pii_inv_global0);
    trivial.
  Qed.

  Definition eqobsinv_out :=
   match pii with
   | Build_eq_inv_info X1 X2 _ _ _ pio =>
     eqobsinv_out_aux (@eqobsinv_out_i inv E1 E2 X1 X2 pio)
   end.

  Lemma eqobsinv_out_correct: forall c I O,
   eqobsinv_out I c = Some O ->
   EqObsInv inv I E1 c E2 c O.
  Proof.
   unfold eqobsinv_out; destruct pii.
   destruct (eqobsinv_out_correct_aux pii_info0 pii_inv_dep0 pii_inv_global0);
    trivial.
  Qed.

  Definition eqobsinv_tail_n p c1 c2 O :=
   match pii with
   | Build_eq_inv_info X1 X2 _ _ _ pio =>
     @eqobsinv_context_tail_n n inv E1 E2 X1 X2 pio p c1 c2 O
   end.

  Definition eqobsinv_tail c1 c2 O := eqobsinv_tail_n (length c1) c1 c2 O.

  Definition eqobsinv_head_n p I c1 c2 :=
    match pii with
    | Build_eq_inv_info X1 X2 _ _ _ pio =>
      @eqobsinv_context_head_n inv E1 E2 X1 X2 pio p I c1 c2
    end.

  Definition eqobsinv_head I c1 c2 := eqobsinv_head_n (length c1) I c1 c2.

  Definition eqobsinv_context I c c' O :=
   let (I1, c1, c1') := eqobsinv_head I c c' in
   let (c2, c2', O2) := eqobsinv_tail c1 c1' O in
    Quad I1 c2 c2' O2.

  Lemma eqobsinv_tail_n_correct : forall p P c1 c2 O h1 h2 IO,
   eqobsinv_tail_n p c1 c2 O = Triple h1 h2 IO ->
   equiv P E1 h1 E2 h2 (req_mem_rel IO inv) ->
   equiv P E1 c1 E2 c2 (req_mem_rel O inv).
  Proof.
   unfold eqobsinv_tail_n; destruct pii.
   apply eqobsinv_context_tail_n_correct; trivial.
  Qed.

  Lemma eqobsinv_tail_correct : forall P c1 c2 O h1 h2 IO,
   eqobsinv_tail c1 c2 O = Triple h1 h2 IO ->
   equiv P E1 h1 E2 h2 (req_mem_rel IO inv) ->
   equiv P E1 c1 E2 c2 (req_mem_rel O inv).
  Proof.
   intros P c1.
   exact (@eqobsinv_tail_n_correct (length c1) P c1).
  Qed.

  Lemma eqobsinv_head_n_correct : forall p I Q c1 c2 t1 t2 IO,
   eqobsinv_head_n p I c1 c2 = Triple IO t1 t2 ->
   equiv (req_mem_rel IO inv) E1 t1 E2 t2 Q ->
   equiv (req_mem_rel I inv) E1 c1 E2 c2 Q.
  Proof.
   unfold eqobsinv_head_n; destruct pii.
   apply eqobsinv_context_head_n_correct; trivial.
  Qed.

  Lemma eqobsinv_head_correct : forall I Q c1 c2 t1 t2 IO,
   eqobsinv_head I c1 c2 = Triple IO t1 t2 ->
   equiv (req_mem_rel IO inv) E1 t1 E2 t2 Q ->
   equiv (req_mem_rel I inv) E1 c1 E2 c2 Q.
  Proof.
   intros I Q c1.
   exact (@eqobsinv_head_n_correct (length c1) I Q c1).
  Qed.

  Lemma eqobsinv_context_correct : forall I c1 c2 O I' c1' c2' O',
   eqobsinv_context I c1 c2 O = Quad I' c1' c2' O' ->
   EqObsInv inv I' E1 c1' E2 c2' O' ->
   EqObsInv inv I E1 c1 E2 c2 O.
  Proof.
   unfold eqobsinv_context; intros I c1 c2 O I' c1' c2' O'.
   case_eq (eqobsinv_head I c1 c2); intros t0 c c0 Heq.
   case_eq (eqobsinv_tail c c0 O); intros.
   inversion H0; clear H0; subst.
   refine (@eqobsinv_head_correct  _ _ _ _ _ _ _ Heq _).
   apply (@eqobsinv_tail_correct  _ _ _ _ _ _ _ H H1).
  Qed.

 End WRAPPER.

End Make.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Automatic Coercions Import.
Set Implicit Arguments.
Unset Strict Implicit.
Require Export Zring.
Section Int_power.
Variable G : GROUP.
Set Strict Implicit.
Unset Implicit Arguments.

Definition group_square (x : G) : G := sgroup_law G x x.
Set Implicit Arguments.
Unset Strict Implicit.

Fixpoint group_power_pos (g : G) (p : positive) {struct p} : G :=
  match p with
  | xH => g
  | xO p' => group_square (group_power_pos g p')
  | xI p' => sgroup_law G (group_square (group_power_pos g p')) g
  end.
Set Strict Implicit.
Unset Implicit Arguments.

Definition group_power (g : G) (z : ZZ) : G :=
  match z with
  | Z0 => monoid_unit G
  | Zpos p => group_power_pos g p
  | Zneg p => group_power_pos (group_inverse G g) p
  end.
Set Implicit Arguments.
Unset Strict Implicit.
End Int_power.
Section Lemmas.
Variable G : GROUP.

Lemma group_power_zero :
 forall g : G, Equal (group_power G g (monoid_unit ZZ)) (monoid_unit G).
intros g; simpl in |- *; auto with algebra.
Qed.

Parameter
  group_power_S :
    forall (g : G) (n : ZZ),
    Equal (group_power G g (sgroup_law ZZ n (ring_unit ZZ)))
      (sgroup_law G (group_power G g n) g).
End Lemmas.
Hint Resolve group_power_zero group_power_S: algebra.


From iris.algebra Require Export ofe.
From iris.prelude Require Import options.

Record solution (F : oFunctor) := Solution {
  solution_car :> ofe;
  solution_cofe : Cofe solution_car;
  solution_iso :> ofe_iso (oFunctor_apply F solution_car) solution_car;
}.
Existing Instance solution_cofe.

Module solver. Section solver.
Context (F : oFunctor) `{Fcontr : oFunctorContractive F}.
Context `{Fcofe : ∀ (T : ofe) `{!Cofe T}, Cofe (oFunctor_apply F T)}.
Context `{Finh : Inhabited (oFunctor_apply F unitO)}.
Notation map := (oFunctor_map F).

Fixpoint A' (k : nat) : { C : ofe & Cofe C } :=
  match k with
  | 0 => existT (P:=Cofe) unitO _
  | S k => existT (P:=Cofe) (@oFunctor_apply F (projT1 (A' k)) (projT2 (A' k))) _
  end.
Notation A k := (projT1 (A' k)).
Local Instance A_cofe k : Cofe (A k) := projT2 (A' k).

Fixpoint f (k : nat) : A k -n> A (S k) :=
  match k with 0 => OfeMor (λ _, inhabitant) | S k => map (g k,f k) end
with g (k : nat) : A (S k) -n> A k :=
  match k with 0 => OfeMor (λ _, ()) | S k => map (f k,g k) end.
Definition f_S k (x : A (S k)) : f (S k) x = map (g k,f k) x := eq_refl.
Definition g_S k (x : A (S (S k))) : g (S k) x = map (f k,g k) x := eq_refl.
Global Arguments f : simpl never.
Global Arguments g : simpl never.

Lemma gf {k} (x : A k) : g k (f k x) ≡ x.
Proof using Fcontr.
  induction k as [|k IH]; simpl in *; [by destruct x|].
  rewrite -oFunctor_map_compose -{2}[x]oFunctor_map_id.
  by apply (contractive_proper map).
Qed.
Lemma fg {k} (x : A (S (S k))) : f (S k) (g (S k) x) ≡{k}≡ x.
Proof using Fcontr.
  induction k as [|k IH]; simpl.
  - rewrite f_S g_S -{2}[x]oFunctor_map_id -oFunctor_map_compose.
    apply (contractive_0 map).
  - rewrite f_S g_S -{2}[x]oFunctor_map_id -oFunctor_map_compose.
    by apply (contractive_S map).
Qed.

Record tower := {
  tower_car k :> A k;
  g_tower k : g k (tower_car (S k)) ≡ tower_car k
}.
Global Instance tower_equiv : Equiv tower := λ X Y, ∀ k, X k ≡ Y k.
Global Instance tower_dist : Dist tower := λ n X Y, ∀ k, X k ≡{n}≡ Y k.
Definition tower_ofe_mixin : OfeMixin tower.
Proof.
  split.
  - intros X Y; split; [by intros HXY n k; apply equiv_dist|].
    intros HXY k; apply equiv_dist; intros n; apply HXY.
  - intros k; split.
    + by intros X n.
    + by intros X Y ? n.
    + by intros X Y Z ?? n; trans (Y n).
  - intros k X Y HXY n; apply dist_S.
    by rewrite -(g_tower X) (HXY (S n)) g_tower.
Qed.
Definition T : ofe := Ofe tower tower_ofe_mixin.

Program Definition tower_chain (c : chain T) (k : nat) : chain (A k) :=
  {| chain_car i := c i k |}.
Next Obligation. intros c k n i ?; apply (chain_cauchy c n); lia. Qed.
Program Definition tower_compl : Compl T := λ c,
  {| tower_car n := compl (tower_chain c n) |}.
Next Obligation.
  intros c k; apply equiv_dist=> n.
  by rewrite (conv_compl n (tower_chain c k))
    (conv_compl n (tower_chain c (S k))) /= (g_tower (c _) k).
Qed.
Global Program Instance tower_cofe : Cofe T := { compl := tower_compl }.
Next Obligation.
  intros n c k; rewrite /= (conv_compl n (tower_chain c k)).
  apply (chain_cauchy c); lia.
Qed.

Fixpoint ff {k} (i : nat) : A k -n> A (i + k) :=
  match i with 0 => cid | S i => f (i + k) ◎ ff i end.
Fixpoint gg {k} (i : nat) : A (i + k) -n> A k :=
  match i with 0 => cid | S i => gg i ◎ g (i + k) end.
Lemma ggff {k i} (x : A k) : gg i (ff i x) ≡ x.
Proof using Fcontr. induction i as [|i IH]; simpl; [done|by rewrite (gf (ff i x)) IH]. Qed.
Lemma f_tower k (X : tower) : f (S k) (X (S k)) ≡{k}≡ X (S (S k)).
Proof using Fcontr. intros. by rewrite -(fg (X (S (S k)))) -(g_tower X). Qed.
Lemma ff_tower k i (X : tower) : ff i (X (S k)) ≡{k}≡ X (i + S k).
Proof using Fcontr.
  intros; induction i as [|i IH]; simpl; [done|].
  by rewrite IH Nat.add_succ_r (dist_le _ _ _ _ (f_tower _ X)); last lia.
Qed.
Lemma gg_tower k i (X : tower) : gg i (X (i + k)) ≡ X k.
Proof. by induction i as [|i IH]; simpl; [done|rewrite g_tower IH]. Qed.

Global Instance tower_car_ne k : NonExpansive (λ X, tower_car X k).
Proof. by intros X Y HX. Qed.
Definition project (k : nat) : T -n> A k := OfeMor (λ X : T, tower_car X k).

Definition coerce {i j} (H : i = j) : A i -n> A j :=
  eq_rect _ (λ i', A i -n> A i') cid _ H.
Lemma coerce_id {i} (H : i = i) (x : A i) : coerce H x = x.
Proof. unfold coerce. by rewrite (proof_irrel H (eq_refl i)). Qed.
Lemma coerce_proper {i j} (x y : A i) (H1 H2 : i = j) :
  x = y → coerce H1 x = coerce H2 y.
Proof. by destruct H1; rewrite !coerce_id. Qed.
Lemma g_coerce {k j} (H : S k = S j) (x : A (S k)) :
  g j (coerce H x) = coerce (Nat.succ_inj _ _ H) (g k x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma coerce_f {k j} (H : S k = S j) (x : A k) :
  coerce H (f k x) = f j (coerce (Nat.succ_inj _ _ H) x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma gg_gg {k i i1 i2 j} : ∀ (H1: k = i + j) (H2: k = i2 + (i1 + j)) (x: A k),
  gg i (coerce H1 x) = gg i1 (gg i2 (coerce H2 x)).
Proof.
  intros Hij -> x. assert (i = i2 + i1) as -> by lia. revert j x Hij.
  induction i2 as [|i2 IH]; intros j X Hij; simplify_eq/=;
    [by rewrite coerce_id|by rewrite g_coerce IH].
Qed.
Lemma ff_ff {k i i1 i2 j} : ∀ (H1: i + k = j) (H2: i1 + (i2 + k) = j) (x: A k),
  coerce H1 (ff i x) = coerce H2 (ff i1 (ff i2 x)).
Proof.
  intros ? <- x. assert (i = i1 + i2) as -> by lia.
  induction i1 as [|i1 IH]; simplify_eq/=;
    [by rewrite coerce_id|by rewrite coerce_f IH].
Qed.

Definition embed_coerce {k} (i : nat) : A k -n> A i :=
  match le_lt_dec i k with
  | left H => gg (k-i) ◎ coerce (eq_sym (Nat.sub_add _ _ H))
  | right H => coerce (Nat.sub_add k i (Nat.lt_le_incl _ _ H)) ◎ ff (i-k)
  end.
Lemma g_embed_coerce {k i} (x : A k) :
  g i (embed_coerce (S i) x) ≡ embed_coerce i x.
Proof using Fcontr.
  unfold embed_coerce; destruct (le_lt_dec (S i) k), (le_lt_dec i k); simpl.
  - symmetry; by erewrite (@gg_gg _ _ 1 (k - S i)); simpl.
  - exfalso; lia.
  - assert (i = k) by lia; subst.
    rewrite (ff_ff _ (eq_refl (1 + (0 + k)))) /= gf.
    by rewrite (gg_gg _ (eq_refl (0 + (0 + k)))).
  - assert (H : 1 + ((i - k) + k) = S i) by lia.
    rewrite (ff_ff _ H) /= -{2}(gf (ff (i - k) x)) g_coerce.
    by erewrite coerce_proper by done.
Qed.
Program Definition embed (k : nat) (x : A k) : T :=
  {| tower_car n := embed_coerce n x |}.
Next Obligation. intros k x i. apply g_embed_coerce. Qed.
Global Instance: Params (@embed) 1 := {}.
Global Instance embed_ne k : NonExpansive (embed k).
Proof. by intros n x y Hxy i; rewrite /= Hxy. Qed.
Definition embed' (k : nat) : A k -n> T := OfeMor (embed k).
Lemma embed_f k (x : A k) : embed (S k) (f k x) ≡ embed k x.
Proof.
  rewrite equiv_dist=> n i; rewrite /embed /= /embed_coerce.
  destruct (le_lt_dec i (S k)), (le_lt_dec i k); simpl.
  - assert (H : S k = S (k - i) + (0 + i)) by lia; rewrite (gg_gg _ H) /=.
    by erewrite g_coerce, gf, coerce_proper by done.
  - assert (S k = 0 + (0 + i)) as H by lia.
    rewrite (gg_gg _ H); simplify_eq/=.
    by rewrite (ff_ff _ (eq_refl (1 + (0 + k)))).
  - exfalso; lia.
  - assert (H : (i - S k) + (1 + k) = i) by lia; rewrite (ff_ff _ H) /=.
    by erewrite coerce_proper by done.
Qed.
Lemma embed_tower k (X : T) : embed (S k) (X (S k)) ≡{k}≡ X.
Proof.
  intros i; rewrite /= /embed_coerce.
  destruct (le_lt_dec i (S k)) as [H|H]; simpl.
  - rewrite -(gg_tower i (S k - i) X).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct (eq_sym _).
  - rewrite (ff_tower k (i - S k) X). by destruct (Nat.sub_add _ _ _).
Qed.

Program Definition unfold_chain (X : T) : chain (oFunctor_apply F T) :=
  {| chain_car n := map (project n,embed' n) (X (S n)) |}.
Next Obligation.
  intros X n i Hi.
  assert (∃ k, i = k + n) as [k ?] by (exists (i - n); lia); subst; clear Hi.
  induction k as [|k IH]; simpl; first done.
  rewrite -IH -(dist_le _ _ _ _ (f_tower (k + n) _)); last lia.
  rewrite f_S -oFunctor_map_compose.
  by apply (contractive_ne map); split=> Y /=; rewrite ?g_tower ?embed_f.
Qed.
Definition unfold (X : T) : oFunctor_apply F T := compl (unfold_chain X).
Global Instance unfold_ne : NonExpansive unfold.
Proof.
  intros n X Y HXY. by rewrite /unfold (conv_compl n (unfold_chain X))
    (conv_compl n (unfold_chain Y)) /= (HXY (S n)).
Qed.

Program Definition fold (X : oFunctor_apply F T) : T :=
  {| tower_car n := g n (map (embed' n,project n) X) |}.
Next Obligation.
  intros X k. apply (_ : Proper ((≡) ==> (≡)) (g k)).
  rewrite g_S -oFunctor_map_compose.
  apply (contractive_proper map); split=> Y; [apply embed_f|apply g_tower].
Qed.
Global Instance fold_ne : NonExpansive fold.
Proof. by intros n X Y HXY k; rewrite /fold /= HXY. Qed.

Theorem result : solution F.
Proof using Type*.
  refine (Solution F T _ (OfeIso (OfeMor fold) (OfeMor unfold) _ _)).
  - move=> X /=. rewrite equiv_dist=> n k; rewrite /unfold /fold /=.
    rewrite -g_tower -(gg_tower _ n); apply (_ : Proper (_ ==> _) (g _)).
    trans (map (ff n, gg n) (X (S (n + k)))).
    { rewrite /unfold (conv_compl n (unfold_chain X)).
      rewrite -(chain_cauchy (unfold_chain X) n (S (n + k))) /=; last lia.
      rewrite -(dist_le _ _ _ _ (f_tower (n + k) _)); last lia.
      rewrite f_S -!oFunctor_map_compose; apply (contractive_ne map); split=> Y.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [exfalso; lia|].
        by rewrite (ff_ff _ (eq_refl (S n + (0 + k)))) /= gf.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [|exfalso; lia].
        by rewrite (gg_gg _ (eq_refl (0 + (S n + k)))) /= gf. }
    assert (∀ i k (x : A (S i + k)) (H : S i + k = i + S k),
      map (ff i, gg i) x ≡ gg i (coerce H x)) as map_ff_gg.
    { intros i; induction i as [|i IH]; intros k' x H; simpl.
      { by rewrite coerce_id oFunctor_map_id. }
      rewrite oFunctor_map_compose g_coerce; apply IH. }
    assert (H: S n + k = n + S k) by lia.
    rewrite (map_ff_gg _ _ _ H).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct H.
  - intros X; rewrite equiv_dist=> n /=.
    rewrite /unfold /= (conv_compl' n (unfold_chain (fold X))) /=.
    rewrite g_S -!oFunctor_map_compose -{2}[X]oFunctor_map_id.
    apply (contractive_ne map); split => Y /=.
    + rewrite f_tower. apply dist_S. by rewrite embed_tower.
    + etrans; [apply embed_ne, equiv_dist, g_tower|apply embed_tower].
Qed.
End solver. End solver.