(*

  Copyright 2014 Cornell University

  This file is part of CFGV project.

  CFGV is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  CFGV is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with CFGV.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/CFGVLFMTP2014/
  Authors: Abhishek Anand & Vincent Rahli

*)
Require Export AlphaDecider.
Set Implicit Arguments.

(** printing #  $\times$ #×# *)
(** printing &  $\times$ #×# *)

Notation inrr := (fun x => inr (inr x)).
Notation inlr := (fun x => inl (inr x)).
Notation inll := (fun x => inl (inl x)).

(** CatchFileBetweenTagsLetRecStart *)

Inductive PNonTerminal : Set :=  lasgn | asgn | asgnRhs.
Inductive VarSym : Set := vsym.
Inductive TNonTerminal : Set := term.
Inductive Terminal :Set := .
Definition vSubstType (_ : VarSym) : TNonTerminal := term.

Inductive PatProd : Set := aNil | aCons | asgnP.
Inductive TermProd : Set := app | lam | letr.
Inductive EmbedProd : Set := asgnRhsE.
Definition epLhsRhs  (_: EmbedProd):
   (PNonTerminal * TNonTerminal) := (asgnRhs, term).

Definition ppLhsRhs (p:PatProd) :
 (PNonTerminal * list (PNonTerminal+ (Terminal + VarSym))):=
match p with
 | aNil => (lasgn,[])
 | aCons => (lasgn, [inl lasgn, inl asgn])
 | asgnP  => (asgn, [inrr vsym, inl asgnRhs])
end.
Definition tpLhsRhs (p:TermProd) :
 (TNonTerminal * list ((PNonTerminal + VarSym)
                         + (Terminal + TNonTerminal))):=
match p with
 | app => (term,[inrr term, inrr term])
 | lam => (term, [inlr vsym, inrr term])
 | letr  => (term, [inll lasgn, inrr term])
end.

Definition bindingInfo (p:TermProd) : list (nat * nat) :=
match p with
 | app => []  | lam => [(0,1)]  | letr  => [(0,0),(0,1)]
end.
(** CatchFileBetweenTagsLetRecEnd *)

Definition letrecCFGV : CFGV.
eapply Build_CFGV
      with   (VarSym := VarSym)
             (Terminal := Terminal)
             (PNonTerminal := PNonTerminal)
             (TNonTerminal := TNonTerminal)
             (PatProd := PatProd)
             (TermProd := TermProd)
             (tpLhsRhs := tpLhsRhs)
             (bindingInfo := bindingInfo)
             (EmbedProd := EmbedProd).
  - intro. exact nvarVarType.
  - exact vSubstType.
  - exact ppLhsRhs.
  - exact epLhsRhs.
  - proveBindingInfoCorrect.
  - proveDeqInductiveNonrec.
  - intro H. contradiction.
  - proveDeqInductiveNonrec.
  - proveDeqInductiveNonrec.
  - proveDeqInductiveNonrec.
  - proveDeqInductiveNonrec.
  - proveDeqInductiveNonrec.
  - proveDeqInductiveNonrec.
Grab Existential Variables.
intro t. inverts t.
Defined.

Require Export Term.

(* to catch stupid errors early, it makes sense
  first replace Notation by Definition and revert
  back to Notation if the Definition typechecks *)

Notation SYMTN := (@gsymTN letrecCFGV).
Notation SYMPN := (@gsymPN letrecCFGV).
Definition TERM := (Term (SYMTN  term)).
Definition PAT p := (Pattern  (SYMPN p)).
Notation VAR := (@vType letrecCFGV (vsym)).

Definition mkAsgn : VAR -> TERM -> PAT asgn.
  intros v t.
  apply (@pnode letrecCFGV asgnP).
  apply mpcons.
  * apply pvleaf. simpl. exact v.
  * apply (mpcons);[| apply mnil].
    apply (@embed letrecCFGV asgnRhsE). simpl.
    exact t.
Defined.

Definition mkLAsgn : list (PAT asgn) -> PAT lasgn.
  intro l. induction l as [| h tl].
  - apply (@pnode letrecCFGV aNil). simpl. apply mnil.
  - apply (@pnode letrecCFGV aCons); simpl.
    apply (mpcons).
    + exact IHtl.
    + apply (mpcons); [| apply mnil].
      exact h.
Defined.

Definition mkLetr : list (PAT asgn) -> TERM -> TERM.
  intros lp t.
  apply (@tnode letrecCFGV letr). unfold tpRhsAugIsPat. simpl.
  apply mpcons.
  - apply mkLAsgn. exact lp.
  - apply (mtcons);[| apply mnil]. exact t.
Defined.

Definition mkVTerm : VAR -> TERM.
  intro v.
  apply (@vleaf letrecCFGV vsym).
  exact v.
Defined.

(** a representation of the term
    letrec x:=y in z
*)

Definition letr_xyz : TERM :=
  mkLetr [mkAsgn nvarx (mkVTerm nvary)]  (mkVTerm nvarz).

(*
Lemma letrxx_alpha_trivial :
 @tAlphaEq letrecCFGV vsym _ letrxxx letrxxx.
Proof.
  remember (@tAlphaEqDecidable letrecCFGV vsym _ letrxxx letrxxx).
  unfold tAlphaEqDecidable, alphaEqDecidable, GInductionS, tcase,
  comp_ind_type in Heqd.
  simpl in Heqd.
*)
(*
*** Local Variables:
*** coq-load-path: ("../")
*** End:
*)


Require Import Verdi.TraceRelations.

Require Import VerdiRaft.Raft.
Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.TraceUtil.

Require Import VerdiRaft.CausalOrderPreservedInterface.
Require Import VerdiRaft.OutputImpliesAppliedInterface.
Require Import VerdiRaft.AppliedImpliesInputInterface.
Require Import VerdiRaft.AppliedEntriesMonotonicInterface.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Section CausalOrderPreserved.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {oiai : output_implies_applied_interface}.
  Context {aiii : applied_implies_input_interface}.
  Context {aemi : applied_entries_monotonic_interface}.

  Section inner.
  Variable client : clientId.
  Variable id : nat.
  Variable client' : clientId.
  Variable id' : nat.

  Lemma output_before_input_not_key_in_input_trace :
    forall tr tr' s s',
      ~ output_before_input client id client' id' tr ->
      step_failure s s' tr' ->
      output_before_input client id client' id' (tr ++ tr') ->
      ~ exists i, in_input_trace client' id' i (tr ++ tr').
  Proof using.
    intros. find_eapply_lem_hyp before_func_app_necessary; eauto.
    intuition.
    break_exists. unfold in_input_trace in *.
    break_exists. do_in_app. intuition;
      [find_apply_hyp_hyp; simpl in *; break_if; repeat (do_bool; intuition)|].
    invcs H0; intuition.
    - break_if; congruence.
    - find_inversion; try congruence.
      repeat (do_bool; intuition).
      break_if; try congruence.
    - find_inversion.
  Qed.

  Lemma output_before_input_key_in_output_trace :
    forall tr,
      output_before_input client id client' id' tr ->
      key_in_output_trace client id tr.
  Proof using.
    intros. unfold output_before_input in *.
    induction tr; simpl in *; intuition.
    - unfold key_in_output_trace.
      unfold is_output_with_key in *. repeat break_match; try congruence.
      subst. do 2 eexists. intuition; eauto.
    - unfold key_in_output_trace in *.
      break_exists_exists. simpl; intuition.
  Qed.

  Lemma in_applied_entries_entries_ordered :
    forall net,
      in_applied_entries client id net ->
      ~ in_applied_entries client' id' net ->
      entries_ordered client id client' id' net.
  Proof using.
    intros. unfold in_applied_entries, entries_ordered in *.
    induction (applied_entries (nwState net)); simpl in *; break_exists; intuition.
    - subst. left. unfold has_key. break_match.
      simpl. break_if; repeat (do_bool; intuition).
    - right. intuition.
      + apply Bool.not_true_iff_false. intuition.
        find_false.
        unfold has_key in *. break_match; simpl in *; break_if; repeat (do_bool; intuition); try congruence.
        subst. eexists; intuition; eauto.
      + eapply IHl.
        * eexists; intuition; eauto.
        * intuition. find_false. break_exists_exists. intuition.
  Qed.

  Lemma in_applied_entries_applied_implies_input_state :
    forall net,
      in_applied_entries client' id' net ->
      exists e,
        eClient e = client' /\
        eId e = id' /\
        applied_implies_input_state client' id' (eInput e) net.
  Proof using.
    intros.
    unfold in_applied_entries in *. break_exists_exists.
    intuition. red. exists x. intuition.
    - red. auto.
    - unfold applied_entries in *. break_match.
      + find_apply_lem_hyp in_rev.
        find_apply_lem_hyp removeAfterIndex_in.
        eauto.
      + simpl in *. intuition.
  Qed.

  Program Instance TR : TraceRelation step_failure :=
    {
      init := step_failure_init;
      T := output_before_input client id client' id';
      R := fun s => entries_ordered client id client' id' (snd s)
    }.
  Next Obligation.
    unfold output_before_input.
    eapply before_func_dec.
  Defined.
  Next Obligation.
    simpl in *.
    unfold entries_ordered in *.
    find_apply_lem_hyp step_failure_star_raft_intermediate_reachable.
    find_eapply_lem_hyp applied_entries_monotonic'; eauto.
    break_exists; repeat find_rewrite.
    eauto using before_func_app.
  Defined.
  Next Obligation.
    simpl in *.
    find_copy_eapply_lem_hyp output_before_input_not_key_in_input_trace; eauto.
    find_copy_apply_lem_hyp output_before_input_key_in_output_trace.
    find_eapply_lem_hyp output_implies_applied;
      [|eapply refl_trans_n1_1n_trace; econstructor; eauto using refl_trans_1n_n1_trace].
    eapply in_applied_entries_entries_ordered; auto.
    intuition.
    find_false.
    find_apply_lem_hyp in_applied_entries_applied_implies_input_state.
    break_exists. intuition.
    eexists. eapply applied_implies_input; eauto.
    eapply refl_trans_n1_1n_trace; econstructor; eauto using refl_trans_1n_n1_trace.
  Defined.

  Theorem causal_order_preserved :
    forall failed net tr,
      step_failure_star step_failure_init (failed, net) tr ->
      output_before_input client id client' id' tr ->
      entries_ordered client id client' id' net.
  Proof using aemi aiii oiai.
    intros. pose proof (trace_relations_work (failed, net) tr).
    concludes. intuition.
  Qed.

  End inner.

  Instance copi : causal_order_preserved_interface.
  Proof.
    split.
    intros.
    eapply causal_order_preserved; eauto.
  Qed.
End CausalOrderPreserved.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D P Q C0 Q0 C1 A0 Y : Universe, ((wd_ P C0 /\ (wd_ P Q /\ (wd_ P Q0 /\ (wd_ C0 Q0 /\ (wd_ A B /\ (wd_ B Q0 /\ (wd_ A Q0 /\ (wd_ C0 A /\ (wd_ C0 B /\ (wd_ Q C0 /\ (wd_ B Q /\ (wd_ A Q /\ (wd_ C D /\ (wd_ D P /\ (wd_ C P /\ (wd_ C A /\ (wd_ C B /\ (wd_ D A /\ (wd_ D B /\ (wd_ C1 C0 /\ (wd_ C0 A0 /\ (wd_ P A0 /\ (wd_ Y P /\ (col_ A B P /\ (col_ C0 C D /\ (col_ Q P Q0 /\ (col_ C D C1 /\ (col_ A B A0 /\ (col_ C0 C1 Y /\ col_ P Q0 Y))))))))))))))))))))))))))))) -> col_ P Q Y)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import RelationClasses.
Require Import Bool.
Require Import List.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.

Require Import Event.
From PromisingLib Require Import DenseOrder.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import Cover.

Set Implicit Arguments.

Inductive sim_message: forall (msg_src msg_tgt: Message.t), Prop :=
| sim_message_full
    val released_src released_tgt
    (RELEASED: View.opt_le released_src released_tgt):
    sim_message (Message.full val released_src) (Message.full val released_tgt)
| sim_message_reserve:
    sim_message Message.reserve Message.reserve
.
#[export]
Hint Constructors sim_message: core.

#[export]
Program Instance sim_message_PreOrder: PreOrder sim_message.
Next Obligation.
  ii. destruct x; econs; refl.
Qed.
Next Obligation.
  ii. inv H; inv H0; econs. etrans; eauto.
Qed.

Inductive message_same_kind: forall (msg_src msg_tgt: Message.t), Prop :=
| message_same_kind_full
    val_src val_tgt released_src released_tgt:
    message_same_kind (Message.full val_src released_src) (Message.full val_tgt released_tgt)
| same_message_kine_reserve:
    message_same_kind Message.reserve Message.reserve
.
#[export]
Hint Constructors sim_message: core.

#[export]
Program Instance message_same_kind_Equivalence: Equivalence message_same_kind.
Next Obligation.
  ii. destruct x; econs.
Qed.
Next Obligation.
  ii. inv H; econs.
Qed.
Next Obligation.
  ii. inv H; inv H0; econs.
Qed.

Lemma sim_message_message_same_kind
      msg_src msg_tgt
      (SIM: sim_message msg_src msg_tgt):
  message_same_kind msg_src msg_tgt.
Proof.
  inv SIM; econs.
Qed.

Inductive sim_memory (mem_src mem_tgt:Memory.t): Prop :=
| sim_memory_intro
    (COVER: forall loc ts, covered loc ts mem_src <-> covered loc ts mem_tgt)
    (MSG: forall loc from_tgt to msg_tgt
            (GET: Memory.get loc to mem_tgt = Some (from_tgt, msg_tgt)),
        exists from_src msg_src,
          <<GET: Memory.get loc to mem_src = Some (from_src, msg_src)>> /\
          <<MSG: sim_message msg_src msg_tgt>>)
    (RESERVE: forall loc from to,
        Memory.get loc to mem_src = Some (from, Message.reserve) <->
        Memory.get loc to mem_tgt = Some (from, Message.reserve))
.

#[export]
Program Instance sim_memory_PreOrder: PreOrder sim_memory.
Next Obligation.
  econs; try refl. i. esplits; eauto. refl.
Qed.
Next Obligation.
  ii. inv H. inv H0. econs; try etrans; eauto. i.
  exploit MSG0; eauto. i. des.
  exploit MSG; eauto. i. des.
  esplits; eauto. etrans; eauto.
Qed.

Lemma sim_memory_get
      loc from_tgt to msg_tgt mem_src mem_tgt
      (SIM: sim_memory mem_src mem_tgt)
      (GET: Memory.get loc to mem_tgt = Some (from_tgt, msg_tgt)):
  exists from_src msg_src,
    <<GET: Memory.get loc to mem_src = Some (from_src, msg_src)>> /\
    <<MSG: sim_message msg_src msg_tgt>>.
Proof.
  eapply SIM. eauto.
Qed.

Lemma sim_memory_get_message_same_kind
      loc
      from_src to_src msg_src mem_src
      from_tgt to_tgt msg_tgt mem_tgt
      ts
      (SIM: sim_memory mem_src mem_tgt)
      (GET_SRC: Memory.get loc to_src mem_src = Some (from_src, msg_src))
      (GET_TGT: Memory.get loc to_tgt mem_tgt = Some (from_tgt, msg_tgt))
      (ITV_SRC: Interval.mem (from_src, to_src) ts)
      (ITV_TGT: Interval.mem (from_tgt, to_tgt) ts):
  message_same_kind msg_src msg_tgt.
Proof.
  destruct msg_src, msg_tgt; try by econs.
  - inv SIM. rewrite <- RESERVE in GET_TGT.
    exploit Memory.get_disjoint; [exact GET_SRC|exact GET_TGT|..]. i. des; try congr.
    exfalso. apply (x0 ts); auto.
  - inv SIM. rewrite RESERVE in GET_SRC.
    exploit Memory.get_disjoint; [exact GET_SRC|exact GET_TGT|..]. i. des; try congr.
    exfalso. apply (x0 ts); auto.
Qed.

Lemma sim_memory_get_inv
      loc from_src to_src msg_src mem_src
      mem_tgt
      (INHABITED_SRC: Memory.inhabited mem_src)
      (INHABITED_TGT: Memory.inhabited mem_tgt)
      (SIM: sim_memory mem_src mem_tgt)
      (GET_SRC: Memory.get loc to_src mem_src = Some (from_src, msg_src)):
  exists from_tgt to_tgt msg_tgt,
    <<FROM: Time.le from_tgt from_src>> /\
    <<TO: Time.le to_src to_tgt>> /\
    <<GET_TGT: Memory.get loc to_tgt mem_tgt = Some (from_tgt, msg_tgt)>> /\
    <<MSG: message_same_kind msg_src msg_tgt>>.
Proof.
  destruct (Time.eq_dec to_src Time.bot).
  { subst. rewrite INHABITED_SRC in GET_SRC. inv GET_SRC.
    esplits; try refl. apply INHABITED_TGT. }
  dup SIM. inv SIM0. dup COVER. specialize (COVER0 loc to_src). des.
  exploit COVER0.
  { econs; eauto. econs; try refl.
    exploit Memory.get_ts; eauto. i. des; subst; timetac. }
  intro x. dup x. inv x0. esplits; eauto.
  - destruct (Time.le_lt_dec from from_src); ss.
    dup COVER. specialize (COVER2 loc from). des. exploit COVER2.
    { econs; eauto.
      exploit Memory.get_ts; try exact GET_SRC. i. des; ss.
      inv ITV. econs; eauto. econs. ss. }
    intro x0. inv x0.
    destruct (Time.eq_dec to0 from).
    + subst. exploit MSG; try exact GET0. i. des.
      exploit Memory.get_disjoint; [exact GET_SRC|exact GET1|..]. i. des.
      * subst. inv ITV. timetac.
      * exfalso. apply (x1 from).
        { inv ITV. econs; eauto. s. econs; eauto. }
        { econs; try refl. s.
          exploit Memory.get_ts; try exact GET1. i. des; ss.
          subst. inv ITV0. inv FROM. }
    + exploit Memory.get_disjoint; [exact GET|exact GET0|..]. i. des.
      * subst. inv ITV0. timetac.
      * exfalso. destruct (Time.le_lt_dec to to0).
        { apply (x1 to).
          - econs; try refl.
            exploit Memory.get_ts; try exact GET. i. des; ss.
            subst. inv ITV0. inv FROM.
          - econs; eauto. inv ITV0. ss.
            exploit Memory.get_ts; try exact GET. i. des; ss.
            + subst. inv l.
            + eapply TimeFacts.lt_le_lt; eauto. econs; eauto. }
        { apply (x1 to0).
          - inv ITV0. econs; ss.
            + inv TO; ss. inv H. congr.
            + econs. ss.
          - econs; try refl.
            exploit Memory.get_ts; try exact GET0. i. des; ss.
            subst. inv ITV0. ss. inv TO; inv H. inv FROM. }
  - inv ITV. ss.
  - eapply sim_memory_get_message_same_kind; eauto.
    exploit Memory.get_ts; try exact GET_SRC. i. des; try congr.
    econs; eauto. refl.
Qed.

Lemma sim_memory_max_ts
      mem_src mem_tgt loc
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt):
  Memory.max_ts loc mem_src = Memory.max_ts loc mem_tgt.
Proof.
  inv SIM. inv CLOSED_SRC. inv CLOSED_TGT.
  clear MSG RESERVE CLOSED CLOSED0.
  apply TimeFacts.antisym.
  - specialize (COVER loc (Memory.max_ts loc mem_src)). des.
    exploit Memory.max_ts_spec; try eapply (INHABITED loc). i. des.
    exploit Memory.get_ts; eauto. i. des.
    { rewrite x1. apply Time.bot_spec. }
    exploit COVER.
    { econs; eauto. econs; eauto. refl. }
    intro x. inv x. exploit Memory.max_ts_spec; try exact GET0. i. des.
    inv ITV. ss. etrans; eauto.
  - specialize (COVER loc (Memory.max_ts loc mem_tgt)). des.
    exploit Memory.max_ts_spec; try eapply (INHABITED0 loc). i. des.
    exploit Memory.get_ts; eauto. i. des.
    { rewrite x1. apply Time.bot_spec. }
    exploit COVER0.
    { econs; eauto. econs; eauto. refl. }
    intro x. inv x. exploit Memory.max_ts_spec; try exact GET0. i. des.
    inv ITV. ss. etrans; eauto.
Qed.

Lemma sim_memory_max_full_ts
      mem_src mem_tgt
      loc mts_src mts_tgt
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (MAX_SRC: Memory.max_full_ts mem_src loc mts_src)
      (MAX_TGT: Memory.max_full_ts mem_tgt loc mts_tgt):
  mts_src = mts_tgt.
Proof.
  apply TimeFacts.antisym.
  - inv MAX_SRC. des.
    exploit sim_memory_get_inv; eauto.
    { apply CLOSED_SRC. }
    { apply CLOSED_TGT. }
    i. des. inv MSG.
    exploit Memory.max_full_ts_spec; eauto. i. des.
    etrans; eauto.
  - inv MAX_TGT. des.
    inv SIM. exploit MSG; eauto. i. des. inv MSG0.
    exploit Memory.max_full_ts_spec; eauto. i. des. ss.
Qed.

Lemma sim_memory_max_full_timemap
      mem_src mem_tgt mtm_src mtm_tgt
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (SIM: sim_memory mem_src mem_tgt)
      (MAX_SRC: Memory.max_full_timemap mem_src mtm_src)
      (MAX_TGT: Memory.max_full_timemap mem_tgt mtm_tgt):
  mtm_src = mtm_tgt.
Proof.
  extensionality loc.
  specialize (MAX_SRC loc).
  specialize (MAX_TGT loc).
  eapply sim_memory_max_full_ts; eauto.
Qed.

Lemma sim_memory_max_full_view
      mem_src mem_tgt mview_src mview_tgt
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (SIM: sim_memory mem_src mem_tgt)
      (MAX_SRC: Memory.max_full_view mem_src mview_src)
      (MAX_TGT: Memory.max_full_view mem_tgt mview_tgt):
  mview_src = mview_tgt.
Proof.
  inv MAX_SRC. inv MAX_TGT.
  exploit sim_memory_max_full_timemap; try exact SIM; eauto. i.
  subst. ss.
Qed.

Lemma split_sim_memory
      mem0 loc ts1 ts2 ts3 val2 released2 val3 released3 mem1
      (SPLIT: Memory.split mem0 loc ts1 ts2 ts3 (Message.full val2 released2) (Message.full val3 released3) mem1):
  sim_memory mem1 mem0.
Proof.
  econs; i.
  - eapply split_covered. eauto.
  - exploit Memory.split_get0; eauto. i. des.
    erewrite Memory.split_o; eauto. repeat condtac; ss.
    + des. subst. congr.
    + guardH o. des. subst. rewrite GET1 in GET. inv GET.
      esplits; eauto. refl.
    + esplits; eauto. refl.
  - exploit Memory.split_get0; eauto. i. des.
    erewrite Memory.split_o; eauto.
    repeat condtac; ss; split; i; try congr.
    + des. subst. rewrite GET in H. inv H.
    + guardH o. des. subst. rewrite GET0 in H. inv H.
Qed.

Lemma lower_sim_memory
      mem1 loc from to msg1 msg2 mem2
      (LOWER: Memory.lower mem1 loc from to msg1 msg2 mem2)
      (MSG: message_same_kind msg1 msg2):
  sim_memory mem2 mem1.
Proof.
  econs; i.
  - eapply lower_covered. eauto.
  - i. erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst.
      exploit Memory.lower_get0; eauto. i. des.
      rewrite GET0 in GET. inv GET.
      inv MSG_LE; inv MSG; esplits; eauto.
    + esplits; eauto. refl.
  - split; i.
    + revert H. erewrite Memory.lower_o; eauto. condtac; ss.
      i. des. subst. inv H. inv LOWER. inv LOWER0. inv MSG.
      unfold Memory.get, Cell.get. rewrite GET2. ss.
    + erewrite Memory.lower_o; eauto. condtac; ss.
      des. subst. inv LOWER. inv LOWER0.
      unfold Memory.get, Cell.get in H. rewrite H in GET2. inv GET2.
      inv MSG. ss.
Qed.

Lemma promise_lower_sim_memory
      promises1 mem1 loc from to msg1 msg2 promises2 mem2
      (PROMISE: Memory.promise promises1 mem1 loc from to msg2 promises2 mem2 (Memory.op_kind_lower msg1))
      (MSG: message_same_kind msg1 msg2):
  sim_memory mem2 mem1.
Proof.
  inv PROMISE. eapply lower_sim_memory; eauto.
Qed.

Lemma sim_memory_add
      mem1_src mem1_tgt msg_src
      mem2_src mem2_tgt msg_tgt
      loc from to
      (SIM_MSG: sim_message msg_src msg_tgt)
      (SRC: Memory.add mem1_src loc from to msg_src mem2_src)
      (TGT: Memory.add mem1_tgt loc from to msg_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv SIM. econs; i.
  - rewrite add_covered; [|eauto]. rewrite (@add_covered mem2_tgt); [|eauto].
    econs; i; des; (try by right).
    + left. eapply COVER. eauto.
    + left. eapply COVER. eauto.
  - revert GET. erewrite Memory.add_o; eauto. condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.add_o; eauto. condtac; ss.
    + erewrite (@Memory.add_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.add_o in H; try exact SRC.
      erewrite Memory.add_o; try exact TGT. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.add_o in H; try exact TGT.
      erewrite Memory.add_o; try exact SRC. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_split
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc ts1 ts2 ts3 msg2_src msg3_src msg2_tgt msg3_tgt
      (SIM_MSG: sim_message msg2_src msg2_tgt)
      (SRC: Memory.split mem1_src loc ts1 ts2 ts3 msg2_src msg3_src mem2_src)
      (TGT: Memory.split mem1_tgt loc ts1 ts2 ts3 msg2_tgt msg3_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv SIM. econs; i.
  - rewrite split_covered; [|eauto]. rewrite (@split_covered mem2_tgt); [|eauto].
    apply COVER.
  - revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.split_o; eauto. condtac; ss.
    + erewrite (@Memory.split_o mem2_src); eauto. repeat condtac; ss.
      i. inv GET. guardH o. guardH o0. des. subst.
      exploit Memory.split_get0; try exact SRC; eauto. i. des.
      exploit Memory.split_get0; try exact TGT; eauto. i. des.
      exploit MSG; eauto. i. des. rewrite GET0 in GET7. inv GET7.
      esplits; eauto.
    + erewrite (@Memory.split_o mem2_src); eauto. repeat condtac; ss. eauto.
  - split; i.
    + erewrite Memory.split_o in H; try exact SRC.
      erewrite Memory.split_o; try exact TGT. repeat condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * guardH o. des. subst. inv H.
        exploit Memory.split_get0; try exact SRC. i. des.
        exploit Memory.split_get0; try exact TGT. i. des.
        rewrite RESERVE in GET0. rewrite GET0 in GET4. inv GET4. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.split_o in H; try exact TGT.
      erewrite Memory.split_o; try exact SRC. repeat condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * guardH o. des. subst. inv H.
        exploit Memory.split_get0; try exact SRC. i. des.
        exploit Memory.split_get0; try exact TGT. i. des.
        rewrite <- RESERVE in GET4. rewrite GET0 in GET4. inv GET4. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_lower
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc from to msg1_src msg2_src msg1_tgt msg2_tgt
      (SIM_MSG: sim_message msg2_src msg2_tgt)
      (SRC: Memory.lower mem1_src loc from to msg1_src msg2_src mem2_src)
      (TGT: Memory.lower mem1_tgt loc from to msg1_tgt msg2_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  dup SIM. inv SIM0. econs; i.
  - rewrite lower_covered; [|eauto]. rewrite (@lower_covered mem2_tgt); [|eauto].
    apply COVER.
  - revert GET. erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.lower_o; eauto. condtac; ss.
    + erewrite (@Memory.lower_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.lower_o in H; try exact SRC.
      erewrite Memory.lower_o; try exact TGT. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.lower_o in H; try exact TGT.
      erewrite Memory.lower_o; try exact SRC. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_remove
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc from to msg_src msg_tgt
      (SRC: Memory.remove mem1_src loc from to msg_src mem2_src)
      (TGT: Memory.remove mem1_tgt loc from to msg_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  dup SIM. inv SIM0. econs; i.
  - rewrite remove_covered; [|eauto]. rewrite (@remove_covered mem2_tgt); [|eauto].
    rewrite COVER. refl.
  - revert GET. erewrite Memory.remove_o; eauto. condtac; ss.
    erewrite (@Memory.remove_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.remove_o in H; try exact SRC.
      erewrite Memory.remove_o; try exact TGT. condtac; ss.
      rewrite <- RESERVE. ss.
    + erewrite Memory.remove_o in H; try exact TGT.
      erewrite Memory.remove_o; try exact SRC. condtac; ss.
      rewrite RESERVE. ss.
Qed.

Lemma sim_memory_closed_timemap
      mem_src mem_tgt
      tm
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_timemap tm mem_tgt):
  Memory.closed_timemap tm mem_src.
Proof.
  ii. exploit TGT; eauto. i. des.
  exploit sim_memory_get; eauto. i. des.
  inv MSG. eauto.
Qed.

Lemma sim_memory_closed_view
      mem_src mem_tgt
      view
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_view view mem_tgt):
  Memory.closed_view view mem_src.
Proof.
  econs.
  - eapply sim_memory_closed_timemap; eauto. apply TGT.
  - eapply sim_memory_closed_timemap; eauto. apply TGT.
Qed.

Lemma sim_memory_closed_opt_view
      mem_src mem_tgt
      view
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_opt_view view mem_tgt):
  Memory.closed_opt_view view mem_src.
Proof.
  inv TGT; econs. eapply sim_memory_closed_view; eauto.
Qed.

Lemma sim_memory_closed_message
      mem_src mem_tgt
      msg
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_message msg mem_tgt):
  Memory.closed_message msg mem_src.
Proof.
  inv TGT; ss. econs. eapply sim_memory_closed_opt_view; eauto.
Qed.

Lemma sim_memory_latest_val_src
      mem_src mem_tgt loc val
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (LATEST: Memory.latest_val loc mem_src val):
  Memory.latest_val loc mem_tgt val.
Proof.
  inv LATEST.
  exploit Memory.max_full_ts_exists; try apply CLOSED_TGT. i. des.
  exploit sim_memory_max_full_ts; eauto. i. subst.
  dup x0. inv x1. des.
  inv SIM. exploit MSG; eauto. i. des. inv MSG0.
  rewrite GET1 in GET. inv GET.
  econs; eauto.
Qed.

Lemma sim_memory_latest_val_tgt
      mem_src mem_tgt loc val
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (LATEST: Memory.latest_val loc mem_tgt val):
  Memory.latest_val loc mem_src val.
Proof.
  inv LATEST.
  exploit Memory.max_full_ts_exists; try apply CLOSED_SRC. i. des.
  exploit sim_memory_max_full_ts; eauto. i. subst.
  dup x0. inv x1. des.
  inv SIM. exploit MSG; eauto. i. des. inv MSG0.
  unfold Memory.get in *. rewrite GET0 in GET1. inv GET1.
  econs; eauto.
Qed.

Lemma sim_memory_adjacent_src
      mem_src mem_tgt
      loc from1 to1 from2 to2
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (ADJ: Memory.adjacent loc from1 to1 from2 to2 mem_src)
      (TS: Time.lt to1 from2):
  exists from1' to2',
    Memory.adjacent loc from1' to1 from2 to2' mem_tgt.
Proof.
  dup SIM. inv SIM0. inv ADJ. clear RESERVE TS0.
  assert (GET1_TGT: exists from1' m1', Memory.get loc to1 mem_tgt = Some (from1', m1')).
  { exploit Memory.get_ts; try exact GET1. i. des.
    { subst. esplits. eapply CLOSED_TGT. }
    destruct (COVER loc to1). exploit H.
    { econs; try exact GET1. econs; eauto. refl. }
    intro x. inv x. inv ITV. ss. inv TO; cycle 1.
    { inv H1. esplits; eauto. }
    exfalso.
    destruct (Time.le_lt_dec to from2).
    { exploit MSG; eauto. i. des.
      exploit (EMPTY to); eauto. i. congr. }
    destruct (COVER loc from2). exploit H3.
    { econs; eauto. econs; eauto. econs. ss. }
    intro x. inv x. inv ITV. ss. inv TO.
    - exploit Memory.get_ts; try exact GET2. i. des.
      { subst. inv FROM0. }
      exploit Memory.get_ts; try exact GET0. i. des.
      { subst. inv H4. }
      exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
      { timetac. }
      destruct (Time.le_lt_dec to2 to0).
      + apply (x3 to2); econs; ss; try refl.
        etrans; try exact FROM0. ss.
      + apply (x3 to0); econs; ss; try refl.
        econs. ss.
    - inv H4. exploit (EMPTY to0); eauto; try refl. i. congr.
  }
  assert (GET2_TGT: exists to2' m2', Memory.get loc to2' mem_tgt = Some (from2, m2')).
  { exploit Memory.get_ts; try exact GET2. i. des.
    { subst. inv TS. }
    exploit Memory.max_ts_spec; try exact GET2. i. des.
    clear from msg GET.
    erewrite sim_memory_max_ts in MAX; eauto.
    exploit TimeFacts.lt_le_lt; try exact x0; try exact MAX. i.
    exploit Memory.next_exists; try exact x1; try eapply CLOSED_TGT. i. des.
    destruct (TimeFacts.le_lt_dec from from2).
    - inv l; cycle 1.
      { inv H. esplits; eauto. }
      destruct (COVER loc from2). exploit H1.
      { econs; try exact x2. econs; ss. econs; ss. }
      intro x. inv x. inv ITV. ss. inv TO; cycle 1.
      { inv H2. exploit (EMPTY to0); eauto; try refl. i. congr. }
      exploit Memory.get_disjoint; [exact GET2|exact GET|..]. i. des.
      { subst. timetac. }
      exfalso.
      destruct (TimeFacts.le_lt_dec to2 to0).
      + apply (x5 to2); econs; ss; try refl.
        etrans; try exact FROM. ss.
      + apply (x5 to0); econs; ss; try refl.
        * econs. ss.
        * etrans; eauto.
    - destruct (TimeFacts.le_lt_dec to2 from).
      + destruct (COVER loc to2). exploit H.
        { econs; eauto. econs; ss. refl. }
        intro x. inv x. inv ITV. ss.
        exploit (x4 to0); eauto; try congr.
        { eapply TimeFacts.lt_le_lt; try exact TO; ss. }
        destruct (Time.le_lt_dec to to0); ss.
        exploit Memory.get_ts; try exact x2. i. des.
        { subst. inv x3. }
        exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
        { subst. timetac. }
        exfalso.
        apply (x6 to); econs; ss; try refl.
        etrans; try exact FROM.
        eapply TimeFacts.le_lt_lt; try exact x5. ss.
      + destruct (COVER loc from). exploit H.
        { econs; try exact GET2. econs; ss. econs. ss. }
        intro x. inv x. inv ITV. ss.
        destruct (TimeFacts.le_lt_dec to to0).
        * exploit Memory.get_ts; try exact x2. i. des.
          { subst. inv x3. }
          exploit Memory.get_ts; try exact GET. i. des.
          { subst. timetac. }
          exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
          { subst. timetac. }
          exfalso.
          apply (x7 to); econs; ss; try refl.
          eapply TimeFacts.lt_le_lt; try exact FROM. econs. ss.
        * exploit (x4 to0); ss; try congr.
          eapply TimeFacts.lt_le_lt; try exact TO; ss.
  }
  des. esplits. econs; eauto; i.
  { exploit Memory.get_ts; try exact GET2_TGT. i. des.
    - subst. inv TS.
    - etrans; eauto. }
  destruct (Memory.get loc ts mem_tgt) as [[]|] eqn:GET; ss.
  exfalso.
  exploit Memory.get_ts; try exact GET. i. des.
  { subst. inv TS1. }
  destruct (COVER loc ts). exploit H0.
  { econs; eauto. econs; ss. refl. }
  intro x. inv x. inv ITV. ss.
  destruct (TimeFacts.le_lt_dec to from2).
  { exploit (EMPTY to); try congr.
    eapply TimeFacts.lt_le_lt; try exact TS1. ss. }
  exploit Memory.get_ts; try exact GET2. i. des.
  { subst. inv TS. }
  exploit Memory.get_ts; try exact GET0. i. des.
  { subst. inv l. }
  exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
  { subst. timetac. }
  destruct (TimeFacts.le_lt_dec to2 to).
  - apply (x3 to2); econs; ss; try refl.
    etrans; try exact x1.
    eapply TimeFacts.lt_le_lt; try exact TS2. ss.
  - apply (x3 to); econs; ss; try refl. econs. ss.
Qed.

Lemma sim_memory_adjacent_tgt
      mem_src mem_tgt
      loc from1 to1 from2 to2
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (ADJ: Memory.adjacent loc from1 to1 from2 to2 mem_tgt)
      (TS: Time.lt to1 from2):
  exists from1' to2',
    Memory.adjacent loc from1' to1 from2 to2' mem_src.
Proof.
  dup SIM. inv SIM0. inv ADJ. clear RESERVE TS0.
  assert (GET1_SRC: exists from1' m1', Memory.get loc to1 mem_src = Some (from1', m1')).
  { exploit MSG; try exact GET1. i. des. eauto. }
  assert (GET2_SRC: exists to2' m2', Memory.get loc to2' mem_src = Some (from2, m2')).
  { exploit Memory.get_ts; try exact GET2. i. des.
    { subst. inv TS. }
    exploit Memory.max_ts_spec; try exact GET2. i. des.
    clear from msg GET.
    erewrite <- sim_memory_max_ts in MAX; eauto.
    exploit TimeFacts.lt_le_lt; try exact x0; try exact MAX. i.
    exploit Memory.next_exists; try exact x1; try eapply CLOSED_SRC. i. des.
    destruct (TimeFacts.le_lt_dec from from2).
    - inv l; cycle 1.
      { inv H. esplits; eauto. }
      destruct (COVER loc from2). exploit H0.
      { econs; try exact x2. econs; ss. econs; ss. }
      intro x. inv x. inv ITV. ss. inv TO; cycle 1.
      { inv H2. exploit (EMPTY to0); eauto; try refl. i. congr. }
      exploit Memory.get_disjoint; [exact GET2|exact GET|..]. i. des.
      { subst. timetac. }
      exfalso.
      destruct (TimeFacts.le_lt_dec to2 to0).
      + apply (x5 to2); econs; ss; try refl.
        etrans; try exact FROM. ss.
      + apply (x5 to0); econs; ss; try refl.
        * econs. ss.
        * etrans; eauto.
    - destruct (TimeFacts.le_lt_dec to2 from).
      + destruct (COVER loc to2). exploit H0.
        { econs; eauto. econs; ss. refl. }
        intro x. inv x. inv ITV. ss.
        exploit (x4 to0); eauto; try congr.
        { eapply TimeFacts.lt_le_lt; try exact TO; ss. }
        destruct (Time.le_lt_dec to to0); ss.
        exploit Memory.get_ts; try exact x2. i. des.
        { subst. inv x3. }
        exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
        { subst. timetac. }
        exfalso.
        apply (x6 to); econs; ss; try refl.
        etrans; try exact FROM.
        eapply TimeFacts.le_lt_lt; try exact x5. ss.
      + destruct (COVER loc from). exploit H0.
        { econs; try exact GET2. econs; ss. econs. ss. }
        intro x. inv x. inv ITV. ss.
        destruct (TimeFacts.le_lt_dec to to0).
        * exploit Memory.get_ts; try exact x2. i. des.
          { subst. inv x3. }
          exploit Memory.get_ts; try exact GET. i. des.
          { subst. timetac. }
          exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
          { subst. timetac. }
          exfalso.
          apply (x7 to); econs; ss; try refl.
          eapply TimeFacts.lt_le_lt; try exact FROM. econs. ss.
        * exploit (x4 to0); ss; try congr.
          eapply TimeFacts.lt_le_lt; try exact TO; ss.
  }
  des. esplits. econs; eauto; i.
  { exploit Memory.get_ts; try exact GET2_SRC. i. des.
    - subst. inv TS.
    - etrans; eauto. }
  destruct (Memory.get loc ts mem_src) as [[]|] eqn:GET; ss.
  exfalso.
  exploit Memory.get_ts; try exact GET. i. des.
  { subst. inv TS1. }
  destruct (COVER loc ts). exploit H.
  { econs; eauto. econs; ss. refl. }
  intro x. inv x. inv ITV. ss.
  destruct (TimeFacts.le_lt_dec to from2).
  { exploit (EMPTY to); try congr.
    eapply TimeFacts.lt_le_lt; try exact TS1. ss. }
  exploit Memory.get_ts; try exact GET2. i. des.
  { subst. inv TS. }
  exploit Memory.get_ts; try exact GET0. i. des.
  { subst. inv l. }
  exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
  { subst. timetac. }
  destruct (TimeFacts.le_lt_dec to2 to).
  - apply (x3 to2); econs; ss; try refl.
    etrans; try exact x1.
    eapply TimeFacts.lt_le_lt; try exact TS2. ss.
  - apply (x3 to); econs; ss; try refl. econs. ss.
Qed.


(*  DEC 2.0 language specification.
   Paolo Torrini
   Universite' de Lille - CRIStAL-CNRS
*)

Require Import List.
Require Import Equality.
Require Import Eqdep.
Require Import PeanoNat.
Require Import Omega.
Require Import ProofIrrelevance.

Require Import AuxLibI1.
Require Import TypSpecI1.
Require Import ModTypI1.
Require Import LangSpecI1.
Require Import StaticSemI1.
Require Import DynamicSemI1.
Require Import WeakenI1.
Require Import UniqueTypI1.
Require Import DerivDynI1.
Require Import TransPrelimI1.
Require Import TSoundnessI1.
Require Import SReducI1.
Require Import DetermI1.

Import ListNotations.

Module PreRefl (IdT: ModTyp) <: ModTyp.

Module DetermL := Determ IdT.
Export DetermL.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Open Scope type_scope.

(* extends the shallow environment *)
Lemma ext_senv (tenv : valTC)
      (X : tlist2type (map sVTyp (map snd tenv))) (x: Id) (t: VTyp)
      (sv : sVTyp t) :
       valTC_Trans ((x, t) :: tenv).
   unfold valTC_Trans.
   simpl.
   constructor.
   exact sv.
   exact X.
Defined.

(* extract values of x from senv *)
Lemma ExpDenotI_Var
  (ftenv : funTC)
  (tenv : valTC)
  (x : Id)
  (t : VTyp)
  (i :  IdTyping tenv x t) :
  (* sfenv *) tlist2type (map snd (FunTC_ListTrans ftenv)) ->
  (* senv *) valTC_Trans tenv -> MM WW (sVTyp t).
  intros.
  assert (sVTyp t).
  eapply (extract_from_valTC_TransB tenv X0 x).
  auto.
  unfold MM.
  intro X2.
  exact (X1,X2).
Defined.

(* extract values of x from senv;
   replaces ExpDenotI_Var *)
Lemma ExpDenI_Var
  (tenv : valTC)
  (x : Id)
  (t : VTyp)
  (i :  IdTyping tenv x t) :
               (* senv: *) valTC_Trans tenv ->
               MM WW (sVTyp t).
  intros.
  assert (sVTyp t).
  eapply (extract_from_valTC_TransB tenv X x).
  auto.
  unfold MM.
  intro X1.
  exact (X0,X1).
Defined.

Lemma ExpDenI2_Var
  (tenv : valTC)
  (x : Id)
  (t : VTyp)
  (i :  IdTyping tenv x t) (n: nat) :
               valTC_Trans tenv ->
               W -> (sVTyp t * W) * (sigT (fun n0 => n0 <= n)).
  intros.
  assert (sVTyp t).
  eapply (extract_from_valTC_TransB tenv X x).
  auto.
  split.
  exact (X1,X0).
  econstructor 1 with (x:=n).
  auto.
Defined.

Lemma ExpTransAux1_Var
    (x : Id)
    (v : Value)
    (t : VTyp) (mB: valueVTyp v = t)
    (n0 : nat) (s0 : W) :
              (sVTyp t * W) * (sigT (fun n => n <= n0)).
  unfold valueVTyp in mB.
  destruct v.
  rewrite <- mB.
  simpl.
  destruct v.
  split.
  exact (v, s0).
  econstructor 1 with (x:= n0).
  auto.
Defined.

Lemma ExpTransAux2_Var
      (tenv: valTC) (env: valEnv)
      (m: EnvTyping env tenv)
      (x : Id)
      (t : VTyp)
      (i : IdTyping tenv x t)
      (n0 : nat) (s0 : W) :
              (sVTyp t * W) * (sigT (fun n => n <= n0)).
  eapply (ExpTransAux1_Var x
                           (ExtRelVal2A_1 valueVTyp tenv env x t m i)
                           t
                           (ExtRelVal2A_4 valueVTyp tenv env x t m i)
                           n0 s0).
Defined.

(*******************************************************************)

Definition ExpTrans1_def :=
   fun (ftenv: funTC) (tenv: valTC) (e: Exp) (t: VTyp)
       (k: ExpTyping ftenv tenv e t) =>
     forall (sfenv: nat -> tlist2type (map snd (FunTC_ListTrans ftenv))),
      (valTC_Trans tenv -> MM WW (sVTyp t)).

Definition PrmsTrans1_def :=
   fun (ftenv: funTC) (tenv: valTC) (ps: Prms) (pt: PTyp)
       (k: PrmsTyping ftenv tenv ps pt) =>
     forall (sfenv: nat -> tlist2type (map snd (FunTC_ListTrans ftenv))),
      (valTC_Trans tenv -> MM WW (PTyp_Trans pt)).

Definition Trans_ExpTyping_mut1 :=
  ExpTyping_mut ExpTrans1_def PrmsTrans1_def.

Definition Trans_PrmsTyping_mut1 :=
  PrmsTyping_mut ExpTrans1_def PrmsTrans1_def.

Lemma ExpDenotK_Var :
  forall (ftenv : funTC) (tenv : valTC) (x : StaticSemL.Id)
    (t : VTyp) (i : IdTyping tenv x t),
  ExpTrans1_def ftenv tenv (Var x) t (Var_Typing ftenv tenv x t i).
     unfold ExpTrans1_def.
     intros.
     eapply ExpDenI_Var.
     exact i.
     exact X.
Defined.

Program Fixpoint ExpTrans (ftenv: funTC) (tenv: valTC) (e: Exp) (t: VTyp)
       (k: ExpTyping ftenv tenv e t) :
  forall (sfenv: nat -> tlist2type (map snd (FunTC_ListTrans ftenv))),
      (valTC_Trans tenv -> MM WW (sVTyp t)) := _
with PrmsTrans (ftenv: funTC) (tenv: valTC) (ps: Prms) (pt: PTyp)
       (k: PrmsTyping ftenv tenv ps pt) :
  forall (sfenv: nat -> tlist2type (map snd (FunTC_ListTrans ftenv))),
      (valTC_Trans tenv -> MM WW (PTyp_Trans pt)) := _.
Next Obligation.
   eapply Trans_ExpTyping_mut1.
   - unfold ExpTrans1_def.
     intros.
     inversion v0; subst.
     exact (ret (sValue v)).
   - (* apply ExpTransVar. *)
     unfold ExpTrans1_def.
     intros.
     eapply ExpDenI_Var.
     exact i.
     exact X.
   - unfold ExpTrans1_def.
     intros.
     exact (bind (X sfenv X1) (fun _ => X0 sfenv X1)).
   - unfold ExpTrans1_def.
     intros.
     specialize (X sfenv X1).
     specialize (X0 sfenv).
     inversion e; subst.
     unfold valTC_Trans in X1.
     unfold VTList_Trans in X1.
     unfold MM.
     unfold MM in X.
     intro w0.
     specialize (X w0).
     destruct X as [sv1 w1].
     specialize (X0 (ext_senv tenv X1 x t1 sv1)).
     unfold MM in X0.
     specialize (X0 w1).
     exact X0.
   - unfold ExpTrans1_def.
     intros.
     specialize (X sfenv).
     inversion e1; subst.
     clear H.
     eapply extend_valTC_Trans with (env0:=env0) (tenv0:=tenv0) in X0.
     eapply X.
     exact X0.
     exact e0.
   - unfold ExpTrans1_def.
     intros.
     specialize (X sfenv X2).
     specialize (X0 sfenv X2).
     specialize (X1 sfenv X2).
     intro w0.
     specialize (X w0).
     destruct X as [b w1].
     inversion b; subst.
     specialize (X0 w1).
     exact X0.
     specialize (X1 w1).
     exact X1.
   - unfold ExpTrans1_def, PrmsTrans1_def.
     intros.
     specialize (X0 sfenv X1).
     unfold MM.
     unfold MM in X0.
     intro w0.
     specialize (X0 w0).
     destruct X0 as [nn w1].
     destruct w1 as [s1 n1].
     set (w2 := (s1, min nn n1)).
     specialize (X sfenv X1).
     assert (FTyp_Trans2 (FT pt t)).
     eapply extract_from_funTC_Trans with
         (sftenv:=(FunTC_ListTrans ftenv)) (ftenv:=ftenv) (x:=x).
     exact (sfenv (snd w2)).
     inversion i; subst.
     reflexivity.
     reflexivity.
     unfold FTyp_Trans2 in X0.
     unfold FType_mk2 in X0.
     simpl in X0.
     destruct pt.
     unfold PTyp_Trans in X.
     unfold VTList_Trans in X.
     unfold PTyp_ListTrans in X0.
     exact (bind X X0 w2).
   - unfold ExpTrans1_def, PrmsTrans1_def.
     intros.
     unfold MM.
     intro w0.
     specialize (X sfenv X0).
     assert (FTyp_Trans2 (FT pt t)).
     eapply extract_from_funTC_Trans with
         (sftenv:=(FunTC_ListTrans ftenv)) (ftenv:=ftenv) (x:=x).
     exact (sfenv (snd w0)).
     inversion i; subst.
     reflexivity.
     reflexivity.
     unfold FTyp_Trans2 in X1.
     unfold FType_mk2 in X1.
     simpl in X1.
     destruct pt.
     unfold PTyp_Trans in X.
     unfold VTList_Trans in X.
     unfold PTyp_ListTrans in X1.
     exact (bind X X1 w0).
   - unfold ExpTrans1_def.
     intros.
     specialize (X sfenv X0).
     unfold MM in *.
     intro w0.
     specialize (X w0).
     destruct X as [v0 w1].
     destruct w1 as [s1 n1].
     destruct XF.
     set (x_mod0 v0 s1) as p.
     subst inpT0.
     subst outT0.
     exact (fst p, (snd p, n1)).
   - unfold PrmsTrans1_def.
     intros.
     intro.
     split.
     constructor.
     exact X0.
   - unfold ExpTrans1_def, PrmsTrans1_def.
     intros.
     specialize (X sfenv X1).
     specialize (X0 sfenv X1).
     intro w0.
     specialize (X w0).
     destruct X as [v1 w1].
     specialize (X0 w1).
     destruct X0 as [vs w2].
     split.
     unfold PTyp_Trans in *.
     constructor.
     exact v1.
     exact vs.
     exact w2.
Defined.

Next Obligation.
   eapply Trans_PrmsTyping_mut1.
   - unfold ExpTrans1_def.
     intros.
     inversion v0; subst.
     exact (ret (sValue v)).
   - (* apply ExpTransVar. *)
     unfold ExpTrans1_def.
     intros.
     eapply ExpDenI_Var.
     exact i.
     exact X.
   - unfold ExpTrans1_def.
     intros.
     exact (bind (X sfenv X1) (fun _ => X0 sfenv X1)).
   - unfold ExpTrans1_def.
     intros.
     specialize (X sfenv X1).
     specialize (X0 sfenv).
     inversion e; subst.
     unfold valTC_Trans in X1.
     unfold VTList_Trans in X1.
     unfold MM.
     unfold MM in X.
     intro w0.
     specialize (X w0).
     destruct X as [sv1 w1].
     specialize (X0 (ext_senv tenv X1 x t1 sv1)).
     unfold MM in X0.
     specialize (X0 w1).
     exact X0.
   - unfold ExpTrans1_def.
     intros.
     specialize (X sfenv).
     inversion e1; subst.
     clear H.
     eapply extend_valTC_Trans with (env0:=env0) (tenv0:=tenv0) in X0.
     eapply X.
     exact X0.
     exact e0.
   - unfold ExpTrans1_def.
     intros.
     specialize (X sfenv X2).
     specialize (X0 sfenv X2).
     specialize (X1 sfenv X2).
     intro w0.
     specialize (X w0).
     destruct X as [b w1].
     inversion b; subst.
     specialize (X0 w1).
     exact X0.
     specialize (X1 w1).
     exact X1.
   - unfold ExpTrans1_def, PrmsTrans1_def.
     intros.
     specialize (X0 sfenv X1).
     unfold MM.
     unfold MM in X0.
     intro w0.
     specialize (X0 w0).
     destruct X0 as [nn w1].
     destruct w1 as [s1 n1].
     set (w2 := (s1, min nn n1)).
     specialize (X sfenv X1).
     assert (FTyp_Trans2 (FT pt t)).
     eapply extract_from_funTC_Trans with
         (sftenv:=(FunTC_ListTrans ftenv)) (ftenv:=ftenv) (x:=x).
     exact (sfenv (snd w2)).
     inversion i; subst.
     reflexivity.
     reflexivity.
     unfold FTyp_Trans2 in X0.
     unfold FType_mk2 in X0.
     simpl in X0.
     destruct pt.
     unfold PTyp_Trans in X.
     unfold VTList_Trans in X.
     unfold PTyp_ListTrans in X0.
     exact (bind X X0 w2).
   - unfold ExpTrans1_def, PrmsTrans1_def.
     intros.
     unfold MM.
     intro w0.
     specialize (X sfenv X0).
     assert (FTyp_Trans2 (FT pt t)).
     eapply extract_from_funTC_Trans with
         (sftenv:=(FunTC_ListTrans ftenv)) (ftenv:=ftenv) (x:=x).
     exact (sfenv (snd w0)).
     inversion i; subst.
     reflexivity.
     reflexivity.
     unfold FTyp_Trans2 in X1.
     unfold FType_mk2 in X1.
     simpl in X1.
     destruct pt.
     unfold PTyp_Trans in X.
     unfold VTList_Trans in X.
     unfold PTyp_ListTrans in X1.
     exact (bind X X1 w0).
   - unfold ExpTrans1_def.
     intros.
     specialize (X sfenv X0).
     unfold MM in *.
     intro w0.
     specialize (X w0).
     destruct X as [v0 w1].
     destruct w1 as [s1 n1].
     destruct XF.
     set (x_mod0 v0 s1) as p.
     subst inpT0.
     subst outT0.
     exact (fst p, (snd p, n1)).
   - unfold PrmsTrans1_def.
     intros.
     intro.
     split.
     constructor.
     exact X0.
   - unfold ExpTrans1_def, PrmsTrans1_def.
     intros.
     specialize (X sfenv X1).
     specialize (X0 sfenv X1).
     intro w0.
     specialize (X w0).
     destruct X as [v1 w1].
     specialize (X0 w1).
     destruct X0 as [vs w2].
     split.
     unfold PTyp_Trans in *.
     constructor.
     exact v1.
     exact vs.
     exact w2.
Defined.

(**********************************************************************)

(* translation of d-function base case *)
Program Definition preZero0 (f: Fun) :
   (* FunWT1 ftenv f ->*) FunTyp_TRN f := _.

Next Obligation.
  intros.
  destruct f.
  unfold FunTyp_TRN.
  unfold FTyp_TRN2.
  unfold FType_mk2.
  simpl.
  intros.
  exact (ret (sValue v)).
Defined.

Definition preZero (f: Fun) : FunTyp_TRN f :=
match f as f0 return (FunTyp_TRN f0) with
 | FC tenv v e =>
     fun _ : tlist2type (map sVTyp (map snd tenv)) => ret (sValue v)
end.

(* translation of fenv base case *)
Program Definition ZeroTRN1 (fenv: funEnv) :
  tlist2type (map snd (FunEnv_ListTrans fenv)) := _.
Next Obligation.
  intro fenv.
  induction fenv.
  intros.
  simpl.
  exact tt.
  intros.
  destruct a.
  simpl in *.
  split.
  eapply preZero.
  exact IHfenv.
Defined.

Lemma FunEnv_Trans_lemma (fenv: funEnv) :
  FunEnv_ListTrans fenv = FunTC_ListTrans (funEnv2funTC fenv).
 unfold FunEnv_ListTrans.
 unfold FunTC_ListTrans.
 induction fenv.
 simpl.
 auto.
 simpl in *.
 rewrite IHfenv.
 auto.
Defined.

(* translation of fenv base case *)
Program Definition ZeroTRN2 (fenv: funEnv) :
  tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) := _.
Next Obligation.
  intro fenv.
  induction fenv.
  intros.
  simpl.
  exact tt.
  intros.
  destruct a.
  simpl in *.
  split.
  eapply preZero.
  exact IHfenv.
Defined.

Program Definition ZeroTRN3 (fenv: funEnv) :
  tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) := _.
Next Obligation.
  intros.
  rewrite <- FunEnv_Trans_lemma.
  eapply ZeroTRN1.
Defined.

(*
NOTE: proved AFTER the translation lemma (ExpTrans).
In contrast, the extract_from_... lemmas are proven beforehand.
ZeroTRN1 used for the base case; then proved
tlist2type (map snd (FunEnv_ListTrans fenv)) =
  tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv)))
 *)
