(** * Stores of variable values *)

From Coq Require Import Program Program.Tactics FMaps ZArith.
From mathcomp Require Import ssreflect ssrbool eqtype.
From Common Require Import Types SsrOrdered HList FMaps ZAriths Env Var.
Import HEnv.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Stores as total maps from variables to values of a single type. *)

Module Type TSTORE (V : SsrOrderedType).

  Local Notation var := V.t.

  Section TStore.

    Variable value : Type.

    Parameter t : Type -> Type.

    Parameter acc : var -> t value -> value.

    Parameter upd : var -> value -> t value -> t value.

    Parameter upd2 : var -> value -> var -> value -> t value -> t value.

    Parameter acc_upd_eq :
      forall x y v s,
        x == y ->
        acc x (upd y v s) = v.

    Parameter acc_upd_neq :
      forall x y v s,
        x != y ->
        acc x (upd y v s) = acc x s.

    Parameter acc_upd2_eq1 :
      forall x y1 v1 y2 v2 (s : t value),
        x == y1 ->
        x != y2 ->
        acc x (upd2 y1 v1 y2 v2 s) = v1.

    Parameter acc_upd2_eq2 :
      forall x y1 v1 y2 v2 (s : t value),
        x == y2 ->
        acc x (upd2 y1 v1 y2 v2 s) = v2.

    Parameter acc_upd2_neq :
      forall x y1 v1 y2 v2 s,
        x != y1 ->
        x != y2 ->
        acc x (upd2 y1 v1 y2 v2 s) = acc x s.

    Parameter Upd : var -> value -> t value -> t value -> Prop.

    Definition Upd2 x1 v1 x2 v2 (s1 s2 : t value) : Prop :=
      forall y, acc y s2 = acc y (upd x2 v2 (upd x1 v1 s1)).

    Parameter Equal : t value -> t value -> Prop.

    Parameter Upd_upd :
      forall x v s,
        Upd x v s (upd x v s).

    Parameter Upd2_upd :
      forall x1 v1 x2 v2 s,
        Upd2 x1 v1 x2 v2 s (upd x2 v2 (upd x1 v1 s)).

    Parameter Upd2_upd2 :
      forall x1 v1 x2 v2 s,
        Upd2 x1 v1 x2 v2 s (upd2 x1 v1 x2 v2 s).

    Parameter acc_Upd_eq :
      forall x y v s1 s2,
        x == y ->
        Upd y v s1 s2 ->
        acc x s2 = v.

    Parameter acc_Upd_neq :
      forall x y v s1 s2,
        x != y ->
        Upd y v s1 s2 ->
        acc x s2 = acc x s1.

    Parameter acc_Upd2_eq1 :
      forall x y1 v1 y2 v2 s1 s2,
        x == y1 ->
        x != y2 ->
        Upd2 y1 v1 y2 v2 s1 s2 ->
        acc x s2 = v1.

    Parameter acc_Upd2_eq2 :
      forall x y1 v1 y2 v2 s1 s2,
        x == y2 ->
        Upd2 y1 v1 y2 v2 s1 s2 ->
        acc x s2 = v2.

    Parameter acc_Upd2_neq :
      forall x y1 v1 y2 v2 s1 s2,
        x != y1 ->
        x != y2 ->
        Upd2 y1 v1 y2 v2 s1 s2 ->
        acc x s2 = acc x s1.

    Parameter Equal_refl : forall s, Equal s s.

    Parameter Equal_sym : forall s1 s2, Equal s1 s2 -> Equal s2 s1.

    Parameter Equal_trans : forall s1 s2 s3, Equal s1 s2 -> Equal s2 s3 -> Equal s1 s3.

    Parameter Equal_ST : RelationClasses.Equivalence Equal.

    Parameter Equal_upd_Equal : forall v e s1 s2,
        Equal s1 s2 ->
        Equal (upd v e s1) (upd v e s2).

    Parameter Equal_Upd_Equal : forall v e s1 s2 s3 s4,
        Upd v e s1 s2 -> Upd v e s3 s4 ->
        Equal s1 s3 -> Equal s2 s4.

    Parameter Upd_pred_Equal : forall v e s1 s2 s,
        Upd v e s1 s2 -> Equal s1 s -> Upd v e s s2.

    Parameter Upd_succ_Equal : forall v e s1 s2 s,
        Upd v e s1 s2 -> Equal s2 s -> Upd v e s1 s.

  End TStore.

End TSTORE.

Module MakeTStore (X : SsrOrderedType) <: TSTORE X.

  Section TStore.

    Variable value : Type.

    Definition var := X.T.

    Definition t : Type := var -> value.

    Parameter empty : var -> value.

    Definition acc (x : var) (s : t) := s x.

    Definition upd (x : var) (v : value) (s : t) :=
      fun (y : var) => if y == x then v else acc y s.

    Definition upd2 x1 v1 x2 v2 (s : t) : t :=
      upd x2 v2 (upd x1 v1 s).

    Lemma acc_upd_eq x y v s :
      x == y ->
      acc x (upd y v s) = v.
    Proof.
      rewrite /acc /upd => Hxy.
      rewrite Hxy.
      reflexivity.
    Qed.

    Lemma acc_upd_neq x y v s :
      x != y ->
      acc x (upd y v s) = acc x s.
    Proof.
      rewrite {1}/acc /upd => Hxy.
      rewrite (negPf Hxy).
      reflexivity.
    Qed.

    Lemma acc_upd2_eq1 :
      forall x y1 v1 y2 v2 (s : t),
        x == y1 ->
        x != y2 ->
        acc x (upd2 y1 v1 y2 v2 s) = v1.
    Proof.
      move=> x y1 v1 y2 v2 s Hx1 Hx2.
      rewrite /upd2 (acc_upd_neq _ _ Hx2) (acc_upd_eq _ _ Hx1).
      reflexivity.
    Qed.

    Lemma acc_upd2_eq2 :
      forall x y1 v1 y2 v2 (s : t),
        x == y2 ->
        acc x (upd2 y1 v1 y2 v2 s) = v2.
    Proof.
      move=> x y1 v1 y2 v2 s Hx2.
      rewrite /upd2 (acc_upd_eq _ _ Hx2).
      reflexivity.
    Qed.

    Lemma acc_upd2_neq :
      forall x y1 v1 y2 v2 s,
        x != y1 ->
        x != y2 ->
        acc x (upd2 y1 v1 y2 v2 s) = acc x s.
    Proof.
      move=> x y1 v1 y2 v2 s Hx1 Hx2.
      rewrite /upd2 (acc_upd_neq _ _ Hx2) (acc_upd_neq _ _ Hx1).
      reflexivity.
    Qed.

    Definition Upd x v (s1 s2 : t) : Prop :=
      forall y, acc y s2 = acc y (upd x v s1).

    Definition Upd2 x1 v1 x2 v2 (s1 s2 : t) : Prop :=
      forall y, acc y s2 = acc y (upd x2 v2 (upd x1 v1 s1)).

    Definition Equal (s1 s2 : t) : Prop :=
      forall v, acc v s1 = acc v s2.

    Lemma Upd_upd :
      forall x v s,
        Upd x v s (upd x v s).
    Proof.
      move=> x v s y.
      reflexivity.
    Qed.

    Lemma Upd2_upd :
      forall x1 v1 x2 v2 s,
        Upd2 x1 v1 x2 v2 s (upd x2 v2 (upd x1 v1 s)).
    Proof.
      move=> x1 v1 x2 v2 s y.
      reflexivity.
    Qed.

    Lemma Upd2_upd2 :
      forall x1 v1 x2 v2 s,
        Upd2 x1 v1 x2 v2 s (upd2 x1 v1 x2 v2 s).
    Proof.
      exact: Upd2_upd.
    Qed.

    Lemma acc_Upd_eq :
      forall x y v s1 s2,
        x == y ->
        Upd y v s1 s2 ->
        acc x s2 = v.
    Proof.
      move=> x y v s1 s2 Hxy Hupd.
      move: (Hupd x) => Hx.
      rewrite (acc_upd_eq _ _ Hxy) in Hx.
      assumption.
    Qed.

    Lemma acc_Upd_neq :
      forall x y v s1 s2,
        x != y ->
        Upd y v s1 s2 ->
        acc x s2 = acc x s1.
    Proof.
      move=> x y v s1 s2 Hxy Hupd.
      move: (Hupd x) => Hx.
      rewrite (acc_upd_neq _ _ Hxy) in Hx.
      assumption.
    Qed.

    Lemma acc_Upd2_eq1 :
      forall x y1 v1 y2 v2 s1 s2,
        x == y1 ->
        x != y2 ->
        Upd2 y1 v1 y2 v2 s1 s2 ->
        acc x s2 = v1.
    Proof.
      move=> x y1 v1 y2 v2 s1 s2 Heq Hne Hupd.
      rewrite (Hupd x).
      exact: acc_upd2_eq1.
    Qed.

    Lemma acc_Upd2_eq2 :
      forall x y1 v1 y2 v2 s1 s2,
        x == y2 ->
        Upd2 y1 v1 y2 v2 s1 s2 ->
        acc x s2 = v2.
    Proof.
      move=> x y1 v1 y2 v2 s1 s2 Heq Hupd.
      rewrite (Hupd x).
      exact: acc_upd2_eq2.
    Qed.

    Lemma acc_Upd2_neq :
      forall x y1 v1 y2 v2 s1 s2,
        x != y1 ->
        x != y2 ->
        Upd2 y1 v1 y2 v2 s1 s2 ->
        acc x s2 = acc x s1.
    Proof.
      move=> x y1 v1 y2 v2 s1 s2 Hne1 Hne2 Hupd.
      rewrite (Hupd x).
      exact: acc_upd2_neq.
    Qed.

    Lemma Equal_refl s : Equal s s.
    Proof.
      done.
    Qed.

    Lemma Equal_sym s1 s2 : Equal s1 s2 -> Equal s2 s1.
    Proof.
      move=> H v; rewrite (H v); reflexivity.
    Qed.

    Lemma Equal_trans s1 s2 s3 : Equal s1 s2 -> Equal s2 s3 -> Equal s1 s3.
    Proof.
      move=> H1 H2 v. rewrite (H1 v) (H2 v). reflexivity.
    Qed.

    Instance Equal_ST : RelationClasses.Equivalence Equal :=
      { Equivalence_Reflexive := Equal_refl;
        Equivalence_Symmetric := Equal_sym;
        Equivalence_Transitive := Equal_trans }.

    Lemma Equal_upd_Equal v e s1 s2 :
      Equal s1 s2 ->
      Equal (upd v e s1) (upd v e s2).
    Proof.
      move=> H x. case Hxv: (x == v).
      - rewrite !(acc_upd_eq _ _ Hxv). reflexivity.
      - move/idP/negP: Hxv => Hxv. rewrite !(acc_upd_neq _ _ Hxv). exact: (H x).
    Qed.

    Lemma Equal_Upd_Equal v e s1 s2 s3 s4 :
      Upd v e s1 s2 -> Upd v e s3 s4 ->
      Equal s1 s3 -> Equal s2 s4.
    Proof.
      move=> Hupd1 Hupd2 Heq x. rewrite (Hupd1 x) (Hupd2 x).
      exact: Equal_upd_Equal.
    Qed.

    Lemma Upd_pred_Equal v e s1 s2 s : Upd v e s1 s2 -> Equal s1 s -> Upd v e s s2.
    Proof.
      move=> Hupd Heq x. case Hxv: (x == v).
      - rewrite (acc_Upd_eq Hxv Hupd) (acc_upd_eq _ _ Hxv). reflexivity.
      - move/idP/negP: Hxv => Hxv.
        rewrite (acc_Upd_neq Hxv Hupd) (acc_upd_neq _ _ Hxv). exact: (Heq x).
    Qed.

    Lemma Upd_succ_Equal v e s1 s2 s : Upd v e s1 s2 -> Equal s2 s -> Upd v e s1 s.
    Proof.
      move=> Hupd Heq x. rewrite -(Heq x). case Hxv: (x == v).
      - rewrite (acc_Upd_eq Hxv Hupd) (acc_upd_eq _ _ Hxv). reflexivity.
      - move/idP/negP: Hxv => Hxv.
        rewrite (acc_Upd_neq Hxv Hupd) (acc_upd_neq _ _ Hxv). reflexivity.
    Qed.

  End TStore.

End MakeTStore.

