Require Import CompCert.Events.
Require Import CompCert.Smallstep.
Require Import Common.Definitions.
Require Import Common.Util.
Require Import Common.Values.
Require Import Common.Memory.
Require Import Common.CompCertExtensions.
Require Import Common.Traces.
Require Import Common.RenamingOption.
Require Import Source.Language.
Require Import Source.GlobalEnv.
Require Import Lib.Tactics.
Require Import Lib.Monads.
Require Import Lib.Extra.

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq.
From mathcomp Require ssrnat.

Require Import Lia.

Canonical ssrnat.nat_eqType.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Set Bullet Behavior "Strict Subproofs".

Import Source.

Inductive cont : Type :=
| Kstop
| Kbinop1 (op: binop) (re: expr) (k: cont)
| Kbinop2 (op: binop) (lv: value) (k: cont)
| Kseq (e: expr) (k: cont)
| Kif (e1: expr) (e2: expr) (k: cont)
| Kalloc (k: cont)
| Kderef (k: cont)
| Kassign1 (e: expr) (k: cont)
| Kassign2 (v: value) (k: cont)
| Kcall (C: Component.id) (P: Procedure.id) (k: cont)
| Kcallptr1 (funptr: expr) (k: cont)
| Kcallptr2 (arg: value) (k: cont)
.

Module CS.

Record frame : Type := Frame {
  f_component : Component.id;
  f_arg       : value;
  f_cont      : cont
}.

Definition stack : Type := list frame.

Record state : Type := State {
  s_component : Component.id;
  s_stack     : stack;
  s_memory    : Memory.t;
  s_cont      : cont;
  s_expr      : expr;
  s_arg       : value
}.

Notation "[ 'State' C , stk , mem , k , e , arg ]" :=
  (State C stk mem k e arg)
  (at level 0, format "[ 'State'  C ,  stk ,  mem ,  k ,  e ,  arg ]").

Ltac unfold_state st :=
  let C := fresh "C" in
  let s := fresh "s" in
  let mem := fresh "mem" in
  let k := fresh "k" in
  let e := fresh "e" in
  let arg := fresh "arg" in
  destruct st as [C s mem k e arg].

Ltac unfold_states :=
  repeat (match goal with
          | st: state |- _ => unfold_state st
          end).

Import MonadNotations.
Open Scope monad_scope.