Program Definition preSucc (fenv: funEnv)
        (k: FEnvWT fenv) (x: Id) (f: Fun) :
  findE fenv x = Some f ->
  forall (sfenv: nat -> tlist2type
                   (map snd (FunTC_ListTrans (funEnv2funTC fenv)))),
  FunTyp_TRN f := _.
Next Obligation.
  intros.
  set (tenv := funValTC f).
  set (e := funSExp f).
  set (t := funVTyp f).
  set (ftenv := funEnv2funTC fenv).
  assert (ExpTyping ftenv tenv e t) as k1.
  unfold FEnvWT in k.
  set (sftenv := FunTC_ListTrans ftenv).
  assert (FEnvTyping fenv ftenv).
  constructor.
  specialize (k ftenv H0 x f H).
  unfold FunWT in k.
  destruct f.
  subst e.
  subst t.
  subst tenv.
  simpl in *.
  exact k.
  specialize (ExpTrans ftenv tenv e t k1 sfenv).
  intro.
  unfold FunTyp_TRN.
  unfold FTyp_TRN2.
  unfold FType_mk2.
  unfold valTC_Trans in X.
  unfold VTList_Trans in X.
  destruct f.
  subst tenv e t.
  simpl in *.
  unfold VTyp_Trans.
  unfold TList_Type in X.
  exact X.