Module TStoreAdapter (X : SsrOrderedType) (V : Equalities.Typ).
  Module S := MakeTStore X.
  Definition value := V.t.
  Definition var := S.var.
  Definition t := S.t value.
  Definition empty : t := S.empty value.
  Definition acc x (s : t) := S.acc x s.
  Definition upd x v (s : t) := S.upd x v s.
  Definition upd2 x1 v1 x2 v2 (s : t) := S.upd2 x1 v1 x2 v2 s.
  Lemma acc_upd_eq :
    forall x y v (s : t),
      x == y ->
      acc x (upd y v s) = v.
  Proof.
    move=> x y v s.
    exact: S.acc_upd_eq.
  Qed.
  Lemma acc_upd_neq :
    forall x y v (s : t),
      x != y ->
      acc x (upd y v s) = acc x s.
  Proof.
    move=> x y v s.
    exact: S.acc_upd_neq.
  Qed.
  Lemma acc_upd2_eq1 :
    forall x y1 v1 y2 v2 (s : t),
      x == y1 ->
      x != y2 ->
      acc x (upd2 y1 v1 y2 v2 s) = v1.
  Proof.
    move=> x y1 v1 y2 v2 s Hx1 Hx2.
    exact: S.acc_upd2_eq1.
  Qed.
  Lemma acc_upd2_eq2 :
    forall x y1 v1 y2 v2 (s : t),
      x == y2 ->
      acc x (upd2 y1 v1 y2 v2 s) = v2.
  Proof.
    move=> x y1 v1 y2 v2 s Hx2.
    exact: S.acc_upd2_eq2.
  Qed.
  Lemma acc_upd2_neq :
    forall x y1 v1 y2 v2 s,
      x != y1 ->
      x != y2 ->
      acc x (upd2 y1 v1 y2 v2 s) = acc x s.
  Proof.
    move=> x y1 v1 y2 v2 s Hx1 Hx2.
    exact: S.acc_upd2_neq.
  Qed.
  Definition Upd x v (s1 s2 : t) := S.Upd x v s1 s2.
  Definition Upd2 x1 v1 x2 v2 (s1 s2 : t) := S.Upd2 x1 v1 x2 v2 s1 s2.
  Definition Equal (s1 s2 : t) := S.Equal s1 s2.
  Lemma Upd_upd :
    forall x v s,
      Upd x v s (upd x v s).
  Proof.
    move=> x v s y.
    exact: S.Upd_upd.
  Qed.
  Lemma Upd2_upd :
    forall x1 v1 x2 v2 s,
      Upd2 x1 v1 x2 v2 s (upd x2 v2 (upd x1 v1 s)).
  Proof.
    move=> x1 v1 x2 v2 s y.
    exact: S.Upd2_upd.
  Qed.
  Lemma Upd2_upd2 :
    forall x1 v1 x2 v2 s,
      Upd2 x1 v1 x2 v2 s (upd2 x1 v1 x2 v2 s).
  Proof.
    move=> x1 v1 x2 v2 s.
    exact: S.Upd2_upd2.
  Qed.
  Lemma acc_Upd_eq :
    forall x y v s1 s2,
      x == y ->
      Upd y v s1 s2 ->
      acc x s2 = v.
  Proof.
    move=> x y v s1 s2.
    exact: S.acc_Upd_eq.
  Qed.
  Lemma acc_Upd_neq :
    forall x y v s1 s2,
      x != y ->
      Upd y v s1 s2 ->
      acc x s2 = acc x s1.
  Proof.
    move=> x y v s1 s2.
    exact: S.acc_Upd_neq.
  Qed.
  Lemma acc_Upd2_eq1 :
    forall x y1 v1 y2 v2 s1 s2,
      x == y1 ->
      x != y2 ->
      Upd2 y1 v1 y2 v2 s1 s2 ->
      acc x s2 = v1.
  Proof.
    move=> x y1 v1 y2 v2 s1 s2.
    exact: S.acc_Upd2_eq1.
  Qed.
  Lemma acc_Upd2_eq2 :
    forall x y1 v1 y2 v2 s1 s2,
      x == y2 ->
      Upd2 y1 v1 y2 v2 s1 s2 ->
      acc x s2 = v2.
  Proof.
    move=> x y1 v1 y2 v2 s1 s2.
    exact: S.acc_Upd2_eq2.
  Qed.
  Lemma acc_Upd2_neq :
    forall x y1 v1 y2 v2 s1 s2,
      x != y1 ->
      x != y2 ->
      Upd2 y1 v1 y2 v2 s1 s2 ->
      acc x s2 = acc x s1.
  Proof.
    move=> x y1 v1 y2 v2 s1 s2.
    exact: S.acc_Upd2_neq.
  Qed.
  Lemma Equal_refl s : Equal s s.
  Proof.
    exact: S.Equal_refl.
  Qed.
  Lemma Equal_sym s1 s2 : Equal s1 s2 -> Equal s2 s1.
  Proof.
    exact: S.Equal_sym.
  Qed.
  Lemma Equal_trans s1 s2 s3 : Equal s1 s2 -> Equal s2 s3 -> Equal s1 s3.
  Proof.
    exact: S.Equal_trans.
  Qed.
  Instance Equal_ST : RelationClasses.Equivalence Equal := S.Equal_ST value.
  Lemma Equal_upd_Equal v e s1 s2 :
    Equal s1 s2 ->
    Equal (upd v e s1) (upd v e s2).
  Proof.
    exact: S.Equal_upd_Equal.
  Qed.
  Lemma Equal_Upd_Equal v e s1 s2 s3 s4 :
    Upd v e s1 s2 -> Upd v e s3 s4 ->
    Equal s1 s3 -> Equal s2 s4.
  Proof.
    exact: S.Equal_Upd_Equal.
  Qed.
  Lemma Upd_pred_Equal v e s1 s2 s : Upd v e s1 s2 -> Equal s1 s -> Upd v e s s2.
  Proof.
    exact: S.Upd_pred_Equal.
  Qed.
  Lemma Upd_succ_Equal v e s1 s2 s : Upd v e s1 s2 -> Equal s2 s -> Upd v e s1 s.
  Proof.
    exact: S.Upd_succ_Equal.
  Qed.
End TStoreAdapter.

(** Stores as partial maps from variables to values of a single type. *)

Module Type PSTORE (V : SsrOrderedType).

  Local Notation var := V.t.

  Section PStore.

    Variable value : Type.

    Parameter t : Type -> Type.

    Parameter empty : t value.

    Parameter acc : var -> t value -> option value.

    Parameter upd : var -> value -> t value -> t value.

    Parameter unset : var -> t value -> t value.

    Parameter acc_upd_eq :
      forall x y v s,
        x == y ->
        acc x (upd y v s) = Some v.

    Parameter acc_upd_neq :
      forall x y v s,
        x != y ->
        acc x (upd y v s) = acc x s.

    Parameter acc_empty :
      forall x, acc x empty = None.

    Parameter acc_unset_eq :
      forall x y s,
        x == y ->
        acc x (unset y s) = None.

    Parameter acc_unset_neq :
      forall x y s,
        x != y ->
        acc x (unset y s) = acc x s.

    Parameter Empty : t value -> Prop.

    Parameter Upd : var -> value -> t value -> t value -> Prop.

    Parameter Unset : var -> t value -> t value -> Prop.

    Parameter Equal : t value -> t value -> Prop.

    Parameter Empty_acc :
      forall x s,
        Empty s ->
        acc x s = None.

    Parameter Upd_upd :
      forall x v s,
        Upd x v s (upd x v s).

    Parameter Unset_unset :
      forall x s,
        Unset x s (unset x s).

    Parameter acc_Upd_eq :
      forall x y v s1 s2,
        x == y ->
        Upd y v s1 s2 ->
        acc x s2 = Some v.

    Parameter acc_Upd_neq :
      forall x y v s1 s2,
        x != y ->
        Upd y v s1 s2 ->
        acc x s2 = acc x s1.

    Parameter acc_Unset_eq :
      forall x y s1 s2,
        x == y ->
        Unset y s1 s2 ->
        acc x s2 = None.

    Parameter acc_Unset_neq :
      forall x y s1 s2,
        x != y ->
        Unset y s1 s2 ->
        acc x s2 = acc x s1.

    Parameter Equal_refl : forall s, Equal s s.

    Parameter Equal_sym : forall s1 s2, Equal s1 s2 -> Equal s2 s1.

    Parameter Equal_trans : forall s1 s2 s3, Equal s1 s2 -> Equal s2 s3 -> Equal s1 s3.

    Parameter Equal_ST : RelationClasses.Equivalence Equal.

    Parameter Equal_upd_Equal : forall v e s1 s2,
        Equal s1 s2 ->
        Equal (upd v e s1) (upd v e s2).

    Parameter Equal_Upd_Equal : forall v e s1 s2 s3 s4,
        Upd v e s1 s2 -> Upd v e s3 s4 ->
        Equal s1 s3 -> Equal s2 s4.

    Parameter Upd_pred_Equal : forall v e s1 s2 s,
        Upd v e s1 s2 -> Equal s1 s -> Upd v e s s2.

    Parameter Upd_succ_Equal : forall v e s1 s2 s,
        Upd v e s1 s2 -> Equal s2 s -> Upd v e s1 s.

  End PStore.

End PSTORE.

Module MakePStore (X : SsrOrderedType) <: PSTORE X.

  Module M := FMapList.Make(X).
  Module L := FMapLemmas(M).

  Section PStore.

    Definition var : eqType := X.T.

    Variable value : Type.

    Definition t : Type := M.t value.

    Definition empty : t := M.empty value.

    Definition acc (x : var) (s : t) := M.find x s.

    Definition upd (x : var) (v : value) (s : t) := M.add x v s.

    Definition unset (x : var) (s : t) := M.remove x s.

    Lemma acc_upd_eq x y v s :
      x == y ->
      acc x (upd y v s) = Some v.
    Proof.
      rewrite /acc /upd => Hxy.
      rewrite (eqP Hxy) => {Hxy x}.
      apply: L.find_add_eq.
      reflexivity.
    Qed.

    Lemma acc_upd_neq x y v s :
      x != y ->
      acc x (upd y v s) = acc x s.
    Proof.
      rewrite /acc /upd => Hxy.
      apply: L.find_add_neq.
      exact: (negP Hxy).
    Qed.

    Lemma acc_empty :
      forall x, acc x empty = None.
    Proof.
      exact: L.empty_o.
    Qed.

    Lemma acc_unset_eq :
      forall x y s,
        x == y ->
        acc x (unset y s) = None.
    Proof.
      move=> x y s Heq.
      apply: L.remove_eq_o.
      rewrite eq_sym.
      exact: Heq.
    Qed.

    Lemma acc_unset_neq :
      forall x y s,
        x != y ->
        acc x (unset y s) = acc x s.
    Proof.
      move=> x y s Hne.
      apply: L.remove_neq_o.
      move=> Heq.
      move/eqP: Hne; apply.
      by rewrite (eqP Heq).
    Qed.

    Definition Empty (s : t) : Prop := M.Empty s.

    Definition Upd x v s1 s2 : Prop :=
      forall y, acc y s2 = acc y (upd x v s1).

    Definition Unset x s1 s2 : Prop :=
      forall y, acc y s2 = acc y (unset x s1).

    Definition Equal (s1 s2 : t) : Prop :=
      forall v, acc v s1 = acc v s2.

    Lemma Empty_acc :
      forall x s,
        Empty s ->
        acc x s = None.
    Proof.
      move=> x s Hemp.
      exact: (L.Empty_find _ Hemp).
    Qed.

    Lemma Upd_upd :
      forall x v s,
        Upd x v s (upd x v s).
    Proof.
      move=> x v s y.
      reflexivity.
    Qed.

    Lemma Unset_unset :
      forall x s,
        Unset x s (unset x s).
    Proof.
      move=> x s y.
      reflexivity.
    Qed.

    Lemma acc_Upd_eq :
      forall x y v s1 s2,
        x == y ->
        Upd y v s1 s2 ->
        acc x s2 = Some v.
    Proof.
      move=> x y v s1 s2 Hxy Hupd.
      move: (Hupd x).
      rewrite (acc_upd_eq _ _ Hxy).
      by apply.
    Qed.

    Lemma acc_Upd_neq :
      forall x y v s1 s2,
        x != y ->
        Upd y v s1 s2 ->
        acc x s2 = acc x s1.
    Proof.
      move=> x y v s1 s2 Hxy Hupd.
      move: (Hupd x).
      rewrite (acc_upd_neq _ _ Hxy).
      by apply.
    Qed.

    Lemma acc_Unset_eq :
      forall x y s1 s2,
        x == y ->
        Unset y s1 s2 ->
        acc x s2 = None.
    Proof.
      move=> x y s1 s2 Hxy Hunset.
      move: (Hunset x).
      rewrite (acc_unset_eq _ Hxy).
      by apply.
    Qed.

    Lemma acc_Unset_neq :
      forall x y s1 s2,
        x != y ->
        Unset y s1 s2 ->
        acc x s2 = acc x s1.
    Proof.
      move=> x y s1 s2 Hxy Hunset.
      move: (Hunset x).
      rewrite (acc_unset_neq _ Hxy).
      by apply.
    Qed.

    Lemma Equal_refl s : Equal s s.
    Proof.
      done.
    Qed.

    Lemma Equal_sym s1 s2 : Equal s1 s2 -> Equal s2 s1.
    Proof.
      move=> H v; rewrite (H v); reflexivity.
    Qed.

    Lemma Equal_trans s1 s2 s3 : Equal s1 s2 -> Equal s2 s3 -> Equal s1 s3.
    Proof.
      move=> H1 H2 v. rewrite (H1 v) (H2 v). reflexivity.
    Qed.

    Instance Equal_ST : RelationClasses.Equivalence Equal :=
      { Equivalence_Reflexive := Equal_refl;
        Equivalence_Symmetric := Equal_sym;
        Equivalence_Transitive := Equal_trans }.

    Lemma Equal_upd_Equal v e s1 s2 :
      Equal s1 s2 ->
      Equal (upd v e s1) (upd v e s2).
    Proof.
      move=> H x. case Hxv: (x == v).
      - rewrite !(acc_upd_eq _ _ Hxv). reflexivity.
      - move/idP/negP: Hxv => Hxv. rewrite !(acc_upd_neq _ _ Hxv). exact: (H x).
    Qed.

    Lemma Equal_Upd_Equal v e s1 s2 s3 s4 :
      Upd v e s1 s2 -> Upd v e s3 s4 ->
      Equal s1 s3 -> Equal s2 s4.
    Proof.
      move=> Hupd1 Hupd2 Heq x. rewrite (Hupd1 x) (Hupd2 x).
      exact: Equal_upd_Equal.
    Qed.

    Lemma Upd_pred_Equal v e s1 s2 s : Upd v e s1 s2 -> Equal s1 s -> Upd v e s s2.
    Proof.
      move=> Hupd Heq x. case Hxv: (x == v).
      - rewrite (acc_Upd_eq Hxv Hupd) (acc_upd_eq _ _ Hxv). reflexivity.
      - move/idP/negP: Hxv => Hxv.
        rewrite (acc_Upd_neq Hxv Hupd) (acc_upd_neq _ _ Hxv). exact: (Heq x).
    Qed.

    Lemma Upd_succ_Equal v e s1 s2 s : Upd v e s1 s2 -> Equal s2 s -> Upd v e s1 s.
    Proof.
      move=> Hupd Heq x. rewrite -(Heq x). case Hxv: (x == v).
      - rewrite (acc_Upd_eq Hxv Hupd) (acc_upd_eq _ _ Hxv). reflexivity.
      - move/idP/negP: Hxv => Hxv.
        rewrite (acc_Upd_neq Hxv Hupd) (acc_upd_neq _ _ Hxv). reflexivity.
    Qed.

  End PStore.

End MakePStore.

