(* *********************************************************************)
(*                                                                     *)
(*              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 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 file is also distributed under the terms of the               *)
(*  INRIA Non-Commercial License Agreement.                            *)
(*                                                                     *)
(* *********************************************************************)

(* A solver for subtyping constraints. *)

Require Import Recdef Coqlib Maps Errors.

Local Open Scope nat_scope.
Local Open Scope error_monad_scope.

(** This module provides a solver for sets of subtyping constraints of the
  following kinds: [base-type <: T(x)] or [T(x) <: base-type] or [T(x) <: T(y)].
  The unknowns are the types [T(x)] of every identifier [x]. *)

(** The interface for base types and the subtyping relation. *)

Module Type TYPE_ALGEBRA.

(** Type expressions *)

Parameter t: Type.
Parameter eq: forall (x y: t), {x=y} + {x<>y}.
Parameter default: t.

(** Subtyping *)

Parameter sub: t -> t -> Prop.
Axiom sub_refl: forall x, sub x x.
Axiom sub_trans: forall x y z, sub x y -> sub y z -> sub x z.
Parameter sub_dec: forall x y, {sub x y} + {~sub x y}.

(** Least upper bounds. [lub x y] is specified only when [x] and [y] have
  a common supertype; it can be arbitrary otherwise. *)

Parameter lub: t -> t -> t.
Axiom lub_left: forall x y z, sub x z -> sub y z -> sub x (lub x y).
Axiom lub_right: forall x y z, sub x z -> sub y z -> sub y (lub x y).
Axiom lub_min: forall x y z, sub x z -> sub y z -> sub (lub x y) z.

(** Greater lower bounds. [glb x y] is specified only when [x] and [y] have
  a common subtype; it can be arbitrary otherwise.*)

Parameter glb: t -> t -> t.
Axiom glb_left: forall x y z, sub z x -> sub z y -> sub (glb x y) x.
Axiom glb_right: forall x y z, sub z x -> sub z y -> sub (glb x y) y.
Axiom glb_max: forall x y z, sub z x -> sub z y -> sub z (glb x y).

(** Low and high bounds for a given type. *)
Parameter low_bound: t -> t.
Parameter high_bound: t -> t.
Axiom low_bound_sub: forall t, sub (low_bound t) t.
Axiom low_bound_minorant: forall x y, sub x y -> sub (low_bound y) x.
Axiom high_bound_sub: forall t, sub t (high_bound t).
Axiom high_bound_majorant: forall x y, sub x y -> sub y (high_bound x).

(** Measure over types *)

Parameter weight: t -> nat.
Parameter max_weight: nat.
Axiom weight_range: forall t, weight t <= max_weight.
Axiom weight_sub: forall x y, sub x y -> weight x <= weight y.
Axiom weight_sub_strict: forall x y, sub x y -> x <> y -> weight x < weight y.

End TYPE_ALGEBRA.

(** The constraint solver. *)

Module SubSolver (T: TYPE_ALGEBRA).

(* The current set of constraints is represented by a record with two components:
- [te_typ]: a partial map from variables to pairs [tlo, thi]
  of types, representing the low and high bounds for this variable.
- [te_sub]: a list of pairs [(x,y)] of variables, indicating that
  the type of [x] must be a subtype of the type of [y].
*)

Inductive bounds : Type := B (lo: T.t) (hi: T.t) (SUB: T.sub lo hi).

Definition constraint : Type := (positive * positive)%type.

Record typenv : Type := Typenv {
  te_typ: PTree.t bounds;    (**r mapping var -> low & high bounds *)
  te_sub: list constraint    (**r additional subtyping constraints *)
}.

Definition initial : typenv := {| te_typ := PTree.empty _; te_sub := nil |}.

(** Add the constraint [ty <: T(x)]. *)

Definition type_def (e: typenv) (x: positive) (ty: T.t) : res typenv :=
  match e.(te_typ)!x with
  | None =>
      let b := B ty (T.high_bound ty) (T.high_bound_sub ty) in
      OK {| te_typ := PTree.set x b e.(te_typ);
            te_sub := e.(te_sub) |}
  | Some(B lo hi s1) =>
      match T.sub_dec ty hi with
      | left s2 =>
          let lo' := T.lub lo ty in
          if T.eq lo lo' then OK e else
            let b := B lo' hi (T.lub_min lo ty hi s1 s2) in
            OK {| te_typ := PTree.set x b e.(te_typ);
                  te_sub := e.(te_sub) |}
      | right _ =>
          Error (MSG "bad definition of variable " :: POS x :: nil)
      end
  end.

Fixpoint type_defs (e: typenv) (rl: list positive) (tyl: list T.t) {struct rl}: res typenv :=
  match rl, tyl with
  | nil, nil => OK e
  | r1::rs, ty1::tys => do e1 <- type_def e r1 ty1; type_defs e1 rs tys
  | _, _ => Error (msg "arity mismatch")
  end.

(** Add the constraint [T(x) <: ty]. *)

Definition type_use (e: typenv) (x: positive) (ty: T.t) : res typenv :=
  match e.(te_typ)!x with
  | None =>
      let b := B (T.low_bound ty) ty (T.low_bound_sub ty) in
      OK {| te_typ := PTree.set x b e.(te_typ);
            te_sub := e.(te_sub) |}
  | Some(B lo hi s1) =>
      match T.sub_dec lo ty with
      | left s2 =>
          let hi' := T.glb hi ty in
          if T.eq hi hi' then OK e else
            let b := B lo hi' (T.glb_max hi ty lo s1 s2) in
            OK {| te_typ := PTree.set x b e.(te_typ);
                  te_sub := e.(te_sub) |}
      | right _ =>
          Error (MSG "bad use of variable " :: POS x :: nil)
      end
  end.

Fixpoint type_uses (e: typenv) (rl: list positive) (tyl: list T.t) {struct rl}: res typenv :=
  match rl, tyl with
  | nil, nil => OK e
  | r1::rs, ty1::tys => do e1 <- type_use e r1 ty1; type_uses e1 rs tys
  | _, _ => Error (msg "arity mismatch")
  end.

(** Add the constraint [T(x) <: T(y)].
    The boolean result is [true] if the types of [r1] and [r2] could be
    made more precise.  Otherwise, [te_typ] does not change and
    [false] is returned. *)

