Add Rec LoadPath "." as DEP_AI.

Require Import language.
Require Import values.
Require Import operational_semantics.

Require Import over_instrumented_values.
Require Import oitval_instantiation.
Require Import oitval_val_conversion.
Require Import oitval_val_conversion_facts.
Require Import is_instantiable_oitval.
Require Import over_instrumented_semantics.

Require Import injection_operational_semantics.
Require Import ldna_in.
Require Import ldna_in_facts.
Require Import proof_injection_op_sem.

Require Import instrumented_values.
Require Import instrumented_semantics.
Require Import itval_val_conversion.
Require Import oival_ival_conversion.
Require Import oival_ival_conversion_facts.

Definition dummy_val := V_Num 0.
Definition dummy_oival := OIV_Num 0.

(* SIMPLE VALUES *)

Inductive partially_approximated_val : val -> val -> Prop :=
| PApprox_val_approx :
    forall (v:val),
      partially_approximated_val v dummy_val
| PApprox_val_Num :
    forall (n:Z),
      partially_approximated_val (V_Num n) (V_Num n)
| PApprox_val_Bool :
    forall (b:bool),
      partially_approximated_val (V_Bool b) (V_Bool b)
| PApprox_val_Constr0 :
    forall (n:constr),
      partially_approximated_val (V_Constr0 n) (V_Constr0 n)