Module PStoreAdapter (X : SsrOrderedType) (V : Equalities.Typ).
  Module S := MakePStore X.
  Definition var := S.var.
  Definition value := V.t.
  Definition t := S.t value.
  Definition empty := S.empty value.
  Definition acc x (s : t) := S.acc x s.
  Definition upd x v (s : t) := S.upd x v s.
  Definition unset x (s : t) := S.unset x s.
  Lemma acc_upd_eq :
    forall x y v s,
      x == y ->
      acc x (upd y v s) = Some v.
  Proof.
    move=> x y v s.
    exact: S.acc_upd_eq.
  Qed.
  Lemma acc_upd_neq :
    forall x y v s,
      x != y ->
      acc x (upd y v s) = acc x s.
  Proof.
    move=> x y v s.
    exact: S.acc_upd_neq.
  Qed.
  Lemma acc_empty :
    forall x, acc x empty = None.
  Proof.
    exact: S.acc_empty.
  Qed.
  Lemma acc_unset_eq :
    forall x y s,
      x == y ->
      acc x (unset y s) = None.
  Proof.
    exact: S.acc_unset_eq.
  Qed.
  Lemma acc_unset_neq :
    forall x y s,
      x != y ->
      acc x (unset y s) = acc x s.
  Proof.
    exact: S.acc_unset_neq.
  Qed.
  Definition Empty (s : t) : Prop := S.Empty s.
  Definition Upd x v (s1 s2 : t) : Prop := S.Upd x v s1 s2.
  Definition Unset x (s1 s2 : t) : Prop := S.Unset x s1 s2.
  Definition Equal (s1 s2 : t) := S.Equal s1 s2.
  Lemma Empty_acc :
    forall x s,
      Empty s ->
      acc x s = None.
  Proof.
    exact: S.Empty_acc.
  Qed.
  Lemma Upd_upd :
    forall x v s,
      Upd x v s (upd x v s).
  Proof.
    exact: S.Upd_upd.
  Qed.
  Lemma Unset_unset :
    forall x s,
      Unset x s (unset x s).
  Proof.
    exact: S.Unset_unset.
  Qed.
  Lemma acc_Upd_eq :
    forall x y v s1 s2,
      x == y ->
      Upd y v s1 s2 ->
      acc x s2 = Some v.
  Proof.
    exact: S.acc_Upd_eq.
  Qed.
  Lemma acc_Upd_neq :
    forall x y v s1 s2,
      x != y ->
      Upd y v s1 s2 ->
      acc x s2 = acc x s1.
  Proof.
    exact: S.acc_Upd_neq.
  Qed.
  Lemma acc_Unset_eq :
    forall x y s1 s2,
      x == y ->
      Unset y s1 s2 ->
      acc x s2 = None.
  Proof.
    exact: S.acc_Unset_eq.
  Qed.
  Lemma acc_Unset_neq :
    forall x y s1 s2,
      x != y ->
      Unset y s1 s2 ->
      acc x s2 = acc x s1.
  Proof.
    exact: S.acc_Unset_neq.
  Qed.
  Lemma Equal_refl s : Equal s s.
  Proof.
    exact: S.Equal_refl.
  Qed.
  Lemma Equal_sym s1 s2 : Equal s1 s2 -> Equal s2 s1.
  Proof.
    exact: S.Equal_sym.
  Qed.
  Lemma Equal_trans s1 s2 s3 : Equal s1 s2 -> Equal s2 s3 -> Equal s1 s3.
  Proof.
    exact: S.Equal_trans.
  Qed.
  Instance Equal_ST : RelationClasses.Equivalence Equal := S.Equal_ST value.
  Lemma Equal_upd_Equal v e s1 s2 :
    Equal s1 s2 ->
    Equal (upd v e s1) (upd v e s2).
  Proof.
    exact: S.Equal_upd_Equal.
  Qed.
  Lemma Equal_Upd_Equal v e s1 s2 s3 s4 :
    Upd v e s1 s2 -> Upd v e s3 s4 ->
    Equal s1 s3 -> Equal s2 s4.
  Proof.
    exact: S.Equal_Upd_Equal.
  Qed.
  Lemma Upd_pred_Equal v e s1 s2 s : Upd v e s1 s2 -> Equal s1 s -> Upd v e s s2.
  Proof.
    exact: S.Upd_pred_Equal.
  Qed.
  Lemma Upd_succ_Equal v e s1 s2 s : Upd v e s1 s2 -> Equal s2 s -> Upd v e s1 s.
  Proof.
    exact: S.Upd_succ_Equal.
  Qed.
End PStoreAdapter.

Module VStore := MakePStore NOrder.

(** Stores with heterogeneous values. *)

Module Type HSTORE.

  Local Open Scope hlist_scope.

  Parameter T : Set.

  Parameter V : T -> Set.

  Parameter t : HEnv.t T -> Type.

  Parameter empty : forall E : HEnv.t T, t E.

  Parameter upd :
    forall (E : HEnv.t T) (ty : T),
      pvar E ty -> V ty -> t E -> t E.

  Parameter acc :
    forall (E : HEnv.t T) (ty : T),
      pvar E ty -> t E -> V ty.

  Parameter bisim : forall (E : HEnv.t T), t E -> t E -> Prop.

  Axiom acc_upd_heq :
    forall (E : HEnv.t T) (tyx tyy : T) (x : pvar E tyx) (y : pvar E tyy)
           (e : V tyy) (s : t E),
      pvar_var x == pvar_var y ->
      acc x (upd y e s) =v e.

  Axiom acc_upd_eq :
    forall (E : HEnv.t T) (ty : T) (x : pvar E ty) (y : pvar E ty)
           (e : V ty) (s : t E),
      pvar_var x == pvar_var y ->
      acc x (upd y e s) = e.

  Axiom acc_upd_neq :
    forall (E : HEnv.t T) (tyx tyy : T) (x : pvar E tyx) (y : pvar E tyy)
           (e : V tyy) (s : t E),
      pvar_var x != pvar_var y ->
      acc x (upd y e s) = acc x s.

  Axiom bisim_refl : forall (E : HEnv.t T) (s : t E), bisim s s.

  Axiom bisim_pvar_inv :
    forall (E : HEnv.t T) (s1 s2 : t E) (ty : T) (x : pvar E ty),
      bisim s1 s2 -> acc x s1 = acc x s2.

End HSTORE.

Module Type HETEROGENEOUS.
  Parameter T : Set.
  Parameter V : T -> Set.
  Parameter default : forall (x : T), V x.
End HETEROGENEOUS.

Module MakeHStore (H : HETEROGENEOUS) <: HSTORE.

  Local Open Scope hlist_scope.

  Definition T : Set := H.T.

  Definition V : T -> Set := H.V.

  Definition t (E : HEnv.t T) : Type := hlist V (HEnv.vtypes E).

  Program Fixpoint defaults (types : list T) : hlist V types :=
    match types with
    | nil => hnil V
    | cons hd tl => Hcons (H.default hd) (defaults tl)
    end.

  Definition empty (E : HEnv.t T) : t E := defaults (HEnv.vtypes E).

  Definition upd E ty (x : pvar E ty) (v : V ty) (st : t E) : t E :=
    updlidx (pvar_lidx x) v st.

  Definition acc E ty (x : pvar E ty) (st : t E) : V ty :=
    acclidx (pvar_lidx x) st.

  Definition bisim E (s1 s2 : t E) : Prop :=
    forall ty (x : pvar E ty), acc x s1 = acc x s2.

  Lemma acc_upd_heq E tyx tyy (x : pvar E tyx) (y : pvar E tyy)
        (e : V tyy) (s : t E) :
    pvar_var x == pvar_var y ->
    (acc x (upd y e s) =v e).
  Proof.
    rewrite /acc /upd /= => Hxy.
    rewrite acclidx_updlidx_heq.
    - reflexivity.
    - apply: pvar_lidx_heq.
      assumption.
  Qed.

  Lemma acc_upd_eq E ty (x y : pvar E ty) (e : V ty) (s : t E) :
    pvar_var x == pvar_var y ->
    acc x (upd y e s) = e.
  Proof.
    move=> Hxy.
    apply: value_eq_eq.
    apply: acc_upd_heq.
    assumption.
  Qed.

  Lemma acc_upd_neq E tyx tyy (x : pvar E tyx) (y : pvar E tyy)
        (e : V tyy) (s : t E) :
    pvar_var x != pvar_var y ->
    acc x (upd y e s) = acc x s.
  Proof.
    rewrite /acc /upd /= => Hne.
    rewrite acclidx_updlidx_hneq.
    - reflexivity.
    - apply: pvar_lidx_hneq.
      assumption.
  Qed.

  Lemma bisim_refl E (s : t E) : bisim s s.
  Proof.
    move=> ty x; reflexivity.
  Qed.

  Lemma bisim_pvar_inv E (s1 s2 : t E) ty (x : pvar E ty) :
    bisim s1 s2 -> acc x s1 = acc x s2.
  Proof.
    move=> Hs.
    exact: Hs.
  Qed.

End MakeHStore.

(** State equality modulo values of a set of variables *)

From Common Require Import FSets.

Module TStateEqmod
       (X : SsrOrderedType)
       (Store : TSTORE X) (VS : SsrFSet with Module E := X).

  Section SEQM1.

    Variable vs : VS.t.

    Variable value : Type.

    Definition state_eqmod (s1 s2 : Store.t value) : Prop :=
      forall v, VS.mem v vs -> Store.acc v s1 = Store.acc v s2.

    Lemma state_eqmod_refl (s : Store.t value) : state_eqmod s s.
    Proof.
      move=> v Hmem; reflexivity.
    Qed.

    Lemma state_eqmod_sym (s1 s2 : Store.t value) :
      state_eqmod s1 s2 -> state_eqmod s2 s1.
    Proof.
      move=> Heqm v Hmem. rewrite (Heqm v Hmem). reflexivity.
    Qed.

    Lemma state_eqmod_trans (s1 s2 s3 : Store.t value) :
      state_eqmod s1 s2 -> state_eqmod s2 s3 -> state_eqmod s1 s3.
    Proof.
      move=> Heqm12 Heqm23 v Hmem. rewrite (Heqm12 v Hmem) (Heqm23 v Hmem).
      reflexivity.
    Qed.

    Global Instance state_eqmod_equiv : RelationClasses.Equivalence state_eqmod.
    Proof.
      split.
      - exact: state_eqmod_refl.
      - exact: state_eqmod_sym.
      - exact: state_eqmod_trans.
    Defined.

  End SEQM1.

  Module VSLemmas := FSetLemmas VS.

  Section SEQM2.

    Variable value : Type.

    Lemma state_eqmod_subset (vs1 vs2 : VS.t) (s1 s2 : Store.t value) :
      state_eqmod vs1 s1 s2 ->
      VS.subset vs2 vs1 ->
      state_eqmod vs2 s1 s2.
    Proof.
      move=> Heqm Hsub v Hmem. exact: (Heqm v (VSLemmas.mem_subset Hmem Hsub)).
    Qed.

    Lemma state_eqmod_add1 v (vs : VS.t) (s1 s2 : Store.t value) :
      state_eqmod (VS.add v vs) s1 s2 ->
      Store.acc v s1 = Store.acc v s2 /\ state_eqmod vs s1 s2.
    Proof.
      move=> Heqm; split.
      - apply: Heqm. apply: VSLemmas.mem_add2. exact: VS.E.eq_refl.
      - move=> x Hmem; apply: Heqm. apply: VSLemmas.mem_add3. assumption.
    Qed.

    Lemma state_eqmod_add2 v (vs : VS.t) (s1 s2 : Store.t value) :
      state_eqmod vs s1 s2 ->
      Store.acc v s1 = Store.acc v s2 ->
      state_eqmod (VS.add v vs) s1 s2.
    Proof.
      move=> Heqm Hv x Hmem. case: (VSLemmas.mem_add1 Hmem) => {Hmem} Hmem.
      - by rewrite (eqP Hmem).
      - exact: (Heqm x Hmem).
    Qed.

    Lemma state_eqmod_union1 (vs1 vs2 : VS.t) (s1 s2 : Store.t value) :
      state_eqmod (VS.union vs1 vs2) s1 s2 ->
      state_eqmod vs1 s1 s2 /\ state_eqmod vs2 s1 s2.
    Proof.
      move=> Heqm; split; move=> v Hmem; apply: Heqm.
      - apply: VSLemmas.mem_union2. assumption.
      - apply: VSLemmas.mem_union3. assumption.
    Qed.

    Lemma state_eqmod_union2 (vs1 vs2 : VS.t) (s1 s2 : Store.t value) :
      state_eqmod vs1 s1 s2 ->
      state_eqmod vs2 s1 s2 ->
      state_eqmod (VS.union vs1 vs2) s1 s2.
    Proof.
      move=> Heqm1 Heqm2 v Hmem. case: (VSLemmas.mem_union1 Hmem) => {Hmem} Hmem.
      - exact: (Heqm1 v Hmem).
      - exact: (Heqm2 v Hmem).
    Qed.

  End SEQM2.

End TStateEqmod.