Defined.

Program Definition preSucc1 (fenv: funEnv)
        (k: FEnvWT fenv) :
  forall (sfenv: nat -> tlist2type
                   (map snd (FunTC_ListTrans (funEnv2funTC fenv))))
         (x: Id) (f: Fun),
  findE fenv x = Some f ->
  FunTyp_TRN f := _.
Next Obligation.
  intros.
  eapply (preSucc fenv k x f H sfenv).
Defined.

(*
If each function definition in fenv can be translated, then
each subset of fenv can be translated.
Here X stands for the call to preSucc.
Essential the use of noDup (used by in_find_lemma)
*)
Program Definition SuccTRN_step (fenv: funEnv) :
  noDup fenv ->
  (forall (x: Id) (f: Fun),
       findE fenv x = Some f ->
       FunTyp_TRN f) ->
  forall (fenv1: funEnv),
    (forall a, In a fenv1 -> In a fenv) ->
     tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv1))) := _.
Next Obligation.
  intros fenv D X fenv1.
  induction fenv1.
  intros.
  simpl in *.
  exact tt.
  intro H.
  destruct a as [x f].
  intros.
  assert (forall a : LangSpecL.Id * Fun, In a fenv1 -> In a fenv).
  {- intros.
     specialize (H a).
     simpl in H.
     assert ((x, f) = a \/ In a fenv1).
     right; exact H0.
     eapply H in H1.
     exact H1.
  }
  specialize (IHfenv1 H0).
  simpl in *.
  clear H0.
  split.
  specialize (H (x,f)).
  assert (In (x, f) fenv).
  eapply H.
  left.
  auto.
  apply in_find_lemma in H0.
  eapply X.
  exact H0.
  exact D.
  eapply IHfenv1.
