From iris.algebra Require Export ofe.
From iris.bi Require Export notation.
From iris.prelude Require Import options.
Set Primitive Projections.

Section bi_mixin.
  Context {PROP : Type} `{Dist PROP, Equiv PROP}.
  Context (bi_entails : PROP → PROP → Prop).
  Context (bi_emp : PROP).
  Context (bi_pure : Prop → PROP).
  Context (bi_and : PROP → PROP → PROP).
  Context (bi_or : PROP → PROP → PROP).
  Context (bi_impl : PROP → PROP → PROP).
  Context (bi_forall : ∀ A, (A → PROP) → PROP).
  Context (bi_exist : ∀ A, (A → PROP) → PROP).
  Context (bi_sep : PROP → PROP → PROP).
  Context (bi_wand : PROP → PROP → PROP).
  Context (bi_persistently : PROP → PROP).

  Bind Scope bi_scope with PROP.
  Local Infix "⊢" := bi_entails.
  Local Notation "'emp'" := bi_emp : bi_scope.
  Local Notation "'True'" := (bi_pure True) : bi_scope.
  Local Notation "'False'" := (bi_pure False) : bi_scope.
  Local Notation "'⌜' φ '⌝'" := (bi_pure φ%type%stdpp) : bi_scope.
  Local Infix "∧" := bi_and : bi_scope.
  Local Infix "∨" := bi_or : bi_scope.
  Local Infix "→" := bi_impl : bi_scope.
  Local Notation "∀ x .. y , P" :=
    (bi_forall _ (λ x, .. (bi_forall _ (λ y, P%I)) ..)) : bi_scope.
  Local Notation "∃ x .. y , P" :=
    (bi_exist _ (λ x, .. (bi_exist _ (λ y, P%I)) ..)) : bi_scope.
  Local Infix "∗" := bi_sep : bi_scope.
  Local Infix "-∗" := bi_wand : bi_scope.
  Local Notation "'<pers>' P" := (bi_persistently P) : bi_scope.

  (** * Axioms for a general BI (logic of bunched implications) *)

  (** The following axioms are satisifed by both affine and linear BIs, and BIs
  that combine both kinds of resources. In particular, we have an "ordered RA"
  model satisfying all these axioms. For this model, we extend RAs with an
  arbitrary partial order, and up-close resources wrt. that order (instead of
  extension order).  We demand composition to be monotone wrt. the order: [x1 ≼
  x2 → x1 ⋅ y ≼ x2 ⋅ y].  We define [emp := λ r, ε ≼ r]; persistently is still
  defined with the core: [persistently P := λ r, P (core r)].  This is uplcosed
  because the core is monotone.  *)

  Record BiMixin := {
    bi_mixin_entails_po : PreOrder bi_entails;
    bi_mixin_equiv_entails P Q : (P ≡ Q) ↔ (P ⊢ Q) ∧ (Q ⊢ P);

    (** Non-expansiveness *)
    bi_mixin_pure_ne n : Proper (iff ==> dist n) bi_pure;
    bi_mixin_and_ne : NonExpansive2 bi_and;
    bi_mixin_or_ne : NonExpansive2 bi_or;
    bi_mixin_impl_ne : NonExpansive2 bi_impl;
    bi_mixin_forall_ne A n :
      Proper (pointwise_relation _ (dist n) ==> dist n) (bi_forall A);
    bi_mixin_exist_ne A n :
      Proper (pointwise_relation _ (dist n) ==> dist n) (bi_exist A);
    bi_mixin_sep_ne : NonExpansive2 bi_sep;
    bi_mixin_wand_ne : NonExpansive2 bi_wand;
    bi_mixin_persistently_ne : NonExpansive bi_persistently;

    (** Higher-order logic *)
    bi_mixin_pure_intro (φ : Prop) P : φ → P ⊢ ⌜ φ ⌝;
    bi_mixin_pure_elim' (φ : Prop) P : (φ → True ⊢ P) → ⌜ φ ⌝ ⊢ P;

    bi_mixin_and_elim_l P Q : P ∧ Q ⊢ P;
    bi_mixin_and_elim_r P Q : P ∧ Q ⊢ Q;
    bi_mixin_and_intro P Q R : (P ⊢ Q) → (P ⊢ R) → P ⊢ Q ∧ R;

    bi_mixin_or_intro_l P Q : P ⊢ P ∨ Q;
    bi_mixin_or_intro_r P Q : Q ⊢ P ∨ Q;
    bi_mixin_or_elim P Q R : (P ⊢ R) → (Q ⊢ R) → P ∨ Q ⊢ R;

    bi_mixin_impl_intro_r P Q R : (P ∧ Q ⊢ R) → P ⊢ Q → R;
    bi_mixin_impl_elim_l' P Q R : (P ⊢ Q → R) → P ∧ Q ⊢ R;

    bi_mixin_forall_intro {A} P (Ψ : A → PROP) : (∀ a, P ⊢ Ψ a) → P ⊢ ∀ a, Ψ a;
    bi_mixin_forall_elim {A} {Ψ : A → PROP} a : (∀ a, Ψ a) ⊢ Ψ a;

    bi_mixin_exist_intro {A} {Ψ : A → PROP} a : Ψ a ⊢ ∃ a, Ψ a;
    bi_mixin_exist_elim {A} (Φ : A → PROP) Q : (∀ a, Φ a ⊢ Q) → (∃ a, Φ a) ⊢ Q;

    (** BI connectives *)
    bi_mixin_sep_mono P P' Q Q' : (P ⊢ Q) → (P' ⊢ Q') → P ∗ P' ⊢ Q ∗ Q';
    bi_mixin_emp_sep_1 P : P ⊢ emp ∗ P;
    bi_mixin_emp_sep_2 P : emp ∗ P ⊢ P;
    bi_mixin_sep_comm' P Q : P ∗ Q ⊢ Q ∗ P;
    bi_mixin_sep_assoc' P Q R : (P ∗ Q) ∗ R ⊢ P ∗ (Q ∗ R);
    bi_mixin_wand_intro_r P Q R : (P ∗ Q ⊢ R) → P ⊢ Q -∗ R;
    bi_mixin_wand_elim_l' P Q R : (P ⊢ Q -∗ R) → P ∗ Q ⊢ R;

    (** Persistently *)
    (* In the ordered RA model: Holds without further assumptions. *)
    bi_mixin_persistently_mono P Q : (P ⊢ Q) → <pers> P ⊢ <pers> Q;
    (* In the ordered RA model: `core` is idempotent *)
    bi_mixin_persistently_idemp_2 P : <pers> P ⊢ <pers> <pers> P;

    (* In the ordered RA model: [ε ≼ core x]. *)
    bi_mixin_persistently_emp_2 : emp ⊢ <pers> emp;

    bi_mixin_persistently_forall_2 {A} (Ψ : A → PROP) :
      (∀ a, <pers> (Ψ a)) ⊢ <pers> (∀ a, Ψ a);
    bi_mixin_persistently_exist_1 {A} (Ψ : A → PROP) :
      <pers> (∃ a, Ψ a) ⊢ ∃ a, <pers> (Ψ a);

    (* In the ordered RA model: [core x ≼ core (x ⋅ y)]. *)
    bi_mixin_persistently_absorbing P Q : <pers> P ∗ Q ⊢ <pers> P;
    (* In the ordered RA model: [x ⋅ core x = x]. *)
    bi_mixin_persistently_and_sep_elim P Q : <pers> P ∧ Q ⊢ P ∗ Q;
  }.

  (** We equip any BI with a later modality. This avoids an additional layer in
  the BI hierachy and improves performance significantly (see Iris issue #303).

  For non step-indexed BIs the later modality can simply be defined as the
  identity function, as the Löb axiom or contractiveness of later is not part of
  [BiLaterMixin]. For step-indexed BIs one should separately prove an instance
  of the class [BiLaterContractive PROP] or [BiLöb PROP]. (Note that there is an
  instance [BiLaterContractive PROP → BiLöb PROP] in [derived_laws_later].)

  For non step-indexed BIs one can get a "free" instance of [BiLaterMixin] using
  the smart constructor [bi_later_mixin_id] below. *)
  Context (bi_later : PROP → PROP).
  Local Notation "▷ P" := (bi_later P) : bi_scope.

  Record BiLaterMixin := {
    bi_mixin_later_ne : NonExpansive bi_later;

    bi_mixin_later_mono P Q : (P ⊢ Q) → ▷ P ⊢ ▷ Q;
    bi_mixin_later_intro P : P ⊢ ▷ P;

    bi_mixin_later_forall_2 {A} (Φ : A → PROP) : (∀ a, ▷ Φ a) ⊢ ▷ ∀ a, Φ a;
    bi_mixin_later_exist_false {A} (Φ : A → PROP) :
      (▷ ∃ a, Φ a) ⊢ ▷ False ∨ (∃ a, ▷ Φ a);
    bi_mixin_later_sep_1 P Q : ▷ (P ∗ Q) ⊢ ▷ P ∗ ▷ Q;
    bi_mixin_later_sep_2 P Q : ▷ P ∗ ▷ Q ⊢ ▷ (P ∗ Q);
    bi_mixin_later_persistently_1 P : ▷ <pers> P ⊢ <pers> ▷ P;
    bi_mixin_later_persistently_2 P : <pers> ▷ P ⊢ ▷ <pers> P;

    bi_mixin_later_false_em P : ▷ P ⊢ ▷ False ∨ (▷ False → P);
  }.

  Lemma bi_later_mixin_id :
    (∀ (P : PROP), (▷ P)%I = P) →
    BiMixin → BiLaterMixin.
  Proof.
    intros Hlater Hbi. pose proof (bi_mixin_entails_po Hbi).
    split; repeat intro; rewrite ?Hlater ?Hequiv //.
    - apply (bi_mixin_forall_intro Hbi)=> a.
      etrans; [apply (bi_mixin_forall_elim Hbi a)|]. by rewrite Hlater.
    - etrans; [|apply (bi_mixin_or_intro_r Hbi)].
      apply (bi_mixin_exist_elim Hbi)=> a.
      etrans; [|apply (bi_mixin_exist_intro Hbi a)]. by rewrite /= Hlater.
    - etrans; [|apply (bi_mixin_or_intro_r Hbi)].
      apply (bi_mixin_impl_intro_r Hbi), (bi_mixin_and_elim_l Hbi).
  Qed.
End bi_mixin.

Structure bi := Bi {
  bi_car :> Type;
  bi_dist : Dist bi_car;
  bi_equiv : Equiv bi_car;
  bi_entails : bi_car → bi_car → Prop;
  bi_emp : bi_car;
  bi_pure : Prop → bi_car;
  bi_and : bi_car → bi_car → bi_car;
  bi_or : bi_car → bi_car → bi_car;
  bi_impl : bi_car → bi_car → bi_car;
  bi_forall : ∀ A, (A → bi_car) → bi_car;
  bi_exist : ∀ A, (A → bi_car) → bi_car;
  bi_sep : bi_car → bi_car → bi_car;
  bi_wand : bi_car → bi_car → bi_car;
  bi_persistently : bi_car → bi_car;
  bi_later : bi_car → bi_car;
  bi_ofe_mixin : OfeMixin bi_car;
  bi_cofe : Cofe (Ofe bi_car bi_ofe_mixin);
  bi_bi_mixin : BiMixin bi_entails bi_emp bi_pure bi_and bi_or bi_impl bi_forall
                        bi_exist bi_sep bi_wand bi_persistently;
  bi_bi_later_mixin : BiLaterMixin bi_entails bi_pure bi_or bi_impl
                                   bi_forall bi_exist bi_sep bi_persistently bi_later;
}.

Coercion bi_ofeO (PROP : bi) : ofe := Ofe PROP (bi_ofe_mixin PROP).
Canonical Structure bi_ofeO.
Global Instance bi_cofe' (PROP : bi) : Cofe PROP.
Proof. apply bi_cofe. Qed.

Global Instance: Params (@bi_entails) 1 := {}.
Global Instance: Params (@bi_emp) 1 := {}.
Global Instance: Params (@bi_pure) 1 := {}.
Global Instance: Params (@bi_and) 1 := {}.
Global Instance: Params (@bi_or) 1 := {}.
Global Instance: Params (@bi_impl) 1 := {}.
Global Instance: Params (@bi_forall) 2 := {}.
Global Instance: Params (@bi_exist) 2 := {}.
Global Instance: Params (@bi_sep) 1 := {}.
Global Instance: Params (@bi_wand) 1 := {}.
Global Instance: Params (@bi_persistently) 1 := {}.
Global Instance: Params (@bi_later) 1  := {}.

Global Arguments bi_car : simpl never.
Global Arguments bi_dist : simpl never.
Global Arguments bi_equiv : simpl never.
Global Arguments bi_entails {PROP} _%I _%I : simpl never, rename.
Global Arguments bi_emp {PROP} : simpl never, rename.
Global Arguments bi_pure {PROP} _%stdpp : simpl never, rename.
Global Arguments bi_and {PROP} _%I _%I : simpl never, rename.
Global Arguments bi_or {PROP} _%I _%I : simpl never, rename.
Global Arguments bi_impl {PROP} _%I _%I : simpl never, rename.
Global Arguments bi_forall {PROP _} _%I : simpl never, rename.
Global Arguments bi_exist {PROP _} _%I : simpl never, rename.
Global Arguments bi_sep {PROP} _%I _%I : simpl never, rename.
Global Arguments bi_wand {PROP} _%I _%I : simpl never, rename.
Global Arguments bi_persistently {PROP} _%I : simpl never, rename.
Global Arguments bi_later {PROP} _%I : simpl never, rename.

Global Hint Extern 0 (bi_entails _ _) => reflexivity : core.
Global Instance bi_rewrite_relation (PROP : bi) : RewriteRelation (@bi_entails PROP) := {}.
Global Instance bi_inhabited {PROP : bi} : Inhabited PROP := populate (bi_pure True).

Notation "P ⊢ Q" := (bi_entails P%I Q%I) : stdpp_scope.
Notation "P '⊢@{' PROP } Q" := (bi_entails (PROP:=PROP) P%I Q%I) (only parsing) : stdpp_scope.
Notation "(⊢)" := bi_entails (only parsing) : stdpp_scope.
Notation "'(⊢@{' PROP } )" := (bi_entails (PROP:=PROP)) (only parsing) : stdpp_scope.

Notation "P ⊣⊢ Q" := (equiv (A:=bi_car _) P%I Q%I) : stdpp_scope.
Notation "P '⊣⊢@{' PROP } Q" := (equiv (A:=bi_car PROP) P%I Q%I) (only parsing) : stdpp_scope.
Notation "(⊣⊢)" := (equiv (A:=bi_car _)) (only parsing) : stdpp_scope.
Notation "'(⊣⊢@{' PROP } )" := (equiv (A:=bi_car PROP)) (only parsing) : stdpp_scope.
Notation "( P ⊣⊢.)" := (equiv (A:=bi_car _) P) (only parsing) : stdpp_scope.
Notation "(.⊣⊢ Q )" := (λ P, P ≡@{bi_car _} Q) (only parsing) : stdpp_scope.

Notation "P -∗ Q" := (P ⊢ Q) : stdpp_scope.

Notation "'emp'" := (bi_emp) : bi_scope.
Notation "'⌜' φ '⌝'" := (bi_pure φ%type%stdpp) : bi_scope.
Notation "'True'" := (bi_pure True) : bi_scope.
Notation "'False'" := (bi_pure False) : bi_scope.
Infix "∧" := bi_and : bi_scope.
Notation "(∧)" := bi_and (only parsing) : bi_scope.
Infix "∨" := bi_or : bi_scope.
Notation "(∨)" := bi_or (only parsing) : bi_scope.
Infix "→" := bi_impl : bi_scope.
Notation "¬ P" := (P → False)%I : bi_scope.
Infix "∗" := bi_sep : bi_scope.
Notation "(∗)" := bi_sep (only parsing) : bi_scope.
Notation "P -∗ Q" := (bi_wand P Q) : bi_scope.
Notation "∀ x .. y , P" :=
  (bi_forall (λ x, .. (bi_forall (λ y, P)) ..)%I) : bi_scope.
Notation "∃ x .. y , P" :=
  (bi_exist (λ x, .. (bi_exist (λ y, P)) ..)%I) : bi_scope.
Notation "'<pers>' P" := (bi_persistently P) : bi_scope.

Notation "▷ P" := (bi_later P) : bi_scope.

Definition bi_emp_valid {PROP : bi} (P : PROP) : Prop := emp ⊢ P.

Global Arguments bi_emp_valid {_} _%I : simpl never.
Typeclasses Opaque bi_emp_valid.

Notation "⊢ Q" := (bi_emp_valid Q%I) : stdpp_scope.
Notation "'⊢@{' PROP } Q" := (bi_emp_valid (PROP:=PROP) Q%I) (only parsing) : stdpp_scope.
(** Work around parsing issues: see [notation.v] for details. *)
Notation "'(⊢@{' PROP } Q )" := (bi_emp_valid (PROP:=PROP) Q%I) (only parsing) : stdpp_scope.
Notation "(.⊢ Q )" := (λ P, P ⊢ Q) (only parsing) : stdpp_scope.
Notation "( P ⊢.)" := (bi_entails P) (only parsing) : stdpp_scope.

Module bi.
Section bi_laws.
Context {PROP : bi}.
Implicit Types φ : Prop.
Implicit Types P Q R : PROP.
Implicit Types A : Type.

(* About the entailment *)
Global Instance entails_po : PreOrder (@bi_entails PROP).
Proof. eapply bi_mixin_entails_po, bi_bi_mixin. Qed.
Lemma equiv_entails P Q : P ≡ Q ↔ (P ⊢ Q) ∧ (Q ⊢ P).
Proof. eapply bi_mixin_equiv_entails, bi_bi_mixin. Qed.

(* Non-expansiveness *)
Global Instance pure_ne n : Proper (iff ==> dist n) (@bi_pure PROP).
Proof. eapply bi_mixin_pure_ne, bi_bi_mixin. Qed.
Global Instance and_ne : NonExpansive2 (@bi_and PROP).
Proof. eapply bi_mixin_and_ne, bi_bi_mixin. Qed.
Global Instance or_ne : NonExpansive2 (@bi_or PROP).
Proof. eapply bi_mixin_or_ne, bi_bi_mixin. Qed.
Global Instance impl_ne : NonExpansive2 (@bi_impl PROP).
Proof. eapply bi_mixin_impl_ne, bi_bi_mixin. Qed.
Global Instance forall_ne A n :
  Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_forall PROP A).
Proof. eapply bi_mixin_forall_ne, bi_bi_mixin. Qed.
Global Instance exist_ne A n :
  Proper (pointwise_relation _ (dist n) ==> dist n) (@bi_exist PROP A).
Proof. eapply bi_mixin_exist_ne, bi_bi_mixin. Qed.
Global Instance sep_ne : NonExpansive2 (@bi_sep PROP).
Proof. eapply bi_mixin_sep_ne, bi_bi_mixin. Qed.
Global Instance wand_ne : NonExpansive2 (@bi_wand PROP).
Proof. eapply bi_mixin_wand_ne, bi_bi_mixin. Qed.
Global Instance persistently_ne : NonExpansive (@bi_persistently PROP).
Proof. eapply bi_mixin_persistently_ne, bi_bi_mixin. Qed.

(* Higher-order logic *)
Lemma pure_intro (φ : Prop) P : φ → P ⊢ ⌜ φ ⌝.
Proof. eapply bi_mixin_pure_intro, bi_bi_mixin. Qed.
Lemma pure_elim' (φ : Prop) P : (φ → True ⊢ P) → ⌜ φ ⌝ ⊢ P.
Proof. eapply bi_mixin_pure_elim', bi_bi_mixin. Qed.

Lemma and_elim_l P Q : P ∧ Q ⊢ P.
Proof. eapply bi_mixin_and_elim_l, bi_bi_mixin. Qed.
Lemma and_elim_r P Q : P ∧ Q ⊢ Q.
Proof. eapply bi_mixin_and_elim_r, bi_bi_mixin. Qed.
Lemma and_intro P Q R : (P ⊢ Q) → (P ⊢ R) → P ⊢ Q ∧ R.
Proof. eapply bi_mixin_and_intro, bi_bi_mixin. Qed.

Lemma or_intro_l P Q : P ⊢ P ∨ Q.
Proof. eapply bi_mixin_or_intro_l, bi_bi_mixin. Qed.
Lemma or_intro_r P Q : Q ⊢ P ∨ Q.
Proof. eapply bi_mixin_or_intro_r, bi_bi_mixin. Qed.
Lemma or_elim P Q R : (P ⊢ R) → (Q ⊢ R) → P ∨ Q ⊢ R.
Proof. eapply bi_mixin_or_elim, bi_bi_mixin. Qed.

Lemma impl_intro_r P Q R : (P ∧ Q ⊢ R) → P ⊢ Q → R.
Proof. eapply bi_mixin_impl_intro_r, bi_bi_mixin. Qed.
Lemma impl_elim_l' P Q R : (P ⊢ Q → R) → P ∧ Q ⊢ R.
Proof. eapply bi_mixin_impl_elim_l', bi_bi_mixin. Qed.

Lemma forall_intro {A} P (Ψ : A → PROP) : (∀ a, P ⊢ Ψ a) → P ⊢ ∀ a, Ψ a.
Proof. eapply bi_mixin_forall_intro, bi_bi_mixin. Qed.
Lemma forall_elim {A} {Ψ : A → PROP} a : (∀ a, Ψ a) ⊢ Ψ a.
Proof. eapply (bi_mixin_forall_elim bi_entails), bi_bi_mixin. Qed.

Lemma exist_intro {A} {Ψ : A → PROP} a : Ψ a ⊢ ∃ a, Ψ a.
Proof. eapply bi_mixin_exist_intro, bi_bi_mixin. Qed.
Lemma exist_elim {A} (Φ : A → PROP) Q : (∀ a, Φ a ⊢ Q) → (∃ a, Φ a) ⊢ Q.
Proof. eapply bi_mixin_exist_elim, bi_bi_mixin. Qed.

(* BI connectives *)
Lemma sep_mono P P' Q Q' : (P ⊢ Q) → (P' ⊢ Q') → P ∗ P' ⊢ Q ∗ Q'.
Proof. eapply bi_mixin_sep_mono, bi_bi_mixin. Qed.
Lemma emp_sep_1 P : P ⊢ emp ∗ P.
Proof. eapply bi_mixin_emp_sep_1, bi_bi_mixin. Qed.
Lemma emp_sep_2 P : emp ∗ P ⊢ P.
Proof. eapply bi_mixin_emp_sep_2, bi_bi_mixin. Qed.
Lemma sep_comm' P Q : P ∗ Q ⊢ Q ∗ P.
Proof. eapply (bi_mixin_sep_comm' bi_entails), bi_bi_mixin. Qed.
Lemma sep_assoc' P Q R : (P ∗ Q) ∗ R ⊢ P ∗ (Q ∗ R).
Proof. eapply bi_mixin_sep_assoc', bi_bi_mixin. Qed.
Lemma wand_intro_r P Q R : (P ∗ Q ⊢ R) → P ⊢ Q -∗ R.
Proof. eapply bi_mixin_wand_intro_r, bi_bi_mixin. Qed.
Lemma wand_elim_l' P Q R : (P ⊢ Q -∗ R) → P ∗ Q ⊢ R.
Proof. eapply bi_mixin_wand_elim_l', bi_bi_mixin. Qed.

(* Persistently *)
Lemma persistently_mono P Q : (P ⊢ Q) → <pers> P ⊢ <pers> Q.
Proof. eapply bi_mixin_persistently_mono, bi_bi_mixin. Qed.
Lemma persistently_idemp_2 P : <pers> P ⊢ <pers> <pers> P.
Proof. eapply bi_mixin_persistently_idemp_2, bi_bi_mixin. Qed.

Lemma persistently_emp_2 : emp ⊢@{PROP} <pers> emp.
Proof. eapply bi_mixin_persistently_emp_2, bi_bi_mixin. Qed.

Lemma persistently_forall_2 {A} (Ψ : A → PROP) :
  (∀ a, <pers> (Ψ a)) ⊢ <pers> (∀ a, Ψ a).
Proof. eapply bi_mixin_persistently_forall_2, bi_bi_mixin. Qed.
Lemma persistently_exist_1 {A} (Ψ : A → PROP) :
  <pers> (∃ a, Ψ a) ⊢ ∃ a, <pers> (Ψ a).
Proof. eapply bi_mixin_persistently_exist_1, bi_bi_mixin. Qed.

Lemma persistently_absorbing P Q : <pers> P ∗ Q ⊢ <pers> P.
Proof. eapply (bi_mixin_persistently_absorbing bi_entails), bi_bi_mixin. Qed.
Lemma persistently_and_sep_elim P Q : <pers> P ∧ Q ⊢ P ∗ Q.
Proof. eapply (bi_mixin_persistently_and_sep_elim bi_entails), bi_bi_mixin. Qed.

(* Later *)
Global Instance later_ne : NonExpansive (@bi_later PROP).
Proof. eapply bi_mixin_later_ne, bi_bi_later_mixin. Qed.

Lemma later_mono P Q : (P ⊢ Q) → ▷ P ⊢ ▷ Q.
Proof. eapply bi_mixin_later_mono, bi_bi_later_mixin. Qed.
Lemma later_intro P : P ⊢ ▷ P.
Proof. eapply bi_mixin_later_intro, bi_bi_later_mixin. Qed.

Lemma later_forall_2 {A} (Φ : A → PROP) : (∀ a, ▷ Φ a) ⊢ ▷ ∀ a, Φ a.
Proof. eapply bi_mixin_later_forall_2, bi_bi_later_mixin. Qed.
Lemma later_exist_false {A} (Φ : A → PROP) :
  (▷ ∃ a, Φ a) ⊢ ▷ False ∨ (∃ a, ▷ Φ a).
Proof. eapply bi_mixin_later_exist_false, bi_bi_later_mixin. Qed.
Lemma later_sep_1 P Q : ▷ (P ∗ Q) ⊢ ▷ P ∗ ▷ Q.
Proof. eapply bi_mixin_later_sep_1, bi_bi_later_mixin. Qed.
Lemma later_sep_2 P Q : ▷ P ∗ ▷ Q ⊢ ▷ (P ∗ Q).
Proof. eapply bi_mixin_later_sep_2, bi_bi_later_mixin. Qed.
Lemma later_persistently_1 P : ▷ <pers> P ⊢ <pers> ▷ P.
Proof. eapply (bi_mixin_later_persistently_1 bi_entails), bi_bi_later_mixin. Qed.
Lemma later_persistently_2 P : <pers> ▷ P ⊢ ▷ <pers> P.
Proof. eapply (bi_mixin_later_persistently_2 bi_entails), bi_bi_later_mixin. Qed.

Lemma later_false_em P : ▷ P ⊢ ▷ False ∨ (▷ False → P).
Proof. eapply bi_mixin_later_false_em, bi_bi_later_mixin. Qed.
End bi_laws.
End bi.


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

(**********************************************************************)
(*                   Substitution.v                                   *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(* adapted from Substitution.v of Project Coq  to act on SF-terms     *)
(**********************************************************************)

Require Import Arith Omega List.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Wave_as_SF.SF_Terms.
Require Import IntensionalLib.Wave_as_SF.SF_Tactics.
Require Import IntensionalLib.Wave_as_SF.SF_reduction.
Require Import IntensionalLib.Wave_as_SF.SF_Normal.
Require Import IntensionalLib.Wave_as_SF.SF_Closed.

(* Lifting *)

Definition relocate (i k n : nat) :=
  match test k i with
   (* k<=i *) | left _ => n+i
   (* k>i  *) | _ => i
  end.

Lemma relocate_null :
forall (n n0 : nat), relocate n n0 0 = n.
Proof. split_all. unfold relocate. case (test n0 n); intro; auto with arith. Qed.

Lemma relocate_lessthan : forall m n k, m<=k -> relocate k m n = (n+k).
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.
Lemma relocate_greaterthan : forall m n k, m>k -> relocate k m n = k.
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.

Ltac relocate_lt :=
try (rewrite relocate_lessthan; [| omega]; relocate_lt);
try (rewrite relocate_greaterthan; [| omega]; relocate_lt);
try(rewrite relocate_null).

Lemma relocate_zero_succ :
forall n k, relocate 0 (S n) k = 0.
Proof.  split_all. Qed.

Lemma relocate_succ :
forall n n0 k, relocate (S n) (S n0) k = S(relocate n n0 k).
Proof.
intros; unfold relocate. elim(test(S n0) (S n)); elim(test n0 n); split_all.
noway.
noway.
Qed.

Lemma relocate_mono : forall M N n k, relocate M n k = relocate N n k -> M=N.
Proof.
intros M N n k.
unfold relocate.
elim(test n M); elim(test n N); split_all; omega.
Qed.

Lemma relocate_null2 :
forall n k, relocate 0 (S n) k = 0.
Proof. split_all. Qed.

Fixpoint lift_rec (L : SF) : nat -> nat -> SF :=
  fun k n =>
  match L with
  | Ref i => Ref (relocate i k n)
  | Op o => Op o
  | App M N => App (lift_rec M k n) (lift_rec N k n)
   end.

Definition lift (n : nat) (N : SF) := lift_rec N 0 n.

(* Lifting lemmas *)

Lemma lift_rec_null_term :
forall (U : SF)(n: nat), lift_rec U n 0 = U.
Proof.
simple induction U; split_all.
relocate_lt; auto.
rewrite H; auto. rewrite H0; auto.
Qed.

Lemma lift1 :
 forall (U : SF) (j i k : nat),
 lift_rec (lift_rec U i j) (j + i) k = lift_rec U i (j + k).
Proof.
simple induction U; simpl in |- *;  split_all.
unfold relocate.
elim (test i n); elim (test (j+i) (j+ n)); split_all; try noway.
assert(k + (j + n) = j + k + n) by omega. congruence.
elim (test (j + i) n); split_all; try noway. rewrite H; auto. rewrite H0; auto.
Qed.

Lemma lift_lift_rec :
 forall (U : SF) (k p n i : nat),
 i <= n ->
 lift_rec (lift_rec U i p) (p + n) k = lift_rec (lift_rec U n k) i p.
Proof.
simple induction U; simpl in |- *;  split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i (k+n)); split_all; try noway.
assert(k+(p+n) = p+ (k+n)) by omega.
rewrite H0; auto.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) n); split_all; try noway.
elim(test i n); split_all; try noway.
(* Ap *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma lift_lift_term :
 forall (U : SF) (k p n : nat),
 lift_rec (lift p U) (p+ n) k = lift p (lift_rec U n k).
Proof.
unfold lift in |- *; intros; apply lift_lift_rec; trivial with arith.
Qed.

Lemma liftrecO : forall (U : SF) (n : nat), lift_rec U n 0 = U.
Proof.
simple induction U; simpl in |- *; intros; split_all; relocate_lt; congruence.
Qed.

Lemma liftO : forall (U : SF) , lift 0 U = U.
Proof.
unfold lift in |- *; split_all; apply liftrecO.
Qed.

Lemma lift_rec_lift_rec :
 forall (U : SF) (n p k i : nat),
 k <= i + n ->
 i <= k -> lift_rec (lift_rec U i n) k p = lift_rec U i (p + n).

Proof.
simple induction U; split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test k (n0 + n)); split_all; try noway.
replace (p+(n0+n)) with (p + n0 + n) by omega. auto.
elim(test k n); split_all; try noway.
(* Ap *)
rewrite H; split_all; rewrite H0; split_all; split_all.
Qed.

Lemma lift_rec_lift :
 forall (U : SF)  (n p k i : nat),
 k <= n -> lift_rec (lift  n U)  k p = lift (p + n) U.
Proof.
unfold lift in |- *; intros; rewrite lift_rec_lift_rec; trivial with arith.
Qed.

Lemma lift_rec_lift2 :
forall M n k, lift_rec (lift 1 M) (S n) k = lift 1 (lift_rec M n k).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite lift_lift_rec; auto.
omega.
Qed.

Lemma lift_rec_app: forall M N n k, lift_rec (App M N) n k = App (lift_rec M n k) (lift_rec N n k).
Proof. split_all. Qed.
Lemma lift_rec_op: forall o n k, lift_rec (Op o) n k = Op o.
Proof. split_all. Qed.
Lemma lift_rec_ref: forall i n k, lift_rec (Ref i) n k = Ref (relocate i n k).
Proof. split_all. Qed.

Lemma lift_rec_not_ref_0 : forall M, lift_rec M 0 1 <> Ref 0.
Proof. induction M; split_all; try discriminate. case n; split_all; discriminate. Qed.

Lemma lift_rec_null :
forall (U : SF) (n: nat), lift_rec U n 0 = U.
Proof. simple induction U; split_all.
 rewrite relocate_null; congruence.
rewrite H; auto. rewrite H0; auto.
Qed.

Ltac  lift_tac :=
unfold_op; rewrite ? lift_rec_app; rewrite ? lift_rec_op; rewrite ? lift_rec_ref; relocate_lt;
rewrite ? lift_rec_not_ref_0.

Lemma lift_rec_preserves_compound :
forall (M: SF), compound M -> forall (n k : nat), compound(lift_rec M n k).
Proof.
intros M c; induction c; split_all.
Qed.
Hint Resolve lift_rec_preserves_compound.

Lemma lift_rec_preserves_status:
forall M n k, status (lift_rec M n k) = status M.
Proof.
match goal with
  | |- forall M, ?P  =>   cut (forall p M, p >= rank M -> P );
      [intros H M;  eapply2 H |
       intro p; induction p; intro M;  [ assert(rank M >0) by eapply2 rank_positive; noway |]
      ]
  end.

induction M; split_all.
rewrite IHM1. (* pepm 2: omega.  *)
gen_case H M1. gen_case H s. gen_case H s1. gen_case H o. eapply2 IHp; omega. omega.
Qed.

Lemma lift_rec_preserves_normal: forall M n k, normal M -> normal (lift_rec M n k).
Proof. induction M; intros. split_all. split_all.
inversion H. apply nf_active; fold lift_rec; auto.
replace  (App (lift_rec M1 n k) (lift_rec M2 n k))
with (lift_rec (App M1 M2) n k) by auto.
rewrite lift_rec_preserves_status. auto.
simpl. eapply2 nf_compound.
replace  (App (lift_rec M1 n k) (lift_rec M2 n k))
with (lift_rec (App M1 M2) n k) by auto.
eapply2 lift_rec_preserves_compound.
Qed.

Lemma lift_rec_closed: forall M n k, maxvar M = 0 -> lift_rec M n k = M.
Proof. induction M; split_all. omega. max_out. rewrite IHM1; auto;  rewrite IHM2; auto. Qed.

Lemma map_lift0 : forall Ms, map (lift 0) Ms = Ms.
Proof. induction Ms; split_all.   rewrite IHMs. unfold lift; rewrite lift_rec_null. auto. Qed.

Lemma lift_preserves_maxvar2:
  forall M, forall k, maxvar (lift k M) - k = maxvar M.
Proof.
  induction M; split_all. relocate_lt. induction k; split_all.
  rewrite max_minus. unfold lift in *; rewrite IHM1; rewrite IHM2; auto.
Qed.

Lemma lift_rec_reflects_compound : forall M n k, compound (lift_rec M n k) -> compound M.
Proof.
induction M; split_all; inversion H; subst; split_all.
gen_case H1 M1; try discriminate.  invsub.
case o; auto.
gen_case H1 M1; try discriminate. inversion H1.
gen_case H2 s; try discriminate. case o; auto.
Qed.

Lemma lift_rec_reflects_normal : forall M n k, normal (lift_rec M n k) -> normal M.
Proof.
induction M; split_all. inversion H; split_all.
replace (App (lift_rec M1 n k) (lift_rec M2 n k)) with (lift_rec (App M1 M2) n k) in H4 by auto.
rewrite lift_rec_preserves_status in *. eapply2 nf_active.
replace (App (lift_rec M1 n k) (lift_rec M2 n k)) with (lift_rec (App M1 M2) n k) in H4 by auto.
eapply2 nf_compound. eapply2 lift_rec_reflects_compound.
Qed.

(* Substitution *)

Definition insert_Ref (N : SF) (i k : nat) :=
  match compare k i with

   (* k<i *) | inleft (left _) => Ref (pred i)
   (* k=i *) | inleft _ => lift k N
   (* k>i *) | _ => Ref i
  end.

Fixpoint subst_rec (L : SF) : SF -> nat -> SF :=
  fun (N : SF) (k : nat) =>
  match L with
  | Ref i => insert_Ref N i k
  | Op o => Op o
  | App M M' => App (subst_rec M N k) (subst_rec M' N k)
  end.

Lemma subst_rec_op:
forall o N k, subst_rec (Op o) N k = Op o.
Proof.  split_all. Qed.

Lemma subst_rec_app:
forall M1 M2 N k, subst_rec (App M1 M2) N k = App (subst_rec M1 N k) (subst_rec M2 N k).
Proof.  split_all. Qed.

Lemma subst_rec_ref: forall i N k,  subst_rec (Ref i) N k = insert_Ref N i k.
Proof.  split_all. Qed.

Definition subst (M N : SF) := subst_rec M N 0.

(* The three cases of substitution of U for (Ref n) *)

Lemma subst_eq :
 forall (M U : SF) (n : nat), subst_rec (Ref n) U n = lift n U.
Proof.
simpl in |- *; unfold insert_Ref in |- *; split_all.
elim (compare n n); intro P; try noway.
elim P; intro Q; simpl in |- *; trivial with arith; try noway.
Qed.

Lemma subst_gt :
 forall (M U : SF) (n p : nat),
 n > p -> subst_rec (Ref n) U p = Ref (pred n).
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P.
elim P; intro Q; trivial with arith.
absurd (n > p); trivial with arith; rewrite Q; trivial with arith.
absurd (n > p); auto with arith.
Qed.

Lemma subst_lt :
 forall (M U : SF) (n p : nat), p > n -> subst_rec (Ref n) U p = Ref n.
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P; trivial with arith.
absurd (p > n); trivial with arith; elim P; intro Q; auto with arith.
rewrite Q; trivial with arith.
Qed.

(* Substitution lemma *)

Lemma lift_rec_subst_rec :
 forall (V U : SF) (k p n : nat),
 lift_rec (subst_rec V U p) (p + n) k =
 subst_rec (lift_rec V (S (p + n)) k) (lift_rec U n k) p.
Proof.
simple induction V; split_all.
(* 1 Ref *)
unfold insert_Ref, relocate in |- *.
elim (test (S(p + n0)) n); elim (compare p n); split_all.
elim a; elim(compare p (k+n)); split_all.
unfold relocate.
elim(test (p+n0) (pred n)); elim a1; split_all; try noway.
replace (k + pred n) with (pred (k + n)) by omega; auto.
noway.
noway.
noway.
noway.
elim a; split_all.
unfold relocate. elim(test(p+n0) (pred n)); split_all.
noway.
unfold lift.
rewrite lift_lift_rec; auto; omega.
unfold relocate.
elim(test (p+n0) n); split_all.
noway.
rewrite H; auto; rewrite H0; auto.
Qed.

Lemma lift_subst :
 forall (U V : SF) (k n : nat),
 lift_rec (subst U V) n k =
 subst (lift_rec U (S n) k) (lift_rec V n k).
Proof.
unfold subst in |- *; intros.
replace n with (0 + n).
rewrite lift_rec_subst_rec; trivial with arith.
auto.
Qed.

Lemma subst_rec_lift_rec1 :
 forall (U V : SF) (n p k : nat),
 k <= n ->
 subst_rec (lift_rec U k p) V (p + n) =
 lift_rec (subst_rec U V n) k p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
(* Ref *)
unfold insert_Ref, relocate.
elim(test k n); split_all.
elim(compare n0 n); split_all; try noway.
elim a0; split_all; try noway.
elim(compare (p+n0) (p+n)); split_all.
elim a2; split_all; try noway.
unfold relocate.
elim(test k (pred n)); split_all; try noway.
assert(pred (p+n) = p + pred n) by omega. auto.
noway.
elim(compare (p+n0) (p+n)); split_all.
elim a1; split_all; try noway.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
elim(compare (p+n0) (p+n)); split_all.
elim a0; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare n0 n); split_all; try noway.
elim a; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
(* 1 *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma subst_rec_lift1 :
 forall (U V : SF) (n p : nat),
 subst_rec (lift p U) V (p + n) = lift p (subst_rec U V n).
Proof.
unfold lift in |- *; intros; rewrite subst_rec_lift_rec1;
 trivial with arith.
Qed.

Lemma subst_rec_lift_rec :
 forall (U V : SF) (p q n : nat),
 q <= p + n ->
 n <= q -> subst_rec (lift_rec U n (S p)) V q = lift_rec U n p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
unfold relocate. elim(test n0 n); split_all.
unfold insert_Ref.
elim(compare q (S(p+n))); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare q n); split_all; try noway.
elim a; split_all; try noway.

(* 1 *)
rewrite H; split_all.
rewrite H0; auto.
Qed.

(* subst_rec_subst_rec *)

Lemma subst_rec_subst_rec :
 forall (V U W : SF) (n p : nat),
 subst_rec (subst_rec V U p) W (p + n) =
 subst_rec (subst_rec V W (S (p + n))) (subst_rec U W n) p.
Proof.
simple induction V;  split_all.

unfold insert_Ref in |- *.
elim (compare p n); split_all.
elim a; split_all.
elim (compare (S (p + n0)) n); split_all.
elim a1; split_all; try noway.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a3; split_all; try noway.
elim (compare p (pred n)); split_all; try noway.
elim a5; split_all; try noway.
unfold lift; split_all.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a2; split_all; try noway.
subst. unfold lift.
rewrite subst_rec_lift_rec; split_all; try omega.
unfold insert_Ref.
elim(compare (p+n0) (pred n)); split_all; try noway.
elim a1; split_all; try noway.
elim(compare p n); split_all; try noway.
elim a1; split_all; try noway.
elim (compare (S (p + n0)) n); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a0; split_all; try noway.
unfold lift.
subst.
rewrite subst_rec_lift_rec1; split_all.  omega.

unfold insert_Ref.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare (S(p+n0)) n); split_all; try noway.
elim a; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a; split_all; try noway.
rewrite H; auto. rewrite H0; auto.
Qed.

Lemma subst_rec_subst_0 :
 forall (U V W : SF) (n : nat),
 subst_rec (subst_rec V U 0) W n =
 subst_rec (subst_rec V W (S n)) (subst_rec U W n) 0.
Proof.
intros; pattern n at 1 3 in |- *.
replace n with (0 + n) by trivial with arith.
rewrite (subst_rec_subst_rec V U W n 0); trivial with arith.
Qed.

(**************************)
(* The Substitution Lemma *)
(**************************)

Lemma substitution :
 forall (U V W : SF) (n : nat),
 subst_rec (subst U V) W n =
 subst (subst_rec U W (S n)) (subst_rec V W n).
Proof.
unfold subst in |- *; intros; apply subst_rec_subst_0; trivial with arith.
Qed.

(* to show (\ t)0 -> t  *)

Lemma subst_lift_null :
forall (W V : SF)(n : nat), subst_rec (lift_rec W n 1) V n = W.
Proof.
simple induction W; split_all.
unfold insert_Ref.
unfold relocate.
elim(test n0 n); split_all.
elim(compare n0 (S n)); split_all.
elim a0; split_all; noway.
noway.
elim(compare n0 n); split_all.
elim a; split_all. noway.
noway.
rewrite H; auto; rewrite H0; auto.
Qed.

(* more  Properties *)

Lemma subst_rec_lift2 :
forall M N n , subst_rec (lift 1 M) N (S n)  = lift 1 (subst_rec M N n).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite subst_rec_lift_rec1; auto.
omega.
Qed.

Lemma insert_Ref_lt : forall M n k, n< k -> insert_Ref M n k = Ref n.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
Qed.

Lemma insert_Ref_eq : forall M n k, n= k -> insert_Ref M n k = lift k M.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Lemma insert_Ref_gt : forall M n k, n> k -> insert_Ref M n k = Ref (pred n).
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Ltac insert_Ref_out :=
try (rewrite insert_Ref_lt; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_eq; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_gt; [|unfold relocate; split_all; omega]; insert_Ref_out).

Lemma fold_subst :  forall M1 M2 N, App (subst_rec M1 N 0) M2 = subst (App M1 (lift 1 M2)) N.
Proof.
  unfold subst, lift, subst_rec; split_all; fold subst_rec.
  rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null; auto.
Qed.

Ltac  subst_tac :=
unfold_op; unfold subst;
rewrite ? subst_rec_app; rewrite ? subst_rec_op; rewrite ? subst_rec_ref;
rewrite ? subst_rec_lift_rec; try omega; rewrite ? lift_rec_null;
unfold subst_rec; fold subst_rec; insert_Ref_out; unfold pred.

Definition subst_preserves_l (red: termred) :=
forall (M M' N : SF), red M M' -> red  (subst M N) (subst M' N).

Definition subst_preserves_r (red: termred) :=
forall (M N N' : SF), red N N' -> red  (subst M N) (subst M N').

Definition subst_preserves (red: termred) :=
forall (M M' : SF), red M M' -> forall N N', red N N' ->
red  (subst M N) (subst M' N').

Lemma subst_preserves_l_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_l (multi_step red).
Proof. unfold subst_preserves_l.
 induction 2; split_all.
apply succ_red with (subst N0 N); auto.
Qed.

Lemma subst_preserves_r_multi_step :
forall (red: termred), subst_preserves_r red -> subst_preserves_r (multi_step red).
Proof. unfold subst_preserves_r.
 induction 2; split_all.
apply succ_red with (subst M N); auto.
Qed.

Lemma subst_preserves_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_r red -> subst_preserves (multi_step red).
Proof.
unfold subst_preserves. split_all.
assert(transitive (multi_step red)) by eapply2 transitive_red.
unfold transitive in *.
apply X with  (subst M' N); auto.
eapply2 subst_preserves_l_multi_step.
eapply2 subst_preserves_r_multi_step.
Qed.

Lemma subst_preserves_compound:
forall (M: SF), compound M -> forall N, compound(subst M N).
Proof. intros M c; induction c; unfold subst; split_all. Qed.
Hint Resolve subst_preserves_compound.

Lemma  subst_rec_preserves_components_l : forall (M : SF) n k, compound M ->
  subst_rec(left_component M) n k = left_component(subst_rec M n k).
Proof. induction M; split_all; inv1 compound. Qed.

Lemma  subst_rec_preserves_components_r :
forall (M : SF),  compound M -> forall n k,
subst_rec(right_component M) n k = right_component(subst_rec M n k).
Proof. induction M; split_all; inversion H; subst; split_all. Qed.
Lemma subst_rec_preserves_compounds:
forall M N k, compound M -> compound (subst_rec M N k).
Proof. intros; inv1 compound. Qed.

Lemma subst_rec_preserves_left_component:
forall M N k, compound M ->
              subst_rec (left_component M) N k = left_component (subst_rec M N k) .
Proof. intros; inv1 compound. Qed.

Lemma subst_rec_preserves_right_component:
forall M N k, compound M ->
              subst_rec (right_component M) N k = right_component (subst_rec M N k) .
Proof. intros; inv1 compound. Qed.

Lemma subst_preserves_sf_red1 : subst_preserves sf_red1.
Proof.
red.
intros M M' R; induction R; unfold subst; split_all.
(* 5 *)
unfold insert_Ref. elim(compare 0 i); split_all. elim a; split_all.
unfold lift. repeat rewrite lift_rec_null_term; auto.
(* 4 *)
eapply2 app_sf_red.
(* 3 *)
eapply2 s_red.
(* 2 *)
eapply2 k_red.
(* 1 *)
eapply2 f_red.
Qed.

Lemma subst_preserves_sf_red : subst_preserves sf_red.
Proof. eapply2 subst_preserves_multi_step. red; split_all.
eapply2 subst_preserves_sf_red1. red; split_all.
eapply2 subst_preserves_sf_red1.
Qed.

Lemma subst_rec_closed: forall M N k, maxvar M <= k -> subst_rec M N k = M.
Proof.
induction M; split_all.
unfold insert_Ref. elim(compare k n); split_all. elim a; split_all. noway. noway.
assert (max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert (max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega;  rewrite IHM2; try omega. auto.
Qed.

Lemma subst_decreases_maxvar :
forall M N,  max (pred (maxvar M)) (maxvar N) >= maxvar(subst M N).
Proof.
unfold subst; induction M; split_all.
unfold insert_Ref.
case n; split_all. unfold lift. rewrite lift_rec_null_term. auto.
case (maxvar N); split_all.
assert(max n0 n1  >= n0) by eapply2 max_is_max.
omega.
omega.
(* 1 *)
rewrite max_pred.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max (pred (maxvar M1)) (maxvar N)).
eapply2 max_monotonic. eapply2 max_is_max.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max (pred (maxvar M2)) (maxvar N)).
eapply2 max_monotonic. eapply2 max_is_max.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max(max (pred (maxvar M1)) (maxvar N)) (max (pred (maxvar M2)) (maxvar N))).
eapply2 max_max2.
assert(max (max (pred (maxvar M1)) (maxvar N))
         (max (pred (maxvar M2)) (maxvar N))>=
max (maxvar (subst_rec M1 N 0)) (maxvar (subst_rec M2 N 0))).
eapply2 max_monotonic.
omega.
Qed.

Lemma subst_closed : forall M, maxvar M = 0 -> forall N, subst M N = M.
Proof.
induction M; split_all; subst. omega.
max_out. unfold subst in *; simpl. rewrite IHM1; try omega; rewrite IHM2; try omega; split_all.
Qed.

Ltac closed_tac M := repeat (rewrite (subst_rec_closed M); [| auto]);
                     repeat (rewrite (lift_rec_closed M); [| auto]).

Lemma fold_subst_list:
  forall sigma M N,  App (fold_left subst sigma M) N =
                     fold_left subst sigma (App M (lift (length sigma) N)).
Proof.
  induction sigma; split_all.
  (* 2 *)
  unfold lift; rewrite lift_rec_null. auto.
  (* 1 *)
  rewrite IHsigma. unfold subst. simpl. unfold lift. rewrite subst_rec_lift_rec; try omega. auto.
Qed.

Lemma list_subst_preserves_op:
  forall sigma o, fold_left subst sigma (Op o) = Op o.
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_app:
  forall sigma M N, fold_left subst sigma (App M N) =
                    App (fold_left subst sigma M) (fold_left subst sigma N).
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_sf_red:
  forall sigma M N, sf_red M N -> sf_red (fold_left subst sigma M) (fold_left subst sigma N).
Proof.  induction sigma; split_all. eapply2 IHsigma. eapply2 subst_preserves_sf_red. Qed.

Lemma list_subst_lift: forall sigma M, fold_left subst sigma (lift (length sigma) M) = M.
Proof.
  induction sigma; split_all. unfold lift; rewrite lift_rec_null. auto.
unfold lift, subst. rewrite subst_rec_lift_rec; try omega. unfold lift in *. rewrite IHsigma. auto.
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                                                     *)

(* New variant where the function receives the coordonates *)

Require Import List.
Require Export fifo.
Require Export table.
Require Export reduce.

Unset Standard Proposition Elimination Names.

Section TABLE.

Variable Site : Set.
Hypothesis eq_site_dec : eq_dec Site.
Variable LS : list Site.

Variable Data : Set.
Let Table := Site -> Data.

Variable t : Table.
Variable s0 : Site.
Variable d0 : Data.

Variable f : Site -> Data -> Z.

Definition sigma_table (st : Table) :=
  sigma Site LS (fun s : Site => f s (st s)).

Definition update_table := change_x0 Site Data eq_site_dec t s0 d0.

Definition sigma_but_table (st : Table) :=
  sigma_but Site s0 eq_site_dec LS (fun s : Site => f s (st s)).

End TABLE.

Section SIGMA_TABLE.
Variable Site : Set.
Hypothesis eq_site_dec : eq_dec Site.
Variable LS : list Site.
(* This is generic code for any kind of tables hopefully *)

Variable Data : Set.
Let Table := Site -> Data.

Variable t : Table.
Variable s0 : Site.
Variable d0 : Data.

Variable f : Site -> Data -> Z.

Lemma sigma_table_change :
 only_once Site eq_site_dec s0 LS ->
 sigma_table Site LS Data f (update_table Site eq_site_dec Data t s0 d0) =
 (sigma_table Site LS Data f t - f s0 (t s0) + f s0 d0)%Z.
Proof.
  unfold sigma_table in |- *.
  unfold update_table in |- *.
  elim LS.
  simpl in |- *.
  intuition.

  intros a l H.
  case (eq_site_dec s0 a).
  intro; rewrite e.
  simpl in |- *.
  unfold change_x0 in |- *.
  case (eq_site_dec a a).
  intros e0 H0.
  replace
   (sigma Site l
      (fun s : Site =>
       f s match eq_site_dec a s with
           | left _ => d0
           | right _ => t s
           end)) with (sigma Site l (fun s : Site => f s (t s))).
  omega.

  apply sigma_simpl.
  intros x H1.
  case (eq_site_dec a x).
  intro; rewrite e1 in H0.
  intuition.

  intro; auto.

  intro n.
  elim n.
  auto.

  intro n.
  intro H0.
  simpl in |- *.
  rewrite H.
  unfold change_x0 in |- *.
  rewrite case_ineq.
  omega.

  auto.

  unfold only_once in H0.
  generalize H0.
  case (eq_site_dec s0 a).
  intuition.

  unfold only_once in |- *.
  auto.
Qed.

(* Just an auxiliary one that is more convenient to use *)

Lemma sigma_table_change_aux :
 only_once Site eq_site_dec s0 LS ->
 (sigma_table Site LS Data f (update_table Site eq_site_dec Data t s0 d0) +
  f s0 (t s0) - f s0 d0)%Z = sigma_table Site LS Data f t.
Proof.
  intro H.
  rewrite sigma_table_change.
  omega.
  auto.
Qed.

Variable f1 : Site -> Data -> Z.
Variable f2 : Site -> Data -> Z.

Definition fun_sum_site (f1 f2 : Site -> Data -> Z)
  (s : Site) (a : Data) := (f1 s a + f2 s a)%Z.

Definition fun_minus_site (f1 f2 : Site -> Data -> Z)
  (s : Site) (a : Data) := (f1 s a - f2 s a)%Z.

Lemma sigma_disjoint :
 sigma_table Site LS Data (fun_sum_site f1 f2) t =
 (sigma_table Site LS Data f1 t + sigma_table Site LS Data f2 t)%Z.
Proof.
  unfold sigma_table, fun_sum_site in |- *.
  elim LS.
  simpl in |- *.
  trivial.
  intros a l H.
  simpl in |- *.
  rewrite H.
  omega.
Qed.

Lemma sigma_disjoint2 :
 sigma_table Site LS Data (fun_minus_site f1 f2) t =
 (sigma_table Site LS Data f1 t - sigma_table Site LS Data f2 t)%Z.
Proof.
  unfold sigma_table, fun_minus_site in |- *.
  elim LS.
  simpl in |- *.
  trivial.
  intros a l H.
  simpl in |- *.
  rewrite H.
  omega.
Qed.

Definition Z_id (s : Site) (x : Z) := x.

Lemma Z_id_reduce : forall (s : Site) (x : Z), Z_id s x = x.
Proof.
  intros s x.
  unfold Z_id in |- *.
  auto.
Qed.

Lemma sigma_same_table :
 forall t1 t2 : Site -> Z,
 sigma_table Site LS Z Z_id (fun_sum Site t1 t2) =
 (sigma_table Site LS Z Z_id t1 + sigma_table Site LS Z Z_id t2)%Z.
Proof.
  intros t1 t2.
  unfold sigma_table in |- *.
  elim LS.
  simpl in |- *.
  auto.
  intros a l H.
  simpl in |- *.
  rewrite H.
  unfold fun_sum in |- *.
  rewrite Z_id_reduce.
  rewrite Z_id_reduce.
  rewrite Z_id_reduce.
  omega.
Qed.

Lemma sigma_same_table2 :
 forall t1 t2 : Site -> Z,
 sigma_table Site LS Z Z_id (fun_minus Site t1 t2) =
 (sigma_table Site LS Z Z_id t1 - sigma_table Site LS Z Z_id t2)%Z.
Proof.
  intros t1 t2.
  unfold sigma_table in |- *.
  elim LS.
  simpl in |- *.
  auto.
  intros a l H.
  simpl in |- *.
  rewrite H.
  unfold fun_minus in |- *.
  rewrite Z_id_reduce.
  rewrite Z_id_reduce.
  rewrite Z_id_reduce.
  omega.
Qed.

Lemma sigma_table_simpl :
 forall t1 t2 : Site -> Data,
 t1 = t2 -> sigma_table Site LS Data f t1 = sigma_table Site LS Data f t2.
Proof.
  unfold sigma_table in |- *.
  intros t1 t2 H.
  apply sigma_simpl.
  intros x H0.
  rewrite H; auto.
Qed.

Lemma sigma_table_simpl_property :
 forall (t1 t2 : Site -> Data) (P : (Site -> Data) -> Site -> Set),
 ((forall d : Site, P t2 d) -> t1 = t2) ->
 (forall d : Site, P t2 d) ->
 sigma_table Site LS Data f t1 = sigma_table Site LS Data f t2.
Proof.
  unfold sigma_table in |- *.
  intros t1 t2 P H H0.
  apply sigma_simpl.
  intros x H1.
  generalize (H H0).
  intro H2.
  rewrite H2.
  auto.
Qed.

Lemma sigma_table_simpl2 :
 forall (Data : Set) (t : Site -> Data) (f1 f2 : Site -> Data -> Z),
 (forall (s : Site) (d : Data), f1 s d = f2 s d) ->
 sigma_table Site LS Data f1 t = sigma_table Site LS Data f2 t.
Proof.
  intros Data0 t0 f0 f3 H.
  unfold sigma_table in |- *.
  apply sigma_simpl.
  intros x H0.
  apply H.
Qed.

(* same as before, but we consider the functions f1 and f2 uniquely
   for values contained in the table t! *)

Lemma sigma_table_simpl2_partial :
 forall (Data : Set) (t : Site -> Data) (f1 f2 : Site -> Data -> Z),
 (forall (s : Site) (d : Data), t s = d -> f1 s d = f2 s d) ->
 sigma_table Site LS Data f1 t = sigma_table Site LS Data f2 t.
Proof.
  intros Data0 t0 f0 f3 H.
  unfold sigma_table in |- *.
  apply sigma_simpl.
  intro x.
  intro H0.
  generalize (H x (t0 x)).
  intro H1.
  apply H1.
  auto.
Qed.

Lemma sigma_table_simpl2_property :
 forall (Data : Set) (t : Site -> Data) (P : (Site -> Data) -> Site -> Set)
   (f1 f2 : Site -> Data -> Z),
 (forall (s : Site) (d : Data), P t s -> f1 s d = f2 s d) ->
 (forall s : Site, P t s) ->
 sigma_table Site LS Data f1 t = sigma_table Site LS Data f2 t.
Proof.
  intros Data0 t0 P f0 f3 H H0.
  unfold sigma_table in |- *.
  apply sigma_simpl.
  intros x H1.
  apply H.
  auto.
Qed.

End SIGMA_TABLE.

Section SIGMA_TABLE2.
Variable Site : Set.
Hypothesis eq_site_dec : eq_dec Site.
Variable LS1 : list Site.
Variable LS2 : list Site.

Variable Data : Set.
Let Table2 := Site -> Site -> Data.

Variable t : Table2.
Variable s0 s1 : Site.
Variable d0 : Data.

Variable f : Site -> Site -> Data -> Z.

Definition sigma2_table (t : Table2) :=
  sigma_table Site LS1 Z (Z_id Site)
    (fun s1 : Site => sigma_table Site LS2 Data (f s1) (t s1)).

Definition update2_table :=
  change_x0y0 Site Site Data eq_site_dec eq_site_dec t s0 s1 d0.

End SIGMA_TABLE2.

Section SIGMA2_BUT_TABLE.

Variable Site : Set.
Hypothesis eq_site_dec : eq_dec Site.
Variable LS1 : list Site.
Variable LS2 : list Site.

Variable Data : Set.
Let Table := Site -> Data.
Let Table2 := Site -> Site -> Data.

Variable f1 : Site -> Data -> Z.
Variable s0 : Site.
Variable s1 : Site.

Variable t : Table2.
Variable f : Site -> Site -> Data -> Z.

Definition sigma2_but_table (t : Table2) :=
  sigma_table Site LS1 Z (Z_id Site)
    (fun s : Site =>
     if eq_site_dec s s0
     then  sigma_but_table Site eq_site_dec LS2 Data s1 (f s) (t s)
     else  sigma_table Site LS2 Data (f s) (t s)).

Definition new_sigma2_but_table (t : Table2) :=
  sigma2_table Site LS1 LS2 Data
    (fun (s2 s3 : Site) (d : Data) =>
     if eq_site_dec s2 s0
     then
       if eq_site_dec s3 s1 then  0%Z else  f s2 s3 d
     else  f s2 s3 d) t.

End SIGMA2_BUT_TABLE.

Section SIGMA_TABLE3.
Variable Site : Set.
Hypothesis eq_site_dec : eq_dec Site.
Variable LS1 : list Site.
Variable LS2 : list Site.

Variable Data : Set.
Let Table2 := Site -> Site -> Data.

Variable t : Table2.

Variable s0 s1 : Site.
Variable d0 : Data.

Variable f : Site -> Site -> Data -> Z.

Variable f1 : Site -> Site -> Data -> Z.
Variable f2 : Site -> Site -> Data -> Z.

(*Definition fun_sum_site2 :=
     [f1,f2: Site -> Site->Data->Z]
    [s1,s2: Site]
       [a: Data]
         `(f1 s1 s2 a) + (f2 s1 s2 a)`.*)

Definition fun_sum_site2 (f1 f2 : Site -> Site -> Data -> Z)
  (s1 : Site) :=
  fun_sum_site Site Data (fun (s2 : Site) (a : Data) => f1 s1 s2 a)
    (fun (s2 : Site) (a : Data) => f2 s1 s2 a).

Definition fun_minus_site2 (f1 f2 : Site -> Site -> Data -> Z)
  (s1 : Site) :=
  fun_minus_site Site Data (fun (s2 : Site) (a : Data) => f1 s1 s2 a)
    (fun (s2 : Site) (a : Data) => f2 s1 s2 a).

Lemma sigma2_disjoint :
 sigma2_table Site LS1 LS2 Data (fun_sum_site2 f1 f2) t =
 (sigma2_table Site LS1 LS2 Data f1 t + sigma2_table Site LS1 LS2 Data f2 t)%Z.
Proof.
  unfold sigma2_table in |- *.
  unfold fun_sum_site2 in |- *.
  rewrite <- sigma_same_table.
  apply sigma_table_simpl.
  unfold fun_sum_site in |- *.
  apply funct_eq.
  intro e.
  unfold fun_sum in |- *.
  rewrite <- sigma_disjoint.
  unfold fun_sum_site in |- *.
  auto.
Qed.

Lemma sigma2_disjoint2 :
 sigma2_table Site LS1 LS2 Data (fun_minus_site2 f1 f2) t =
 (sigma2_table Site LS1 LS2 Data f1 t - sigma2_table Site LS1 LS2 Data f2 t)%Z.
Proof.
  unfold sigma2_table in |- *.
  unfold fun_minus_site2 in |- *.
  rewrite <- sigma_same_table2.
  apply sigma_table_simpl.
  unfold fun_minus_site in |- *.
  apply funct_eq.
  intro e.
  unfold fun_minus in |- *.
  rewrite <- sigma_disjoint2.
  unfold fun_minus_site in |- *.
  auto.
Qed.

(*** ***)
Definition a_fun (s : Site) := f s1 s (t s1 s).

Remark sigma2_change_1 :
 forall (l : list Site) (n0 : Z),
 only_once Site eq_site_dec s0 l ->
 (sigma Site l (change_x0 Site Z eq_site_dec a_fun s0 n0) + a_fun s0 - n0)%Z =
 sigma Site l a_fun.

Proof.
  intros l n0 H.
  rewrite sigma_change.
  omega.
  auto.
Qed.

Remark add_reduce1 :
 forall x y z a b c : Z, (x + y - z - a + z)%Z = (x + y - a)%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce2 :
 forall x y z a b c : Z,
 (x + y)%Z = (z + a - b + c)%Z -> (x + y)%Z = (a + z - b + c)%Z.
Proof.
intros; omega.
Qed.

Lemma sigma_table2_change :
 only_once Site eq_site_dec s0 LS1 ->
 only_once Site eq_site_dec s1 LS2 ->
 sigma2_table Site LS1 LS2 Data f
   (update2_table Site eq_site_dec Data t s0 s1 d0) =
 (sigma2_table Site LS1 LS2 Data f t - f s0 s1 (t s0 s1) + f s0 s1 d0)%Z.
Proof.
  clear f1 f2. (* BUG DISCHARGE? *)
  intros H H0.
  generalize H.
  unfold sigma2_table in |- *.
  unfold sigma_table at 1 3 in |- *.
  elim LS1.
  simpl in |- *; intuition.

  simpl in |- *.
  intros a l H1 H2.
  case (eq_site_dec s0 a).
  intro e.
  rewrite e.
  unfold update2_table at 1 in |- *.
  unfold change_x0y0 in |- *.
  unfold change_x0 at 1 in |- *.
  rewrite case_eq.
  apply add_reduce2.
  generalize (sigma_table_change Site eq_site_dec LS2 Data (t a) s1 d0 (f a)).
  unfold update_table at 1 in |- *.
  simpl in |- *.
  intro H3.
  rewrite H3.
  replace
   (sigma Site l
      (fun s : Site =>
       Z_id Site s
         (sigma_table Site LS2 Data (f s)
            (update2_table Site eq_site_dec Data t a s1 d0 s)))) with
   (sigma Site l (fun s : Site => sigma_table Site LS2 Data (f s) (t s))).
  unfold Z_id in |- *.
  omega.

  apply sigma_simpl.
  intros x H4.
  unfold Z_id in |- *.
  apply sigma_table_simpl.
  unfold update2_table in |- *.
  unfold change_x0y0 in |- *; simpl in |- *.
  rewrite elsewhere.
  auto.

  generalize H2.
  unfold only_once in |- *.
  case (eq_site_dec s0 a).
  rewrite e.
  intro e0.
  generalize H4.
  exact (equality_from_membership Site eq_site_dec a x l).

  intuition.

  auto.

  intro n.
  rewrite H1.
  unfold Z_id in |- *.
  replace
   (sigma_table Site LS2 Data (f a)
      (update2_table Site eq_site_dec Data t s0 s1 d0 a)) with
   (sigma_table Site LS2 Data (f a) (t a)).
  omega.

  apply sigma_table_simpl.
  unfold update2_table in |- *.
  unfold change_x0y0 in |- *; simpl in |- *.
  rewrite elsewhere.
  auto.

  auto.

  generalize H2.
  simpl in |- *.
  case (eq_site_dec s0 a).
  intuition.

  auto.
Qed.

Lemma sigma2_table_simpl :
 forall (t : Site -> Site -> Data) (f1 f2 : Site -> Site -> Data -> Z),
 (forall (s1 s2 : Site) (d : Data), f1 s1 s2 d = f2 s1 s2 d) ->
 sigma2_table Site LS1 LS2 Data f1 t = sigma2_table Site LS1 LS2 Data f2 t.
Proof.
  intros t0 f0 f3 H.
  unfold sigma2_table in |- *.
  apply sigma_table_simpl.
  apply funct_eq.
  intros e.
  apply sigma_table_simpl2.
  auto.
Qed.

Lemma sigma2_table_simpl_partial :
 forall (t : Site -> Site -> Data) (f1 f2 : Site -> Site -> Data -> Z),
 (forall (s1 s2 : Site) (d : Data), t s1 s2 = d -> f1 s1 s2 d = f2 s1 s2 d) ->
 sigma2_table Site LS1 LS2 Data f1 t = sigma2_table Site LS1 LS2 Data f2 t.
Proof.
  intros t0 f0 f3 H.
  unfold sigma2_table in |- *.
  apply sigma_table_simpl.
  apply funct_eq.
  intros e.
  apply sigma_table_simpl2_partial.
  auto.
Qed.

Lemma sigma2_table_simpl_property :
 forall (t : Site -> Site -> Data)
   (P : (Site -> Site -> Data) -> Site -> Site -> Set)
   (f1 f2 : Site -> Site -> Data -> Z),
 (forall (s1 s2 : Site) (d : Data), P t s1 s2 -> f1 s1 s2 d = f2 s1 s2 d) ->
 (forall s1 s2 : Site, P t s1 s2) ->
 sigma2_table Site LS1 LS2 Data f1 t = sigma2_table Site LS1 LS2 Data f2 t.
Proof.
  intros t0 P f1' f2' H.
  unfold sigma2_table in |- *.
  intro H0.
  apply
   sigma_table_simpl_property
    with (P := fun (t : Site -> Z) (s2 : Site) => P t0 s1 s2).
  intros H1.
  apply funct_eq.
  intros e.
  apply sigma_table_simpl2.
  intros s d.
  apply H.
  auto.

  auto.
Qed.

End SIGMA_TABLE3.

Section SIGMA2_BUT.

Variable Site : Set.
Hypothesis eq_site_dec : eq_dec Site.
Variable LS0 : list Site.
Variable LS1 : list Site.
Variable LS2 : list Site.

Variable Data : Set.
Let Table2 := Site -> Site -> Data.

Variable t : Table2.
Variable s0 s1 : Site.
Variable d0 : Data.

Variable f : Site -> Site -> Site -> Data -> Z.

Lemma sigma2_sigma_but :
 sigma_but Site s0 eq_site_dec LS0
   (fun s : Site => sigma2_table Site LS1 LS2 Data (f s) t) =
 sigma2_table Site LS1 LS2 Data
   (fun (s1 s2 : Site) (d : Data) =>
    sigma_but Site s0 eq_site_dec LS0 (fun s : Site => f s s1 s2 d)) t.

Proof.
  elim LS0.
  simpl in |- *.
  unfold sigma2_table in |- *.
  unfold sigma_table in |- *.
  rewrite sigma_null.
  unfold Z_id in |- *.
  rewrite sigma_null.
  auto.

  intros a l H.
  simpl in |- *.
  case (eq_site_dec a s0).
  intro e.
  auto.

  intro n.
  rewrite H.
  rewrite <- sigma2_disjoint.
  unfold fun_sum_site2 in |- *.
  unfold fun_sum_site in |- *.
  auto.
Qed.

End SIGMA2_BUT.

Section SIGMA_BUT.

Variable Site : Set.

Hypothesis eq_site_dec : eq_dec Site.
Variable LS0 : list Site.
Variable LS1 : list Site.
Variable LS2 : list Site.

Variable Data : Set.
Let Table := Site -> Data.

Variable t : Table.
Variable s s0 s1 owner : Site.
Variable s2 : Site.
Variable d0 : Data.

Variable f : Site -> Site -> Site -> Data -> Z.

Variable pred : Data -> bool.

Variable
  decidable_predicate : forall a : Data, {pred a = true} + {pred a = false}.

Lemma decidable_pred_pred :
 forall a : Data,
 {fun_or Data pred pred a = true} + {fun_or Data pred pred a = false}.

Proof.
  unfold fun_or in |- *.
  intro a.
  generalize (decidable_predicate a).
  intro H.
  elim H.
  intro y.
  rewrite y.
  simpl in |- *.
  auto.

  intro y.
  rewrite y.
  simpl in |- *.
  auto.
Qed.

Lemma permute_sigma_reduce :
 forall q : queue Data,
 sigma Site LS0 (fun s : Site => reduce Data (f s s1 s2) q) =
 reduce Data (fun d : Data => sigma Site LS0 (fun s : Site => f s s1 s2 d)) q.

Proof.
  elim LS0.
  simpl in |- *.
  intro q.
  rewrite reduce_null_fun.
  auto.

  auto.

  intros a l H q.
  simpl in |- *.
  rewrite H.
  rewrite <- disjoint_reduce.
  unfold fun_sum in |- *.
  auto.
Qed.

Lemma permute_sigma_reduce2 :
 forall q : queue Data,
 sigma Site LS0 (fun _ : Site => reduce Data (f s s1 s2) q) =
 reduce Data (fun d : Data => sigma Site LS0 (fun _ : Site => f s s1 s2 d)) q.

Proof.
  elim LS0.
  simpl in |- *.
  intro q.
  rewrite reduce_null_fun.
  auto.

  auto.

  intros a l H q.
  simpl in |- *.
  rewrite H.
  rewrite <- disjoint_reduce.
  unfold fun_sum in |- *.
  auto.
Qed.

Lemma permute_sigma_but_reduce :
 forall q : queue Data,
 sigma_but Site owner eq_site_dec LS0
   (fun s : Site => reduce Data (f s s1 s2) q) =
 reduce Data
   (fun d : Data =>
    sigma_but Site owner eq_site_dec LS0 (fun s : Site => f s s1 s2 d)) q.

Proof.
  elim LS0.
  simpl in |- *.
  intro q.
  rewrite reduce_null_fun.
  auto.

  auto.

  intros a l H q.
  simpl in |- *.
  case (eq_site_dec a owner).
  intro e.
  auto.

  intro n.
  rewrite H.
  rewrite <- disjoint_reduce.
  unfold fun_sum in |- *.
  auto.
Qed.

Lemma sigma_but_null :
 forall (f : Site -> Z) (l : list Site),
 (forall s : Site, s <> owner -> f s = 0%Z) ->
 sigma_but Site owner eq_site_dec l f = 0%Z.
Proof.
  simple induction l.
  simpl in |- *.
  auto.

  intros a l0 H H0.
  simpl in |- *.
  case (eq_site_dec a owner).
  intro e.
  apply H.
  exact H0.

  intros n.
  rewrite H0.
  rewrite H.
  auto.

  exact H0.

  auto.
Qed.

Lemma sigma_but_simpl :
 forall (f1 f2 : Site -> Z) (l : list Site),
 (forall s : Site, s <> owner -> f1 s = f2 s) ->
 sigma_but Site owner eq_site_dec l f1 =
 sigma_but Site owner eq_site_dec l f2.
Proof.
  simple induction l.
  simpl in |- *.
  auto.
  intros a l0 H H0.
  simpl in |- *.
  case (eq_site_dec a owner).
  intro; apply H.
  auto.
  intro; rewrite H.
  rewrite H0.
  auto.
  auto.
  auto.
Qed.

End SIGMA_BUT.

Section positive.

Variable E : Set.

Hypothesis eq_E_dec : eq_dec E.

Lemma sigma_strictly_positive :
 forall (f : E -> Z) (x : E) (l : list E),
 In x l -> (forall y : E, (f y >= 0)%Z) -> (f x > 0)%Z -> (sigma E l f > 0)%Z.
Proof.
  intros f x l.
  elim l.
  simpl in |- *; intuition.

  intros a l0 H H0 H1 H2.
  simpl in |- *.
  case (eq_E_dec a x).
  intro e.
  rewrite e.
  generalize (sigma_pos E f l0 H1).
  intro H3.
  omega.

  intro n.
  generalize (H1 a).
  intro H3.
  generalize H0.
  simpl in |- *.
  intro H4.
  elim H4.
  intro; elim n; auto.

  intro H5.
  generalize (H H5 H1 H2).
  intro H6.
  omega.
Qed.

Variable x0 : E.

Lemma sigma_but_strictly_positive :
 forall (f : E -> Z) (x : E) (l : list E),
 In x l ->
 x <> x0 ->
 (forall y : E, (f y >= 0)%Z) ->
 (f x > 0)%Z -> (sigma_but E x0 eq_E_dec l f > 0)%Z.
Proof.
  intros f x l.
  elim l.
  simpl in |- *; intuition.

  intros a l0 H H0 H1 H2 H3.
  simpl in |- *.
  case (eq_E_dec a x0); intro.
  apply H.
  generalize H0; simpl in |- *.
  rewrite e.
  intro H4.
  elim H4; auto.
  intro; elim H1; auto.

  auto.

  auto.

  auto.

  case (eq_E_dec a x).
  intro e.
  rewrite e.
  generalize (sigma_but_pos E x0 eq_E_dec f l0 H2).
  intro H4.
  omega.

  intro n0.
  elim H0; intro.
  elim n0; auto.

  generalize (H H4 H1 H2 H3); intro.
  generalize (H2 a).
  omega.
Qed.

End positive.

Section positive2.

Variable Site : Set.
Hypothesis eq_site_dec : eq_dec Site.
Variable LS1 : list Site.
Variable LS2 : list Site.

Variable Data : Set.
Let Table2 := Site -> Site -> Data.

Variable t : Table2.
Variable s0 s1 : Site.
Variable d0 : Data.

Variable f : Site -> Site -> Data -> Z.

Lemma sigma2_strictly_positive :
 forall (x y : Site) (l1 l2 : list Site),
 In x l1 ->
 In y l2 ->
 (forall x' y' : Site, (f x' y' (t x' y') >= 0)%Z) ->
 (f x y (t x y) > 0)%Z -> (sigma2_table Site l1 l2 Data f t > 0)%Z.
Proof.
  unfold sigma2_table in |- *.
  intros x y l1 l2 H H0 H1 H2.
  unfold sigma_table in |- *.
  apply sigma_strictly_positive with (x := x).
  auto.

  auto.

  intro y0.
  unfold Z_id in |- *.
  apply sigma_pos.
  intro x_.
  generalize (H1 y0 x_).
  auto.

  unfold Z_id in |- *.
  apply sigma_strictly_positive with (x := y).
  auto.

  auto.

  intro y0.
  generalize (H1 x y0).
  auto.

  auto.
Qed.

End positive2.

Section BUT_XY.
Variable Site : Set.
Hypothesis eq_site_dec : eq_dec Site.
Variable LS1 : list Site.
Variable LS2 : list Site.

Variable Data : Set.
Let Table2 := Site -> Site -> Data.
Variable f : Site -> Site -> Data -> Z.

Remark add_reduce2_1 :
 forall x y z a : Z, x = a -> (x + (y + z))%Z = (a + y + z)%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce3 :
 forall x y z a : Z, x = a -> y = z -> (x + y)%Z = (a + z)%Z.
Proof.
intros; omega.
Qed.

Lemma sigma2_sigma2_but_x_y :
 forall (s0 s1 : Site) (t : Table2),
 only_once Site eq_site_dec s0 LS1 ->
 only_once Site eq_site_dec s1 LS2 ->
 sigma2_table Site LS1 LS2 Data f t =
 (sigma2_but_table Site eq_site_dec LS1 LS2 Data s0 s1 f t +
  f s0 s1 (t s0 s1))%Z.
Proof.
  intro s0.
  intro s1.
  intro t.
  elim LS1.
  simpl in |- *.
  intros; contradiction.

  intros a l H H0 H1.
  unfold sigma2_table, sigma2_but_table in |- *.
  simpl in |- *.
  case (eq_site_dec a s0); intro.
  unfold sigma_table in |- *.
  rewrite (sigma_sigma_but Site a eq_site_dec).
  rewrite (sigma_sigma_but Site a eq_site_dec) with (l := a :: l).
  simpl in |- *.
  case (eq_site_dec a a).
  intro e0.
  case (eq_site_dec a s0).
  intro e1.
  rewrite <- sigma_sigma_but_not_in with (x0 := a).
  rewrite <- sigma_sigma_but_not_in with (x0 := a).
  rewrite (sigma_sigma_but Site s1 eq_site_dec) with (l := LS2).
  unfold sigma_but_table in |- *.
  rewrite e1.
  unfold Z_id in |- *.
  apply add_reduce2_1.
  apply sigma_simpl.
  intros x H2.
  case (eq_site_dec x s0).
  intro e2.
  generalize H0; rewrite e1.
  simpl in |- *.
  case (eq_site_dec s0 s0); intro.
  intro H3.
  elim H3; rewrite <- e2; auto.

  elim n; auto.

  intro n.
  auto.

  auto.

  generalize H0; simpl in |- *.
  rewrite e.
  case (eq_site_dec s0 s0); intro.
  auto.

  elim n; auto.

  generalize H0; simpl in |- *.
  case (eq_site_dec s0 a); intro.
  rewrite e; auto.

  elim n; auto.

  intro n.
  elim n; auto.

  intro n.
  elim n; auto.

  rewrite e; auto.
  generalize H0; rewrite e; auto.

  generalize H0; rewrite e.
  auto.

  unfold sigma_table in |- *; simpl in |- *.
  generalize H.
  unfold sigma2_table in |- *.
  unfold sigma_table in |- *.
  intro H2.
  rewrite H2.
  unfold Z_id in |- *; simpl in |- *.
  case (eq_site_dec a s0); intro.
  elim n; auto.

  unfold sigma2_but_table in |- *.
  unfold sigma_table in |- *.
  unfold Z_id in |- *.
  omega.

  generalize H0; simpl in |- *.
  case (eq_site_dec s0 a); intro.
  elim n; auto.

  auto.

  auto.

Qed.

Lemma sigma2_but_simpl :
 forall (s0 s1 : Site) (t : Table2) (f g : Site -> Site -> Data -> Z),
 (forall x y : Site, ~ (x = s0 /\ y = s1) -> f x y (t x y) = g x y (t x y)) ->
 only_once Site eq_site_dec s0 LS1 ->
 only_once Site eq_site_dec s1 LS2 ->
 sigma2_but_table Site eq_site_dec LS1 LS2 Data s0 s1 f t =
 sigma2_but_table Site eq_site_dec LS1 LS2 Data s0 s1 g t.
Proof.
  intros s0 s1 t f0 g H.
  elim LS1.
  simpl in |- *.
  intros; contradiction.

  simpl in |- *.
  intros a l.
  case (eq_site_dec s0 a); intro.
  rewrite e.
  simpl in |- *.
  intros H0 H1 H2.
  unfold sigma2_but_table in |- *.
  unfold sigma_table in |- *; simpl in |- *.
  unfold Z_id in |- *.
  case (eq_site_dec a a); intro.
  apply add_reduce3.
  generalize H2.
  elim LS2; simpl in |- *.
  intro; contradiction.

  intros a0 l0 H3 H4.
  unfold sigma_but_table in |- *; simpl in |- *.
  generalize H4.
  case (eq_site_dec a0 s1); intro.
  rewrite e1.
  case (eq_site_dec s1 s1); intros.
  rewrite <- (sigma_sigma_but_not_in Site s1 eq_site_dec).
  rewrite <- (sigma_sigma_but_not_in Site s1 eq_site_dec).
  apply sigma_simpl.
  intros x H6.
  apply H.
  unfold not in |- *; intro.
  decompose [and] H7.
  elim H5; rewrite <- H9; auto.

  auto.

  exact H5.

  elim n; auto.

  case (eq_site_dec s1 a0); intro.
  elim n; auto.

  intros H5.
  apply add_reduce3.
  apply H.
  unfold not in |- *; intro.
  decompose [and] H6.
  elim n; auto.

  generalize H3.
  unfold sigma_but_table in |- *.
  auto.

  apply sigma_simpl.
  intros x H3.
  case (eq_site_dec x a); intro.
  elim H1; rewrite <- e1; auto.

  apply sigma_simpl.
  intros x0 H4.
  apply H.
  unfold not in |- *; intro.
  decompose [and] H5; elim n; rewrite <- e; auto.

  elim n; auto.

  unfold sigma2_but_table in |- *.
  unfold sigma_table in |- *; simpl in |- *.
  intros H0 H1 H2.
  case (eq_site_dec a s0); intro.
  elim n; auto.

  rewrite H0.
  apply add_reduce3.
  unfold Z_id in |- *.
  apply sigma_simpl.
  intros x H3.
  apply H.
  unfold not in |- *; intro; elim n0.
  decompose [and] H4; auto.

  auto.

  auto.

  auto.

Qed.

(* Interestingly, the proof of the following Lemma is exactly the same
as the proof of the previous lemma *)

Lemma sigma2_but_simpl2 :
 forall (s0 s1 : Site) (t1 t2 : Table2) (f : Site -> Site -> Data -> Z),
 (forall x y : Site, ~ (x = s0 /\ y = s1) -> f x y (t1 x y) = f x y (t2 x y)) ->
 only_once Site eq_site_dec s0 LS1 ->
 only_once Site eq_site_dec s1 LS2 ->
 sigma2_but_table Site eq_site_dec LS1 LS2 Data s0 s1 f t1 =
 sigma2_but_table Site eq_site_dec LS1 LS2 Data s0 s1 f t2.
Proof.
  intros s0 s1 t1 t2 f0 H.
  elim LS1.
  simpl in |- *.
  intros; contradiction.

  simpl in |- *.
  intros a l.
  case (eq_site_dec s0 a); intro.
  rewrite e.
  simpl in |- *.
  intros H0 H1 H2.
  unfold sigma2_but_table in |- *.
  unfold sigma_table in |- *; simpl in |- *.
  unfold Z_id in |- *.
  case (eq_site_dec a a); intro.
  apply add_reduce3.
  generalize H2.
  elim LS2; simpl in |- *.
  intro; contradiction.

  intros a0 l0 H3 H4.
  unfold sigma_but_table in |- *; simpl in |- *.
  generalize H4.
  case (eq_site_dec a0 s1); intro.
  rewrite e1.
  case (eq_site_dec s1 s1); intros.
  rewrite <- (sigma_sigma_but_not_in Site s1 eq_site_dec).
  rewrite <- (sigma_sigma_but_not_in Site s1 eq_site_dec).
  apply sigma_simpl.
  intros x H6.
  apply H.
  unfold not in |- *; intro.
  decompose [and] H7.
  elim H5; rewrite <- H9; auto.

  auto.

  exact H5.

  elim n; auto.

  case (eq_site_dec s1 a0); intro.
  elim n; auto.

  intros H5.
  apply add_reduce3.
  apply H.
  unfold not in |- *; intro.
  decompose [and] H6.
  elim n; auto.

  generalize H3.
  unfold sigma_but_table in |- *.
  auto.

  apply sigma_simpl.
  intros x H3.
  case (eq_site_dec x a); intro.
  elim H1; rewrite <- e1; auto.

  apply sigma_simpl.
  intros x0 H4.
  apply H.
  unfold not in |- *; intro.
  decompose [and] H5; elim n; rewrite <- e; auto.

  elim n; auto.

  unfold sigma2_but_table in |- *.
  unfold sigma_table in |- *; simpl in |- *.
  intros H0 H1 H2.
  case (eq_site_dec a s0); intro.
  elim n; auto.

  rewrite H0.
  apply add_reduce3.
  unfold Z_id in |- *.
  apply sigma_simpl.
  intros x H3.
  apply H.
  unfold not in |- *; intro; elim n0.
  decompose [and] H4; auto.

  auto.

  auto.

  auto.
Qed.

End BUT_XY.

Section NEW_BUT_XY.

Variable Site : Set.
Hypothesis eq_site_dec : eq_dec Site.
Variable LS1 : list Site.
Variable LS2 : list Site.

Variable Data : Set.
Let Table2 := Site -> Site -> Data.
Variable f : Site -> Site -> Data -> Z.

Remark add_reduce17 : forall x y a : Z, x = y -> (x + a)%Z = (y + a)%Z.
Proof.
intros; omega.
Qed.

Remark add_reduce18 : forall x y a : Z, x = y -> a = 0%Z -> x = (y + a)%Z.
Proof.
intros; omega.
Qed.

(* another way of defining sigma_but:

   On the one hand, it is less convenient, because the functional
   argument is changed, which later, if we use sigma2_simpl, will
   imply a tedious case analysis.

   On the other hand, it is more convenient, because I can
   apply sigma2_but several times, there are transformed into
   a sigma2_table.
*)
Lemma new_sigma2_sigma2_but_x_y :
 forall (s0 s1 : Site) (Data : Set) (f : Site -> Site -> Data -> Z)
   (t : Site -> Site -> Data),
 only_once Site eq_site_dec s0 LS1 ->
 only_once Site eq_site_dec s1 LS2 ->
 sigma2_table Site LS1 LS2 Data f t =
 (new_sigma2_but_table Site eq_site_dec LS1 LS2 Data s0 s1 f t +
  f s0 s1 (t s0 s1))%Z.
Proof.
  intros s0 s1 Data0 f0 t H H0.
  unfold new_sigma2_but_table in |- *.
  rewrite
   sigma2_sigma2_but_x_y
                         with
                         (s0 := s0)
                        (s1 := s1)
                        (eq_site_dec := eq_site_dec).
  apply add_reduce17.
  rewrite
   sigma2_sigma2_but_x_y
                         with
                         (s0 := s0)
                        (s1 := s1)
                        (eq_site_dec := eq_site_dec).
  apply add_reduce18.
  apply sigma2_but_simpl.
  intros x y H1.
  case (eq_site_dec x s0); intro.
  case (eq_site_dec y s1); intro.
  elim H1; auto.

  auto.

  auto.

  auto.

  auto.

  rewrite case_eq.
  rewrite case_eq.
  auto.

  auto.

  auto.

  auto.

  auto.

Qed.

End NEW_BUT_XY.


(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter" "-nois") -*- *)
(* File reduced by coq-bug-finder from original input, then from 8858 lines to 268 lines, then from 249 lines to 207 lines *)
(* coqc version trunk (December 2014) compiled on Dec 10 2014 12:26:15 with OCaml 4.01.0
   coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (c938cb8e85f741ce697e7486d35c27c1aa31fe7a) *)

Global Set Universe Polymorphism.
Generalizable All Variables.
Require Import Coq.Init.Notations.
Notation "A -> B" := (forall (_ : A), B) : type_scope.
Open Scope type_scope.
Inductive False := .
Axiom proof_admitted : False.
Ltac admit := destruct proof_admitted.
Record prod (A B : Type) := pair { fst : A ; snd : B }.
Notation "x * y" := (prod x y) : type_scope.
Inductive nat : Set := O | S (_ : nat).
Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
Notation "{ x : A  & P }" := (sigT (fun x:A => P)) : type_scope.
Notation idmap := (fun x => x).
Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
Open Scope function_scope.
Definition composeD {A B C} (g : forall b, C b) (f : A -> B) := fun x : A => g (f x).
Notation "g 'oD' f" := (composeD g f) (at level 40, left associativity) : function_scope.
Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.
Arguments idpath {A a} , [A] a.
Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.
Delimit Scope path_scope with path.
Local Open Scope path_scope.
Notation "1" := idpath : path_scope.
Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y.
  exact (match p with idpath => idpath end).
Defined.
Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x)
  := forall x:A, f x = g x.
Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.
Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
: f == g.
  exact (fun x => match h with idpath => 1 end).
Defined.
Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }.
Record Equiv A B := BuildEquiv {
                        equiv_fun : A -> B ;
                        equiv_isequiv : IsEquiv equiv_fun
                      }.
Coercion equiv_fun : Equiv >-> Funclass.
Global Existing Instance equiv_isequiv.
Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.
Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope.
Class Contr_internal (A : Type) := BuildContr {
                                       center : A ;
                                       contr : (forall y : A, center = y)
                                     }.
Inductive trunc_index : Type :=
| minus_two : trunc_index
| trunc_S : trunc_index -> trunc_index.

Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope.
Local Open Scope trunc_scope.
Notation "-2" := minus_two (at level 0) : trunc_scope.
Notation "-1" := (-2.+1) (at level 0) : trunc_scope.

Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
  match n with
    | -2 => Contr_internal A
    | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y)
  end.

Class IsTrunc (n : trunc_index) (A : Type) : Type :=
  Trunc_is_trunc : IsTrunc_internal n A.
Notation IsHProp := (IsTrunc -1).

Ltac simple_induction n n' IH :=
  generalize dependent n;
  fix IH 1;
  intros [| n'];
  [ clear IH | specialize (IH n') ].
Axiom isequiv_apD10 : forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g).

Inductive Unit : Set := tt : Unit.

Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }.
Local Open Scope equiv_scope.

Global Instance isequiv_idmap (A : Type) : IsEquiv idmap | 0 :=
  Build_IsEquiv A A idmap idmap.
Definition equiv_idmap (A : Type) : A <~> A.
  exact (BuildEquiv A A idmap _).
Defined.
Definition equiv_compose' {A B C : Type} (g : B <~> C) (f : A <~> B)
: A <~> C.
  admit.
Defined.

Section EquivInverse.

  Context {A B : Type} (f : A -> B) {feq : IsEquiv f}.
  Global Instance isequiv_inverse : IsEquiv f^-1 | 10000.
  admit.
  Defined.
End EquivInverse.

Theorem equiv_inverse {A B : Type} : (A <~> B) -> (B <~> A).
  admit.
Defined.

Definition trunc_equiv A {B} (f : A -> B)
           `{IsTrunc n A} `{IsEquiv A B f}
: IsTrunc n B.
  admit.
Defined.

Definition equiv_apD10  {A : Type} (P : A -> Type) f g
: (f = g) <~> (f == g)
  := BuildEquiv _ _ (@apD10 A P f g) _.
Definition equiv_path_forall `{P : A -> Type} (f g : forall x, P x)
: (f == g)  <~>  (f = g).
  admit.
