(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(** CAMP is a small calculus for pattern matching. Its purpose is to
  capture the semantics of rules languages that rely on the ability to
  recover from match failure. *)

(** Two distinct evaluation functions for CAMP are defined. The first
  is a standard evaluation function and serves as semantic
  definition. The second is equivalent but maintains a trace of the
  evaluation for debugging purposes. *)

(** Summary:
- Language: CAMP (Calculus for Aggregating Matching Patterns)
- Based on: "A Pattern Calculus for Rule Languages:
  Expressiveness, Compilation, and Mechanization" Avraham
  Shinnar, Jérôme Siméon, and Martin Hirzel. ECOOP'2015.
- URL: http://drops.dagstuhl.de/opus/volltexte/2015/5237/
- Languages translating to CAMP: TechRule, DesignRule, CAMPRule, cNNRC
- Languages translating from CAMP: NRA, cNRAEnv, NRAEnv
*)

Require Import String.
Require Import List.
Require Import EquivDec.
Require Import Morphisms.
Require Import Utils.
Require Import DataRuntime.
Require Import CAMPUtil.

Declare Scope camp_scope.

Section CAMP.
  Local Open Scope string.

  Context {fruntime:foreign_runtime}.

  (** * Abstract Syntax Tree *)

  (** CAMP patterns are pure expressions. They match against a current
  value in the context of an environment. The environment has a
  globale component which is static, and a local component which can
  be modified in the course of evaluation. *)

  (** Operations include: pmap, a functional map which skips match
  failure; passert, which turns match failure into a terminal failure,
  and porElse which allows to continue to a new pattern in case of
  match failure. *)

  (** Compared to the published material, three new operators are
  added: pgetConstant which accesses the global environment, pleft and
  pright which support pattern matching against choice values. *)

  Inductive camp : Set :=
  | pconst : data -> camp                  (**r Constant value *)
  | punop : unary_op -> camp -> camp        (**r Unary operators *)
  | pbinop : binary_op -> camp -> camp -> camp (**r Binary operators *)
  | pmap : camp -> camp                    (**r Functional map *)
  | passert : camp -> camp                 (**r Assert pattern-matching success *)
  | porElse : camp -> camp -> camp         (**r Recover from failure *)
  | pit : camp                             (**r Current value being matched *)
  | pletIt : camp -> camp -> camp          (**r Set the current value *)
  | pgetConstant : string -> camp          (**r Access to a global variable *)
  | penv : camp                            (**r Current environment *)
  | pletEnv : camp -> camp -> camp         (**r Add bindings to the environment *)
  | pleft : camp                           (**r Matches if the value is a left choice *)
  | pright : camp.                         (**r Matches if the value is a right choice *)

  (* begin hide *)
  Tactic Notation "camp_cases" tactic(first) ident(c) :=
    first;
    [ Case_aux c "pconst"%string
    | Case_aux c "punop"%string
    | Case_aux c "pbinop"%string
    | Case_aux c "pmap"%string
    | Case_aux c "passert"%string
    | Case_aux c "porElse"%string
    | Case_aux c "pit"%string
    | Case_aux c "pletIt"%string
    | Case_aux c "pgetConstant"%string
    | Case_aux c "penv"%string
    | Case_aux c "pletEnv"%string
    | Case_aux c "pleft"%string
    | Case_aux c "pright"%string].
  (* end hide *)

  (** Equality between two CAMP patterns is decidable. *)

  Global Instance camp_eqdec : EqDec camp eq.
  Proof.
    change (forall x y : camp, {x = y} + {x <> y}).
    decide equality.
    apply data_eqdec.
    apply unary_op_eqdec.
    apply binary_op_eqdec.
    apply string_dec.
  Qed.

  (** * Evaluation Semantics *)

  (** Evaluation takes a camp pattern, a global environment, a local
    environment and a current value. It returns a presult which can be
    either a successful evaluation holding a value, a match failure,
    or a terminal failure. *)

  (** The external context for evaluation includes a brand relation,
    and a global environment. *)

  Section Evaluation.
    Context (h:brand_relation_t).
    Context (constant_env:bindings).

    Fixpoint camp_eval (p:camp) (bind:bindings) (d:data) : presult data
      := match p with
         | pconst d' => Success (normalize_data h d')
         | punop op p₁ => bindpr (camp_eval p₁ bind d)
                                 (fun d' => (op2tpr (unary_op_eval h op d')))
         | pbinop op p₁ p₂ =>
           bindpr (camp_eval p₁ bind d)
                  (fun d'₁ =>
                     bindpr (camp_eval p₂ bind d)
                            (fun d'₂ =>  (op2tpr (binary_op_eval h op d'₁ d'₂))))
         | pmap p₁ =>
           match d with
           | dcoll l => liftpr dcoll (gather_successes (map (camp_eval p₁ bind) l))
           | _ => TerminalError
           end
         | passert p₁ =>
           bindpr (camp_eval p₁ bind d)
                  (fun d' => match d' with
                             | dbool true => Success (drec nil)
                             | dbool false => RecoverableError
                             | _ => TerminalError
                             end)
         | porElse p₁ p₂ =>
           match camp_eval p₁ bind d with
           | TerminalError => TerminalError
           | RecoverableError => camp_eval p₂ bind d
           | Success x => Success x
           end
         | pit => Success d
         | pletIt p₁ p₂ =>
           bindpr (camp_eval p₁ bind d) (camp_eval p₂ bind)
         | pgetConstant s => op2tpr (edot constant_env s)
         | penv => Success (drec bind)
         | pletEnv p₁ p₂ =>
           bindpr (camp_eval p₁ bind d)
                  (fun rd'₁ => match rd'₁ with
                               | drec d'₁ => match merge_bindings bind d'₁ with
                                             | Some bind' => camp_eval p₂ bind' d
                                             | None => RecoverableError
                                             end
                               | _ => TerminalError
                               end)
         | pleft =>
           match d with
           | dleft d' => Success d'
           | dright _ => RecoverableError
           | _ => TerminalError
           end
         | pright =>
           match d with
           | dright d' => Success d'
           | dleft _ => RecoverableError
           | _ => TerminalError
           end
         end.

  End Evaluation.

  (** * Pretty Printing *)

  (** Evaluation traces rely on printing support for CAMP's abstract syntax. *)

  Global Instance ToString_camp : ToString camp
    := { toString :=
           fix toStringp (p:camp) : string :=
             match p with
             | pconst d => "(pconst " ++ toString d ++ ")"
             | punop u p1 => "(punop " ++ toString u ++ " " ++ toStringp p1 ++ ")"
             | pbinop b p1 p2 => "(pbinop " ++ toString b ++ " " ++ toStringp p1++ " " ++ toStringp p2 ++ ")"
             | pmap p1 => "(pmap " ++ toStringp p1 ++ ")"
             | passert p1 => "(passert " ++ toStringp p1 ++ ")"
             | porElse p1 p2 => "(porElse " ++ toStringp p1++ " " ++ toStringp p2 ++ ")"
             | pit  => "pit"
             | pletIt p1 p2 => "(pletIt " ++ toStringp p1++ " " ++ toStringp p2 ++ ")"
             | pgetConstant s => "(pgetConstant " ++ s ++ ")"
             | penv => "penv"
             | pletEnv p1 p2 => "(pletEnv " ++ toStringp p1++ " " ++ toStringp p2 ++ ")"
             | pleft => "pleft"
             | pright => "pright"
             end
       }.

  Fixpoint toString_camp_with_path (p:camp) (loc:camp_src_path) :=
    match loc with
    | nil => string_bracket "<<<"  (toString p) ">>>"
    | pos::loc' =>
      match p with
      | pconst d => "(pconst " ++ toString d ++ ")"
      | punop u p1 => "(punop " ++ toString u ++ " " ++
                                toString_camp_with_path p1 loc' ++ ")"
      | pbinop b p1 p2 => "(pbinop "
                            ++ toString b ++ " " ++
                            (if pos == 0
                             then toString_camp_with_path p1 loc'
                             else toString p1)
                            ++ " " ++
                            (if pos == 1
                             then toString_camp_with_path p2 loc'
                             else toString p2) ++ ")"
      | pmap p1 => "(pmap " ++ toString_camp_with_path p1 loc' ++ ")"
      | passert p1 => "(passert " ++ toString_camp_with_path p1 loc' ++ ")"
      | porElse p1 p2 => "(porElse " ++
                                     (if pos == 0
                                      then toString_camp_with_path p1 loc'
                                      else toString p1)
                                     ++ " " ++
                                     (if pos == 1
                                      then toString_camp_with_path p2 loc'
                                      else toString p2) ++ ")"
      | pit  => "pit"
      | pletIt p1 p2 => "(pletIt " ++
                                   (if pos == 0
                                    then toString_camp_with_path p1 loc'
                                    else toString p1)
                                   ++ " " ++
                                   (if pos == 1
                                    then toString_camp_with_path p2 loc'
                                    else toString p2) ++ ")"
      | pgetConstant s => "(pgetConstant " ++ s ++ ")"
      | penv => "penv"
      | pletEnv p1 p2 => "(pletEnv " ++
                                     (if pos == 0
                                      then toString_camp_with_path p1 loc'
                                      else toString p1)
                                     ++ " " ++
                                     (if pos == 1
                                      then toString_camp_with_path p2 loc'
                                      else toString p2) ++ ")"

      | pleft => "pleft"
      | pright => "pright"
      end
    end.

  (** * Traced Evaluation *)

  (** An alternative version of the compiler that keeps debug
     information. While this forces some code duplication, this is
     mitigated by the fact that the evaluation code is relatively
     small and simple. *)

  (** The context is the same as for default evaluation, with an
  additional printing flag. *)

  Section EvaluationDebug.
    Context (h:brand_relation_t).
    Context (constant_env:list(string*data)).
    Context (print_env:bool).

    (** The following functions are used to produce error messages. *)

    Definition mk_err (desc:string) (p:camp) (bind:bindings) (it:data)
      := toString p ++ " failed" ++ desc ++ "." ++
                  (if print_env
                   then "\n Current environment (env): "
                          ++ toString (drec bind)
                   else "") ++
                  "\n Current scrutinee (it): "
                  ++ toString it ++
                  "\n".

    (* It is important to separate out the debug messages.
     Otherwise, they get reduced by proofs, which is painful *)
    Definition punop_err (p:camp) (bind:bindings) (it:data) (d:data) : string
      := (mk_err "" p bind it ++ " The operator's argument was: " ++ toString d ++ "\n").

    Definition binop_err (p:camp) (bind:bindings) (it:data) (d'₁ d'₂:data) : string
      := (mk_err "" p bind it ++ " The operator's first argument was: " ++ toString d'₁
                 ++ "\n The operator's second argument was: " ++ toString d'₂
                 ++ "\n").

    Definition pmap_err (p:camp) (bind:bindings) (it:data) : string
      := mk_err " because the scrutinee was not a collection" p bind it.

    Definition passert_err (p:camp) (bind:bindings) (it d:data) : string
      := mk_err " because the argument was not a boolean" p bind it
                ++ " The argument to passert was: " ++ toString d
                ++ "\n".

    Definition pletEnv_err (p:camp) (bind:bindings) (it d:data) : string
      := mk_err " because its first argument was not a record" p bind it
                ++ " The first argument to pletEnv was: " ++ toString d.

    Definition pleft_err (bind:bindings) (it:data) : string
      := mk_err " because the scrutinee was an incompatible type" pleft bind it.

    Definition pright_err (bind:bindings) (it:data) : string
      := mk_err " because the scrutinee was an incompatible type" pright bind it.

    Definition pgetConstant_err s (bind:bindings) (it:data) : string
      := mk_err (" because the given field (" ++ s ++
                                              ") is not a valid constant") (pgetConstant s) bind it
                ++ " The set of constants for this execution is: " ++
                (string_bracket "{" (String.concat "; " (domain constant_env)) "}")
                ++ "\n".

    (** The alternative traced evaluation is defined as follows. *)

    Fixpoint camp_eval_debug (loc:camp_src_path) (p:camp) (bind:bindings) (d:data) : presult_debug data
      := match p with
         | pconst d' => Success_debug (normalize_data h d')
         | punop op p₁ =>
           match camp_eval_debug (0::loc) p₁ bind d with
           | TerminalError_debug s loc' => TerminalError_debug s loc'
           | RecoverableError_debug s => RecoverableError_debug s
           | Success_debug d' =>
             match unary_op_eval h op d' with
             | None => TerminalError_debug (punop_err (punop op p₁) bind d d')  loc
             | Some x => Success_debug x
             end
           end
         | pbinop op p₁ p₂ =>
           match camp_eval_debug (0::loc) p₁ bind d with
           | TerminalError_debug s loc' => TerminalError_debug s loc'
           | RecoverableError_debug s => RecoverableError_debug s
           | Success_debug d'₁ =>
             match camp_eval_debug (1::loc) p₂ bind d with
             | TerminalError_debug s loc' => TerminalError_debug s loc'
             | RecoverableError_debug s => RecoverableError_debug s
             | Success_debug d'₂ =>
               match binary_op_eval h op d'₁ d'₂ with
               | None => TerminalError_debug (binop_err (pbinop op p₁ p₂) bind d d'₁ d'₂)  loc
               | Some x => Success_debug x
               end
             end
           end
         | pmap p₁ =>
           match d with
           | dcoll l => liftpr_debug dcoll (gather_successes_debug (map (camp_eval_debug (0::loc) p₁ bind) l))
           | _ => TerminalError_debug (pmap_err (pmap p₁) bind d) loc
           end
         | passert p₁ =>
           match camp_eval_debug (0::loc) p₁ bind d with
           | TerminalError_debug s loc' => TerminalError_debug s loc'
           | RecoverableError_debug s => RecoverableError_debug s
           | Success_debug d' =>
             match d' with
             | dbool true => Success_debug (drec nil)
             | dbool false => RecoverableError_debug "assertion failure"
             | _ => TerminalError_debug (passert_err (passert p₁) bind d d') loc
             end
           end
         | porElse p₁ p₂ =>
           match camp_eval_debug (0::loc) p₁ bind d with
           | TerminalError_debug s loc' => TerminalError_debug s loc'
           | RecoverableError_debug _ => camp_eval_debug (1::loc) p₂ bind d
           | Success_debug x => Success_debug x
           end
         | pit => Success_debug d
         | pletIt p₁ p₂ =>
           match camp_eval_debug (0::loc) p₁ bind d with
           | TerminalError_debug s loc' => TerminalError_debug s loc'
           | RecoverableError_debug s => RecoverableError_debug s
           | Success_debug x => camp_eval_debug (1::loc) p₂ bind x
           end
         | pgetConstant s =>
           match edot constant_env s with
           | Some x => Success_debug x
           | None => TerminalError_debug (pgetConstant_err s bind d) loc
           end
         | penv => Success_debug (drec bind)
         | pletEnv p₁ p₂ =>
           match camp_eval_debug (0::loc) p₁ bind d with
           | TerminalError_debug s loc' => TerminalError_debug s loc'
           | RecoverableError_debug s => RecoverableError_debug s
           | Success_debug rd'₁ =>
             match rd'₁ with
             | drec d'₁ => match merge_bindings bind d'₁ with
                           | Some bind' => camp_eval_debug (1::loc) p₂ bind' d
                           | None => RecoverableError_debug "bindings could not be unfied"
                           end
             | _ => TerminalError_debug (pletEnv_err (pletEnv p₁ p₂) bind d rd'₁) loc
             end
           end
         | pleft =>
           match d with
           | dleft d' => Success_debug d'
           | dright _ => RecoverableError_debug "pleft called on a pright"
           | _ => TerminalError_debug (pleft_err bind d) loc
           end
         | pright =>
           match d with
           | dright d' => Success_debug d'
           | dleft _ => RecoverableError_debug "pright called on a pleft"
           | _ => TerminalError_debug (pright_err bind d) loc
           end
         end.

    (** The following theorem states that traced evaluation is equivalent to regular evaluation. *)

    Theorem camp_eval_debug_correct (loc:camp_src_path) (p:camp) (bind:bindings) (d:data) :
      presult_same
        (camp_eval h constant_env p bind d)
        (camp_eval_debug loc p bind d).
    Proof.
      revert loc bind d.
      camp_cases (induction p) Case; simpl; intros.
      - trivial.
      - apply bindpr_presult_same; [eauto | ]; intros.
        destruct (unary_op_eval h u x); simpl; trivial.
      - apply bindpr_presult_same; [eauto | ]; intros.
        apply bindpr_presult_same; [eauto | ]; intros.
        destruct (binary_op_eval h b x x0); simpl; trivial.
      - destruct d; simpl; trivial.
        apply liftpr_presult_same.
        apply gather_successes_presult_same.
        rewrite <- Forall2_map.
        apply Forall2_refl; red; intros.
        apply IHp.
      - apply bindpr_presult_same; [eauto | ]; intros.
        destruct x; simpl; trivial.
        destruct b; simpl; trivial.
      - specialize (IHp1 (0::loc) bind d); red in IHp1.
        repeat match_destr_in IHp1; try tauto.
      - trivial.
      - apply bindpr_presult_same; [eauto | ]; intros.
        eauto.
      - unfold op2tpr. match_destr; simpl; trivial.
      - trivial.
      - apply bindpr_presult_same; [eauto | ]; intros.
        destruct x; simpl; trivial.
        destruct (merge_bindings bind l); simpl; trivial.
      - destruct d; simpl; trivial.
      - destruct d; simpl; trivial.
    Qed.

  End EvaluationDebug.

  (** * Toplevel *)

  (** Top-level evaluation functions are used externally by the Q*cert
  compiler. They take a CAMP pattern and a global environment as
  input. The initial local environment is set to an empty record, and
  the initial current value to unit. *)

  (** The result of evaluation is lifted back from presult to and
  optional value for consistency with evaluation functions for the
  other intermediate languages. *)

  Section Top.
    Context (h:brand_relation_t).

    Definition presult_to_result (pr:presult data) : option data :=
      match pr with
      | Success l => Some (dcoll (l::nil))
      | RecoverableError => Some (dcoll nil)
      | TerminalError => None
      end.

    Definition camp_eval_top_to_presult (q:camp) (global_env:bindings) : presult data :=
      camp_eval h (rec_sort global_env) q nil dunit.

    (** The main top-level evaluation function for CAMP is as follows. *)

    Definition camp_eval_top (q:camp) (global_env:bindings) : option data :=
      presult_to_result (camp_eval_top_to_presult q global_env).

    Definition presult_to_result_debug (pr:presult_debug data) : option data :=
      match pr with
      | Success_debug l => Some (dcoll (l::nil))
      | RecoverableError_debug _ => Some (dcoll nil)
      | TerminalError_debug _ _ => None
      end.

    Definition pr2op_debug (pr:presult_debug data) : option data :=
      match pr with
      | Success_debug l => Some (dsome l)
      | RecoverableError_debug _ => Some dnone
      | TerminalError_debug _ _ => None
      end.

    Definition camp_eval_top_debug_to_presult_debug
               (debug:bool) (q:camp) (global_env:bindings) : presult_debug data :=
      camp_eval_debug h (rec_sort global_env) debug nil q nil dunit.

    Theorem camp_eval_top_debug_correct (debug:bool) (p:camp) (global_env:bindings) (d:data) :
      presult_same
        (camp_eval_top_to_presult p global_env)
        (camp_eval_top_debug_to_presult_debug debug p global_env).
    Proof.
      unfold camp_eval_top_to_presult.
      unfold camp_eval_top_debug_to_presult_debug.
      apply camp_eval_debug_correct.
    Qed.

    Definition camp_eval_top_debug_to_data
               (debug:bool) (q:camp) (global_env:bindings) : option data :=
      presult_to_result_debug (camp_eval_debug h (rec_sort global_env) debug nil q nil dunit).

    (** The main top-level traced evaluation function for CAMP is as follows. *)

    Definition camp_eval_top_debug (debug:bool) (q:camp) (global_env:bindings) : string :=
      print_presult_debug q toString_camp_with_path
                          (camp_eval_top_debug_to_presult_debug debug q global_env).
  End Top.

End CAMP.

(* begin hide *)
Tactic Notation "camp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "pconst"%string
  | Case_aux c "punop"%string
  | Case_aux c "pbinop"%string
  | Case_aux c "pmap"%string
  | Case_aux c "passert"%string
  | Case_aux c "porElse"%string
  | Case_aux c "pit"%string
  | Case_aux c "pletIt"%string
  | Case_aux c "pgetConstant"%string
  | Case_aux c "penv"%string
  | Case_aux c "pletEnv"%string
  | Case_aux c "pleft"%string
  | Case_aux c "pright"%string].
(* end hide *)


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.SpecLemmas.
Require Import VerdiRaft.RefinementSpecLemmas.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.TermSanityInterface.
Require Import VerdiRaft.LogAllEntriesInterface.

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

  Context {rri : raft_refinement_interface}.
  Context {tsi : term_sanity_interface}.

  Ltac rewrite_goal :=
    match goal with
      | H: _ = _ |- _ => rewrite H
    end.

  Definition no_entries_past_current_term_host_lifted net :=
    forall (h : name) e,
      In e (log (snd (nwState net h))) ->
      eTerm e <= currentTerm (snd (nwState net h)).

  Lemma no_entries_past_current_term_host_lifted_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      no_entries_past_current_term_host_lifted net.
  Proof using tsi rri.
    unfold no_entries_past_current_term_host_lifted.
    pose proof deghost_spec.
    do 4 intro.
    repeat find_reverse_higher_order_rewrite.
    eapply lift_prop; eauto.
    intros.
    find_apply_lem_hyp no_entries_past_current_term_invariant; eauto.
  Qed.

  Lemma handleAppendEntries_currentTerm_monotonic:
    forall h st (d : raft_data)
      (m : msg) (t : term) (n : name) (pli : logIndex)
      (plt : term) (es : list entry) (ci : logIndex),
      handleAppendEntries h st t n pli plt es
                          ci = (d, m) ->
      currentTerm st <= currentTerm d.
  Proof using.
    intros.
    unfold handleAppendEntries in *.
    repeat break_match; simpl in *; do_bool; repeat find_inversion; auto; try lia;
    simpl in *;
    unfold advanceCurrentTerm in *; repeat break_match; do_bool; auto.
  Qed.

  Lemma log_all_entries_append_entries :
    refined_raft_net_invariant_append_entries log_all_entries.
  Proof using tsi rri.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp handleAppendEntries_currentTerm_monotonic.
    find_eapply_lem_hyp update_elections_data_appendEntries_log_allEntries;
      intuition; eauto; repeat find_rewrite; repeat rewrite_goal; eauto.
    - copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
      find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
      repeat find_rewrite. eauto using Nat.le_antisymm.
    - subst.
      apply in_app_iff. right.
      find_apply_hyp_hyp.
      find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
      eauto using Nat.le_antisymm.
    - subst.
      apply in_app_iff.
      left.
      apply in_map_iff. eauto.
    - do_in_app. intuition.
      + subst.
        apply in_app_iff.
        left.
        apply in_map_iff. eauto.
      + subst.
        apply in_app_iff. right.
        find_apply_lem_hyp removeAfterIndex_in.
        find_apply_hyp_hyp.
        find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
        eauto using Nat.le_antisymm.
  Qed.

  Lemma log_all_entries_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply log_all_entries.
  Proof using tsi rri.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp handleAppendEntriesReply_log. find_rewrite.
    find_copy_apply_lem_hyp handleAppendEntriesReply_type_term.
    intuition; repeat find_rewrite; copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
    find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
    repeat find_rewrite. eauto using Nat.le_antisymm.
  Qed.

  Lemma log_all_entries_request_vote :
    refined_raft_net_invariant_request_vote log_all_entries.
  Proof using tsi rri.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp handleRequestVote_log. find_rewrite.
    find_copy_apply_lem_hyp handleRequestVote_type_term.
    rewrite update_elections_data_requestVote_allEntries.
    intuition; repeat find_rewrite; copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
    find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
    repeat find_rewrite. eauto using Nat.le_antisymm.
  Qed.

  Lemma log_all_entries_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply log_all_entries.
  Proof using tsi rri.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_erewrite_lem handleRequestVoteReply_log.
    rewrite update_elections_data_requestVoteReply_allEntries.
    match goal with
      | |- context [handleRequestVoteReply ?h ?st ?h' ?t ?v] =>
        pose proof handleRequestVoteReply_type h st h' t v
             (handleRequestVoteReply h st h' t v)
    end.
    intuition; repeat find_rewrite;
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
    find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
    repeat find_rewrite.
    unfold raft_data in *. simpl in *.
    unfold raft_data in *. simpl in *.
    lia.
  Qed.

  Lemma log_all_entries_do_leader :
    refined_raft_net_invariant_do_leader log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp doLeader_type; intuition.
    find_apply_lem_hyp doLeader_log. repeat find_rewrite.
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
  Qed.

  Lemma log_all_entries_do_generic_server :
    refined_raft_net_invariant_do_generic_server log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp doGenericServer_type; intuition.
    find_apply_lem_hyp doGenericServer_log. repeat find_rewrite.
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
  Qed.

  Lemma log_all_entries_client_request :
    refined_raft_net_invariant_client_request log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp update_elections_data_client_request_log_allEntries.
    find_apply_lem_hyp handleClientRequest_type.
    intuition; repeat find_rewrite;
    [copy_eapply_prop_hyp In In; repeat find_rewrite; auto|].
    break_exists. intuition.
    repeat find_rewrite.  simpl in *. intuition; subst; auto.
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
  Qed.

  Lemma log_all_entries_timeout :
    refined_raft_net_invariant_timeout log_all_entries.
  Proof using tsi rri.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp handleTimeout_log_same.
    rewrite update_elections_data_timeout_allEntries.
    find_apply_lem_hyp handleTimeout_type_strong.
    intuition; repeat find_rewrite;
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
    find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
    repeat find_rewrite.
    unfold raft_data in *. simpl in *.
    unfold raft_data in *. simpl in *.
    lia.
  Qed.

  Lemma log_all_entries_reboot :
    refined_raft_net_invariant_reboot log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
  Qed.

  Lemma log_all_entries_init :
    refined_raft_net_invariant_init log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    simpl in *. intuition.
  Qed.

  Lemma log_all_entries_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    simpl in *.
    repeat find_reverse_higher_order_rewrite.
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
  Qed.

  Theorem log_all_entries_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      log_all_entries net.
  Proof using tsi rri.
    intros. apply refined_raft_net_invariant; auto.
    - apply log_all_entries_init.
    - apply log_all_entries_client_request.
    - apply log_all_entries_timeout.
    - apply log_all_entries_append_entries.
    - apply log_all_entries_append_entries_reply.
    - apply log_all_entries_request_vote.
    - apply log_all_entries_request_vote_reply.
    - apply log_all_entries_do_leader.
    - apply log_all_entries_do_generic_server.
    - apply log_all_entries_state_same_packet_subset.
    - apply log_all_entries_reboot.
  Qed.

  Instance laei : log_all_entries_interface.
  split.
  auto using log_all_entries_invariant.
  Qed.
End LogAllEntries.


Require Import String.
Require Import NPeano.
Require Import PeanoNat.
Require Import Coq.Strings.Ascii.
Require FMapWeakList.
Require Export Coq.Structures.OrderedTypeEx.
Require Import Lists.List.
Import ListNotations.
Require Import JaSyntax.
Require Import JaTypes.
Require Import JaProgram.
Require Import JaEnvs.
Require Import Jafun.
Require Import JaIrisCommon.
Require Import JaEval.
Require Import JaSubtype.
Require Import Bool.

Require Export FMapAVL.
Require Export Coq.Structures.OrderedTypeEx.
Require Import FMapFacts.

Module StrMap := JaIrisCommon.StrMap.
Module HeapFacts := Facts Heap.

(* Heaps *)
Definition JFIObjFieldEq (objLoc : Loc) (fieldName : string) (loc : Loc) (h : Heap) : Prop :=
  match objLoc with
    | null => False
    | JFLoc n =>
        match (Heap.find n h) with
          | None => False
          | Some obj =>
              match obj with
                | (rawObj, className) =>
                  match (JFXIdMap.find fieldName rawObj) with
                    | Some val => val = loc
                    | None => False
                  end
              end
        end
   end.

Definition JFIRawObjEq (obj1 : RawObj) (obj2 : RawObj) : Prop :=
  forall id, match (JFXIdMap.find id obj1, JFXIdMap.find id obj2) with
    | (Some l1, Some l2) => l1 = l2
    | (None, None) => True
    | _ => False
  end.

Definition JFIObjEq (obj1 : Obj) (obj2 : Obj) : Prop :=
  match (obj1, obj2) with
    | ((rawObj1, className1), (rawObj2, className2)) => className1 = className2 /\ JFIRawObjEq rawObj1 rawObj2
  end.

Definition JFIGetLocType (n : nat) (h : Heap) : option JFClassName :=
  match (Heap.find n h) with
    | None => None
    | Some (_, objClass) => Some objClass
  end.

Definition JFIValToLoc (val : JFIVal) (env : JFITermEnv) (this : nat) : option Loc :=
  match val with
  | JFINull => Some null
  | JFIThis => Some (JFLoc this)
  | JFIVar x => StrMap.find x env
  end.

(* Semantics *)

Fixpoint JFIHeapSatisfiesInEnv (h : Heap) (t : JFITerm) (env : JFITermEnv) (this : nat) (CC : JFProgram) : Prop :=
  match t with
    | JFITrue => True
    | JFIFalse => False
    | JFIAnd t1 t2 => JFIHeapSatisfiesInEnv h t1 env this CC /\ JFIHeapSatisfiesInEnv h t2 env this CC
    | JFIOr t1 t2 => JFIHeapSatisfiesInEnv h t1 env this CC \/ JFIHeapSatisfiesInEnv h t2 env this CC
    | JFIImplies t1 t2 => ~(JFIHeapSatisfiesInEnv h t1 env this CC) \/ JFIHeapSatisfiesInEnv h t2 env this CC
    | JFIHoare t1 e ex valueName t2 => JFIHeapSatisfiesInEnv h t1 env this CC -> exists confs hn res_ex res,
        let newEnv := StrMap.add valueName res env
        in (JFIEvalInEnv h e confs hn res_ex res env this CC) /\
           (res_ex = ex /\ JFIHeapSatisfiesInEnv hn t2 newEnv this CC)
    | JFIEq val1 val2 =>
        let l1 := JFIValToLoc val1 env this
        in let l2 := JFIValToLoc val2 env this
        in match (l1, l2) with
           | (Some loc1, Some loc2) => loc1 = loc2
           | _ => False
        end
    | JFIFieldEq obj fieldName val =>
        let l1 := JFIValToLoc obj env this
        in let l2 := JFIValToLoc val env this
        in match (l1, l2) with
          | (Some objLoc, Some valLoc) => JFIObjFieldEq objLoc fieldName valLoc h
          | _ => False
        end
    | JFISep t1 t2 => exists (h1 h2 : Heap), (* TODO free vars in t_n map to h_n *)
        (HeapConsistent h1 /\ HeapConsistent h2) /\
        (JFIHeapsUnion h1 h2 h /\ JFIHeapsDisjoint h1 h2) /\
        (JFIHeapSatisfiesInEnv h1 t1 env this CC /\ JFIHeapSatisfiesInEnv h2 t2 env this CC)
    | JFIWand t1 t2 => forall h',
        HeapConsistent h' ->
        JFIHeapsDisjoint h h' ->
        JFIHeapSatisfiesInEnv h' t1 env this CC ->
        (exists h_h', JFIHeapsUnion h h' h_h' /\ JFIHeapSatisfiesInEnv h_h' t2 env this CC)
  end.

Fixpoint JFIHeapSatisfiesOuterInEnv (h : Heap) (t : JFIOuterTerm) (env : JFITermEnv) (this : nat) (CC : JFProgram) : Prop :=
  match t with
  | JFIOuterAnd t1 t2 => JFIHeapSatisfiesOuterInEnv h t1 env this CC /\ JFIHeapSatisfiesOuterInEnv h t2 env this CC
  | JFIOuterOr t1 t2 => JFIHeapSatisfiesOuterInEnv h t1 env this CC \/ JFIHeapSatisfiesOuterInEnv h t2 env this CC
  | JFIExists class name term => exists l : Loc,
      let env1 := StrMap.add name l env
      in JFILocOfType l h class /\ JFIHeapSatisfiesOuterInEnv h term env1 this CC
  | JFIInner t => JFIHeapSatisfiesInEnv h t env this CC
  end.

Definition JFIGammaMatchEnv (h : Heap) (gamma : JFITypeEnv) (env : JFITermEnv) :=
  forall var_name,
    (StrMap.In var_name gamma <-> StrMap.In var_name env) /\
    (forall var_loc var_type,
      (StrMap.MapsTo var_name var_type gamma) ->
      (StrMap.MapsTo var_name var_loc env) ->
       JFILocOfType var_loc h var_type).

Definition JFIHeapSatisfies (h : Heap) (t : JFITerm) (gamma : JFITypeEnv) (CC : JFProgram) : Prop :=
  forall env this, JFIGammaMatchEnv h gamma env -> JFIHeapSatisfiesInEnv h t env this CC.

(* Persistence *)

Fixpoint JFITermPersistent (t : JFITerm) : Prop :=
  match t with
  | JFITrue => True
  | JFIFalse => True
  | JFIAnd t1 t2 => JFITermPersistent t1 /\ JFITermPersistent t2
  | JFIOr t1 t2 => JFITermPersistent t1 /\ JFITermPersistent t2
  | JFIImplies t1 t2 => JFITermPersistent t1 /\ JFITermPersistent t2
  | JFIHoare t1 e ex valueName t2 => JFITermPersistent t1 /\ JFITermPersistent t2
  | JFIEq val1 val2 => True
  | JFIFieldEq obj fieldName val => False
  | JFISep t1 t2 => False
  | JFIWand t1 t2 => False
  end.

Fixpoint JFIOuterTermPersistent (t : JFIOuterTerm) : Prop :=
  match t with
  | JFIOuterAnd t1 t2 => JFIOuterTermPersistent t1 /\ JFIOuterTermPersistent t2
  | JFIOuterOr t1 t2 => JFIOuterTermPersistent t1 /\ JFIOuterTermPersistent t2
  | JFIExists class name term => JFIOuterTermPersistent term
  | JFIInner t => JFITermPersistent t
  end.

(* Program structure for proofs *)

Inductive JFIInvariantType : Type :=
| JFIInvariant (cn : string) (mn : string) (precondition : JFITerm) (ex : JFEvMode) (var : string) (postcondition : JFITerm).

Inductive JFIDeclsType : Type :=
| JFIDecls (prog : JFProgram) (invariants : list JFIInvariantType) (class : JFClassDeclaration) (method : JFMethodDeclaration).

Definition JFIDeclsProg (decls : JFIDeclsType) : JFProgram :=
  match decls with JFIDecls prog _ _ _ => prog end.
Definition JFIDeclsInvariants (decls : JFIDeclsType) : list JFIInvariantType :=
  match decls with JFIDecls _ invariants _ _ => invariants end.
Definition JFIDeclsCDecl (decls : JFIDeclsType) : JFClassDeclaration :=
  match decls with JFIDecls _ _ class _ => class end.
Definition JFIDeclsMD (decls : JFIDeclsType) : JFMethodDeclaration :=
  match decls with JFIDecls _ _ _ method => method end.

(* Types *)

Definition JFITypes : JFIDeclsType -> JFExEnv -> JFEnv -> JFExpr -> JFCId -> Prop :=
  fun decls exEnv env expr cid =>
    types (JFIDeclsProg decls) (JFIDeclsCDecl decls) (JFIDeclsMD decls) exEnv env expr (cid, JFrwr).

Definition JFIValType (decls : JFIDeclsType) (gamma : JFITypeEnv) (ref : JFIVal) : option JFClassName :=
  match ref with
  | JFIVar v => StrMap.find v gamma
  | JFIThis => Some (name_of_cd (JFIDeclsCDecl decls))
  | JFINull => None
  end.

(* TODO do wywalenia *)
Definition JFIGammaAdd (x : string) (type : JFClassName) (gamma : JFITypeEnv) : JFITypeEnv :=
  StrMap.add x type gamma.

Definition JFIGammaAddNew (x : string) (type : JFClassName) (gamma : JFITypeEnv) : option JFITypeEnv :=
  if StrMap.mem x gamma then None else Some (StrMap.add x type gamma).

Definition JFIEnvAddNew (x : string) (l : Loc) (env : JFITermEnv) : option JFITermEnv :=
  if StrMap.mem x env then None else Some (StrMap.add x l env).

Definition JFIVarFreshInVal (x : string) (v : JFIVal) :=
  match v with
  | JFIVar y => x <> y
  | _ => True
  end.

Fixpoint JFIVarFreshInExpr (x : string) (e : JFExpr) := (* TODO pewnie wywalic *)
  match e with
    | JFNew mu C vs => True
    | JFLet C x e1 e2 => True
    | JFIf v1 v2 e1 e2 => True
    | JFInvoke v1 m vs => True
    | JFAssign (v1,fld) v2 => True
    | JFVal1 v1 => True
    | JFVal2 (v1, fld) => True
    | JFThrow v1 => True
    | JFTry e1 mu C x e2 => True
  end.

Fixpoint JFIVarFreshInTerm (x : string) (t : JFITerm) :=
  match t with
  | JFITrue => True
  | JFIFalse => True
  | JFIAnd t1 t2 => JFIVarFreshInTerm x t1 /\ JFIVarFreshInTerm x t2
  | JFIOr t1 t2 => JFIVarFreshInTerm x t1 /\ JFIVarFreshInTerm x t2
  | JFIImplies t1 t2 => JFIVarFreshInTerm x t1 /\ JFIVarFreshInTerm x t2
  | JFIHoare t1 e ex name t2 => (* TODO maybe allow x = name *)
      if String.eqb name x then False else
        (JFIVarFreshInTerm x t1 /\ JFIVarFreshInTerm x t2 /\ JFIVarFreshInExpr x e)
  | JFIEq val1 val2 => JFIVarFreshInVal x val1 /\ JFIVarFreshInVal x val2
  | JFIFieldEq obj fieldName val => JFIVarFreshInVal x obj /\ JFIVarFreshInVal x val
  | JFISep t1 t2 => JFIVarFreshInTerm x t1 /\ JFIVarFreshInTerm x t2
  | JFIWand t1 t2 => JFIVarFreshInTerm x t1 /\ JFIVarFreshInTerm x t2
  end.

Fixpoint JFIVarFreshInOuterTerm (x : string) (t : JFIOuterTerm) :=
  match t with
  | JFIOuterAnd t1 t2 => JFIVarFreshInOuterTerm x t1 /\ JFIVarFreshInOuterTerm x t2
  | JFIOuterOr t1 t2 => JFIVarFreshInOuterTerm x t1 /\ JFIVarFreshInOuterTerm x t2
  | JFIExists class name term => (* TODO maybe allow x = name *)
      if String.eqb name x then False else JFIVarFreshInOuterTerm x term
  | JFIInner t => JFIVarFreshInTerm x t
  end.

Definition JFIValFreshInTerm (v : JFIVal) (t : JFITerm) :=
  match v with
  | JFIVar x => JFIVarFreshInTerm x t
  | JFIThis => True
  | JFINull => True
  end.

Inductive JFIProves : JFIDeclsType -> JFITypeEnv -> JFITerm -> JFITerm -> Prop :=

(* Rules for intuitionistic logic with equality *)

| JFIAsmRule :
    forall decls gamma p,
      (FreeVarsInTermAreInGamma p gamma) ->
      (*-----------------*)
      JFIProves decls gamma p p

| JFITransRule :
    forall q decls gamma p r,
      (JFIProves decls gamma p q) ->
      (JFIProves decls gamma q r) ->
      (*----------------*)
      JFIProves decls gamma p r

| JFIEqReflRule :
    forall decls gamma p v,
      (FreeVarsInTermAreInGamma p gamma) ->
      (FreeVarsInValAreInGamma v gamma) ->
      (*----------------------------------*)
      JFIProves decls gamma p (JFIEq v v)

| JFIEqSymRule :
    forall decls gamma v1 v2 p,
      (JFIProves decls gamma p (JFIEq v1 v2)) ->
      (*-----------------------------------*)
      JFIProves decls gamma p (JFIEq v2 v1)

| JFIFalseElimRule :
    forall decls gamma p q,
      (FreeVarsInTermAreInGamma q gamma) ->
      (JFIProves decls gamma p JFIFalse) ->
      (*-----------------*)
      JFIProves decls gamma p q

| JFITrueIntroRule :
    forall decls gamma p,
      (FreeVarsInTermAreInGamma p gamma) ->
      (*----------------------*)
      JFIProves decls gamma p JFITrue

| JFIAndIntroRule :
    forall decls gamma p q r,
      (JFIProves decls gamma r p) ->
      (JFIProves decls gamma r q) ->
      (*----------------------------*)
      JFIProves decls gamma r (JFIAnd p q)

| JFIAndElimLRule :
    forall q decls gamma p r,
      (JFIProves decls gamma r (JFIAnd p q)) ->
      (*----------------*)
      JFIProves decls gamma r p

| JFIAndElimRRule :
    forall p decls gamma q r,
      (JFIProves decls gamma r (JFIAnd p q)) ->
      (*-----------------*)
      JFIProves decls gamma r q

| JFIOrIntroLRule :
    forall decls gamma p q r,
      (FreeVarsInTermAreInGamma q gamma) ->
      (JFIProves decls gamma r p) ->
      (*--------------------------*)
      JFIProves decls gamma r (JFIOr p q)

| JFIOrIntroRRule :
    forall decls gamma p q r,
      (FreeVarsInTermAreInGamma p gamma) ->
      (JFIProves decls gamma r q) ->
      (*--------------------------*)
      JFIProves decls gamma r (JFIOr p q)

| JFIOrElimRule :
    forall decls gamma p q r s,
      (JFIProves decls gamma s (JFIOr p q)) ->
      (JFIProves decls gamma (JFIAnd s p) r) ->
      (JFIProves decls gamma (JFIAnd s q) r) ->
      (*-----------------*)
      JFIProves decls gamma s r

| JFIImpliesIntroRule :
    forall decls gamma p q r,
      (JFIProves decls gamma (JFIAnd r p) q) ->
      (*--------------------------------------*)
      JFIProves decls gamma r (JFIImplies p q)

| JFIImpliesElimRule:
    forall p decls gamma q r,
      (JFIProves decls gamma r (JFIImplies p q)) ->
      (JFIProves decls gamma r p) ->
      (*-----------------------*)
      JFIProves decls gamma r q

(* Rules for separation logic *)

| JFIWeakRule :
    forall decls gamma p1 p2,
      (FreeVarsInTermAreInGamma p1 gamma) ->
      (FreeVarsInTermAreInGamma p2 gamma) ->
      (*------------------------------------*)
      JFIProves decls gamma (JFISep p1 p2) p1

| JFISepAssoc1Rule :
    forall decls gamma p1 p2 p3,
      (FreeVarsInTermAreInGamma p1 gamma) ->
      (FreeVarsInTermAreInGamma p2 gamma) ->
      (FreeVarsInTermAreInGamma p3 gamma) ->
      (*------------------------------------------------------------------*)
      JFIProves decls gamma (JFISep p1 (JFISep p2 p3)) (JFISep (JFISep p1 p2) p3)

| JFISepAssoc2Rule :
    forall decls gamma p1 p2 p3,
      (FreeVarsInTermAreInGamma p1 gamma) ->
      (FreeVarsInTermAreInGamma p2 gamma) ->
      (FreeVarsInTermAreInGamma p3 gamma) ->
      (*------------------------------------------------------------------*)
      JFIProves decls gamma (JFISep (JFISep p1 p2) p3) (JFISep p1 (JFISep p2 p3))

| JFISepSymRule :
    forall decls gamma p1 p2,
      (FreeVarsInTermAreInGamma p1 gamma) ->
      (FreeVarsInTermAreInGamma p2 gamma) ->
      (*-----------------------------------------*)
      JFIProves decls gamma (JFISep p1 p2) (JFISep p2 p1)

| JFISepIntroRule :
    forall decls gamma p1 p2 q1 q2,
      (JFIProves decls gamma p1 q1) ->
      (JFIProves decls gamma p2 q2) ->
      (*------------------------------------------*)
      JFIProves decls gamma (JFISep p1 p2) (JFISep q1 q2)

| JFISepIntroPersistentRule :
    forall decls gamma p q,
      (FreeVarsInTermAreInGamma p gamma) ->
      (FreeVarsInTermAreInGamma q gamma) ->
      (JFITermPersistent p) ->
      (*---------------------------------------------*)
      JFIProves decls gamma (JFIAnd p q) (JFISep p q)

| JFIWandIntroRule :
    forall decls gamma p q r,
      (JFIProves decls gamma (JFISep r p) q) ->
      (*----------------------------*)
      JFIProves decls gamma r (JFIWand p q)

| JFIWandElimRule :
    forall decls gamma p q r1 r2,
      (JFIProves decls gamma r1 (JFIWand p q)) ->
      (JFIProves decls gamma r2 p) ->
      (*------------------------------*)
      JFIProves decls gamma (JFISep r1 r2) q

(* Structural rules for Hoare triples *)

| JFIHTFrameRule :
    forall decls gamma p q r s e ex v,
      (JFITermPersistent s) ->
      (JFIVarFreshInTerm v r) ->
      (JFIProves decls gamma s (JFIHoare p e ex v q)) ->
      (*-------------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare (JFISep p r) e ex v (JFISep q r))

| JFIHTRetRule :
    forall decls gamma s v w w_expr,
      FreeVarsInValAreInGamma w gamma ->
      w_expr = JFIValToJFVal w ->
      (*--------------------------------------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare JFITrue (JFVal1 w_expr) None v (JFIEq (JFIVar v) w))

| JFIHTCsqRule:
    forall p' q' cn decls gamma s p q ex v e,
      (JFITermPersistent s) ->
      (JFIVarFreshInTerm v s) ->
      (JFIProves decls gamma s (JFIImplies p p')) ->
      (JFIProves decls gamma s (JFIHoare p' e ex v q')) ->
      (JFIProves decls (JFIGammaAdd v cn gamma) s (JFIImplies q' q)) ->
      (*------------------------------*)
      JFIProves decls gamma s (JFIHoare p e ex v q)

| JFIHTDisjIntroRule :
    forall decls gamma s p q r e ex v,
      (JFIProves decls gamma s (JFIHoare p e ex v r)) ->
      (JFIProves decls gamma s (JFIHoare q e ex v r)) ->
      (*--------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare (JFIOr p q) e ex v r)

(* TODO remove both and replace with persistent *)

| JFIHTEqRule1 :
    forall decls gamma s v1 v2 p e ex v q,
      (JFIProves decls gamma (JFIAnd s (JFIEq v1 v2)) (JFIHoare p e ex v q)) ->
      (*----------------------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare (JFIAnd p (JFIEq v1 v2)) e ex v q)

| JFIHTEqRule2 :
    forall decls gamma s v1 v2 p e ex v q,
      (JFIProves decls gamma s (JFIHoare (JFIAnd p (JFIEq v1 v2)) e ex v q)) ->
      (*----------------------------------------------------------------*)
      JFIProves decls gamma (JFIAnd s (JFIEq v1 v2)) (JFIHoare p e ex v q)

(* Rules for basic constructs of Jafun *)

| JFIHTNewNotNullRule :
    forall decls gamma s p mu cn vs v,
      JFIProves decls gamma s (JFIHoare p (JFNew mu cn vs) None v (JFIImplies (JFIEq (JFIVar v) JFINull) JFIFalse))

| JFIHTNewFieldRule :
    forall decls gamma s p mu cn vs v objflds n field value,
      (FreeVarsInValAreInGamma value gamma) ->
      (flds (JFIDeclsProg decls) (JFClass cn) = Some objflds) ->
      (nth_error objflds n = Some field) ->
      (nth_error vs n = Some (JFIValToJFVal value)) ->
      (value <> (JFIVar v)) ->
      (*----------------------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare p (JFNew mu cn vs) None v (JFIFieldEq (JFIVar v) field value))

| JFIHTLetRule :
    forall q decls gamma p r s e1 e2 x ex u class,
      (JFITermPersistent s) ->
      (JFIVarFreshInTerm x s) ->
      (JFIVarFreshInTerm x r) ->
      (JFIProves decls gamma s (JFIHoare p e1 None x q)) ->
      (JFIProves decls (JFIGammaAdd x class gamma) s (JFIHoare q e2 ex u r)) ->
      (*------------------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare p (JFLet class x e1 e2) ex u r )

| JFIHTLetExRule :
    forall q decls gamma p s e1 e2 x ex u class,
      (JFIProves decls gamma s (JFIHoare p e1 (Some ex) u q)) ->
      (*------------------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare p (JFLet class x e1 e2) (Some ex) u q )

| JFIHTFieldSetRule :
    forall decls gamma s x x_expr field u v v_expr,
      (FreeVarsInValAreInGamma x gamma) ->
      (FreeVarsInValAreInGamma v gamma) ->
      (x_expr = JFIValToJFVal x) ->
      (v_expr = JFIValToJFVal v) ->
      (x <> (JFIVar u)) ->
      (v <> (JFIVar u)) ->
      (*--------------------------------------------------*)
      JFIProves decls gamma s
        (JFIHoare
          (JFIImplies (JFIEq x JFINull) JFIFalse)
          (JFAssign (x_expr, field) v_expr)
           None u (JFIFieldEq x field v))

| JFIHTNullFieldSetRule :
    forall decls gamma s x x_expr field v loc,
      (x_expr = JFIValToJFVal x) ->
      (*--------------------------------------------------*)
      JFIProves decls gamma s
        (JFIHoare (JFIEq x JFINull)
          (JFAssign (x_expr, field) (JFVLoc loc))
           NPE_mode v JFITrue)

| JFIHTFieldGetRule :
    forall decls gamma s x x_expr field u v,
      (x_expr = JFIValToJFVal x) ->
      (x <> (JFIVar u)) ->
      (v <> (JFIVar u)) ->
      (*--------------------------------------------------*)
      JFIProves decls gamma s
        (JFIHoare
          (JFIFieldEq x field v)
          (JFVal2 (x_expr, field))
           None u (JFIEq (JFIVar u) v))

| JFIHTNullFieldGetRule :
    forall decls gamma s x x_expr field v,
      (x_expr = JFIValToJFVal x) ->
      (*--------------------------------------------------*)
      JFIProves decls gamma s
        (JFIHoare (JFIEq x JFINull)
          (JFVal2 (x_expr, field))
           NPE_mode v JFITrue)

| JFIHTIfRule :
    forall decls gamma p v1 v1_expr v2 v2_expr e1 e2 ex u q s,
      (FreeVarsInValAreInGamma v1 gamma) ->
      (FreeVarsInValAreInGamma v2 gamma) ->
      (v1_expr = JFIValToJFVal v1) -> (v2_expr = JFIValToJFVal v2) ->
      (JFIProves decls gamma s (JFIHoare (JFIAnd p (JFIEq v1 v2)) e1 ex u q)) ->
      (JFIProves decls gamma s (JFIHoare (JFIAnd p (JFIImplies (JFIEq v1 v2) JFIFalse)) e2 ex u q)) ->
      (*---------------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare p (JFIf v1_expr v2_expr e1 e2) ex u q)

| JFIHTInvokeRetRule :
    forall cn method rettypeCN ex w decls gamma s p q u v v_expr vs vs_expr mn,
      (FreeVarsInValAreInGamma v gamma) ->
      (v_expr = JFIValToJFVal v) -> (vs_expr = JFIValsToJFVals vs) ->
      (JFIValType decls gamma v = Some cn) ->
      (methodLookup (JFIDeclsProg decls) cn mn = Some method) ->
      (fst (rettyp_of_md method) = JFClass rettypeCN) ->
      (In (JFIInvariant cn mn p ex w q) (JFIDeclsInvariants decls)) ->
      (JFIProves decls gamma (JFIAnd s p) (JFIImplies (JFIEq v JFINull) JFIFalse)) ->
      (*--------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare p (JFInvoke v_expr mn vs_expr) ex u q)

| JFIHTNullInvokeRule :
    forall decls gamma s x x_expr mn vs v,
      (FreeVarsInValAreInGamma x gamma) ->
      (x_expr = JFIValToJFVal x) ->
      (*--------------------------------------------------*)
      JFIProves decls gamma s
        (JFIHoare (JFIEq x JFINull)
          (JFInvoke x_expr mn vs)
           NPE_mode v JFITrue)

| JFIHTThrowRule :
    forall decls gamma s cn x x_expr v,
      (FreeVarsInValAreInGamma x gamma) ->
      (x_expr = JFIValToJFVal x) ->
      (JFIValType decls gamma x = Some cn) ->
      (*--------------------------------------------------*)
      JFIProves decls gamma s
        (JFIHoare (JFIImplies (JFIEq x JFINull) JFIFalse)
           (JFThrow x_expr)
           (Some cn) v (JFIEq (JFIVar v) x))

| JFIHTNullThrowRule :
    forall decls gamma s x x_expr v,
      (FreeVarsInValAreInGamma x gamma) ->
      (x_expr = JFIValToJFVal x) ->
      (*--------------------------------------------------*)
      JFIProves decls gamma s
        (JFIHoare (JFIEq x JFINull)
           (JFThrow x_expr)
            NPE_mode v JFITrue)

| JFIHTCatchNormalRule :
    forall decls gamma s p e1 mu x e2 u q ex,
      (JFIProves decls gamma s (JFIHoare p e1 None u q)) ->
      (*------------------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare p (JFTry e1 mu ex x e2) None u q )

| JFIHTCatchExRule :
    forall decls gamma s p r e1 mu x e2 u q ex ex' ex'',
      (JFITermPersistent s) ->
      (JFIVarFreshInTerm x s) ->
      (JFIVarFreshInTerm x r) ->
      (JFIProves decls gamma s (JFIHoare p e1 (Some ex') x q)) ->
      (JFIProves decls (JFIGammaAdd x ex gamma) s (JFIHoare q e2 ex'' u r)) ->
      (Is_true (subtype_bool (JFIDeclsProg decls) (JFClass ex') (JFClass ex))) ->
      (*------------------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare p (JFTry e1 mu ex x e2) ex'' u r )

| JFIHTCatchPassExRule :
    forall decls gamma s p e1 mu x e2 u q ex ex',
      (JFIProves decls gamma s (JFIHoare p e1 (Some ex') u q)) ->
       ~Is_true (subtype_bool (JFIDeclsProg decls) (JFClass ex') (JFClass ex)) ->
      (*------------------------------------------------------------*)
      JFIProves decls gamma s (JFIHoare p (JFTry e1 mu ex x e2) (Some ex') u q )
.

Inductive JFIProvesOuter : JFIDeclsType -> JFITypeEnv -> JFIOuterTerm -> JFIOuterTerm -> Prop :=
| JFIExistsIntroRule :
    forall decls gamma p q x v type,
      (JFIValType decls gamma v = Some type) ->
      (JFIProvesOuter decls gamma q (JFIOuterTermSubstituteVal x v p)) ->
      (*-----------------------------------*)
      JFIProvesOuter decls gamma q (JFIExists type x p)

| JFIExistsElimRule :
    forall decls gamma p q r x type,
      (JFIVarFreshInOuterTerm x r) ->
      (JFIVarFreshInOuterTerm x q) ->
      (JFIProvesOuter decls gamma r (JFIExists type x p)) ->
      (JFIProvesOuter decls (JFIGammaAdd x type gamma) (JFIOuterAnd r p) q) ->
      (*----------------*)
      JFIProvesOuter decls gamma r q

| JFIOuterInnerRule :
    forall decls gamma p q,
      (JFIProves decls gamma p q) ->
      (JFIProvesOuter decls gamma (JFIInner p) (JFIInner q))

| JFIOuterAndIntroRule :
    forall decls gamma p q r,
      (JFIProvesOuter decls gamma r p) ->
      (JFIProvesOuter decls gamma r q) ->
      (*----------------------------*)
      JFIProvesOuter decls gamma r (JFIOuterAnd p q)

| JFIOuterAndElimLRule :
    forall q decls gamma p r,
      (JFIProvesOuter decls gamma r (JFIOuterAnd p q)) ->
      (*----------------*)
      JFIProvesOuter decls gamma r p

| JFIOuterAndElimRRule :
    forall p decls gamma q r,
      (JFIProvesOuter decls gamma r (JFIOuterAnd p q)) ->
      (*-----------------*)
      JFIProvesOuter decls gamma r q

| JFIOuterOrIntroLRule :
    forall decls gamma p q r,
      (JFIProvesOuter decls gamma r p) ->
      (*--------------------------*)
      JFIProvesOuter decls gamma r (JFIOuterOr p q)

| JFIOuterOrIntroRRule :
    forall decls gamma p q r,
      (JFIProvesOuter decls gamma r q) ->
      (*--------------------------*)
      JFIProvesOuter decls gamma r (JFIOuterOr p q)

| JFIOuterOrElimRule :
    forall decls gamma p q r s,
      (JFIProvesOuter decls gamma s (JFIOuterOr p q)) ->
      (JFIProvesOuter decls gamma (JFIOuterAnd s p) r) ->
      (JFIProvesOuter decls gamma (JFIOuterAnd s q) r) ->
      (*-----------------*)
      JFIProvesOuter decls gamma s r
.


(** * Undecidability of the subtyping problem of System FsubD *)

Require Import Undecidability.Synthetic.Undecidability.

Require Import FsubF_undec FsubD.
Require Import Reductions.FsubF_to_FsubD.

Lemma FsubD_SUBTYPE_undec : undecidable FsubD_SUBTYPE.
Proof.
  apply (undecidability_from_reducibility FsubF_SUBTYPE_undec).
  exact FsubF_to_FsubD.reduction.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.CorrectnessBaseTypes.
Require Import Fiat.Common.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.ContextFreeGrammar.Valid.
Require Import Fiat.Parsers.ContextFreeGrammar.ValidReflective.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Fiat.Parsers.MinimalParseOfParse.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section recursive_descent_parser.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
          {G : pregrammar' Char}.

  Context (Hvalid : is_true (grammar_rvalid G)).

  Let predata := @rdp_list_predata _ G.
  Local Existing Instance predata.

  Let rdata' : @parser_removal_dataT' _ G predata := rdp_list_rdata'.
  Local Existing Instance rdata'.

  Context {splitdata : @split_dataT Char _ _}.
  Let data : boolean_parser_dataT :=
    {| split_data := splitdata |}.
  Context {splitdata_correct : @boolean_parser_completeness_dataT' _ _ _ G data}.

  Local Instance optsplitdata : @split_dataT Char _ _
    := { split_string_for_production p_idx str offset len
         := match to_production p_idx with
              | nil => 0::nil
              | _::nil => len::nil
              | it::_
                => match it with
                     | Terminal _ => 1::nil
                     | _ => @split_string_for_production _ _ _ splitdata p_idx str offset len
                   end
            end }.
  Let optdata : boolean_parser_dataT :=
    {| split_data := optsplitdata |}.

  Local Arguments minus !_ !_.
  Local Arguments min !_ !_.

  Local Instance optsplitdata_correct : @boolean_parser_completeness_dataT' _ _ _ G optdata
    := { split_string_for_production_complete := _ }.
  Proof.
    pose proof (@split_string_for_production_complete _ _ _ _ _ splitdata_correct) as H.
    repeat (let x := fresh in intro x; specialize (H x)).
    revert H.
    apply ForallT_impl, ForallT_all; intro.
    apply Forall_tails_impl, Forall_tails_all; intros [|??];
    [ exact (fun x => x) | ].
    intro H;
      repeat (let x := fresh in intro x; specialize (H x));
      revert H.
    simpl in *.
    repeat match goal with
           | _ => assumption
           | [ |- ?R ?x ?x ] => reflexivity
           | [ H : S _ = 0 |- _ ] => clear -H; congruence
           | [ H : 0 = S _ |- _ ] => clear -H; congruence
           | [ H : nil = _::_ |- _ ] => clear -H; congruence
           | [ H : _::_ = nil |- _ ] => clear -H; congruence
           | [ H : _::_ = _::_ |- _ ] => inversion H; clear H
           | _ => progress subst
           | [ |- ?T -> ?T ] => exact (fun x => x)
           | [ |- context[match ?e with Terminal _ => _ | _ => _ end] ]
             => destruct e eqn:?
           | [ |- context[match ?e with nil => _ | _ => _ end] ]
             => destruct e eqn:?
           | _ => progress simpl
           | _ => rewrite Min.min_0_r
           | _ => intro
           | [ |- context[0 = min _ _] ] => exists 0
           | [ |- ?x = ?x ] => reflexivity
           | [ |- _ \/ False ] => left
           | _ => progress destruct_head @sigT
           | _ => progress destruct_head @prod
           | [ H : MinimalParse.minimal_parse_of_item _ _ (take _ (substring _ 0 _)) (Terminal _) |- _ ]
             => exfalso; inversion H; clear H
           | [ H : is_true (take _ (substring _ 0 _) ~= [_]) |- _ ]
             => apply length_singleton in H
           | [ H : length (take _ (substring _ 0 _)) = S _ |- _ ]
             => rewrite take_length, substring_length, <- Nat.sub_min_distr_r, Nat.add_sub, !Min.min_0_r in H
           | [ H : MinimalParse.minimal_parse_of_production _ _ _ nil |- _ ] => inversion H; clear H
           | [ |- MinimalParse.minimal_parse_of_production _ _ _ nil ] => constructor
           | [ H : MinimalParse.minimal_parse_of_item _ _ _ (Terminal _) |- _ ]
             => inversion H; clear H
           | [ |- MinimalParse.minimal_parse_of_item _ _ _ (Terminal _) ]
             => econstructor; [ eassumption | ]
           | [ H : length (drop _ (substring _ _ _)) = 0 |- _ ] => rewrite drop_length, substring_length in H
           | [ |- length (drop _ (substring _ _ _)) = 0 ] => rewrite drop_length, substring_length
           | [ H : ?x = 0 \/ ?T |- _ ]
             => let H' := fresh in
                destruct (Compare_dec.zerop x) as [H'|H'];
                  [ clear H
                  | assert T by (clear -H H'; destruct H; try assumption; try omega); clear H ]
           | [ |- (_ * _)%type ] => split
           | [ |- { _ : nat & _ } ] => eexists; repeat split; [ left; reflexivity | .. ]
           | [ H : ?x + ?y <= _ |- context[(?y + ?x)%nat] ]
             => not constr_eq x y; rewrite (Plus.plus_comm y x)
           | [ H : ?x + ?y <= _, H' : context[(?y + ?x)%nat] |- _ ]
             => not constr_eq x y; rewrite (Plus.plus_comm y x) in H'
           | [ H : context[(?x + 1)%nat] |- _ ] => rewrite (Plus.plus_comm x 1) in H; simpl plus in H
           | [ H : context[min ?x ?y], H' : ?y <= ?x |- _ ] => rewrite (Min.min_r x y) in H by assumption
           | [ H' : ?y <= ?x |- context[min ?x ?y] ] => rewrite (Min.min_r x y) by assumption
           | [ H : _ - _ = 0 |- _ ] => apply Nat.sub_0_le in H
           | [ |- _ - _ = 0 ] => apply Nat.sub_0_le
           | [ H : _ |- _ ] => progress rewrite ?Nat.add_sub, ?Minus.minus_plus in H
           | _ => progress rewrite ?Nat.add_sub, ?Minus.minus_plus, ?Minus.minus_diag, ?Min.min_idempotent
           | [ |- is_true (is_char (take ?x (take ?x _)) _) ]
             => rewrite take_take
           | [ H : is_true (is_char (take ?n ?str) ?ch) |- is_true (is_char ?str ?ch) ]
             => rewrite (take_long str)
               in H
               by (rewrite substring_length, Plus.plus_comm, Min.min_r by assumption; omega)
           | [ H : is_true (is_char (take ?n ?str) ?ch) |- is_true (is_char (take 1 ?str) ?ch) ]
             => apply take_n_1_singleton in H
           | [ |- MinimalParse.minimal_parse_of_production _ _ _ (_::_) ]
             => eapply @MinimalParseOfParse.expand_minimal_parse_of_production_beq;
               [ try assumption.. | eassumption ]
           | [ |- MinimalParse.minimal_parse_of_item _ _ (take 0 _) _ ]
             => eapply @MinimalParseOfParse.expand_minimal_parse_of_item_beq;
               [ try assumption.. | eassumption ]
           | [ |- MinimalParse.minimal_parse_of_item _ _ _ _ ]
             => eapply @MinimalParseOfParse.expand_minimal_parse_of_item_beq;
               [ try assumption.. | eassumption ]
           | [ H : is_true (is_char (take ?x _) _) |- ?R (drop ?x _) (drop 1 _) ]
             => apply length_singleton in H; rewrite take_length, substring_length in H
           | [ H : min ?x ?y = 1
               |- ?R (drop ?x (substring _ ?y _)) (drop 1 (substring _ ?y _)) ]
             => revert H; apply Min.min_case_strong; intros; subst;
                try reflexivity;
                apply bool_eq_empty
           | [ |- context[S ?x - ?x] ]
             => rewrite <- Nat.add_1_r, Minus.minus_plus
           | [ |- context[take ?x (take 0 _)] ]
             => rewrite take_take
           | [ |- context[min _ ?x - ?x] ]
             => rewrite <- Nat.sub_min_distr_r
           | [ H : ?y <= ?x |- context[take ?x (substring ?z ?y ?str)] ]
             => rewrite (take_long (substring z y str))
               by (rewrite substring_length, Plus.plus_comm, Min.min_r by assumption; omega)
           | [ |- context[take ?x (substring ?z ?x ?str)] ]
             => rewrite (take_long (substring z x str))
               by (rewrite substring_length, Plus.plus_comm, Min.min_r by assumption; omega)
           end.
  Qed.
End recursive_descent_parser.


From Coq Require Import ssreflect.
From stdpp Require Import strings gmap list.
From melocoton Require Import named_props stdpp_extra.
From melocoton.mlanguage Require Import mlanguage.
From melocoton.language Require Import language weakestpre.
From melocoton.mlanguage Require Import weakestpre.
From melocoton.ml_lang Require Import lang lang_instantiation primitive_laws.
From melocoton.c_interface Require Import defs notation.
From melocoton.interop Require Import basics prims basics_resources state.

Global Notation MLval := ML_lang.val.
Global Notation Cval := C_intf.val.

Section ChiZetaConstruction.

Definition lookup_reversed `{Countable A} {B} (m : gmap A B) (b : B) :=
  { a | m !! a = Some b }.

Definition find_in_reverse `{Countable A} `{EqDecision B} (m : gmap A B) (b : B) :
  sum (lookup_reversed m b) (lookup_reversed m b → False).
Proof.
  pose (map_to_set (fun a b' => if decide (b' = b) then Some a else None) m : gset _) as Hset.
  epose (filter (fun k => is_Some k) Hset) as Hset2.
  destruct (elements Hset2) as [|[γ|] ?] eqn:Heq.
  - right. intros (a & Ha).
    apply elements_empty_inv in Heq. apply gset_leibniz in Heq.
    eapply filter_empty_not_elem_of_L.
    2: apply Heq. 1: apply _.
    2: eapply elem_of_map_to_set.
    2: exists a, b; split; done.
    rewrite decide_True; done. Unshelve. all: apply _.
  - left. exists γ.
    assert (Some γ ∈ Hset2) as Hin.
    1: eapply elem_of_elements; rewrite Heq; left.
    eapply elem_of_filter in Hin. destruct Hin as [_ Hin].
    eapply elem_of_map_to_set in Hin.
    destruct Hin as (i & b' & H1 & H2).
    destruct decide; congruence.
  - exfalso. assert (None ∈ Hset2) as Hin.
    + eapply elem_of_elements. rewrite Heq. left.
    + apply elem_of_filter in Hin. destruct Hin as [[? Hc]?]. congruence.
Qed.

Lemma ensure_in_χ_pub χ ℓ :
  lloc_map_inj χ →
  ∃ χ' γ,
    lloc_map_mono χ χ' ∧
    χ' !! γ = Some (LlocPublic ℓ) ∧
    (∀ γ' r, γ' ≠ γ → χ' !! γ' = r → χ !! γ' = r).
Proof.
  intros Hinj.
  destruct (find_in_reverse χ (LlocPublic ℓ)) as [[γ Hgam]|Hnot].
  1: exists χ, γ; done.
  eexists (<[fresh (dom χ) := LlocPublic ℓ]> χ), _.
  erewrite lookup_insert; split_and!. 2: done.
  2: intros γ' r Hne H1; by rewrite lookup_insert_ne in H1.
  split.
  1: eapply insert_subseteq, not_elem_of_dom, is_fresh.
  intros γ1 γ2 ℓ' [[? ?]|[? ?]]%lookup_insert_Some [[? ?]|[? ?]]%lookup_insert_Some; subst.
  1: done.
  3: by eapply Hinj.
  all: intros _; exfalso; apply Hnot; eexists; eauto.
Qed.

Lemma ensure_in_χ_foreign χ id :
  lloc_map_inj χ →
  ∃ χ' γ,
    lloc_map_mono χ χ' ∧
    χ' !! γ = Some (LlocForeign id) ∧
    (∀ γ' r, γ' ≠ γ → χ' !! γ' = r → χ !! γ' = r).
Proof.
  intros Hinj.
  destruct (find_in_reverse χ (LlocForeign id)) as [[γ Hgam]|Hnot].
  1: exists χ, γ; done.
  eexists (<[fresh (dom χ) := LlocForeign id]> χ), _.
  erewrite lookup_insert; split_and!. 2: done.
  2: intros γ' r Hne H1; by rewrite lookup_insert_ne in H1.
  split.
  1: eapply insert_subseteq, not_elem_of_dom, is_fresh.
  intros γ1 γ2 ℓ' [[? ?]|[? ?]]%lookup_insert_Some [[? ?]|[? ?]]%lookup_insert_Some; subst.
  1: done.
  3: by eapply Hinj.
  all: intros _; exfalso; apply Hnot; eexists; eauto.
Qed.

Definition extended_to (χold : lloc_map) (ζ : lstore) (χnew : lloc_map) :=
  lloc_map_mono χold χnew ∧ dom χold ## dom ζ ∧ is_private_blocks χnew ζ.

Lemma extended_to_inj χ1 ζ χ2 : extended_to χ1 ζ χ2 → lloc_map_inj χ2.
Proof.
  intros (H&_); apply H.
Qed.

Lemma extended_to_dom_subset χ1 ζ χ2 : extended_to χ1 ζ χ2 → dom ζ ⊆ dom χ2.
Proof.
  intros (H1&H2&H3).
  eapply elem_of_subseteq. intros γ Hx; eapply elem_of_dom_2. by apply H3.
Qed.

Definition allocate_in_χ_priv_strong (exclusion : gset lloc) (χold : lloc_map) v : lloc_map_inj χold → exists χnew γ, extended_to χold {[γ := v]} χnew ∧ γ ∉ exclusion.
Proof.
  intros Hinj.
  pose (fresh (dom χold ∪ exclusion)) as γ.
  pose (is_fresh (dom χold ∪ exclusion)) as Hγ.
  eexists (<[γ := LlocPrivate]> χold), γ.
  unfold extended_to; split_and!; first split.
  - eapply insert_subseteq, not_elem_of_dom. intros HH; eapply Hγ, elem_of_union_l, HH.
  - intros γ1 γ2 ℓ' [[? ?]|[? ?]]%lookup_insert_Some [[? ?]|[? ?]]%lookup_insert_Some; subst; try congruence.
    by eapply Hinj.
  - rewrite dom_singleton_L. eapply disjoint_singleton_r. intros HH; eapply Hγ, elem_of_union_l, HH.
  - intros x. rewrite dom_singleton_L. intros ->%elem_of_singleton.
    eapply lookup_insert.
  - intros HH; eapply Hγ, elem_of_union_r, HH.
Qed.

Definition allocate_in_χ_priv (χold : lloc_map) v : lloc_map_inj χold → exists χnew γ, extended_to χold {[γ := v]} χnew.
Proof.
  intros Hinj. destruct (allocate_in_χ_priv_strong ∅ χold v Hinj) as (χnew&γ&H&_).
  by do 2 eexists.
Qed.

Lemma disjoint_weaken T `{Countable T} (A1 A2 B1 B2 : gset T) : A1 ## B1 → A2 ⊆ A1 → B2 ⊆ B1 → A2 ## B2.
Proof.
  intros HD H1 H2.
  apply elem_of_disjoint.
  intros x HA HB.
  edestruct (@elem_of_disjoint) as [HL _]; eapply HL.
  - apply HD.
  - eapply elem_of_weaken; first apply HA. done.
  - eapply elem_of_weaken; first apply HB. done.
Qed.

Lemma extended_to_trans (χ1 χ2 χ3 : lloc_map) (ζ1 ζ2 : lstore) :
  extended_to χ1 ζ1 χ2 →
  extended_to χ2 ζ2 χ3 →
  extended_to χ1 (ζ1 ∪ ζ2) χ3 /\ ζ1 ##ₘ ζ2.
Proof.
  intros (HA1 & HA2 & HA3) (HB1 & HB2 & HB3). unfold extended_to; split_and!.
  - split; last apply HB1. etransitivity; first apply HA1; apply HB1.
  - erewrite dom_union_L. eapply disjoint_union_r. split; first done.
    eapply disjoint_weaken. 1: apply HB2. 2: done. apply subseteq_dom, HA1.
  - intros γ. rewrite dom_union_L. intros [H|H]%elem_of_union; last by apply HB3.
    eapply lookup_weaken; first by apply HA3.
    apply HB1.
  - eapply map_disjoint_dom. eapply disjoint_weaken. 1: apply HB2. 2: done.
    eapply extended_to_dom_subset; done.
Qed.

Lemma extended_to_trans_2 (χ1 χ2 χ3 : lloc_map) (ζ1 ζ2 : lstore) :
  extended_to χ1 ζ1 χ2 →
  extended_to χ2 ζ2 χ3 →
  extended_to χ1 (ζ2 ∪ ζ1) χ3 /\ ζ1 ##ₘ ζ2.
Proof.
  intros H1 H2.
  destruct (extended_to_trans χ1 χ2 χ3 ζ1 ζ2) as (H3&H4). 1-2: done.
  erewrite map_union_comm; done.
Qed.

Lemma extended_to_refl χ1 :
  lloc_map_inj χ1 →
  extended_to χ1 ∅ χ1.
Proof.
  by repeat split.
Qed.

Lemma extended_to_mono χ1 χ2 :
  lloc_map_mono χ1 χ2 →
  extended_to χ1 ∅ χ2.
Proof.
  intros (H1 & H2); by repeat split.
Qed.

Lemma is_val_extended_to_weaken χ1 χ2 ζ1 ζ2 v lv:
  is_val χ1 ζ1 v lv →
  extended_to χ1 ζ2 χ2 →
  is_val χ2 (ζ1 ∪ ζ2) v lv.
Proof.
  intros H1 (H21&H22&H23).
  eapply is_val_mono; last done.
  1: apply H21.
  apply map_union_subseteq_l.
Qed.

Lemma deserialize_ML_value χMLold v :
  lloc_map_inj χMLold
→ ∃ χC ζimm lv,
    extended_to χMLold ζimm χC
  ∧ is_val χC ζimm v lv.
Proof.
  induction v as [[x|bo| |ℓ|]| |v1 IHv1 v2 IHv2|v IHv|v IHv] in χMLold|-*; intros Hinj.
  1-3: eexists χMLold, ∅, _; split_and!; [by eapply extended_to_refl | econstructor ].
  - destruct (ensure_in_χ_pub χMLold ℓ) as (χ' & γ & Hχ' & Hγ & _); first done.
    exists χ', ∅, (Lloc γ); (split_and!; last by econstructor).
    by eapply extended_to_mono.
  - destruct (ensure_in_χ_foreign χMLold id) as (χ' & γ & Hχ' & Hid & _); first done.
    exists χ', ∅, (Lloc γ); split_and!; last by econstructor.
    by eapply extended_to_mono.
  - destruct (allocate_in_χ_priv χMLold (Bclosure f x e)) as (χ & γ & Hextend); first done.
    eexists _, _, (Lloc γ). split; eauto. econstructor. by simplify_map_eq.
  - destruct (IHv1 χMLold) as (χ1 & ζ1 & lv1 & Hext1 & Hlv1); first done.
    destruct (IHv2 χ1) as (χ2 & ζ2 & lv2 & Hext2 & Hlv2); first by eapply extended_to_inj.
    pose (Bvblock (Immut,(TagDefault,[lv1;lv2]))) as blk.
    edestruct (allocate_in_χ_priv χ2 blk) as (χ3 & γ & Hext3); first by eapply extended_to_inj.
    eassert (extended_to χMLold _ χ3).
    1: do 2 (eapply extended_to_trans; last done); done.
    do 3 eexists; split; first done.
    econstructor.
    + rewrite lookup_union_r; first by erewrite lookup_singleton.
      eapply map_disjoint_Some_r. 1: eapply extended_to_trans_2; first eapply extended_to_trans; done.
      apply lookup_singleton.
    + eapply is_val_extended_to_weaken; last done.
      eapply is_val_extended_to_weaken; done.
    + eapply is_val_extended_to_weaken; last done.
      eapply is_val_mono; last done; try done.
      eapply map_union_subseteq_r. eapply extended_to_trans; done.
  - destruct (IHv χMLold) as (χ1 & ζ1 & lv1 & Hext1 & Hlv1); first done.
    epose (Bvblock (Immut,(_,[lv1]))) as blk.
    edestruct (allocate_in_χ_priv χ1 blk) as (χ3 & γ & Hext3); first by eapply extended_to_inj.
    eassert (extended_to χMLold _ χ3).
    1: (eapply extended_to_trans; last done); done.
    do 3 eexists; split; first done.
    econstructor.
    + rewrite lookup_union_r; first by erewrite lookup_singleton.
      eapply map_disjoint_Some_r. 1: eapply extended_to_trans_2; done.
      apply lookup_singleton.
    + eapply is_val_extended_to_weaken; done.
  - destruct (IHv χMLold) as (χ1 & ζ1 & lv1 & Hext1 & Hlv1); first done.
    epose (Bvblock (Immut,(_,[lv1]))) as blk.
    edestruct (allocate_in_χ_priv χ1 blk) as (χ3 & γ & Hext3); first by eapply extended_to_inj.
    eassert (extended_to χMLold _ χ3).
    1: (eapply extended_to_trans; last done); done.
    do 3 eexists; split; first done.
    econstructor.
    + rewrite lookup_union_r; first by erewrite lookup_singleton.
      eapply map_disjoint_Some_r. 1: eapply extended_to_trans_2; done.
      apply lookup_singleton.
    + eapply is_val_extended_to_weaken; done.
Qed.

Lemma deserialize_ML_values χMLold vs :
  lloc_map_inj χMLold
→ ∃ χC ζimm lvs,
    extended_to χMLold ζimm χC
  ∧ Forall2 (is_val χC ζimm) vs lvs.
Proof.
  induction vs as [|v vs IH] in χMLold|-*; intros Hinj.
  - eexists χMLold, ∅, _; split_and!; [by eapply extended_to_refl | econstructor ].
  - destruct (deserialize_ML_value χMLold v Hinj) as (χ1 & ζ1 & lv & Hext1 & Hlv1).
    destruct (IH χ1) as (χ2 & ζ2 & lvs & Hext2 & Hlv2); first by eapply extended_to_inj.
    eassert (extended_to χMLold _ χ2) by by eapply extended_to_trans.
    eexists _, _, (lv::lvs). split_and!; first done.
    econstructor.
    + by eapply is_val_extended_to_weaken.
    + eapply Forall2_impl; first done.
      intros v' lv' H1. eapply is_val_mono; last done; try done.
      eapply map_union_subseteq_r, extended_to_trans; done.
Qed.

Lemma deserialize_ML_block χMLold vs :
  lloc_map_inj χMLold
→ ∃ χC ζimm blk,
    extended_to χMLold ζimm χC
  ∧ is_heap_elt χC ζimm vs blk.
Proof.
  intros H.
  destruct (deserialize_ML_values χMLold vs H) as (χC & ζimm & lvs & H1 & H2).
  by exists χC, ζimm, (Bvblock (Mut,(TagDefault,lvs))).
Qed.

Lemma is_store_blocks_mono_weaken χ1 χ2 ζ σ:
  is_store_blocks χ1 ζ σ →
  lloc_map_mono χ1 χ2 →
  is_store_blocks χ2 ζ σ.
Proof.
  intros (H1&H2) [Hsub H3]. split.
  - intros x Hx. destruct (H1 x Hx) as [y Hy]; exists y.
    eapply lookup_weaken; done.
  - intros γ; destruct (H2 γ) as [H2L H2R]; split.
    + intros H; destruct (H2L H) as (ℓ&Vs&HH1&HH2). do 2 eexists; repeat split; try done.
      eapply lookup_weaken; done.
    + intros (ℓ&Vs&HH1&HH2).
      apply H2R. do 2 eexists; repeat split; try done.
      destruct (H1 ℓ) as (γ2&Hγ2); first by eapply elem_of_dom_2.
      rewrite <- Hγ2.
      eapply lookup_weaken in Hγ2; last done.
      f_equiv. eapply H3; done.
Qed.

Lemma is_heap_elt_weaken χ ζ vs blk ζ' χ' :
  is_heap_elt χ ζ vs blk
→ χ ⊆ χ'
→ ζ ⊆ ζ'
→ is_heap_elt χ' ζ' vs blk.
Proof.
  intros H1 H2 H3.
  inversion H1; subst.
  econstructor. eapply Forall2_impl; first done.
  intros x y H4; eapply is_val_mono; last done. all:done.
Qed.

Lemma is_heap_elt_weaken_2 χ ζ vs blk ζ' χ' :
  is_heap_elt χ ζ vs blk
→ extended_to χ' ζ χ
→ dom ζ' ⊆ dom χ'
→ is_heap_elt χ (ζ' ∪ ζ) vs blk.
Proof.
  intros H1 H2 H3.
  eapply is_heap_elt_weaken. 1: done.
  1: done. eapply map_union_subseteq_r.
  eapply map_disjoint_dom. eapply disjoint_weaken.
  1: apply H2. 1-2:done.
Qed.

Lemma deserialize_ML_heap χMLold σ :
  lloc_map_inj χMLold
→ ∃ χC ζσ ζnewimm,
    extended_to χMLold ζnewimm χC
  ∧ is_store_blocks χC σ ζσ
  ∧ is_store χC (ζσ ∪ ζnewimm) σ.
Proof.
  revert χMLold.
  induction σ as [|ℓ [vv|] σ Hin IH] using map_ind; intros χMLold HχMLold .
  - exists χMLold, ∅, ∅; split_and!. 2: econstructor.
    + by eapply extended_to_refl.
    + intros γ; rewrite dom_empty_L; done.
    + split; rewrite dom_empty_L. 1: done.
      intros (ℓ & Vs & H1 & H2). exfalso. rewrite lookup_empty in H2. done.
    + intros ℓ Vs γ blk Hc. exfalso. rewrite lookup_empty in Hc. done.
  - destruct (IH χMLold) as (χ0 & ζσ & ζi0 & Hext & Hstbl & Hstore). 1: done.
    destruct (ensure_in_χ_pub χ0 ℓ) as (χ1 & γ & Hχ1 & Hγ & Hold); first by eapply extended_to_inj.
    apply extended_to_mono in Hχ1.
    destruct (deserialize_ML_block χ1 vv) as (χ2 & ζi2 & lvs & Hext2 & Helt); first by eapply extended_to_inj.
    edestruct (extended_to_trans) as (HextA&Hdisj1). 1: exact Hext. 1: eapply extended_to_trans; done.
    rewrite map_empty_union in Hdisj1.
    rewrite map_empty_union in HextA.
    assert (is_store_blocks χ2 (<[ℓ:=Some vv]> σ) (<[γ:=lvs]> ζσ)) as Hstore2.
    1: {eapply is_store_blocks_restore_loc.
        * eapply is_store_blocks_mono_weaken; first done. eapply extended_to_trans; done.
        * apply Hext2.
        * eapply lookup_weaken. 1: done. apply Hext2.
        * by right. }
    assert (dom (<[γ:=lvs]> ζσ ∪ ζi0) ⊆ dom χ1) as Hsub3.
    { rewrite dom_union_L. eapply union_subseteq. split.
      * rewrite dom_insert_L. apply union_subseteq. split.
        1: eapply singleton_subseteq_l; first by eapply elem_of_dom_2.
        eapply elem_of_subseteq; intros k Hk.
        destruct Hstbl as (HH1&HH2). apply HH2 in Hk. destruct Hk as (?&?&H1&H2).
        eapply elem_of_dom_2. eapply lookup_weaken; first apply H1.
        eapply Hχ1.
      * etransitivity; last eapply subseteq_dom, Hχ1.
        eapply extended_to_dom_subset; done. }
    eexists χ2, (<[γ := lvs]> ζσ), (ζi0 ∪ ζi2). split_and!. 1-2:done.
    intros ℓ' vs γ' blk H1 H2 H3.  destruct HextA as (HH1&HH2&HH3).
    apply lookup_union_Some in H3. 1: destruct H3 as [H3|H3].
    3: { eapply map_disjoint_dom; eapply elem_of_disjoint.
         intros x Hx1 Hx2; specialize (HH3 x Hx2). destruct Hstore2 as [HHL HHR].
         apply HHR in Hx1. destruct Hx1 as (l1 & Vs1 & ? & ?); congruence. }
    2: { rewrite HH3 in H2; last by eapply elem_of_dom_2. congruence. }
    apply lookup_insert_Some in H3. destruct H3 as [[? ?]|[Hne H3]].
    + subst. rewrite map_union_assoc.
      eapply lookup_weaken in Hγ. 2: eapply Hext2. rewrite Hγ in H2. injection H2; intros ->.
      rewrite lookup_insert in H1. injection H1; intros ->.
      by eapply is_heap_elt_weaken_2.
    + eapply lookup_insert_Some in H1. destruct H1 as [[-> H]|[Hne1 H1]].
      1: {exfalso. apply Hne. eapply HH1. 2,3: done. eapply lookup_weaken; first done. apply Hext2. }
      assert (χ0 !! γ' = Some (LlocPublic ℓ')) as H2'.
      1: {destruct Hstbl as [HHL HHR]. destruct (HHL ℓ') as (gg&Hgg); first by eapply elem_of_dom_2.
          rewrite <- Hgg; f_equal. eapply HH1. 1,3: done. eapply lookup_weaken; first done.
          etransitivity; last eapply Hext2; eapply Hχ1. }
      eapply is_heap_elt_weaken.
      1: eapply Hstore. 1: done. 3: etransitivity; first eapply Hχ1; last apply Hext2.
      2: erewrite lookup_union_l; first done. 1: done.
      1: eapply not_elem_of_dom; intros H; eapply Hext in H; congruence.
      etransitivity; first eapply map_union_mono_l.
      2: etransitivity; first eapply map_union_mono_r. 4: done.
      1: eapply map_union_subseteq_l.
      1: eapply is_store_blocks_is_private_blocks_disjoint; done.
      eapply insert_subseteq, not_elem_of_dom.
      intros H. destruct Hstbl as [HHL HHR]. eapply HHR in H.
      destruct H as (?&?&Heq1&HeqF). eapply lookup_weaken in Heq1; first erewrite Hγ in Heq1. 2: apply Hχ1.
      injection Heq1; intros ->; rewrite HeqF in Hin; congruence.
  - destruct (IH χMLold) as (χ0 & ζσ & ζi0 & Hext & Hstbl & Hstore). 1: done.
    destruct (ensure_in_χ_pub χ0 ℓ) as (χ1 & γ & Hχ1 & Hγ & Hold); first by eapply extended_to_inj.
    edestruct (extended_to_trans) as (HextA&Hdisj1); first exact Hext. 1: eapply extended_to_mono, Hχ1.
    exists χ1, ζσ, ζi0. split_and!. 2: destruct Hstbl as [HL HR]; split.
    + rewrite map_union_empty in HextA. done.
    + rewrite dom_insert_L. intros ℓ0 [->%elem_of_singleton|H]%elem_of_union.
      1: eexists; done.
      destruct (HL ℓ0 H) as (γ1&Hγ1). exists γ1; eapply lookup_weaken; first done.
      eapply Hχ1.
    + intros γ0; specialize (HR γ0) as (HRL&HRR). split.
      1: intros H; destruct (HRL H) as (ℓ0 & Vs & H3 & H5); do 2 eexists;
        split; first (eapply lookup_weaken; first done; eapply Hχ1);
        rewrite lookup_insert_ne; first done;
        intros ->; rewrite Hin in H5; congruence.
      intros (ℓ0&Vs&HH1&HH2).
      rewrite lookup_insert_Some in HH2; destruct HH2 as [[? ?]|[Hne HH2]].
      1: congruence.
      eapply HRR. eexists ℓ0, Vs. split; last done.
      eapply elem_of_dom_2 in HH2.
      destruct (HL ℓ0 HH2) as (γ1&Hγ1). rewrite <- Hγ1. f_equal.
      eapply Hχ1; try done. eapply lookup_weaken, Hχ1; done.
    + intros ℓ1 vs γ1 blk [[? ?]|[? H1]]%lookup_insert_Some H2 H3; try congruence.
      eapply is_heap_elt_weaken. 1: eapply Hstore; try done.
      3: done. 2: eapply Hχ1.
      destruct Hstbl as [HHL HHR].
      destruct (HHL ℓ1) as (k1&Hk1); first by eapply elem_of_dom_2.
      rewrite <- Hk1. f_equal. eapply Hχ1; try done. eapply lookup_weaken, Hχ1; done.
Qed.

Lemma deserialize_ML_heap_extra ζMLold χMLold σ :
  lloc_map_inj χMLold
→ dom ζMLold ⊆ dom χMLold
→ (map_Forall (fun _ ℓ => σ !! ℓ = Some None) (pub_locs_in_lstore χMLold ζMLold))
→ ∃ χC ζσ ζnewimm,
    extended_to χMLold ζnewimm χC
  ∧ is_store_blocks χC σ ζσ
  ∧ ζMLold ##ₘ (ζσ ∪ ζnewimm)
  ∧ is_store χC (ζMLold ∪ ζσ ∪ ζnewimm) σ.
Proof.
  intros H1 H2 H3.
  destruct (deserialize_ML_heap χMLold σ) as (χC&ζσ&ζi&HA1&HA2&HA3). 1: apply H1.
  assert (ζMLold ##ₘ ζσ ∪ ζi) as Hdisj.
  1: eapply map_disjoint_union_r; split; last (eapply map_disjoint_dom, disjoint_weaken; first apply HA1; done).
  1: { eapply map_disjoint_spec. intros γ b1 b2 HH1 HH2.
       destruct HA2 as [_ HA2R]. eapply elem_of_dom_2 in HH2. apply HA2R in HH2.
       destruct HH2 as (ℓ & Vs & HH7 & HH8).
       erewrite (map_Forall_lookup_1 _ _ _ _ H3) in HH8.
       2: { eapply elem_of_dom_2 in HH1. erewrite pub_locs_in_lstore_lookup; first done; first done.
            eapply elem_of_weaken in H2; last done.
            eapply elem_of_dom in H2; destruct H2 as [k Hk]. rewrite Hk.
            eapply lookup_weaken in Hk; first erewrite HH7 in Hk. 2: eapply HA1. done. }
       congruence. }
  do 3 eexists; split_and!; try done.
  - intros ℓ vs γ b He1 He2 He3.
    eapply is_heap_elt_weaken. 1: eapply HA3; try done. 2: done.
    + rewrite <- map_union_assoc in He3. eapply lookup_union_Some in He3; destruct He3; try done.
      destruct (HA2) as [HL HR]. destruct (HR γ) as [HRL HRR]. eapply elem_of_dom in HRR.
      2: do 2 eexists; done.
      destruct HRR as [vv Hvv].
      exfalso. erewrite map_disjoint_Some_r in H; try congruence. 1: done.
      erewrite lookup_union_Some_l; last done; first done.
    + erewrite <- map_union_assoc. eapply map_union_subseteq_r. done.
Qed.

End ChiZetaConstruction.

Section ThetaConstruction.

Lemma collect_dom_θ_vs (θdom : gset lloc) (vs : list lval) :
  exists θdom' : gset lloc,
    ∀ γ, Lloc γ ∈ vs ∨ γ ∈ θdom ↔ γ ∈ θdom'.
Proof.
  induction vs as [|[|ℓ] vs (θdom1 & IH)].
  - exists θdom. intros γ. split; last eauto. by intros [H%elem_of_nil|].
  - exists θdom1. intros γ. etransitivity; last by eapply IH.
    split; (intros [H|]; last by eauto); left.
    + apply elem_of_cons in H as [|]; done.
    + apply elem_of_cons; eauto.
  - exists (θdom1 ∪ {[ ℓ ]}). intros γ. split.
    + intros [[Hc|H]%elem_of_cons|?]; eapply elem_of_union.
      1: right; eapply elem_of_singleton; congruence.
      all: left; apply IH. 1: by left. by right.
    + intros [[H|H]%IH| ->%elem_of_singleton]%elem_of_union.
      1: left; by right. 1: by right.
      left; by left.
Qed.

Lemma collect_dom_θ_block (θdom : gset lloc) (blk : block) :
  exists θdom' : gset lloc,
    ∀ γ, lval_in_block blk (Lloc γ) ∨ γ ∈ θdom ↔ γ ∈ θdom'.
Proof.
  destruct blk as [[m [tg vs]]| |].
  { (* Bvblock *)
    destruct (collect_dom_θ_vs θdom vs) as (θdom' & H).
    exists θdom'. intros γ. split.
    - intros [HH|]; first inversion HH; subst; apply H; eauto.
    - intros [?|?]%H; eauto. left; by constructor. }
  { (* Bclosure *)
    exists θdom. intros γ. split; eauto. intros [H|]; auto.
    by inversion H. }
  { (* Bforeign *)
    exists θdom. intros γ. split; eauto. intros [H|]; auto.
    by inversion H. }
Qed.

Lemma collect_dom_θ_ζ_blocks (θdom : gset lloc) (ζ : lstore) :
  exists θdom' : gset lloc,
    forall γ, ((exists γ1 blk, ζ !! γ1 = Some blk ∧ lval_in_block blk (Lloc γ))
               ∨ γ ∈ θdom)
              ↔ γ ∈ θdom'.
Proof.
  induction ζ as [|k blk ζ Hne (θdom1 & Hdom1)] using map_ind.
  - exists θdom; split; auto. intros [(γ1&blk&H1&_)|]; auto.
    simplify_map_eq.
  - destruct (collect_dom_θ_block θdom1 blk) as (θdom2 & Hdom2).
    exists θdom2. intros γ; split.
    + intros [(γ1&blk'&[[-> ->]|[Hne2 Hin]]%lookup_insert_Some&H2)|Hold].
      { apply Hdom2; left; congruence. }
      { apply Hdom2. right. apply Hdom1. left. by do 2 eexists. }
      { apply Hdom2; right; apply Hdom1; right; done. }
    + intros [H|[(γ1&blk'&H1&H2)|H]%Hdom1]%Hdom2.
      1: left; do 2 eexists; split; first eapply lookup_insert; done.
      2: by right.
      left; do 2 eexists; split; last done; first rewrite lookup_insert_ne; first done.
      intros ->; rewrite Hne in H1; congruence.
Qed.

Lemma collect_dom_θ_ζ (θdom : gset lloc) (ζ : lstore) :
  exists θdom' : gset lloc,
    forall γ, (γ ∈ dom ζ ∨ (exists γ1 blk, ζ !! γ1 = Some blk ∧ lval_in_block blk (Lloc γ))
               ∨ γ ∈ θdom)
              ↔ γ ∈ θdom'.
Proof.
  destruct (collect_dom_θ_ζ_blocks θdom ζ) as (θdom1 & Hdom1).
  exists (dom ζ ∪ θdom1). intros γ; split.
  - (intros [H|H]; apply elem_of_union); first by left.
    right; apply Hdom1; done.
  - intros [H|H]%elem_of_union; first by left. right; by apply Hdom1.
Qed.

Lemma collect_dom_θ_roots (θdom : gset lloc) (roots : roots_map) : exists θdom' : gset lloc,
    forall γ, ((exists k, roots !! k = Some (Lloc γ)) ∨ γ ∈ θdom) ↔ γ ∈ θdom'.
Proof.
  induction roots as [|k [z|l] roots Hne (θdom1 & IH)] using map_ind.
  - exists θdom. intros γ. split; last eauto. intros [[? H%lookup_empty_Some]|?]; done.
  - exists θdom1. intros γ. split.
    + intros [[k1 [[-> ?]|[H1 H2]]%lookup_insert_Some]|?]; try congruence; apply IH. 2: by right. left. by eexists.
    + intros [[k' Hk]|H]%IH; last by right. left. exists k'. rewrite lookup_insert_ne; first done. intros ->; rewrite Hne in Hk; done.
  - exists (θdom1 ∪ {[ l ]}). intros γ. split.
    + intros [[k1 [[-> ?]|[H1 H2]]%lookup_insert_Some]|?]; try congruence; eapply elem_of_union. 1: right; eapply elem_of_singleton; congruence.
      all: left; apply IH. 2: by right. left; by eexists.
    + intros [[[k' Hk]|H]%IH| ->%elem_of_singleton]%elem_of_union. 2: by right. 2: left; exists k; by rewrite lookup_insert.
      left; exists k'; rewrite lookup_insert_ne; first done. intros ->; rewrite Hne in Hk; congruence.
Qed.

Lemma injectivify_map (S : gset lloc) : exists M : addr_map, dom M = S ∧ gmap_inj M.
Proof.
  induction S as [|s S Hne (M & <- & Hinj)] using set_ind_L.
  - exists ∅; split; first by rewrite dom_empty_L. intros ??? H1; exfalso. rewrite lookup_empty in H1; done.
  - exists (<[s := fresh (codom M)]> M). split.
    1: by rewrite dom_insert_L.
    apply gmap_inj_extend; try done.
    intros k' v' H%codom_spec_2 <-. unshelve eapply is_fresh; last exact H. all: apply _.
Qed.

End ThetaConstruction.

Lemma find_repr_lval_vv θ v :
   (forall γ, Lloc γ = v → γ ∈ dom θ)
 → exists l, repr_lval θ v l.
Proof.
  intros H. destruct v as [z|a].
  - eexists; by econstructor.
  - destruct (θ !! a) as [va|] eqn:Heq.
    2: eapply not_elem_of_dom in Heq; exfalso; apply Heq; apply H; done.
    eexists; econstructor; apply Heq.
Qed.

Lemma find_repr_lval_vs θ vs :
   (forall γ, Lloc γ ∈ vs → γ ∈ dom θ)
 → exists ls, Forall2 (repr_lval θ) vs ls.
Proof.
  intros H; induction vs as [|v vs IH] in H|-*.
  - exists nil. econstructor.
  - destruct IH as [ls IH]; first (intros γ Hγ; eapply H; right; done).
    destruct (find_repr_lval_vv θ v) as [l Hl].
    1: intros γ <-; apply H; by left.
    eexists. econstructor; done.
Qed.

Lemma find_repr_roots θ roots privmem :
   roots_are_live θ roots
 → dom privmem ## dom roots
 → exists mem, repr θ roots privmem mem.
Proof.
  revert privmem. unfold repr.
  induction roots as [|l a roots_m Hin IH] using map_ind; intros privmem Hlive Hdisj.
  - exists privmem, ∅. split_and!.
    + econstructor.
    + eapply map_disjoint_empty_r.
    + by rewrite map_empty_union.
  - destruct (IH privmem) as (mem1 & memr1 & Hrepr1 & Hdisj1 & Heq1).
    1: { intros a1 w1 H1; eapply Hlive; rewrite lookup_insert_ne; first done.
         intros ->; rewrite Hin in H1; congruence. }
    1: rewrite dom_insert_L in Hdisj; set_solver.
    destruct (find_repr_lval_vv θ a) as (w & Hw).
    1: intros γ <-; eapply Hlive; apply lookup_insert.
    exists (<[l:=Storing w]> mem1), (<[l:=Storing w]> memr1). split_and!.
    + econstructor. 1: done. 1:done. 2: erewrite <- repr_roots_dom; last apply Hrepr1. all: by eapply not_elem_of_dom.
    + apply map_disjoint_dom in Hdisj1. apply map_disjoint_dom.
      rewrite dom_insert_L. rewrite dom_insert_L in Hdisj. set_solver.
    + erewrite Heq1. now rewrite insert_union_l.
Qed.


Require Import Relations.
Require Import EquivDec.
Require Import Equality.
Require Import List.
Require Import Bool.
Require Import Lia.
Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import FMapPositive.
Require Import FSetPositive.
Require Import sflib.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.Order.
Require Import PromisingArch.lib.Time.
Require Import PromisingArch.lib.Lang.
Require Import PromisingArch.promising.TsoPromising.

Set Implicit Arguments.

Lemma rtc_state_step_state_exec
      m1 m2
      (WF: Machine.wf m1)
      (STEP: rtc (Machine.step ExecUnit.state_step) m1 m2):
  Machine.state_exec m1 m2.
Proof.
  revert WF. induction STEP.
  { econs; ss. ii. destruct (IdMap.find id (Machine.tpool x)); ss. econs. refl. }
  i. exploit Machine.step_state_step_wf; eauto. i.
  exploit IHSTEP; eauto. i. inv x0.
  destruct x as [tpool1 mem1].
  destruct y as [tpool2 mem2].
  inv H. inversion STEP0. inv STEP1. ss. subst. econs; ss.
  ii. specialize (TPOOL id). revert TPOOL.
  rewrite IdMap.add_spec. condtac; ss. i.
  inversion e0. inv TPOOL. rewrite FIND, <- H2. econs.
  econs; eauto.
Qed.

Lemma state_exec_rtc_state_step
      m1 m2
      (STEP: Machine.state_exec m1 m2):
  exists m2',
    <<EXEC: rtc (Machine.step ExecUnit.state_step) m1 m2'>> /\
    <<EQUIV: Machine.equiv m2 m2'>>.
Proof.
  inv STEP.
  assert (IN: forall tid sl1
                (FIND1: IdMap.find tid m1.(Machine.tpool) = Some sl1),
             exists sl2,
               IdMap.find tid m2.(Machine.tpool) = Some sl2 /\
               rtc (ExecUnit.state_step tid)
                   (ExecUnit.mk (fst sl1) (snd sl1) m1.(Machine.mem))
                   (ExecUnit.mk (fst sl2) (snd sl2) m1.(Machine.mem))).
  { i. specialize (TPOOL tid). rewrite FIND1 in TPOOL. inv TPOOL. esplits; ss. }
  assert (OUT: forall tid
                 (FIND1: IdMap.find tid m1.(Machine.tpool) = None),
             IdMap.find tid m1.(Machine.tpool) = IdMap.find tid m2.(Machine.tpool)).
  { i. specialize (TPOOL tid). rewrite FIND1 in TPOOL. inv TPOOL. ss. }
  assert (P: forall tid sl1
               (FIND1: IdMap.find tid m1.(Machine.tpool) = Some sl1),
             IdMap.find tid m1.(Machine.tpool) = Some sl1).
  { ss. }
  clear TPOOL.
  setoid_rewrite IdMap.elements_spec in IN at 1.
  setoid_rewrite IdMap.elements_spec in OUT at 1.
  setoid_rewrite IdMap.elements_spec in P at 1.
  generalize (IdMap.elements_3w m1.(Machine.tpool)). intro NODUP. revert NODUP.
  revert IN OUT P. generalize (IdMap.elements (m1.(Machine.tpool))). intro ps.
  revert m1 MEM. induction ps; ss.
  { i. esplits; eauto. econs; ss. ii. rewrite OUT; ss. }

  i. destruct a. inv NODUP.
  exploit (IN k).
  { destruct (equiv_dec k k); ss. congr. }
  exploit (P k).
  { destruct (equiv_dec k k); ss. congr. }
  i. des. destruct p. ss.

  cut (exists m2', rtc (Machine.step ExecUnit.state_step)
                 (Machine.mk (IdMap.add k (fst sl2, snd sl2) m1.(Machine.tpool)) m1.(Machine.mem))
                 m2' /\
             Machine.equiv m2 m2').
  { i. des. esplits; [|by eauto]. etrans; [|by eauto].
    eapply Machine.rtc_eu_step_step; [eauto|refl|eauto].
  }
  assert (TID: forall tid sl (FIND: SetoidList.findA (fun id' : IdMap.key => if equiv_dec tid id' then true else false) ps = Some sl), tid <> k).
  { ii. subst. apply H1. revert FIND. clear. induction ps; ss.
    destruct a. destruct (equiv_dec k k0); ss.
    - inv e. i. inv FIND. left. ss.
    - i. right. apply IHps. ss.
  }
  eapply IHps; ss.
  - i. eapply IN. destruct (equiv_dec tid k); ss.
    inv e. exfalso. eapply TID; eauto.
  - i. rewrite IdMap.add_spec. condtac.
    + inversion e. subst. rewrite x1. destruct sl2. ss.
    + eapply OUT. destruct (equiv_dec tid k); ss.
  - i. rewrite IdMap.add_spec. condtac.
    + inversion e. subst. exfalso. eapply TID; eauto.
    + eapply P. destruct (equiv_dec tid k); ss.
Qed.