(**********************************************************************)
(* 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                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                    Tuple Lambda Calculus                           *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                    Tuple_reduction2.v                             *)
(*                                                                    *)
(* adapted from Terms.v for Lambda Calculus                           *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega Test Delayed_Terms Delayed_Tactics Delayed_reduction Delayed_Normal.

(* standardisation via head reduction *)

Inductive hnf_tuple: lambda -> Prop :=
| hnft_unit : hnf_tuple Unit
| hnft_pair : forall s t, hnf_tuple s -> hnf_tuple (Pair s t)
.

Inductive hnf: lambda -> Prop :=
| hnf_ref : forall i s, hnf_tuple s -> hnf (Ref i s)
| hnf_abs : forall t, hnf t -> hnf (Abs t)
.

Hint Constructors hnf_tuple hnf .

Lemma nf_implies_hnf_tuple : forall st s, normal st s -> st = Tuple -> hnf_tuple s.
Proof. intros st s nf; induction nf; split_all; subst; inversion H; subst; eauto. Qed.

Lemma nf_implies_hnf : forall st t, normal st t -> st = Term -> hnf t .
Proof.
intros t nf; induction nf; split_all; subst; inversion H; subst; eauto.
eapply2 hnf_ref. eapply2 nf_implies_hnf_tuple.
Qed.

Fixpoint head_tuple t :=
(* t is assumed to be a well-formed tuple *)
  match t with
| Unit => Unit
| Pair s u => Pair (head_tuple s) u
| _ => t
end
.

Fixpoint head_app t u :=
match t with
| Abs t1 =>
  match t1 with
    | Ref 0 Unit => u
    | Ref (S i) Unit => Ref i Unit
    | Ref i (Pair s t1) => (App (App (Abs (Ref i s)) u) (App (Abs t1) u))
    | Abs t2 =>  Abs (App (Abs t2) (lift u))
    | _ => App t u
  end
| Ref i s => Ref i (Pair s u)
| _ => App t u
end.

Inductive head : nat -> termred :=
| hd_ref : forall i s, head 0 (Ref i s) (Ref i (head_tuple s))
| hd_abs : forall n t v, head n t v ->  head n (Abs t) (Abs v)
| hd_app: forall n1 t1 v1,  head n1 t1 v1 ->
          forall n2 t2 v, head n2 (head_app v1 t2) v -> head (S (n1+n2)) (App t1 t2) v
.

Hint Constructors head .

Lemma head_tuple_is_hnf_tuple:
forall st t, well_formed st t -> st = Tuple -> hnf_tuple (head_tuple t).
Proof.
intros st t wf; induction wf; split_all; subst.
Qed.

Lemma head_tuple_preserves_well_formed:
forall st t, well_formed st t -> st = Tuple -> well_formed Tuple (head_tuple t).
Proof.
intros t wf; induction wf; split_all; subst; inversion H; subst; eauto.
Qed.

Lemma head_app_preserves_well_formed:
forall t1, forall t2, well_formed Term t1 -> well_formed Term t2 ->
well_formed Term (head_app t1 t2).
Proof.
induction t1; split_all; inversion H; subst; split_all.
inversion H2; subst.
case i; split_all; inversion H1; subst; auto.
eapply2 wf_abs. eapply2 wf_app. unfold lift. eapply2 lift_rec_preserves_well_formed.
eapply2 wf_app.
Qed.

Lemma head_is_hnf:
forall st n t v, well_formed st t -> head n t v -> hnf v /\ well_formed Term v /\ st = Term.
Proof.
intros st n t v wf e; induction e; inversion wf; subst; split_all.
(* 6 *)
eapply2 hnf_ref. eapply2 head_tuple_is_hnf_tuple.
eapply2 wf_ref. eapply2 head_tuple_preserves_well_formed.
(* 4 *)
eapply2 hnf_abs.  eapply2 IHe. eapply2 wf_abs.  eapply2 IHe.
(* 2 *)
 eapply2 IHe2. eapply2 (head_app_preserves_well_formed). eapply2 IHe1.
(* 1 *)
 eapply2 IHe2. eapply2 (head_app_preserves_well_formed).  eapply2 IHe1.
Qed.

Lemma head_tuple_of_hnf_tuple: forall n, hnf_tuple n -> head_tuple n = n.
Proof. intros n nf; induction nf; split_all. Qed.

Lemma head_of_hnf: forall n, hnf n -> head 0 n n.
Proof. intros n nf; induction nf; split_all.
assert (head_tuple s = s). eapply2  head_tuple_of_hnf_tuple. rewrite <- H0 at 2.
eapply2 hd_ref.
Qed.

Lemma head_app_head_reduces : forall t u, tuple_red (App t u) (head_app t u).
Proof.
induction t; split_all; try (eapply2 zero_red; fail); try red; try (one_step; fail).
case t; split_all; try one_step. case l; split_all; case n; split_all.
Qed.

Lemma head_tuple_reduces : forall t, tuple_red t (head_tuple t).
Proof.
intros t; induction t; split_all;
try (eapply2 zero_red; fail); try red; try (one_step; fail).
eapply2 preserves_pair_tuple_red. eapply2 zero_red.
Qed.

Lemma head_reduces : forall n t v, head n t v -> tuple_red t v.
Proof.
intros n t v e; induction e; split_all;
try (eapply2 zero_red; fail); try red; try (one_step; fail).
(* 3 *)
eapply preserves_ref_tuple_red.  2: eauto. eapply2 head_tuple_reduces.
(* 2 *)
 eapply2 preserves_abs_tuple_red.
(* 1 *)
eapply transitive_red. eapply preserves_app_tuple_red.  eexact IHe1. eapply2 zero_red.
eapply transitive_red. eapply2 head_app_head_reduces. auto.
Qed.

Lemma head_is_functional:
forall n1 t v1, head n1 t v1 -> forall n2 v2, head n2 t v2 -> n1 = n2 /\ v1 = v2.
Proof.
intros n1 t v1 e; induction e; intros;
try (inversion H; subst; auto; rewrite (IHe v0); split_all; fail).
(* 2 *)
inversion H; subst; auto.
assert(n = n2 /\ v = v0) by eapply2 IHe; subst.
split_all; subst.
(* 1 *)
inversion H; subst; auto.
assert(n1 = n3 /\ v1 = v0) by eapply2 IHe1. inversion H0; subst.
assert(n2 = n4 /\ v = v2) by eapply2 IHe2. split_all.
Qed.

Lemma head_tuple_preserves_tuple_red1:
forall t u, well_formed Tuple t -> tuple_red1 t u -> tuple_red1 (head_tuple t) (head_tuple u).
Proof.
intros t u wf r; induction r; inversion wf; subst; split_all; eauto.
Qed.

(* delete ??
Lemma head_app_preserves_tuple_red1:
  forall t t1, well_formed Term t -> tuple_red1 t t1 ->
  forall u u1, tuple_red1 u u1 ->  well_formed Term u ->
               tuple_red1 (head_app t u) (head_app t1 u1) .
Proof.
induction t; split_all; inversion H; subst; split_all;
try (inversion H0; subst; split_all; fail).
(* 2 *)
inversion H0; subst; split_all.  inversion H4; subst.
(* 4 *)
inversion H5; subst; split_all.
case i; split_all; inversion H3; subst; split_all; inversion H9; subst;   auto.
(* 3 *)
inversion H4; subst; split_all. inversion H5; subst; split_all.
eapply2 abs_tuple_red. eapply2 app_tuple_red.
unfold lift; eapply2 lift_rec_preserves_tuple_red1.
(* 2 *)
case i; split_all; inversion H3; subst; split_all; inversion H9; subst;   auto.
(* 1 *)
inversion H4; subst; auto.
eapply2 abs_tuple_red. eapply2 app_tuple_red.
unfold lift. eapply2 lift_rec_preserves_tuple_red1.
Qed.

*)

Lemma head_app_preserves_tuple_red1:
  forall t, hnf t -> forall t1, tuple_red1 t t1 ->
  forall u u1, tuple_red1 u u1 ->  well_formed Term u ->
               tuple_red1 (head_app t u) (head_app t1 u1) .
Proof.
induction t; split_all; inversion H0; subst; split_all; inversion H; subst.
inversion H5; subst; split_all.
(* 2 *)
inversion H4; subst.
case i; split_all;
inversion H3; subst; split_all; inversion H9; subst;   auto.
(* 1 *)
inversion H4; subst; auto.
eapply2 abs_tuple_red. eapply2 app_tuple_red.
unfold lift. eapply2 lift_rec_preserves_tuple_red1.
Qed.

Lemma tuple_red1_then_head_implies_head_then_tuple_red1:
  forall n u v, head n u v -> forall t, well_formed Term t -> tuple_red1 t u ->
  exists n1 v1, head n1 t v1 /\ tuple_red1 v1 v.
Proof.
cut(forall p n, n<p ->
 forall u v, head n u v -> forall t, well_formed Term t -> tuple_red1 t u ->
  exists n1 v1, head n1 t v1 /\ tuple_red1 v1 v).
split_all. eapply2 H.
induction p. split_all; noway.
(* 1 *)
intros n c u v h; induction h; split_all; eauto.
(* 3 *)
generalize t s i H H0; clear. induction t; split_all;  inversion H0; subst.
(* 6 *)
inversion H; subst. exist 0; exist (Ref i (head_tuple t)).
eapply2 ref_tuple_red.
eapply2 head_tuple_preserves_tuple_red1.
(* 5 *)
inversion H; subst. inversion H3; subst.
exists (S (0+0)); exists(head_app (Ref i (head_tuple M)) t2). split.
eapply hd_app. eapply2 hd_ref.
eapply2 head_of_hnf. eapply2 hnf_ref. eapply2 hnft_pair.
eapply2 head_tuple_is_hnf_tuple.
split_all. eapply2 ref_tuple_red. eapply2 pair_tuple_red.
eapply2 head_tuple_preserves_tuple_red1.
(* 4 *)
inversion H; subst.
elim(IHt2 s i); split_all.
exists (S(0+x)); exists x0. split.
eapply2 hd_app. auto.
(* 3 *)
exists (S(0+0)); exists (Ref i Unit). split.
eapply2 hd_app. simpl. eapply2 head_of_hnf. split_all.
(* 2 *)
assert(forall t0 t1, tuple_red1 t0 t1 -> forall t, t1 = Abs t ->
(forall n : nat,
        n < p ->
        forall u v : lambda,
        head n u v ->
        forall t : lambda,
        well_formed Term t ->
        tuple_red1 t u ->
        exists (n1 : nat) (v1 : lambda), head n1 t v1 /\ tuple_red1 v1 v) ->
forall n v, head n t v -> n < S p ->
 well_formed Term t0 ->
(n < S p ->
        forall t0 : lambda,
        well_formed Term t0 ->
        tuple_red1 t0 t ->
        exists (n1 : nat) (v1 : lambda), head n1 t0 v1 /\ tuple_red1 v1 v) ->
  exists (n0 : nat) (v0 : lambda), head n0 t0 v0 /\ tuple_red1 v0 (Abs v)).
clear.
intros t0 t1 r; induction r; split_all; subst; split_all; invsub.
(* 5 *)
inversion H3; subst. elim(H4 H2 M); split_all. exist x; exist (Abs x0).
(* 4 *)
inversion H3; subst.
assert(exists (n0 : nat) (v0 : lambda), head n0 N v0 /\ tuple_red1 v0 (Abs v)).
eapply2 IHr. split_all.
exists (S (0+x)); exists x0. split. eapply2 hd_app. auto.
(* 3 *)
inversion H1; subst. inversion H7; subst. inversion H3; inversion H8;  inversion H12; subst.
assert(n1<p) by omega.
assert(exists (n0 : nat) (v1 : lambda), head n0 M v1 /\ tuple_red1 v1 v0).
eapply2 (H0 n1 H M' v0). split_all.
assert(n2<p) by omega.
assert(exists (n0 : nat) (v1 : lambda), head n0 (head_app (Abs x0) (lift N)) v1 /\ tuple_red1 v1 v).
eapply2 (H0 n2 H5  (head_app (Abs v0) (lift N')) v).
eapply2 head_app_preserves_well_formed.
eapply2 wf_abs.  eapply2 head_is_hnf.
unfold lift. eapply2 lift_rec_preserves_well_formed.
eapply2 head_app_preserves_tuple_red1.
eapply2 hnf_abs. eapply2 head_is_hnf.
unfold lift. eapply2 lift_rec_preserves_tuple_red1.
unfold lift. eapply2 lift_rec_preserves_well_formed.
split_all.
exists (S(x+ S(0+x1))); exists (Abs x2). split.
eapply2 hd_app. unfold head_app.  eapply2 hd_abs. eapply2 hd_app.
eapply2 head_of_hnf.
eapply2 hnf_abs. eapply2 head_is_hnf. auto.
(* 2 *)
eapply2 H1.
(* end of sub-lemma *)
(* 1 *)
cut(forall t0 t, tuple_red1 t0 t -> forall t1 t2, t = App t1 t2 -> forall v,
(forall n : nat,
        n < p ->
        forall u v : lambda,
        head n u v ->
        forall t : lambda,
        well_formed Term t ->
        tuple_red1 t u ->
        exists (n1 : nat) (v1 : lambda), head n1 t v1 /\ tuple_red1 v1 v) ->
forall n1 v1, head n1 t1 v1 ->
forall n2, head n2 (head_app v1 t2) v -> (S (n1+n2)) < S p ->
 well_formed Term t0 ->
(n1 < S p ->
         forall t : lambda,
         well_formed Term t ->
         tuple_red1 t t1 ->
         exists (n1 : nat) (v2 : lambda), head n1 t v2 /\ tuple_red1 v2 v1) ->
(n2 < S p ->
         forall t : lambda,
         well_formed Term t ->
         tuple_red1 t (head_app v1 t2) ->
         exists (n1 : nat) (v1 : lambda), head n1 t v1 /\ tuple_red1 v1 v) ->
  exists (n0 : nat) (v0 : lambda), head n0 t0 v0 /\ tuple_red1 v0 v).
split_all. eapply2 H1.
clear.
intros t0 t r; induction r; split_all; subst; split_all; invsub; inversion H4; subst.
(* 3 *)
assert(n1<p) by omega.
elim(H0 n1 H t1 v1 H1 M); split_all.
assert(n2<p) by omega.
elim(H0 n2 H10 (head_app v1 t2) v H2 (head_app x0 N)); split_all.
exist(S(x+x1)); exist x2. eapply2 hd_app.
eapply2 head_app_preserves_well_formed.
eapply2 (head_is_hnf Term x M).
eapply2 head_app_preserves_tuple_red1. eapply2 (head_is_hnf Term x M).
(* 2 *)
assert(exists (n0 : nat) (v0 : lambda), head n0 N v0 /\ tuple_red1 v0 v) by eapply2 IHr.
split_all.
exists (S(0+ x)); exists x0. split. eapply2 hd_app. auto.
(* 1 *)
inversion H8; subst. inversion H7; subst. inversion H11; subst.
assert(n1<p) by omega.
elim(H0 n1 H (App (Abs (Ref i P')) N') v1 H1 (App (Abs (Ref i P)) N)); split_all.
assert(n2<p) by omega.
elim(H0 n2 H14 (head_app v1 (App (Abs M') N')) v H2  (head_app x0 (App (Abs M) N))); split_all.
exists(S(0+ S(x+x1))); exists x2. split.
eapply2 hd_app. unfold head_app.
gen_case H10 i.
eapply2 hd_app. inversion H10; subst; split_all.
inversion H21; subst; split_all.
inversion H20; subst; split_all.
replace (S n3) with (S(0+n3)) by omega. eapply2 hd_app.
replace(head_tuple (head_tuple P)) with (head_tuple P).  auto.
rewrite (head_tuple_of_hnf_tuple (head_tuple P)). auto.
eapply2 head_tuple_is_hnf_tuple.
eapply2 hd_app.
inversion H10; subst; split_all.
inversion H21; subst; split_all.
inversion H20; subst; split_all.
replace (S n3) with (S(0+n3)) by omega. eapply2 hd_app.
replace(head_tuple (head_tuple P)) with (head_tuple P).  auto.
rewrite (head_tuple_of_hnf_tuple (head_tuple P)). auto.
eapply2 head_tuple_is_hnf_tuple.
auto.
eapply2 head_app_preserves_well_formed.
eapply2 (head_is_hnf Term x (App (Abs (Ref i P)) N)).
eapply2 head_app_preserves_tuple_red1.
eapply2 (head_is_hnf Term x (App (Abs (Ref i P)) N)).
Qed.

(* leftmost_outermost reduction *)

Inductive leftmost_outermost : termred :=
| lo_unit : leftmost_outermost Unit Unit
| lo_pair : forall t1 v1, leftmost_outermost t1 v1 ->
            forall t2 v2, leftmost_outermost t2 v2 ->
                             leftmost_outermost (Pair t1 t2) (Pair v1 v2)
| lo_ref : forall s v i, leftmost_outermost s v -> leftmost_outermost (Ref i s) (Ref i v)
| lo_abs : forall t v, leftmost_outermost t v -> leftmost_outermost (Abs t) (Abs v)
| lo_app : forall n t1 t2 v1, head n (App t1 t2) v1 ->
           forall v, leftmost_outermost v1 v -> leftmost_outermost (App t1 t2) v
.

Hint Constructors leftmost_outermost.

Lemma lo_is_nf:
forall t v, leftmost_outermost t v -> forall st, well_formed st t -> normal st v.
Proof.
intros t v e; induction e; intros st wf; inversion wf; subst; eauto.
eapply2 IHe. eapply2 (head_is_hnf Term n (App t1 t2)).
Qed.

Lemma lo_of_normal: forall st n, normal st n -> leftmost_outermost n n.
Proof. intros st n nf; induction nf; split_all. Qed.

Lemma lo_normal_is_same2 :
forall n n1, leftmost_outermost n n1 -> forall st,  normal st n ->  n1 = n.
Proof.
intros n n1 e; induction e; intros st nf; inversion nf; subst; eauto.
(* 3 *)
rewrite (IHe1 Tuple); auto. rewrite (IHe2 Term); auto.
(* 2 *)
rewrite (IHe Tuple); auto.
(* 1 *)
rewrite (IHe Term); auto.
Qed.

Lemma lo_reduces : forall t v, leftmost_outermost t v -> tuple_red t v.
Proof.
intros t v e; induction e; split_all;
try (eapply2 zero_red; fail); try red; try (one_step; fail).
(* 4 *)
eapply2 preserves_pair_tuple_red.
(* 3 *)
eapply2 preserves_ref_tuple_red.
(* 2 *)
eapply preserves_abs_tuple_red.  eexact IHe. auto.
(* 1 *)
eapply transitive_red.
2: eexact IHe. eapply2 head_reduces.
Qed.

Lemma lo_is_functional:
forall t v1, leftmost_outermost t v1 -> forall v2, leftmost_outermost t v2 -> v1 = v2.
Proof.
intros t v1 e; induction e; intros; inversion H; subst; auto;
try(inversion H0; subst; assert(v1 = v0) by eapply2 head_is_functional; subst; eapply2 IHe; fail).
(* 4 *)
rewrite (IHe1 v3); auto; rewrite (IHe2 v4); auto.
(* 3 *)
rewrite (IHe v0); auto.
(* 2 *)
assert(v = v0) by eapply2 IHe. subst; auto.
(* 1 *)
inversion H0; subst. inversion H3; subst.
assert((n1=n0 /\ v0 = v4)) by eapply2 head_is_functional. split_all; subst.
assert((S(n0+n2)) = (S(n0+n3)) /\ v1 = v3) by eapply2 head_is_functional. split_all; subst.
eapply2 IHe.
Qed.

Lemma leftmost_outermost_tuple_implies_head_tuple:
forall N v, leftmost_outermost N v -> well_formed Tuple N ->
leftmost_outermost (head_tuple N) v.
Proof.
intros N v l; induction l; intro wf; split_all; inversion wf; subst; split_all; eauto.
Qed.

Lemma leftmost_outermost_implies_head:
forall N v, leftmost_outermost N v -> well_formed Term N ->
exists n h, head n N h /\ leftmost_outermost h v.
Proof.
intros N v l; induction l; intro wf; split_all; inversion wf; subst; split_all; eauto.
(* 2 *)
exist 0; exist (Ref i (head_tuple s)) . eapply2 lo_ref.
eapply2 leftmost_outermost_tuple_implies_head_tuple.
(* 1 *)
elim(IHl); split_all.
exist x; exist (Abs x0).
Qed.

Lemma leftmost_outermost_head_tuple:
forall s v, leftmost_outermost (head_tuple s) v -> well_formed Tuple s ->
leftmost_outermost s v.
Proof. induction s; split_all. inversion H0; inversion H; subst. eapply2 lo_pair. Qed.

Lemma aux3:
forall M n v0, head n M v0 -> well_formed Term M ->
forall v, leftmost_outermost v0 v -> leftmost_outermost M v.
Proof.
induction M; split_all; inversion H0; subst; inversion H; subst.
(* 3 *)
inversion H1; subst. eapply2 lo_ref. eapply2 leftmost_outermost_head_tuple.
(* 2 *)
inversion H1; subst. eapply2 lo_abs.
(* 1 *)
eapply2 lo_app.
Qed.

Lemma tuple_red1_then_lo:
forall N P, leftmost_outermost N P ->
forall st M, well_formed st M -> tuple_red1 M N -> leftmost_outermost M P.
Proof.
intros N P e; induction e; intros st M wf r; split_all.
(* 5 *)
assert(well_formed st Unit) by eapply2 tuple_red1_preserves_well_formed. inversion H.  subst.
inversion r; subst; inversion wf; subst; split_all.
(* 4 *)
assert(well_formed st (Pair t1 t2)) by eapply2 tuple_red1_preserves_well_formed. inversion H.  subst.
inversion r; subst; inversion wf; subst; split_all.
eapply2 lo_pair.
(* 3 *)
assert(well_formed st (Ref i s)) by eapply2 tuple_red1_preserves_well_formed.
inversion H; subst.

Lemma aux:
forall M N, tuple_red1 M N -> well_formed Term M -> forall i s, N = Ref i s ->
forall v, leftmost_outermost s v ->
(forall (st : sort) (M : lambda),
        well_formed st M -> tuple_red1 M s -> leftmost_outermost M v) ->
leftmost_outermost M (Ref i v).
Proof.
intros M N r; induction r; split_all; subst; invsub.
(* 4 *)
eapply2 lo_ref. inversion H; subst. eapply2 H2.
(* 3 *)
inversion H; subst. inversion H4; subst. inversion H1; subst.
assert(leftmost_outermost (Pair M N) (Pair v1 v2)). eapply2 H2.
inversion H0; subst.
eapply lo_app. eapply hd_app.  eapply2 hd_ref. simpl.  eapply2 hd_ref. simpl.
eapply2 lo_ref. eapply2 lo_pair.
replace(head_tuple (head_tuple M)) with (head_tuple M).
eapply2 leftmost_outermost_tuple_implies_head_tuple.
rewrite (head_tuple_of_hnf_tuple (head_tuple M)). auto.
eapply2 head_tuple_is_hnf_tuple.
(* 2 *)
inversion H; subst. assert(leftmost_outermost N (Ref i v)) by  eapply2 IHr.
elim(leftmost_outermost_implies_head N (Ref i v)); split_all.
eapply lo_app. eapply hd_app.
eapply2 (head_of_hnf (Abs (Ref 0 Unit)) ). simpl.
eexact H3; split_all. auto.
(* 1 *)
eapply2 lo_app. eapply2 hd_app. simpl.
eapply2 head_of_hnf.
Qed.

eapply2 aux.

(* 2 *)
assert(well_formed st (Abs t)) by eapply2 tuple_red1_preserves_well_formed.
inversion H; subst.

Lemma aux2:
forall M N, tuple_red1 M N -> well_formed Term M -> forall t, N = Abs t ->
forall v, leftmost_outermost t v ->
(forall (st : sort) (M : lambda),
        well_formed st M -> tuple_red1 M t -> leftmost_outermost M v) ->
leftmost_outermost M (Abs v).
Proof.
intros M N r; induction r; split_all; subst; invsub; inversion H; subst.
(* 3 *)
eapply2 lo_abs.
(* 2 *)
assert(leftmost_outermost N (Abs v)) by eapply2 IHr.
elim(leftmost_outermost_implies_head N (Abs v)); split_all.
eapply lo_app. eapply hd_app.
eapply2 (head_of_hnf (Abs (Ref 0 Unit)) ). simpl.
eexact H3; split_all. auto.
(* 1 *)
inversion H4; subst. inversion H3; subst.
assert(leftmost_outermost (App (Abs M) (lift N)) v). eapply2 H2. eapply2 wf_app.
unfold lift. eapply2 lift_rec_preserves_well_formed.
eapply2 app_tuple_red. unfold lift; eapply2 lift_rec_preserves_tuple_red1.
elim(leftmost_outermost_implies_head (App (Abs M) (lift N)) v); split_all.
inversion H7; subst. inversion H12; subst.
eapply2 lo_app. eapply2 hd_app. simpl. eapply2 hd_abs.  eapply2 hd_app.
eapply2 head_of_hnf. eapply2 hnf_abs. eapply2 head_is_hnf.
eapply2 wf_app. unfold lift. eapply2 lift_rec_preserves_well_formed.
Qed.

eapply2 aux2.

(* 1 *)
assert(well_formed st (App t1 t2)) by eapply2 tuple_red1_preserves_well_formed.
inversion H0; subst.
assert(exists n0 v0, head n0 M v0 /\ tuple_red1 v0 v1).
eapply2 tuple_red1_then_head_implies_head_then_tuple_red1. split_all.
assert(leftmost_outermost x0 v). eapply2 IHe.
eapply2 (head_is_hnf Term x M).
eapply2 aux3.
Qed.

Lemma tuple_red_then_lo:
forall M N, tuple_red M N -> forall st, well_formed st M ->
forall  P, leftmost_outermost N P ->  leftmost_outermost M P.
Proof.
cut(forall red M N, multi_step red M N -> red = tuple_red1 ->
forall st, well_formed st M ->
forall  P, leftmost_outermost N P ->  leftmost_outermost M P).
split_all.
eapply2 H.
intros red M N r; induction r; split_all; subst.
eapply2 (tuple_red1_then_lo N P0); split_all. eapply2 IHr.
eapply2 tuple_red1_preserves_well_formed.
Qed.

Theorem standardisation:
forall st t n, well_formed st t -> normal st n -> tuple_red t n -> leftmost_outermost t n.
Proof.
intros. assert(leftmost_outermost n n). eapply2 lo_of_normal. eapply2 tuple_red_then_lo.
Qed.


(* 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                                                     *)

(** %\subsection*{ support :  finite\_subsets.v }%*)
Set Implicit Arguments.
Unset Strict Implicit.
From Algebra Require Export Diff.
From Algebra Require Export Singleton.
Require Export cast_between_subsets.
Require Export empty.
Require Export Classical_Prop.

(** - A set is finite if we can list its elements (possibly with duplicates in the list)

 %\label{isfiniteset}% *)

Definition is_finite_set (A : Setoid) :=
  exists n : Nat, (exists v : seq n A, full A =' seq_set v in _).

(** - For subsets, the following notion is more useful as it removes one
   one layer of taking subsets: *)
Definition is_finite_subset (A : Setoid) (B : part_set A) :=
  exists n : Nat, (exists v : seq n A, B =' seq_set v in _).

Lemma is_finite_subset_comp :
 forall (A : Setoid) (B C : part_set A),
 B =' C in _ -> is_finite_subset B -> is_finite_subset C.
red in |- *.
intros.
red in H0.
inversion H0.
inversion H1.
exists x.
exists x0.
apply Trans with B; auto with algebra.
Qed.

(** - There is no corresponding is_finite_set_comp, for there is no 'master' setoid
 wherein two Setoids can be compared. *)

Hint Resolve is_finite_subset_comp: algebra.

Lemma is_finite_subset_then_is_finite :
 forall (A : Setoid) (B : part_set A), is_finite_subset B -> is_finite_set B.
intros.
red in |- *; red in H.
inversion_clear H; inversion_clear H0.
exists x.
assert (forall i : fin x, in_part (x0 i) B).
simpl in H; red in H; simpl in H.
intros.
elim (H (x0 i)).
intros p q; (apply q; auto with algebra).
exists i; auto with algebra.
exists (cast_map_to_subset H0).
simpl in |- *; red in |- *; simpl in |- *; split; intro; auto.
unfold subtype_image_equal in |- *.
simpl in H; red in H; simpl in H.
elim (H (subtype_elt x1)).
intros.
assert (in_part (subtype_elt x1) B).
auto with algebra.
elim (H2 H4).
intros.
exists x2.
apply Trans with (x0 x2); auto with algebra.
Qed.

Lemma is_finite_set_then_is_finite_subset :
 forall (A : Setoid) (B : part_set A), is_finite_set B -> is_finite_subset B.
intros; red in |- *; red in H.
inversion_clear H; inversion_clear H0.
exists x; exists (Map_embed x0).
destruct x0; simpl in H; red in H; simpl in H; simpl in |- *; red in |- *;
 simpl in |- *.
split; intros.
red in H0; elim (H (Build_subtype H0)).
intros p _; generalize (p I); clear p; intro.
inversion_clear H1.
red in H2.
exists x1.
simpl in H2.
auto.
inversion_clear H0.
apply in_part_comp_l with (subtype_elt (Ap x1)); auto with algebra.
Qed.

Lemma seq_set_is_finite_subset :
 forall (A : Setoid) (n : Nat) (v : seq n A), is_finite_subset (seq_set v).
intros.
red in |- *.
exists n.
exists v.
auto with algebra.
Qed.

(** - This one is surprisingly hard to prove (or did I not think hard enough?) *)

Lemma included_reflects_is_finite_subset :
 forall (A : Setoid) (B C : part_set A),
 is_finite_subset C -> included B C -> is_finite_subset B.
intros.
red in H.
inversion_clear H.
generalize B C H0 H1.
clear H1 H0 C B.
induction  x as [| x Hrecx].
intros.
inversion_clear H1.
assert (C =' empty A in _).
apply Trans with (seq_set x); auto with algebra.
clear H x.
assert (included B (empty A)).
apply included_comp with B C; auto with algebra.
red in H.
red in |- *.
exists 0; exists (empty_seq A).
apply Trans with (empty A); auto with algebra.
split.
intro; auto.
intro p; simpl in p; contradiction.

intros.
inversion_clear H1.
assert (in_part (head x0) B \/ ~ in_part (head x0) B); try apply classic.
inversion_clear H1.
assert (included (diff B (single (head x0))) (seq_set (Seqtl x0))).
red in |- *.
intros.
simpl in H1.
inversion_clear H1.
red in H0.
generalize (H0 x1 H3).
intro.
assert (in_part x1 (seq_set x0)).
apply in_part_comp_r with C; auto with algebra.
simpl in H5.
inversion_clear H5.
assert (~ x2 =' Build_finiteT (lt_O_Sn x) in fin (S x)).
unfold head in H4.
red in |- *; red in H4; intro; apply H4.
apply Trans with (x0 x2); auto with algebra.
assert
 (exists i : fin x,
    x2 ='
    match i with
    | Build_finiteT n Hn => Build_finiteT (lt_n_S _ _ Hn)
    end in fin (S x)).
clear H6 H1 H4 H3 x1 H2 H x0 H0 C B Hrecx A.
destruct x2.
simpl in H5.
simpl in |- *.
assert (exists n : Nat, index = S n).
destruct index as [| n].
absurd (0 = 0); auto.
exists n.
auto.
inversion_clear H.
rewrite H0 in in_range_prf.
exists (Build_finiteT (lt_S_n _ _ in_range_prf)).
simpl in |- *.
auto.
inversion_clear H7.
destruct x3.
apply in_part_comp_l with (x0 (Build_finiteT (lt_n_S _ _ in_range_prf)));
 auto with algebra.
simpl in |- *.
exists (Build_finiteT in_range_prf).
auto with algebra.
apply Trans with (x0 x2); auto with algebra.

generalize (Hrecx _ _ H1).
intros.
assert (exists v : seq x A, seq_set (Seqtl x0) =' seq_set v in _).
exists (Seqtl x0).
auto with algebra.
generalize (H3 H4); clear H4 H3; intros.
red in H3.
inversion_clear H3.
inversion_clear H4.
red in |- *.
exists (S x1).
exists (head x0;; x2).
assert
 (forall x : A,
  in_part x B -> x =' head x0 in _ \/ in_part x (diff B (single (head x0)))).
simpl in |- *.
intros.
case (classic (x3 =' head x0 in _)); intro.
left; auto.
right; auto.
simpl in |- *.
red in |- *.
intros.
split.
intro.
generalize (H4 x3 H5); clear H4; intros.
simpl in |- *.
case H4; clear H4; intros.
exists (Build_finiteT (lt_O_Sn x1)).
auto.
simpl in H3; red in H3.
generalize (H3 x3); clear H3; intros.
inversion_clear H3.
generalize (H6 H4); clear H6; intros.
simpl in H3.
inversion_clear H3.
destruct x4.
exists (Build_finiteT (lt_n_S _ _ in_range_prf)).
apply Trans with (x2 (Build_finiteT in_range_prf)); auto with algebra.
intros.
simpl in H5.
inversion_clear H5.
destruct x4.
destruct index as [| n].
apply in_part_comp_l with (head x0); auto with algebra.
assert (included (diff B (single (head x0))) B).
red in |- *.
intros.
simpl in H5.
inversion_clear H5; auto.
red in H5.
apply H5; auto with algebra.
apply in_part_comp_r with (seq_set x2); auto with algebra.
simpl in |- *.
exists (Build_finiteT (lt_S_n n x1 in_range_prf)).
auto.

assert (included B (seq_set (Seqtl x0))).
red in |- *.
intros.
red in H0.
generalize (H0 _ H1).
intro.
assert (in_part x1 (seq_set x0)).
apply in_part_comp_r with C; auto with algebra.
clear H3; simpl in H4.
inversion_clear H4.
assert (~ x2 =' Build_finiteT (lt_O_Sn x) in fin (S x)).
red in |- *; red in H2; intro; apply H2.
apply in_part_comp_l with x1; auto with algebra.
apply Trans with (x0 x2); auto with algebra.
simpl in |- *.
assert
 (exists i : fin x,
    x2 ='
    match i with
    | Build_finiteT n Hn => Build_finiteT (lt_n_S _ _ Hn)
    end in fin (S x)).
destruct x2.
destruct index as [| n].
simpl in H4.
absurd (0 = 0); auto.
clear H4.
exists (Build_finiteT (lt_S_n _ _ in_range_prf)).
simpl in |- *.
auto.
inversion_clear H5.
exists x3.
destruct x3.
apply Trans with (x0 x2); auto with algebra.
apply (Hrecx _ _ H1); auto with algebra.
exists (Seqtl x0); auto with algebra.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 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 proof_with_lib_non_dep.

Definition opabs_myint : opabs := Build_opabs "myint" [] [].

Definition cmds1 {o} : @commands o :=
  [
    (* We add the 'member' abstraction *)
    COM_add_def
      (MkAbstraction
         opabs_member
         [(nvart, 0), (nvarT, 0)]
         (mk_so_equality (sovar nvart []) (sovar nvart []) (sovar nvarT []))
         opabs_member_correct),

    (* We prove that 'member' is well-formed *)
    COM_start_proof
      "member_wf"
      (mk_uall
         (mk_uni 0)
         nvarT
         (mk_uall
            (mk_var nvarT)
            nvart
            (mk_member
               (mk_abs opabs_member [nobnd (mk_var nvart), nobnd (mk_var nvarT)])
               (mk_uni 0)))),

    COM_update_proof
      "member_wf"
      []
      (proof_step_isect_member_formation (nvar "T") 1),
    COM_update_proof
      "member_wf"
      [1]
      (proof_step_isect_member_formation (nvar "t") 0),
    COM_update_proof
      "member_wf"
      [1,1]
      (proof_step_cut
         (nvar "w")
         (mk_cequiv
            (mk_abs opabs_member [nobnd (mk_var (nvar "t")), nobnd (mk_var (nvar "T"))])
            (mk_equality (mk_var (nvar "t")) (mk_var (nvar "t")) (mk_var (nvar "T"))))),
    COM_update_proof
      "member_wf"
      [1,1,1]
      (proof_step_cequiv_computation 1),
    COM_update_proof
      "member_wf"
      [1,1,2]
      (proof_step_cequiv_subst_concl
         (nvar "x")
         (mk_equality (vterm (nvar "x")) (vterm (nvar "x")) (mk_uni 0))
         (mk_abs opabs_member [nobnd (mk_var (nvar "t")), nobnd (mk_var (nvar "T"))])
         (mk_equality (mk_var (nvar "t")) (mk_var (nvar "t")) (mk_var (nvar "T")))),
    COM_update_proof
      "member_wf"
      [1,1,2,1]
      (proof_step_hypothesis (nvar "w")),
    COM_update_proof
      "member_wf"
      [2]
      (proof_step_universe_equality),
    COM_update_proof
      "member_wf"
      [1,2]
      (proof_step_unhide_equality (nvar "T")),
    COM_update_proof
      "member_wf"
      [1,2,1]
      (proof_step_hypothesis_equality),
    COM_update_proof
      "member_wf"
      [1,1,2,2]
      (proof_step_equality_equality),
    COM_update_proof
      "member_wf"
      [1,1,2,2,1]
      (proof_step_unhide_equality (nvar "T")),
    COM_update_proof
      "member_wf"
      [1,1,2,2,1,1]
      (proof_step_hypothesis_equality),
    COM_update_proof
      "member_wf"
      [1,1,2,2,2]
      (proof_step_unhide_equality (nvar "t")),
    COM_update_proof
      "member_wf"
      [1,1,2,2,2,1]
      (proof_step_hypothesis_equality),
    COM_update_proof
      "member_wf"
      [1,1,2,2,3]
      (proof_step_unhide_equality (nvar "t")),
    COM_update_proof
      "member_wf"
      [1,1,2,2,3,1]
      (proof_step_hypothesis_equality),
    COM_find_holes "member_wf",
    COM_finish_proof "member_wf",

    (* We prove that Z is inhabited (by 17 here) *)
    COM_start_proof
      "int_member"
      mk_int,
    COM_update_proof
      "int_member"
      []
      (proof_step_introduction (mk_integer 17)),
    COM_update_proof
      "int_member"
      [1]
      (proof_step_integer_equality),
    COM_finish_proof "int_member",
    COM_find_holes "int_member",

    (* We prove that 'int_member' computes to 17 in 1 computation step *)
    COM_start_proof
      "int_member_cequiv"
      (mk_cequiv (mk_abs (opname2opabs "int_member") []) (mk_integer 17)),
    COM_update_proof
      "int_member_cequiv"
      []
      (proof_step_cequiv_computation 1),
    COM_find_holes "int_member_cequiv",
    COM_finish_proof "int_member_cequiv",

    (* We define a new abstraction on top of the one we got from "int_member"'s proof *)
    COM_add_def
      (MkAbstraction
         opabs_myint
         []
         (mk_simple_so_abs (opname2opabs "int_member"))
         (eq_refl, (eq_refl, (eq_refl, (eq_refl, eq_refl))))),

    (* We prove that 'myint' computes to 17 in 2 computation steps *)
    COM_start_proof
      "myint_cequiv"
      (mk_cequiv (mk_abs opabs_myint []) (mk_integer 17)),
    COM_update_proof
      "myint_cequiv"
      []
      (proof_step_cequiv_computation 2),
    COM_find_holes "myint_cequiv",
    COM_finish_proof "myint_cequiv",

    (* We prove once more that Z is inhabited.  We'll use our previous proof *)
    COM_start_proof
      "int_member_v2"
      mk_int,
    COM_update_proof
      "int_member_v2"
      []
      (proof_step_lemma "int_member"),
    COM_find_holes "int_member_v2",
    COM_finish_proof "int_member_v2",

    (* rename 'member' into 'MEMBER' *)
    COM_rename "member" "MEMBER"
  ].

Definition lib1 {o} : @UpdRes o := update_list_from_init cmds1.
Eval compute in lib1.

Time Eval compute in (update_list_from_init_with_validity cmds1).

(*
(*

***********************************************
                  TESTING
(compute wrapped in a Some below takes forever)
***********************************************

*)

Definition cmds2 {o} : @commands o :=
  [
    (* We prove that Z is inhabited (by 17 here) *)
    COM_start_proof
      "int_member"
      mk_int
      (eq_refl, eq_refl),
    COM_update_proof
      "int_member"
      []
      (proof_step_introduction (mk_integer 17)),
    COM_update_proof
      "int_member"
      [1]
      (proof_step_integer_equality),
    COM_finish_proof "int_member",
    COM_find_holes "int_member"
  ].

Definition lib2 {o} : @UpdRes o := update_list_from_init cmds2.

Eval compute in lib2.
Eval compute in (Library2ProofContext (upd_res_state lib2)).

Eval compute in (compute_atmost_k_steps
                   (Library2ProofContext (upd_res_state lib2))
                   1
                   (mk_abs (opname2opabs "int_member") [])).

Lemma reduces_to_of_compute_atmost_k_steps_if_eq {o} :
  forall lib k (t : @NTerm o) u,
    compute_atmost_k_steps lib k t = u
    -> reduces_to lib t u.
Proof.
  introv h; subst.
  apply reduces_to_of_compute_atmost_k_steps.
Qed.

Opaque reduces_to_of_compute_atmost_k_steps.

Eval compute in
    (@apply_proof_step_cequiv_computation
       _
       (Library2ProofContext (upd_res_state lib2))
       (mk_pre_bseq [] (pre_concl_ext
                          (mk_cequiv
                             (mk_abs (opname2opabs "int_member") [])
                             (mk_integer 17))))
       1).

Eval compute in
    (* this is fine *)
    (reduces_to_of_compute_atmost_k_steps [] 0 (mk_integer 1)).

Eval compute in
    (* the [Some] triggers the long computation!  WTF is going on? *)
    (Some (reduces_to_of_compute_atmost_k_steps [] 0 (mk_integer 1))).

Eval compute in
    (let ctxt := Library2ProofContext (upd_res_state lib2) in
     let a := mk_abs (opname2opabs "int_member") [] in
     let b := mk_integer 17 in
     let x := compute_atmost_k_steps ctxt 1 a in
(*     match term_dec_op x b with
     | Some p =>
*)
       Some (reduces_to_of_compute_atmost_k_steps ctxt 1 a)

(*       Some (reduces_to_of_compute_atmost_k_steps_if_eq ctxt 1 a b p)*)

     (*
                   Some ((*pre_proof_cequiv_computation
                           ctxt a b []*)
                           (eq_rect
                              _
                              _
                              (reduces_to_of_compute_atmost_k_steps ctxt 1 a)
                              _
                              p))*)

(*     | None => None
     end*)).
 *)


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal28.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons Zero (Cons Zero (Cons Zero Nil))).
Definition lfind_example_2  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_3  := ( Cons Zero (Cons Zero (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_4  := ( Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) Nil)).
Definition lfind_example_5  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons (Succ Zero) (Cons Zero Nil)))).
Definition lfind_example_6  := ( Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_7  := ( Cons Zero         (Cons Zero            (Cons Zero               (Cons (Succ (Succ Zero))                  (Cons Zero (Cons Zero (Cons Zero (Cons Zero Nil)))))))).
Definition lfind_example_8  := ( Cons Zero         (Cons Zero            (Cons Zero               (Cons (Succ (Succ (Succ Zero)))                  (Cons Zero                     (Cons Zero                        (Cons (Succ (Succ (Succ (Succ Zero))))                           (Cons Zero (Cons (Succ (Succ Zero)) Nil))))))))).
Definition lfind_example_9  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_10  := ( Cons (Succ Zero) Nil).
Definition lfind_example_11  := ( Cons (Succ Zero) (Cons Zero (Cons Zero (Cons Zero (Cons Zero Nil))))).
Definition lfind_example_12  := ( Cons (Succ Zero)         (Cons (Succ Zero)            (Cons Zero               (Cons (Succ (Succ Zero))                  (Cons (Succ (Succ (Succ Zero)))                     (Cons (Succ (Succ Zero))                        (Cons (Succ Zero)                           (Cons (Succ Zero) (Cons Zero (Cons Zero Nil)))))))))).
Definition lfind_example_13  := ( Cons Zero (Cons Zero (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))))).
Definition lfind_example_14  := ( Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_15  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_16  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_17  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_18  := ( Cons Zero Nil).
Definition lfind_example_19  := ( Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal28_theorem0_82_qrevflat_append/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 .


From RecordUpdate Require Import RecordSet.

Set Implicit Arguments.

Module SimpleExample.

  Record X := mkX { A: nat;
                    B: nat;
                    C: unit }.

  Instance etaX : Settable _ := settable! mkX <A; B; C>.

  Import RecordSetNotations.
  Definition setAB a b x := x <|A := a|> <|B := b|>.
  Definition updateAB a b x := x <|A ::= plus a|> <|B ::= minus b|>.

End SimpleExample.

Module IndexedType.
  Record X {T} := mkX { A: T;
                        B: T;
                        C: unit }.
  Arguments X T : clear implicits.

  Instance etaX T: Settable (X T) :=
    settable! (mkX (T:=T)) < A; B; C>.

  Import RecordSetNotations.
  Definition setAB T a b (x: X T) := x <|A := a|> <|B := b|>.

End IndexedType.

Module DependentExample.
  Record X := mkX { T: Type;
                    A: T;
                    B: nat }.

  Instance etaX : Settable X :=
    settable! mkX <T; A; B>.

  Import RecordSetNotations.
  Definition setB b x := x <|B := b|>.
End DependentExample.

Module WellFormedExample.

  Record X := mkX { A: nat;
                    B: nat;
                    C: unit }.

  Instance etaX : Settable _ := settable! mkX <A; B; C>.

  Definition setAB a b x := set A (fun _ => a) (set B (fun _ => b) x).

  (* Resolving an instance for SetterWf proves some correctness properties of
  the setter. You can also require constructing this instance by accessing the
  setter through set_wf. *)
  Instance set_A : SetterWf A.
  Proof.
    apply _.
  Qed.

  Definition setAB_wf a b x := set_wf A (fun _ => a) (set_wf B (fun _ => b) x).
End WellFormedExample.

Module DependentWfExample.
  Record X := mkX { T: Type;
                    A: T;
                    B: nat }.

  Instance etaX : Settable X :=
    settable! mkX <T; A; B>.

  Instance set_A : SetterWf B.
  Proof.
    apply _.
  Qed.
End DependentWfExample.

Module NestedExample.
  Record C := mkC { n : nat }.
  Record B := mkB { c : C }.
  Record A := mkA { b : B }.

  Instance etaC : Settable _ := settable! mkC<n>.
  Instance etaB : Settable _ := settable! mkB<c>.
  Instance etaA : Settable _ := settable! mkA<b>.

  Import RecordSetNotations.
  Definition setNested n' x := x <| b; c; n := n' |>.
End NestedExample.

Module TypeParameterExample.
  Record X T := mkX { a: nat; b: T; c: T * T; }.
  Arguments a {T}.
  Arguments b {T}.
  Arguments c {T}.

  Instance etaX T : Settable _ := settable! (@mkX T) <a;b;c>.

  Import RecordSetNotations.
  Definition set_a (x:X unit) := x <| a := 3 |>.
  Definition set_b (x:X unit) := x <| b := tt |>.
  Definition set_b' {T} (x:X T) (v:T) := x <| b := v |>.
  Definition set_c {T} (x:X T) (v:T) := x <| c := (v,v) |>.
End TypeParameterExample.

Module TypeParameterLimitation.
  Record X T := mkX { a: nat; b: T; }.
  Arguments a {T}.
  Arguments b {T}.

  Instance etaX T : Settable _ := settable! (@mkX T) <a;b>.

  Import RecordSetNotations.
  Definition set_a (x:X unit) := x <| a := 3 |>.
  Definition set_b {T} (x:X T) (v:T) := x <| b := v |>.

  (* unsupported by RecordUpdate: the pattern trick could do this in principle,
  but the type of [set] in the [Setter] typeclass is too restrictive to allow
  the change in X's type.

  We could give [Setter] a broader type (where the type of the record can
  change), but then I'd worry about type inference being underconstrained in the
  common case. *)
  Definition strong_update_to_b {T1 T2} (x: X T1) (v: T2) : X T2 :=
    mkX (a x) v.
End TypeParameterLimitation.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX Protocols Worlds NetworkSem Rely.
Require FunctionalExtensionality.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module ProtocolWithInvariant.
Section ProtocolWithInvariant.

Variable p : protocol.

(* Decompose the initial protocol *)
Notation l := (plab p).
Notation coh := (coh p).

(* User-provided (supposedly inductive) invariant *)
Variable I : dstatelet -> pred nid -> Prop.
(* "Initial" state *)
Variable d0 : dstatelet.

Definition W := mkWorld p.

Notation toSt d := (l \\-> d).

(* TODO: prove relation between stability and reachability *)

(* New coherence predicate: includes only reachable states *)
Definition cohI :=
  [Pred d | coh d /\ I d (nodes p d)].

(* The usual coherence properties all hold *)
Lemma cohIVd d : cohI d -> valid (dstate d).
Proof. by case=>/cohVl. Qed.

Lemma cohIVs d : cohI d -> valid (dsoup d).
Proof. by case=>/cohVs. Qed.

Lemma cohIDom d : cohI d -> dom (dstate d) =i nodes p d.
Proof. by case=>/cohDom. Qed.

(* Define it as a coherence *)
Definition CohI := CohPred (CohPredMixin cohIVd cohIVs cohIDom).

(* Some helper lemmas *)
Lemma st_helper d : (getStatelet (toSt d) l) = d.
Proof. by rewrite /getStatelet findPt. Qed.

Lemma cohSt d : coh d -> Coh W (toSt d).
Proof.
move=>C; split.
- by apply/andP; rewrite valid_unit; split=>//; apply: validPt.
- by apply: validPt.
- by move=>z lc ls st; rewrite dom0.
- by move=>z; rewrite !domPt inE.
move=>k; case B: (k \in dom (toSt d)); last first.
- rewrite /getProtocol /getStatelet.
  case: (dom_find k (toSt d))=>[->|v /find_some]; last by rewrite B.
  rewrite domPt inE/= in B.
  by case: (dom_find k (toSt p))=>[->|? /find_some]//; rewrite domPt inE/= B.
rewrite domPt inE/= in B; move/eqP: B=>B; subst k.
by rewrite /getProtocol /getStatelet !findPt.
Qed.

Section SendInvWrapper.

Variable st : send_trans coh.

Definition send_safeI this to d m :=
  send_safe st this to d m /\ I d (nodes p d).

Lemma s_safe_cohI this to d m : send_safeI this to d m -> CohI d.
Proof. by case=>/s_safe_coh=>[H1]H2. Qed.

Lemma s_safe_inI this to d m : send_safeI this to d m ->
                               this \in nodes p d /\ to \in nodes p d.
Proof. by case=>/s_safe_in. Qed.

Definition send_stepI: send_step_t (send_safeI) :=
  fun this to d msg S => (@send_step _ _ st this to d msg (proj1 S)).

Lemma s_safe_defI this to d msg :
  send_safeI this to d msg <->
  exists b pf, @send_stepI this to d msg pf = Some b.
Proof.
move: (s_safe_def st this to d msg)=>H; split.
- move=>S; case: (S)=>/H[b][pf]E H1; exists b.
  exists (conj pf H1).
  by rewrite /send_stepI (pf_irr (proj1 (conj pf H1)) pf).
by case=>b[pf]E.
Qed.

(* Inducitve step - prove that the invariant indeed holds *)
Definition S_inv := forall this to d msg (S : send_safe st this to d msg) b,
    I d (nodes p d) -> Some b = send_step S ->
    let: f' := upd this b (dstate d) in
    let: s' := (post_msg (dsoup d) (Msg (TMsg (t_snd st) msg) this to true)).1 in
    let: d' := DStatelet f' s' in
    (forall z, z == this = false -> getLocal z d' = getLocal z d) ->
    I d' (nodes p d').

Hypothesis HIstep : S_inv.

Lemma s_step_cohI : s_step_coh_t CohI (t_snd st) send_stepI.
Proof.
have E1: (getProtocol W l) = p by rewrite /getProtocol/W/=findPt.
move/s_step_coh: (st)=>H.
move=>this to d msg [S]H1 b.
rewrite /send_stepI (pf_irr (proj1 (conj S H1)) S)=>E.
split=>//= ; first by apply: (H this to d msg S b E).
apply: (HIstep H1 E _)=>//.
by move=>z N; rewrite /getLocal/= findU N.
Qed.

(* Assemble a new send-transition for the rich coherence *)
Definition snd_transI := SendTrans s_safe_cohI s_safe_inI s_safe_defI s_step_cohI.

End SendInvWrapper.

Section ReceiveInvWrapper.

Variable rt : receive_trans coh.

Definition receive_stepI: receive_step_t CohI :=
  fun this from m d C pf => receive_step rt from m (proj1 C) pf.

Definition R_inv := forall d from this i (C : coh d) m
                           (pf: this \in nodes p d),
    I d (nodes p d) ->
    find i (dsoup d) = Some (Msg m from this true) ->
    this \in dom (dstate d) ->
    msg_wf rt C this from m -> tag m = t_rcv rt ->
    let: loc' := receive_step rt from m C pf in
    let: s'' := consume_msg (dsoup d) i in
    let: f' := upd this loc' (dstate d) in
    let: d' := (DStatelet f' s'') in
    (forall z, z == this = false -> getLocal z d' = getLocal z d) ->
    I d' (nodes p d').

Hypothesis HIstep : R_inv.

Notation msg_wfI := (fun d (C : CohI d) => msg_wf rt (proj1 C)).

Lemma r_step_cohI :
  r_step_coh_t msg_wfI (t_rcv rt) receive_stepI.
Proof.
have E1: (getProtocol W l) = p by rewrite /getProtocol/W/=findPt.
move=>d from this i C F m D N Wf T.
rewrite /receive_stepI/=.
set d' := {| dstate := upd this (receive_step rt from m (proj1 C) F) (dstate d);
             dsoup := consume_msg (dsoup d) i |}.
split; first by apply: (r_step_coh F D N Wf T).
- apply: (HIstep (proj2 C) N D Wf T)=>//z N'.
  by rewrite /getLocal findU N'.
Qed.

Definition rcv_transI := @ReceiveTrans _ CohI _ msg_wfI _ r_step_cohI.

End ReceiveInvWrapper.

(* The client has to provide instances of the following
   two structures along with the proofs of Hs and Hr. *)

Structure SendInv := SI {
  st : send_trans coh;
  st_inv : S_inv st;
}.

Structure ReceiveInv := RI {
  rt : receive_trans coh;
  rt_inv : R_inv rt;
}.

Structure InductiveInv := II {
  sts : seq SendInv;
  rts : seq ReceiveInv;
  _ : map st sts = snd_trans p;
  _ : map rt rts = rcv_trans p
}.

(* Obtain new send/receive transitions *)
Definition stsI sts := map (fun stt =>
                          @snd_transI (st stt) (@st_inv stt)) sts.
Definition rtsI rts := map (fun rtt =>
                          @rcv_transI (rt rtt) (@rt_inv rtt)) rts.

Import FunctionalExtensionality.

Variable ii : InductiveInv.

Lemma us : uniq (map (@t_snd _ _) (stsI (sts ii))).
Proof.
case: ii=>sts rts Hs Hr; rewrite /stsI -seq.map_comp/=.
suff E: (t_snd (coh:=CohI) \o
               (fun stt : SendInv => snd_transI (st_inv (s:=stt))))
        = fun stt => t_snd (st stt).
by rewrite E seq.map_comp; rewrite Hs; apply: snd_uniq.
(* TODO: can we do without this? *)
by apply: functional_extensionality=>z.
Qed.

Lemma ur : uniq (map (@t_rcv _ _) (rtsI (rts ii))).
Proof.
case: ii=>sts rts Hs Hr; rewrite /stsI -seq.map_comp/=.
suff E: (t_rcv (coh:=CohI) \o
               (fun rtt : ReceiveInv => rcv_transI (rt_inv (r:=rtt))))
        = fun rtt => t_rcv (rt rtt).
by rewrite E seq.map_comp; rewrite Hr; apply: rcv_uniq.
(* TODO: can we do without this? *)
by apply: functional_extensionality=>z.
Qed.

Definition ProtocolWithIndInv := @Protocol _ l _ _ _ us ur.

Lemma stIn (s : SendInv) :
  s \In (sts ii) ->
  (snd_transI (@st_inv s)) \In (snd_trans ProtocolWithIndInv).
Proof. by move=>H; rewrite /stsI/=; apply/Mem_map. Qed.

Lemma rtIn (r : ReceiveInv) :
  r \In (rts ii) ->
  (rcv_transI (@rt_inv r)) \In (rcv_trans ProtocolWithIndInv).
Proof. by move=>H; rewrite /rtsI/=; apply/Mem_map. Qed.

Lemma getInvSendTrans st z to msg s1 h :
  st \In (snd_trans ProtocolWithIndInv) ->
  forall (S : send_safe st z to (getStatelet s1 (plab p)) msg),
  Some h = send_step S ->
  exists st', [/\ st' \In get_st (mkWorld p) (plab p),
     t_snd st' = t_snd st,
     all_hooks_fire (mkWorld p) (plab p) (t_snd st') s1 z msg to &
     exists S': (send_safe st' z to (getStatelet s1 (plab p)) msg),
       Some h = send_step S'].
Proof.
simpl; case: ii=>sts rts HS HR/=; rewrite /stsI.
case/Mem_map_inv; case=>st' stI/= [->]H1; case=>S Is E.
rewrite /get_st/InMem!prEq; exists st'. split=>//.
- by rewrite -HS/=; apply: (Mem_map ProtocolWithInvariant.st H1).
rewrite/send_step/=/Transitions.send_step/=/send_stepI in E.
- move=>??? F.
  apply sym_eq in F.
  move: F.
  by move/find_some; rewrite dom0.
by exists (proj1 (conj S Is)).
Qed.

End ProtocolWithInvariant.

Section InductiveInvConj.

Variable p : protocol.

Definition s_inv_conj (I1 I2 : dstatelet -> pred nid -> Prop)
           (st : send_trans (coh p)) :=
  S_inv (fun d n => I1 d n /\ I2 d n) st.

Lemma s_inv_conjC I1 I2 st :
  s_inv_conj I1 I2 st <-> s_inv_conj I2 I1 st.
Proof.
by split; move=>H this to d msg S b /and_comm G E N; apply/and_comm; apply: H.
Qed.

Lemma s_inv_conjA I1 I2 I3 st :
  s_inv_conj I1 (fun d n => I2 d n /\ I3 d n) st <->
  s_inv_conj (fun d n => I1 d n /\ I2 d n) I3 st.
Proof.
by split=>H this to d msg S b /and_assoc G E N; apply/and_assoc; apply: H.
Qed.

Definition r_inv_conj (I1 I2 : dstatelet -> pred nid -> Prop)
           (rt : receive_trans (coh p)) :=
  R_inv (fun d n => I1 d n /\ I2 d n) rt.

Lemma r_inv_conjC I1 I2 rt :
  r_inv_conj I1 I2 rt <-> r_inv_conj I2 I1 rt.
Proof.
by split=>H d from this i C m pf/and_comm G E D W T N; apply/and_comm; apply: H.
Qed.

Lemma r_inv_conjA I1 I2 I3 rt :
  r_inv_conj I1 (fun d n => I2 d n /\ I3 d n) rt <->
  r_inv_conj (fun d n => I1 d n /\ I2 d n) I3 rt.
Proof.
by split=>H d from this i C m pf/and_assoc G E D W T N; apply/and_assoc; apply: H.
Qed.

(* Definition ii_conj (I1 I2 : dstatelet -> pred nid -> Prop) *)
(*            (ii1 : InductiveInv p I1) *)
(*            (ii2 : InductiveInv p I2) : *)
(*   InductiveInv p (fun d n => I1 d n /\ I2 d n). *)
(* Proof. *)
(* case: ii1 ii2=>sts1 rts1 Es1 Er1 [sts2] rts2 Es2 Er2. *)
(* Qed. *)

End InductiveInvConj.

End ProtocolWithInvariant.

Module PWIExports.
Section PWIExports.

Import ProtocolWithInvariant.

Definition st_helper := st_helper.
Definition cohSt := cohSt.

Definition S_inv := ProtocolWithInvariant.S_inv.
Definition R_inv := ProtocolWithInvariant.R_inv.

Definition SendInv := SendInv.
Definition SI := SI.
Definition ReceiveInv := ReceiveInv.
Definition RI := RI.

Definition InductiveInv := InductiveInv.

Lemma with_inv_coh pr I (ii : InductiveInv pr I) s:
  s \In Coh (mkWorld (ProtocolWithIndInv ii)) ->
  s \In Coh (mkWorld pr).
Proof.
case=>G1 G2 Gh G3 G4; split=>//.
- by apply/andP; rewrite valid_unit; split=>//; rewrite !validPt in G1 *.
- by move=>???? ;rewrite dom0.
- by move=>z; move: (G3 z); rewrite !domPt !inE.
move=>l; move: (G4 l).
case X: (l == plab pr); first by move/eqP:X=>X; subst l; rewrite !prEq; case.
rewrite /getProtocol/mkWorld/=.
suff [X1 X2]: l \notin dom (plab pr \\-> ProtocolWithIndInv ii) /\
              l \notin dom (plab pr \\-> pr).
- by case: dom_find X1 X2=>//=->_; case: dom_find=>//=->.
rewrite !domPt !inE/=; suff: plab pr != l by [].
by apply/negbT; apply/negP=>/eqP Z; subst l; rewrite eqxx in X.
Qed.

Lemma with_inv_nodes pr I (ii : InductiveInv pr I) l :
  nodes (getProtocol (mkWorld (ProtocolWithIndInv ii)) l) =
  nodes (getProtocol (mkWorld pr) l).
Proof.
rewrite /getProtocol/mkWorld/=.
case X: (l == plab pr);
  first by move/eqP:X=>X; subst l; rewrite !findPt.
rewrite /getProtocol/mkWorld/=.
suff [X1 X2]: l \notin dom (plab pr \\-> ProtocolWithIndInv ii) /\
              l \notin dom (plab pr \\-> pr).
by case: dom_find X1 X2=>//=->_; case: dom_find=>//=->.
rewrite !domPt !inE/=; suff: plab pr != l by [].
by apply/negbT; apply/negP=>/eqP Z; subst l; rewrite eqxx in X.
Qed.

Lemma with_inv_labE pr I (ii : InductiveInv pr I):
  plab (ProtocolWithIndInv ii) = plab pr.
Proof. by []. Qed.

Lemma with_inv_step pr I (ii : InductiveInv pr I) z s1 s2:
  s1 \In Coh (mkWorld (ProtocolWithIndInv ii)) ->
  network_step (mkWorld pr) z s1 s2 ->
  network_step (mkWorld (ProtocolWithIndInv ii)) z s1 s2.
Proof.
move=>C'; move: (with_inv_coh C')=>C.
case; first by case=>_<-; apply: Idle.

(*** Send-transition of the host protocol ***)
move=>l st Hs to msg h H1 H2 _ S A E ->/=.
have Y : l = plab pr
  by rewrite -(cohD C) domPt inE/= in H2; move/eqP:H2.
subst l; move: st Hs H1 S E A; rewrite /get_st/InMem!prEq/==>st Hs H1 S E A.
suff X: exists st',
    [/\ st' \In get_st (mkWorld (ProtocolWithIndInv ii)) (plab pr),
     t_snd st' = t_snd st,
     all_hooks_fire (mkWorld (ProtocolWithIndInv ii)) (plab pr) (t_snd st') s1 z msg to &
     exists S': (send_safe st' z to (getStatelet s1 (plab pr)) msg),
                Some h = send_step S'].
case:X=>st'[Hs']Et A'[S']E'; rewrite -Et.
move: (with_inv_nodes ii (plab pr)); rewrite !prEq=>P.
by rewrite -P in H1; apply: (SendMsg (to:=to)(this:=z)(b:=h)(msg:=msg) Hs').

(* Finding the corresponding send-transition of rich protocol *)
rewrite -(with_inv_labE ii)/get_st/InMem!prEq.
case: ii (@stIn _ _ ii) C' =>sts rts HS HR/= Hi C'.
rewrite -HS in Hs; move/Mem_map_inv: Hs=>[[st' stI]]/=[Es]Si; subst st'.
have G: I (getStatelet s1 (plab pr)) (nodes pr (getStatelet s1 (plab pr))).
+ by case: C'=>_ _ _ _/(_ (plab pr)); rewrite prEq; case.
move:(Hi _ Si)=>/={Hi Si}Hi; exists (@snd_transI pr I st stI); split=>//=.
rewrite /send_safeI /send_stepI/=.
by exists (conj S G); rewrite (pf_irr (proj1 (conj S G)) S).

(*** Receive-transition of the host protocol ***)
move=>l rt  Hr i from H1 H2 C1 msg E[F]Hw/=.
have Y : l = plab pr by rewrite -(cohD C) domPt inE/= in H2; move/eqP:H2.
subst l; move: rt Hr H1 E (coh_s _ C1) Hw.
rewrite /get_rt/InMem/=!prEq=>rt Hr H1 E C1' Hw .
have Hi: (coh (getProtocol (mkWorld (ProtocolWithIndInv ii)) (plab pr)))
           (getStatelet s1 (plab pr)) by case:C'=>_ _ _/(_ (plab pr)).
have Hz : z \in nodes
          (getProtocol (mkWorld (ProtocolWithIndInv ii)) (plab pr))
          (getStatelet s1 (plab pr)) by rewrite (with_inv_nodes ii (plab pr)) prEq.
suff X: exists rt',
     [/\ rt' \In get_rt (mkWorld (ProtocolWithIndInv ii)) (plab pr),
      tag msg = t_rcv rt', msg_wf rt' Hi z from msg &
      receive_step rt from msg C1' H1 = receive_step rt' from msg Hi Hz].
case:X=>rt'[Hr']E' Hw' Gr G.
have pf: (z \in nodes (getProtocol (mkWorld (ProtocolWithIndInv ii)) (plab pr))
                  (getStatelet s1 (plab pr))) by rewrite prEq.
move: (@ReceiveMsg _ z s1 s2 (plab pr) rt' Hr' i from pf)=>/=.
rewrite -(cohD C) /= domPt inE eqxx/=; move/(_ is_true_true C' msg E')=>X.
subst s2; apply X; split=>//; clear X.
- by rewrite (pf_irr (coh_s (plab pr) C') Hi).
congr (upd _ _); congr {| dstate := _ ; dsoup := _ |}; congr (upd _ _).
rewrite Gr; clear E E' Hw Hw' Hr Hr' Gr rt F H2 H1 C1 C.
rewrite (pf_irr pf Hz).
by rewrite (pf_irr Hi (coh_s (plab pr) C')).

(* Finding the corresponding receive-transition of rich protocol *)
rewrite /get_rt/InMem/=; move: C1' H1 Hi Hz Hw; rewrite !prEq=>C1' H1 Hi Hz Hw.
case: ii (@rtIn _ _ ii) C' Hi Hz=>/=sts rts HS HR/= Hi C'.
rewrite -HR in Hr; move/Mem_map_inv: Hr=>[[rt' rtI]]/=[Er]Ri; subst rt'.
case=>C1'' Inv Hz. exists (@rcv_transI pr I rt rtI); split=>//.
- by move: (@Hi _ Ri).
rewrite /receive_step/=/receive_stepI/=/receive_step/=.
- by rewrite -(pf_irr C1' (proj1 (conj C1'' Inv))).
by rewrite ?(pf_irr C1' (proj1 (conj C1'' Inv)))
           ?(pf_irr H1 Hz).
Qed.

Lemma with_inv_step' pr I (ii : InductiveInv pr I) z s1 s2:
  network_step (mkWorld (ProtocolWithIndInv ii)) z s1 s2 ->
  network_step (mkWorld pr) z s1 s2.
Proof.
case.
- by case=>C'<-; apply: Idle; split=>//; apply: with_inv_coh C'.
(* Emulating send-transition *)
move=>l st Hs to msg h H1 H2 C' S A E->{s2}.
have Y : l = plab pr
  by rewrite -(cohD C') domPt inE/= in H2; move/eqP:H2.
subst l; move: st Hs H1 S E A; rewrite /get_st/InMem!prEq/==>st Hs H1 S E A.
suff X: exists st',
    [/\ st' \In get_st (mkWorld pr) (plab pr),
     t_snd st' = t_snd st,
     all_hooks_fire (mkWorld (ProtocolWithIndInv ii)) (plab pr) (t_snd st') s1 z msg to &
     exists S': (send_safe st' z to (getStatelet s1 (plab pr)) msg),
                Some h = send_step S'].
case:X=>st'[Hs']Et A'[S']E'; rewrite -Et.
apply: (SendMsg (to:=to)(this:=z)(b:=h)(msg:=msg) Hs')=>//;
  [by rewrite prEq| by apply: (with_inv_coh C')].
by apply: (getInvSendTrans (ii := ii)).

(* Emulating a receive-transition *)
move=>l rt  Hr i from H1 H2 C1 msg E[F]Hw/=.
have Y : l = plab pr by rewrite -(cohD C1) domPt inE/= in H2; move/eqP:H2.
subst l; move: rt Hr H1 E (coh_s _ C1) Hw.
rewrite /get_rt/InMem/=!prEq=>rt Hr H1 E C1' Hw.
have Hi: (coh (getProtocol (mkWorld pr) (plab pr)))
           (getStatelet s1 (plab pr)) by case:(C1'); rewrite prEq.
have Hz : z \in nodes (getProtocol (mkWorld pr) (plab pr))
                      (getStatelet s1 (plab pr))
  by rewrite -(with_inv_nodes ii (plab pr)) prEq.
suff X: exists rt',
     [/\ rt' \In get_rt (mkWorld pr) (plab pr),
      tag msg = t_rcv rt', msg_wf rt' Hi z from msg &
      receive_step rt from msg C1' H1 = receive_step rt' from msg Hi Hz].
case:X=>rt'[Hr']E' Hw' Gr G.
have pf: (z \in nodes (getProtocol (mkWorld pr) (plab pr))
                  (getStatelet s1 (plab pr))) by rewrite prEq.
move: (@ReceiveMsg _ z s1 s2 (plab pr) rt' Hr' i from pf)=>/=.
rewrite -(cohD C1) domPt inE eqxx/=.
move/(_ is_true_true (with_inv_coh C1) msg E')=>X.
subst s2; apply X; split=>//; clear X.
- by rewrite (pf_irr (coh_s (plab pr) (with_inv_coh C1)) Hi).
congr (upd _ _); congr {| dstate := _ ; dsoup := _ |}; congr (upd _ _).
rewrite Gr; clear E E' Hw Hw' Hr Hr' Gr rt F H2 H1.
rewrite (pf_irr pf Hz).
by rewrite (pf_irr Hi (coh_s (plab pr) (with_inv_coh C1))).
(* Identifying the appropriate receive transition *)
case: ii C1 H2 rt Hr E H1 C1' Hw=>sts rts HS HR/=C1 H2 rt Hr E H1 C1' Hw.
move: Hr; rewrite /rtsI.
case/Mem_map_inv; case=>rt' rtI/= [Z] H1'; subst rt.
rewrite /get_rt/InMem; move: C1' H1 Hi Hz Hw; rewrite !prEq=>C1' H1 Hi Hz Hw.
exists rt'; split=>//; last first.
- rewrite {1}/receive_step /rcv_transI /receive_stepI/=.
  rewrite (pf_irr H1 Hz).
  by rewrite (pf_irr (proj1 C1') Hi).
- by rewrite -(pf_irr (proj1 C1') Hi).
by rewrite -HR; apply: (Mem_map (@ProtocolWithInvariant.rt pr I) H1').
Qed.

Lemma with_inv_rely' pr I (ii : InductiveInv pr I) z s1 s2:
  network_rely (mkWorld (ProtocolWithIndInv ii)) z s1 s2 ->
  network_rely (mkWorld pr) z s1 s2.
Proof.
case=>n; elim: n s1=>[|n Hi] s1; first by move=>[<-]/with_inv_coh=>C; exists 0.
case=>z'[s3][N]H/Hi; move/with_inv_step':H=>S; case=>n' R.
by exists n'.+1, z', s3.
Qed.

(* The following definition requires the proofs, for each transitions
   of p that it satisfies the corresponding two-state invariants with
   respect to the supposedly inductive I. *)

Definition ProtocolWithIndInv := ProtocolWithIndInv.

End PWIExports.
End PWIExports.

Export PWIExports.