| PApprox_val_Constr1 :
    forall (n:constr) (v v':val),
      partially_approximated_val v v'
      -> partially_approximated_val (V_Constr1 n v) (V_Constr1 n v')
| PApprox_val_Couple :
    forall (v1 v1' v2 v2':val),
    partially_approximated_val v1 v1'
    -> partially_approximated_val v2 v2'
    -> partially_approximated_val (V_Couple v1 v2) (V_Couple v1' v2')
| PApprox_val_Closure :
    forall (x:identifier) (e:expr) (c c':env),
      partially_approximated_env c c'
      -> partially_approximated_val (V_Closure x e c) (V_Closure x e c')
| PApprox_val_Rec_Closure :
    forall (f x:identifier) (e:expr) (c c':env),
      partially_approximated_env c c'
      -> partially_approximated_val (V_Rec_Closure f x e c) (V_Rec_Closure f x e c')

with partially_approximated_env : env -> env -> Prop :=
| PApprox_env_empty :
    partially_approximated_env Env_empty Env_empty
| PApprox_env_cons :
    forall (x:identifier) (v v':val) (c c':env),
    partially_approximated_val v v'
    -> partially_approximated_env c c'
    -> partially_approximated_env (Env_cons x v c) (Env_cons x v' c').

(* OVER-INSTRUMENTED VALUES *)

Inductive partially_approximated_oitdeps_fun : (val->bool) -> (val->bool) -> Prop :=
| PApprox_oitdeps_fun :
    forall (tf tf':val->bool),
      (forall (vl:val), tf' vl = true \/ tf' vl = tf vl)
      -> partially_approximated_oitdeps_fun tf tf'.

Inductive partially_approximated_oitdeps : oitdeps -> oitdeps -> Prop :=
| PApprox_oitdeps_empty :
    partially_approximated_oitdeps nil nil
| PApprox_oitdeps_cons :
    forall (oitd oitd':oitdeps) (l:label) (tf tf':val->bool),
      partially_approximated_oitdeps oitd oitd'
      -> partially_approximated_oitdeps_fun tf tf'
      -> partially_approximated_oitdeps (cons (l,tf) oitd) (cons (l,tf') oitd').

Inductive partially_approximated_oideps_fun : (val->val) -> (val->val) -> Prop :=
| PApprox_oideps_fun :
    forall (f f':val->val),
      (forall (vl:val), partially_approximated_val (f vl) (f' vl))
      -> partially_approximated_oideps_fun f f'.

Inductive partially_approximated_oideps : oideps -> oideps -> Prop :=
| PApprox_oideps_empty :
    partially_approximated_oideps nil nil
| PApprox_oideps_cons :
    forall (oid oid':oideps) (l:label) (f f':val->val),
      partially_approximated_oideps oid oid'
      -> partially_approximated_oideps_fun f f'
      -> partially_approximated_oideps (cons (l,f) oid) (cons (l,f') oid').

(* express that oiu2 is a partial approximation of oiu1 *)
Inductive partially_approximated_oival0 : oival0 -> oival0 -> Prop :=
| PApprox_oival0_approx :
    forall (v:oival0),
      partially_approximated_oival0 v (OIV_Num 0)
| PApprox_oival0_Num :
    forall (n:Z),
    partially_approximated_oival0 (OIV_Num n) (OIV_Num n)
| PApprox_oival0_Bool :
    forall (b:bool),
    partially_approximated_oival0 (OIV_Bool b) (OIV_Bool b)
| PApprox_oival0_Constr0 :
    forall (n:constr),
    partially_approximated_oival0 (OIV_Constr0 n) (OIV_Constr0 n)
| PApprox_oival0_Constr1 :
    forall (oiu oiu':oival) (n:constr),
    partially_approximated_oival oiu oiu'
    -> partially_approximated_oival0 (OIV_Constr1 n oiu) (OIV_Constr1 n oiu')
| PApprox_oival0_Couple :
    forall (oiu1 oiu2 oiu1' oiu2':oival),
    partially_approximated_oival oiu1 oiu1'
    -> partially_approximated_oival oiu2 oiu2'
    -> partially_approximated_oival0 (OIV_Couple oiu1 oiu2) (OIV_Couple oiu1' oiu2')
| PApprox_oival0_Closure :
    forall (oic oic':oienv) (x:identifier) (e:expr),
    partially_approximated_oienv oic oic'
    -> partially_approximated_oival0 (OIV_Closure x e oic) (OIV_Closure x e oic')
| PApprox_oival0_Rec_Closure :
    forall (oic oic':oienv) (f x:identifier) (e:expr),
    partially_approximated_oienv oic oic'
    -> partially_approximated_oival0 (OIV_Rec_Closure f x e oic) (OIV_Rec_Closure f x e oic')

with partially_approximated_oival : oival -> oival -> Prop :=
| PApprox_oival :
    forall (oid oid':oideps) (oiv oiv':oival0),
    partially_approximated_oideps oid oid'
    -> partially_approximated_oival0 oiv oiv'
    -> partially_approximated_oival (OIV_ oid oiv) (OIV_ oid' oiv')

with partially_approximated_oienv : oienv -> oienv -> Prop :=
| PApprox_oienv_empty :
    partially_approximated_oienv OIEnv_empty OIEnv_empty
| PApprox_oienv_cons :
    forall (x:identifier) (oiu oiu':oival) (oic oic':oienv),
    partially_approximated_oival oiu oiu'
    -> partially_approximated_oienv oic oic'
    -> partially_approximated_oienv (OIEnv_cons x oiu oic) (OIEnv_cons x oiu' oic').

Inductive partially_approximated_oitval : oitval -> oitval -> Prop :=
| PApprox_oitval :
    forall (oitd oitd':oitdeps) (oiu oiu':oival),
    partially_approximated_oitdeps oitd oitd'
    -> partially_approximated_oival oiu oiu'
    -> partially_approximated_oitval (OIV oitd oiu) (OIV oitd' oiu').

Inductive partially_approximated_oitenv : oitenv -> oitenv -> Prop :=
| PApprox_oitenv_empty :
    partially_approximated_oitenv OITEnv_empty OITEnv_empty
| PApprox_oitenv_cons :
    forall (x:identifier) (oitu oitu':oitval) (oitc oitc':oitenv),
    partially_approximated_oitval oitu oitu'
    -> partially_approximated_oitenv oitc oitc'
    -> partially_approximated_oitenv (OITEnv_cons x oitu oitc) (OITEnv_cons x oitu' oitc').

(*
TODO: déplacer l'explication hors du code source Coq

explications:
- pa_oid possède 2 cas à cause de la règle Annot (qui ajoute un f non approximé dans d)
- pa_oitd possède 2 cas à cause des 3 deps_spec_... qui propagent l'approx
-
à part ça, le reste est équivalent à oitval_to_itval_to_oitval

pa_oitd_fun =
| forall vl, tf' vl = true OR tf' vl = tf vl
pa_oitd =
| nil
| cons: tf = pa_oitd_fun, oitd = pa_oitd

pa_oid_fun =
| forall vl, f' vl = dummy_val OR f' vl = f vl
pa_oid =
| nil
| cons: f = pa_oid_fun, oid = pa_oid

pa_oienv =
| empty
| cons: oiu = pa_oival, oic = pa_oienv

pa_oival0 =
| same (num, bool, constr0)
| constr1: u = pa_oival
| closure: c = pa_oienv
| rec: c = pa_oienv
| couple: u1 = pa_oival, u2 = pa_oival

pa_oival =
|d' = pa_oid, v = pa_oival0

pa_oitval =
|td' = pa_oitd, u = pa_oival

à l'endroit où on utilisait le lemme oival_of_in_approximated_oitenv_via_itenv, on avait une évaluation dans un environnement complètement approximé (oitenv_to_itenv_to_oitenv, donc le lemme suivant nous suffirait:
si éval dans env approx donne oitu
alors on a éval dans env qui donne oitu'
      et oitu = partial_approx oitu'
mais la preuve par induction nécessite une hypothèse moins forte:
si éval dans env partial_approx donne oitu
alors on a éval dans env qui donne oitu'
      et oitu = partial_approx oitu'

 *)

(* STRICT FOR OVER-INSTRUMENTED VALUES *)

(* express that oiu2 is a partial approximation of oiu1 *)
Inductive strictly_partially_approximated_oival0 : oival0 -> oival0 -> Prop :=
| SPApprox_oival0_Num :
    forall (n:Z),
    strictly_partially_approximated_oival0 (OIV_Num n) (OIV_Num n)
| SPApprox_oival0_Bool :
    forall (b:bool),
    strictly_partially_approximated_oival0 (OIV_Bool b) (OIV_Bool b)
| SPApprox_oival0_Constr0 :
    forall (n:constr),
    strictly_partially_approximated_oival0 (OIV_Constr0 n) (OIV_Constr0 n)
| SPApprox_oival0_Constr1 :
    forall (oiu oiu':oival) (n:constr),
    strictly_partially_approximated_oival oiu oiu'
    -> strictly_partially_approximated_oival0 (OIV_Constr1 n oiu) (OIV_Constr1 n oiu')
| SPApprox_oival0_Couple :
    forall (oiu1 oiu2 oiu1' oiu2':oival),
    strictly_partially_approximated_oival oiu1 oiu1'
    -> strictly_partially_approximated_oival oiu2 oiu2'
    -> strictly_partially_approximated_oival0 (OIV_Couple oiu1 oiu2) (OIV_Couple oiu1' oiu2')
| SPApprox_oival0_Closure :
    forall (oic oic':oienv) (x:identifier) (e:expr),
    strictly_partially_approximated_oienv oic oic'
    -> strictly_partially_approximated_oival0 (OIV_Closure x e oic) (OIV_Closure x e oic')
| SPApprox_oival0_Rec_Closure :
    forall (oic oic':oienv) (f x:identifier) (e:expr),
    strictly_partially_approximated_oienv oic oic'
    -> strictly_partially_approximated_oival0 (OIV_Rec_Closure f x e oic) (OIV_Rec_Closure f x e oic')

with strictly_partially_approximated_oival : oival -> oival -> Prop :=
| SPApprox_oival :
    forall (oid oid':oideps) (oiv oiv':oival0),
    partially_approximated_oideps oid oid'
    -> strictly_partially_approximated_oival0 oiv oiv'
    -> strictly_partially_approximated_oival (OIV_ oid oiv) (OIV_ oid' oiv')

with strictly_partially_approximated_oienv : oienv -> oienv -> Prop :=
| SPApprox_oienv_empty :
    strictly_partially_approximated_oienv OIEnv_empty OIEnv_empty
| SPApprox_oienv_cons :
    forall (x:identifier) (oiu oiu':oival) (oic oic':oienv),
    strictly_partially_approximated_oival oiu oiu'
    -> strictly_partially_approximated_oienv oic oic'
    -> strictly_partially_approximated_oienv (OIEnv_cons x oiu oic) (OIEnv_cons x oiu' oic').

Inductive strictly_partially_approximated_oitval : oitval -> oitval -> Prop :=
| SPApprox_oitval :
    forall (oitd oitd':oitdeps) (oiu oiu':oival),
    partially_approximated_oitdeps oitd oitd'
    -> strictly_partially_approximated_oival oiu oiu'
    -> strictly_partially_approximated_oitval (OIV oitd oiu) (OIV oitd' oiu').

Inductive strictly_partially_approximated_oitenv : oitenv -> oitenv -> Prop :=
| SPApprox_oitenv_empty :
    strictly_partially_approximated_oitenv OITEnv_empty OITEnv_empty
| SPApprox_oitenv_cons :
    forall (x:identifier) (oitu oitu':oitval) (oitc oitc':oitenv),
    strictly_partially_approximated_oitval oitu oitu'
    -> strictly_partially_approximated_oitenv oitc oitc'
    -> strictly_partially_approximated_oitenv (OITEnv_cons x oitu oitc) (OITEnv_cons x oitu' oitc').

(*** TACTIC ***)

Ltac auto_papprox :=
  match goal with
    | |- partially_approximated_val _ dummy_val => apply PApprox_val_approx; auto_papprox
    | |- partially_approximated_val _ (V_Num 0) => apply PApprox_val_approx; auto_papprox
    | |- partially_approximated_val (V_Num _) _ => apply PApprox_val_Num; auto_papprox
    | |- partially_approximated_val (V_Bool _) _ => apply PApprox_val_Bool; auto_papprox
    | |- partially_approximated_val (V_Constr0 _) _ => apply PApprox_val_Constr0; auto_papprox
    | |- partially_approximated_val (V_Constr1 _ _) _ => apply PApprox_val_Constr1; auto_papprox
    | |- partially_approximated_val (V_Couple _ _) _ => apply PApprox_val_Couple; auto_papprox
    | |- partially_approximated_val (V_Closure _ _ _) _ => apply PApprox_val_Closure; auto_papprox
    | |- partially_approximated_val (V_Rec_Closure _ _ _ _) _ => apply PApprox_val_Rec_Closure; auto_papprox
    | |- partially_approximated_env (Env_empty) _ => apply PApprox_env_empty; auto_papprox
    | |- partially_approximated_env (Env_cons _ _ _) _ => apply PApprox_env_cons; auto_papprox
    | |- partially_approximated_oitdeps nil nil => apply PApprox_oitdeps_empty; auto_papprox
    | |- partially_approximated_oitdeps (cons _ _) _ => apply PApprox_oitdeps_cons; auto_papprox
    | |- partially_approximated_oideps nil nil => apply PApprox_oideps_empty; auto_papprox
    | |- partially_approximated_oideps (cons _ _) _ => apply PApprox_oideps_cons; auto_papprox
    | |- partially_approximated_oitval _ _ => apply PApprox_oitval; auto_papprox
    | |- partially_approximated_oival _ _ => apply PApprox_oival; auto_papprox
    | |- partially_approximated_oival0 _ (OIV_Num 0) => apply PApprox_oival0_approx; auto_papprox
    | |- partially_approximated_oival0 (OIV_Num _) _ => apply PApprox_oival0_Num; auto_papprox
    | |- partially_approximated_oival0 (OIV_Bool _) _ => apply PApprox_oival0_Bool; auto_papprox
    | |- partially_approximated_oival0 (OIV_Constr0 _) _ => apply PApprox_oival0_Constr0; auto_papprox
    | |- partially_approximated_oival0 (OIV_Constr1 _ _) _ => apply PApprox_oival0_Constr1; auto_papprox
    | |- partially_approximated_oival0 (OIV_Couple _ _) _ => apply PApprox_oival0_Couple; auto_papprox
    | |- partially_approximated_oival0 (OIV_Closure _ _ _) _ => apply PApprox_oival0_Closure; auto_papprox
    | |- partially_approximated_oival0 (OIV_Rec_Closure _ _ _ _) _ => apply PApprox_oival0_Rec_Closure; auto_papprox
    | |- partially_approximated_oienv OIEnv_empty OIEnv_empty => apply PApprox_oienv_empty; auto_papprox
    | |- partially_approximated_oienv (OIEnv_cons _ _ _) (OIEnv_cons _ _ _) =>
      apply PApprox_oienv_cons; auto_papprox
    | |- partially_approximated_oitenv OITEnv_empty OITEnv_empty => apply PApprox_oitenv_empty; auto_papprox
    | |- partially_approximated_oitenv (OITEnv_cons _ _ _) (OITEnv_cons _ _ _) =>
      apply PApprox_oitenv_cons; auto_papprox

    | |- strictly_partially_approximated_oitval _ _ => apply SPApprox_oitval; auto_papprox
    | |- strictly_partially_approximated_oival _ _ => apply SPApprox_oival; auto_papprox
    | |- strictly_partially_approximated_oival0 (OIV_Num _) _ => apply SPApprox_oival0_Num; auto_papprox
    | |- strictly_partially_approximated_oival0 (OIV_Bool _) _ => apply SPApprox_oival0_Bool; auto_papprox
    | |- strictly_partially_approximated_oival0 (OIV_Constr0 _) _ => apply SPApprox_oival0_Constr0; auto_papprox
    | |- strictly_partially_approximated_oival0 (OIV_Constr1 _ _) _ => apply SPApprox_oival0_Constr1; auto_papprox
    | |- strictly_partially_approximated_oival0 (OIV_Couple _ _) _ => apply SPApprox_oival0_Couple; auto_papprox
    | |- strictly_partially_approximated_oival0 (OIV_Closure _ _ _) _ => apply SPApprox_oival0_Closure; auto_papprox
    | |- strictly_partially_approximated_oival0 (OIV_Rec_Closure _ _ _ _) _ => apply SPApprox_oival0_Rec_Closure; auto_papprox
    | |- strictly_partially_approximated_oienv OIEnv_empty OIEnv_empty => apply SPApprox_oienv_empty; auto_papprox
    | |- strictly_partially_approximated_oienv (OIEnv_cons _ _ _) (OIEnv_cons _ _ _) =>
      apply SPApprox_oienv_cons; auto_papprox
    | |- strictly_partially_approximated_oitenv OITEnv_empty OITEnv_empty => apply SPApprox_oitenv_empty; auto_papprox
    | |- strictly_partially_approximated_oitenv (OITEnv_cons _ _ _) (OITEnv_cons _ _ _) =>
      apply SPApprox_oitenv_cons; auto_papprox
    | |- _ => auto
  end.

(*** FACTS  ***)

Lemma partially_approximated_val_refl :
  forall v : val, partially_approximated_val v v.
Proof.
  apply (val_ind2
           (fun v => partially_approximated_val v v)
           (fun c => partially_approximated_env c c));
  intros; auto_papprox.
Qed.

Lemma partially_approximated_env_refl :
  forall c : env, partially_approximated_env c c.
Proof.
  apply (env_ind2
           (fun v => partially_approximated_val v v)
           (fun c => partially_approximated_env c c));
  intros; auto_papprox.
Qed.

Lemma partially_approximated_oitdeps_fun_refl :
  forall tf : val->bool, partially_approximated_oitdeps_fun tf tf.
Proof.
  intros tf.
  apply PApprox_oitdeps_fun.
  intros vl.
  right; auto.
Qed.

Lemma partially_approximated_oitdeps_refl :
  forall oitd : oitdeps, partially_approximated_oitdeps oitd oitd.
Proof.
  induction oitd; auto_papprox.
  destruct a as [l f].
  auto_papprox.
  apply partially_approximated_oitdeps_fun_refl.
Qed.

Lemma partially_approximated_oideps_fun_refl :
  forall f : val->val, partially_approximated_oideps_fun f f.
Proof.
  intros f.
  apply PApprox_oideps_fun.
  intros vl.
  apply partially_approximated_val_refl.
Qed.

Lemma partially_approximated_oideps_refl :
  forall oid : oideps, partially_approximated_oideps oid oid.
Proof.
  induction oid; auto_papprox.
  destruct a as [l f].
  auto_papprox.
  apply partially_approximated_oideps_fun_refl.
Qed.

Lemma strictly_partially_approximated_oival_refl :
  forall oiu : oival, strictly_partially_approximated_oival oiu oiu.
Proof.
  apply (oival_ind2
           (fun oiu => strictly_partially_approximated_oival oiu oiu)
           (fun oiv => strictly_partially_approximated_oival0 oiv oiv)
           (fun oic => strictly_partially_approximated_oienv oic oic));
  intros;  auto_papprox.
  apply partially_approximated_oideps_refl.
Qed.

Lemma strictly_partially_approximated_oitenv_refl :
  forall oitc : oitenv, strictly_partially_approximated_oitenv oitc oitc.
Proof.
  apply (oitenv_ind2
           (fun oitu => strictly_partially_approximated_oitval oitu oitu)
           (fun oitc => strictly_partially_approximated_oitenv oitc oitc));
  intros;  auto_papprox.
  apply partially_approximated_oitdeps_refl.
  apply strictly_partially_approximated_oival_refl.
Qed.

(*** FACTS ABOUT INSTANTIATION ***)

Lemma aif_in_partially_approximated_oideps_some :
  forall (oid oid':oideps) (l:label) (vl v':val),
  partially_approximated_oideps oid oid'
  -> apply_impact_fun l vl oid' = Some v'
  -> exists (v:val), apply_impact_fun l vl oid = Some v
    /\ partially_approximated_val v v'.
Proof.
  intros oid oid' l vl v' H H0.
  induction H.

  inversion H0.

  simpl in H0.
  destruct (eq_label_dec l l0) eqn:H_l_l0.

  (* l = l0 *)
  induction H1.
  specialize (H1 vl).
  inversion H1; inversion H0.

  exists (f vl); simpl; rewrite H_l_l0; split; auto_papprox.

  exists (V_Num n); simpl; rewrite H_l_l0, <-H3, <-H4; split; auto_papprox.
  exists (V_Bool b); simpl; rewrite H_l_l0, <-H3, <-H4; split; auto_papprox.
  exists (V_Constr0 n); simpl; rewrite H_l_l0, <-H3, <-H4; split; auto_papprox.
  exists (V_Constr1 n v); simpl; rewrite H_l_l0, <-H2, <-H3; split; auto_papprox.
  exists (V_Couple v1 v2); simpl; rewrite H_l_l0, <-H2, <-H3; split; auto_papprox.
  exists (V_Closure x e0 c); simpl; rewrite H_l_l0, <-H2, <-H3; split; auto_papprox.
  exists (V_Rec_Closure f0 x e0 c); simpl; rewrite H_l_l0, <-H2, <-H3; split; auto_papprox.

  (* l <> l0 *)
  specialize (IHpartially_approximated_oideps H0).
  inversion IHpartially_approximated_oideps as [v HH].
  inversion HH as [H_aif_oid H_papprox_v].
  exists v.
  simpl.
  rewrite H_l_l0.
  split; auto.
Qed.

Lemma aif_in_partially_approximated_oideps_none :
  forall (oid oid':oideps) (l:label) (vl:val),
  partially_approximated_oideps oid oid'
  -> apply_impact_fun l vl oid' = None
  -> apply_impact_fun l vl oid = None.
Proof.
  intros oid oid' l vl H H0.
  induction H; auto.

  simpl; simpl in H0.
  destruct (eq_label_dec l l0).
  inversion H0.
  auto.
Qed.

Lemma atif_in_partially_approximated_oitdeps_some_true :
  forall (oitd oitd':oitdeps) (l:label) (vl:val),
  partially_approximated_oitdeps oitd oitd'
  -> apply_timpact_fun l vl oitd' <> Some true
  -> apply_timpact_fun l vl oitd <> Some true.
Proof.
  intros oitd oitd' l vl H H0.
  induction H; auto.

  simpl; simpl in H0.
  destruct (eq_label_dec l l0).

  inversion H1.
  specialize (H2 vl).
  inversion_clear H2.
  rewrite H5 in H0.
  simpl in H0.
  destruct (apply_timpact_fun l vl oitd'); elim (H0 eq_refl).
  rewrite <-H5.

  assert(HH: apply_timpact_fun l vl oitd' <> Some true).
  intro HH; rewrite HH in H0; simpl in H0; rewrite Bool.orb_true_intro in H0; auto.
  rewrite utils.match_option_bool_not_true2 in H0; auto.
  apply IHpartially_approximated_oitdeps in HH.
  rewrite utils.match_option_bool_not_true2; auto.
  auto.
Qed.

Lemma instantiate_partially_approximated_oival :
  forall (oiu oiu':oival) (l:label) (vl v':val),
  partially_approximated_oival oiu oiu'
  -> instantiate_oival l vl oiu' = Some v'
  -> exists (v:val), instantiate_oival l vl oiu = Some v
                     /\ partially_approximated_val v v'.
Proof.
  apply (oival_ind2
    (fun oiu => forall (oiu':oival) (l:label) (vl v':val),
      partially_approximated_oival oiu oiu'
      -> instantiate_oival l vl oiu' = Some v'
      -> exists (v:val), instantiate_oival l vl oiu = Some v
        /\ partially_approximated_val v v')
    (fun oiv => forall (oiv':oival0) (l:label) (vl v':val),
      partially_approximated_oival0 oiv oiv'
      -> instantiate_oival0 l vl oiv' = Some v'
      -> exists (v:val), instantiate_oival0 l vl oiv = Some v
        /\ partially_approximated_val v v')
    (fun oic => forall (oic':oienv) (l:label) (vl:val) (c':env),
      partially_approximated_oienv oic oic'
      -> instantiate_oienv l vl oic' = Some c'
      -> exists (c:env), instantiate_oienv l vl oic = Some c
        /\ partially_approximated_env c c')).

  (* case oival *)
  intros d vv H oiu' l vl v' H0 H1.
  inversion H0.
  rewrite <-H5 in H1.
  simpl in H1.

  destruct (apply_impact_fun l vl oid') eqn:H_aif_oid'.

  (** l is in oid *)
  rewrite H1 in H_aif_oid'; clear H1 v.
  apply aif_in_partially_approximated_oideps_some with (oid:=d) in H_aif_oid'; auto.
  inversion_clear H_aif_oid' as [v HH].
  inversion_clear HH as [H_aif_oid H_papprox_v].
  exists v.
  simpl.
  rewrite H_aif_oid.
  auto.

  (** l is not in oid *)
  apply aif_in_partially_approximated_oideps_none with (oid:=d) in H_aif_oid'; auto.
  rename H_aif_oid' into H_aif_oid.
  specialize(H oiv' l vl v' H6 H1).
  inversion_clear H as [v HH].
  inversion_clear HH as [H_inst_vv H_papprox_v].
  exists v.
  simpl.
  rewrite H_aif_oid.
  auto.

  (* case oival0 Num *)
  intros n oiv' l vl v' H H0.
  inversion H;
    [rewrite <-H2 in H0|rewrite <-H1 in H0];
    inversion H0;
    exists (V_Num n);
    split; auto_papprox.

  (* case oival0 Bool *)
  intros b oiv' l vl v' H H0.
  inversion H;
  [rewrite <-H2 in H0|rewrite <-H1 in H0];
    inversion H0;
    exists (V_Bool b);
    split; auto_papprox.

  (* case oival0 Constr0 *)
  intros n oiv' l vl v' H H0.
  inversion H;
  [rewrite <-H2 in H0|rewrite <-H1 in H0];
    inversion H0;
    exists (V_Constr0 n);
    split; auto_papprox.

  (* case oival0 Constr1 *)
  intros n u H oiv' l vl v' H0 H1.
  inversion H0;
  rewrite <-H3 in H1; simpl in H1.

  destruct (is_instantiable_oival u l vl) as [v0 H_inst_u];
  exists(V_Constr1 n v0);
  simpl; rewrite H_inst_u.
  inversion H1.
  split; simpl; auto_papprox.

  destruct(instantiate_oival l vl oiu') as [v'0|] eqn:H_inst_oiu'; try solve [inversion H1].
  simpl in H1.
  inversion H1.
  specialize(H oiu' l vl v'0 H5 H_inst_oiu').
  inversion_clear H as [v HH].
  inversion_clear HH as [H_inst_u H_papprox_v].
  exists (V_Constr1 n v).
  split; auto_papprox.
  simpl.
  rewrite H_inst_u; auto.

  (* case oival0 Closure *)
  intros x e oic H oiv' l vl v' H0 H1.
  inversion H0;
    rewrite <-H3 in H1; inversion H1.

  destruct (is_instantiable_oienv oic l vl) as [c H_inst_oic];
  exists(V_Closure x e c);
  simpl; rewrite H_inst_oic.
  inversion H1.
  split; simpl; auto_papprox.

  destruct(instantiate_oienv l vl oic') as [c'|] eqn:H_inst_oic'; try solve [inversion H8]; inversion H8.
  specialize(H oic' l vl c' H6 H_inst_oic').
  inversion_clear H as [c HH].
  inversion_clear HH as [H_inst_oic H_papprox_c].
  exists (V_Closure x e c).
  split; auto_papprox.
  simpl.
  rewrite H_inst_oic; auto.

  (* case oival0 Couple *)
  intros u1 H u2 H0 oiv' l vl v' H1 H2.
  inversion H1.

  rewrite <-H4 in H2; simpl in H2.
  destruct (is_instantiable_oival u1 l vl) as [v1 H_inst_u1];
  destruct (is_instantiable_oival u2 l vl) as [v2 H_inst_u2];
  exists(V_Couple v1 v2);
  simpl; rewrite H_inst_u1; rewrite H_inst_u2.
  inversion H2.
  split; simpl; auto_papprox.

  rewrite <-H6 in H2; simpl in H2.
  destruct(instantiate_oival l vl oiu1') as [v'1|] eqn:H_inst_oiu1'; try solve [inversion H2].
  destruct(instantiate_oival l vl oiu2') as [v'2|] eqn:H_inst_oiu2'; try solve [inversion H2].
  inversion_clear H2.
  specialize(H oiu1' l vl v'1 H5 H_inst_oiu1').
  inversion_clear H as [v1 HH].
  inversion_clear HH as [H_inst_u1 H_papprox_v1].
  specialize(H0 oiu2' l vl v'2 H7 H_inst_oiu2').
  inversion_clear H0 as [v2 HH].
  inversion_clear HH as [H_inst_u2 H_papprox_v2].
  exists(V_Couple v1 v2).
  split; auto_papprox.
  simpl; rewrite H_inst_u1, H_inst_u2; auto.

  (* case oival0 Rec_Closure *)
  intros f x e oic H oiv' l vl v' H0 H1.
  inversion H0;
    rewrite <-H3 in H1; inversion H1.

  destruct (is_instantiable_oienv oic l vl) as [c H_inst_oic];
  exists(V_Rec_Closure f x e c);
  simpl; rewrite H_inst_oic.
  inversion H1.
  split; simpl; auto_papprox.

  destruct(instantiate_oienv l vl oic') as [c'|] eqn:H_inst_oic'; try solve [inversion H9]; inversion H9.
  specialize(H oic' l vl c' H7 H_inst_oic').
  inversion_clear H as [c HH].
  inversion_clear HH as [H_inst_oic H_papprox_c].
  exists (V_Rec_Closure f x e c).
  split; auto_papprox.
  simpl.
  rewrite H_inst_oic; auto.

  (* case env empty *)
  intros oic' l vl c' H H0.
  inversion H.
  rewrite <-H2 in H0; inversion H0.
  exists Env_empty; split; auto_papprox.

  (* case env cons *)
  intros x u H oic'0 H0 oic' l vl c'0 H1 H2.
  inversion H1.
  rewrite <-H5 in H2; simpl in H2.
  destruct(instantiate_oival l vl oiu') as [v'|] eqn:H_inst_oiu'; try solve [inversion H2].
  destruct(instantiate_oienv l vl oic'1) as [c'1|] eqn:H_inst_oic'1; try solve [inversion H2]; inversion H2.
  inversion_clear H2.
  specialize(H oiu' l vl v' H7 H_inst_oiu').
  inversion_clear H as [v HH].
  inversion_clear HH as [H_inst_u H_papprox_v].
  specialize(H0 oic'1 l vl c'1 H8 H_inst_oic'1).
  inversion_clear H0 as [c HH].
  inversion_clear HH as [H_inst_oic' H_papprox_c].
  exists (Env_cons x v c).
  split; auto_papprox.
  simpl.
  rewrite H_inst_u, H_inst_oic'; auto.
Qed.

Lemma instantiate_partially_approximated_oitval :
  forall (oitu oitu':oitval) (l:label) (vl v':val),
  partially_approximated_oitval oitu oitu'
  -> instantiate_oitval l vl oitu' = Some v'
  -> exists (v:val), instantiate_oitval l vl oitu = Some v
                     /\ partially_approximated_val v v'.
Proof.
  intros oitu oitu' l vl v' H H0.
  inversion H.
  rewrite <-H4 in H0; simpl in H0.
  assert(HH: apply_timpact_fun l vl oitd' <> Some true); try solve [intro HH; rewrite HH in H0; inversion H0].
  rewrite utils.match_option_bool_not_true in H0; auto.
  destruct(instantiate_partially_approximated_oival oiu oiu' l vl v' H2 H0) as [v].
  inversion H5 as [H_inst_oiu H_papprox_v].
  exists (v).
  split; auto.
  simpl.
  rewrite utils.match_option_bool_not_true; auto.
  apply atif_in_partially_approximated_oitdeps_some_true with (oitd':=oitd'); auto.
Qed.

Lemma instantiate_partially_approximated_oitenv :
  forall (oitc oitc_:oitenv) (l:label) (vl:val) (c_:env),
  partially_approximated_oitenv oitc oitc_
  -> instantiate_oitenv l vl oitc_ = Some c_
  -> exists (c:env), instantiate_oitenv l vl oitc = Some c
                     /\ partially_approximated_env c c_.
Proof.
  intros oitc oitc_ l vl c_ H.
  revert c_.
  induction H; intros c_ H_inst_oitc_.
  exists c_; split; auto.
  apply partially_approximated_env_refl.

  simpl in H_inst_oitc_.
  destruct(instantiate_oitval l vl oitu') as [v'|] eqn:H_inst_oitu'; try solve [inversion H_inst_oitc_].
  destruct(instantiate_oitenv l vl oitc') as [c'|] eqn:H_inst_oitc'; try solve [inversion H_inst_oitc_].
  inversion_clear H_inst_oitc_.
  specialize (IHpartially_approximated_oitenv c' eq_refl).
  inversion_clear IHpartially_approximated_oitenv as [c HH].
  inversion_clear HH as [H_inst_oitc H_papprox_c].
  destruct(instantiate_partially_approximated_oitval _ _ _ _ _ H H_inst_oitu') as [v HH].
  inversion_clear HH as [H_inst_oitu H_papprox_v].
  exists (Env_cons x v c).
  simpl.
  rewrite H_inst_oitu, H_inst_oitc; simpl.
  split; auto_papprox.
Qed.

(*** FACTS ABOUT CONVERSION ***)

Lemma partially_approximated_val_to_oival :
  forall (v v_:val),
    partially_approximated_val v v_
    -> partially_approximated_oival (val_to_oival v) (val_to_oival v_).
Proof.
  intros v v_ H.

  apply (val_ind2
           (fun v => forall (v_:val), partially_approximated_val v v_
                     -> partially_approximated_oival (val_to_oival v) (val_to_oival v_))
           (fun c => forall (c_:env), partially_approximated_env c c_
                     -> partially_approximated_oienv (env_to_oienv c) (env_to_oienv c_)));
    intros; try inversion H2; try inversion H1; try inversion H0; simpl; auto_papprox.
Qed.

Lemma partially_approximated_val_to_oitval :
  forall (v v_:val),
    partially_approximated_val v v_
    -> partially_approximated_oitval (val_to_oitval v) (val_to_oitval v_).
Proof.
  intros v v_ H.

  unfold val_to_oitval; simpl; auto_papprox.
  apply partially_approximated_val_to_oival; auto.
Qed.

Lemma partially_approximated_env_to_oitenv :
  forall (c c_:env),
    partially_approximated_env c c_
    -> partially_approximated_oitenv (env_to_oitenv c) (env_to_oitenv c_).
Proof.
  intros c c_ H.

  induction H; simpl; auto_papprox.

  apply partially_approximated_val_to_oival; auto.
Qed.

(*** FACTS ABOUT TOTALLY-APPROXIMATED ***)

Lemma approximated_oitval_implies_strictly_partially_approximated :
  forall (oitu oitu':oitval),
    oitu' = itval_to_oitval (oitval_to_itval oitu)
    -> strictly_partially_approximated_oitval oitu oitu'.
Proof.
  intros oitu oitu' H.
  destruct oitu as [oitd oiu].
  destruct oitu' as [oitd' oiu'].
  inversion H.
  apply SPApprox_oitval with (oitd:=oitd) (oitd':=itdeps_to_oitdeps (oitdeps_to_itdeps oitd)) (oiu:=oiu) (oiu':=ival_to_oival (oival_to_ival oiu)); auto.

  (* oitdeps *)
  clear dependent oiu'.
  clear dependent oitd'.
  induction oitd.
  apply PApprox_oitdeps_empty.
  destruct a as [l f].
  simpl.
  apply PApprox_oitdeps_cons; auto.
  apply PApprox_oitdeps_fun; auto.

  (* oival *)
  clear dependent oiu'.
  clear dependent oitd'.
  apply (oival_ind2
           (fun oiu => strictly_partially_approximated_oival oiu (ival_to_oival (oival_to_ival oiu)))
           (fun oiv => strictly_partially_approximated_oival0 oiv (ival0_to_oival0 (oival0_to_ival0 oiv)))
           (fun oic => strictly_partially_approximated_oienv oic (ienv_to_oienv (oienv_to_ienv oic))));
    intros; simpl; auto_papprox.

  (* oideps *)
  induction d.
  apply PApprox_oideps_empty.
  destruct a as [l f].
  simpl.
  apply PApprox_oideps_cons; auto.
  apply PApprox_oideps_fun; auto.
  intros vl.
  auto_papprox.
Qed.

Lemma approximated_oitenv_implies_strictly_partially_approximated :
  forall (oitc oitc_:oitenv),
    oitc_ = itenv_to_oitenv (oitenv_to_itenv oitc)
    -> strictly_partially_approximated_oitenv oitc oitc_.
Proof.
  induction oitc; intros oitc_ H.

  inversion H; simpl; auto_papprox.

  simpl in H.
  rewrite H; auto_papprox.
  apply approximated_oitval_implies_strictly_partially_approximated; auto.
Qed.

(*** FACTS ABOUT TOTALLY-APPROXIMATED ***)

Lemma strictly_partially_approximated_oitval_implies_partially_approximated :
  forall (oitu oitu':oitval),
    strictly_partially_approximated_oitval oitu oitu'
    -> partially_approximated_oitval oitu oitu'.
Proof.
  intros oitu oitu' H.

  inversion H; simpl; auto_papprox.

  (* oitval *)
  clear H H0 H2 H3 oitd oitd' oitu oitu'.
  revert oiu' H1.
  apply (oival_ind2
           (fun oiu => forall oiu' : oival, strictly_partially_approximated_oival oiu oiu' ->
                                            partially_approximated_oival oiu oiu')
           (fun oiv => forall oiv' : oival0, strictly_partially_approximated_oival0 oiv oiv' ->
                                            partially_approximated_oival0 oiv oiv')
           (fun oic => forall oic' : oienv, strictly_partially_approximated_oienv oic oic' ->
                                            partially_approximated_oienv oic oic')
        );
    intros;
    try solve [inversion H; auto_papprox];
    try solve [inversion H0; auto_papprox];
    try solve [inversion H1; auto_papprox].
Qed.

Lemma strictly_partially_approximated_oitenv_implies_partially_approximated :
  forall (oitc oitc':oitenv),
    strictly_partially_approximated_oitenv oitc oitc'
    -> partially_approximated_oitenv oitc oitc'.
Proof.
  intros oitc oitc' H.
  induction H; auto_papprox.

  apply strictly_partially_approximated_oitval_implies_partially_approximated; auto.
Qed.

(*** FACTS ABOUT CONCATENATION ***)

Lemma partially_approximated_conc_oitenv :
  forall (oitc1 oitc1_ oitc2 oitc2_:oitenv),
    partially_approximated_oitenv oitc1 oitc1_
    -> partially_approximated_oitenv oitc2 oitc2_
    -> partially_approximated_oitenv (conc_oitenv oitc1 oitc2) (conc_oitenv oitc1_ oitc2_).
Proof.
  induction oitc1; intros oitc1_ oitc2 oitc2_ H H0; simpl.

  inversion H; simpl; auto.

  inversion H; simpl.
  auto_papprox.
Qed.

Lemma strictly_partially_approximated_conc_oitenv :
  forall (oitc1 oitc1_ oitc2 oitc2_:oitenv),
    strictly_partially_approximated_oitenv oitc1 oitc1_
    -> strictly_partially_approximated_oitenv oitc2 oitc2_
    -> strictly_partially_approximated_oitenv (conc_oitenv oitc1 oitc2) (conc_oitenv oitc1_ oitc2_).
Proof.
  induction oitc1; intros oitc1_ oitc2 oitc2_ H H0; simpl.

  inversion H; simpl; auto.

  inversion H; simpl.
  auto_papprox.
Qed.

(*** FACTS ABOUT IS_FILTERED_VAL ***)

Lemma is_filtered_partially_approximated_val :
  forall (c_p_:env) (v v_:val) (p:pattern),
    partially_approximated_val v v_
    -> is_filtered v_ p = Filtered_result_Match c_p_
    -> exists (c_p:env), is_filtered v p = Filtered_result_Match c_p
                              /\ partially_approximated_env c_p c_p_.
Proof.
  intros c_p_ v v_ p H H0.
  destruct v_; destruct p; inversion H0.

  (* case Constr0 *)
  destruct (eq_nat_dec n c) eqn:H_n_c; inversion H2.
  inversion H.
  exists Env_empty.
  simpl; rewrite H_n_c.
  split; auto_papprox.

  (* case Constr1 *)
  destruct (eq_nat_dec n c) eqn:H_n_c; inversion H2.
  inversion H.
  exists (Env_cons i v0 Env_empty).
  simpl; rewrite H_n_c.
  split; auto_papprox.

  (* case Couple *)
  inversion H.
  exists (Env_cons i v1 (Env_cons i0 v2 Env_empty)); simpl; split; auto_papprox.
Qed.

Lemma is_not_filtered_partially_approximated_val :
  forall (v v_:val) (p:pattern),
    partially_approximated_val v v_
    -> is_filtered v_ p = Filtered_result_Match_var
    -> is_filtered v p = Filtered_result_Match_var.
Proof.
  intros v v_ p H H0.
  destruct v_; destruct p; inversion H0; inversion H; auto.

  (* case Constr0 *)
  destruct (eq_nat_dec n c) eqn:H_n_c; inversion H2.
  simpl; rewrite H_n_c; auto.
Qed.

(*** FACTS ABOUT IS_FILTERED_OITVAL ***)

Lemma is_filtered_strictly_partially_approximated_oitval :
  forall (c_p_:oitenv) (oitu oitu_:oitval) (p:pattern),
    strictly_partially_approximated_oitval oitu oitu_
    -> is_filtered_oitval oitu_ p = Filtered_oitval_result_Match c_p_
    -> exists (c_p:oitenv), is_filtered_oitval oitu p = Filtered_oitval_result_Match c_p
                              /\ strictly_partially_approximated_oitenv c_p c_p_.
Proof.
  intros c_p_ oitu oitu_ p H H0.
  inversion H.
  inversion H2.
  destruct oiv'; destruct p;
  rewrite <-H4, <-H8 in H0; inversion H0.

  (* case Constr0 *)
  destruct (eq_nat_dec n c) eqn:H_n_c; inversion H10.
  inversion H6.
  exists OITEnv_empty.
  simpl; rewrite H_n_c.
  split; auto_papprox.

  (* case Constr1 *)
  destruct (eq_nat_dec n c) eqn:H_n_c; inversion H10.
  inversion H6.
  exists (OITEnv_cons i (OIV nil oiu0) OITEnv_empty).
  simpl; rewrite H_n_c.
  split; auto_papprox.

  (* case Couple *)
  inversion H6.
  exists (OITEnv_cons i (OIV nil oiu1) (OITEnv_cons i0 (OIV nil oiu2) OITEnv_empty)); simpl; split; auto_papprox.
Qed.

Lemma is_not_filtered_strictly_partially_approximated_oitval :
  forall (oitu oitu_:oitval) (p:pattern),
    strictly_partially_approximated_oitval oitu oitu_
    -> is_filtered_oitval oitu_ p = Filtered_oitval_result_Match_var
    -> is_filtered_oitval oitu p = Filtered_oitval_result_Match_var.
Proof.
  intros oitu oitu_ p H H0.
  inversion H.
  inversion H2.
  destruct oiv'; destruct p;
  rewrite <-H4, <-H8 in H0; inversion H0;
  inversion H6; auto.

  (* case Constr0 *)
  destruct (eq_nat_dec n c) eqn:H_n_c; inversion H10.
  simpl; rewrite H_n_c; auto.
Qed.

(*** FACTS ABOUT ASSOC_IN_OITENV ***)

Lemma assoc_in_partially_approximated_oitenv :
  forall (oitc oitc_:oitenv) (oitu_:oitval) (x:identifier),
    partially_approximated_oitenv oitc oitc_
    -> assoc_ident_in_oitenv x oitc_ = Ident_in_oitenv oitu_
    -> exists (oitu:oitval), assoc_ident_in_oitenv x oitc = Ident_in_oitenv oitu
                             /\ partially_approximated_oitval oitu oitu_.
Proof.
  intros oitc oitc_ oitu_ x H.
  induction H; intros H_assoc_in_oitc_; inversion H_assoc_in_oitc_.

  destruct (beq_identifier x x0) eqn:H_x_x0; inversion H2.

  exists oitu.
  simpl.
  rewrite H_x_x0, <-H3; auto.

  specialize (IHpartially_approximated_oitenv H2).
  inversion_clear IHpartially_approximated_oitenv as [oitu0 HH].
  inversion_clear HH.
  exists oitu0.
  simpl.
  rewrite H_x_x0; auto.
Qed.


(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs64.object.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope Z.
Local Open Scope logic.

Definition object_invariant := list Z -> val -> mpred.

Definition tobject := tptr (Tstruct _object noattr).

Definition reset_spec (instance: object_invariant) :=
  WITH self: val, history: list Z
  PRE [ tobject]
          PROP ()
          PARAMS (self)
          SEP (instance history self)
  POST [ tvoid ]
          PROP() RETURN () SEP(instance nil self).

Definition twiddle_spec (instance: object_invariant) :=
  WITH self: val, i: Z, history: list Z
  PRE [ tobject, tint]
          PROP (0 < i <= Int.max_signed / 4;
                0 <= fold_right Z.add 0 history <= Int.max_signed / 4)
          PARAMS (self; Vint (Int.repr i))
          SEP (instance history self)
  POST [ tint ]
      EX v: Z,
          PROP(2* fold_right Z.add 0 history < v <= 2* fold_right Z.add 0 (i::history))
          RETURN (Vint (Int.repr v))
          SEP(instance (i::history) self).

Definition object_methods (instance: object_invariant) (mtable: val) : mpred :=
  EX sh: share, EX reset: val, EX twiddle: val,
  !! readable_share sh &&
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset,twiddle) mtable.

Lemma object_methods_local_facts: forall instance p,
  object_methods instance p |-- !! isptr p.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.
entailer!.
Qed.
#[export] Hint Resolve object_methods_local_facts : saturate_local.

Definition object_mpred (history: list Z) (self: val) : mpred :=
  EX instance: object_invariant, EX mtable: val,
       (object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self*
     instance history self).

Definition foo_invariant : object_invariant :=
  (fun (history: list Z) p =>
    withspacer Ews (sizeof size_t + sizeof tint) (2 * sizeof size_t) (field_at Ews (Tstruct _foo_object noattr)
            [StructField _data] (Vint (Int.repr (2*fold_right Z.add 0 history)))) p
      *  malloc_token Ews (Tstruct _foo_object noattr) p).

Definition foo_reset_spec :=
 DECLARE _foo_reset (reset_spec foo_invariant).

Definition foo_twiddle_spec :=
 DECLARE _foo_twiddle  (twiddle_spec foo_invariant).

Definition make_foo_spec :=
 DECLARE _make_foo
 WITH gv: globals
 PRE [ ]
    PROP () PARAMS() GLOBALS (gv)
    SEP (mem_mgr gv; object_methods foo_invariant (gv _foo_methods))
 POST [ tobject ]
    EX p: val, PROP () RETURN (p)
     SEP (mem_mgr gv; object_mpred nil p; object_methods foo_invariant (gv _foo_methods)).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     EX i:Z, PROP(0<=i<=6) RETURN (Vint (Int.repr i)) SEP(TT).

Definition Gprog : funspecs :=   ltac:(with_library prog [
    foo_reset_spec; foo_twiddle_spec; make_foo_spec; main_spec]).

Lemma object_mpred_i:
  forall (history: list Z) (self: val) (instance: object_invariant) (mtable: val),
    object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self *
     instance history self
    |-- object_mpred history self.
Proof.
intros. unfold object_mpred. Exists instance mtable; auto.
Qed.

Lemma body_foo_reset: semax_body Vprog Gprog f_foo_reset foo_reset_spec.
Proof.
unfold foo_reset_spec, foo_invariant, reset_spec.
start_function.
unfold withspacer; simpl; Intros.
forward.  (* self->data=0; *)
entailer!!.
all: unfold withspacer; simpl; entailer!!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_foo_twiddle: semax_body Vprog Gprog f_foo_twiddle foo_twiddle_spec.
Proof.
unfold foo_twiddle_spec, foo_invariant, twiddle_spec.
start_function.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)
forward.  (* self -> data = d+2*i; *)
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!!.
forward.  (* return d+i; *)
simpl.
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!!.
Exists (2 * fold_right Z.add 0 history + i).
simpl;
entailer!!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!!.
Qed.

Lemma split_object_methods:
  forall instance m,
    object_methods instance m |-- object_methods instance m * object_methods instance m.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.

Exists (fst (slice.cleave sh)) reset twiddle.
Exists (snd (slice.cleave sh)) reset twiddle.
rewrite (split_func_ptr' (reset_spec instance) reset) at 1.
rewrite (split_func_ptr' (twiddle_spec instance) twiddle) at 1.
entailer!!.
split.
apply slice.cleave_readable1; auto.
apply slice.cleave_readable2; auto.
rewrite (data_at_share_join (fst (slice.cleave sh)) (snd (slice.cleave sh)) sh).
auto.
apply slice.cleave_join.
Qed.

Lemma body_make_foo: semax_body Vprog Gprog f_make_foo make_foo_spec.
Proof.
unfold make_foo_spec.
start_function.
forward_call (Tstruct _foo_object noattr, gv).
Intros p.
forward_if
  (PROP ( )
   LOCAL (temp _p p; gvars gv)
   SEP (mem_mgr gv;
          malloc_token Ews (Tstruct _foo_object noattr) p;
          data_at_ Ews (Tstruct _foo_object noattr) p;
          object_methods foo_invariant (gv _foo_methods))).
*
change (EqDec_val p nullval) with (eq_dec p nullval).
if_tac; entailer!!.
*
forward_call 1.
contradiction.
*
rewrite if_false by auto.
Intros.
forward.  (*  /*skip*/;  *)
entailer!!.
*
unfold data_at_, field_at_, default_val; simpl.
forward. (* p->mtable = &foo_methods; *)
forward. (* p->data = 0; *)
forward. (* return (struct object * ) p; *)
Exists p.
unfold object_mpred.
Exists foo_invariant (gv _foo_methods).
sep_apply (split_object_methods foo_invariant (gv _foo_methods)).
unfold foo_invariant at 4.
entailer!!.
simpl.
unfold_data_at (field_at _ _ nil _ p).
cancel.
unfold withspacer; simpl.
rewrite !field_at_data_at.
simpl.
apply derives_refl'.
rewrite <- ?sepcon_assoc. (* needed if Archi.ptr64=true *)
rewrite !field_compatible_field_address; auto with field_compatible.
clear - H.
(* TODO: simplify the following proof. *)
destruct p; try contradiction.
destruct H as [AL SZ].
repeat split; auto.
simpl in *.  unfold sizeof in *; simpl in *; lia.
eapply align_compatible_rec_Tstruct; [reflexivity.. |].
simpl co_members; intros.
simpl in H.
if_tac in H; [| inv H].
inv H. inv H0.
eapply align_compatible_rec_by_value.
reflexivity.
rewrite Z.add_0_r.
simpl.
unfold natural_alignment in AL.
eapply Z.divide_trans; [ | apply AL].
apply prove_Zdivide.
reflexivity.
left; auto.
Qed.

Lemma make_object_methods:
  forall sh instance reset twiddle mtable,
  readable_share sh ->
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset, twiddle) mtable
  |-- object_methods instance mtable.
Proof.
  intros.
  unfold object_methods.
  Exists sh reset twiddle.
  entailer!!.
Qed.

Ltac method_call witness hist' result :=
repeat apply seq_assoc1;
match goal with
   |- semax _ (PROPx _ (LOCALx ?Q (SEPx ?R)))
            (Ssequence (Sset ?mt (Efield (Ederef (Etempvar ?x _)  _) _ _))
                 _) _  =>
    match Q with context [temp ?x ?x'] =>
     match R with context [object_mpred _ x'] =>
          let instance := fresh "instance" in let mtable := fresh "mtable" in
          unfold object_mpred; Intros instance mtable;
          forward;
          unfold object_methods at 1;
          let sh := fresh "sh" in let r := fresh "r" in let t := fresh "t" in
          Intros sh r t;
          forward;
          forward_call witness;
          [ .. | try Intros result;
                  sep_apply (make_object_methods sh instance r t mtable); [ auto .. | ];
                  sep_apply (object_mpred_i hist' x' instance mtable);
                  deadvars; try clear dependent sh; try clear r; try clear t
           ]
    end end
end.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv).
(* assert_gvar _foo_methods. (* TODO: this is needed for a field_compatible later on *) *)
fold noattr cc_default.
(* 0. This part should be handled automatically by start_function *)
gather_SEP (mapsto _ _ _ _) (data_at _ _ _ _);
replace_SEP 0 (data_at Ews (Tstruct _methods noattr)
   (gv _foo_reset, gv _foo_twiddle) (gv _foo_methods)). {
  entailer!.
  unfold_data_at (data_at _ (Tstruct _methods _) _ (gv _foo_methods)).
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddle]) (v:= (gv _foo_twiddle))
  by  auto with field_compatible.
  rewrite field_at_data_at.  rewrite !field_compatible_field_address by auto with field_compatible.
  rewrite !isptr_offset_val_zero by auto.
  cancel.
}

(* 1. Prove that [mtable] is a proper method-table for foo-objects *)

make_func_ptr _foo_twiddle.
make_func_ptr _foo_reset.
sep_apply (make_object_methods Ews foo_invariant(gv _foo_reset) (gv _foo_twiddle) (gv _foo_methods)); auto.

(* 2. Build an instance of class [foo], called [p] *)
forward_call (* p = make_foo(); *)
        gv.
Intros p.
assert_PROP (p<>Vundef) by entailer!.
(* Illustration of an alternate method to prove the method calls.
   Method 1:  comment out lines AA and BB and the entire range CC-DD.
   Method 2:  comment out lines AA-BB, inclusive.
*)

(* AA *) try (tryif
  (method_call (p, @nil Z) (@nil Z) whatever;
   method_call (p, 3, @nil Z) [3%Z] i;
     [simpl; computable | ])
(* BB *)  then fail else fail 99)
  .

(* CC *)
(* 4. first method-call *)
unfold object_mpred.
Intros instance mtable0.
forward. (*  mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward. (* p_reset = mtable->reset; *)
forward_call (* p_reset(p); *)
      (p, @nil Z).
(* Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).
deadvars!. clear.

(* 5. second method-call *)
unfold object_mpred.
Intros instance mtable0.
forward.  (* mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward.   (* p_twiddle = mtable->twiddle; *)
assert_PROP (p<>Vundef) by entailer!.
forward_call (* i = p_twiddle(p,3); *)
      (p, 3, @nil Z).
  simpl. computable.
Intros i.
simpl in H0.
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [3] p instance mtable0).
deadvars!.
simpl in H1.

(* DD *)

(* 6. return *)
forward.  (* return i; *)
Exists i; entailer!!.
Qed.


Require Import Axioms.

Require Import effect_semantics.

Require Import pos.
Require Import compcert_linking.

Require Import ssreflect ssrbool ssrnat ssrfun seq fintype.
Set Implicit Arguments.

Require Import AST. (*for ident*)
Require Import Values.
Require Import Globalenvs.

Section linkingLemmas.

Import Linker.
Import Modsem.

Variable N : pos.
Variable cores : 'I_N -> Modsem.t.
Variable fun_tbl : ident -> option 'I_N.
Variable my_ge : ge_ty.

Let linker := effsem N cores fun_tbl.

Lemma upd_upd (st : Linker.t N cores) c c' :
  updCore (updCore st c) c' = updCore st c'.
Proof.
rewrite /updCore /updStack /=; f_equal.
move: (updCore_obligation_1 _ _); simpl.
rewrite collection.COL.theory.unbumpbump=> w2.
by have ->: w2 = updCore_obligation_1 _ _ by apply: proof_irr.
Qed.

Lemma step_STEP {U st1 m1 c1' m1'} :
  let: c1 := peekCore st1 in
  effect_semantics.effstep
    (sem (cores (Core.i c1)))
    (ge (cores (Core.i c1))) U (Core.c c1) m1 c1' m1' ->
  effect_semantics.effstep linker my_ge
  U st1 m1 (updCore st1 (Core.upd c1 c1')) m1'.
Proof.
move=> STEP; move: (@effstep_corestep _ _ _ _ _ _ _ _ _ STEP)=> STEP'; split.
by left; exists c1'; split.
by move=> ?; exists c1'; split.
by move=> H b ofs; case: H; rewrite/LinkerSem.corestep0; exists c1'; split.
Qed.

Lemma stepN_STEPN {U st1 m1 c1' m1' n} :
  let: c1 := peekCore st1 in
  effect_semantics.effstepN
    (sem (cores (Core.i c1)))
    (ge (cores (Core.i c1))) n U (Core.c c1) m1 c1' m1' ->
  effect_semantics.effstepN linker my_ge
    n U st1 m1 (updCore st1 (Core.upd c1 c1')) m1'.
Proof.
move: st1 c1' m1 U; elim: n.
move=> st1 c1' m1 U /= [][] <- <- <-; split=> //; f_equal.
{ have H: Core.upd (peekCore st1) (Core.c (peekCore st1))
        = peekCore st1.
  { by clear; rewrite /Core.upd; case: (peekCore st1). }
  by rewrite H LinkerSem.updPeekCore.
}
move=> n IH st1 c1' m1 U /= => [][]c1'' []m1'' []U1 []U2 []B []C D.
exists (updCore st1 (Core.upd (peekCore st1) c1'')), m1'',U1,U2; split.
by apply: (step_STEP B).
have H: Core.i (peekCore st1)
      = Core.i (peekCore (updCore st1 (Core.upd (peekCore st1) c1''))).
{ admit. }
admit.
(*move: (IH (updCore st1 (Core.upd (peekCore st1) c1'')) c1' m1'' U2).
by rewrite upd_upd=> H; split=> //; move: H; apply; apply: C.*)
Qed.

Lemma stepPLUS_STEPPLUS {U st1 m1 c1' m1'} :
  let: c1 := peekCore st1 in
  effect_semantics.effstep_plus
    (sem (cores (Core.i c1)))
    (ge (cores (Core.i c1))) U (Core.c c1) m1 c1' m1' ->
  effect_semantics.effstep_plus linker my_ge
  U st1 m1 (updCore st1 (Core.upd c1 c1')) m1'.
Proof. by rewrite/effstep_plus=> [][]n; move/stepN_STEPN=> B; exists n. Qed.

Lemma stepSTAR_STEPSTAR {U st1 m1 c1' m1'} :
  let: c1 := peekCore st1 in
  effect_semantics.effstep_star
    (sem (cores (Core.i c1)))
    (ge (cores (Core.i c1))) U (Core.c c1) m1 c1' m1' ->
  effect_semantics.effstep_star linker my_ge
  U st1 m1 (updCore st1 (Core.upd c1 c1')) m1'.
Proof. by rewrite/effstep_star=> [][]n; move/stepN_STEPN=> B; exists n. Qed.

End linkingLemmas.


From aneris.examples.consensus Require Import paxos_prelude.
Import RecordSetNotations.

Section paxos_proposer.
  Context `{!anerisG (Paxos_model params) Σ}.
  Context `{!paxosG Σ params}.

  Lemma recv_promises_spec p h (n : nat) (b : Ballot) :
    p ∈ Proposers →
    {{{ inv paxosN paxos_inv ∗ p ⤇ proposer_si ∗
        h ↪[ip_of_address p] (mkSocket (Some p) true) }}}
      recv_promises int_serializer #(LitSocket h) #n #b
      @[ip_of_address p]
    {{{ vp (promises : gset (option (Ballot * Value))) (senders : gset Acceptor),
        RET vp;
        h ↪[ip_of_address p] (mkSocket (Some p) true) ∗
        ⌜is_set promises vp⌝ ∗
        ⌜size senders = n⌝ ∗
        (∀ a, ⌜a ∈ senders⌝ -∗
               ∃ mv, ⌜mv ∈ promises⌝ ∗ msgs_elem_of (msg1b a b mv)) ∗
        (* TODO: better spec/implementation? - this is a bit silly *)
        (∀ mv, ⌜mv ∈ promises⌝ →
               ∃ a, ⌜a ∈ senders⌝ ∗ msgs_elem_of (msg1b a b mv)) }}}.
  Proof.
    iIntros (? Φ) "(#Hinv & #Hp_si & Hh) HΦ". rewrite /recv_promises.
    wp_pures.
    wp_apply (wp_set_empty (option (Ballot * Value))); [done|].
    iIntros (vp Hvp). wp_alloc lp as "Hlp".
    wp_pures.
    wp_apply (wp_set_empty Acceptor); [done|].
    iIntros (vs Hvs). wp_alloc ls as "Hls".
    do 4 wp_pure _.
    (* loop invariant *)
    iAssert (
        ∃ (promises : gset (option (Ballot * Value))) (senders : gset Acceptor) vp vs,
          lp ↦[ip_of_address p] vp ∗ ls ↦[ip_of_address p] vs ∗
             ⌜is_set promises vp⌝ ∗ ⌜is_set senders vs⌝ ∗
             (∀ a, ⌜a ∈ senders⌝ -∗
                    ∃ mv, ⌜mv ∈ promises⌝ ∗ msgs_elem_of (msg1b a b mv)) ∗
             (∀ mv, ⌜mv ∈ promises⌝ →
               ∃ a, ⌜a ∈ senders⌝ ∗ msgs_elem_of (msg1b a b mv)))%I
      with "[Hlp Hls]" as "Hloop".
    { iExists ∅, ∅, _, _. iFrame "∗%". iSplit; iIntros (? []%elem_of_empty). }
    clear Hvp Hvs vs vp. wp_pure _.
    iLöb as "IH".
    iDestruct "Hloop" as (promises senders vp vs) "(Hlp & Hls & %Hvp & %Hvs & Hincl & Hacc)".
    wp_pures.
    wp_load.
    wp_apply wp_set_cardinal; [done|]; iIntros "_".
    wp_op. case_bool_decide as Heq; wp_pures.
    { wp_load. iApply "HΦ". iFrame. apply Nat2Z.inj in Heq. by iFrame "%". }
    wp_bind (ReceiveFrom _).
    iInv (paxosN) as (δ) "(>Hfrag & >Hmauth & >Hbal & >Hval & Hmcoh & >HbI)"
                         "Hclose".
    iDestruct "Hmcoh" as ">Hmcoh".
    iDestruct "Hmcoh" as (F Ts) "(Has & Hps & -> & %HM)".
    iDestruct (big_sepS_delete _ _ p with "Hps") as "[[% Hp] Hps]"; [done|].
    wp_apply (aneris_wp_pers_receivefrom with "[$Hh $Hp $Hp_si]"); [done..|].
    iIntros (m) "(Hh & Hp & Hm)".
    iMod ("Hclose" with "[-Hh Hm Hlp Hls Hincl Hacc HΦ]") as "_".
    { iModIntro. iExists _. iFrame.
      iExists _, _. iFrame (HM) "Has".
      iSplit; [|done].
      iDestruct (big_sepS_insert _ _ p with "[Hp $Hps]")
        as "Hps"; [set_solver|eauto|].
      rewrite -union_difference_singleton_L //. }
    rewrite /proposer_si.
    iDestruct "Hm" as (?? mval Hser) "(-> & Hm)".
    iModIntro. wp_apply wp_unSOME; [done|]; iIntros "_".
    wp_pures.
    wp_apply (s_deser_spec proposer_serialization); [done|]; iIntros "_".
    wp_pures.
    case_bool_decide; wp_if; last first.
    { wp_seq. wp_apply ("IH" with "Hh HΦ [Hlp Hls Hincl Hacc]").
      iExists _, _, _, _. auto with iFrame. }
    simplify_eq.
    wp_load.
    wp_apply (wp_set_add $! Hvs). iIntros (vs' ?).
    wp_store. wp_load.
    wp_apply (wp_set_add $! Hvp).
    iIntros (vp' Hvp'). wp_store.
    wp_apply ("IH" with "Hh HΦ").
    iExists (_ ∪ _), (_ ∪ _), _, _. iFrame "Hlp Hls".
    do 2 (iSplit; [done|]).
    iSplit; last first.
    { iIntros (mv). rewrite elem_of_union elem_of_singleton. iIntros ([-> | Hin]).
      - iExists _. iFrame. iPureIntro; set_solver.
      - iDestruct ("Hacc" $! mv Hin) as (a') "[% ?]".
        iExists a'. iFrame. iPureIntro; set_solver. }
    iIntros (a').
    rewrite elem_of_union elem_of_singleton.
    iIntros ([-> | ?]); last first.
    { iDestruct ("Hincl" $! a' with "[//]") as (mv') "[% H]".
      iExists mv'. iFrame. iPureIntro; set_solver. }
    iExists _. iFrame. iPureIntro; set_solver.
  Qed.

  Lemma find_max_promise_spec (lp : val)
        (promises : gset (option (Ballot * Value))) ip :
    is_set promises lp →
    {{{ True }}}
      find_max_promise lp @[ip]
    {{{ v, RET v;
        (⌜v = NONEV⌝ ∗ ⌜set_Forall (λ p, p = None) promises⌝) ∨
        (∃ (b : Ballot) (val : Value),
            ⌜Some (b, val) ∈ promises⌝ ∗
            ⌜v = SOMEV ($b, $val)⌝ ∗
            ⌜set_Forall (λ p, if p is Some (b', v')
                              then b ≥ b' else True) promises⌝) }}}.
  Proof.
    iIntros (? Φ) "_ HΦ". rewrite /find_max_promise.
    wp_pures.
    wp_apply (wp_set_foldl (A := option (Ballot * Value))
                (λ X v, (⌜v = NONEV⌝ ∗ ⌜set_Forall (λ p, p = None) X⌝) ∨
                        (∃ (b : Ballot) (val : Value),
                            ⌜Some (b, val) ∈ X⌝ ∗
                            ⌜v = SOMEV ($b, $val)⌝ ∗
                            ⌜set_Forall (λ p, if p is Some (b', v')
                                              then b ≥ b' else True) X⌝))%I
                (λ _, True%I) (λ _, True%I)).
    { iIntros ([[b v]|] acc X) "!#";
        iIntros (Ψ) "[[[-> %Hall] | (% & % & %Hin & -> & %Hall)] _] HΨ".
      - wp_pures. iApply "HΨ". iSplit; [|done]. iRight.
        iExists b, v. iPureIntro.
        split; [by apply elem_of_union_r, elem_of_singleton|].
        split; [done|].
        apply set_Forall_union.
        { apply (set_Forall_impl _ _ _ Hall). by intros ? ->. }
        apply set_Forall_singleton. lia.
      - wp_pures. case_bool_decide; wp_if.
        + iApply "HΨ". iPureIntro.
          split; [|done]. right.
          do 2 eexists.
          split; [apply elem_of_union_l, Hin|].
          split; [done|].
          apply set_Forall_union; [done|].
          apply set_Forall_singleton. lia.
        + iApply "HΨ". iPureIntro.
          split; [|done]. right.
          do 2 eexists.
          split; [by apply elem_of_union_r, elem_of_singleton|].
          split; [done|].
          apply set_Forall_union; [|apply set_Forall_singleton; lia].
          apply (set_Forall_impl _ _ _ Hall).
          intros [[]|]; [|done]. lia.
      - wp_pures. iApply "HΨ". iPureIntro.
        split; [|done]. left.
        split; [done|].
        apply set_Forall_union; [done|].
        by apply set_Forall_singleton.
      - wp_pures. iApply "HΨ". iPureIntro.
        split; [|done]. right.
        do 2 eexists.
        split; [by apply elem_of_union_l, Hin|].
        split; [done|].
        apply set_Forall_union; [done|].
        by apply set_Forall_singleton. }
    { iFrame "%". rewrite big_opS_unit; eauto. }
    iIntros (?) "[H _]". by iApply "HΦ".
  Qed.

  (* Definition bal (n : nat) (p : nat) := n * ProposersN + p. *)

  Lemma proposer_spec av h b (p : Proposer) (z : Value) :
    is_set Acceptors av →
    inv paxosN paxos_inv -∗
    ([∗ set] a ∈ Acceptors, a ⤇ acceptor_si) -∗
    (`p) ⤇ proposer_si -∗
    h ↪[ip_of_address (`p)] (mkSocket (Some (`p)) true) -∗
    pending b -∗
    WP proposer int_serializer av #(LitSocket h) #b #`z @[ip_of_address (`p)]
    {{ _, ∃ v, msgs_elem_of (msg2a b v) ∗
               h ↪[ip_of_address (`p)] (mkSocket (Some (`p)) true) }}.
  Proof.
    iIntros (?) "#Hinv #HA_sis #Hp_si Hh Hb".
    rewrite /proposer.
    wp_pures.
    wp_apply (s_ser_spec (acceptor_serialization)).
    { iPureIntro. apply serializable. }
    iIntros (s) "%Hser".
    (* send a phase 1a message to all acceptors, taking a step in the model for
       each message. *)
    wp_apply (wp_pers_sendto_all_take_step
                True%I
                (λ _, msgs_elem_of (msg1a _))
                (λ _, True)%I
                with "[] [$Hh //]"); [done|done|eassumption| |].
    { iIntros "!#" (a ?) "(_ & _ & %Ha)".
      set (m := {| m_sender := `p; m_destination := a; m_body := s |}).
      iInv (paxosN) as (δ) ">(Hfrag & Hmauth & Hbal & Hval & Hmcoh & HbI)" "Hclose".
      iMod (msgs_update (msg1a b) with "Hmauth") as "[Hmauth #Hm]".
      iModIntro.
      iDestruct "Hmcoh" as (F Ts) "(Has & Hps & -> & %HM)".
      iDestruct (big_sepS_delete _ _ (`p) with "Hps") as "[[% Hp] Hps]"; [auto|].
      iDestruct (big_sepS_elem_of _ _ a with "HA_sis") as "#Ha_si"; [done|].
      iExists _, _, _, _, δ, (δ <| msgs ::= λ ms, ms ∪ {[msg1a _]} |>).
      iFrame "#∗".
      iSplit.
      { iPureIntro. right. constructor. }
      iSplitR.
      { iExists p. iSplit; [done|]. iLeft. iExists _. iFrame "% #". }
      iIntros "(Hp & Hfrag)".
      iMod ("Hclose" with "[-]"); [|done].
      iModIntro. iExists _. iFrame.
      iSplitR "HbI"; last first.
      { iApply (ballot_inv_send_not2a with "HbI"). naive_solver. }
      iExists (<[(`p) := {[m]} ∪ F (`p)]>F), _; simpl.
      rewrite send_msg_notin; [|auto].
      iFrame.
      iDestruct (send_msg_combine with "Hp Hps") as "$"; [auto|].
      iSplit; [done|].
      iPureIntro.
      apply messages_agree_add; [| |done].
      { apply elem_of_union; auto. }
      simpl. destruct_is_ser Hser.
      by exists p, (a ↾ Ha). }
    iIntros "(_ & Hh & _ & Helem)". wp_pures.
    wp_apply (wp_set_cardinal with "[//]"); iIntros "_".
    wp_pures.
    replace #(_ + 1) with #(size Acceptors / 2 + 1)%nat; last first.
    { do 2 f_equal. lia. }
    wp_apply (recv_promises_spec with "[$Hinv $Hp_si $Hh]"); [auto|].
    iIntros (vp promises senders) "(Hh & %Hvp & %Hsize & #Hmsgs & #Hacc)".
    wp_pures.
    (* find the maximum phase 1b message from the majority, if any *)
    wp_apply (find_max_promise_spec _ promises with "[//]"); [done|].
    iIntros (?) "[(-> & %Hpromises) | (%b0 & %z' & %Hin &-> & %Hall)]".
    - (* no value was proposed by the majority *)
      wp_pures.
      iMod (pend_update_shot b z with "Hb") as "#Hshot".
      wp_apply (s_ser_spec (acceptor_serialization)).
      { iPureIntro. apply serializable. }
      iIntros (s' Hser').
      (* send phase 2a decision to all acceptors *)
      wp_apply (wp_pers_sendto_all_take_step
                  True%I (λ _, msgs_elem_of (msg2a b z)) (λ _, True)%I
                  with "[Hmsgs] [$Hh]"); [done|done|eassumption| |].
      { iIntros "!#" (a _) "(_ & _ & %Ha)".
        iInv (paxosN) as (δ) ">(Hfrag & Hmauth & Hbal & Hval & Hmcoh & HbI)" "Hclose".
        iAssert (⌜∀ a, a ∈ senders →
                       ∃ mv, mv ∈ promises ∧ msg1b a b mv ∈ δ.(msgs)⌝)%I
          as "%Hsenders".
        { iIntros (a' Ha').
          iDestruct ("Hmsgs" $! a' Ha') as (mv) "[% Hm]".
          iDestruct (msgs_elem_of_in with "Hmauth Hm") as %?. eauto. }
        iMod (msgs_update (msg2a b z) with "Hmauth") as "[Hmauth #Hm]".
        iModIntro.
        iDestruct "Hmcoh" as (F Ts) "(Has & Hps & -> & %HM)".
        iDestruct (big_sepS_delete _ _ (`p) with "Hps") as "[[% Hp] Hps]"; [auto|].
        iDestruct (big_sepS_elem_of _ _ a with "HA_sis") as "#Ha_si"; [done|].
        set (m := {| m_sender := `p; m_destination := a; m_body := s' |}).
        (* this viewshift is used for all acceptors; here we destruct on whether
           we're considering the first (the 2a message has not been recorded in
           the model) or not. *)
        destruct (decide (msg2a b z ∈ δ.(msgs))).
        + iExists _, _, _, _, δ, δ.
          iFrame "Hfrag Hp Ha_si".
          iSplit; [auto|].
          iSplitR.
          { iExists p. iSplit; [done|]. iRight. iExists _, z. by iFrame "Hm". }
          iIntros "(Hp & Hfrag)".
          iMod ("Hclose" with "[-]") as "_"; [|auto].
          iModIntro. iExists _. simpl.
          assert ((msgs δ ∪ {[msg2a b z]}) = msgs δ) as -> by set_solver.
          iFrame.
          iExists (<[(`p) := {[m]} ∪ F (`p)]>F), _; iFrame.
          rewrite send_msg_notin; [|auto]. iFrame.
          iDestruct (send_msg_combine with "Hp Hps") as "$"; [auto|].
          iSplit; [done|]. iPureIntro.
          eapply messages_agree_duplicate; [done| |done].
          destruct_is_ser Hser'. by exists p, (a ↾ Ha).
        + iExists _, _, _, _, δ, (δ <| msgs ::= λ ms, ms ∪ {[msg2a _ z]} |>).
          iAssert (⌜¬ (∃ z', msg2a b z' ∈ msgs δ)⌝)%I as "%".
          { iIntros ([? Hz']).
            iSpecialize ("HbI" $! _ _ Hz').
            by iDestruct (shot_agree with "Hshot HbI") as %->. }
          iDestruct (frag_st_rtc with "Hfrag") as %Hrtc.
          iFrame "Hfrag Hp Ha_si".
          iSplit.
          { iPureIntro. right.
            eapply (phase2a _ _ _ senders).
            * done.
            * apply majority_show_quorum. rewrite Hsize. lia.
            * split.
              - intros a' Ha'.
                destruct (Hsenders a' Ha') as (mv &?&?).
                exists (msg1b a' b mv).
                rewrite !elem_of_PropSet. split; eauto.
              - left.
                rewrite set_equiv=> m'.
                rewrite !elem_of_PropSet.
                split; [|done].
                intros ([Hin1 (? &?&?& Ha')] & a' & [? ?]); simplify_eq.
                destruct (Hsenders a' Ha') as (? & Hprom & Hin2).
                (* N.B.: here we are explicitlty using a pure property of the
                   model to obtain the contradiction! *)
                specialize (msg1b_agree _ _ _ _ _ Hrtc Hin1 Hin2).
                rewrite (Hpromises _ Hprom).
                done. }
          iSplit.
          { iExists p. iSplit; [done|]. iRight. iExists _, z. by iFrame "Hm". }
          iIntros "[Hp Hfrag]".
          iMod ("Hclose" with "[-]") as "_"; [|auto].
          iModIntro. iExists _. iFrame "Hfrag Hmauth Hbal Hval".
          iSplitR "HbI"; last first.
          { iIntros (??).
            rewrite elem_of_union elem_of_singleton.
            iIntros ([?|?]); by [iApply "HbI"|simplify_eq]. }
          iExists (<[(`p) := {[m]} ∪ F (`p)]>F), _. simpl.
          rewrite send_msg_notin; [|auto]. iFrame.
          iDestruct (send_msg_combine with "Hp Hps") as "$"; [auto|].
          iSplit; [done|].
          iPureIntro.
          apply messages_agree_add; [| |done].
          { apply elem_of_union; auto. }
          destruct_is_ser Hser'. by exists p, (a ↾ Ha). }
      iIntros "(_ & Hh & _ & H2a)".
      iExists _. iFrame.
      destruct Acceptors_choose as [a ?].
      by iApply (big_sepS_elem_of _ _ a with "H2a").
    - (* a value has already been proposed *)
      wp_pures.
      wp_apply (s_ser_spec (acceptor_serialization)).
      { iPureIntro. apply serializable. }
      iIntros (s' Hser').
      iMod (pend_update_shot b z' with "Hb") as "#Hshot".
      wp_apply (wp_pers_sendto_all_take_step
                  True%I (λ _, msgs_elem_of (msg2a b z')) (λ _, True)%I
                  with "[Hmsgs] [$Hh]"); [done|done|eassumption| |].
      { iIntros "!#" (a _) "(_ & _ & %Ha)".
        iInv (paxosN) as (δ) ">(Hfrag & Hmauth & Hbal & Hval & Hmcoh & HbI)"
                                 "Hclose".
        iAssert (⌜∀ a, a ∈ senders →
                       ∃ mv, mv ∈ promises ∧ msg1b a b mv ∈ δ.(msgs)⌝)%I as "%Hsenders".
        { iIntros (a' Ha').
          iDestruct ("Hmsgs" $! a' Ha') as (mv) "[% Hm']".
          iDestruct (msgs_elem_of_in with "Hmauth Hm'") as %?. eauto. }
        iAssert (⌜∀ mv, mv ∈ promises →
                        ∃ a, a ∈ senders ∧ msg1b a b mv ∈ δ.(msgs)⌝)%I as "%Hpromises".
        { iIntros (mv Hmv).
          iDestruct ("Hacc" $! mv Hmv) as (a') "[% Hm']".
          iDestruct (msgs_elem_of_in with "Hmauth Hm'") as %?. eauto. }
        iMod (msgs_update (msg2a b z') with "Hmauth") as "[Hmauth #Hm]".
        iModIntro.
        iDestruct "Hmcoh" as (F Ts) "(Has & Hps & -> & %HM)".
        iDestruct (big_sepS_delete _ _ (`p) with "Hps") as "[[% Hp] Hps]"; [auto|].
        iDestruct (big_sepS_elem_of _ _ a with "HA_sis") as "#Ha_si"; [done|].
        set (m := {| m_sender := `p; m_destination := a; m_body := s' |}).
        destruct (decide ((msg2a b z') ∈ δ.(msgs))).
        + iExists _, _, _, _, δ, δ.
          iFrame "Hfrag Hp Ha_si".
          iSplit; [auto|].
          iSplit.
          { iExists p. iSplit; [done|]. iRight. iExists _, _. by iFrame "Hm". }
          iIntros "[Hp Hfrag]".
          iMod ("Hclose" with "[-]") as "_"; [|auto].
          iModIntro. iExists _. simpl.
          assert ((msgs δ ∪ {[msg2a b z']}) = msgs δ) as -> by set_solver.
          iFrame. iExists (<[(`p) := {[m]} ∪ F (`p)]>F), _.
          rewrite send_msg_notin; [|auto]. iFrame.
          iDestruct (send_msg_combine with "Hp Hps") as "$"; [auto|].
          iSplit; [done|]. iPureIntro.
          eapply messages_agree_duplicate; [done| |done].
          destruct_is_ser Hser'. by exists p, (a ↾ Ha).
        + iExists _, _, _, _, δ, (δ <| msgs ::= λ ms, ms ∪ {[msg2a b z']} |>).
          iAssert (⌜¬ (∃ z', msg2a b z' ∈ msgs δ)⌝)%I as "%".
          { iIntros ([? Hz']).
            iSpecialize ("HbI" $! _ _ Hz').
            by iDestruct (shot_agree with "Hshot HbI") as %->. }
          iDestruct (frag_st_rtc with "Hfrag") as %Hrtc.
          iFrame "Hfrag Hp Ha_si".
          iSplit.
          { iPureIntro. right.
            eapply (phase2a _ z' _ senders).
            * done.
            * apply majority_show_quorum. rewrite Hsize. lia.
            * split.
              - intros a' Ha'.
                destruct (Hsenders a' Ha') as (mv &?&?).
                exists (msg1b a' b mv).
                rewrite !elem_of_PropSet. split; eauto.
              - right.
                destruct (Hpromises _ Hin) as (a' & Ha' & Hm).
                eexists _; exists a', b0.
                repeat split; eauto.
                intros m' ((Hin1 &?&?&?& Hin') & ? & ([]&?)); simplify_eq.
                do 3 eexists. split; [done|].
                destruct (Hsenders _ Hin') as (mv & Hmv & Hin2).
                specialize (Hall _ Hmv).
                (* N.B.: here we are explicitlty using a pure property of the
                   model to finish the proof!  *)
                specialize (msg1b_agree _ _ _ _ _ Hrtc Hin1 Hin2) as ?.
                simplify_eq. done. }
          iSplitR.
          { iExists p. iSplit; [done|]. iRight. iExists _, z'. by iFrame "Hm". }
          iIntros "[Hp Hfrag]".
          iMod ("Hclose" with "[-]") as "_"; [|auto].
          iModIntro. iExists _. iFrame.
          iSplitR "HbI"; last first.
          { iIntros (??).
            rewrite elem_of_union elem_of_singleton.
            iIntros ([?|?]); by [iApply "HbI"|simplify_eq]. }
          iExists (<[(`p) := {[m]} ∪ F (`p)]>F), _; simpl.
          rewrite send_msg_notin; [|auto]. iFrame.
          iDestruct (send_msg_combine with "Hp Hps") as "$"; [auto|].
          iSplit; [done|].
          iPureIntro.
          apply messages_agree_add; [| |done].
          { apply elem_of_union; auto. }
          destruct_is_ser Hser'. by exists p, (a ↾ Ha). }
      iIntros "(_ & Hh & _ & H2a)".
      iExists _. iFrame.
      destruct Acceptors_choose as [a ?].
      by iApply (big_sepS_elem_of _ _ a with "H2a").
  Qed.

  Lemma proposer'_spec av i (p : Proposer) (z : Value) :
    i < size Proposers →
    is_set Acceptors av →
    inv paxosN paxos_inv -∗
    ([∗ set] a ∈ Acceptors, a ⤇ acceptor_si) -∗
    free_ports (ip_of_address (`p)) {[port_of_address (`p)]} -∗
    (`p) ⤇ proposer_si -∗
    pending_class i 0 -∗
    WP proposer' int_serializer av #(`p) #i #(size Proposers) #`z
       @[ip_of_address (`p)] {{ _, True }}.
  Proof.
    iIntros (??) "#Hinv #Has Hport #Hp Hi". rewrite /proposer'.
    wp_pures.
    wp_socket sh as "Hskt".
    wp_pures.
    wp_socketbind.
    wp_alloc l as "Hl".
    do 4 wp_pure _.
    (* loop invariant *)
    iAssert (∃ c, pending_class i c ∗ l ↦[ip_of_address (`p)] #c)%I
      with "[Hi Hl]" as "Hloop".
    { iExists 0. replace (#0%nat) with (#0) by f_equal. iFrame. }
    wp_pure _.
    iLöb as "IH".
    iDestruct "Hloop" as (b) "(Hi & Hl)".
    wp_pures.
    wp_load.
    wp_pures.
    iDestruct (pending_pend_split with "Hi") as "[Hi Hpend]"; [done|].
    replace (#(b * size Proposers + i)) with (#(b * size Proposers + i)%nat)
      by (do 2 f_equal; lia).
    wp_bind (proposer _ _ _ _ _)%E.
    wp_apply aneris_wp_wand_r. iSplitL "Hpend Hskt".
    { by wp_apply (proposer_spec with "Hinv Has Hp Hskt Hpend"). }
    iIntros (?) "(% & #? & Hskt)".
    wp_seq. wp_load. wp_op.
    wp_store.
    iApply ("IH" with "Hskt [-]").
    iExists _. iFrame.
    replace (#(b + 1)%nat) with (#(b + 1)) by (do 2 f_equal; lia).
    done.
  Qed.

End paxos_proposer.


Require Import List.
Require Import ZArith.

Require Import Utils.
Require Import Lattices.
Require Import CLattices.
Require Import Instr.
Require Import Memory.
Require Import AbstractCommon.
Require Import AbstractMachine.
Require Import NIAbstractMachine.
Require Import Concrete.
Require Import ConcreteMachine.
Require Import ConcreteExecutions.
Require Import Semantics.
Require Import Refinement.
Require Import RefinementAQA.
Require Import RefinementQAC.
Require Import RefinementAC.
Require TINI.

Open Scope Z_scope.

Set Implicit Arguments.

Section NI.

Context {T: Type}
        {Latt: JoinSemiLattice T}
        {CLatt: ConcreteLattice T}.

Variable cblock : FaultRoutine.block.
Hypothesis stamp_cblock : Mem.stamp cblock = Kernel.

Variable ctable_impl : list CSysCallImpl.

Let faultHandler := FaultRoutine.faultHandler _ QuasiAbstractMachine.fetch_rule.
Let ctable := build_syscall_table (Z.of_nat (length faultHandler)) ctable_impl.

Context {WFCLatt: WfConcreteLattice cblock ctable T Latt CLatt}.

Variable atable : ASysTable T.
Hypothesis Hatable : parametric_asystable atable.
Hypothesis Hctable_impl_correct : ctable_impl_correct cblock atable ctable_impl faultHandler.
Hypothesis table_syscall_lowstep : forall o, syscall_lowstep o atable.
Hypothesis table_systable_inv : systable_inv atable.

Inductive concrete_i_equiv (o : T) :
  concrete_init_data -> concrete_init_data -> Prop :=
  | ci_equiv : forall ai1 ai2 ci1 ci2
                      (EQ : abstract_i_equiv o ai1 ai2)
                      (MATCH1 : ac_match_initial_data cblock QuasiAbstractMachine.fetch_rule ai1 ci1)
                      (MATCH2 : ac_match_initial_data cblock QuasiAbstractMachine.fetch_rule ai2 ci2),
                 concrete_i_equiv o ci1 ci2.

Instance CMObservation : TINI.Observation (tini_concrete_machine cblock ctable_impl) (Event T) := {
  out e := match e with
             | CEInt (z, t) m => EInt (z, valToLab t m)
           end;
  e_low := fun o e => @TINI.e_low _ _ (AMObservation atable) o e;
  e_low_dec := fun o e => TINI.e_low_dec o e;
  i_equiv := concrete_i_equiv
}.

Lemma ac_low_compatible :
  forall (o : T)
         (e1 : event (abstract_machine atable))
         (e2 : CEvent),
    ref_match_events (@abstract_concrete_ref _ _ _ cblock stamp_cblock
                                             ctable_impl
                                             WFCLatt
                                             atable Hatable Hctable_impl_correct) e1 e2 ->
    (TINI.e_low o (TINI.out e1)
       <-> TINI.e_low o (@TINI.out _ _ CMObservation e2)).
Proof.
  simpl.
  intros o [[x xl]] [[x' xt] m] H; simpl.
  inv H. unfold pcatom_labToVal in ATOMS. simpl in ATOMS.
  destruct ATOMS as [? TAG]. subst x'.
  assert (valToLab xt m = xl) by (eapply labToVal_valToLab_id; eauto).
  subst. reflexivity.
Qed.

Lemma concrete_equiv_abstract_equiv :
  forall o ci1 ci2,
    concrete_i_equiv o ci1 ci2 ->
    exists ai1 ai2,
      abstract_i_equiv o ai1 ai2 /\
      ac_match_initial_data cblock QuasiAbstractMachine.fetch_rule ai1 ci1 /\
      ac_match_initial_data cblock QuasiAbstractMachine.fetch_rule ai2 ci2.
Proof.
  intros o ci1 ci2 EQ.
  inv EQ. eauto.
Qed.

Lemma ac_match_events_equiv :
  forall o e11 e12 e21 e22
         (EQ : @TINI.a_equiv (abstract_machine atable) _ _ o (E e11) (E e12))
         (MATCH1 : ref_match_events (abstract_concrete_ref stamp_cblock Hatable Hctable_impl_correct) e11 e21)
         (MATCH2 : ref_match_events (abstract_concrete_ref stamp_cblock Hatable Hctable_impl_correct) e12 e22),
    @TINI.a_equiv (tini_concrete_machine cblock ctable_impl) _ _ o (E e21) (E e22).
Proof.
  simpl.
  intros o [[x1 xl1]] [[x2 xl2]] [[x1' xt1] m1] [[x2' xt2] m2].
  intros.
  inv EQ; inv MATCH1; inv MATCH2;
  repeat match goal with
           | ATOMS : pcatom_labToVal _ _ _ |- _ =>
             unfold pcatom_labToVal in ATOMS;
             simpl in ATOMS; destruct ATOMS; subst
           | H : TINI.out _ = TINI.out _ |- _ =>
             simpl in H; inv H
           | H : TINI.e_low _ _ |- _ =>
             simpl in H
         end;
  intuition; repeat subst;
  [> once (constructor; solve [simpl; eauto;
                        repeat match goal with
                               | H : labToVal _ _ _ |- _ =>
                                 eapply labToVal_valToLab_id in H; eauto; rewrite H
                             end;
                      eauto]) ..].
Qed.

Lemma ac_tini_preservation_premises :
  tini_preservation_hypothesis
    (abstract_concrete_ref stamp_cblock Hatable Hctable_impl_correct).
Proof.
  intros o. exists o.
  split. { apply ac_low_compatible. }
  split. { apply concrete_equiv_abstract_equiv. }
  apply ac_match_events_equiv.
Qed.

Lemma concrete_noninterference :
  TINI.tini CMObservation.
Proof.
   exact (@refinement_preserves_noninterference
          (abstract_machine atable) (tini_concrete_machine cblock ctable_impl)
          _ _ _
          (abstract_concrete_ref stamp_cblock Hatable Hctable_impl_correct)
          (abstract_noninterference_short table_syscall_lowstep table_systable_inv)
          ac_tini_preservation_premises).
Qed.

End NI.


Require Import Coq.Strings.String.
From Equations Require Import Equations.
Require Import PeanoNat.

Require Export SystemFR.EquivalentContext.
Require Export SystemFR.ErasedList.
Require Export SystemFR.EquivalenceLemmas3.
Require Export SystemFR.EvalListMatch.
Require Export SystemFR.EvalFixDefault.

Opaque reducible_values.

Reserved Notation "'[' Γ ⊨ t1 '⤳*' t2 ']'" (at level 60, Γ at level 60, t1 at level 60).

Inductive delta_beta_reduction: context -> tree -> tree -> Prop :=
| DBVar:
    forall Γ x ty t v,
      wf t 0 ->
      lookup Nat.eq_dec Γ x = Some (T_singleton ty t) ->
      [ Γ ⊨ t ⤳* v ] ->
      [ Γ ⊨ fvar x term_var ⤳* v ]

| DBPair:
    forall Γ t1 t2 v1 v2,
      [ Γ ⊨ t1 ⤳* v1 ] ->
      [ Γ ⊨ t2 ⤳* v2 ] ->
      [ Γ ⊨ pp t1 t2 ⤳* pp v1 v2 ]

| DBFirst:
    forall Γ t v1 v2,
      is_erased_term v1 ->
      is_erased_term v2 ->
      wf v1 0 ->
      wf v2 0 ->
      subset (fv v1) (support Γ) ->
      subset (fv v2) (support Γ) ->
      [ Γ ⊫ v1 : T_top ] ->
      [ Γ ⊫ v2 : T_top ] ->
      [ Γ ⊨ t ⤳* pp v1 v2 ] ->
      [ Γ ⊨ pi1 t ⤳* v1 ]

| DBSecond:
    forall Γ t v1 v2,
      is_erased_term v1 ->
      is_erased_term v2 ->
      wf v1 0 ->
      wf v2 0 ->
      subset (fv v1) (support Γ) ->
      subset (fv v2) (support Γ) ->
      [ Γ ⊫ v1 : T_top ] ->
      [ Γ ⊫ v2 : T_top ] ->
      [ Γ ⊨ t ⤳* pp v1 v2 ] ->
      [ Γ ⊨ pi2 t ⤳* v2 ]

| DBApp1:
    forall Γ f t t' body v,
      is_erased_term t' ->
      is_erased_term body ->
      pfv t' term_var = nil ->
      pfv body term_var = nil ->
      wf t' 0 ->
      wf body 0 ->
      [ Γ ⊫ t' : T_top ] ->
      [ Γ ⊨ t ⤳* t' ] ->
      [ Γ ⊨ f ⤳* notype_lambda body ] ->
      [ Γ ⊨ open 0 body t' ⤳* v ] ->
      [ Γ ⊨ app f t ⤳* v ]

| DBApp2:
    forall Γ f f' t t',
      [ Γ ⊨ t ⤳* t' ] ->
      [ Γ ⊨ f ⤳* f' ] ->
      [ Γ ⊨ app f t ⤳* app f' t' ]

| DBNatMatch1:
    forall Γ t t0 ts v,
      is_erased_term ts ->
      wf ts 1 ->
      subset (fv ts) (support Γ) ->
      [ Γ ⊨ t ⤳* zero ] ->
      [ Γ ⊨ t0 ⤳* v ] ->
      [ Γ ⊨ tmatch t t0 ts ⤳* v ]

| DBNatMatch2:
    forall Γ t t0 ts t' v,
      is_erased_term t0 ->
      is_erased_term ts ->
      wf t0 0 ->
      wf ts 1 ->
      subset (fv t0) (support Γ) ->
      subset (fv ts) (support Γ) ->
      subset (fv v) (support Γ) ->
      [ Γ ⊫ t' : T_top ] ->
      [ Γ ⊨ t ⤳* succ t' ] ->
      [ Γ ⊨ open 0 ts t' ⤳* v ] ->
      [ Γ ⊨ tmatch t t0 ts ⤳* v ]

| DBNatMatch3:
    forall Γ t t' t0 ts,
      is_erased_term t0 ->
      is_erased_term ts ->
      wf t0 0 ->
      wf ts 1 ->
      subset (fv t0) (support Γ) ->
      subset (fv ts) (support Γ) ->
      [ Γ ⊨ t ⤳* t' ] ->
      [ Γ ⊨ tmatch t t0 ts ⤳* tmatch t' t0 ts ]

| DBListMatch1:
    forall Γ t t1 t2 v,
      is_erased_term t2 ->
      wf t2 2 ->
      subset (fv t2) (support Γ) ->
      [ Γ ⊨ t ⤳* tnil ] ->
      [ Γ ⊨ t1 ⤳* v ] ->
      [ Γ ⊨ list_match t t1 t2 ⤳* v ]

| DBListMatch2:
    forall Γ t1 t2 h t v,
      wf t1 0 ->
      wf t2 2 ->
      is_erased_term t1 ->
      is_erased_term t2 ->
      subset (fv t1) (support Γ) ->
      subset (fv t2) (support Γ) ->
      [ Γ ⊫ t : List ] ->
      [ Γ ⊨ t ⤳* tcons h t ] ->
      [ Γ ⊨ open 0 (open 1 t2 h) t ⤳* v ] ->
      [ Γ ⊨ list_match t t1 t2 ⤳* v ]

| DBListMatch3:
    forall Γ t t' t1 t2,
      is_erased_term t1 ->
      is_erased_term t2 ->
      wf t1 0 ->
      wf t2 2 ->
      subset (fv t1) (support Γ) ->
      subset (fv t2) (support Γ) ->
      [ Γ ⊨ t ⤳* t' ] ->
      [ Γ ⊨ list_match t t1 t2 ⤳* list_match t' t1 t2 ]

| DBLeft:
    forall Γ t v,
      [ Γ ⊨ t ⤳* v ] ->
      [ Γ ⊨ tleft t ⤳* tleft v ]

| DBRight:
    forall Γ t v,
      [ Γ ⊨ t ⤳* v ] ->
      [ Γ ⊨ tright t ⤳* tright v ]

| DBFix0:
    forall Γ t default v,
      wf default 0 ->
      wf t 1 ->
      is_erased_term default ->
      is_erased_term t ->
      subset (fv default) (support Γ) ->
      subset (fv t) (support Γ) ->
      [ Γ ⊨ default ⤳* v ] ->
      [ Γ ⊨ fix_default' t default zero  ⤳* v ]

| DBFix:
    forall Γ t default fuel v,
      is_nat_value fuel ->
      wf default 0 ->
      wf t 1 ->
      is_erased_term default ->
      is_erased_term t ->
      subset (fv default) (support Γ) ->
      subset (fv t) (support Γ) ->
      [ Γ ⊨ open 0 t (fix_default' t default fuel) ⤳* v ] ->
      [ Γ ⊨ fix_default' t default (succ fuel) ⤳* v ]

| DBRefl:
    forall Γ v,
      is_erased_term v ->
      wf v 0 ->
      subset (fv v) (support Γ) ->
      [ Γ ⊨ v ⤳* v ] (* when evaluation is finished *)

where "'[' Γ ⊨ t1 '⤳*' t2 ']'" := (delta_beta_reduction Γ t1 t2).

Lemma delta_beta_var:
  forall Θ Γ x ty t v,
    wf t 0 ->
    lookup Nat.eq_dec Γ x = Some (T_singleton ty t) ->
    [ Θ; Γ ⊨ t ≡ v ] ->
    [ Θ; Γ ⊨ fvar x term_var ≡ v ].
Proof.
  unfold open_equivalent, T_singleton;
    repeat step || t_lookup || erewrite satisfies_same_support in * by eauto.
  unshelve epose proof (satisfies_lookup2 _ _ _ _ _ _ H3 H0 matched);
    repeat step || simp_red || open_none || rewrite shift_nothing2 in * by eauto with wf;
    eauto using equivalent_trans.
Qed.

Lemma delta_beta_pair:
  forall Θ Γ t1 t2 t1' t2',
    [ Θ; Γ ⊨ t1 ≡ t1' ] ->
    [ Θ; Γ ⊨ t2 ≡ t2' ] ->
    [ Θ; Γ ⊨ pp t1 t2 ≡ pp t1' t2' ].
Proof.
  unfold open_equivalent; repeat step || apply equivalent_pp; eauto.
Qed.

Lemma open_equivalent_refl:
  forall Θ Γ t,
    is_erased_term t ->
    wf t 0 ->
    subset (fv t) (support Γ) ->
    [ Θ; Γ ⊨ t ≡ t ].
Proof.
  unfold open_equivalent; intros; apply equivalent_refl; steps;
    eauto with erased fv wf.
Qed.

Lemma equivalent_pi1_pp:
  forall t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 0 ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    scbv_normalizing t1 ->
    scbv_normalizing t2 ->
    [ pi1 (pp t1 t2) ≡ t1 ].
Proof.
  unfold scbv_normalizing; steps.
  apply equivalent_trans with v0.
  - equivalent_star.
    eapply star_trans; eauto with cbvlemmas.
    eapply star_trans; eauto with cbvlemmas.
    eauto using star_one with smallstep.
  - apply equivalent_sym; equivalent_star.
Qed.

Lemma equivalent_pi2_pp:
  forall t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 0 ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    scbv_normalizing t1 ->
    scbv_normalizing t2 ->
    [ pi2 (pp t1 t2) ≡ t2 ].
Proof.
  unfold scbv_normalizing; steps.
  apply equivalent_trans with v.
  - equivalent_star.
    eapply star_trans; eauto with cbvlemmas.
    eapply star_trans; eauto with cbvlemmas.
    eauto using star_one with smallstep.
  - apply equivalent_sym; equivalent_star.
Qed.

Lemma lookup_value:
  forall l x v,
    are_values l ->
    lookup Nat.eq_dec l x = Some v ->
    cbv_value v.
Proof.
  induction l; steps; eauto.
Qed.

Lemma satisfies_are_values:
  forall l ρ Γ,
    valid_interpretation ρ ->
    satisfies (reducible_values ρ) Γ l ->
    are_values l.
Proof.
  induction l; repeat step || step_inversion satisfies; eauto with values.
Qed.

Lemma typable_normalizing:
  forall Θ Γ t T ρ l,
    [ Θ; Γ ⊨ t : T ] ->
    satisfies (reducible_values ρ) Γ l ->
    valid_interpretation ρ ->
    Θ = support ρ ->
    scbv_normalizing (psubstitute t l term_var).
Proof.
  unfold scbv_normalizing, open_reducible, reduces_to;
    repeat step || t_instantiate_sat3; eauto with values.
Qed.

Lemma delta_beta_first:
  forall Γ t t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 0 ->
    subset (fv t1) (support Γ) ->
    subset (fv t2) (support Γ) ->
    [ Γ ⊫ t1 : T_top ] ->
    [ Γ ⊫ t2 : T_top ] ->
    [ Γ ⊫ t ≡ pp t1 t2 ] ->
    [ Γ ⊫ pi1 t ≡ t1 ].
Proof.
  unfold open_equivalent; repeat step; eauto.
  eapply equivalent_trans; eauto using equivalent_pi1.
  apply equivalent_pi1_pp; steps; eauto with erased wf fv;
    eauto using typable_normalizing.
Qed.

Lemma delta_beta_second:
  forall Γ t t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 0 ->
    subset (fv t1) (support Γ) ->
    subset (fv t2) (support Γ) ->
    [ Γ ⊫ t1 : T_top ] ->
    [ Γ ⊫ t2 : T_top ] ->
    [ Γ ⊫ t ≡ pp t1 t2 ] ->
    [ Γ ⊫ pi2 t ≡ t2 ].
Proof.
  unfold open_equivalent; repeat step; eauto.
  eapply equivalent_trans; eauto using equivalent_pi2.
  apply equivalent_pi2_pp; steps; eauto with erased wf fv;
    eauto using typable_normalizing.
Qed.

Lemma equivalent_beta2:
  forall f t,
    is_erased_term t ->
    is_erased_term f ->
    pfv t term_var = nil ->
    pfv f term_var = nil ->
    wf t 0 ->
    wf f 1 ->
    scbv_normalizing t ->
    equivalent_terms (app (notype_lambda f) t) (open 0 f t).
Proof.
  unfold scbv_normalizing; repeat step; eauto using equivalent_beta.
Qed.

Lemma delta_beta_app1:
  forall Γ f t t' v body,
    is_erased_term t' ->
    is_erased_term body ->
    pfv t' term_var = nil ->
    pfv body term_var = nil ->
    wf t' 0 ->
    wf body 0 ->
    [ Γ ⊫ t' : T_top ] ->
    [ Γ ⊫ t ≡ t' ] ->
    [ Γ ⊫ f ≡ notype_lambda body ] ->
    [ Γ ⊫ open 0 body t' ≡ v ] ->
    [ Γ ⊫ app f t ≡ v ].
Proof.
  unfold open_equivalent; repeat step || t_instantiate_sat3 || t_substitutions.
  eapply equivalent_trans; eauto using equivalent_app.
  eapply equivalent_trans; eauto; repeat step || t_substitutions.
  eapply equivalent_beta2; steps; eauto using typable_normalizing;
    eauto with erased fv wf.
Qed.

Lemma delta_beta_app2:
  forall Θ Γ f f' t t',
    [ Θ; Γ ⊨ t ≡ t' ] ->
    [ Θ; Γ ⊨ f ≡ f' ] ->
    [ Θ; Γ ⊨ app f t ≡ app f' t' ].
Proof.
  unfold open_equivalent; repeat step || t_instantiate_sat3 || t_substitutions;
    eauto using equivalent_app.
Qed.

Lemma equivalent_match_scrut:
  forall t t' t0 ts,
    is_erased_term t0 ->
    is_erased_term ts ->
    wf t0 0 ->
    wf ts 1 ->
    pfv t0 term_var = nil ->
    pfv ts term_var = nil ->
    [ t ≡ t' ] ->
    [ tmatch t t0 ts ≡ tmatch t' t0 ts ].
Proof.
  intros.
  unshelve epose proof (equivalent_context (tmatch (lvar 0 term_var) t0 ts) _ _ _ _ _ H5);
    repeat step || list_utils || open_none;
    eauto with wf.
Qed.

Lemma equivalent_list_match_scrut:
  forall t t' t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 2 ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    [ t ≡ t' ] ->
    [ list_match t t1 t2 ≡ list_match t' t1 t2 ].
Proof.
  intros.
  unshelve epose proof (equivalent_context (list_match (lvar 0 term_var) t1 t2) _ _ _ _ _ H5);
    repeat step || list_utils || open_none ||
           (rewrite (open_none t1) in * by eauto with wf) ||
           (rewrite open_none in H6 by (steps; eauto with wf step_tactic));
    eauto 3 with wf erased fv step_tactic.
Qed.

Lemma delta_beta_match_zero:
  forall Θ Γ t t0 ts v,
    is_erased_term ts ->
    wf ts 1 ->
    subset (fv ts) (support Γ) ->
    [ Θ; Γ ⊨ t ≡ zero ] ->
    [ Θ; Γ ⊨ t0 ≡ v ] ->
    [ Θ; Γ ⊨ tmatch t t0 ts ≡ v ].
Proof.
  unfold open_equivalent; repeat step || t_instantiate_sat3.
  eapply equivalent_trans; eauto.
  eapply equivalent_trans; try apply equivalent_match_scrut; eauto;
    eauto with erased wf fv;
    equivalent_star.
Qed.

Lemma delta_beta_match_succ:
  forall Γ t t0 ts t' v,
    is_erased_term t0 ->
    is_erased_term ts ->
    wf t0 0 ->
    wf ts 1 ->
    subset (fv t0) (support Γ) ->
    subset (fv ts) (support Γ) ->
    subset (fv v) (support Γ) ->
    [ Γ ⊫ t' : T_top ] ->
    [ Γ ⊫ t ≡ succ t' ] ->
    [ Γ ⊫ open 0 ts t' ≡ v ] ->
    [ Γ ⊫ tmatch t t0 ts ≡ v ].
Proof.
  unfold open_equivalent, open_reducible;
    repeat step || t_instantiate_sat3_nil || t_substitutions.
  eapply equivalent_trans; eauto; repeat step || t_substitutions.
  eapply equivalent_trans; try apply equivalent_match_scrut;
    eauto with erased fv wf.
  top_level_unfold reduces_to; steps.
  eapply equivalent_trans; try apply equivalent_match_scrut;
    eauto with erased fv wf;
    try solve [ apply equivalent_succ; equivalent_star ].

  eapply equivalent_trans; try solve [ equivalent_star ].
  apply equivalent_context; eauto with erased wf fv.
  apply equivalent_sym; equivalent_star.
Qed.

Lemma delta_beta_match_scrut:
  forall Θ Γ t t' t0 ts,
    is_erased_term t0 ->
    is_erased_term ts ->
    wf t0 0 ->
    wf ts 1 ->
    subset (fv t0) (support Γ) ->
    subset (fv ts) (support Γ) ->
    [ Θ; Γ ⊨ t ≡ t' ] ->
    [ Θ; Γ ⊨ tmatch t t0 ts ≡ tmatch t' t0 ts ].
Proof.
  unfold open_equivalent; steps; apply equivalent_match_scrut;
    eauto with erased wf fv.
Qed.

Opaque list_match.

Lemma delta_beta_list_match_nil:
  forall Θ Γ t t1 t2 v,
    is_erased_term t2 ->
    wf t2 2 ->
    subset (fv t2) (support Γ) ->
    [ Θ; Γ ⊨ t ≡ tnil ] ->
    [ Θ; Γ ⊨ t1 ≡ v ] ->
    [ Θ; Γ ⊨ list_match t t1 t2 ≡ v ].
Proof.
  unfold open_equivalent; repeat step || t_instantiate_sat3 || rewrite substitute_list_match;
    eauto with wf.
  eapply equivalent_trans; eauto.
  eapply equivalent_trans; try apply equivalent_list_match_scrut; eauto;
    eauto with erased wf fv;
    try solve [ equivalent_star ].

  evaluate_list_match; repeat step; eauto with wf fv erased.
  - apply reducible_nil; auto.
  - equivalent_star; eauto 3 with wf erased fv step_tactic.
  - unfold tcons in *; steps.
Qed.

Opaque List.

Lemma equivalent_right_eval_left:
  forall t t' v,
    cbv_value v  ->
    [ t ≡ tright t' ] ->
    t ~>* tleft v ->
    False.
Proof.
  intros.
  apply right_left_equivalence with t' v; auto.
  eapply equivalent_trans; eauto using equivalent_sym; equivalent_star.
Qed.

Lemma equivalent_right_eval_nil:
  forall t t',
    [ t ≡ tright t' ] ->
    t ~>* tnil ->
    False.
Proof.
  intros.
  apply equivalent_right_eval_left with t t' uu; steps.
Qed.

Lemma equivalent_context2:
  forall C t1 t1' t2 t2',
    is_erased_term C ->
    wf C 2 ->
    pfv C term_var = nil ->
    [ t1 ≡ t1' ] ->
    [ t2 ≡ t2' ] ->
    [ open 0 (open 1 C t1) t2 ≡ open 0 (open 1 C t1') t2' ].
Proof.
  intros.
  eapply equivalent_trans; try solve [ apply equivalent_context; steps; eauto with erased wf fv ].
  repeat rewrite (swap_term_holes_open C); steps; eauto with wf.
  apply equivalent_context; steps; eauto with erased wf fv.
Qed.

Lemma delta_beta_list_match_cons:
  forall Γ h t t1 t2 v,
    wf t1 0 ->
    wf t2 2 ->
    is_erased_term t1 ->
    is_erased_term t2 ->
    subset (fv t1) (support Γ) ->
    subset (fv t2) (support Γ) ->
    [ Γ ⊫ t : List ] ->
    [ Γ ⊫ t ≡ tcons h t ] ->
    [ Γ ⊫ open 0 (open 1 t2 h) t ≡ v ] ->
    [ Γ ⊫ list_match t t1 t2 ≡ v ].
Proof.
  unfold open_equivalent, open_reducible;
    repeat step || t_instantiate_sat3_nil || t_substitutions || rewrite substitute_list_match;
    eauto with wf.

  eapply equivalent_trans; eauto.

  eapply equivalent_trans; try apply equivalent_list_match_scrut; eauto;
    eauto with erased wf fv;
    try solve [ equivalent_star ].

  evaluate_list_match2; repeat step || t_invert_star || unfold tcons in *; eauto with wf fv erased;
    eauto using reducibility_equivalent2, is_erased_list, wf_list;
    try solve [ unfold tnil in *; repeat step || t_invert_star ].

  eapply equivalent_trans; eauto.
  apply_anywhere right_right_star.
  apply equivalent_context2; steps; eauto with fv wf erased.
  - apply equivalent_sym; equivalent_star; eauto using pp_pp_star_1.
  - apply equivalent_sym; equivalent_star; eauto using pp_pp_star_2.
Qed.

Lemma delta_beta_list_match_scrut:
  forall Θ Γ t t' t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 2 ->
    subset (fv t1) (support Γ) ->
    subset (fv t2) (support Γ) ->
    [ Θ; Γ ⊨ t ≡ t' ] ->
    [ Θ; Γ ⊨ list_match t t1 t2 ≡ list_match t' t1 t2 ].
Proof.
  unfold open_equivalent; repeat step || rewrite substitute_list_match;
    try apply equivalent_list_match_scrut;
    eauto with erased wf fv.
Qed.

Lemma open_equivalent_context:
  forall Θ Γ t1 t2 C,
    is_erased_term C ->
    wf C 1 ->
    subset (fv C) (support Γ) ->
    [ Θ; Γ ⊨ t1 ≡ t2 ] ->
    [ Θ; Γ ⊨ open 0 C t1 ≡ open 0 C t2 ].
Proof.
  unfold open_equivalent;
    repeat step || t_instantiate_sat3 || t_substitutions || apply equivalent_context;
    eauto with fv wf erased.
Qed.

Lemma delta_beta_left:
  forall Θ Γ t t',
    [ Θ; Γ ⊨ t ≡ t' ] ->
    [ Θ; Γ ⊨ tleft t ≡ tleft t' ].
Proof.
  intros.
  unshelve epose proof (open_equivalent_context _ _ _ _ (tleft (lvar 0 term_var)) _ _ _ H);
    steps; eauto with sets.
Qed.

Lemma delta_beta_right:
  forall Θ Γ t t',
    [ Θ; Γ ⊨ t ≡ t' ] ->
    [ Θ; Γ ⊨ tright t ≡ tright t' ].
Proof.
  intros.
  unshelve epose proof (open_equivalent_context _ _ _ _ (tright (lvar 0 term_var)) _ _ _ H);
    steps; eauto with sets.
Qed.

Opaque fix_default'.

Lemma delta_beta_fix_zero:
  forall Γ t default v,
    wf default 0 ->
    wf t 1 ->
    is_erased_term default ->
    is_erased_term t ->
    subset (fv default) (support Γ) ->
    subset (fv t) (support Γ) ->
    [ Γ ⊫ default ≡ v ] ->
    [ Γ ⊫ fix_default' t default zero ≡ v ].
Proof.
  unfold open_equivalent; repeat step || rewrite subst_fix_default; eauto with wf.

  evaluate_fix_default; steps; eauto with wf.
  eapply equivalent_trans; eauto.

  equivalent_star; eauto 4 with fv erased wf step_tactic.
Qed.

Lemma delta_beta_fix_succ:
  forall Γ t default fuel v,
    is_nat_value fuel ->
    wf default 0 ->
    wf t 1 ->
    is_erased_term default ->
    is_erased_term t ->
    subset (fv default) (support Γ) ->
    subset (fv t) (support Γ) ->
    [ Γ ⊫ open 0 t (fix_default' t default fuel) ≡ v ] ->
    [ Γ ⊫ fix_default' t default (succ fuel) ≡ v ].
Proof.
  unfold open_equivalent; repeat step || t_instantiate_sat3_nil || t_substitutions ||
                                 rewrite subst_fix_default in * by eauto with wf.
  evaluate_fix_default; repeat step || rewrite (substitute_nothing5 fuel) in * by eauto with fv;
    eauto with wf; eauto with is_nat_value.
  eapply equivalent_trans; eauto.
  equivalent_star; eauto with erased wf fv step_tactic.
Qed.

Lemma delta_beta_obs_equiv:
  forall Γ t1 t2,
    [ Γ ⊨ t1 ⤳* t2 ] ->
    [ Γ ⊫ t1 ≡ t2 ].
Proof.
  induction 1; repeat step;
    eauto using delta_beta_var;
    eauto using delta_beta_pair;
    eauto using delta_beta_first;
    eauto using delta_beta_second;
    eauto using delta_beta_app1;
    eauto using delta_beta_app2;
    eauto using delta_beta_match_zero;
    eauto using delta_beta_match_succ;
    eauto using delta_beta_match_scrut;
    eauto using delta_beta_list_match_nil;
    eauto using delta_beta_list_match_cons;
    eauto using delta_beta_list_match_scrut;
    eauto using delta_beta_left;
    eauto using delta_beta_right;
    eauto using delta_beta_fix_zero;
    eauto using delta_beta_fix_succ;
    eauto using open_equivalent_refl.
Qed.