Defined.
Definition equiv_functor_forall' `{P : A -> Type} `{Q : B -> Type}
           (f : B <~> A) (g : forall b, P (f b) <~> Q b)
: (forall a, P a) <~> (forall b, Q b).
  admit.
Defined.

Definition equiv_functor_prod' {A A' B B' : Type} (f : A <~> A') (g : B <~> B')
: A * B <~> A' * B'.
  admit.
Defined.

Definition equiv_functor_sigma' `{P : A -> Type} `{Q : B -> Type}
           (f : A <~> B)
           (g : forall a, P a <~> Q (f a))
: sigT P <~> sigT Q.
  admit.
Defined.

Fixpoint PathSplit (n : nat) `(f : A -> B) : Type
  := match n with
       | O => Unit
       | S n => (forall a, hfiber f a) *
                forall (x y : A), PathSplit n (@ap _ _ f x y)
     end.

Lemma equiv_functor_pathsplit (n : nat) {A B C D}
      (f : A -> B) (g : C -> D) (h : A <~> C) (k : B <~> D)
      (p : g o h == k o f)
: PathSplit n f <~> PathSplit n g.
  admit.
Defined.
Definition ooPathSplit `(f : A -> B) : Type.
  exact (forall n, PathSplit n f).
Defined.

Global Instance ishprop_oopathsplit `(f : A -> B)
: IsHProp (ooPathSplit f).
admit.
Defined.

Definition ExtensionAlong {A B : Type} (f : A -> B)
           (P : B -> Type) (d : forall x:A, P (f x))
  := { s : forall y:B, P y & forall x:A, s (f x) = d x }.

Fixpoint ExtendableAlong
         (n : nat) {A : Type@{i}} {B : Type@{j}}
         (f : A -> B) (C : B -> Type@{k}) : Type@{l}
  := match n with
       | O => Unit : Type@{l}
       | S n => (forall (g : forall a, C (f a)),
                   ExtensionAlong@{i j k l l} f C g) *
                forall (h k : forall b, C b),
                  ExtendableAlong n f (fun b => h b = k b)
     end.

Definition equiv_extendable_pathsplit  (n : nat)
           {A B : Type} (C : B -> Type) (f : A -> B)
: ExtendableAlong n f C
                  <~> PathSplit n (fun (g : forall b, C b) => g oD f).
Proof.
  generalize dependent C; simple_induction n n IHn; intros C.
  1:apply equiv_idmap.
  apply equiv_functor_prod'; simpl.
  -
    refine (equiv_functor_forall' (equiv_idmap _) _); intros g; simpl.
    refine (equiv_functor_sigma' (equiv_idmap _) _); intros rec.
    apply equiv_path_forall.
  -
    refine (equiv_functor_forall' (equiv_idmap _) _); intros h.
    refine (equiv_functor_forall' (equiv_idmap _) _); intros k; simpl.
    refine (equiv_compose' _ (IHn (fun b => h b = k b))).
    apply equiv_inverse.
    refine (equiv_functor_pathsplit n _ _
                                    (equiv_apD10 _ _ _) (equiv_apD10 _ _ _) _).
    intros []; reflexivity.
Defined.
Definition ooExtendableAlong
           {A : Type@{i}} {B : Type@{j}}
           (f : A -> B) (C : B -> Type@{k}) : Type@{l}.
  exact (forall n, ExtendableAlong@{i j k l} n f C).
Defined.

Definition equiv_ooextendable_pathsplit
           {A B : Type} (C : B -> Type) (f : A -> B)
: ooExtendableAlong f C <~>
                    ooPathSplit (fun (g : forall b, C b) => g oD f).
Proof.
  refine (equiv_functor_forall' (equiv_idmap _) _); intros n.
  apply equiv_extendable_pathsplit.
Defined.

Global Instance ishprop_ooextendable
       {A B : Type} (C : B -> Type) (f : A -> B)
: IsHProp (ooExtendableAlong f C).
Proof.
  refine (trunc_equiv _ (equiv_ooextendable_pathsplit C f)^-1).
Defined.
Check ishprop_ooextendable@{a a i i i i}.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj27synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (mult lv0 lv1) (plus lv1 (mult lv2 lv1))) (lv3)).
Admitted.
QuickChick conj27synthconj6.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj19synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus (plus lv2 lv0) lv3)).
Admitted.
QuickChick conj19synthconj6.


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.
Require Import Defs.Defs.

Require Import Complete.SameShape.

(*** Definition *)

Definition Sch_or_Obj (env : Env) := env = • \/ (exists x sch env', env = env' ::x x :- sch) \/ (exists obj env', env = env' ::o obj).
Ltac SOO_auto := ((now (left; eauto)) || (now (right; (now (left; exists; eauto)) || (now (right; exists; eauto))))).
Definition DSch_or_DObj (denv : DEnv) := denv = ▪ \/ (exists x dsch denv', denv = denv' :::x x :- dsch) \/ (exists dobj denv', denv = denv' :::o dobj).

(** Conversion *)
Theorem SOO_DSODO : forall denv__in dsub__in env denv dsub,
    {denv__in, dsub__in}|= env ~> {denv, dsub}
  -> Sch_or_Obj env
  -> DSch_or_DObj denv.
Proof.
  introv INST SOO. unfold Sch_or_Obj in SOO. destr.
  - inverts INST. SOO_auto.
  - inv_EInst. SOO_auto.
  - destruct obj.
    inv_EInst. SOO_auto.
Qed.

(*** DSODO *)
Theorem DSODO_cons_DA' : forall denv1 denv2 da1 da2,
    denv1 :::a da1 = denv2 :::a da2
  -> DSch_or_DObj denv1
  -> DSch_or_DObj denv2
  -> denv1 = denv2 /\ da1 = da2.
Proof.
  introv EQ DSODO1 DSODO2. gen da2. induction da1; intros.
  - destruct da2. crush.
    simpl in EQ. rewr in EQ. inverts EQ. unfold DSch_or_DObj in DSODO1. crush.
  - destruct da2.
    simpl in EQ. rewr in EQ. inverts EQ. unfold DSch_or_DObj in DSODO2. crush.
    simpl in EQ. rewr in EQ. inverts EQ. forwards: IHda1. eassumption. crush.
Qed.

Theorem DSODO_cons_DA : forall denv1 denv2 da1 da2,
    DSch_or_DObj denv1
  -> denv1 :::a da1 = denv2 :::a da2
  -> exists da1', da1 = da2 ++ da1' /\ denv2 = denv1 :::a da1'.
Proof.
  intros. gen da2. induction da1; intros.
  - destruct da2.
    + simpl in H0. subst. exists ([]:DA). crush.
    + destruct H; destr; inverts H0.
  - destruct da2.
    + simpl in H0. rewr in H0. subst.
      exists. crush.
    + simpl in H0. rewr in H0. inverts H0.
      forwards: IHda1. eassumption. destr. exists. crush.
Qed.

(*** SOO *)
Theorem SOO_Inf : forall env__in e a ty env__out,
    env__in |= e ▸ ⟨a⟩ ty =| env__out
  -> Sch_or_Obj env__in
  -> Sch_or_Obj env__out.
Proof.
  intros.
  forwards: Inf_SameShape. eassumption. unfold Sch_or_Obj in H0. destr; inverts H1; SOO_auto.
Qed.

Theorem SOO_Gen : forall env__in e sch env__out,
    env__in |= e ▸ sch =| env__out
  -> Sch_or_Obj env__in
  -> Sch_or_Obj env__out.
Proof.
  intros.
  forwards: Gen_SameShape. eassumption. unfold Sch_or_Obj in H0. destr; inverts H1; SOO_auto.
Qed.

Theorem SOO_cons_DA : forall env denv1 denv2 dsub da1 da2 denv__in dsub__in,
    {denv__in, dsub__in}|= env ~> {denv1, dsub}
  -> Sch_or_Obj env
  -> denv1 :::a da1 = denv2 :::a da2
  -> exists da1', da1 = da2 ++ da1' /\ denv2 = denv1 :::a da1'.
Proof. introv INST SOB EQ. eapply DSODO_cons_DA. eapply SOO_DSODO. all: eassumption. Qed.


From iris Require Import program_logic.weakestpre.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Import gen_heap.

From st.STLCmuST Require Import lang.
From st.STLCmuVS Require Import lang wkpre.
From st Require Import resources.

Section lift.

  Context `{Σ : !gFunctors} `{sem_le_stΣ_inst : !sem_le_stΣ Σ}.

  Context (s : stuckness).

  Definition lift (Φ : valO -n> STLCmuST.lang.valO -n> iPropO Σ) :
    exprO → STLCmuST.lang.exprO → iProp Σ :=
      fun eᵢ eₛ => (∀ σ : gmap loc STLCmuST.lang.val ,
                    (gen_heap_interp σ -∗ WP eᵢ @ s ; top {{ vᵢ, ∃ vₛ σ', gen_heap_interp σ' ∗ ⌜ rtc STLCmuST_step (σ, eₛ) (σ', STLCmuST.lang.of_val vₛ) ⌝ ∗ Φ vᵢ vₛ }}))%I.

  Lemma lift_bind (Kᵢ : list ectx_item) (Kₛ : list STLCmuST.lang.ectx_item) (Φ Ψ : valO -n> STLCmuST.lang.valO -n> iPropO Σ)
        (eᵢ : expr) (eₛ  : STLCmuST.lang.expr) :
    ⊢ lift Φ eᵢ eₛ -∗ (∀ vᵢ vₛ, Φ vᵢ vₛ -∗ lift Ψ (fill Kᵢ (of_val vᵢ)) (fill Kₛ (STLCmuST.lang.of_val vₛ))) -∗ lift Ψ (fill Kᵢ eᵢ) (fill Kₛ eₛ).
  Proof.
    iIntros "HΦeN H". rewrite /lift. iIntros (σ) "Hσ". iSpecialize ("HΦeN" $! σ with "Hσ").
    iApply (wp_bind' Kᵢ). iApply (wp_wand with "HΦeN").
    iIntros (v). iIntros "des". iDestruct "des" as (v' σ') "(Hσ' & %HNv' & Hvv')".
    iSpecialize ("H" $! v v' with "Hvv'"). iSpecialize ("H" $! σ' with "Hσ'").
    iApply (wp_wand with "H").
    iIntros (w). iIntros "des". iDestruct "des" as (w' σ'') "(Hσ'' & %HKₛv'w' & Hww')".
    iExists w', σ''. iFrame. iPureIntro.
    apply (rtc_transitive _ (σ', fill Kₛ v')); auto.
    by apply fill_STLCmuST_step_rtc.
  Qed.

  Lemma lift_pure_step_rtc Φ eᵢ e e' (H : rtc pure_step e e') : lift Φ eᵢ e' ⊢ lift Φ eᵢ e.
  Proof.
    iIntros "H". iIntros (σ) "Hσ". iSpecialize ("H" $! σ with "Hσ"). iApply (wp_wand with "H").
    iIntros (v) "des". iDestruct "des" as (w' σ') "(Hσ' & %Hsteps & H2)". iExists w'. iFrame "H2".
    iExists σ'. iFrame. iPureIntro. eapply rtc_transitive with (y := (σ, e')); eauto.
    eapply rtc_congruence; eauto. intros. destruct H0. destruct (pure_step_safe σ).
    destruct H0 as (σ'' & efs & primstep).
    by destruct (pure_step_det _ _ _ _ _ primstep) as (eq1 & -> & -> & ->).
  Qed.

  Lemma lift_pure_step Φ eᵢ e e' (H : pure_step e e') : lift Φ eᵢ e' ⊢ lift Φ eᵢ e.
  Proof. iApply lift_pure_step_rtc. by apply rtc_once. Qed.

  Lemma lift_step_later Φ e e' eₛ (H : STLCmuVS_step e e') : ▷ lift Φ e' eₛ ⊢ lift Φ e eₛ.
  Proof. iIntros "H". iIntros (σ) "Hσ". iApply wp_step_later. eauto. by iApply "H". Qed.

  Lemma lift_val (Ψ : valO -n> STLCmuST.lang.valO -n> iPropO Σ) vᵢ vₛ : (Ψ vᵢ vₛ) ⊢ lift Ψ vᵢ vₛ.
  Proof. iIntros "Hv". rewrite /lift. iIntros (σ) "Hσ". iApply wp_value'. iExists vₛ, σ. iFrame. iPureIntro. apply rtc_refl. Qed.

  Lemma lift_val_fupd (Ψ : valO -n> STLCmuST.lang.valO -n> iPropO Σ) vᵢ vₛ : (|={⊤}=> Ψ vᵢ vₛ) ⊢ lift Ψ vᵢ vₛ.
  Proof. iIntros "Hv". rewrite /lift. iIntros (σ) "Hσ". iApply wp_value_fupd'. iExists vₛ, σ. iFrame. iMod "Hv". iModIntro. iSplit; auto. Qed.

  Lemma lift_wand (Φ Ψ : valO -n> STLCmuST.lang.valO -n> iPropO Σ) e e' :
    ⊢ (∀ v v', Φ v v' -∗ Ψ v v') -∗ lift Φ e e' -∗ lift Ψ e e'.
  Proof.
    iIntros "H Hee'". iIntros (σ) "Hσ". iSpecialize ("Hee'" $! σ with "Hσ").
    iApply (wp_wand with "Hee'"). iIntros (v) "Hdes".
    iDestruct "Hdes" as (v' σ') "(Hσ' & %He'v' & HΦ)".
    iExists v', σ'. iFrame. iSplit; auto. by iApply "H".
  Qed.

End lift.


Require Import Arith.
Require Import Omega.
Require Import String.
Require Import List.
Import ListNotations.

Require Import msl.eq_dec.

(* ************************************************************ *)
(* ************************************************************ *)
(*                                                              *)
(*                             ast                              *)
(*                                                              *)
(* ************************************************************ *)
(* ************************************************************ *)

(*
 * abstract syntax the code is written in
 *)

(* types are the types of values we can touch directly *)
Inductive type :=
| t_unit : type
| t_nat  : type
| t_bool : type
| t_pair : type -> type -> type
| t_list : type -> type
| t_addr : type -> type
| t_lock : type -> type
.

(* variables are identified by numbers *)
Inductive var: Type :=
| mkvar: type -> nat -> var
.

Definition type_of_var v :=
   match v with
   | mkvar t _ => t
   end.

(* heap addresses are also numbers (and which heap, currently a bool) *)
Inductive addr: Type :=
| mkaddr : type -> nat -> bool -> addr
.

Inductive value : Type :=
| v_unit: value
| v_nat  (n: nat): value
| v_bool (b: bool): value
| v_pair (a: value) (b: value): value
| v_list (t: type) (l: list value): value
| v_addr (a: addr): value
| v_lock (a: addr): value
| v_undef: value
.

Function type_of_value (v: value): type :=
   match v with
   | v_unit => t_unit
   | v_nat _ => t_nat
   | v_bool _ => t_bool
   | v_pair a b => t_pair (type_of_value a) (type_of_value b)
   | v_list t l => t_list t
   | v_addr (mkaddr ty _ _) => t_addr ty
   | v_lock (mkaddr ty _ _) => t_lock ty
   | v_undef => t_unit (* XXX *)
   end.

Inductive invariant : Type :=
(* Just an example *)
| nat_inv : invariant
.

(*
 * expressions produce values
 *)
Inductive expr: Type :=
| e_value: type -> value -> expr
| e_read: var -> expr
| e_cond: type -> expr -> expr -> expr -> expr
.

(*
 * statements don't
 *)
Inductive stmt: Type :=
| s_skip: stmt
| s_seq: stmt -> stmt -> stmt
| s_start: proc -> expr -> stmt
| s_assign: var -> expr -> stmt
| s_load: var -> expr -> stmt
| s_store: var -> expr -> stmt
| s_scope: stmt -> stmt
| s_if: expr -> stmt -> stmt -> stmt
| s_while: expr -> stmt -> stmt
| s_call: var -> proc -> expr -> stmt
| s_local: var -> expr -> stmt
| s_return: expr -> stmt
| s_getlock: var -> stmt
| s_putlock: var -> stmt
with

(*
 * procs both take and produce values
 *)
(*Inductive*) proc: Type :=
| mkproc: type -> var -> stmt -> proc
.

(*
 * Extended/sugary AST forms
 *)

Definition v_true: value := v_bool true.
Definition v_false: value := v_bool false.

(* doesn't quite work any more
Definition e_coqcall {ta tr : type} (f : ta -> tr) (x : ta): expr tr :=
   e_value tr (f x)
.
*)

(* no longer relevant
Definition s_skip: stmt := s_block nil.
*)

(*
 * Notation
 *)

Notation "[{ s1 ; s2 ; }]" :=
  (s_seq s1 s2) (at level 90, s1 at next level, s2 at next level, format
"'[v' [{ '[  ' '//' s1 ; '//' s2 ; ']' '//' }] ']'").

Instance EqDec_var : EqDec (var) := _.
Proof.
Admitted.

Instance EqDec_lock : EqDec (addr) := _.
Proof.
Admitted.


Typeclasses eauto := debug.
Set Printing All.

Axiom SProp : Set.
Axiom sp : SProp.

(* If we hardcode valueType := nat, it goes through *)
Class StateIs := {
  valueType : Type;
  stateIs : valueType -> SProp
}.

Instance NatStateIs : StateIs := {
  valueType := nat;
  stateIs := fun _ => sp
}.
Canonical Structure NatStateIs.

Class LogicOps F := { land: F -> F }.
Instance : LogicOps SProp. Admitted.
Instance : LogicOps Prop. Admitted.

Parameter (n : nat).
(* If this is a [Definition], the resolution goes through fine. *)
Notation vn := (@stateIs _ n).
Definition vn' := (@stateIs _ n).
Definition GOOD : SProp :=
  @land _ _ vn'.
(* This doesn't resolve, if PropLogicOps is defined later than SPropLogicOps *)
Definition BAD : SProp :=
  @land _ _ vn.

Class A T := { foo : T -> Prop }.
Instance: A nat. Admitted.
Instance: A Set. Admitted.

Class B := { U : Type ; b : U }.
Instance bi: B := {| U := nat ; b := 0 |}.
Canonical Structure bi.

Notation b0N := (@b _ : nat).
Notation b0Ni := (@b bi : nat).
Definition b0D := (@b _ : nat).
Definition GOOD1 := (@foo _ _ b0D).
Definition GOOD2 := (let x := b0N in @foo _ _ x).
Definition GOOD3 := (@foo _ _ b0Ni).
Definition BAD1 := (@foo _ _ b0N). (* Error: The term "b0Ni" has type "nat" while it is expected to have type "Set". *)