Defined.

Program Definition preSucc2 (fenv: funEnv)
        (k: FEnvWT fenv) :
  noDup fenv ->
  forall (sfenv:
            tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))))
         (fenv1: funEnv),
    (forall a, In a fenv1 -> In a fenv) ->
     tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv1))) := _.
Next Obligation.
  intros.
  eapply (SuccTRN_step fenv H).
  eapply (preSucc1 fenv k).
  intro.
  exact sfenv.
  exact H0.
Defined.

Program Definition SuccTRN (fenv: funEnv)
        (k: FEnvWT fenv) :
  noDup fenv ->
  forall (sfenv:
            tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv)))),
     tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) := _.
Next Obligation.
  intros.
  eapply (preSucc2 fenv k H).
  exact sfenv.
  intros.
  exact H0.
Defined.

Fixpoint FunEnvTRN (fenv: funEnv)
        (k1: FEnvWT fenv) (k2: noDup fenv) (n: nat) :
  tlist2type (map snd (FunTC_ListTrans (funEnv2funTC fenv))) := match n with
          | 0 => ZeroTRN3 fenv
          | S m => SuccTRN fenv k1 k2
                           (FunEnvTRN fenv k1 k2 m)
          end.

Definition ExpTrans2 (ftenv: funTC) (tenv: valTC)
        (e: Exp) (t: VTyp)
        (k: ExpTyping ftenv tenv e t) :
  forall (sfenv: nat -> tlist2type (map snd (FunTC_ListTrans ftenv))),
    (valTC_Trans tenv) -> MM WW (sVTyp t) := fun sfenv =>
  ExpTrans ftenv tenv e t k sfenv.