Definition type_move (e: typenv) (r1 r2: positive) : res (bool * typenv) :=
  if peq r1 r2 then OK (false, e) else
  match e.(te_typ)!r1, e.(te_typ)!r2 with
  | None, None =>
      OK (false, {| te_typ := e.(te_typ); te_sub := (r1, r2) :: e.(te_sub) |})
  | Some(B lo1 hi1 s1), None =>
      let b2 := B lo1 (T.high_bound lo1) (T.high_bound_sub lo1) in
      OK (true, {| te_typ := PTree.set r2 b2 e.(te_typ);
                   te_sub := if T.sub_dec hi1 lo1 then e.(te_sub)
                             else (r1, r2) :: e.(te_sub) |})
  | None, Some(B lo2 hi2 s2) =>
      let b1 := B (T.low_bound hi2) hi2 (T.low_bound_sub hi2) in
      OK (true, {| te_typ := PTree.set r1 b1 e.(te_typ);
                   te_sub := if T.sub_dec hi2 lo2 then e.(te_sub)
                             else (r1, r2) :: e.(te_sub) |})
  | Some(B lo1 hi1 s1), Some(B lo2 hi2 s2) =>
      if T.sub_dec hi1 lo2 then
        (* The constraint is always true, don't record it *)
        OK (false, e)
      else match T.sub_dec lo1 hi2 with
      | left s =>
          (* Tighten the bounds on [r1] and [r2] when possible and record
             the constraint. *)
          let lo2' := T.lub lo1 lo2 in
          let hi1' := T.glb hi1 hi2 in
          let b1 := B lo1 hi1' (T.glb_max hi1 hi2 lo1 s1 s) in
          let b2 := B lo2' hi2 (T.lub_min lo1 lo2 hi2 s s2) in
          if T.eq lo2 lo2' then
            if T.eq hi1 hi1' then
              OK (false, {| te_typ := e.(te_typ);
                            te_sub := (r1, r2) :: e.(te_sub) |})
            else
              OK (true, {| te_typ := PTree.set r1 b1 e.(te_typ);
                           te_sub := (r1, r2) :: e.(te_sub) |})
          else
            if T.eq hi1 hi1' then
              OK (true, {| te_typ := PTree.set r2 b2 e.(te_typ);
                           te_sub := (r1, r2) :: e.(te_sub) |})
            else
              OK (true, {| te_typ := PTree.set r2 b2 (PTree.set r1 b1 e.(te_typ));
                           te_sub := (r1, r2) :: e.(te_sub) |})
      | right _ =>
          Error(MSG "ill-typed move from " :: POS r1 :: MSG " to " :: POS r2 :: nil)
      end
  end.

(** Solve the remaining subtyping constraints by iteration. *)

Fixpoint solve_rec (e: typenv) (changed: bool) (q: list constraint) : res (typenv * bool) :=
  match q with
  | nil =>
      OK (e, changed)
  | (r1, r2) :: q' =>
      do (changed1, e1) <- type_move e r1 r2; solve_rec e1 (changed || changed1) q'
  end.

(** Measuring the state *)

Definition weight_bounds (ob: option bounds) : nat :=
  match ob with None => T.max_weight + 1 | Some(B lo hi s) => T.weight hi - T.weight lo end.

Lemma weight_bounds_1:
  forall lo hi s, weight_bounds (Some (B lo hi s)) < weight_bounds None.
Proof.
  intros; simpl. generalize (T.weight_range hi); lia.
Qed.

Lemma weight_bounds_2:
  forall lo1 hi1 s1 lo2 hi2 s2,
  T.sub lo2 lo1 -> T.sub hi1 hi2 -> lo1 <> lo2 \/ hi1 <> hi2 ->
  weight_bounds (Some (B lo1 hi1 s1)) < weight_bounds (Some (B lo2 hi2 s2)).
Proof.
  intros; simpl.
  generalize (T.weight_sub _ _ s1) (T.weight_sub _ _ s2) (T.weight_sub _ _ H) (T.weight_sub _ _ H0); intros.
  destruct H1.
  assert (T.weight lo2 < T.weight lo1) by (apply T.weight_sub_strict; auto). lia.
  assert (T.weight hi1 < T.weight hi2) by (apply T.weight_sub_strict; auto). lia.
Qed.

Hint Resolve T.sub_refl: ty.

Lemma weight_type_move:
  forall e r1 r2 changed e',
  type_move e r1 r2 = OK(changed, e') ->
  (e'.(te_sub) = e.(te_sub) \/ e'.(te_sub) = (r1, r2) :: e.(te_sub))
  /\ (forall r, weight_bounds e'.(te_typ)!r <= weight_bounds e.(te_typ)!r)
  /\ (changed = true ->
        weight_bounds e'.(te_typ)!r1 + weight_bounds e'.(te_typ)!r2
        < weight_bounds e.(te_typ)!r1 + weight_bounds e.(te_typ)!r2).
Proof.
  unfold type_move; intros.
  destruct (peq r1 r2).
  inv H. split; auto. split; intros. lia. discriminate.
  destruct (te_typ e)!r1 as [[lo1 hi1 s1]|] eqn:E1;
  destruct (te_typ e)!r2 as [[lo2 hi2 s2]|] eqn:E2.
- destruct (T.sub_dec hi1 lo2).
  inv H. split; auto. split; intros. lia. discriminate.
  destruct (T.sub_dec lo1 hi2); try discriminate.
  set (lo2' := T.lub lo1 lo2) in *.
  set (hi1' := T.glb hi1 hi2) in *.
  assert (S1': T.sub hi1' hi1) by (eapply T.glb_left; eauto).
  assert (S2': T.sub lo2 lo2') by (eapply T.lub_right; eauto).
  set (b1 := B lo1 hi1' (T.glb_max hi1 hi2 lo1 s1 s)) in *.
  set (b2 := B lo2' hi2 (T.lub_min lo1 lo2 hi2 s s2)) in *.
Local Opaque weight_bounds.
  destruct (T.eq lo2 lo2'); destruct (T.eq hi1 hi1'); inversion H; clear H; subst changed e'; simpl.
+ split; auto. split; intros. lia. discriminate.
+ assert (weight_bounds (Some b1) < weight_bounds (Some (B lo1 hi1 s1)))
  by (apply weight_bounds_2; auto with ty).
  split; auto. split; intros.
  rewrite PTree.gsspec. destruct (peq r r1). subst r. rewrite E1. lia. lia.
  rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E2. lia.
+ assert (weight_bounds (Some b2) < weight_bounds (Some (B lo2 hi2 s2)))
  by (apply weight_bounds_2; auto with ty).
  split; auto. split; intros.
  rewrite PTree.gsspec. destruct (peq r r2). subst r. rewrite E2. lia. lia.
  rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E1. lia.
+ assert (weight_bounds (Some b1) < weight_bounds (Some (B lo1 hi1 s1)))
  by (apply weight_bounds_2; auto with ty).
  assert (weight_bounds (Some b2) < weight_bounds (Some (B lo2 hi2 s2)))
  by (apply weight_bounds_2; auto with ty).
  split; auto. split; intros.
  rewrite ! PTree.gsspec.
  destruct (peq r r2). subst r. rewrite E2. lia.
  destruct (peq r r1). subst r. rewrite E1. lia.
  lia.
  rewrite PTree.gss. rewrite PTree.gso by auto. rewrite PTree.gss. lia.

- set (b2 := B lo1 (T.high_bound lo1) (T.high_bound_sub lo1)) in *.
  assert (weight_bounds (Some b2) < weight_bounds None) by (apply weight_bounds_1).
  inv H; simpl.
  split. destruct (T.sub_dec hi1 lo1); auto.
  split; intros.
  rewrite PTree.gsspec. destruct (peq r r2). subst r; rewrite E2; lia. lia.
  rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E1. lia.

- set (b1 := B (T.low_bound hi2) hi2 (T.low_bound_sub hi2)) in *.
  assert (weight_bounds (Some b1) < weight_bounds None) by (apply weight_bounds_1).
  inv H; simpl.
  split. destruct (T.sub_dec hi2 lo2); auto.
  split; intros.
  rewrite PTree.gsspec. destruct (peq r r1). subst r; rewrite E1; lia. lia.
  rewrite PTree.gss. rewrite PTree.gso by auto. rewrite E2. lia.

- inv H. split; auto. simpl; split; intros. lia. congruence.
Qed.

Definition weight_constraints (b: PTree.t bounds) (cstr: list constraint) : nat :=
  List.fold_right (fun xy n => n + weight_bounds b!(fst xy) + weight_bounds b!(snd xy)) 0 cstr.

Remark weight_constraints_tighter:
  forall b1 b2, (forall r, weight_bounds b1!r <= weight_bounds b2!r) ->
  forall q, weight_constraints b1 q <= weight_constraints b2 q.
Proof.
  induction q; simpl. lia. generalize (H (fst a)) (H (snd a)); lia.
Qed.

Lemma weight_solve_rec:
  forall q e changed e' changed',
  solve_rec e changed q = OK(e', changed') ->
  (forall r, weight_bounds e'.(te_typ)!r <= weight_bounds e.(te_typ)!r) /\
  weight_constraints e'.(te_typ) e'.(te_sub) + (if changed' && negb changed then 1 else 0)
     <= weight_constraints e.(te_typ) e.(te_sub) + weight_constraints e.(te_typ) q.
Proof.
  induction q; simpl; intros.
- inv H. split. intros; lia. replace (changed' && negb changed') with false.
  lia. destruct changed'; auto.
- destruct a as [r1 r2]; monadInv H; simpl.
  rename x into changed1. rename x0 into e1.
  exploit weight_type_move; eauto. intros [A [B C]].
  exploit IHq; eauto. intros [D E].
  split. intros. eapply le_trans. eapply D. eapply B.
  assert (P: weight_constraints (te_typ e1) (te_sub e) <=
             weight_constraints (te_typ e) (te_sub e))
  by (apply weight_constraints_tighter; auto).
  assert (Q: weight_constraints (te_typ e1) (te_sub e1) <=
             weight_constraints (te_typ e1) (te_sub e) +
             weight_bounds (te_typ e1)!r1 + weight_bounds (te_typ e1)!r2).
  { destruct A as [Q|Q]; rewrite Q. lia. simpl. lia. }
  assert (R: weight_constraints (te_typ e1) q <= weight_constraints (te_typ e) q)
  by (apply weight_constraints_tighter; auto).
  set (ch1 := if changed' && negb (changed || changed1) then 1 else 0) in *.
  set (ch2 := if changed' && negb changed then 1 else 0) in *.
  destruct changed1.
  assert (ch2 <= ch1 + 1).
  { unfold ch2, ch1. rewrite orb_true_r. simpl. rewrite andb_false_r.
    destruct (changed' && negb changed); lia. }
  exploit C; eauto. lia.
  assert (ch2 <= ch1).
  { unfold ch2, ch1. rewrite orb_false_r. lia. }
  generalize (B r1) (B r2); lia.
Qed.

Definition weight_typenv (e: typenv) : nat :=
  weight_constraints e.(te_typ) e.(te_sub).

(** Iterative solving of the remaining constraints *)

Function solve_constraints (e: typenv) {measure weight_typenv e}: res typenv :=
  match solve_rec {| te_typ := e.(te_typ); te_sub := nil |} false e.(te_sub) with
  | OK(e', false) => OK e                   (**r no more changes, fixpoint reached *)
  | OK(e', true)  => solve_constraints e'   (**r one more iteration *)
  | Error msg => Error msg
  end.
Proof.
  intros. exploit weight_solve_rec; eauto. simpl. intros [A B].
  unfold weight_typenv. lia.
Qed.

Definition typassign := positive -> T.t.

Definition makeassign (e: typenv) : typassign :=
  fun x => match e.(te_typ)!x with Some(B lo hi s) => lo | None => T.default end.

Definition solve (e: typenv) : res typassign :=
  do e' <- solve_constraints e; OK(makeassign e').

(** What it means to be a solution *)

Definition satisf (te: typassign) (e: typenv) : Prop :=
   (forall x lo hi s, e.(te_typ)!x = Some(B lo hi s) -> T.sub lo (te x) /\ T.sub (te x) hi)
/\ (forall x y, In (x, y) e.(te_sub) -> T.sub (te x) (te y)).

Lemma satisf_initial: forall te, satisf te initial.
Proof.
  unfold initial; intros; split; simpl; intros.
  rewrite PTree.gempty in H; discriminate.
  contradiction.
Qed.

(** Soundness proof *)

Lemma type_def_incr:
  forall te x ty e e', type_def e x ty = OK e' -> satisf te e' -> satisf te e.
Proof.
  unfold type_def; intros. destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec ty hi); try discriminate.
  destruct (T.eq lo (T.lub lo ty)); monadInv H.
  subst e'; auto.
  destruct H0 as [P Q]; split; auto; intros.
  destruct (peq x x0).
  + subst x0. rewrite E in H; inv H.
    exploit (P x); simpl. rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.lub lo0 ty); auto. eapply T.lub_left; eauto.
  + eapply P; simpl. rewrite PTree.gso; eauto.
- inv H. destruct H0 as [P Q]; split; auto; intros.
  eapply P; simpl. rewrite PTree.gso; eauto. congruence.
Qed.

Hint Resolve type_def_incr: ty.

Lemma type_def_sound:
  forall te x ty e e', type_def e x ty = OK e' -> satisf te e' -> T.sub ty (te x).
Proof.
  unfold type_def; intros. destruct H0 as [P Q].
  destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec ty hi); try discriminate.
  destruct (T.eq lo (T.lub lo ty)); monadInv H.
  + subst e'. apply T.sub_trans with lo.
    rewrite e0. eapply T.lub_right; eauto. eapply P; eauto.
  + apply T.sub_trans with (T.lub lo ty).
    eapply T.lub_right; eauto.
    eapply (P x). simpl. rewrite PTree.gss; eauto.
- inv H. eapply (P x); simpl. rewrite PTree.gss; eauto.
Qed.

Lemma type_defs_incr:
  forall te xl tyl e e', type_defs e xl tyl = OK e' -> satisf te e' -> satisf te e.
Proof.
  induction xl; destruct tyl; simpl; intros; monadInv H; eauto with ty.
Qed.

Hint Resolve type_defs_incr: ty.

Lemma type_defs_sound:
  forall te xl tyl e e', type_defs e xl tyl = OK e' -> satisf te e' -> list_forall2 T.sub tyl (map te xl).
Proof.
  induction xl; destruct tyl; simpl; intros; monadInv H.
  constructor.
  constructor; eauto. eapply type_def_sound; eauto with ty.
Qed.

Lemma type_use_incr:
  forall te x ty e e', type_use e x ty = OK e' -> satisf te e' -> satisf te e.
Proof.
  unfold type_use; intros. destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec lo ty); try discriminate.
  destruct (T.eq hi (T.glb hi ty)); monadInv H.
  subst e'; auto.
  destruct H0 as [P Q]; split; auto; intros.
  destruct (peq x x0).
  + subst x0. rewrite E in H; inv H.
    exploit (P x); simpl. rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.glb hi0 ty); auto. eapply T.glb_left; eauto.
  + eapply P; simpl. rewrite PTree.gso; eauto.
- inv H. destruct H0 as [P Q]; split; auto; intros.
  eapply P; simpl. rewrite PTree.gso; eauto. congruence.
Qed.

Hint Resolve type_use_incr: ty.

Lemma type_use_sound:
  forall te x ty e e', type_use e x ty = OK e' -> satisf te e' -> T.sub (te x) ty.
Proof.
  unfold type_use; intros. destruct H0 as [P Q].
  destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec lo ty); try discriminate.
  destruct (T.eq hi (T.glb hi ty)); monadInv H.
  + subst e'. apply T.sub_trans with hi.
    eapply P; eauto. rewrite e0. eapply T.glb_right; eauto.
  + apply T.sub_trans with (T.glb hi ty).
    eapply (P x). simpl. rewrite PTree.gss; eauto.
    eapply T.glb_right; eauto.
- inv H. eapply (P x); simpl. rewrite PTree.gss; eauto.
Qed.

Lemma type_uses_incr:
  forall te xl tyl e e', type_uses e xl tyl = OK e' -> satisf te e' -> satisf te e.
Proof.
  induction xl; destruct tyl; simpl; intros; monadInv H; eauto with ty.
Qed.

Hint Resolve type_uses_incr: ty.

Lemma type_uses_sound:
  forall te xl tyl e e', type_uses e xl tyl = OK e' -> satisf te e' -> list_forall2 T.sub (map te xl) tyl.
Proof.
  induction xl; destruct tyl; simpl; intros; monadInv H.
  constructor.
  constructor; eauto. eapply type_use_sound; eauto with ty.
Qed.

Lemma type_move_incr:
  forall te e r1 r2 e' changed,
  type_move e r1 r2 = OK(changed, e') -> satisf te e' -> satisf te e.
Proof.
  unfold type_move; intros. destruct H0 as [P Q].
  destruct (peq r1 r2). inv H; split; auto.
  destruct (te_typ e)!r1 as [[lo1 hi1 s1]|] eqn:E1;
  destruct (te_typ e)!r2 as [[lo2 hi2 s2]|] eqn:E2.
- destruct (T.sub_dec hi1 lo2). inv H; split; auto.
  destruct (T.sub_dec lo1 hi2); try discriminate.
  set (lo := T.lub lo1 lo2) in *. set (hi := T.glb hi1 hi2) in *.
  destruct (T.eq lo2 lo); destruct (T.eq hi1 hi); monadInv H; simpl in *.
  + subst e'; simpl in *. split; auto.
  + subst e'; simpl in *. split; auto. intros. destruct (peq x r1).
    subst x.
    rewrite E1 in H. injection H; intros; subst lo0 hi0.
    exploit (P r1). rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.glb hi1 hi2); auto. eapply T.glb_left; eauto.
    eapply P. rewrite PTree.gso; eauto.
  + subst e'; simpl in *. split; auto. intros. destruct (peq x r2).
    subst x.
    rewrite E2 in H. injection H; intros; subst lo0 hi0.
    exploit (P r2). rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.lub lo1 lo2); auto. eapply T.lub_right; eauto.
    eapply P. rewrite PTree.gso; eauto.
  + split; auto. intros.
    destruct (peq x r1). subst x.
    rewrite E1 in H. injection H; intros; subst lo0 hi0.
    exploit (P r1). rewrite PTree.gso; eauto. rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.glb hi1 hi2); auto. eapply T.glb_left; eauto.
    destruct (peq x r2). subst x.
    rewrite E2 in H. injection H; intros; subst lo0 hi0.
    exploit (P r2). rewrite PTree.gss; eauto. intuition.
    apply T.sub_trans with (T.lub lo1 lo2); auto. eapply T.lub_right; eauto.
    eapply P. rewrite ! PTree.gso; eauto.
- inv H; simpl in *. split; intros.
  eapply P. rewrite PTree.gso; eauto. congruence.
  apply Q.   destruct (T.sub_dec hi1 lo1); auto with coqlib.
- inv H; simpl in *. split; intros.
  eapply P. rewrite PTree.gso; eauto. congruence.
  apply Q.   destruct (T.sub_dec hi2 lo2); auto with coqlib.
- inv H; simpl in *. split; auto.
Qed.

Hint Resolve type_move_incr: ty.

Lemma type_move_sound:
  forall te e r1 r2 e' changed,
  type_move e r1 r2 = OK(changed, e') -> satisf te e' -> T.sub (te r1) (te r2).
Proof.
  unfold type_move; intros. destruct H0 as [P Q].
  destruct (peq r1 r2). subst r2. apply T.sub_refl.
  destruct (te_typ e)!r1 as [[lo1 hi1 s1]|] eqn:E1;
  destruct (te_typ e)!r2 as [[lo2 hi2 s2]|] eqn:E2.
- destruct (T.sub_dec hi1 lo2).
  inv H. apply T.sub_trans with hi1. eapply P; eauto. apply T.sub_trans with lo2; auto. eapply P; eauto.
  destruct (T.sub_dec lo1 hi2); try discriminate.
  set (lo := T.lub lo1 lo2) in *. set (hi := T.glb hi1 hi2) in *.
  destruct (T.eq lo2 lo); destruct (T.eq hi1 hi); monadInv H; simpl in *.
  + subst e'; simpl in *. apply Q; auto.
  + subst e'; simpl in *. apply Q; auto.
  + subst e'; simpl in *. apply Q; auto.
  + apply Q; auto.
- inv H; simpl in *. destruct (T.sub_dec hi1 lo1).
  + apply T.sub_trans with hi1. eapply P; eauto. rewrite PTree.gso; eauto.
    apply T.sub_trans with lo1; auto. eapply P. rewrite PTree.gss; eauto.
  + auto with coqlib.
- inv H; simpl in *. destruct (T.sub_dec hi2 lo2).
  + apply T.sub_trans with hi2. eapply P. rewrite PTree.gss; eauto.
    apply T.sub_trans with lo2; auto. eapply P. rewrite PTree.gso; eauto.
  + auto with coqlib.
- inv H. simpl in Q; auto.
Qed.

Lemma solve_rec_incr:
  forall te q e changed e' changed',
  solve_rec e changed q = OK(e', changed') -> satisf te e' -> satisf te e.
Proof.
  induction q; simpl; intros.
- inv H. auto.
- destruct a as [r1 r2]; monadInv H. eauto with ty.
Qed.

Lemma solve_rec_sound:
  forall te r1 r2 q e changed e' changed',
  solve_rec e changed q = OK(e', changed') -> In (r1, r2) q -> satisf te e' ->
  T.sub (te r1) (te r2).
Proof.
  induction q; simpl; intros.
- contradiction.
- destruct a as [r3 r4]; monadInv H. destruct H0.
  + inv H. eapply type_move_sound; eauto. eapply solve_rec_incr; eauto.
  + eapply IHq; eauto with ty.
Qed.

Lemma type_move_false:
  forall e r1 r2 e',
  type_move e r1 r2 = OK(false, e') ->
  te_typ e' = te_typ e /\ T.sub (makeassign e r1) (makeassign e r2).
Proof.
  unfold type_move; intros.
  destruct (peq r1 r2). inv H. split; auto. apply T.sub_refl.
  unfold makeassign;
  destruct (te_typ e)!r1 as [[lo1 hi1 s1]|] eqn:E1;
  destruct (te_typ e)!r2 as [[lo2 hi2 s2]|] eqn:E2.
- destruct (T.sub_dec hi1 lo2).
  inv H. split; auto. eapply T.sub_trans; eauto.
  destruct (T.sub_dec lo1 hi2); try discriminate.
  set (lo := T.lub lo1 lo2) in *. set (hi := T.glb hi1 hi2) in *.
  destruct (T.eq lo2 lo); destruct (T.eq hi1 hi); try discriminate.
  monadInv H. split; auto. rewrite e0. unfold lo. eapply T.lub_left; eauto.
- discriminate.
- discriminate.
- inv H. split; auto. apply T.sub_refl.
Qed.

Lemma solve_rec_false:
  forall r1 r2 q e changed e',
  solve_rec e changed q = OK(e', false) ->
  changed = false /\
  (In (r1, r2) q -> T.sub (makeassign e r1) (makeassign e r2)).
Proof.
  induction q; simpl; intros.
- inv H. tauto.
- destruct a as [r3 r4]; monadInv H.
  exploit IHq; eauto. intros [P Q].
  destruct changed; try discriminate. destruct x; try discriminate.
  exploit type_move_false; eauto. intros [U V].
  split. auto. intros [A|A]. inv A. auto. exploit Q; auto.
  unfold makeassign; rewrite U; auto.
Qed.

Lemma solve_constraints_incr:
  forall te e e', solve_constraints e = OK e' -> satisf te e' -> satisf te e.
Proof.
  intros te e; functional induction (solve_constraints e); intros.
- inv H. auto.
- exploit solve_rec_incr; eauto. intros [A B].
  split; auto. intros; eapply solve_rec_sound; eauto.
- discriminate.
Qed.

Lemma solve_constraints_sound:
  forall e e', solve_constraints e = OK e' -> satisf (makeassign e') e'.
Proof.
  intros e0; functional induction (solve_constraints e0); intros.
- inv H. split; intros.
  unfold makeassign; rewrite H. split; auto with ty.
  exploit solve_rec_false. eauto. intros [A B]. eapply B; eauto.
- eauto.
- discriminate.
Qed.

Theorem solve_sound:
  forall e te, solve e = OK te -> satisf te e.
Proof.
  unfold solve; intros. monadInv H.
  eapply solve_constraints_incr. eauto. eapply solve_constraints_sound; eauto.
Qed.

(** Completeness proof *)

Lemma type_def_complete:
  forall te e x ty,
  satisf te e -> T.sub ty (te x) -> exists e', type_def e x ty = OK e' /\ satisf te e'.
Proof.
  unfold type_def; intros. destruct H as [P Q].
  destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec ty hi).
  destruct (T.eq lo (T.lub lo ty)).
  exists e; split; auto. split; auto.
  econstructor; split; eauto. split; simpl; auto; intros.
  rewrite PTree.gsspec in H. destruct (peq x0 x).
  inv H. exploit P; eauto. intuition. eapply T.lub_min; eauto.
  eapply P; eauto.
  elim n. apply T.sub_trans with (te x); auto. eapply P; eauto.
- econstructor; split; eauto. split; simpl; auto; intros.
  rewrite PTree.gsspec in H. destruct (peq x0 x).
  inv H. split; auto. apply T.high_bound_majorant; auto.
  eapply P; eauto.
Qed.

Lemma type_defs_complete:
  forall te xl tyl e,
  satisf te e -> list_forall2 T.sub tyl (map te xl) ->
  exists e', type_defs e xl tyl = OK e' /\ satisf te e'.
Proof.
  induction xl; intros; inv H0; simpl.
  econstructor; eauto.
  exploit (type_def_complete te e a a1); auto. intros (e1 & P & Q).
  exploit (IHxl al e1); auto. intros (e2 & U & V).
  exists e2; split; auto. rewrite P; auto.
Qed.

Lemma type_use_complete:
  forall te e x ty,
  satisf te e -> T.sub (te x) ty -> exists e', type_use e x ty = OK e' /\ satisf te e'.
Proof.
  unfold type_use; intros. destruct H as [P Q].
  destruct (te_typ e)!x as [[lo hi s1]|] eqn:E.
- destruct (T.sub_dec lo ty).
  destruct (T.eq hi (T.glb hi ty)).
  exists e; split; auto. split; auto.
  econstructor; split; eauto. split; simpl; auto; intros.
  rewrite PTree.gsspec in H. destruct (peq x0 x).
  inv H. exploit P; eauto. intuition. eapply T.glb_max; eauto.
  eapply P; eauto.
  elim n. apply T.sub_trans with (te x); auto. eapply P; eauto.
- econstructor; split; eauto. split; simpl; auto; intros.
  rewrite PTree.gsspec in H. destruct (peq x0 x).
  inv H. split; auto. apply T.low_bound_minorant; auto.
  eapply P; eauto.
Qed.

Lemma type_uses_complete:
  forall te xl tyl e,
  satisf te e -> list_forall2 T.sub (map te xl) tyl ->
  exists e', type_uses e xl tyl = OK e' /\ satisf te e'.
Proof.
  induction xl; intros; inv H0; simpl.
  econstructor; eauto.
  exploit (type_use_complete te e a b1); auto. intros (e1 & P & Q).
  exploit (IHxl bl e1); auto. intros (e2 & U & V).
  exists e2; split; auto. rewrite P; auto.
Qed.

Lemma type_move_complete:
  forall te e r1 r2,
  satisf te e -> T.sub (te r1) (te r2) ->
  exists changed e', type_move e r1 r2 = OK(changed, e') /\ satisf te e'.
Proof.
  unfold type_move; intros. elim H; intros P Q.
  assert (Q': forall x y, In (x, y) ((r1, r2) :: te_sub e) -> T.sub (te x) (te y)).
  { intros. destruct H1; auto. congruence. }
  destruct (peq r1 r2). econstructor; econstructor; eauto.
  destruct (te_typ e)!r1 as [[lo1 hi1 s1]|] eqn:E1;
  destruct (te_typ e)!r2 as [[lo2 hi2 s2]|] eqn:E2.
- exploit (P r1); eauto. intros [L1 U1].
  exploit (P r2); eauto. intros [L2 U2].
  destruct (T.sub_dec hi1 lo2). econstructor; econstructor; eauto.
  destruct (T.sub_dec lo1 hi2).
  destruct (T.eq lo2 (T.lub lo1 lo2)); destruct (T.eq hi1 (T.glb hi1 hi2));
  econstructor; econstructor; split; eauto; split; auto; simpl; intros.
  + rewrite PTree.gsspec in H1. destruct (peq x r1).
    clear e0. inv H1. split; auto.
    apply T.glb_max. auto. apply T.sub_trans with (te r2); auto.
    eapply P; eauto.
  + rewrite PTree.gsspec in H1. destruct (peq x r2).
    clear e0. inv H1. split; auto.
    apply T.lub_min. apply T.sub_trans with (te r1); auto. auto.
    eapply P; eauto.
  + rewrite ! PTree.gsspec in H1. destruct (peq x r2).
    inv H1. split; auto. apply T.lub_min; auto. apply T.sub_trans with (te r1); auto.
    destruct (peq x r1).
    inv H1. split; auto. apply T.glb_max; auto. apply T.sub_trans with (te r2); auto.
    eapply P; eauto.
  + elim n1. apply T.sub_trans with (te r1); auto.
    apply T.sub_trans with (te r2); auto.
- econstructor; econstructor; split; eauto; split.
  + simpl; intros. rewrite PTree.gsspec in H1. destruct (peq x r2).
    inv H1. exploit P; eauto. intuition.
    apply T.sub_trans with (te r1); auto.
    apply T.high_bound_majorant. apply T.sub_trans with (te r1); auto.
    eapply P; eauto.
  + destruct (T.sub_dec hi1 lo1); auto.
- econstructor; econstructor; split; eauto; split.
  + simpl; intros. rewrite PTree.gsspec in H1. destruct (peq x r1).
    inv H1. exploit P; eauto. intuition.
    apply T.low_bound_minorant. apply T.sub_trans with (te r2); auto.
    apply T.sub_trans with (te r2); auto.
    eapply P; eauto.
  + destruct (T.sub_dec hi2 lo2); auto.
- econstructor; econstructor; split; eauto; split; auto.
Qed.

Lemma solve_rec_complete:
  forall te q e changed,
  satisf te e ->
  (forall r1 r2, In (r1, r2) q -> T.sub (te r1) (te r2)) ->
  exists e' changed', solve_rec e changed q = OK(e', changed') /\ satisf te e'.
Proof.
  induction q; simpl; intros.
- econstructor; econstructor; eauto.
- destruct a as [r1 r2].
  exploit (type_move_complete te e r1 r2); auto. intros (changed1 & e1 & A & B).
  exploit (IHq e1 (changed || changed1)); auto. intros (e' & changed' & C & D).
  exists e'; exists changed'. rewrite A; simpl; rewrite C; auto.
Qed.

Lemma solve_constraints_complete:
  forall te e, satisf te e -> exists e', solve_constraints e = OK e' /\ satisf te e'.
Proof.
  intros te e. functional induction (solve_constraints e); intros.
- exists e; auto.
- exploit (solve_rec_complete te (te_sub e) {| te_typ := te_typ e; te_sub := nil |} false).
  destruct H; split; auto. simpl; tauto.
  destruct H; auto.
  intros (e1 & changed1 & P & Q).
  apply IHr. congruence.
- exploit (solve_rec_complete te (te_sub e) {| te_typ := te_typ e; te_sub := nil |} false).
  destruct H; split; auto. simpl; tauto.
  destruct H; auto.
  intros (e1 & changed1 & P & Q).
  congruence.
Qed.

Lemma solve_complete:
  forall te e, satisf te e -> exists te', solve e = OK te'.
Proof.
  intros. unfold solve.
  destruct (solve_constraints_complete te e H) as (e' & P & Q).
  econstructor. rewrite P. simpl. eauto.
Qed.

End SubSolver.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv0 lv1)).
Admitted.
QuickChick conj5eqsynthconj5.


From Coq Require Import
     Fin
     Nat
     List
     Relations.

From Equations Require Import Equations.

From ITree Require Import
     Indexed.Sum
     Subevent
     CategoryOps.

From CTree Require Import
     CTree
     Equ
     SBisim
     Misc.Vectors
     Core.Utils.

From ExtLib Require Import
     Monad.

From Coinduction Require Import
     coinduction rel tactics.

Import MonadNotation.
Import ListNotations.
Import EquNotations.
Local Open Scope monad_scope.
Local Open Scope fin_vector_scope.

Set Implicit Arguments.

Module Network.

  (*| IP addresses |*)
  Notation uid := fin.

  Section Messaging.
    (*| [n] number of processes
        [msg] type of messages |*)
    Context (n: nat) (msg: Set) {E C: Type -> Type} {HasStuck: B0 -< C}.

    (*| Messages exchagend |*)
    Record req := {
        principal: uid n;
        payload: msg;
      }.

    (*| A queue of messages |*)
    Definition queue := list req.

    (*| Network effects |*)
    Inductive Net: Type -> Type :=
    | Recv: Net (option req)
    | Send : req -> Net unit
    | Broadcast: msg -> Net unit.

    (*| A task is either running or returned |*)
    Inductive Task :=
    | Running (c: ctree E C void)(q: queue)
    (** this is "soft" blocked -- the scheduler can pass it "None"
        which corresponds to a timeout, and it will unblock *)
    | Blocked (k: option req -> ctree E C void).

  End Messaging.

  (*| API for messaging processes |*)
  Arguments Running {n} {msg} {E C}.
  Arguments Blocked {n} {msg} {E C}.
  Arguments Send {n} {msg}.
  Arguments Recv {n} {msg}.
  Arguments Broadcast {n} {msg}.

  Definition recv {n msg E C} `{Net n msg -< E}: ctree E C (option (req n msg)) := trigger Recv.
  Definition send {n msg E C} `{Net n msg -< E}: uid n -> msg -> ctree E C unit :=
    fun u p => trigger (Send {| principal := u; payload := p |}).
  Definition broadcast {n msg E C} `{Net n msg -< E}: msg -> ctree E C unit :=
    fun bs => trigger (Broadcast bs).

  (*| A process running forever |*)
  Notation daemon t := (@CTree.forever _ _ _ _ void t).

  (*| Contexts -- when a process enters and exits thelet's see how far we go before universe inconsistency |*)
  Inductive frameE(n: nat): Type -> Type :=
  | Enter: uid n -> frameE n unit.

  Arguments Enter {n}.

  Definition enter {n E C} `{frameE n -< E} : uid n -> ctree E C unit :=
    fun u => trigger (Enter u).

  Section Scheduler.
    Context (n: nat) (msg: Set) {E C: Type -> Type} `{B1 -< C} `{B2 -< C} `{Bn -< C}.
    Notation Sys := (vec n (@Task n msg (Net n msg +' E) C)) (only parsing).

    (*| General coinductive scheduler |*)
    Equations schedule_one
              (schedule: Sys -> ctree (frameE n +' E) C void)
              (sys: Sys) (r: uid n): ctree (frameE n +' E) C void :=
      schedule_one schedule sys r with sys $ r => {
          schedule_one _ _ _ (Running a q) with observe a => {
            (** A previous choice, traverse it *)
            schedule_one _ _ _ _ (BrF b c k) :=
            Br b c (fun i' => schedule (sys @ r := Running (k i') q));

            (** A network `send` effect, interpet it! *)
            schedule_one _ _ _ _ (VisF (inl1 (Send m)) k) :=
            let msg' := {| principal := r; payload := payload m |} in
            let sys' := sys @ r := Running (k tt) q in
            match sys $ principal m with
            | Running a' q' =>
                (** Deliver to running *)
                Guard (schedule (sys' @ (principal m) := Running a' (List.cons msg' q')))
            | Blocked kk =>
                (** Deliver to blocked processes and unblock them *)
                Guard (schedule (sys' @ (principal m) := Running (kk (Some msg')) List.nil))
            end;

            (** Receive a message *)
            schedule_one _ _ _ _ (VisF (inl1 Recv) k) :=
            (** Check my inbox q *)
            match last q with
            | Some msg =>
                (** Pop the msg from the end *)
                Guard (schedule (sys @ r := Running (k (Some msg)) (init q)))
            | None =>
                (** Becomes blocked if no messages in q *)
                Guard (schedule (sys @ r := Blocked k))
            end;

            (** Broadcast a message to everyone *)
            schedule_one _ _ _ _ (VisF (inl1 (Broadcast b)) k) :=
            let msg := {| principal := r; payload := b |} in
            let sys' := Vector.map (fun a => match a with
                                          | Running a q => Running a (List.cons msg q)
                                          | Blocked kk => Running (kk (Some msg)) List.nil
                                          end) sys in
            Guard (schedule (sys' @ r := Running (k tt) q));

            (** Some other downstream effect, trigger *)
            schedule_one _ _ _ _ (VisF (inr1 e) k) :=
            Guard (schedule (sys @ r := Running (trigger e >>= k) q))
          };
          (** If the agent is blocked, it could timeout or stay blocked *)
          schedule_one _ _ _ (Blocked k) :=
            brD2
              (schedule (sys @ r := Running (k None) List.nil))  (** Timeout *)
              (schedule (sys @ r := Blocked k));                 (** Keep blocking *)
        }.

    CoFixpoint schedule(sys: Sys): ctree (frameE n +' E) C void :=
      (* Nondterministic pick of a client to run *)
      r <- branch true (branchn n) ;;
      (* Mark context switch *)
      enter r;;
      (* Schedule it *)
      schedule_one schedule sys r.

    (*| Fair scheduler, uses a list of scheduled processes to avoid
      infinitely rescheduling the same process. |*)
    CoFixpoint schedule_fair'(picked: list (fin n))(sys: Sys):
      ctree (frameE n +' E) C void :=
      if (length picked =? n) then
        r <- branch true (branchn n);;
        enter r;;
        schedule_one (schedule_fair' [r]%list) sys r
      else
        r <- CTree.iter (fun _: unit =>
                          r <- branch true (branchn n) ;;
                          if (in_dec Fin.eq_dec r picked) then
                            ret (inl tt)
                          else
                            ret (inr r)) tt;;
        enter r;;
        schedule_one (schedule_fair' (r :: picked)) sys r.

    Notation schedule_fair := (schedule_fair' []%list) (only parsing).

    Transparent schedule.
    Transparent schedule_fair'.
    Transparent schedule_one.
    Transparent vector_replace.

    Lemma unfold_schedule(sys: Sys) :
      schedule sys ≅ (r <- branch true (branchn n) ;; enter r;; schedule_one schedule sys r).
    Proof.
      __step_equ; cbn; econstructor; reflexivity.
    Qed.

    (** Evaluates Net *)
    Program Definition run_network(s: vec n (ctree (Net n msg +' E) C void)):
      ctree (frameE n +' E) C void :=
      schedule (Vector.map (fun it => Running it List.nil) s).

    #[global] Instance sbisim_network_goal `{B0 -< C}:
      Proper (pairwise (sbisim eq) ==> sbisim eq) run_network.
    Proof.
      unfold Proper, pairwise, respectful.
      unfold sbisim.
      coinduction ? CIH.
      intros x y FORALL.
      unfold run_network.
      (* TODO: complete *)
    Admitted.

  End Scheduler.
End Network.


Require Import sflib.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import Loc.
Require Import Coqlib.
Require Import Language.

Require Import Time.
Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import NPThread.
Require Import Configuration.
Require Import MsgMapping.

Require Import MemoryReorder.
Require Import ReorderPromise.
Require Import ReorderReserve.
Require Import ReorderCancel.

(* Promises injection *)
Inductive promise_inj_weak: Mapping -> Memory.t -> Memory.t -> Prop :=
| Promise_inj_intro
    promises1 promises2 inj
    (SOUND: forall loc to val from released,
        Memory.get loc to promises1 = Some (from, Message.concrete val released) ->
        exists to' released' from',
          inj loc to = Some to' /\
          Memory.get loc to' promises2 = Some (from', Message.concrete val released') /\
          Time.lt from' to')
    (COMPLETE: forall loc to' val from' released',
        Memory.get loc to' promises2 = Some (from', Message.concrete val released') ->
        exists to released from,
          inj loc to = Some to' /\
          Memory.get loc to promises1 = Some (from, Message.concrete val released))
    (RSV_SOUND: forall loc to from,
        Memory.get loc to promises1 = Some (from, Message.reserve) ->
        Memory.get loc to promises2 = Some (from, Message.reserve))
    (RSV_COMPLETE: forall loc to from,
        Memory.get loc to promises2 = Some (from, Message.reserve) ->
        Memory.get loc to promises1 = Some (from, Message.reserve)):
    promise_inj_weak inj promises1 promises2.

Lemma promise_inj_weak_incr
      inj inj' promises promises'
      (P_INJ: promise_inj_weak inj promises promises')
      (INJ_INCR: incr_inj inj inj'):
  promise_inj_weak inj' promises promises'.
Proof.
  inv P_INJ.
  econs; ii; eauto.
  {
    eapply SOUND in H; eauto.
    des; eauto.
    exists to', released', from'.
    split; eauto.
  }
  {
    eapply COMPLETE in H; eauto.
    des; eauto.
    do 3 eexists.
    split; eauto.
  }
Qed.

Lemma promise_inj_weak_remove_reseve
      inj promises promises' loc from to promises1 promises1'
      (P_INJ: promise_inj_weak inj promises promises')
      (REMOVE_RSV1: Memory.remove promises loc from to Message.reserve promises1)
      (REMOVE_RSV2: Memory.remove promises' loc from to Message.reserve promises1'):
  promise_inj_weak inj promises1 promises1'.
Proof.
  inv P_INJ.
  econs; ii.
  {
    erewrite Memory.remove_o in H; eauto.
    des_ifH H; ss; subst; eauto.
    eapply SOUND in H; eauto.
    destruct H as (to' & released' & from' & INJ & GET).
    exists to', released', from'. split; eauto.
    erewrite Memory.remove_o; eauto.
    des_if; eauto. ss. des; subst. ss.
    clear - REMOVE_RSV2 GET.
    exploit Memory.remove_get0; eauto; ii; des.
    rewrite GET in GET0; inv GET0; eauto.
  }
  {
    erewrite Memory.remove_o in H; eauto.
    des_ifH H; ss; des; eauto.
    exploit COMPLETE; eauto; ii; des.
    exploit Memory.remove_get1; [eapply REMOVE_RSV1 | eauto..]. ii.
    des; subst; ss.
    do 3 eexists. split; eauto.
    exploit COMPLETE; eauto; ii; des.
    exploit Memory.remove_get1; [eapply REMOVE_RSV1 | eauto..]. ii.
    des; subst; ss.
    eapply Memory.remove_get0 in REMOVE_RSV1; eauto; des.
    rewrite GET in H1. inv H1.
    do 3 eexists. split; eauto.
  }
  {
    erewrite Memory.remove_o in H; eauto.
    des_ifH H; ss.
    eapply RSV_SOUND in H.
    exploit Memory.remove_get1; eauto. ii.
    destruct H0; eauto.
    destruct H0; subst; des; ss.
  }
  {
    erewrite Memory.remove_o in H; eauto.
    des_ifH H; ss.
    eapply RSV_COMPLETE in H.
    erewrite Memory.remove_o; eauto.
    des_if; eauto.
    ss; des; subst; ss.
  }
Qed.

Lemma promise_inj_weak_remove_concrete
      inj promises promises' loc from to msg from' to' msg' promises1 promises1'
      (P_INJ: promise_inj_weak inj promises promises')
      (REMOVE_RSV1: Memory.remove promises loc from to msg promises1)
      (REMOVE_RSV2: Memory.remove promises' loc from' to' msg' promises1')
      (INJ: inj loc to = Some to')
      (MON: monotonic_inj inj)
      (CONCRETE_MSG: exists val released, msg = Message.concrete val released):
  promise_inj_weak inj promises1 promises1'.
Proof.
  des; subst.
  inv P_INJ.
  econs; ii.
  {
    erewrite Memory.remove_o in H; eauto.
    des_ifH H; ss.
    exploit SOUND; eauto. ii.
    destruct H0 as (to1 & released1 & from1 & INJ1 & GET1 & Time_LT).
    destruct (Loc.eq_dec loc0 loc).
    {
      des; subst; ss.
      assert(to' <> to1).
      {
        eapply monotonic_inj_implies_disj_mapping; eauto.
      }
      eapply Memory.remove_get1 in GET1; eauto; des; subst; ss.
      do 3 eexists; eauto.
    }
    {
      eapply Memory.remove_get1 in GET1; eauto; des; subst; ss.
      do 3 eexists; eauto.
      do 3 eexists; eauto.
    }
  }
  {
    erewrite Memory.remove_o in H; eauto.
    des_ifH H; ss; des; ss; eauto.
    exploit COMPLETE; eauto; ii; des.
    exploit Memory.remove_get1; [eapply REMOVE_RSV1 | eauto..]. ii.
    des; subst; ss.
    do 3 eexists. split; eauto.
    exploit COMPLETE; eauto; ii; des.
    exploit Memory.remove_get1; [eapply REMOVE_RSV1 | eauto..]. ii.
    des; subst; ss.
    rewrite INJ in H0; inv H0; ss.
    do 3 eexists. split; eauto.
  }
  {
    erewrite Memory.remove_o in H; eauto.
    des_ifH H; ss; des; ss; eauto.
    eapply RSV_SOUND in H; eauto.
    erewrite Memory.remove_o; eauto.
    des_if; eauto; ss; des; subst; ss.
    eapply RSV_SOUND in H; eauto.
    erewrite Memory.remove_o; eauto.
    des_if; eauto; ss; des; subst; ss.
    exploit Memory.remove_get0; eauto; ii; des.
    rewrite GET in H; inv H.
    exploit Memory.remove_get0; [eapply REMOVE_RSV1 | eauto..]; ii; des.
    eapply SOUND in GET1; eauto; des.
    rewrite INJ in GET1; inv GET1.
    rewrite GET in GET3. inv GET3.
  }
  {
    erewrite Memory.remove_o in H; eauto.
    des_ifH H; ss.
    eapply RSV_COMPLETE in H.
    erewrite Memory.remove_o; eauto.
    des_if. ss. destruct a; subst. des; ss.
    exploit Memory.remove_get0; [eapply REMOVE_RSV1 | eauto..]; ii; des.
    rewrite H in GET; inv GET.
    ss.
  }
Qed.

Lemma promise_inj_weak_split
      inj promises promises' loc from to ts val msg1 msg2 from' to' msg1' msg2' ts' promises1 promises1'
      (P_INJ: promise_inj_weak inj promises promises')
      (SPLIT1: Memory.split promises loc from to ts msg1 msg2 promises1)
      (SPLIT2: Memory.split promises' loc from' to' ts' msg1' msg2' promises1')
      (INJ: inj loc to = Some to')
      (INJ': inj loc ts = Some ts')
      (MON: monotonic_inj inj)
      (CONCRETE_MSG1: exists released, msg1 = Message.concrete val released)
      (CONCRETE_MSG1': exists released, msg1' = Message.concrete val released)
      (CONCRETE_MSG2: exists val released, msg2 = Message.concrete val released)
      (CONCRETE_MSG2': exists val released, msg2' = Message.concrete val released):
  promise_inj_weak inj promises1 promises1'.
Proof.
  subst. des; subst.
  inv P_INJ.
  econs; ii.
  {
    dup H.
    erewrite Memory.split_o in H; eauto.
    des_ifH H; eauto; ss; des; subst.
    {
      inv H.
      exploit Memory.split_get0; [eapply SPLIT1 | eauto..]. ii; des.
      rewrite GET1 in H0; inv H0.
      exploit Memory.split_get0; [eapply SPLIT2 | eauto..]. ii; des.
      do 3 eexists. split; eauto.
      split; eauto.
      exploit MemoryProps.split_succeed_wf; [eapply SPLIT2 | eauto..]. ii; des; eauto.
    }
    {
      des_ifH H; ss; des; subst; ss.
      exploit SOUND; [eapply H | eauto..]; ii; des.
      assert(Memory.get loc0 to'0 promises1' = Some (from'0, Message.concrete val2 released')).
      {
        erewrite Memory.split_o; eauto.
        des_if; ss; subst; des; subst; ss; eauto.
        des_if; ss; subst; des; subst; ss; eauto.
        des_if; ss; subst; des; subst; ss.
      }
      do 3 eexists. split; eauto.
      exploit SOUND; [eapply H | eauto..]; ii; des.
      assert(Memory.get loc0 to'0 promises1' = Some (from'0, Message.concrete val2 released')).
      {
        erewrite Memory.split_o; eauto.
        des_if; ss; subst; des; subst; ss.
        des_if; ss; subst; des; subst; ss.
        des_if; ss; subst; des; subst; ss.
      }
      do 3 eexists. split; eauto.
    }
    des_ifH H; ss; des; subst; ss.
    {
      inv H.
      exploit Memory.split_get0; [eapply SPLIT1 | eauto..]. ii; des.
      rewrite GET2 in H0; inv H0.
      exploit SOUND; eauto. ii; des.
      rewrite INJ' in H. inv H.
      exploit Memory.split_get0; [eapply SPLIT2 | eauto..]. ii; des.
      rewrite GET4 in H0. inv H0.
      do 3 eexists. split; eauto.
      split; eauto.
      exploit MemoryProps.split_succeed_wf; [eapply SPLIT2 | eauto..]. ii; des; eauto.
    }
    {
      exploit SOUND; eauto. ii; des.
      assert(Memory.get loc0 to'0 promises1' = Some (from'0, Message.concrete val2 released')).
      {
        erewrite Memory.split_o; eauto.
        des_if; ss; subst; des; subst; ss.
        des_if; ss; subst; des; subst; ss.
        des_if; ss; subst; des; subst; ss.
      }
      do 3 eexists. split; eauto.
    }
    {
      exploit SOUND; eauto. ii; des.
      do 3 eexists.
      split; eauto.
      erewrite Memory.split_o; eauto.
      instantiate (2 := released').
      instantiate (1 := from'0).
      des_if; ss; des; subst.
      clear - INJ o H1 MON.
      exploit monotonic_inj_implies_disj_mapping; [eapply MON | eapply H1 | eapply INJ | eapply o | eauto..].
      ii; ss.
      des_if; ss; des; subst; ss.
      des_if; ss; des; subst; ss.
      clear - INJ' o0 H1 MON.
      exploit monotonic_inj_implies_disj_mapping; [eapply MON | eapply H1 | eapply INJ' | eapply o0 | eauto..].
      ii; ss.
    }
  }
  {
    dup H.
    erewrite Memory.split_o in H; eauto.
    des_ifH H; eauto; ss; des; subst.
    {
      inv H.
      exploit Memory.split_get0; [eapply SPLIT2 | eauto..]. ii; des.
      rewrite GET1 in H0; inv H0.
      exploit Memory.split_get0; [eapply SPLIT1 | eauto..]. ii; des.
      do 3 eexists. split; eauto.
    }
    {
      des_ifH H; ss; des; subst; ss.
      exploit COMPLETE; [eapply H | eauto..]; ii; des.
      assert(Memory.get loc0 to0 promises1 = Some (from0, Message.concrete val2 released3)).
      {
        erewrite Memory.split_o; eauto.
        des_if; ss; subst; des; subst; ss; eauto.
        des_if; ss; subst; des; subst; ss; eauto.
        des_if; ss; subst; des; subst; ss.
      }
      do 3 eexists. split; eauto.
      exploit COMPLETE; [eapply H | eauto..]; ii; des.
      assert(Memory.get loc0 to0 promises1 = Some (from0, Message.concrete val2 released3)).
      {
        erewrite Memory.split_o; eauto.
        des_if; ss; subst; des; subst; ss.
        des_if; ss; subst; des; subst; ss.
        des_if; ss; subst; des; subst; ss.
      }
      do 3 eexists. split; eauto.
    }
    des_ifH H; ss; des; subst; ss.
    {
      inv H.
      exploit Memory.split_get0; [eapply SPLIT2 | eauto..]. ii; des.
      rewrite GET2 in H0; inv H0.
      exploit COMPLETE; eauto. ii; des.
      assert(to0 = ts).
      {
        clear - MON INJ' H.
        destruct(Time.eq_dec to0 ts); eauto.
        exploit monotonic_inj_implies_disj_mapping; [eapply MON | eapply H | eapply INJ' | eapply n | eauto..].
        ii; ss.
      }
      subst.
      rewrite INJ' in H. inv H.
      exploit Memory.split_get0; [eapply SPLIT1 | eauto..]. ii; des.
      rewrite GET4 in H0. inv H0.
      do 3 eexists. split; eauto.
    }
    {
      exploit COMPLETE; eauto. ii; des.
      assert(Memory.get loc0 to0 promises1 = Some (from0, Message.concrete val2 released3)).
      {
        erewrite Memory.split_o; eauto.
        des_if; ss; subst; des; subst; ss.
        des_if; ss; subst; des; subst; ss.
        des_if; ss; subst; des; subst; ss.
      }
      do 3 eexists. split; eauto.
    }
    {
      exploit COMPLETE; eauto. ii; des.
      do 3 eexists.
      split; eauto.
      erewrite Memory.split_o; eauto.
      instantiate (1 := released3).
      instantiate (1 := from0).
      des_if; ss; des; subst.
      clear - INJ o H1 MON.
      rewrite INJ in H1. inv H1. ss.
      des_if; ss; des; subst; ss.
      des_if; ss; des; subst; ss.
      rewrite INJ' in H1. inv H1. ss.
    }
  }
  {
    erewrite Memory.split_o in H; eauto.
    des_ifH H; eauto; ss; des; ss.
    des_ifH H; eauto; ss; des; ss.
    eapply RSV_SOUND in H.
    erewrite Memory.split_o; eauto.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    eapply RSV_SOUND in H.
    erewrite Memory.split_o; eauto.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    des_ifH H; eauto; ss; des; ss.
    eapply RSV_SOUND in H.
    erewrite Memory.split_o; eauto.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    eapply RSV_SOUND in H.
    erewrite Memory.split_o; eauto.
    des_if; ss; des; ss.
    subst.
    exploit Memory.split_get0; [eapply SPLIT2 | eauto..]; ii; des.
    rewrite H in GET. ss.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    subst.
    exploit Memory.split_get0; [eapply SPLIT2 | eauto]; ii; des.
    rewrite GET0 in H. inv H.
  }
  {
    erewrite Memory.split_o in H; eauto.
    des_ifH H; eauto; ss; des; ss.
    des_ifH H; eauto; ss; des; ss.
    eapply RSV_COMPLETE in H.
    erewrite Memory.split_o; eauto.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    eapply RSV_COMPLETE in H.
    erewrite Memory.split_o; eauto.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    des_ifH H; eauto; ss; des; ss.
    eapply RSV_COMPLETE in H.
    erewrite Memory.split_o; eauto.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    eapply RSV_COMPLETE in H.
    erewrite Memory.split_o; eauto.
    des_if; ss; des; ss.
    subst.
    exploit Memory.split_get0; [eapply SPLIT1 | eauto]; ii; des.
    rewrite H in GET. ss.
    des_if; ss; des; ss.
    des_if; ss; des; ss.
    subst.
    exploit Memory.split_get0; [eapply SPLIT1 | eauto]; ii; des.
    rewrite GET0 in H. inv H.
  }
Qed.

Lemma promise_inj_weak_lower
      inj promises promises' loc from to msg1 msg2 from' to' msg1' msg2' promises1 promises1'
      (P_INJ: promise_inj_weak inj promises promises')
      (LOWER1: Memory.lower promises loc from to msg1 msg2 promises1)
      (LOWER2: Memory.lower promises' loc from' to' msg1' msg2' promises1')
      (CONCRETE: exists val released, msg1 = Message.concrete val released)
      (INJ: inj loc to = Some to'):
  promise_inj_weak inj promises1 promises1'.
Proof.
  inv P_INJ. des; subst.
  econs; ii.
  {
    erewrite Memory.lower_o in H; eauto.
    des_ifH H; eauto; ss; des; subst; ss.
    {
      inv H.
      eapply Memory.lower_get0 in LOWER1; eauto; des.
      inv MSG_LE.
      exploit SOUND; eauto; ii; des.
      rewrite INJ in H; inv H.
      eapply Memory.lower_get0 in LOWER2; eauto; des.
      rewrite GET1 in H0; inv H0.
      inv MSG_LE. do 3 eexists. split; eauto.
    }
    {
      eapply SOUND in H; eauto; des; subst.
      eapply Memory.lower_get1 in LOWER2; eauto; des.
      inv MSG_LE.
      do 3 eexists.
      split; eauto.
    }
    {
      eapply SOUND in H; eauto. des; subst.
      eapply Memory.lower_get1 in LOWER2; eauto; des.
      inv MSG_LE.
      do 3 eexists.
      split; eauto.
    }
  }
  {
    erewrite Memory.lower_o in H; eauto.
    des_ifH H; ss; des; subst; eauto.
    {
      inv H.
      eapply Memory.lower_get0 in LOWER1; eauto; des. inv MSG_LE.
      eapply Memory.lower_get0 in LOWER2; eauto; des. inv MSG_LE.
      exploit SOUND; eauto. ii; des.
      rewrite INJ in H; inv H.
      rewrite GET1 in H0. inv H0.
      do 3 eexists. split; eauto.
      exploit SOUND; eauto. ii; des.
      rewrite INJ in H; inv H.
      rewrite GET1 in H0; inv H0.
    }
    {
      eapply COMPLETE in H; eauto. des.
      exploit Memory.lower_get1; [eapply LOWER1 | eauto..].
      ii; des. inv MSG_LE.
      do 3 eexists. split; eauto.
    }
    {
      eapply COMPLETE in H; eauto. des.
      exploit Memory.lower_get1; [eapply LOWER1 | eauto..].
      ii; des. inv MSG_LE.
      do 3 eexists. split; eauto.
    }
  }
  {
    erewrite Memory.lower_o in H; eauto.
    des_ifH H; ss; des; subst; eauto.
    {
      inv H.
      eapply Memory.lower_get0 in LOWER1; eauto; des.
      inv MSG_LE.
    }
    {
      eapply RSV_SOUND in H.
      erewrite Memory.lower_o; eauto.
      des_if; eauto; ss; des; subst; ss.
    }
    {
      eapply RSV_SOUND in H.
      erewrite Memory.lower_o; eauto.
      des_if; eauto; ss; des; subst; ss.
      eapply Memory.lower_get0 in LOWER1; eauto; des.
      eapply Memory.lower_get0 in LOWER2; eauto; des.
      eapply SOUND in GET; des; eauto.
      rewrite INJ in GET; inv GET.
      rewrite GET3 in GET1; inv GET1.
      inv MSG_LE.
      rewrite GET3 in H. inv H.
    }
  }
  {
    erewrite Memory.lower_o in H; eauto.
    des_ifH H; eauto; ss; des; ss; subst.
    {
      inv H.
      eapply Memory.lower_get0 in LOWER1; eauto; des.
      inv MSG_LE.
      eapply SOUND in GET; eauto; des.
      rewrite INJ in GET; inv GET.
      eapply Memory.lower_get0 in LOWER2; eauto; des.
      rewrite GET1 in GET; inv GET.
      inv MSG_LE.
    }
    {
      eapply RSV_COMPLETE in H.
      erewrite Memory.lower_o; eauto.
      des_if; eauto; ss; subst; des; ss.
    }
    {
      eapply RSV_COMPLETE in H.
      erewrite Memory.lower_o; eauto.
      des_if; eauto; ss; des; subst; ss.
      eapply Memory.lower_get0 in LOWER1; eauto; des.
      rewrite GET in H. inv H.
    }
  }
Qed.

Lemma mem_nonsynch_loc_msgInj_weak
      promises promises' mem mem' inj loc
      (MEM_INJ: MsgInj inj mem mem')
      (LE1: Memory.le promises mem)
      (LE2: Memory.le promises' mem')
      (PROM_INJ: promise_inj_weak inj promises promises')
      (NONSYNC_LOC: Memory.nonsynch_loc loc promises):
  Memory.nonsynch_loc loc promises'.
Proof.
  unfold Memory.nonsynch_loc in *; ii.
  inv PROM_INJ.
  destruct msg; ss.
  dup GET.
  exploit COMPLETE; eauto. ii; des.
  exploit NONSYNC_LOC; eauto. ii; ss; subst.
  inv MEM_INJ.
  dup H0.
  eapply LE1 in H1.
  eapply SOUND0 in H1; eauto. des.
  rewrite H in H1. inv H1.
  unfold opt_ViewInj in H2. destruct R'; ss.
  eapply LE2 in GET.
  rewrite GET in H3. inv H3; eauto.
Qed.

Lemma mem_nonsynch_msgInj_weak
      promises promises' mem mem' inj
      (MEM_INJ: MsgInj inj mem mem')
      (LE1: Memory.le promises mem)
      (LE2: Memory.le promises' mem')
      (PROM_INJ: promise_inj_weak inj promises promises')
      (NONSYNC: Memory.nonsynch promises):
  Memory.nonsynch promises'.
Proof.
  unfold Memory.nonsynch in *. intro loc.
  specialize (NONSYNC loc).
  eapply mem_nonsynch_loc_msgInj_weak; eauto.
Qed.

Lemma promise_inj_weak_bot
      promises promises' inj
      (PROM_INJ: promise_inj_weak inj promises promises')
      (BOT: promises = Memory.bot):
  promises' = Memory.bot.
Proof.
  subst.
  inv PROM_INJ.
  destruct (classic (exists loc to from msg, Memory.get loc to promises' = Some (from, msg))).
  {
    des.
    destruct msg.
    eapply COMPLETE in H; eauto; des.
    rewrite Memory.bot_get in H0; ss.
    eapply RSV_COMPLETE in H; eauto; des.
    rewrite Memory.bot_get in H; ss.
  }
  {
    eapply Memory.ext; ii.
    rewrite Memory.bot_get.
    destruct (Memory.get loc ts promises') eqn:Heqe; eauto.
    destruct p.
    contradiction H; eauto.
  }
Qed.

Lemma write_step_promise_inj_weak_stable
      lc1 sc1 mem1 loc from1 to1 val releasedr1 releasedw1 ord lc1' sc1' mem1' kind1 lo
      lc2 sc2 mem2 from2 to2 releasedr2 releasedw2 lc2' sc2' mem2' kind2
      inj inj'
      (WRITE1: Local.write_step lc1 sc1 mem1 loc from1 to1 val releasedr1 releasedw1 ord lc1' sc1' mem1' kind1 lo)
      (WRITE2: Local.write_step lc2 sc2 mem2 loc from2 to2 val releasedr2 releasedw2 ord lc2' sc2' mem2' kind2 lo)
      (PROM_INJ: promise_inj_weak inj (Local.promises lc1) (Local.promises lc2))
      (INJ_INCR: incr_inj inj inj')
      (INJ: inj' loc to1 = Some to2)
      (MON: monotonic_inj inj')
      (KIND_MATCH: kind_match kind1 kind2)
      (SPLIT: forall t val R, kind1 = Memory.op_kind_split t (Message.concrete val R) ->
                         exists t' val' R', kind2 = Memory.op_kind_split t' (Message.concrete val' R') /\
                                       to1 = to2 /\ inj loc t = Some t'):
  promise_inj_weak inj' (Local.promises lc1') (Local.promises lc2').
Proof.
  inv WRITE1; ss. inv WRITE. inv PROMISE.
  - destruct kind2; ss.
    inv WRITE2; ss. inv WRITE. inv PROMISE.
    assert(Local.promises lc1 = promises2).
    {
      eapply MemoryMerge.MemoryMerge.add_remove; eauto.
    }
    subst.
    assert(Local.promises lc2 = promises1).
    {
      eapply MemoryMerge.MemoryMerge.add_remove; eauto.
    }
    subst.
    eapply promise_inj_weak_incr; eauto.
  - des; subst. inv RESERVE.
    destruct kind2; ss.
    exploit SPLIT; eauto. ii; des; subst.
    inv H. des; subst.
    assert(promise_inj_weak inj' (Local.promises lc1) (Local.promises lc2)).
    {
      eapply promise_inj_weak_incr; eauto.
    }
    inv WRITE2; ss.
    inv WRITE. inv PROMISE. des; ss.
    inv RESERVE. inv RESERVEORIGINAL.
    exploit promise_inj_weak_split; eauto.
    ii.
    eapply promise_inj_weak_remove_concrete; eauto.
  - des; subst.
    destruct kind2; ss.
    inv WRITE2; ss. inv WRITE. inv PROMISE. des; subst.
    subst.
    assert(INJ'': inj loc to1 = Some to2).
    {
      clear - PROM_INJ INJ INJ_INCR PROMISES PROMISES0.
      exploit Memory.lower_get0; [eapply PROMISES | eauto..]. ii; des.
      inv PROM_INJ.
      eapply SOUND in GET; eauto. des.
      dup GET.
      eapply INJ_INCR in GET. rewrite GET in INJ. inv INJ. eauto.
    }
    exploit promise_inj_weak_lower; eauto. ii.
    eapply promise_inj_weak_incr in H; eauto.
    eapply promise_inj_weak_remove_concrete in H; eauto.
  - ss.
Qed.

Definition promise_fulfill_kind_match (kind1 kind2: Memory.op_kind) :=
  match kind1, kind2 with
  | Memory.op_kind_split to (Message.concrete val R),
    Memory.op_kind_split to' (Message.concrete val' R') => val = val'
  | Memory.op_kind_lower (Message.concrete val R),
    Memory.op_kind_lower (Message.concrete val' R') => val = val'
  | _, _ => False
  end.

Lemma promise_fulfill_promise_inj_weak_stable
      lc1 sc1 mem1 loc from1 to1 val releasedr1 releasedw1 ord lc1' sc1' mem1' kind1 lo
      lc2 sc2 mem2 from2 to2 releasedr2 releasedw2 lc2' sc2' mem2' kind2
      inj inj'
      (WRITE1: Local.write_step lc1 sc1 mem1 loc from1 to1 val releasedr1 releasedw1 ord lc1' sc1' mem1' kind1 lo)
      (WRITE2: Local.write_step lc2 sc2 mem2 loc from2 to2 val releasedr2 releasedw2 ord lc2' sc2' mem2' kind2 lo)
      (PROM_INJ: promise_inj_weak inj (Local.promises lc1) (Local.promises lc2))
      (INJ_INCR: incr_inj inj inj')
      (INJ: inj' loc to1 = Some to2)
      (MON: monotonic_inj inj')
      (KIND_MATCH: promise_fulfill_kind_match kind1 kind2)
      (SPLIT: forall t val R, kind1 = Memory.op_kind_split t (Message.concrete val R) ->
                         exists t' val' R', kind2 = Memory.op_kind_split t' (Message.concrete val' R') /\
                                       inj loc t = Some t'):
  promise_inj_weak inj' (Local.promises lc1') (Local.promises lc2').
Proof.
  destruct kind1; ss.
  - destruct msg3; ss.
    destruct kind2; ss.
    destruct msg3; ss. subst.
    inv WRITE1; ss. inv WRITE; ss. inv PROMISE; ss.
    inv WRITE2; ss. inv WRITE; ss. inv PROMISE; ss.
    des; subst. inv RESERVE0. inv RESERVEORIGINAL0. inv RESERVE.
    exploit SPLIT; eauto. ii; des; subst.
    inv H.
    assert(promise_inj_weak inj' (Local.promises lc1) (Local.promises lc2)).
    {
      eapply promise_inj_weak_incr; eauto.
    }
    exploit promise_inj_weak_split; eauto.
    ii.
    eapply promise_inj_weak_remove_concrete; eauto.
  - destruct msg1; ss. destruct kind2; ss. destruct msg1; ss. subst.
    inv WRITE1; ss. inv WRITE; ss. inv PROMISE; ss.
    inv WRITE2; ss. inv WRITE; ss. inv PROMISE; ss.
    des; subst. inv RESERVE0.
    assert(INJ'': inj loc to1 = Some to2).
    {
      clear - PROM_INJ INJ INJ_INCR PROMISES PROMISES0.
      exploit Memory.lower_get0; [eapply PROMISES | eauto..]. ii; des.
      inv PROM_INJ.
      eapply SOUND in GET; eauto. des.
      dup GET.
      eapply INJ_INCR in GET. rewrite GET in INJ. inv INJ. eauto.
    }
    exploit promise_inj_weak_lower; eauto. ii.
    eapply promise_inj_weak_incr in H; eauto.
    eapply promise_inj_weak_remove_concrete in H; eauto.
Qed.


Require Import Kami.All.

Definition EffectfulRelation {k: Kind} (R: RegsT -> RegsT -> Prop) (a_i a_s: ActionT type k): Prop :=
  forall o_i o_s,
    R o_i o_s ->
    forall calls reads_i upds_i retval,
      SemAction o_i a_i reads_i upds_i calls retval ->
        exists reads_s upds_s,
          (SemAction o_s a_s reads_s upds_s calls retval) /\
          R (doUpdRegs upds_i o_i) (doUpdRegs upds_s o_s).

Definition EffectlessRelation {k: Kind} (R: RegsT -> RegsT -> Prop) (a_i a_s: ActionT type k): Prop :=
  forall o_i o_s,
    R o_i o_s ->
    forall reads_i upds calls retval,
      SemAction o_i a_i reads_i upds calls retval ->
      (upds = [] /\
       calls = [] /\
       exists reads_s,
        (SemAction o_s a_s reads_s [] [] retval)).

Definition ActionWb {k} myRegs (act: ActionT type k): Prop :=
  forall o reads upds calls ret,
    NoDup (map fst o) ->
    SubList myRegs (getKindAttr o) ->
    SemAction o act reads upds calls ret ->
    ((exists o',
         SubList o' o
         /\ SubList reads o'
         /\ getKindAttr o' = myRegs
         /\ SemAction o' act reads upds calls ret
     ) /\
     SubList (getKindAttr upds) myRegs).


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal30.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (l1:lst) (n0:natural) (l2:lst):@eq lst (Cons n (append l1 (Cons n0 (append l2 Nil))))
  (Cons n (append (append l1 (Cons n0 l2)) Nil)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal30_append_assoc_35_append_nil/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (l1:lst) (n0:natural) (l2:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"l1:" ++ "(" ++ show l1 ++ ")"++ "|" ++"n0:" ++ "(" ++ show n0 ++ ")"++ "|" ++"l2:" ++ "(" ++ show l2 ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  l1 n0 l2.
QuickChick collect_data.
Success.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl 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.

  VPrl 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 VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

 *)

Require Export continuity_type.
Require Export continuity_type_v2.
Require Export sequents2.
Require Export sequents_tacs.
Require Export per_props_squash.
Require Export per_props_isect.
Require Export lift_lsubst_tacs.

Lemma zero_in_int {o} :
  forall (lib : @library o), member lib mkc_zero mkc_int.
Proof.
  introv.
  rewrite mkc_zero_eq.
  apply nat_in_int.
Qed.
Hint Resolve zero_in_int : slow.

Lemma inhabited_type_mkc_int {o} :
  forall  (lib : @library o), inhabited_type lib mkc_int.
Proof.
  introv.
  exists (@mkc_zero o).
  eauto 3 with slow.
Qed.
Hint Resolve inhabited_type_mkc_int : slow.

Definition simple_eq_typec {o} lib (T : @NTerm o) :=
  forall w s c, simple_eq_type lib (lsubstc T w s c).

Definition rule_continuity {o}
           (F f T : @NTerm o)
           (H : barehypotheses)
           (i : nat) :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_squash (continuous_type_v2 F f T))))
      [
        mk_baresequent H (mk_conclax (mk_member F (mk_fun (mk_fun mk_int T) mk_int))),
        mk_baresequent H (mk_conclax (mk_member f (mk_fun mk_int T))),
        mk_baresequent H (mk_conclax (mk_member T (mk_uni i)))
      ]
      [].

Lemma rule_continuity_true3 {p} :
  forall lib
         (F f T : NTerm)
         (H : @barehypotheses p)
         (i : nat)
         (se : simple_eq_typec lib T),
    rule_true3 lib (rule_continuity
                      F f T
                      H i).
Proof.
  unfold rule_continuity, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  rename Hyp into hyp1.
  rename Hyp0 into hyp2.
  rename Hyp1 into hyp3.
  destruct hyp1 as [wc1 hyp1].
  destruct hyp2 as [wc2 hyp2].
  destruct hyp3 as [wc3 hyp3].
  destseq; allsimpl; proof_irr; GC.
  unfold closed_extract; simpl.

  assert (wf_csequent ((H) ||- (mk_conclax (mk_squash (continuous_type_v2 F f T))))) as wfs.
  { wfseq. }

  exists wfs.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  vr_seq_true.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as h; exrepnd; clear hyp1.

  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as k; exrepnd; clear hyp2.

  vr_seq_true in hyp3.
  pose proof (hyp3 s1 s2 eqh sim) as q; exrepnd; clear hyp3.

  lsubst_tac.

  apply equality_in_member in q1; repnd.
  clear q2 q3.
  apply member_in_uni in q1; auto.
  apply tequality_in_uni_implies_tequality in q0; auto;[].

  assert ((newvarlst [F, f, T]
           <> newvarlst
                [F, f, T, mk_var (newvarlst [F, f, T]),
                 mk_var (newvarlst [F, f, T, mk_var (newvarlst [F, f, T])])])
            # (newvarlst [F, f, T]
               <> newvarlst [F, f, T, mk_var (newvarlst [F, f, T])])
            # (newvarlst [F, f, T, mk_var (newvarlst [F, f, T])]
               <> newvarlst
                    [F, f, T, mk_var (newvarlst [F, f, T]),
                     mk_var (newvarlst [F, f, T, mk_var (newvarlst [F, f, T])])])
            # (!LIn (newvarlst
                       [F, f, T, mk_var (newvarlst [F, f, T]),
                        mk_var (newvarlst [F, f, T, mk_var (newvarlst [F, f, T])])])
                (free_vars f))
            # (!LIn (newvarlst [F, f, T, mk_var (newvarlst [F, f, T])]) (free_vars f))
            # (!LIn (newvarlst [F, f, T]) (free_vars f))
            # (!LIn (newvarlst
                       [F, f, T, mk_var (newvarlst [F, f, T]),
                        mk_var (newvarlst [F, f, T, mk_var (newvarlst [F, f, T])])])
                (free_vars F))
            # (!LIn (newvarlst [F, f, T, mk_var (newvarlst [F, f, T])]) (free_vars F))
            # (!LIn (newvarlst [F, f, T]) (free_vars F))
            # (!LIn (newvarlst
                       [F, f, T, mk_var (newvarlst [F, f, T]),
                        mk_var (newvarlst [F, f, T, mk_var (newvarlst [F, f, T])])])
                (free_vars T))
            # (!LIn (newvarlst [F, f, T, mk_var (newvarlst [F, f, T])]) (free_vars T))
            # (!LIn (newvarlst [F, f, T]) (free_vars T))
         ) as d.
  { repeat gen_newvar.
    repeat get_newvar_prop.
    allsimpl; allrw in_app_iff.
    allrw not_over_or; sp. }
  repnd.

  prove_and teq.

  - apply tequality_mkc_squash.
    allrw @member_eq.
    allrw <- @member_member_iff.
    allrw @tequality_mkc_member; repnd.
    allrw @fold_equorsq.

    unfold continuous_type_v2, continuous_type_aux_v2; simpl.
    lsubst_tac.

    apply tequality_product; dands; eauto with slow.

    { allrw @lsubstc_mkc_tnat.
      apply type_tnat. }

    introv e1.
    repeat substc_lsubstc_vars3.
    lsubst_tac.

    apply tequality_isect; dands.

    { lsubst_tac.
      auto. }

    introv e2.

    repeat substc_lsubstc_vars3.
    repeat one_lift_lsubst_concl.
    apply tequality_mkc_ufun; dands.

    { unfold agree_upto_b_type_v2.
      repeat one_lift_lsubst_concl.
      repeat one_lift_lsubst2_concl.

      apply tequality_isect; dands.

      - apply tequality_set; dands.

        { apply tequality_int. }

        introv e3.
        repeat substc_lsubstc_vars3.
        repeat one_lift_lsubst_concl.
        apply tequality_mkc_member_if_cequivc; dands.

        + unfold mk_natk_aux.
          repeat one_lift_lsubst_concl.
          repeat one_lift_lsubst2_concl.
          apply tequality_set; dands.

          { apply tequality_int. }

          introv e4.

          repeat substc_lsubstc_vars3.
          repeat one_lift_lsubst_concl.
          apply tequality_mkc_prod; dands.

          { repeat one_lift_lsubst2_concl.
            repeat one_lift_lsubst_concl.
            repeat (rw @lsubstc_cons_var).

            clear_cv.

            apply tequality_mkc_le.
            apply equality_in_int in e4.
            unfold equality_of_int in e4; exrepnd.
            exists (0%Z) k (0%Z) k; dands; spcast; auto;
            try (complete (unfold computes_to_valc; simpl;
                           unfold computes_to_value; dands;
                           eauto with slow)).

            destruct (Z_le_gt_dec 0 k); tcsp.
            right; dands; omega. }

          revert e1 e4.

          repeat one_lift_lsubst2_concl.
          repeat one_lift_lsubst_concl.
          repeat (rw @lsubstc_cons_var).
          lsubstc_snoc.
          introv e1 e4 inh1.

          apply equality_in_int_and_inhabited_le_implies_equality_in_nat in e4; auto.
          apply equality_in_tnat in e1.
          apply equality_in_tnat in e4.
          unfold equality_of_nat in e1.
          unfold equality_of_nat in e4.
          exrepnd.

          apply tequality_mkc_less_than.
          exists (Z.of_nat k) (Z.of_nat k4) (Z.of_nat k) (Z.of_nat k4).
          dands; spcast; auto.

          destruct (Z_lt_ge_dec (Z.of_nat k) (Z.of_nat k4)); tcsp.
          right; dands; omega.

        + unfold absolute_value, mk_natk_aux.
          repeat one_lift_lsubst2_concl.
          repeat one_lift_lsubst_concl.
          repeat one_lift_lsubst2_concl.
          repeat (rw @lsubstc_cons_var).
          revert e3; intro e3.
          fold (absolute_value_c a1).
          fold (absolute_value_c a'1).
          spcast.
          apply cequivc_absolute_value; auto.

      - introv e3.
        clear_cv.
        repeat substc_lsubstc_vars3.
        repeat one_lift_lsubst_concl.
        repeat one_lift_lsubst2_concl.
        repeat (rw @lsubstc_cons_var).
        lsubstc_snoc.
        clear_cv.

        apply tequality_fun in k2; repnd.
        autodimp k2 hyp; eauto 3 with slow.

        apply tequality_mkc_equality_if_equal; dands; auto.

        { revert k0.
          repeat one_lift_lsubst2_concl; intro k.
          apply equality_in_set in e3; repnd.
          clear - k1 e4 k.
          autodimp k hyp; lsubst_tac; auto.
          apply equality_in_fun in k; repnd.
          apply k; auto.
        }

        { revert e2; intro e2.
          unfold int2int in e2.
          repeat (one_lift_lsubst_hyp e2).
          repeat (one_lift_lsubst2_hyp e2).
          apply equality_in_set in e3; repnd.
          apply equality_in_fun in e2; repnd.
          apply e2; auto.
        }
    }

    { clear_cv.
      repeat one_lift_lsubst2_concl.
      intro inh.
      lsubstc_snoc_concl.
      revert h1 h0; intros h0 h1.
      unfold member in h0.
      repeat (one_lift_lsubst_hyp h0).
      autodimp h1 hyp.
      { clear - h0.
        lsubst_tac; auto. }
      autodimp k0 hyp.
      { clear - k1.
        lsubst_tac; auto. }

      clear - k0 h1 e2.
      lsubst_tac.

      apply tequality_mkc_equality_if_equal.

      { apply tequality_int. }

      { apply equality_in_fun in h1; repnd.
        apply h1.
        lsubst_tac; auto. }

      { apply equality_in_fun in h1; repnd.
        apply h1; auto.
        lsubst_tac; auto. }
    }

  - apply equality_in_mkc_squash; dands; spcast; auto;
    try computes_to_value_refl.

    allrw @member_eq.
    allrw <- @member_member_iff.
    allrw @tequality_mkc_member; repnd.
    allrw @fold_equorsq.

    pose proof (continuity_axiom_v2
                  lib
                  (lsubstc F wt1 s1 ct6)
                  (lsubstc T wt s1 ct2)) as cont.
    repeat (autodimp cont hyp).
    (* I need to generalize agree_upto in Lemma comp_force_int_step3_2 in continuity3_2_v2,
       which is used in Lemma continuity_axiom_v2 in continuity_axiom2_v2.
       First, I should try to generalize the "modulo alpha" to "modulo squiggle".
     *)
    {
      revert h1; unfold member; intro h.
      repeat (one_lift_lsubst_hyp h).
      eapply alphaeqc_preserving_equality;[apply h|].
      apply alphaeqc_mkc_fun; eauto 2 with slow.

      pose proof (lsubstc_mk_fun_ex mk_int T s1 wT0 cT1) as xx; exrepnd.
      eapply alphaeqc_trans;[exact xx1|clear xx1].
      clear_irr.
      rw @lsubstc_mk_int.
      apply alphaeqc_refl.
    }

    pose proof (cont (lsubstc f wt0 s1 ct4)) as cont1; clear cont.
    autodimp cont1 hyp.
    {
      revert k1; unfold member; intro h.
      repeat (one_lift_lsubst_hyp h).
      repeat (one_lift_lsubst2_hyp h).
      auto.
    }

    exrepnd.
    unfold continuous_type_v2, continuous_type_aux_v2; simpl.
    repeat (one_lift_lsubst_concl).
    repeat (one_lift_lsubst2_concl).
    exists (@mkc_pair p (mkc_nat b) mkc_axiom).

    rw @tequality_mkc_squash in teq.
    apply tequality_refl in teq.
    rw @fold_type in teq.
    unfold continuous_type_v2, continuous_type_aux_v2 in teq; simpl in teq.
    repeat (one_lift_lsubst_hyp teq).
    repeat (one_lift_lsubst2_hyp teq).

    apply member_product2; dands; auto.

    apply tequality_product in teq; repnd.
    pose proof (teq (mkc_nat b) (mkc_nat b)) as teq2; clear teq.
    allrw @fold_type.

    keepdimp teq2 teq.
    {
      apply equality_in_tnat.
      exists b; dands; spcast; eauto with slow;
      apply computes_to_valc_refl; eauto with slow.
    }

    exists (@mkc_nat p b) (@mkc_axiom p); dands; spcast; auto.

    { apply computes_to_valc_refl; eauto with slow. }

    { repeat substc_lsubstc_vars3.
      repeat one_lift_lsubst_concl.
      repeat (one_lift_lsubst_hyp teq2).
      allrw (@lsubstc_int2int).
      clear_cv.

      apply tequality_isect in teq2; repnd.

      apply equality_in_isect; dands; auto.

      intros g1 g2 e1.
      pose proof (teq2 g1 g2 e1) as teq3; clear teq2.
      allrw @fold_type.
      repeat substc_lsubstc_vars3.
      repeat one_lift_lsubst_concl.
      repeat (one_lift_lsubst_hyp teq3).
      clear_cv.
      apply tequality_refl in teq3.
      rw @fold_type in teq3.

      apply tequality_mkc_ufun in teq3; repnd.
      apply equality_in_ufun; dands; auto.
      intro inh.
      autodimp teq3 hyp;[].
      apply tequality_refl in teq2.
      apply tequality_refl in teq3.
      allrw @fold_type.

      revert teq3.
      lsubstc_snoc_concl.
      intro teq3.
      apply tequality_mkc_equality in teq3; repnd.

      GC.
      autodimp k0 hyp.
      autodimp teq3 hyp.
      { clear - h1 e1 d.
        lsubst_tac.
        apply equality_in_fun in h1; repnd.
        apply h1.
        lsubst_tac; auto.
        apply equality_refl in e1; auto. }
      autodimp h0 hyp.
      autodimp teq6 hyp.
      { clear - h1 k0.
        lsubst_tac.
        apply equality_in_fun in h1; repnd.
        apply h1.
        lsubst_tac.
        apply equality_refl in k0; auto.  }

      revert e1; intro e1.
      repeat (one_lift_lsubst_hyp e1).
      revert e1; lsubstc_snoc_concl; intro e1.

      pose proof (cont0 g1) as cont1; clear cont0.
      autodimp cont1 hyp.
      { apply equality_refl in e1; auto. }

      keepdimp cont1 cont2.
      {
        introv r1 r2 l.
        unfold agree_upto_b_type_v2 in inh.
        repeat (one_lift_lsubst_hyp inh).
        unfold inhabited_type in inh; exrepnd.
        rw @equality_in_isect in inh0; repnd.
        pose proof (inh0 t2 t2) as inh; clear inh0.
        repeat (one_lift_lsubst2_hyp inh1).
        repeat (one_lift_lsubst2_hyp inh2).
        repeat (one_lift_lsubst2_hyp inh).
        autodimp inh hyp.
        {
          rw @tequality_set in inh1; repnd.
          assert (equality lib t2 t2 mkc_int) as ei.
          {
            apply equality_in_int.
            exists i0; dands; spcast; auto;
            apply computes_to_valc_iff_reduces_toc; eauto with slow.
          }

          rw @equality_in_set; dands; auto; [].
          applydup inh1 in ei as inh3; clear inh1 inh2.
          repeat substc_lsubstc_vars3.
          apply tequality_refl in inh3.
          allrw @fold_type.
          repeat one_lift_lsubst_concl.
          repeat (one_lift_lsubst_hyp inh3).
          exists (@mkc_axiom p).
          rw <- @member_member_iff.
          apply tequality_mkc_member in inh3; repnd.
          allrw @fold_type.
          clear inh3.

          unfold absolute_value, mk_natk_aux.
          unfold absolute_value, mk_natk_aux in inh1.
          repeat one_lift_lsubst2_concl.
          repeat one_lift_lsubst_concl.
          repeat one_lift_lsubst2_concl.
          repeat (rw @lsubstc_cons_var).
          fold (absolute_value_c t2).

          repeat (one_lift_lsubst_hyp inh1).
          repeat (one_lift_lsubst2_hyp inh1).
          rw @tequality_set in inh1; repnd.

          pose proof (inh1 (absolute_value_c t2) (absolute_value_c t2)) as inh.
          keepdimp inh ai.
          {
            apply equality_in_int.
            unfold equality_of_int.
            exists (Z.abs i0).
            dands; spcast; apply computes_to_valc_absolute_value; auto;
            apply computes_to_valc_iff_reduces_toc; eauto with slow.
          }

          apply equality_in_set; dands; auto; clear inh1;[].

          repeat substc_lsubstc_vars3.
          apply tequality_refl in inh.
          allrw @fold_type.
          repeat (one_lift_lsubst_hyp inh).
          repeat (one_lift_lsubst2_hyp inh).
          repeat (one_lift_lsubst_concl).
          repeat (one_lift_lsubst2_concl).
          clear_cv.

          apply type_mkc_prod in inh; repnd.
          apply inhabited_prod2.

          prove_and ty1; GC.

          prove_and it1;[|prove_and ty2]; auto; GC.

          {
            repeat (one_lift_lsubst_hyp inh1).
            repeat (one_lift_lsubst2_hyp inh1).
            repeat (one_lift_lsubst_concl).
            repeat (one_lift_lsubst2_concl).
            lsubstc_snoc_concl.
            lsubstc_snoc_hyp inh1.
            apply inhabited_le.
            exists (0%Z) (Z.abs i0).
            dands; spcast;
            try (complete (unfold computes_to_valc; simpl;
                           unfold computes_to_value; dands;
                           eauto with slow));
            try (complete (apply computes_to_valc_absolute_value; auto;
                           apply computes_to_valc_iff_reduces_toc; eauto with slow)).
            destruct i0; allsimpl; try omega; apply Pos2Z.is_nonneg.
          }

          {
            autodimp inh hyp.
            repeat (one_lift_lsubst_hyp inh).
            repeat (one_lift_lsubst2_hyp inh).
            repeat (one_lift_lsubst_concl).
            repeat (one_lift_lsubst2_concl).
            lsubstc_snoc_concl.
            lsubstc_snoc_hyp inh.
            apply inhabited_less_than.
            exists (Z.abs i0) (Z.of_nat b).
            dands; spcast;
            try (complete (unfold computes_to_valc; simpl;
                           unfold computes_to_value; dands;
                           eauto with slow));
            try (complete (apply computes_to_valc_absolute_value; auto;
                           apply computes_to_valc_iff_reduces_toc; eauto with slow)).
            revert l; intro l.
            destruct i0; allsimpl; try omega; rw <- Znat.positive_nat_Z; apply Znat.inj_lt; auto.
          }
        }

        repeat substc_lsubstc_vars3.
        repeat (one_lift_lsubst_hyp inh).
        repeat (one_lift_lsubst2_hyp inh).
        revert inh.
        lsubstc_snoc_concl.
        intro inh.
        revert k1; intro k1.
        repeat (one_lift_lsubst_hyp k1).

        rw @equality_in_fun in k1; repnd.
        pose proof (k1 t1 t2) as ef; autodimp ef hyp.
        {
          apply equality_in_int.
          exists i0; dands; spcast; auto;
          apply computes_to_valc_iff_reduces_toc; eauto with slow.
        }

        apply equality_in_mkc_equality in inh; repnd.
        eapply equality_trans;[exact ef|]; auto.
      }

      rw @member_eq.
      rw <- @member_equality_iff.
      repeat (one_lift_lsubst2_concl).
      apply equality_in_int.
      unfold equality_of_int_tt in cont1; exrepnd.
      exists k; dands; spcast; auto.
    }
Qed.


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

(*
Definition subset_couplingP {A1 A2} (Is1: pidist A1) (Is2: pidist A2) (P: A1 → A2 → Prop) :=
  ∀ (I1: ival A1), In (I1 : ival A1) Is1 →
  { I2 : { I2: ival A2 | In (I2 : ival A2) Is2 } & ival_couplingP I1 (sval I2) P }.
*)

Definition subset_couplingP {A1 A2} (Is1: pidist A1) (Is2: pidist A2) (P: A1 → A2 → Prop) : Prop :=
  ∀ (I1: ival A1), In (I1 : ival A1) Is1 →
  ∃ (I2: ival A2), In (I2 : ival A2) Is2 ∧ ∃ (C: ival_couplingP I1 I2 P), True.

Lemma subset_coupling_eq {A} (Is1 Is2: pidist A)
      (Ic: subset_couplingP Is1 Is2 (λ x y, x = y)): le_pidist Is1 Is2.
Proof.
  intros I1 Hin.
  specialize (Ic (lift_In_pidist I1 Hin) Hin).
  destruct Ic as (I2&Hin2&(Hcouple&_)).
  exists I2; split; auto.
  eapply ival_coupling_eq in Hcouple; done.
Qed.

Lemma singleton_coupling_eq {A} (I1 : ivdist A) (Is2: pidist A)
      (Ic: subset_couplingP (singleton I1) Is2 (λ x y, x = y)): In_pidist I1 Is2.
Proof.
  by apply In_pidist_le_singleton, subset_coupling_eq.
Qed.

Lemma subset_coupling_bind {A1 A2 B1 B2} (f1: A1 → pidist B1) (f2: A2 → pidist B2)
      Is1 Is2 P Q (Ic: subset_couplingP Is1 Is2 P):
  (∀ x y, P x y → subset_couplingP (f1 x) (f2 y) Q) →
  subset_couplingP (mbind f1 Is1) (mbind f2 Is2) Q.
Proof.
  intros Hfc.
  intros I1 Hin.
  edestruct (pival_mbind_in_inv_idxOf Is1 f1 I1) as (I1_0&h1&Hin1_0&Hh1&Heq); auto.
  specialize (Ic I1_0 Hin1_0).
  destruct Ic as (I2_0&Hin2_0&(Hcouple&_)).
  apply ival_coupling_idxOf in Hcouple.
  destruct Hcouple as ((Rel&Hfunc)&[Ic_0 Hp1 Hp2]).
  apply ClassicalEpsilon.constructive_indefinite_description in Hp1.
  destruct Hp1 as (hidx1&Hp1).
  apply ClassicalEpsilon.constructive_indefinite_description in Hp1.
  destruct Hp1 as (hidx1'&?&?&Hind1&?).

  apply ClassicalEpsilon.constructive_indefinite_description in Hp2.
  destruct Hp2 as (hidx2&Hp2).
  apply ClassicalEpsilon.constructive_indefinite_description in Hp2.
  destruct Hp2 as (hidx2'&?&?&Hind2&?).

  unshelve (edestruct (pival_mbind_in_alt2_idxOf Is2 f2 I2_0) as (Ib&Heqb&Hinb)).
  { intros i2.
    destruct (Rgt_dec (val I2_0 i2) 0) as [Hgt|Hngt]; last (exact zero_ival).
    destruct (hidx2 (coerce_supp _ _ Hgt)) as ((i0&[])&Hgt0).
    destruct (ind Ic_0 i0) as ((i1&i2')&(HP&Hsup1&Hsup2)).
    specialize (Hfc _ _ HP (h1 i1) (Hh1 _ Hsup1)).
    apply ClassicalEpsilon.constructive_indefinite_description in Hfc.
    destruct Hfc as (I2&?).
    exact I2.
  }
  - exists I2_0; split; auto; reflexivity.
  - intros.
    simpl. destruct Rgt_dec as [r|?] => //=.
    specialize (Hind2 ((coerce_supp (val I2_0) i r))).
    destruct (hidx2) as ((i0&[])&Hgt0) => //=.
    rewrite //= in Hind2.
    case_eq (ind Ic_0 i0). intros (i1&i2') (HP&Hsup1&Hsup2&HQ) Heq0.
    rewrite Heq0. rewrite Heq0 in Hind2.
    destruct ClassicalEpsilon.constructive_indefinite_description as (?&?&?); auto.
    subst. done.
  - exists Ib; split; auto.
    unshelve (eexists); last done.
    eapply ival_coupling_proper.
    * eauto.
    * eauto.
    * eapply (ival_coupling_bind _ _ _ _
          (λ x y, P (ind I1_0 x) (ind I2_0 y) ∧ val I1_0 x > 0 ∧ val I2_0 y > 0 ∧ Rel x y)).
      { exists Ic_0. exists hidx1; eauto. exists hidx2; eauto.  }
      intros x y (HP&Hgtx&Hgty&HRel).
      destruct Rgt_dec as [r|?] => //=.
    specialize (Hind2 ((coerce_supp (val I2_0) y r))).
    destruct (hidx2) as ((i0&[])&Hgt0) => //=.
    rewrite //= in Hind2.
    case_eq (ind Ic_0 i0). intros (i1&i2') (HP'&Hsup1&Hsup2&HQ) Heq0.
    rewrite Heq0. rewrite Heq0 in Hind2.
      destruct ClassicalEpsilon.constructive_indefinite_description as (?&?&Hc).
      apply ClassicalEpsilon.constructive_indefinite_description in Hc as (Hc&?).
      cut (x = i1).
      { intros.  subst. auto. }
      eapply Hfunc.
      eauto. clear -HQ Hind2. rewrite //= in Hind2. rewrite -Hind2. rewrite //= in HQ.
Qed.

Lemma subset_coupling_le {X Y} Is1 Is1' Is2 Is2' (P: X → Y → Prop) :
  le_pidist Is1' Is1 →
  le_pidist Is2 Is2' →
  subset_couplingP Is1 Is2 P →
  subset_couplingP Is1' Is2' P.
Proof.
  intros Hle1 Hle2 Hsub.
  intros I1' Hin1'.
  destruct (Hle1 _ Hin1') as (I1&Heq&Hin1).
  destruct (Hsub _ Hin1) as (I2&Hin2&Hc&_).
  destruct (Hle2 _ Hin2) as (I2'&Heq2&Hin2').
  exists I2'; split; auto.
  eexists; last by done.
  eapply ival_coupling_proper; try eassumption.
    by symmetry.
Qed.

Lemma subset_coupling_proper {X Y} Is1 Is1' Is2 Is2' (P: X → Y → Prop) :
  eq_pidist Is1 Is1' →
  eq_pidist Is2 Is2' →
  subset_couplingP Is1 Is2 P →
  subset_couplingP Is1' Is2' P.
Proof.
  intros Heq1 Heq2. eapply subset_coupling_le; eauto.
  - setoid_rewrite Heq1; reflexivity.
  - setoid_rewrite Heq2; reflexivity.
Qed.

Lemma subset_coupling_support {X Y} I1 I2 (P: X → Y → Prop) :
  subset_couplingP I1 I2 P →
  subset_couplingP I1 I2 (λ x y, P x y ∧ In_psupport x I1 ∧ In_psupport y I2).
Proof.
  intros Hsub I Hin.
  edestruct (Hsub I Hin) as (I'&Hin'&Ic&_).
  exists I'; split; first done.
  unshelve (eexists); last done.
  eapply ival_coupling_conseq; last first.
  { apply (ival_coupling_support _ _ _ Ic). }
  intros x y (Hpf&Hin1&Hin2&?); repeat split; auto.
  - exists I; auto. edestruct Hin1; eexists; eauto.
  - exists I'; auto. edestruct Hin2; eexists; eauto.
Qed.

Lemma subset_coupling_plus {A1 A2} p Hpf p' Hpf'
      (P : A1 → A2 → Prop) (Is1 Is1': pidist A1) (Is2 Is2': pidist A2) :
  p = p' →
  subset_couplingP Is1 Is2 P →
  subset_couplingP Is1' Is2' P →
  subset_couplingP (pidist_plus p Hpf Is1 Is1') (pidist_plus p' Hpf' Is2 Is2') P.
Proof.
  intros Hp Hsub Hsub'.
  subst.
  intros I (I1&I1'&Hin1&Hin1'&Heq1)%pidist_plus_in_inv.
  subst.

  edestruct (Hsub _ Hin1) as (I2&Hin&Hequiv&?).
  edestruct (Hsub' _ Hin1') as (I2'&Hin'&Hequiv'&?).
  exists (iplus (iscale p' I2) (iscale (1 - p') I2')).
  split.
  - apply pplus_in; apply pscale_in; auto.
  - unshelve (eexists); auto.
    apply ival_coupling_plus'; auto.
Qed.