Definition initial_machine_state (p: program) : state :=
  match prog_main p with
  | Some main_expr => State Component.main [::] (prepare_buffers p) Kstop main_expr (Int 0)
  | None =>
    (* this case shouldn't happen for a well formed p *)
    State Component.main [::] emptym Kstop E_exit (Int 0)
  end.

(* transition system *)

Definition initial_state (p: program) (st: state) : Prop :=
  st = initial_machine_state p.

Definition final_state (st: state) : Prop :=
  let: State C s mem k e arg := st in
  e = E_exit \/ (exists v, e = E_val v /\ k = Kstop /\ s = []).

Inductive kstep (G: global_env) : state -> trace event -> state -> Prop :=
| KS_Binop1 : forall C s mem k op e1 e2 arg,
    kstep G [State C, s, mem, k, E_binop op e1 e2, arg] E0
            [State C, s, mem, Kbinop1 op e2 k, e1, arg]
| KS_Binop2 : forall C s mem k op v1 e2 arg,
    kstep G [State C, s, mem, Kbinop1 op e2 k, E_val v1, arg] E0
            [State C, s, mem, Kbinop2 op v1 k, e2, arg]
| KS_BinopEval : forall C s mem k op v1 v2 arg,
    kstep G [State C, s, mem, Kbinop2 op v1 k, E_val v2, arg] E0
            [State C, s, mem, k, E_val (eval_binop op v1 v2), arg]
| KS_Seq1 :  forall C s mem k e1 e2 arg,
    kstep G [State C, s, mem, k, E_seq e1 e2, arg] E0
            [State C, s, mem, Kseq e2 k, e1, arg]
| KS_Seq2 : forall C s mem k v e2 arg,
    kstep G [State C, s, mem, Kseq e2 k, E_val v, arg] E0
            [State C, s, mem, k, e2, arg]
| KS_If1 : forall C s mem k e1 e2 e3 arg,
    kstep G [State C, s, mem, k, E_if e1 e2 e3, arg] E0
            [State C, s, mem, Kif e2 e3 k, e1, arg]
| KS_If2 : forall C s mem k e2 e3 i arg,
    kstep G [State C, s, mem, Kif e2 e3 k, E_val (Int i), arg] E0
            [State C, s, mem, k, if i != 0%Z then e2 else e3, arg]
| KS_Arg : forall C s mem k v,
    kstep G [State C, s, mem, k, E_arg, v] E0
            [State C, s, mem, k, E_val v, v]
| KS_LocalBuffer : forall C s mem k arg,
    kstep G [State C, s, mem, k, E_local, arg] E0
            [State C, s, mem, k, E_val (Ptr (Permission.data,C,Block.local,0%Z)), arg]
| KS_Alloc1 : forall C s mem k e arg,
    kstep G [State C, s, mem, k, E_alloc e, arg] E0
            [State C, s, mem, Kalloc k, e, arg]
| KS_AllocEval : forall C s mem mem' k size ptr arg,
    (size > 0) % Z ->
    Memory.alloc mem C (Z.to_nat size) = Some (mem', ptr) ->
    kstep G [State C, s, mem, Kalloc k, E_val (Int size), arg] E0
            [State C, s, mem', k, E_val (Ptr ptr), arg]
| KS_Deref1 : forall C s mem k e arg,
    kstep G [State C, s, mem, k, E_deref e, arg] E0
          [State C, s, mem, Kderef k, e, arg]
| KS_DerefEval : forall C s mem k P' C' b' o' v arg,
    (* C = C' -> *)
    Memory.load mem (P',C',b',o') = Some v ->
    kstep G [State C, s, mem, Kderef k, E_val (Ptr (P',C',b',o')), arg] E0
          [State C, s, mem, k, E_val v, arg]
| KS_FunPtr : forall C s mem k P Pexpr arg,
    find_procedure (genv_procedures G) C P = Some Pexpr ->
    kstep G [State C, s, mem, k, E_funptr P, arg] E0
          [State C, s, mem, k, E_val (Ptr (Permission.code, C, P, 0%Z)), arg]
| KS_Assign1 : forall C s mem k e1 e2 arg,
    kstep G [State C, s, mem, k, E_assign e1 e2, arg] E0
            [State C, s, mem, Kassign1 e1 k, e2, arg]
| KS_Assign2 : forall C s mem k v e1 arg,
    kstep G [State C, s, mem, Kassign1 e1 k, E_val v, arg] E0
            [State C, s, mem, Kassign2 v k, e1, arg]
| KS_AssignEval : forall C s mem mem' k v P' C' b' o' arg,
    (* C = C' -> *)
    Memory.store mem (P', C', b', o') v = Some mem' ->
    kstep G [State C, s, mem, Kassign2 v k, E_val (Ptr (P', C', b', o')), arg] E0
          [State C, s, mem', k, E_val v, arg]
| KS_InitCall : forall C s mem k C' P e arg,
    kstep G [State C, s, mem, k, E_call C' P e, arg] E0
          [State C, s, mem, Kcall C' P k, e, arg]
| KS_InitCallPtr1 : forall C s mem k e1 e2 arg,
    kstep G [State C, s, mem, k, E_callptr e1 e2, arg] E0
          [State C, s, mem, Kcallptr1 e1 k, e2, arg]
| KS_InitCallPtr2 : forall C s mem k e1 v arg,
    kstep G [State C, s, mem, Kcallptr1 e1 k, E_val v, arg] E0
          [State C, s, mem, Kcallptr2 v k, e1, arg]
| KS_InitCallPtr3 : forall C s mem k v C' P arg,
    C = C' ->
    kstep G [State C, s, mem, Kcallptr2 v k, E_val (Ptr (Permission.code, C', P, 0%Z)),
             arg] E0
          [State C, s, mem, Kcall C' P k, E_val v, arg]
| KS_InternalCall : forall C s mem k C' P v P_expr old_call_arg,
    C = C' ->
    (* retrieve the procedure code *)
    find_procedure (genv_procedures G) C' P = Some P_expr ->
    kstep G [State C, s, mem, Kcall C' P k, E_val v, old_call_arg] E0
            [State C', Frame C old_call_arg k :: s, mem, Kstop, P_expr, v]
| KS_ExternalCall : forall C s mem k C' P v P_expr old_call_arg,
    C <> C' ->
    (* check permission *)
    imported_procedure (genv_interface G) C C' P  ->
    (* retrieve the procedure code *)
    find_procedure (genv_procedures G) C' P = Some P_expr ->
    kstep G [State C, s, mem, Kcall C' P k, E_val v, old_call_arg]
            [:: ECall C P v mem C']
            [State C', Frame C old_call_arg k :: s, mem, Kstop, P_expr, v]
| KS_InternalReturn: forall C s mem k v arg C' old_call_arg,
    C = C' ->
    kstep G [State C, Frame C' old_call_arg k :: s, mem, Kstop, E_val v, arg] E0
            [State C', s, mem, k, E_val v, old_call_arg]
| KS_ExternalReturn: forall C s mem k v arg C' old_call_arg,
    C <> C' ->
    kstep G [State C, Frame C' old_call_arg k :: s, mem, Kstop, E_val v, arg]
            [:: ERet C v mem C']
            [State C', s, mem, k, E_val v, old_call_arg].

Lemma kstep_component G s t s' :
  kstep G s t s' ->
  s_component s' =
  if t is e :: _ then next_comp_of_event e
  else s_component s.
Proof. by case: s t s' /. Qed.

Lemma final_state_stuck G (st: state) :
  final_state st ->
  forall t st', ~ kstep G st t st'.
Proof.
move=> Hfinal t st' Hstep.
case: st t st' / Hstep Hfinal => //= *;
by repeat match goal with
| H : _ \/ _ |- _ => case: H=> ?
| H : exists _, _ |- _ => case: H => ??
| H : _ /\ _ |- _ => case: H => ??
end.
Qed.

(* functional kstep *)

Definition eval_kstep (G : global_env) (st : state) : option (trace event * state) :=
  let: State C s mem k e arg := st in
  match e with
  (* pushing a new continuation *)
  | E_binop b_op e1 e2 =>
    ret (E0, [State C, s, mem, Kbinop1 b_op e2 k, e1, arg])
  | E_seq e1 e2 =>
    ret (E0, [State C, s, mem, Kseq e2 k, e1, arg])
  | E_if e1 e2 e3 =>
    ret (E0, [State C, s, mem, Kif e2 e3 k, e1, arg])
  | E_arg =>
    (* if arg is Int v then *)
      ret (E0, [State C, s, mem, k, E_val arg(* (Int v) *), arg])
    (* else None *)
  | E_local =>
    ret (E0, [State C, s, mem, k, E_val (Ptr (Permission.data, C, Block.local, 0%Z)), arg])
  | E_alloc e =>
    ret (E0, [State C, s, mem, Kalloc k, e, arg])
  | E_deref e =>
    ret (E0, [State C, s, mem, Kderef k, e, arg])
  | E_funptr P =>
    match find_procedure (genv_procedures G) C P with
    | Some Pexpr => ret (E0, [State C, s, mem, k,
                              E_val (Ptr (Permission.code, C, P, 0%Z)), arg])
    | None => None
    end
  | E_assign e1 e2 =>
    ret (E0, [State C, s, mem, Kassign1 e1 k, e2, arg])
  | E_callptr e1 e2 =>
    ret (E0, [State C, s, mem, Kcallptr1 e1 k, e2, arg])
  | E_call C' P e =>
    ret (E0, [State C, s, mem, Kcall C' P k, e, arg])
  (* evaluating current continuation *)
  | E_val v =>
    match k with
    | Kbinop1 b_op e2 k' =>
      ret (E0, [State C, s, mem, Kbinop2 b_op v k', e2, arg])
    | Kbinop2 b_op v1 k' =>
      ret (E0, [State C, s, mem, k', E_val (eval_binop b_op v1 v), arg])
    | Kseq e2 k' =>
      ret (E0, [State C, s, mem, k', e2, arg])
    | Kif e2 e3 k' =>
      match v with
      | Int z => ret (E0, [State C, s, mem, k', if z != 0%Z then e2 else e3, arg])
      | _ => None
      end
    | Kalloc k' =>
      match v with
      | Int size =>
        if (size >? 0) % Z then
          do (mem',ptr) <- Memory.alloc mem C (Z.to_nat size);
          ret (E0, [State C, s, mem', k', E_val (Ptr ptr), arg])
        else
          None
      | _ => None
      end
    | Kderef k' =>
      match v with
      | Ptr (P',C',b',o') =>
        (* if C == C' then *)
          do v <- Memory.load mem (P',C',b',o');
          ret (E0, [State C, s, mem, k', E_val v, arg])
        (* else *)
        (*   None *)
      | _ => None
      end
    | Kassign1 e1 k' =>
      ret (E0, [State C, s, mem, Kassign2 v k', e1, arg])
    | Kassign2 v' k' =>
      match v with
      | Ptr (P',C',b',o') =>
        (* if C == C' then *)
          do mem' <- Memory.store mem (P',C',b',o') v';
          ret (E0, [State C, s, mem', k', E_val v', arg])
        (* else *)
        (*   None *)
      | _ => None
      end
    | Kcallptr1 efunptr k' =>
      ret (E0, [State C, s, mem, Kcallptr2 v k', efunptr, arg])
    | Kcallptr2 varg k' =>
      match v with
      | Ptr (perm, C', P', 0%Z) =>
        if (Permission.eqb perm Permission.code) && (C' =? C) then
            ret (E0, [State C, s, mem, Kcall C' P' k', E_val varg, arg])
        else None
      | _ => None
      end
    | Kcall C' P k' =>
      (*match v with
      | Int i =>*)
        if C == C' then
          (* retrieve the procedure code *)
          do P_expr <- find_procedure (genv_procedures G) C' P;
          ret (E0, [State C', Frame C arg k' :: s, mem, Kstop, P_expr, v])
        else if imported_procedure_b (genv_interface G) C C' P then
          (* retrieve the procedure code *)
          do P_expr <- find_procedure (genv_procedures G) C' P;
          ret ([ECall C P v mem C'], [State C', Frame C arg k' :: s, mem, Kstop, P_expr, v])
        else
          None
      (*| _ => None
      end*)
    | Kstop =>
      match (*v,*) s with
      | (*Int i,*) Frame C' old_call_arg k' :: s' =>
        let t := if C == C' then E0 else [:: ERet C v mem C'] in
        ret (t, [State C', s', mem, k', E_val v, old_call_arg])
      | (*_,*) _ => None
      end
    end
  | E_exit => None
  end.

Hint Unfold eval_kstep.

Fixpoint execN (n: nat) (G: global_env) (st: state) : option state :=
  match n with
  | O => None
  | S n' =>
    match eval_kstep G st with
    | None => Some st
    | Some (_, st') => execN n' G st'
    end
  end.

Close Scope monad_scope.

(* Semantics Properties *)

Theorem eval_kstep_complete:
  forall G st t st',
    kstep G st t st' -> eval_kstep G st = Some (t, st').
Proof.
  intros G st t st' Hkstep.
  inversion Hkstep; subst; simpl; auto;
    try (unfold Memory.store, Memory.load, Memory.alloc in *;
         repeat simplify_nat_equalities;
         repeat simplify_option;
         reflexivity).
  (* if expressions *)
  - assert (Hsize: (size >? 0) % Z = true). {
      destruct size; try inversion H; auto.
    }
    rewrite Hsize.
    rewrite H0. reflexivity.
  (* external calls *)
  - move/eqP/negbTE: H => ->.
    apply imported_procedure_iff in H0.
    rewrite H0 H1.
    reflexivity.
  (* external return *)
  - move/eqP/negbTE: H => ->.
    reflexivity.
Qed.

Theorem eval_kstep_sound:
  forall G st t st',
    eval_kstep G st = Some (t, st') -> kstep G st t st'.
Proof.
  intros.
  unfold_states.
  match goal with
  | H: eval_kstep _ _ = Some _ |- kstep _ [State _, _, _, _, ?E, _] _ [State _, _, _, _, _, _] =>
    destruct E; simpl in H;
      try discriminate;
      try (repeat simplify_option;
           econstructor; eauto;
           repeat simplify_nat_equalities;
           reflexivity)
  end.
  - repeat simplify_option.
    + destruct (C0 == C) eqn:eC0.
      * assert (C0 = C). by apply/eqP. subst.
        eapply KS_InternalReturn; by auto.
      * econstructor. intros ?. subst. by rewrite eq_refl in eC0.
    + econstructor; eauto.
    + econstructor; eauto.
    + econstructor; eauto.
    + destruct z; econstructor; eauto; discriminate.
    + econstructor; eauto.
      * apply Zgt_is_gt_bool. assumption.
    + by econstructor; eauto; apply/eqP.
    + econstructor; eauto.
    + by econstructor; eauto; apply/eqP.
    + econstructor; eauto. by apply/eqP.
    + econstructor; eauto; first exact/eqP/negbT.
      apply imported_procedure_iff. assumption.
    + econstructor; eauto.
    + move: Heqb => /andP.
      intros [Hperm HC].
      assert (i0 = Permission.code). by apply /Permission.eqP. subst.
      assert (i1 = C). by apply beq_nat_true. subst.
      by econstructor.
Qed.

Theorem eval_kstep_correct:
  forall G st t st',
    eval_kstep G st = Some (t, st') <-> kstep G st t st'.
Proof.
  split.
  apply eval_kstep_sound.
  apply eval_kstep_complete.
Qed.

Section Semantics.
  Variable p: program.

  Hypothesis valid_program:
    well_formed_program p.

  Hypothesis complete_program:
    closed_program p.

  Let G := prepare_global_env p.

  Definition sem :=
    @Semantics_gen event state global_env kstep (initial_state p) final_state G.

  Lemma receptiveness_step:
    forall s t1 s1 t2,
      kstep G s t1 s1 -> equal_and_nil_or_singleton t1 t2 ->
      exists s2, kstep G s t2 s2.
  Proof.
    intros s t1 s1 t2.
    intros Hkstep Hmatch_traces.
    inversion Hkstep; subst;
    inversion Hmatch_traces; subst;
      try (eexists; apply Hkstep);
      match goal with H: event_equal _ _ |- _ => apply event_equal_equal in H end;
      subst; eexists; exact Hkstep.
  Qed.

  Lemma singleton_traces:
    single_events sem.
  Proof.
    unfold single_events.
    intros s t s' Hstep.
    inversion Hstep; subst; simpl; auto.
  Qed.

  Theorem receptiveness:
    receptive sem.
  Proof.
    constructor.
    - apply receptiveness_step.
    - apply singleton_traces.
  Qed.

  Local Open Scope fset_scope.

  Definition stack_components (cs: state) : {fset Component.id} :=
    s_component cs |: fset [seq f_component f | f <- s_stack cs].

  Lemma stack_components_step cs t cs' :
    Step sem cs t cs' ->
    fsubset (stack_components cs) (domm (prog_interface p)) ->
    fsubset (stack_components cs') (domm (prog_interface p)).
  Proof.
  case: cs t cs' / => //=.
  - (* Internal Call *)
    move=> C stk mem k _ P v P_expr arg <-; rewrite /stack_components /=.
    by rewrite fset_cons fsetUA fsetUid.
  - (* External Call *)
    move=> C stk mem k C' P v P_expr arg _; rewrite /stack_components /=.
    rewrite (fsubU1set C') mem_domm fset_cons.
    by case/(cprog_closed_interface complete_program)=> CI [->].
  - (* Internal Return *)
    move=> C stk mem k v arg _ old <-; rewrite /stack_components /=.
    by rewrite fset_cons fsetUA fsetUid.
  - (* External Return *)
    move=> C stk mem k v arg C' old _; rewrite /stack_components /=.
    by rewrite (fsubU1set C) fset_cons; case/andP.
  Qed.

  Lemma stack_components_star cs t cs' :
    initial_state p cs ->
    Star sem cs t cs' ->
    fsubset (stack_components cs') (domm (prog_interface p)).
  Proof.
  move=> init star.
  have main_ok : Component.main \in domm (prog_interface p).
    have := cprog_main_existence complete_program.
    rewrite wfprog_defined_procedures // mem_domm /prog_main /find_procedure.
    by case: getm.
  have {init main_ok} cs_ok : fsubset (stack_components cs) (domm (prog_interface p)).
    rewrite init /initial_machine_state /stack_components.
    by case e_main: (prog_main p)=> [mainP|] /=; rewrite -fset0E fsetU0 fsub1set.
  elim: cs t cs' / star cs_ok=> // cs1 t1 cs2 t2 cs3 t step _ IH _ cs1_ok.
  by apply: IH; apply: stack_components_step cs1_ok; eauto.
  Qed.

  Fixpoint unstutter (T : eqType) (x : T) (s : seq T) :=
    if s is x' :: s' then
      if x == x' then unstutter x s'
      else x' :: unstutter x' s'
    else [::].

  Definition stack_state_of (cs: state) : stack_state :=
    let: State curr stk _ _ _ _ := cs in
    StackState curr (unstutter curr (map f_component stk)).

  Lemma star_component s1 t s2 :
    Star sem s1 t s2 ->
    s_component s2 =
    last (s_component s1) [seq next_comp_of_event e | e <- t].
  Proof.
  elim: s1 t s2 / => //= s1 t1 s2 t2 s3 _ Hstep _ -> ->.
  rewrite map_cat last_cat (kstep_component Hstep).
  move/singleton_traces: Hstep.
  by case: t1=> [|e [|e' t1]] //= *; lia.
  Qed.

  Lemma initial_state_exists:
    exists s, initial_state p s.
  Proof.
    unfold initial_state, initial_machine_state;
      by eauto.
  Qed.

  Lemma load_component_prog_interface_intitial_state s ptr ptr':
    initial_state p s ->
    Memory.load (s_memory s) ptr = Some (Ptr ptr') ->
    Pointer.component ptr' \in domm (prog_interface p).
  Proof.
    intros Hini Hload.
    unfold initial_state, initial_machine_state in Hini.
    apply cprog_main_existence in complete_program as HisSome.
    destruct (prog_main p) eqn:emain; last discriminate. subst. simpl in *.
    unfold prepare_buffers, Memory.load in *. rewrite mapmE in Hload.
    find_if_inside_hyp Hload; last discriminate.
    destruct ((prog_buffers p (Pointer.component ptr))) as [buf|] eqn:ebuf;
      last discriminate.
    simpl in *. rewrite ComponentMemory.load_prealloc in Hload.
    find_if_inside_hyp Hload; last discriminate.
    destruct (setm emptym 0 buf (Pointer.block ptr)) as [buf'|] eqn:esetm;
      last discriminate.
    destruct buf'; first (find_if_inside_hyp Hload; discriminate).
    apply nth_error_In in Hload.
    rewrite setmE in esetm.
    find_if_inside_hyp esetm; last discriminate. inversion esetm; subst; clear esetm.
    assert (exists x, prog_interface p (Pointer.component ptr) = Some x) as [? H_].
    {
      apply/dommP. rewrite wfprog_defined_buffers; auto. apply/dommP; by eauto.
    }
    assert (H__: prog_interface p (Pointer.component ptr)). by rewrite H_.
    specialize (wfprog_well_formed_buffers valid_program H__) as [? Bwf].
    clear H_ H__. unfold Buffer.well_formed_buffer_opt in *.
    rewrite ebuf in Bwf. simpl in *. move : Bwf => /andP => [[_ Bwf]].
    apply In_in in Hload.
    assert (contra: exists2 x, x \in l & ~~ (fun v : value => ~~ is_ptr v) x).
    { by eauto. }
    move : contra => /allPn => contra. by rewrite Bwf in contra.
  Qed.

  Definition runtime_val_wf_wrt_prog_interface_ (v: value) : bool :=
    match v with
      | Ptr ptr => Pointer.component ptr \in domm (prog_interface p)
      | _ => true
    end.

  Fixpoint runtime_expr_struct_invariant
           (e: expr) (val_test: value -> bool) : bool :=
    match e with
    | E_val v => val_test v
    | E_binop _ e1 e2 =>
      runtime_expr_struct_invariant e1 val_test &&
      runtime_expr_struct_invariant e2 val_test
    | E_seq e1 e2 =>
      runtime_expr_struct_invariant e1 val_test &&
      runtime_expr_struct_invariant e2 val_test
    | E_if e1 e2 e3 =>
      runtime_expr_struct_invariant e1 val_test &&
      runtime_expr_struct_invariant e2 val_test &&
      runtime_expr_struct_invariant e3 val_test
    | E_alloc e =>
      runtime_expr_struct_invariant e val_test
    | E_deref e =>
      runtime_expr_struct_invariant e val_test
    | E_assign e1 e2 =>
      runtime_expr_struct_invariant e1 val_test &&
      runtime_expr_struct_invariant e2 val_test
    | E_call _ _ e =>
      runtime_expr_struct_invariant e val_test
    | E_callptr e1 e2 =>
      runtime_expr_struct_invariant e1 val_test &&
      runtime_expr_struct_invariant e2 val_test
    | E_funptr _
    | E_arg
    | E_local
    | E_exit => true
    end.

  Fixpoint cont_struct_invariant (k: cont) (val_test: value -> bool) : bool :=
    match k with
    | Kbinop1 _ e k2 =>
      runtime_expr_struct_invariant e val_test &&
      cont_struct_invariant k2 val_test
    | Kbinop2 _ v k2 =>
      val_test v &&
      cont_struct_invariant k2 val_test
    | Kseq e k2 =>
      runtime_expr_struct_invariant e val_test &&
      cont_struct_invariant k2 val_test
    | Kif e1 e2 k3 =>
      runtime_expr_struct_invariant e1 val_test &&
      runtime_expr_struct_invariant e2 val_test &&
      cont_struct_invariant k3 val_test
    | Kalloc k2 =>
      cont_struct_invariant k2 val_test
    | Kderef k2 =>
      cont_struct_invariant k2 val_test
    | Kassign1 e k2 =>
      runtime_expr_struct_invariant e val_test &&
      cont_struct_invariant k2 val_test
    | Kassign2 v k2 =>
      val_test v &&
      cont_struct_invariant k2 val_test
    | Kcall _ _ k2 =>
      cont_struct_invariant k2 val_test
    | Kcallptr1 e k2 =>
      runtime_expr_struct_invariant e val_test &&
      cont_struct_invariant k2 val_test
    | Kcallptr2 v k2 =>
      val_test v &&
      cont_struct_invariant k2 val_test
    | Kstop => true
    end.

  Definition stack_wf_wrt_prog_interface (s: stack) (val_test: value -> bool) : bool :=
    all (fun frm =>
           (f_component frm \in domm (prog_interface p))
           &&
           val_test (f_arg frm)
           &&
           cont_struct_invariant (f_cont frm) val_test
        )
        s.

  Lemma values_are_integers_runtime_expr_wf_wrt_prog_interface e:
    values_are_integers e ->
    runtime_expr_struct_invariant e (runtime_val_wf_wrt_prog_interface_).
  Proof.
    induction e; auto; intros Hval; inversion Hval as [Hval'];
      try (
          move : Hval' => /andP => [[Hval1 Hval2]];
                                   specialize (IHe1 Hval1);
                                   specialize (IHe2 Hval2);
                                   simpl; by rewrite IHe1 IHe2
        ).
    - destruct v; by auto.
    - move : Hval' => /andP => [[Hval1 Hval_]].
      move : Hval_ => /andP => [[Hval2 Hval3]].
      specialize (IHe1 Hval1).
      specialize (IHe2 Hval2).
      specialize (IHe3 Hval3).
      simpl. by rewrite IHe1 IHe2 IHe3.
  Qed.

  Lemma well_formed_expr_runtime_expr_wf_wrt_prog_interface C e:
    well_formed_expr p C e ->
    runtime_expr_struct_invariant e runtime_val_wf_wrt_prog_interface_.
  Proof.
    unfold well_formed_expr. intros [_ [? _]].
    by apply values_are_integers_runtime_expr_wf_wrt_prog_interface.
  Qed.

  Lemma runtime_val_wf_wrt_prog_interface_eval_binop v1 v2 op:
    runtime_val_wf_wrt_prog_interface_ v1 ->
    runtime_val_wf_wrt_prog_interface_ v2 ->
    runtime_val_wf_wrt_prog_interface_ (eval_binop op v1 v2).
  Proof.
    intros Hv1 Hv2.
    destruct op; destruct v1 as [| [[[perm1 c1] b1] o1] |];
      destruct v2 as [| [[[perm2 c2] b2] o2] |]; simpl in *; auto.
    - find_if_inside_goal; by auto.
    - find_if_inside_goal; by auto.
  Qed.

  Lemma load_component_prog_interface_inductively_provable s t s':
    initial_state p s ->
    Star sem s t s' ->
    (
      (
        forall ptr ptr',
          Memory.load (s_memory s') ptr = Some (Ptr ptr') ->
          Pointer.component ptr' \in domm (prog_interface p)
      )
      /\
      runtime_expr_struct_invariant (s_expr s') runtime_val_wf_wrt_prog_interface_
      /\
      cont_struct_invariant (s_cont s') runtime_val_wf_wrt_prog_interface_
      /\
      runtime_val_wf_wrt_prog_interface_ (s_arg s')
      /\
      s_component s' \in domm (prog_interface p)
      /\
      stack_wf_wrt_prog_interface (s_stack s') runtime_val_wf_wrt_prog_interface_
    ).
  Proof.
    intros Hini Hstar.
    apply star_iff_starR in Hstar.
    revert Hini.
    induction Hstar as [| s1 t1 s2 t2 s3 ? Hstar12 IHHstar Hstep23];
      subst;
      intros Hini.
    - split; [intros ? ? Hload | split; [| ]].
      + by eapply load_component_prog_interface_intitial_state; eauto.
      + unfold initial_state, initial_machine_state in Hini.
        destruct (prog_main p) eqn:emain; subst; simpl; auto.
        unfold prog_main in emain.
        apply wfprog_well_formed_procedures in emain; auto.
        unfold well_formed_expr in *. destruct emain as [_ [G_ _]].
        by apply values_are_integers_runtime_expr_wf_wrt_prog_interface in G_.
      + unfold initial_state, initial_machine_state in Hini.
        destruct (prog_main p) eqn:emain; subst; simpl; auto.
        * rewrite wfprog_main_existence; auto; by rewrite emain.
        * specialize (cprog_main_existence complete_program) as contra.
          by rewrite emain in contra.
    - specialize (IHHstar Hini)
        as [IHload [IHexpr [IHcont [IHarg [IHcomp IHstack]]]]];
            simpl in *.
      split;
        [
          intros ? ? Hload; inversion Hstep23; subst;
          try (simpl in Hload; eapply IHload; by eauto)
        |].
      + (* Hload in context; case alloc *)
        simpl in *.
        destruct ((Pointer.component ptr, Pointer.block ptr) ==
                  (Pointer.component ptr0, Pointer.block ptr0)) eqn:eqalloc.
        * move : eqalloc => /eqP => eqalloc.
          specialize (Memory.load_after_alloc_eq _ _ _ _ _ _ H0 eqalloc) as Hload'.
          rewrite Hload' in Hload. repeat (find_if_inside_hyp Hload; last discriminate).
          discriminate.
        * assert (Hneq: (Pointer.component ptr, Pointer.block ptr) <>
                        (Pointer.component ptr0, Pointer.block ptr0)).
          { unfold not. move => /eqP => contra. by rewrite contra in eqalloc. }
          specialize (Memory.load_after_alloc _ _ _ _ _ _ H0 Hneq) as Hrewr.
          rewrite Hrewr in Hload. by eapply IHload; eauto.
      + (* Hload in context; case store *)
        simpl in *.
        specialize (Memory.load_after_store _ _ _ _ ptr H) as Hload'.
        rewrite Hload' in Hload.
        find_if_inside_hyp Hload.
        * inversion Hload; subst; clear Hload.
          simpl in IHcont. by move : IHcont => /andP => [[G_ _]].
        * eapply IHload; by eauto.
      + split; [inversion Hstep23; subst; simpl in *; auto;
                try (by move : IHexpr => /andP => [[? ?]]);
                try (by move : IHcont => /andP => [[? ?]])
               |].
        * apply runtime_val_wf_wrt_prog_interface_eval_binop; auto.
          by move : IHcont => /andP => [[? ?]].
        * move : IHexpr => /andP => [[G_ ?]].
          by move : G_ => /andP => [[? ?]].
        * move : IHcont => /andP => [[G_ ?]].
          move : G_ => /andP => [[? ?]].
          by find_if_inside_goal.
        * by apply Memory.component_of_alloc_ptr in H0; subst.
        * destruct v; auto. by eapply IHload; eauto.
        * apply wfprog_well_formed_procedures in H0; auto.
          by eapply well_formed_expr_runtime_expr_wf_wrt_prog_interface; eauto.
        * apply wfprog_well_formed_procedures in H1; auto.
          by eapply well_formed_expr_runtime_expr_wf_wrt_prog_interface; eauto.
        * split; [inversion Hstep23; subst; simpl in *; auto;
                try (move : IHexpr => /andP => [[IHe1 IHe2]]);
                try (move : IHcont => /andP => [[IHk1 IHk2]]);
                auto;
                try (
                    match goal with
                    | H1 : is_true (?X), H2: is_true (?Y) |-
                      is_true (andb ?X ?Y) => by rewrite H1 H2
                    end
                  )
               |].
          -- move : IHe1 => /andP => [[IHe1 IHe2_]].
             by rewrite IHe2_ IHe2 IHcont.
          -- move : IHstack => /andP => [[IHstack _]].
             by move : IHstack => /andP => [[_ ?]].
          -- move : IHstack => /andP => [[IHstack _]].
             by move : IHstack => /andP => [[_ ?]].
          -- split; [inversion Hstep23; subst; simpl in *; auto;
                     try (move : IHexpr => /andP => [[IHe1 IHe2]]);
                     try (move : IHcont => /andP => [[IHk1 IHk2]]);
                     auto;
                     try (
                         match goal with
                         | H1 : is_true (?X), H2: is_true (?Y) |-
                           is_true (andb ?X ?Y) => by rewrite H1 H2
                         end
                       )
                    |].
             ++ do 2 (move : IHstack => /andP => [[IHstack _]]).
                by move : IHstack => /andP => [[_ ?]].
             ++ do 2 (move : IHstack => /andP => [[IHstack _]]).
                by move : IHstack => /andP => [[_ ?]].
             ++ split; [inversion Hstep23; subst; simpl in *; auto |].
                ** by eapply find_procedure_prog_interface; eauto.
                ** by repeat (move : IHstack => /andP => [[IHstack _]]).
                ** inversion Hstep23; subst; simpl in *; auto.
                   --- by rewrite IHarg IHcont IHstack IHcomp.
                   --- by rewrite IHarg IHcont IHstack IHcomp.
                   --- by (move : IHstack => /andP => [[_ ?]]).
                   --- by (move : IHstack => /andP => [[_ ?]]).
  Qed.

  Lemma load_component_prog_interface s t s' ptr ptr' :
    initial_state p s ->
    Star sem s t s' ->
    Memory.load (s_memory s') ptr = Some (Ptr ptr') ->
    Pointer.component ptr' \in domm (prog_interface p).
  Proof.
    intros Hini Hstar.
    specialize (load_component_prog_interface_inductively_provable Hini Hstar);
      intuition.
    (* by eapply H1; eauto. *)
  Qed.

  (* TODO: Move to Common/Memory.v *)
  Lemma load_some_in_domm mem ptr v:
    Memory.load mem ptr = Some v ->
    Pointer.component ptr \in domm mem.
  Proof.
    unfold Memory.load. find_if_inside_goal; last discriminate.
    destruct (mem (Pointer.component ptr)) eqn:emem; last discriminate. intros _.
    apply/dommP. by eauto.
  Qed.

  Lemma initial_state_domm_s_memory s:
    initial_state p s ->
    domm (s_memory s) = domm (prog_interface p).
  Proof.
    unfold initial_state. intros. subst. unfold initial_machine_state.
    apply cprog_main_existence in complete_program as HisSome.
    destruct (prog_main p) eqn:emain; last discriminate. simpl.
    by apply domm_prepare_buffers.
  Qed.

  Lemma step_preserves_mem_domm s t s' :
    Step sem s t s' ->
    domm (s_memory s) = domm (s_memory s').
  Proof.
    intros Hstep.
    inversion Hstep; subst;
      try reflexivity. (* Most operations do not modify the memory. *)
    - (* Preservation by Memory.alloc. *)
      match goal with
      | Halloc : Memory.alloc _ _ _ = _ |- _ =>
        unfold Memory.alloc in Halloc;
          destruct (mem C) as [memC |] eqn:Hcase;
            [| discriminate];
          destruct (ComponentMemory.alloc memC (Z.to_nat size)) as [memC' b];
          inversion Halloc; subst; simpl;
          rewrite domm_set fsetU1in; [reflexivity |];
          apply /dommP; now eauto
      end.
    - (* Preservation by Memory.store. *)
      rename H into Hstore.
    match goal with
    | Hstore : Memory.store _ ?PTR ?V = _ |- _ =>
      unfold Memory.store in Hstore;
        destruct (Permission.eqb (Pointer.permission PTR) Permission.data) eqn:Hperm;
        [| discriminate];
        destruct (mem (Pointer.component PTR)) as [memC |] eqn:Hcase1;
        [| discriminate];
        destruct (ComponentMemory.store
                    memC (Pointer.block PTR) (Pointer.offset PTR) V)
          as [memC' |] eqn:Hcase2;
        [| discriminate];
        inversion Hstore as [Hsetm];
        simpl; rewrite domm_set fsetU1in;
          [reflexivity |];
          apply /dommP; now eauto
    end.
  Qed.

  Lemma comes_from_initial_state_mem_domm s t s' :
    initial_state p s ->
    Star sem s t s' ->
    domm (s_memory s') = domm (prog_interface p).
  Proof.
    intros Hini Hstar.
    apply star_iff_starR in Hstar.
    revert Hini.
    induction Hstar as [| s1 t1 s2 t2 s3 ? Hstar12 IHHstar Hstep23];
      subst;
      intros Hini.
    - by apply initial_state_domm_s_memory.
    - specialize (IHHstar Hini).
      apply step_preserves_mem_domm in Hstep23. congruence.
  Qed.

  Lemma load_component_prog_interface_addr s t s' ptr v :
    initial_state p s ->
    Star sem s t s' ->
    Memory.load (s_memory s') ptr = Some v ->
    Pointer.component ptr \in domm (prog_interface p).
  Proof.
    intros Hini Hstar.
    apply star_iff_starR in Hstar.
    revert Hini.
    induction Hstar as [| s1 t1 s2 t2 s3 ? Hstar12 IHHstar Hstep23];
      subst;
      intros Hini Hload.
    - apply load_some_in_domm in Hload.
      by erewrite <- initial_state_domm_s_memory; eauto.
    - specialize (IHHstar Hini).
      inversion Hstep23; subst;
        try (simpl in Hload; apply IHHstar; by auto);
        (
          apply load_some_in_domm in Hload; simpl in Hload;
          apply star_iff_starR in Hstar12;
          specialize (comes_from_initial_state_mem_domm Hini Hstar12) as G_; simpl in G_
        ).
      + apply Memory.domm_alloc in H0. by rewrite -G_ H0.
      + apply Memory.domm_store in H. by rewrite -G_ H.
  Qed.

  Definition b_nextblock mem (v: value) : bool :=
    match v with
    | Ptr (Permission.data, C, b, o) =>
      match mem C with
      | Some Cmem => b <? ComponentMemory.next_block Cmem
      | None => false
      end
    | _ => true
    end.

  Lemma values_are_integers_b_nextblock e mem:
    values_are_integers e ->
    runtime_expr_struct_invariant e (b_nextblock mem).
  Proof.
    induction e; simpl; auto.
    - by destruct v; auto.
    - move => /andP [? ?]. rewrite IHe1; by auto.
    - move => /andP [? ?]. rewrite IHe1; by auto.
    - move => /andP [? H]. move : H => /andP => [[? ?]].
      rewrite IHe1; auto. rewrite IHe2; by auto.
    - move => /andP [? ?]. rewrite IHe1; by auto.
    - move => /andP [? ?]. rewrite IHe1; by auto.
  Qed.

(* Print Assumptions comes_from_initial_state_mem_domm. *)

  Lemma b_next_block_eval_binop mem v1 v2 op:
    b_nextblock mem v1 ->
    b_nextblock mem v2 ->
    b_nextblock mem (eval_binop op v1 v2).
  Proof.
    intros Hv1 Hv2.
    destruct op; destruct v1 as [| [[[perm1 c1] b1] o1] |];
      destruct v2 as [| [[[perm2 c2] b2] o2] |]; simpl in *; auto.
    - find_if_inside_goal; by auto.
    - find_if_inside_goal; by auto.
  Qed.

  Lemma load_data_next_block_initial_state s:
    initial_state p s ->
    forall ptr C b o,
      Memory.load (s_memory s) ptr = Some (Ptr (Permission.data, C, b, o)) ->
      exists Cmem,
        (s_memory s) C = Some Cmem /\
        b < ComponentMemory.next_block Cmem.
  Proof.
    intros Hinit ? ? ? ? Hload.
    unfold initial_state in Hinit. subst.
    unfold initial_machine_state in *.
    destruct (prog_main p) eqn:e; simpl in *.
    - unfold prepare_buffers, Memory.load in *.
      find_if_inside_hyp Hload; [|discriminate].
      rewrite mapmE in Hload.
      unfold omap, obind, oapp in *.
      destruct (prog_buffers p (Pointer.component ptr)) as [buf|] eqn:ebuf;
        [|discriminate].
      simpl in *. rewrite ComponentMemory.load_prealloc in Hload.
      find_if_inside_hyp Hload; [|discriminate].
      rewrite setmE in Hload.
      find_if_inside_hyp Hload; [|discriminate].
      destruct buf as [sz|chnk].
      + find_if_inside_hyp Hload; discriminate.
      + assert (exists x, prog_interface p (Pointer.component ptr) = Some x)
          as [? Hifc].
        {
          apply/dommP. specialize (wfprog_defined_buffers valid_program) as Hrewr.
          rewrite Hrewr. apply/dommP. by eauto.
        }
        assert (Hifc_: prog_interface p (Pointer.component ptr)).
        { by rewrite Hifc. }
        specialize (wfprog_well_formed_buffers valid_program Hifc_) as Hwfbuf.
        rewrite ebuf in Hwfbuf.
        simpl in *. destruct Hwfbuf as [_ G_]. move : G_ => /andP => [[_ G_]].
        move : G_ => /allP => G_. apply nth_error_In, In_in, G_ in Hload.
        by simpl in *.
    - unfold Memory.load in *. find_if_inside_hyp Hload; [|discriminate].
      by rewrite emptymE in Hload.
  Qed.

  Lemma b_nextblock_alloc v (mem: Memory.t) C sz ptr mem':
    b_nextblock mem v ->
    Memory.alloc mem C (Z.to_nat sz) = Some (mem', ptr) ->
    b_nextblock mem' v.
  Proof.
    intros Hb Halloc.
    destruct v as [ | [[[[] c] b] o] | ]; auto. simpl in *.
    unfold Memory.alloc in *.
    destruct (mem c) as [memc|] eqn:ememc; [|discriminate].
    destruct (mem C) as [memC|] eqn:ememC; [|discriminate].
    destruct (ComponentMemory.alloc memC (Z.to_nat sz))
      as [memC' b'] eqn:ememC'.
    inversion Halloc; subst. rewrite setmE.
    find_if_inside_goal.
    + move : e => /eqP => ?; subst.
      apply ComponentMemory.next_block_alloc in ememC' as [G1 G2]; subst; rewrite G2.
      apply Nat.ltb_lt. apply/ssrnat.leP. apply ssrnat.ltn_addr.
      apply/ssrnat.leP. apply Nat.ltb_lt.
      rewrite ememc in ememC. inversion ememC; subst. by rewrite Hb.
    + by rewrite ememc.
  Qed.

  Lemma b_nextblock_store (mem: Memory.t) v P C b o v' mem':
    b_nextblock mem v ->
    Memory.store mem (P, C, b, o) v' = Some mem' ->
    b_nextblock mem' v.
  Proof.
    intros Hb Hstore.
    destruct v as [ | [[[[] c] bv] ov] | ]; auto. simpl in *.
    unfold Memory.store in *.
    destruct (mem c) as [memc|] eqn:ememc; [|discriminate].
    find_if_inside_hyp Hstore; [|discriminate]; simpl in *.
    destruct (mem C) as [memC|] eqn:ememC; [|discriminate].
    destruct (ComponentMemory.store memC b o v')
      as [memC'|] eqn:ememC'; [|discriminate].
    inversion Hstore; subst. rewrite setmE.
    find_if_inside_goal.
    + apply ComponentMemory.next_block_store_stable in ememC'. rewrite -ememC'.
      move : e0 => /eqP => ?; subst. rewrite ememc in ememC. inversion ememC. by subst.
    + by rewrite ememc.
  Qed.

  Lemma runtime_expr_struct_invariant_b_nextblock_alloc
        re (mem: Memory.t) C sz ptr mem':
    runtime_expr_struct_invariant re (b_nextblock mem) ->
    Memory.alloc mem C (Z.to_nat sz) = Some (mem', ptr) ->
    runtime_expr_struct_invariant re (b_nextblock mem').
  Proof.
    induction re; auto; intros Hre Halloc; simpl in *;
      try (move : Hre => /andP => [[H1 H2]]; apply/andP; by intuition).
    - by eapply b_nextblock_alloc; eauto.
    - move : Hre => /andP => [[H1 H2]]. apply/andP. intuition.
      move : H1 => /andP => [[? ?]]. apply/andP. by intuition.
  Qed.

  Lemma runtime_expr_struct_invariant_b_nextblock_store
        re (mem: Memory.t) P C b o v' mem':
    runtime_expr_struct_invariant re (b_nextblock mem) ->
    Memory.store mem (P, C, b, o) v' = Some mem' ->
    runtime_expr_struct_invariant re (b_nextblock mem').
  Proof.
    induction re; auto; intros Hre Hstore; simpl in *;
      try (move : Hre => /andP => [[H1 H2]]; apply/andP; by intuition).
    - by eapply b_nextblock_store; eauto.
    - move : Hre => /andP => [[H1 H2]]. apply/andP. intuition.
      move : H1 => /andP => [[? ?]]. apply/andP. by intuition.
  Qed.

  Lemma cont_struct_invariant_b_nextblock_alloc k (mem: Memory.t) C sz ptr mem' :
    cont_struct_invariant k (b_nextblock mem) ->
    Memory.alloc mem C (Z.to_nat sz) = Some (mem', ptr) ->
    cont_struct_invariant k (b_nextblock mem').
  Proof.
    induction k; auto; intros Hmem Halloc; simpl in *;
      move : Hmem => /andP => [[H1 H2]]; apply/andP; intuition;
                                try (by eapply b_nextblock_alloc; eauto);
                                try (by eapply runtime_expr_struct_invariant_b_nextblock_alloc; eauto).
    - apply/andP. move : H1 => /andP => [[? ?]].
      split; by eapply runtime_expr_struct_invariant_b_nextblock_alloc; eauto.
  Qed.

  Lemma cont_struct_invariant_b_nextblock_store k (mem: Memory.t) P C b o v mem':
    cont_struct_invariant k (b_nextblock mem) ->
    Memory.store mem (P, C, b, o) v = Some mem' ->
    cont_struct_invariant k (b_nextblock mem').
  Proof.
    induction k; auto; intros Hmem Hstore; simpl in *;
      move : Hmem => /andP => [[H1 H2]]; apply/andP; intuition;
                                try (by eapply b_nextblock_store; eauto);
                                try (by eapply runtime_expr_struct_invariant_b_nextblock_store; eauto).
    - apply/andP. move : H1 => /andP => [[? ?]].
      split; by eapply runtime_expr_struct_invariant_b_nextblock_store; eauto.
  Qed.

  Lemma stack_wf_wrt_prog_interface_b_nextblock_alloc
        s (mem: Memory.t) C size mem' ptr:
    stack_wf_wrt_prog_interface s (b_nextblock mem) ->
    Memory.alloc mem C (Z.to_nat size) = Some (mem', ptr) ->
    stack_wf_wrt_prog_interface s (b_nextblock mem').
  Proof.
    induction s using last_ind; auto. unfold stack_wf_wrt_prog_interface.
    rewrite !all_rcons. intros Hwf Halloc.
    repeat (let H := fresh "H" in move : Hwf => /andP => [[Hwf H]]).
    specialize (IHs H Halloc).
    apply/andP; split; [|assumption].
    apply/andP; split; [|by eapply cont_struct_invariant_b_nextblock_alloc; eauto].
    apply/andP; split; [assumption|by eapply b_nextblock_alloc; eauto].
  Qed.

  Lemma stack_wf_wrt_prog_interface_b_nextblock_store
        s (mem: Memory.t) P C b o v mem':
    stack_wf_wrt_prog_interface s (b_nextblock mem) ->
    Memory.store mem (P, C, b, o) v = Some mem' ->
    stack_wf_wrt_prog_interface s (b_nextblock mem').
  Proof.
    induction s using last_ind; auto. unfold stack_wf_wrt_prog_interface.
    rewrite !all_rcons. intros Hwf Hstore.
    repeat (let H := fresh "H" in move : Hwf => /andP => [[Hwf H]]).
    specialize (IHs H Hstore).
    apply/andP; split; [|assumption].
    apply/andP; split; [|by eapply cont_struct_invariant_b_nextblock_store; eauto].
    apply/andP; split; [assumption|by eapply b_nextblock_store; eauto].
  Qed.

  Lemma load_data_next_block_inductively_provable s t s' :
    initial_state p s ->
    Star sem s t s' ->
    (
      (
        forall ptr C b o,
          Memory.load (s_memory s') ptr = Some (Ptr (Permission.data, C, b, o)) ->
          exists Cmem,
            (* Memory.next_block (s_memory s') c = some b' /\ *)
            (s_memory s') C = Some Cmem /\
            b < ComponentMemory.next_block Cmem
      )
      /\
      runtime_expr_struct_invariant (s_expr s') (b_nextblock (s_memory s'))
      /\
      cont_struct_invariant (s_cont s') (b_nextblock (s_memory s'))
      /\
      b_nextblock (s_memory s') (s_arg s')
      /\
      (exists cmem,
          (s_memory s') (s_component s') = Some cmem
          /\
          Block.local <? ComponentMemory.next_block cmem
      )
      /\
      stack_wf_wrt_prog_interface (s_stack s') (b_nextblock (s_memory s'))
      /\
      (
        forall C',
          C' \in domm (prog_interface p) ->
          exists cmem : ComponentMemory.t,
            (s_memory s') C' = Some cmem /\
            Block.local <? ComponentMemory.next_block cmem
      )
    ).
  Proof.
    intros Hini Hstar.
    apply star_iff_starR in Hstar.
    revert Hini.
    induction Hstar as [| s1 t1 s2 t2 s3 ? Hstar12 IHHstar Hstep23];
      subst;
      intros Hini.
    - split; [intros ? ? ? ? Hload | split; [| ]].
      + by eapply load_data_next_block_initial_state; eauto.
      + unfold initial_state, initial_machine_state in Hini.
        destruct (prog_main p) eqn:emain; subst; simpl; auto.
        unfold prog_main in emain.
        apply wfprog_well_formed_procedures in emain; auto.
        unfold well_formed_expr in *. destruct emain as [_ [G_ _]].
          by eapply values_are_integers_b_nextblock in G_; eauto.
      + unfold initial_state, initial_machine_state in Hini.
        destruct (prog_main p) eqn:emain; subst; simpl; try by eauto; intuition.
        -- assert (exists cmem, prepare_buffers p Component.main = Some cmem) as [? ?].
           {
             apply/dommP. rewrite domm_prepare_buffers; auto.
             rewrite wfprog_main_existence; auto.
             by rewrite emain.
           }
           assert (G1: Block.local <? ComponentMemory.next_block x).
           {
             unfold prepare_buffers in H. rewrite mapmE in H.
             unfold omap, obind, oapp in *.
             destruct (prog_buffers p Component.main)
               as [buf|] eqn:ebuf; [|discriminate].
             inversion H; subst. by rewrite ComponentMemory.nextblock_prealloc.
           }
           intuition.
           ++ exists x; by intuition.
           ++ assert (exists cmem, prepare_buffers p C' = Some cmem) as [? ?].
              {
                apply/dommP. rewrite domm_prepare_buffers; auto.
              }
              eexists; intuition; eauto.
              unfold prepare_buffers in H1. rewrite mapmE in H1.
              unfold omap, obind, oapp in *.
              destruct (prog_buffers p C')
                as [buf|] eqn:ebuf; [|discriminate].
              inversion H1; subst. by rewrite ComponentMemory.nextblock_prealloc.
        -- intuition; destruct complete_program;
             by rewrite emain in cprog_main_existence0.
    - specialize (IHHstar Hini)
        as [IHload [IHexpr [IHcont [IHarg [[compMem [HcompMem HcompMem2]] [IHstack IHfind]]]]]];
            simpl in *.
      split;
        [
          intros ? ? ? ? Hload; inversion Hstep23; subst;
          try (simpl in Hload; eapply IHload; by eauto)
         |]; simpl in *.
      + destruct ((Pointer.component ptr, Pointer.block ptr) ==
                  (Pointer.component ptr0, Pointer.block ptr0)) eqn:eptr.
        * move : eptr => /eqP => eptr.
          erewrite Memory.load_after_alloc_eq in Hload; eauto.
          repeat (find_if_inside_hyp Hload; [|discriminate]).
          by inversion Hload.
        * erewrite Memory.load_after_alloc in Hload; eauto.
          -- specialize (IHload _ _ _ _ Hload) as [? [? ?]].
             unfold Memory.alloc in *.
             destruct (mem C0) as [memC0|] eqn:eC0; [|discriminate].
             destruct (ComponentMemory.alloc memC0 (Z.to_nat size))
               as [memC' b'] eqn:ememC'.
             inversion H0; subst. rewrite setmE.
             find_if_inside_goal.
             ++ move : e => /eqP => ?; subst. rewrite eC0 in H1. inversion H1; subst.
                simpl in *. apply ComponentMemory.next_block_alloc in ememC' as [G1 G2].
                subst. exists memC'. intuition.
                rewrite G2. apply/ssrnat.ltP.
                apply ssrnat.ltn_addr. by apply/ssrnat.ltP.
             ++ rewrite H1. by eauto.
          -- apply/eqP. by rewrite eptr.
      + destruct (Pointer.eq (P', C', b', o') ptr) eqn:eptr.
        * move : eptr => /Pointer.eqP => eptr; subst.
          specialize (Memory.load_after_store_eq _ _ _ _ H) as H_.
          rewrite Hload in H_. inversion H_; subst. clear H_.
          simpl in *. move : IHcont => /andP => [[G1 G2]].
          unfold Memory.store in H. find_if_inside_hyp H; [simpl in *|discriminate].
          destruct (mem C') as [memC'|] eqn:ememC'; [|discriminate].
          destruct (ComponentMemory.store memC' b' o' (Ptr (Permission.data, C, b, o)))
            as [memC'_after|] eqn:ememC'_after; [|discriminate].
          inversion H; subst. clear H. move : e => /Permission.eqP => e. subst.
          rewrite setmE. find_if_inside_goal.
          -- move : e => /eqP => ?; subst. exists memC'_after; intuition.
             rewrite ememC' in G1.
             apply ComponentMemory.next_block_store_stable in ememC'_after.
             by rewrite -ememC'_after -Nat.ltb_lt.
          -- destruct (mem C) as [memC|] eqn:ememC; [|discriminate].
             exists memC; intuition. by rewrite -Nat.ltb_lt.
        * move : eptr => /Pointer.eqP => eptr.
          erewrite (Memory.load_after_store_neq _ _ _ _ _ eptr) in Hload; eauto.
          specialize (IHload _ _ _ _ Hload) as [memC [ememC G1]].
          unfold Memory.store in H. find_if_inside_hyp H; [simpl in *|discriminate].
          destruct (mem C') as [memC'|] eqn:ememC'; [|discriminate].
          destruct (ComponentMemory.store memC' b' o' v)
            as [memC'_after|] eqn:ememC'_after; [|discriminate].
          inversion H; subst. clear H. move : e => /Permission.eqP => e. subst.
          rewrite setmE. find_if_inside_goal.
          -- move : e => /eqP => ?; subst. exists memC'_after; intuition.
             rewrite ememC' in ememC; inversion ememC; subst.
             apply ComponentMemory.next_block_store_stable in ememC'_after.
             by rewrite -ememC'_after.
          -- by eexists; eauto.
      + split; [inversion Hstep23; subst; simpl in *; auto;
                try (by move : IHexpr => /andP => [[? ?]]);
                try (by move : IHcont => /andP => [[? ?]])
               |].
        * apply b_next_block_eval_binop; auto.
          by move : IHcont => /andP => [[? ?]].
        * move : IHexpr => /andP => [[G_ ?]].
          by move : G_ => /andP => [[? ?]].
        * move : IHcont => /andP => [[G_ ?]].
          move : G_ => /andP => [[? ?]].
          by find_if_inside_goal.
        * by rewrite HcompMem.
        * destruct ptr as [[[[] c] b] o]; auto.
          specialize (Memory.next_block_alloc _ _ _ _ _ H0) as [G1 G2].
          specialize (Memory.component_of_alloc_ptr _ _ _ _ _ H0). simpl; intros; subst.
          simpl in *. unfold Memory.next_block in *.
          rewrite HcompMem in G1.
          destruct (mem' C) as [mem'C|] eqn:emem'C; [|discriminate].
          inversion G1. subst. inversion G2 as [G3]. rewrite G3 ssrnat.addn1.
          by apply Nat.ltb_lt.
        * destruct v as [| [[[[] c] b] o] |]; auto.
          specialize (IHload _ _ _ _ H) as [? [G1 G2]]. simpl. rewrite G1.
          by apply Nat.ltb_lt.
        * destruct v as [| [[[[] c] b] o] |]; auto.
          move : IHcont => /andP => [[G1 _]].
          simpl in *.
          assert (exists Cmem, mem' c = Some Cmem) as [memc ememc].
          { apply/ dommP. erewrite <- Memory.domm_store; eauto. apply/dommP.
            by destruct (mem c) as [memc|] eqn:ememc; [|discriminate]; eauto.
          }
          rewrite ememc.
          specialize (Memory.next_block_store_stable _ _ _ _ c H) as Heq.
          destruct (mem c) as [memc_|] eqn:ememc_; [|discriminate].
          unfold Memory.next_block in *. rewrite ememc ememc_ in Heq.
          inversion Heq as [Hrewr]. by rewrite Hrewr.
        * apply values_are_integers_b_nextblock.
          eapply wfprog_well_formed_procedures in H0; auto.
          unfold well_formed_expr in *. by intuition.
        * apply values_are_integers_b_nextblock.
          eapply wfprog_well_formed_procedures in H1; auto.
          unfold well_formed_expr in *. by intuition.
        * split; [inversion Hstep23; subst; simpl in *; auto;
                try (move : IHexpr => /andP => [[IHe1 IHe2]]);
                try (move : IHcont => /andP => [[IHk1 IHk2]]);
                auto;
                try (
                    match goal with
                    | H1 : is_true (?X), H2: is_true (?Y) |-
                      is_true (andb ?X ?Y) => by rewrite H1 H2
                    end
                  )
               |].
          -- move : IHe1 => /andP => [[IHe1 IHe2_]].
             by rewrite IHe2_ IHe2 IHcont.
          -- by eapply cont_struct_invariant_b_nextblock_alloc; eauto.
          -- by eapply cont_struct_invariant_b_nextblock_store; eauto.
          -- move : IHstack => /andP => [[IHstack _]].
             by move : IHstack => /andP => [[_ ?]].
          -- move : IHstack => /andP => [[IHstack _]].
             by move : IHstack => /andP => [[_ ?]].
          -- split; [inversion Hstep23; subst; simpl in *; auto;
                     try (move : IHexpr => /andP => [[IHe1 IHe2]]);
                     try (move : IHcont => /andP => [[IHk1 IHk2]]);
                     auto;
                     try (
                         match goal with
                         | H1 : is_true (?X), H2: is_true (?Y) |-
                           is_true (andb ?X ?Y) => by rewrite H1 H2
                         end
                       )
                    |].
             ++ by eapply b_nextblock_alloc; eauto.
             ++ by eapply b_nextblock_store; eauto.
             ++ do 2 (move : IHstack => /andP => [[IHstack _]]).
                by move : IHstack => /andP => [[_ ?]].
             ++ do 2 (move : IHstack => /andP => [[IHstack _]]).
                by move : IHstack => /andP => [[_ ?]].
             ++ split; [inversion Hstep23; subst; simpl in *; auto;
                        try (by rewrite HcompMem; eauto)
                       |].
                ** specialize (@b_nextblock_alloc
                                 (Ptr (Permission.data, C, Block.local, 0%Z))
                                 mem C size ptr mem')
                    as G1.
                   assert (b_nextblock
                             mem (Ptr (Permission.data, C, Block.local, 0%Z))) as G2.
                   {
                     simpl. by rewrite HcompMem.
                   }
                   specialize (G1 G2 H0). simpl in G1.
                   destruct (mem' C); [|discriminate].
                   by eauto.
                ** specialize (@b_nextblock_store

                                 mem
                                 (Ptr (Permission.data, C, Block.local, 0%Z))
                                 P' C' b' o' v mem') as G1.
                   assert (b_nextblock
                             mem (Ptr (Permission.data, C, Block.local, 0%Z))) as G2.
                   {
                     simpl. by rewrite HcompMem.
                   }
                   specialize (G1 G2 H). simpl in G1.
                   destruct (mem' C); [|discriminate].
                   by eauto.
                ** eapply IHfind; eauto. by eapply find_procedure_prog_interface; eauto.
                ** repeat (move : IHstack => /andP => [[IHstack _]]).
                   by eapply IHfind; eauto.
                ** split; [inversion Hstep23; subst; simpl in *; auto |].
                   --- by eapply stack_wf_wrt_prog_interface_b_nextblock_alloc; eauto.
                   --- by eapply stack_wf_wrt_prog_interface_b_nextblock_store; eauto.
                   --- repeat (apply/andP; split; [|assumption]).
                       by eapply find_procedure_prog_interface; eauto.
                   --- repeat (apply/andP; split; [|assumption]).
                       assert (Hrewr: mem =
                                      s_memory [State C, s, mem,
                                                Kcall C' P k,
                                                E_val v, old_call_arg]) by auto.
                       erewrite <- comes_from_initial_state_mem_domm.
                       +++ apply/dommP. exists compMem. by erewrite <- Hrewr.
                       +++ eassumption.
                       +++ apply star_iff_starR. eassumption.
                   --- by (move : IHstack => /andP => [[_ ?]]).
                   --- by (move : IHstack => /andP => [[_ ?]]).
                   --- inversion Hstep23; subst; simpl in *; auto.
                       +++ intros ? Hdomm.
                           specialize (IHfind _ Hdomm) as [? [Ga Gb]].
                           specialize (@b_nextblock_alloc
                                         (Ptr (Permission.data, C', Block.local, 0%Z))
                                         mem C size ptr mem')
                             as G1.
                           assert (b_nextblock
                                     mem
                                     (Ptr (Permission.data, C', Block.local, 0%Z)))
                             as G2.
                           {
                             simpl. by rewrite Ga.
                           }
                           specialize (G1 G2 H0). simpl in G1.
                           destruct (mem' C'); [|discriminate].
                           by eauto.
                       +++ intros C'0 Hdomm.
                           specialize (IHfind _ Hdomm) as [? [Ga Gb]].
                           specialize (@b_nextblock_store
                                         mem
                                         (Ptr (Permission.data, C'0, Block.local, 0%Z))
                                         P' C' b' o' v mem') as G1.
                           assert (b_nextblock
                                     mem (Ptr (Permission.data, C'0, Block.local, 0%Z)))
                             as G2.
                           {
                             simpl. by rewrite Ga.
                           }
                           specialize (G1 G2 H). simpl in G1.
                           destruct (mem' C'0); [|discriminate].
                           by eauto.
  Qed.

  Lemma load_data_next_block:
      forall s t s' ptr C b o,
        initial_state p s ->
        Star sem s t s' ->
        Memory.load (CS.s_memory s') ptr = Some (Ptr (Permission.data, C, b, o)) ->
        exists Cmem : ComponentMemory.t,
          CS.s_memory s' C = Some Cmem /\ b < ComponentMemory.next_block Cmem.
  Proof.
    intros.
    specialize (load_data_next_block_inductively_provable H H0) as [G1 _].
    eapply G1; eauto.
  Qed.

  (* NOTE: Consider a CSInvariants for the Source *)
  Definition private_pointers_never_leak_S metadata_size :=
    forall (s : state) (t : Events.trace Events.event),
      Star sem (initial_machine_state p) t s ->
      good_trace_extensional (left_addr_good_for_shifting metadata_size) t /\
      (forall (mem : eqtype.Equality.sort Memory.Memory.t),
          s_memory s = mem ->
          shared_locations_have_only_shared_values mem metadata_size
      ).
End Semantics.

End CS.

Notation "[ 'CState' C , stk , mem , k , e , arg ]" :=
  (CS.State C stk mem k e arg)
  (at level 0, format "[ 'CState'  C ,  stk ,  mem ,  k ,  e ,  arg ]").


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.