Definition PrmsTrans2 (ftenv: funTC) (tenv: valTC)
        (ps: Prms) (pt: PTyp)
        (k: PrmsTyping ftenv tenv ps pt) :
  forall (sfenv: nat -> tlist2type (map snd (FunTC_ListTrans ftenv))),
    (valTC_Trans tenv) -> MM WW (PTyp_Trans pt) := fun sfenv =>
  PrmsTrans ftenv tenv ps pt k sfenv.

Definition ExpEvalTRN (fenv: funEnv)
           (k1: FEnvWT fenv) (k2: noDup fenv)
           (env: valEnv) (e: Exp) (t: VTyp)
  (k: ExpTyping (funEnv2funTC fenv) (valEnv2valTC env) e t) :
  MM WW (sVTyp t) := fun w =>
  let senv := ValEnvTRN env in
  let sfenv := FunEnvTRN fenv k1 k2 in
  ExpTrans2 (funEnv2funTC fenv) (valEnv2valTC env) e t k sfenv senv w.

Definition PrmsEvalTRN (fenv: funEnv)
           (k1: FEnvWT fenv) (k2: noDup fenv)
           (env: valEnv) (ps: Prms) (pt: PTyp)
  (k: PrmsTyping (funEnv2funTC fenv) (valEnv2valTC env) ps pt) :
  MM WW (PTyp_Trans pt) := fun w =>
  let senv := ValEnvTRN env in
  let sfenv := FunEnvTRN fenv k1 k2 in
  PrmsTrans2 (funEnv2funTC fenv) (valEnv2valTC env) ps pt k sfenv senv w.

(**************************************************************************)
(**************************************************************************)

(* IMPORTANT *)

Lemma ExtRelVal2A_ok (env: valEnv)
    (x: Id) (t: VTyp) (v: Value)
    (k1: findE (valEnv2valTC env) x = Some t)
    (k2: findE env x = Some v) :
  v = proj1_of_sigT2 (ExtRelVal2A valueVTyp (valEnv2valTC env) env x t
                                  eq_refl k1).
  induction env.
  inversion k1.
  destruct a.
  simpl in k1, k2.
  simpl.
  unfold ExtRelVal2A.
  unfold proj1_of_sigT2.
  unfold sigT_of_sigT2.
  simpl.
  destruct (IdT.IdEqDec x i).
  inversion k2; subst.
  reflexivity.
  specialize (IHenv k1 k2).
  rewrite IHenv.
  reflexivity.
Defined.

Lemma ExtRelVal2A2_ok (env: valEnv) (tenv: valTC)
    (m: EnvTyping env tenv)
    (x: Id) (t: VTyp) (v: Value)
    (k1: findE tenv x = Some t)
    (k2: findE env x = Some v) :
  v = proj1_of_sigT2 (ExtRelVal2A valueVTyp tenv env x t
                                  m k1).
  unfold EnvTyping in m.
  unfold MatchEnvs in m.
  inversion m; subst.
  induction env.
  inversion k2.
  destruct a.
  simpl in k1, k2.
  simpl.
  unfold ExtRelVal2A.
  unfold proj1_of_sigT2.
  unfold sigT_of_sigT2.
  simpl.
  destruct (IdT.IdEqDec x i).
  inversion k2; subst.
  reflexivity.
  specialize (IHenv k1 k2).
  rewrite IHenv.
  reflexivity.
  reflexivity.
Defined.

Lemma ExtRelVal2A_Typ_ok (env: valEnv)
    (x: Id) (t: VTyp) (v: Value)
    (k1: findE (valEnv2valTC env) x = Some t)
    (k2: findE env x = Some v) :
    sVTyp (projT1
       (proj1_of_sigT2
          (ExtRelVal2A valueVTyp (valEnv2valTC env) env x t eq_refl k1))) =
    (sVTyp (projT1 v)).
  rewrite (ExtRelVal2A_ok env x t v k1 k2).
  reflexivity.
Defined.

Lemma ExtRelVal2A_TypSym_ok (env: valEnv)
    (x: Id) (t: VTyp) (v: Value)
    (k1: findE (valEnv2valTC env) x = Some t)
    (k2: findE env x = Some v) :
  (sVTyp (projT1 v)) =
      sVTyp (projT1
       (proj1_of_sigT2
          (ExtRelVal2A valueVTyp (valEnv2valTC env) env x t eq_refl k1))).
  symmetry.
  eapply (ExtRelVal2A_Typ_ok env x t v k1 k2).
Defined.

Lemma ExtRelVal2A2_Typ_ok (env: valEnv) (tenv: valTC)
    (m: EnvTyping env tenv)
    (x: Id) (t: VTyp) (v: Value)
    (k1: findE tenv x = Some t)
    (k2: findE env x = Some v) :
  (sVTyp (projT1 v)) =
      sVTyp (projT1
       (proj1_of_sigT2
          (ExtRelVal2A valueVTyp tenv env x t m k1))).
  rewrite (ExtRelVal2A2_ok env tenv m x t v k1 k2).
  reflexivity.
Defined.

Lemma ExtRelVal2A2_TypSym_ok (env: valEnv) (tenv: valTC)
    (m: EnvTyping env tenv)
    (x: Id) (t: VTyp) (v: Value)
    (k1: findE tenv x = Some t)
    (k2: findE env x = Some v) :
    sVTyp (projT1
       (proj1_of_sigT2
          (ExtRelVal2A valueVTyp tenv env x t m k1))) =
    (sVTyp (projT1 v)).
  rewrite (ExtRelVal2A2_ok env tenv m x t v k1 k2).
  reflexivity.
Defined.

Lemma ExtRelVal_aux1 (env : list (LangSpecL.Id * Value))
  (x : Id)
  (t : VTyp)
  (v : sVTyp t)
  (k2 : findE env x = Some (existT ValueI t (Cst t v)))
  (k1 : findE (valEnv2valTC env) x = Some t)
  (H : existT ValueI t (Cst t v) =
       (let (a, _, _) := ExtRelVal2B env x t k1 in a))  :
  ExtRelVal2B_Typ_ok env x t (existT ValueI t (Cst t v)) k1 k2 =

    eq_ind_r
      (fun v0 : Value =>
       sVTyp (projT1 v0) =
       sVTyp (projT1 (proj1_of_sigT2 (ExtRelVal2B env x t k1)))) eq_refl
      (eq_ind_r
         (fun v0 : Value =>
          v0 =
          (let (a, _, _) :=
             list_rect
               (fun env0 : list (LangSpecL.Id * Value) =>
                findE (valEnv2valTC env0) x = Some t ->
                {v1 : Value & findE env0 x = Some v1 & projT1 v1 = t})
               (fun H0 : None = Some t =>
                False_rect {v1 : Value & None = Some v1 & projT1 v1 = t}
                  (eq_ind None
                     (fun e : option VTyp =>
                      match e with
                      | Some _ => False
                      | None => True
                      end) I (Some t) H0))
               (fun (a : LangSpecL.Id * Value)
                  (env0 : list (LangSpecL.Id * Value))
                  (IHenv : findE (valEnv2valTC env0) x = Some t ->
                           {v1 : Value & findE env0 x = Some v1 &
                           projT1 v1 = t}) =>
                let
                  (i, v1) as p
                   return
                     ((if IdT.IdEqDec x (fst p)
                       then Some (valueVTyp (snd p))
                       else findE (valEnv2valTC env0) x) =
                      Some t ->
                      {v1 : Value &
                      (let (k', x0) := p in
                       if IdT.IdEqDec x k' then Some x0 else findE env0 x) =
                      Some v1 & projT1 v1 = t}) := a in
                if IdT.IdEqDec x i as s
                 return
                   ((if s
                     then Some (valueVTyp v1)
                     else findE (valEnv2valTC env0) x) =
                    Some t ->
                    {v2 : Value &
                    (if s then Some v1 else findE env0 x) = Some v2 &
                    projT1 v2 = t})
                then
                 fun H0 : Some (valueVTyp v1) = Some t =>
                 existT2 (fun v2 : Value => Some v1 = Some v2)
                   (fun v2 : Value => projT1 v2 = t) v1 eq_refl
                   (f_equal
                      (fun e0 : option VTyp =>
                       match e0 with
                       | Some v2 => v2
                       | None => let (a0, _) := v1 in a0
                       end) H0)
                else fun H0 : findE (valEnv2valTC env0) x = Some t => IHenv H0)
               env k1 in
           a)) eq_refl
         (ExtRelVal2B_ok env x t (existT ValueI t (Cst t v)) k1 k2)).
  unfold eq_ind_r.
  unfold eq_ind.
  unfold eq_sym at 1.

  simpl.
  eapply proof_irrelevance.
Defined.

(* DEPTYP main idea: replace the equality parameter, and work through
by simplifing the equality proof-term *)
Lemma ExtRelVal2B_ok2 (env: valEnv)
    (x: Id) (t: VTyp) (v: Value)
    (k1: findE (valEnv2valTC env) x = Some t)
    (k2: findE env x = Some v)
    (te: (sVTyp (projT1 v)) = sVTyp (projT1
                            (proj1_of_sigT2 (ExtRelVal2B env x t k1))))
  :  sValue (proj1_of_sigT2 (ExtRelVal2B env x t k1)) =
     match te with
          eq_refl => sValue v
     end.
  replace te with (ExtRelVal2B_Typ_ok env x t v k1 k2).
  Focus 2.
  eapply proof_irrelevance.
  clear te.
  assert ( v = proj1_of_sigT2 (ExtRelVal2B env x t k1)).
  eapply ExtRelVal2B_ok.
  exact k2.
  destruct v.
  destruct v.
  assert (x0 = t).
  clear H.
  eapply RelatedByEnv with (f:= valueVTyp) (env1:=env)
                           (v1:= (existT ValueI x0 (Cst x0 v))) in k1.
  simpl in k1.
  exact k1.
  constructor.
  exact k2.
  inversion H0; subst.
  clear H1.
  unfold proj1_of_sigT2 in H.
  simpl in H.
  revert H.
  generalize k1.
  generalize (ExtRelVal2B env x t k1).
  clear k1.
  induction env.
  inversion k2.
  simpl in k2.
  destruct a.

  unfold ExtRelVal2B_Typ_ok.
  simpl.

  destruct (IdT.IdEqDec x i).

  inversion e; subst.
  clear H.
  inversion k2; subst.
  dependent destruction k2.
  simpl in *.
  intros.
  unfold sValue.
  unfold sValueI.
  unfold proj1_of_sigT2.
  unfold sigT_of_sigT2.
  simpl.
  reflexivity.

  intros.
  specialize (IHenv k2 X k1 H).

  rewrite IHenv.
  clear IHenv.

  clear X.
  clear n.
  clear i.
  clear v0.

  assert (sValue (existT ValueI t (Cst t v)) = v) as E1.
  unfold sValue.
  unfold sValueI.
  simpl.
  reflexivity.

  rewrite E1.
  clear E1.

  rewrite ExtRelVal_aux1.
  reflexivity.
  exact H.
Defined.

Lemma depeq_sym {T1 T2: Type} (te: T2 = T1) (x1: T1) (x2: T2)
        (p: x1 = match te with eq_refl => x2 end) :
   x2 = match (eq_sym te) with eq_refl => x1 end.
    rewrite p.
    unfold eq_sym.
    dependent destruction te.
    reflexivity.
Defined.

Lemma ExtRelVal2B_ok1 (env: valEnv)
    (x: Id) (t: VTyp) (v: Value)
    (k1: findE (valEnv2valTC env) x = Some t)
    (k2: findE env x = Some v)
    (te: sVTyp (projT1 (proj1_of_sigT2 (ExtRelVal2B env x t k1))) =
         (sVTyp (projT1 v)))
  : sValue v = match te with
      eq_refl => sValue (proj1_of_sigT2 (ExtRelVal2B env x t k1))
               end.
  replace te with (eq_sym (ExtRelVal2B_Typ_ok env x t v k1 k2)).
  Focus 2.
  eapply proof_irrelevance.
  eapply depeq_sym.
  eapply ExtRelVal2B_ok2.
  exact k2.
Defined.

End PreRefl.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export DistributedReferenceCounting.machine2.invariant0.
Require Export DistributedReferenceCounting.machine2.invariant1.
Require Export DistributedReferenceCounting.machine2.invariant2.
Require Export DistributedReferenceCounting.machine2.invariant3.
Require Export DistributedReferenceCounting.machine2.invariant4.

Unset Standard Proposition Elimination Names.

(* changes:
   only a few changes in ancestor_not_reflexive for
   transition  6 ,  where n0->n1, n1-> n2, n2-> n3.
*)

Section INVARIANT6.

Variable c0 : Config.

Fixpoint inc_dec_in_queue (s : Site) (q : queue Message) {struct q} : Prop :=
  match q with
  | empty => False
  | input (inc_dec s2) q' =>
      if eq_site_dec s2 s then True else False
  | input _ q' => inc_dec_in_queue s q'
  end.

(* note that the contrary is not true ! *)

Lemma inc_dec_in :
 forall (s : Site) (q : queue Message),
 inc_dec_in_queue s q -> In_queue Message (inc_dec s) q.

Proof.
  simple induction q.
  simpl in |- *.
  auto.
  simpl in |- *.
  intro.
  intro.
  intro.
  case d.
  intuition.
  intro.
  case (eq_site_dec s0 s).
  intro.
  rewrite e.
  intuition.
  intro.
  intuition.
  intuition.
Qed.

Lemma inc_dec_queue_equal :
 forall (q : queue Message) (s1 s2 : Site),
 inc_dec_in_queue s1 q -> inc_dec_in_queue s2 q -> s1 = s2.

Proof.
  simple induction q.
  simpl in |- *.
  intuition.
  simpl in |- *.
  intros d q0 s1 s2.
  intro s0.
  case d.
  auto.
  intro.
  case (eq_site_dec s s2).
  case (eq_site_dec s s0).
  intros.
  rewrite <- e; rewrite e0.
  auto.
  intuition.
  intuition.
  auto.
Qed.

(* s1 is parent of s0 *)
Inductive parent : Site -> Site -> Prop :=
    parent_intro :
      forall s1 s0 : Site,
      rt c0 s0 = true -> inc_dec_in_queue s1 (bm c0 s0 owner) -> parent s1 s0.

(* s1 is ancestor of s0 *)
Inductive ancestor : Site -> Site -> Prop :=
  | short : forall s1 s0 : Site, parent s1 s0 -> ancestor s1 s0
  | long :
      forall s2 s1 s0 : Site,
      ancestor s2 s1 -> parent s1 s0 -> ancestor s2 s0.

Lemma decide_rt : forall s : Site, {rt c0 s = false} + {rt c0 s = true}.
Proof.
  intros.
  case (rt c0 s).
  auto.
  auto.
Qed.

Lemma decide_inc_dec_in_queue :
 forall s : Site,
 {s1 : Site | inc_dec_in_queue s1 (bm c0 s owner)} +
 {(forall s1 : Site, ~ inc_dec_in_queue s1 (bm c0 s owner))}.
Proof.
  intros.
  elim (bm c0 s owner).
  simpl in |- *.
  intuition.

  intros.
  case d.
  simpl in |- *.
  auto.

  simpl in |- *.
  intros.
  left.
  split with s0.
  case (eq_site_dec s0 s0).
  auto.
  intro; elim n; auto.
  simpl in |- *; auto.
Qed.

Lemma decide_parent : forall s1 s3 : Site, {parent s1 s3} + {~ parent s1 s3}.

Proof.
  intros.
  elim (decide_rt s3).
  intro.
  right.
  unfold not in |- *.
  intro.
  generalize a.
  elim H.
  intros.
  rewrite H0 in a0.
  discriminate.

  intro.
  elim (decide_inc_dec_in_queue s3).
  intros.
  elim a.
  intros.
  case (eq_site_dec x s1).
  intro.
  left.
  apply parent_intro.
  auto.

  rewrite <- e.
  auto.

  intro.
  right.
  unfold not in |- *.
  intro.
  generalize p; generalize n.
  elim H.
  intros.
  elim n0.
  apply inc_dec_queue_equal with (q := bm c0 s2 owner).
  auto.

  auto.

  intros.
  right.
  unfold not in |- *.
  intro.
  generalize b0.
  elim H.
  intros.
  generalize (b1 s0).
  intro.
  elim H2; auto.
Qed.

Inductive direct_son : Site -> Prop :=
    direct_son_intro :
      forall s : Site,
      s <> owner ->
      rt c0 s = true ->
      (forall s1 : Site, ~ inc_dec_in_queue s1 (bm c0 s owner)) ->
      direct_son s.

Inductive indirect_son1 : Site -> Prop :=
    indirect_son1_intro :
      forall s : Site,
      s <> owner ->
      rt c0 s = true ->
      ~ (forall s1 : Site, ~ inc_dec_in_queue s1 (bm c0 s owner)) ->
      indirect_son1 s.

(*  {s1:Site | (inc_dec_in_queue s1 (bm c0 s owner))}  *)

Inductive indirect_son2 : Site -> Prop :=
    indirect_son2_intro :
      forall s s1 : Site,
      s <> owner /\ rt c0 s = true /\ direct_son s1 /\ ancestor s1 s ->
      indirect_son2 s.

(* by specifying the lemma as follows, I don't need to
   know that there is no cycle in the relation *)

Lemma decide_direct_son :
 forall s1 : Site, s1 <> owner -> {direct_son s1} + {~ direct_son s1}.
Proof.
  intros.
  elim (decide_rt s1).
  intros.
  right.
  unfold not in |- *.
  intro.
  generalize a.
  elim H0.
  intros.
  rewrite H2 in a0.
  discriminate.

  intro.
  elim (decide_inc_dec_in_queue s1).
  intro.
  right.
  unfold not in |- *.
  intro.
  generalize a.
  elim H0.
  intros.
  elim a0.
  auto.

  intro.
  left.
  apply direct_son_intro.
  auto.
  auto.
  auto.
Qed.

Lemma direct_or_indirect_son1 :
 forall s : Site,
 s <> owner -> rt c0 s = true -> {direct_son s} + {indirect_son1 s}.

Proof.
  intros.
  elim (decide_inc_dec_in_queue s).
  intro.
  right.
  apply (indirect_son1_intro s).
  auto.
  auto.
  unfold not in |- *; intros.
  elim a.
  auto.
  intros; left.
  apply (direct_son_intro s).
  auto.
  auto.
  auto.
Qed.

Lemma disjoint_case_for_site :
 forall s : Site,
 {s = owner} + {rt c0 s = false} + {direct_son s} + {indirect_son1 s}.
Proof.
  intro.
  case (eq_site_dec s owner).
  intro.
  auto.
  intro.
  generalize (direct_or_indirect_son1 s).
  intro.
  elim (decide_rt s).
  intro.
  auto.
  intro.
  auto.
  elim H.
  auto.
  auto.
  auto.
  auto.
Qed.

Lemma ancestor_transitive :
 forall s1 s2 s3 : Site, ancestor s1 s2 -> ancestor s2 s3 -> ancestor s1 s3.
Proof.
  intros s1 s2 s3 H.
  intro.
  generalize H.
  elim H0.
  intros.
  apply long with (s1 := s0).
  auto.
  auto.
  intros.
  apply long with (s1 := s4).
  auto.
  auto.
Qed.

Lemma aux :
 forall s0 s1 s2 : Site,
 parent s0 s2 -> direct_son s0 -> ancestor s1 s2 -> s1 = s0.
Proof.
   intros.
  generalize H H0.
  elim H1.
  intros.
  apply inc_dec_queue_equal with (q := bm c0 s4 owner).
  elim H2; auto.

  elim H3; auto.

  intros.
  cut (s0 = s4).
  intro.
  rewrite <- H7 in H2.
  generalize H2.
  elim H6.
  intros.
  generalize H10.
  elim H11.
  intros.
  generalize H13.
  elim H12.
  intros.
  elim (H16 s8).
  auto.

  intros.
  generalize H15.
  elim H14.
  intros.
  elim (H18 s9).
  auto.

  apply inc_dec_queue_equal with (q := bm c0 s5 owner).
  elim H5; auto.

  elim H4; auto.
Qed.

Lemma decide_ancestor :
 forall x s s1 : Site,
 direct_son x ->
 ancestor x s ->
 indirect_son1 s1 -> (s1 = s \/ ancestor s1 s) \/ s1 <> s /\ ~ ancestor s1 s.
Proof.
  intros.
  generalize H H1.
  elim H0.
  intros.
  case (eq_site_dec s1 s2).
  intro.
  left; left; auto.

  intro.
  case (eq_site_dec s0 s1).
  intro.
  generalize H3.
  rewrite e.
  elim H4.
  intros.
  intros.
  generalize H7.
  elim H8.
  intros.
  elim H12.
  auto.

  intro.
  right.
  split; auto.
  unfold not in |- *.
  intro.
  generalize (aux s0 s1 s2 H2 H3 H5).
  intro; elim n0; auto.

  intros.
  generalize (H3 H5 H1).
  intro.
  elim H7.
  intro.
  case (eq_site_dec s1 s3).
  intro.
  left; left; auto.

  intro.
  left; right.
  case (eq_site_dec s1 s0).
  intro.
  apply short.
  rewrite e; auto.

  intro.
  apply long with (s1 := s0).
  elim H8.
  intro; elim n0; auto.

  auto.

  auto.

  intro.
  case (eq_site_dec s1 s3).
  intro.
  left; left; auto.

  intro.
  right.
  split; auto.
  unfold not in |- *.
  intro.
  decompose [and] H8.
  generalize H4 H11 H10 n.
  elim H9.
  intros.
  elim H15.
  apply inc_dec_queue_equal with (q := bm c0 s5 owner).
  elim H12; auto.

  elim H13; auto.

  intros.
  cut (s0 = s5).
  intro.
  rewrite H18 in H16.
  elim H16; auto.

  apply inc_dec_queue_equal with (q := bm c0 s6 owner).
  elim H15; auto.

  elim H14; auto.
Qed.

End INVARIANT6.

Section INVARIANT6_bis.

Lemma inc_dec_in_post :
 forall (b : Bag_of_message) (s0 s1 s2 s3 : Site) (m : Message),
 inc_dec_in_queue s1 (b s0 owner) ->
 (forall s4 : Site, m <> inc_dec s4) ->
 inc_dec_in_queue s1 (Post_message Message m b s2 s3 s0 owner).
Proof.
   intros.
   case (eq_queue_dec s2 s0 s3 owner).
   intros.
   decompose [and] a.
   rewrite H1; rewrite H2.
   rewrite post_here.
   generalize H0.
   case m.
   simpl in |- *; auto.

   intro.
   intro.
   generalize (H3 s).
   intro.
   elim H4; auto.

   simpl in |- *; auto.

   intro; rewrite post_elsewhere; auto.
Qed.

Lemma inc_dec_in_post2 :
 forall (b : Bag_of_message) (s0 s1 s2 s3 : Site) (m : Message),
 inc_dec_in_queue s1 (Post_message Message m b s2 s3 s0 owner) ->
 m <> inc_dec s1 -> inc_dec_in_queue s1 (b s0 owner).
Proof.
  intros.
  generalize H.
  case (eq_queue_dec s2 s0 s3 owner).
  intros.
  decompose [and] a.
  generalize H1.
  rewrite H2; rewrite H3.
  rewrite post_here.
  generalize H0.
  elim m.
  simpl in |- *; auto.
  intro; intro.
  simpl in |- *.
  case (eq_site_dec s s1).
  intro; elim H4.
  rewrite e; auto.
  intuition.
  simpl in |- *; auto.
  intro.
  rewrite post_elsewhere.
  auto.
  auto.
Qed.

(* these two lemmas are just negations of the previous ones *)

Lemma inc_dec_not_in_post :
 forall (b : Bag_of_message) (s0 s1 s2 s3 : Site) (m : Message),
 ~ inc_dec_in_queue s1 (b s0 owner) ->
 (forall s4 : Site, m <> inc_dec s4) ->
 ~ inc_dec_in_queue s1 (Post_message Message m b s2 s3 s0 owner).
Proof.
  intros.
  unfold not in |- *.
  intro.
  elim H.
  apply (inc_dec_in_post2 b s0 s1 s2 s3 m).
  auto.
  auto.
Qed.

Lemma inc_dec_not_in_post2 :
 forall (b : Bag_of_message) (s0 s1 s2 s3 : Site) (m : Message),
 (forall s4 : Site, m <> inc_dec s4) ->
 ~ inc_dec_in_queue s1 (Post_message Message m b s2 s3 s0 owner) ->
 ~ inc_dec_in_queue s1 (b s0 owner).
Proof.
  intros.
  unfold not in |- *.
  intro.
  elim H0.
  apply inc_dec_in_post.
  auto.
  auto.
Qed.

Lemma inc_dec_not_in_first_out :
 forall (q : queue Message) (m : Message) (s3 : Site),
 first Message q = value Message m ->
 m <> inc_dec s3 ->
 ~ inc_dec_in_queue s3 q -> ~ inc_dec_in_queue s3 (first_out Message q).
Proof.
  simple induction q.
  simpl in |- *.
  auto.

  intros d q0.
  case q0.
  intro.
  intros m s3.
  simpl in |- *.
  intros.
  intuition.

  intros m q1 H m0 s3 H0 H1.
  case d.
  generalize (H m0 s3).
  simpl in |- *.
  auto.

  intro.
  case (eq_site_dec s3 s).
  intro.
  rewrite e.
  simpl in |- *.
  case (eq_site_dec s s).
  auto.

  intro.
  elim n; auto.

  intro.
  simpl in |- *.
  case (eq_site_dec s s3).
  auto.

  intro.
  generalize (H m0 s3).
  simpl in |- *.
  auto.

  generalize (H m0 s3).
  simpl in |- *.
  auto.
Qed.

Lemma inc_dec_in_first_out :
 forall (q : queue Message) (m : Message) (s3 : Site),
 first Message q = value Message m ->
 m <> inc_dec s3 ->
 inc_dec_in_queue s3 q -> inc_dec_in_queue s3 (first_out Message q).
Proof.
  simple induction q.
  simpl in |- *.
  auto.

  intros d q0.
  case q0.
  intro.
  intros m s3.
  simpl in |- *.
  case d.
  auto.

  intro.
  case (eq_site_dec s s3).
  intros.
  elim H1.
  generalize H0.
  auto.
  rewrite e.
  auto.
  generalize (inc_dec s3).
  intro.
  auto.
  intro.
  symmetry  in |- *.
  injection H3.
  auto.

  auto.

  intros.
  contradiction.

  intros m q1 H m0 s3 H0 H1.
  case d.
  generalize (H m0 s3).
  simpl in |- *.
  auto.

  intro.
  case (eq_site_dec s3 s).
  intro.
  rewrite e.
  simpl in |- *.
  case (eq_site_dec s s).
  auto.

  intro.
  elim n; auto.

  intro.
  simpl in |- *.
  case (eq_site_dec s s3).
  auto.

  intro.
  generalize (H m0 s3).
  simpl in |- *.
  auto.

  generalize (H m0 s3).
  simpl in |- *.
  auto.
Qed.

Lemma inc_dec_not_in_collect :
 forall (b : Bag_of_message) (m : Message) (s0 s1 s2 s3 : Site),
 first Message (b s1 s2) = value Message m ->
 ~ inc_dec_in_queue s3 (b s0 owner) ->
 m <> inc_dec s3 ->
 ~ inc_dec_in_queue s3 (Collect_message Message b s1 s2 s0 owner).
Proof.
  intros.
  case (eq_queue_dec s1 s0 s2 owner).
  intros.
  decompose [and] a.
  rewrite H2; rewrite H3.
  rewrite collect_here.
  apply inc_dec_not_in_first_out with (m := m).
  rewrite <- H2; rewrite <- H3; auto.
  auto.
  auto.
  intro.
  rewrite collect_elsewhere.
  auto.
  auto.
Qed.

Lemma inc_dec_in_collect :
 forall (b : Bag_of_message) (s0 s1 s2 s3 : Site) (m : Message),
 first Message (b s1 s2) = value Message m ->
 inc_dec_in_queue s3 (b s0 owner) ->
 m <> inc_dec s3 ->
 inc_dec_in_queue s3 (Collect_message Message b s1 s2 s0 owner).
Proof.
  intros.
  case (eq_queue_dec s1 s0 s2 owner).
  intros.
  decompose [and] a.
  rewrite H2; rewrite H3.
  rewrite collect_here.
  generalize (inc_dec_not_in_first_out (b s0 owner) m s3).
  intros.
  apply inc_dec_in_first_out with (m := m).
  rewrite <- H2; rewrite <- H3.
  auto.
  auto.
  auto.
  intro.
  rewrite collect_elsewhere.
  auto.
  auto.
Qed.

Lemma inc_dec_in_collect2 :
 forall (b : Bag_of_message) (m : Message) (s0 s1 s2 s3 : Site),
 first Message (b s1 s2) = value Message m ->
 inc_dec_in_queue s3 (Collect_message Message b s1 s2 s0 owner) ->
 inc_dec_in_queue s3 (b s0 owner).
Proof.
  intros b m s0 s1 s2 s3 H.
  case (eq_queue_dec s1 s0 s2 owner).
  intros.
  decompose [and] a.
  generalize H0.
  rewrite H1; rewrite H2.
  rewrite collect_here.
  elim (b s0 owner).
  simpl in |- *.
  auto.

  intros d q.
  case q.
  simpl in |- *.
  intuition.

  intro.
  case d.
  simpl in |- *.
  auto.

  intro.
  case (eq_site_dec s s3).
  intro.
  rewrite e.
  simpl in |- *.
  auto.
  case (eq_site_dec s3 s3).
  auto.

  intro.
  elim n.
  auto.

  intro.
  simpl in |- *.
  auto.

  auto.

  simpl in |- *.
  auto.

  intro.
  rewrite collect_elsewhere.
  auto.

  auto.
Qed.

Lemma not_inc_dec_in :
 forall q : queue Message,
 (forall s : Site, ~ inc_dec_in_queue s q) ->
 forall s : Site, ~ In_queue Message (inc_dec s) q.

Proof.
  simple induction q.
  simpl in |- *.
  auto.
  intro.
  case d.
  simpl in |- *.
  intros.
  intuition.
  discriminate.
  eauto.
  intros.
  generalize (H0 s).
  intro.
  elim H1.
  simpl in |- *.
  case (eq_site_dec s s).
  auto.
  intro; elim n; auto.
  intro; simpl in |- *.
  intros.
  intuition.
  discriminate.
  eauto.
Qed.

Lemma joining_node :
 forall (c : Config) (s2 : Site),
 legal c ->
 rt c s2 = false -> forall s3 s4 : Site, parent c s3 s4 -> s2 <> s3.
Proof.
  intros.
  unfold not in |- *.
  intro.
  rewrite H2 in H0.
  generalize H0.
  elim H1.
  intros.
  generalize (inc_dec_in s1 (bm c s0 owner) H4).
  intro.
  generalize (not_owner_inc3 c s0 owner H s1 H6).
  intro.
  generalize (positive_st c s1 s0 H7 H H6).
  intro.
  generalize (st_rt c s1 H H7 H8).
  rewrite H5.
  discriminate.
Qed.

Lemma ancestor_rt :
 forall c : Config,
 legal c -> forall s1 s2 : Site, ancestor c s1 s2 -> rt c s1 = true.
Proof.
  intros.
  elim H0.
  intros.
  elim H1.
  intros.
  generalize (inc_dec_in s4 (bm c s5 owner) H3).
  intro.
  generalize (not_owner_inc3 c s5 owner H s4 H4).
  intro.
  generalize (positive_st c s4 s5 H5 H H4).
  intro.
  generalize (st_rt c s4 H H5 H6).
  auto.
  intros.
  auto.
Qed.

Lemma ancestor_rt2 :
 forall c : Config,
 legal c -> forall s1 s2 : Site, ancestor c s1 s2 -> rt c s2 = true.
Proof.
  intros.
  elim H0.
  intros.
  elim H1.
  auto.
  intros.
  elim H3; auto.
Qed.

(* the parent of a node cannot be the which receives
   a gp for the first time *)

Lemma parent_does_not_join :
 forall (c0 : Config) (s2 s3 s4 : Site),
 legal c0 ->
 legal (rec_copy2_trans c0 s2) ->
 parent (rec_copy2_trans c0 s2) s3 s4 ->
 rt c0 s2 = false ->
 first Message (bm c0 owner s2) = value Message copy -> s3 <> s2.
Proof.
  intros.
  elim H1.
  intros.
  generalize (inc_dec_in s1 (bm (rec_copy2_trans c0 s2) s0 owner) H5).
  intro.
  generalize (not_reflexive (rec_copy2_trans c0 s2) H0 s1 s0 H6).
  intro.
  cut (s1 <> owner).
  intro.
  generalize (positive_st (rec_copy2_trans c0 s2) s1 s0 H8 H0 H6).
  intro.
  generalize (st_rt (rec_copy2_trans c0 s2) s1 H0 H8 H9).
  intro.
  generalize H5.
  simpl in |- *.
  intro.
  generalize (inc_dec_in_collect2 (bm c0) copy s0 owner s2 s1 H3 H11).
  intro.
  generalize (inc_dec_in s1 (bm c0 s0 owner) H12).
  intro.
  generalize (positive_st c0 s1 s0 H8 H H13).
  intro.
  generalize (st_rt c0 s1 H H8 H14).
  intro.
  unfold not in |- *.
  intro.
  rewrite H16 in H15.
  rewrite H15 in H2.
  discriminate.

  apply (not_owner_inc3 (rec_copy2_trans c0 s2) s0 owner H0).
  auto.
Qed.

(* the ancestor of a node cannot be the which receives
   a gp for the first time *)

Lemma ancestor_does_not_join :
 forall (c0 : Config) (s2 s3 s4 : Site),
 legal c0 ->
 legal (rec_copy2_trans c0 s2) ->
 ancestor (rec_copy2_trans c0 s2) s3 s4 ->
 rt c0 s2 = false ->
 first Message (bm c0 owner s2) = value Message copy -> s3 <> s2.
Proof.
  intros.
  elim H1.
  intros.
  apply (parent_does_not_join c0 s2 s1 s0).
  auto.
  auto.
  auto.
  auto.
  auto.
  intros.
  auto.
Qed.

Lemma parent_does_not_join2 :
 forall (c0 : Config) (s1 s2 s3 s4 : Site),
 legal c0 ->
 legal (rec_copy3_trans c0 s1 s2) ->
 parent (rec_copy3_trans c0 s1 s2) s3 s4 ->
 rt c0 s2 = false ->
 first Message (bm c0 s1 s2) = value Message copy -> s3 <> s2.
Proof.
  intros.
  elim H1.
  intros.
  generalize (inc_dec_in s0 (bm (rec_copy3_trans c0 s1 s2) s5 owner) H5).
  intro.
  generalize (not_reflexive (rec_copy3_trans c0 s1 s2) H0 s0 s5 H6).
  intro.
  cut (s0 <> owner).
  intro.
  generalize (positive_st (rec_copy3_trans c0 s1 s2) s0 s5 H8 H0 H6).
  intro.
  generalize (st_rt (rec_copy3_trans c0 s1 s2) s0 H0 H8 H9).
  intro.
  generalize H5.
  simpl in |- *.
  intro.
  case (eq_site_dec s2 s5).
  intro.
  rewrite e; auto.

  intro.
  generalize H11.
  rewrite post_elsewhere.
  intro.
  generalize (inc_dec_in_collect2 (bm c0) copy s5 s1 s2 s0 H3 H12).
  intro.
  generalize (inc_dec_in s0 (bm c0 s5 owner) H13).
  intro.
  generalize (positive_st c0 s0 s5 H8 H H14).
  intro.
  generalize (st_rt c0 s0 H H8 H15).
  intro.
  unfold not in |- *.
  intro.
  rewrite H17 in H16.
  rewrite H16 in H2.
  discriminate.

  left; auto.

  apply (not_owner_inc3 (rec_copy3_trans c0 s1 s2) s5 owner H0).
  auto.
Qed.

Lemma ancestor_does_not_join2 :
 forall (c0 : Config) (s1 s2 s3 s4 : Site),
 legal c0 ->
 legal (rec_copy3_trans c0 s1 s2) ->
 ancestor (rec_copy3_trans c0 s1 s2) s3 s4 ->
 rt c0 s2 = false ->
 first Message (bm c0 s1 s2) = value Message copy -> s3 <> s2.
Proof.
  intros.
  elim H1.
  intros.
  apply (parent_does_not_join2 c0 s1 s2 s0 s5).
  auto.
  auto.
  auto.
  auto.
  auto.
  intros; auto.
Qed.

Lemma ancestor_not_reflexive :
 forall c : Config,
 legal c -> forall s1 s2 : Site, ancestor c s1 s2 -> s1 <> s2.
Proof.
  intros c H.
  generalize H.
  elim H.
  simpl in |- *.
  intros.
  elim H1.
  intros.
  elim H2.
  simpl in |- *.
  intuition.

  simpl in |- *.
  intros.
  elim H4.
  simpl in |- *.
  intuition.

  simple induction t.

(*  1*)
  intros.
  apply H1.
  auto.

  elim H3.
  simpl in |- *.
  intros.
  apply short.
  elim H4.
  intros.
  apply parent_intro.
  generalize H5; simpl in |- *; auto.

  apply (inc_dec_in_post2 (bm c0) s7 s6 s1 s2 copy).
  generalize H6; simpl in |- *; auto.

  discriminate.

  intros.
  apply long with (s1 := s5).
  auto.

  elim H6.
  intros.
  apply parent_intro.
  generalize H7; simpl in |- *; auto.

  apply (inc_dec_in_post2 (bm c0) s8 s7 s1 s2 copy).
  generalize H8; simpl in |- *; auto.

  discriminate.

(* 2 *)
  intros.
  apply H1.
  auto.

  elim H3.
  simpl in |- *.
  intros.
  apply short.
  elim H4.
  intros.
  apply parent_intro.
  generalize H5; simpl in |- *; auto.

  apply (inc_dec_in_collect2 (bm c0) dec s7 s1 s2 s6).
  auto.

  generalize H6; simpl in |- *; auto.

  intros.
  apply long with (s1 := s5).
  auto.

  elim H6.
  intros.
  apply parent_intro.
  generalize H7; simpl in |- *; auto.

  apply (inc_dec_in_collect2 (bm c0) dec s8 s1 s2 s7).
  auto.

  generalize H8; simpl in |- *; auto.

(* 3 *)
  intros.
  apply H1.
  auto.

  elim H3.
  simpl in |- *.
  intros.
  apply short.
  elim H4.
  intros.
  apply parent_intro.
  generalize H5; simpl in |- *; auto.

  apply (inc_dec_in_collect2 (bm c0) (inc_dec s3) s7 s1 owner s6).
  auto.

  apply
   (inc_dec_in_post2 (Collect_message Message (bm c0) s1 owner) s7 s6 owner
      s3 dec).
  generalize H6; simpl in |- *; auto.

  discriminate.

  intros.
  apply long with (s1 := s5).
  auto.

  elim H6.
  intros.
  apply parent_intro.
  generalize H7; simpl in |- *; auto.

  apply (inc_dec_in_collect2 (bm c0) (inc_dec s3) s8 s1 owner s7).
  auto.

  apply
   (inc_dec_in_post2 (Collect_message Message (bm c0) s1 owner) s8 s7 owner
      s3 dec).
  generalize H8; simpl in |- *; auto.

  discriminate.

(* 4 *)
  intros.
  apply H1.
  auto.

  elim H3.
  simpl in |- *.
  intros.
  apply short.
  elim H4.
  intros.
  apply parent_intro.
  generalize H5; simpl in |- *; auto.

  apply (inc_dec_in_collect2 (bm c0) copy s7 s1 s2 s6).
  auto.

  apply
   (inc_dec_in_post2 (Collect_message Message (bm c0) s1 s2) s7 s6 s2 s1 dec).
  generalize H6; simpl in |- *; auto.

  discriminate.

  intros.
  apply long with (s1 := s5).
  auto.

  elim H6.
  intros.
  apply parent_intro.
  generalize H7; simpl in |- *; auto.

  apply (inc_dec_in_collect2 (bm c0) copy s8 s1 s2 s7).
  auto.

  apply
   (inc_dec_in_post2 (Collect_message Message (bm c0) s1 s2) s8 s7 s2 s1 dec).
  generalize H8; simpl in |- *; auto.

  discriminate.

  (*  5 *)
  simpl in |- *.
  intros.
  case (eq_site_dec s0 s2).
  intro.
  generalize e e0 e1.
  elim H3.
  intro; intro; intro.
  elim H4.
  intros.
  rewrite e4 in H5.
  rewrite e4 in H6.
  rewrite e4.
  generalize (inc_dec_in s5 (bm (rec_copy2_trans c0 s2) s2 owner) H6).
  intro.
  apply not_reflexive with (c := rec_copy2_trans c0 s2).
  auto.
  auto.
  intros.

  apply (ancestor_does_not_join c0 s5 s3 s4).
  auto.
  rewrite e4; auto.
  rewrite e4; auto.
  rewrite e4; auto.
  rewrite e4; auto.

   (* base case when s0!=s2*)

  intro.
  apply H1.
  auto.

  generalize e.
  generalize n.
  elim H3.
  intros.
  apply short.
  generalize n0.
  elim H4.
  intros.
  apply parent_intro.
  generalize H5; simpl in |- *.
  unfold Set_rec_table in |- *; rewrite other_site; auto.

  generalize H6; simpl in |- *.
  intro.
  apply (inc_dec_in_collect2 (bm c0) copy s6 owner s2 s5).
  auto.

  auto.

      (* inductive case when s0!=s1*)

  intros.
  apply long with (s1 := s4).
  apply H5.
  apply (parent_does_not_join c0 s2 s4 s5).
  auto.
  auto.
  auto.
  auto.
  auto.
  auto.

  generalize n0; elim H6.
  intros.
  apply parent_intro.
  generalize H7; simpl in |- *.
  unfold Set_rec_table in |- *; rewrite other_site; auto.

  generalize H8; simpl in |- *.
  intro.
  apply (inc_dec_in_collect2 (bm c0) copy s7 owner s2 s6).
  auto.

  auto.

  (*  6 *)

  simpl in |- *.
  intros.
  case (eq_site_dec s2 s3).
  intro.
  generalize e e0 e1.
  elim H3.
  intro; intro; intro.
  elim H4.
  intros.
  generalize (inc_dec_in s6 (bm (rec_copy3_trans c0 s1 s2) s7 owner) H6).
  intro.
  apply not_reflexive with (c := rec_copy3_trans c0 s1 s2).
  auto.

  auto.

  intros.
  rewrite <- e4.
  apply (ancestor_does_not_join2 c0 s1 s2 s4 s5).
  auto.
  auto.
  auto.
  auto.
  auto.
  intro.
  apply H1.
  auto.

  generalize e.
  generalize n.
  generalize n1.
  elim H3.
  intros.
  apply short.
  generalize n2 n3 e1.
  elim H4.
  intros.
  apply parent_intro.
  generalize H5; simpl in |- *.
  unfold Set_rec_table in |- *; rewrite other_site; auto.

  generalize H6; simpl in |- *.
  rewrite post_elsewhere.
  intro.
  apply (inc_dec_in_collect2 (bm c0) copy s7 s1 s2 s6).
  auto.

  auto.

  left; auto.

  intros.
  apply long with (s1 := s5).
  apply H5.
  generalize (parent_does_not_join2 c0 s1 s2 s5 s6 H0 H2 H6 e1 e0).
  auto.

  auto.

  auto.

  generalize n2.
  elim H6.
  intros.
  apply parent_intro.
  generalize H7; simpl in |- *.
  unfold Set_rec_table in |- *; rewrite other_site; auto.

  generalize H8; simpl in |- *.
  rewrite post_elsewhere.
  intro.
  apply (inc_dec_in_collect2 (bm c0) copy s8 s1 s2 s7).
  auto.

  auto.

  left; auto.

  (* 7 *)

  intros.
  apply H1.
  auto.

  elim H3.
  simpl in |- *.
  intros.
  apply short.
  elim H4.
  intros.
  apply parent_intro.
  generalize H5; simpl in |- *; auto.
  unfold Reset_rec_table in |- *.
  case (eq_site_dec s s5).
  intro; rewrite e1.
  rewrite that_site; auto.
  intro; discriminate.

  intro; rewrite other_site; auto.

  generalize H6; simpl in |- *.
  intro.
  apply (inc_dec_in_post2 (bm c0) s5 s4 s owner dec).
  auto.

  discriminate.

  intros.
  apply long with (s1 := s3).
  auto.

  elim H6.
  intros.
  apply parent_intro.
  generalize H7; simpl in |- *; auto.
  case (eq_site_dec s s6).
  intro; rewrite e1; unfold Reset_rec_table in |- *; rewrite that_site.
  intro; discriminate.

  intro; unfold Reset_rec_table in |- *; rewrite other_site; auto.

  generalize H8; simpl in |- *; intro.
  apply (inc_dec_in_post2 (bm c0) s6 s5 s owner dec).
  auto.

  discriminate.
Qed.

Lemma ancestor_has_positive_st :
 forall c : Config,
 legal c -> forall s1 s2 : Site, ancestor c s1 s2 -> (st c s1 > 0)%Z.
Proof.
  intros.
  elim H0.
  intros.
  elim H1.
  intros.
  generalize (inc_dec_in s4 (bm c s5 owner) H3).
  intro.
  apply positive_st with (s5 := s5).
  apply not_owner_inc3 with (s1 := s5) (s2 := owner) (c := c).
  auto.
  auto.
  auto.
  auto.
  intros; auto.
Qed.

End INVARIANT6_bis.