From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
From extructures Require Import ord fmap.
From CoqUtils Require Import hseq word.
Require Import lib.utils common.types symbolic.symbolic.

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

Import DoNotation.

Section WithClasses.

Context {mt : machine_types}
        {ops : machine_ops mt}
        {sp : Symbolic.params}.

Variable table : Symbolic.syscall_table mt.

Import Symbolic.

Local Open Scope word_scope.
Local Notation "x .+1" := (x + 1).

Definition stepf (st : state mt) : option (state mt) :=
  let 'State mem reg pc@tpc extra := st in
  match mem pc with
  | Some iti =>
    let: i@ti := iti in
    do! instr <- decode_instr i;
    match instr with
    | Nop =>
      let mvec := IVec NOP tpc ti [hseq] in
      next_state_pc st mvec (pc.+1)
    | Const n r =>
      do! old <- reg r;
      let: _@told := old in
      let ivec := IVec CONST tpc ti [hseq told] in
      next_state_reg st ivec r (swcast n)
    | Mov r1 r2 =>
      do! a1 <- reg r1;
      let: w1@t1 := a1 in
      do! a2 <- reg r2;
      let: _@told := a2 in
      let mvec := IVec MOV tpc ti [hseq t1;told] in
      next_state_reg st mvec r2 w1
    | Binop op r1 r2 r3 =>
      do! a1 <- reg r1;
      let: w1@t1 := a1 in
      do! a2 <- reg r2;
      let: w2@t2 := a2 in
      do! a3 <- reg r3;
      let: _@told := a3 in
      let mvec := IVec (BINOP op) tpc ti [hseq t1;t2;told] in
      next_state_reg st mvec r3 (binop_denote op w1 w2)
    | Load r1 r2 =>
      do! a1 <- reg r1;
      let: w1@t1 := a1 in
      do! amem <- mem w1;
      let: w2@t2 := amem in
      do! a2 <- reg r2;
      let: _@told := a2 in
      let mvec := IVec LOAD tpc ti [hseq t1;t2;told] in
      next_state_reg st mvec r2 w2
    | Store r1 r2 =>
      do! a1 <- reg r1;
      let: w1@t1 := a1 in
      do! amem <- mem w1;
      let: _@told := amem in
      do! a2 <- reg r2;
      let: w2@t2 := a2 in
      let mvec := IVec STORE tpc ti [hseq t1;t2;told] in
      @next_state _ _ st mvec (fun ov =>
         do! mem' <- updm mem w1 w2@(tr ov);
         Some (State mem' reg (pc.+1)@(trpc ov) extra))
    | Jump r =>
      do! a <- reg r;
      let: w@t1 := a in
      let mvec := IVec JUMP tpc ti [hseq t1] in
      next_state_pc st mvec w
    | Bnz r n =>
      do! a <- reg r;
      let: w@t1 := a in
      let pc' := pc + (if w == 0
                       then 1 else swcast n) in
      let ivec := IVec BNZ tpc ti [hseq t1] in
      next_state_pc st ivec pc'
    | Jal r =>
      do! a <- reg r;
      let: w@t1 := a in
      do! oldtold <- reg ra;
      let: _@told := oldtold in
      let mvec := IVec JAL tpc ti [hseq t1; told] in
      next_state_reg_and_pc st mvec ra (pc.+1) w
    | JumpEpc | AddRule | GetTag _ _ | PutTag _ _ _ | Halt =>
      None
    end
  | None =>
    match mem pc with
    | None =>
      do! sc <- table pc;
      run_syscall sc st
    | Some _ =>
      None
    end
  end.

Lemma stepP :
  forall st st',
    stepf st = Some st' <->
    step table st st'.
Proof.
  intros st st'. split; intros STEP.
  { destruct st as [mem reg [pc tpc] int].
    move: STEP => /=; case GET: (mem pc) => [[i ti]|] //= STEP;
    apply obind_inv in STEP.
    - destruct STEP as (instr & INSTR & STEP).
      destruct instr; try discriminate;
          repeat match goal with
             | STEP : (do! x <- ?t; _) = Some _ |- _ =>
               destruct t eqn:?; simpl in STEP; try discriminate
             | x : atom _ _ |- _ =>
               destruct x; simpl in *
             | rv : ovec _ |- _ =>
               destruct rv; simpl in *
             | H : Some _ = Some _ |- _ =>
               inversion H; subst; clear H
           end;
      s_econstructor (solve [eauto]).

    - destruct STEP as (sc & GETCALL & STEP).
      s_econstructor (solve [eauto]).
  }
  { unfold stepf.
    inversion STEP; subst; rewrite PC; try (subst mv);
    simpl;
    repeat match goal with
             | [H: ?Expr = _ |- context[?Expr]] =>
               rewrite H; simpl
           end; by reflexivity.
  }
Qed.

Lemma stepP' :
  forall st st',
    reflect (step table st st') (stepf st == Some st').
Proof.
  move => st st'.
  apply (iffP eqP); by move => /stepP.
Qed.

Definition build_ivec st : option (ivec ttypes)  :=
  match mem st (pcv st) with
    | Some i =>
      match decode_instr (vala i) with
        | Some op =>
          let part := @IVec ttypes (opcode_of op) (pct st) (taga i) in
          match op return (hseq (tag_type ttypes) (inputs (opcode_of op)) ->
                           ivec ttypes) -> option (ivec ttypes) with
            | Nop => fun part => Some (part [hseq])
            | Const n r => fun part =>
                do! old <- regs st r;
                Some (part [hseq taga old])
            | Mov r1 r2 => fun part =>
              do! v1 <- regs st r1;
              do! v2 <- regs st r2;
              Some (part [hseq (taga v1); (taga v2)])
            | Binop _ r1 r2 r3 => fun part =>
              do! v1 <- regs st r1;
              do! v2 <- regs st r2;
              do! v3 <- regs st r3;
              Some (part [hseq (taga v1); (taga v2); (taga v3)])
            | Load  r1 r2 => fun part =>
              do! w1 <- regs st r1;
              do! w2 <- (mem st) (vala w1);
              do! old <- regs st r2;
              Some (part [hseq (taga w1); (taga w2); (taga old)])
            | Store  r1 r2 => fun part =>
              do! w1 <- regs st r1;
              do! w2 <- regs st r2;
              do! w3 <- mem st (vala w1);
              Some (part [hseq (taga w1); (taga w2); (taga w3)])
            | Jump  r => fun part =>
              do! w <- regs st r;
              Some (part [hseq taga w])
            | Bnz  r n => fun part =>
              do! w <- regs st r;
              Some (part [hseq taga w])
            | Jal  r => fun part =>
              do! w <- regs st r;
              do! old <- regs st ra;
              Some (part [hseq taga w; taga old])
            | JumpEpc => fun _ => None
            | AddRule => fun _ => None
            | GetTag _ _ => fun _ => None
            | PutTag _ _ _ => fun _ => None
            | Halt => fun _ => None
          end part
        | None => None
      end
    | None =>
      match table (pcv st) with
        | Some sc =>
          Some (IVec SERVICE (pct st) (entry_tag sc) [hseq])
        | None => None
      end
  end.

Lemma step_build_ivec st st' :
  step table st st' ->
  exists ivec ovec,
    build_ivec st = Some ivec /\
    transfer ivec = Some ovec.
Proof.
  move/stepP.
  rewrite {1}(state_eta st) /= /build_ivec.
  case: (getm _ _) => [[i ti]|] //=; last first.
    case: (getm _ _) => [sc|] //=.
    rewrite /run_syscall /=.
    case TRANS: (transfer _) => [ovec|] //= _.
    by eauto.
  case: (decode_instr i) => [instr|] //=.
  rewrite /next_state_pc /next_state_reg /next_state_reg_and_pc /next_state.
  by destruct instr; move=> STEP; match_inv; first [ eauto | discriminate ].
Qed.

End WithClasses.


From RecoveryRefinement Require Import Lib.

Require Export Examples.Logging.TxnDiskAPI.
Require Export Examples.Logging.LogEncoding.
Require Export Examples.ReplicatedDisk.OneDiskAPI.

From Array Require Import Array.

Import ProcNotations.
Local Open Scope proc.

(* We encode the log with two blocks: a header and a descriptor block. The header has a bit which commits the transaction: log_commit first records the transaction completes and then applies it, so that recovery (also log_apply) can see that the transaction is committed and finish applying it. *)

(* The logical log is either:
- a partial list of writes, or
- a committed list of writes.

The partial list of writes is represented by a committed flag of false followed
by [hdr.(log_length)] addresses from the descriptor block (the rest are ignored)
paired with the values in the log region of the disk. The length of the log is
restricted by LogHdr so that there are always enough addresses in the descriptor
block and spaces on disk for the values.

A committed transaction is represented almost the same way, except that the committed flag is set to true.

On crash committed will generally be false, so the logical log is empty and the
whole thing is aborted, reverting the disk to its old state. The one exception
is after writing the commit header but before finishing apply.
 *)

(* Once we have a data region + logical log, we map that to the TxnDiskAPI's two
disks by setting the old disk to the data region and the new disk to the data
region + writes from the logical log. *)

Axiom LogHdr_fmt: block_encoder LogHdr.
Axiom Descriptor_fmt: block_encoder Descriptor.

Definition read a := Call (D.op_read a).
Definition write a v := Call (D.op_write a v).
Definition size := Call (D.op_size).

Definition gethdr: proc D.Op LogHdr :=
  b <- read 0;
    Ret (LogHdr_fmt.(decode) b).

Definition writehdr (hdr:LogHdr) :=
  write 0 (LogHdr_fmt.(encode) hdr).

Definition hdr_full (hdr:LogHdr) :
  {hdr.(log_length) = LOG_LENGTH} + {hdr.(log_length) < LOG_LENGTH}.
  destruct (lt_dec (hdr.(log_length)) LOG_LENGTH).
  - right; auto.
  - pose proof (hdr.(log_length_ok)).
    left; lia.
Defined.

Definition hdr_inc (hdr:LogHdr) (pf:hdr.(log_length) < LOG_LENGTH) : LogHdr.
  refine {| committed := hdr.(committed);
            log_length := hdr.(log_length) + 1; |}.
  abstract lia.
Defined.

Definition empty_hdr : LogHdr.
  refine {| committed := false;
            log_length := 0; |}.
  abstract lia.
Defined.

Definition hdr_setcommit (hdr:LogHdr) : LogHdr :=
  {| committed := true;
     log_length := hdr.(log_length);
     log_length_ok := hdr.(log_length_ok); |}.

Definition getdesc: proc D.Op Descriptor :=
  b <- read 1;
    Ret (Descriptor_fmt.(decode) b).

Definition writedesc (ds:Descriptor) :=
  write 1 (Descriptor_fmt.(encode) ds).

Global Instance def_desc : Default Descriptor.
  refine {| addresses := List.repeat 0 LOG_LENGTH |}.
  apply repeat_length.
Defined.

Definition add_addr (ds:Descriptor) (idx:nat) (a:addr) : Descriptor.
  refine {| addresses := assign ds.(addresses) idx a; |}.
  rewrite length_assign.
  apply ds.(addresses_length).
Defined.

(* log init establishes that the log and descriptor are valid (note that the
block_encoder does not assume that every block is parseable, only the encodings)
and correspond to an empty log *)
Definition log_init :=
  sz <- size;
    if lt_dec sz (2+LOG_LENGTH) then
      Ret InitFailed
    else
      _ <- writehdr empty_hdr;
    _ <- writedesc default; (* value is unimportant, ignored due to log_length = 0 *)
    Ret Initialized.

Definition log_size :=
  sz <- size;
    (* this subtraction never underflows because of the size established by init
    (and the size is an invariant) *)
    Ret (sz-(2+LOG_LENGTH)).

(* manipulating the log region *)
Definition set_desc desc (i:nat) a v :=
  _ <- writedesc (add_addr desc i a);
    write (2+i) v.

Definition get_logwrite desc (i:nat) :=
    let a := sel desc.(addresses) i in
    v <- read (2+i);
      Ret (a, v).

(* manipulating the data region *)
Definition data_read a :=
  read (2+LOG_LENGTH+a).

Definition data_write a v :=
  write (2+LOG_LENGTH+a) v.

(* reads just go directly to the data region (transactions don't read their own
writes) *)
Definition log_read a :=
  data_read a.

Definition log_write a v :=
  (* I believe out-of-bounds reads at the logical level are always translated to
  out-of-bounds applies when we attempt to apply the log; this works but is
  complicated, since the write does actually take space in the physical log but
  won't do anything when applied. *)
  hdr <- gethdr;
    match hdr_full hdr with
    | left _ => Ret TxnD.WriteErr
    | right pf =>
      (* here we've established that the log has at least one position left *)
      desc <- getdesc;
        _ <- writehdr (hdr_inc hdr pf);
        (* a crash here doesn't matter because [committed = false] and therefore
        the entire log is logically empty *)
        _ <- set_desc desc hdr.(log_length) a v;
          (* now the partial transaction has one more write; the descriptor
          block has the correct address at the new index, and the corresponding
          value is in the log at the paired address *)
      Ret TxnD.WriteOK
    end.

(** log_apply (which is also the recovery procedure) *)

(* Crashes during log_apply will leave the physical disk in a partial state,
where some of the committed writes have been applied, but log_apply always
starts at the beginning. Its sub-procedures [apply_at] and [apply_upto] only run
when [committed := true] and always have i < hdr.(log_length). *)

(* apply_at guarantees that index i in the log is applied *)
Definition apply_at desc (i:nat) :=
  a_v <- get_logwrite desc i;
    let '(a, v) := a_v in
    _ <- data_write a v;
      Ret tt.

(* [apply_upto] applies entries i through (len-1) from the log; if it crashes, the
log is still partially applied (and it doesn't much matter how much, since
log_apply always applies from the beginning).

 [apply_upto] maintains an invariant in its recursive subcalls that [i <=
 len]. *)
Fixpoint apply_upto desc i len :=
  match len with
  | 0 => Ret tt
  | S len =>
    _ <- apply_at desc i;
      apply_upto desc (i+1) len
  end.

(* log_apply is just a wrapper around apply_upto that reads the metadata; note
that it establishes the invariants of [apply_upto] by checking for a commit.

Its postcondition/recovery postcondition says the log is now empty, because it
explicitly sets the header. Note that the descriptor block does not need to be
changed because it's ignored with a log length of 0. *)
Definition log_apply :=
  hdr <- gethdr;
    _ <- if hdr.(committed) then
          desc <- getdesc;
            apply_upto desc 0 hdr.(log_length)
        else Ret tt;
    writehdr empty_hdr.

Definition commit :=
  hdr <- gethdr;
    _ <- writehdr (hdr_setcommit hdr);
    (* here we can crash in a committed state, where we need to apply *)
    log_apply.

Definition recovery := log_apply.


From iris.program_logic Require Import adequacy.
From iris_time.heap_lang Require Import notation proofmode.
From iris_time Require Import Base Reduction Tactics.
From iris_time Require Export Translation.

Implicit Type e : expr.
Implicit Type v : val.
Implicit Type σ : state.
Implicit Type t : list expr.
Implicit Type K : ectx heap_ectx_lang.
Implicit Type ℓ : loc.
Implicit Type m n : nat.
Implicit Type φ : val → Prop.

(* Our definition of “tick” will depend on a location. This is made a typeclass
 * so as to be inferred automatically. *)
Class TickCounter := { tick_counter : loc }.
Notation "S« σ , n »" := (<[tick_counter := LitV (LitInt n%nat)]> (translationS σ%V)).
(* Notation "« σ , n »" := (<[ℓ := LitV (LitInt n%nat)]> (translationS σ%V)) (only printing). *)
Local Notation ℓ := tick_counter.

(* This whole file is parameterized by a “runtime_error” value: *)
Section Simulation.
Context (runtime_error : val).

(*
 * Definition of “tick”
 *)

Local Instance generic_tick {Hloc : TickCounter} : Tick :=
 (rec: "tick" "x" :=
    let: "k" := ! #ℓ in
    if: "k" ≤ #0 then
      runtime_error #()
    else if: CAS #ℓ "k" ("k" - #1) then
      "x"
    else
      "tick" "x")%V.

(*
 * Operational behavior of “tick”
 *)

Section Tick_exec.

  Context {Hloc : TickCounter}.

  Lemma exec_tick_success n v σ :
    prim_exec  (tick v) (<[ℓ := #(S n)]> σ)  v (<[ℓ := #n]> σ)  [].
  Proof.
    remember (Z.of_nat (S n)) as Sn.
    unlock tick generic_tick.
    eapply prim_exec_cons_nofork. (* Initial β-redex *)
    { by prim_step. }
    simpl. eapply prim_exec_cons_nofork. (* Load of ℓ *)
    { prim_step; apply lookup_insert. }
    simpl. eapply prim_exec_cons_nofork. (* First redex of let *)
    { by prim_step. }
    simpl. eapply prim_exec_cons_nofork. (* Second redex of let *)
    { by prim_step. }
    simpl. eapply prim_exec_cons_nofork. (* Comparison ["k" ≤ #0] *)
    { by prim_step. }
    rewrite /= bool_decide_false; [|lia].
    eapply prim_exec_cons_nofork.        (* If *)
    { by prim_step. }
    simpl. eapply prim_exec_cons_nofork. (* Decrementing "k" *)
    { by prim_step. }
                                         (* CAS *)
    simpl. eapply (prim_exec_cons_nofork _ _ _ (if: #true then _ else _)).
    { prim_step; [apply lookup_insert|by left]. }
    eapply prim_exec_cons_nofork.        (* If *)
    { by prim_step. }
    replace (Sn - 1) with (Z.of_nat n) by lia.
    rewrite insert_insert.
    apply prim_exec_nil.
  Qed.

  Lemma exec_tick_case_branch e1 v2 σ :
    prim_exec  (tick_case_branch (λ: <>, e1) v2)%E  σ ((tick e1) v2) σ  [].
  Proof.
    unfold tick_case_branch ; unlock.
    eapply prim_exec_cons_nofork.
    { by prim_step. }
    simpl. eapply prim_exec_cons_nofork.
    { by prim_step. }
    simpl. eapply prim_exec_cons_nofork.
    { by prim_step. }
    simpl. eapply prim_exec_cons_nofork.
    { by prim_step. }
    simpl. eapply prim_exec_cons_nofork.
    { by prim_step. }
    apply prim_exec_nil.
  Qed.

End Tick_exec.

(*
 * Simulation lemma
 *)

Section SimulationLemma.

  Context {Hloc : TickCounter}.

  Local Ltac exec_tick_success :=
    lazymatch goal with
    | |- prim_exec ?e _ _ _ _ =>
        reshape_expr false e ltac:(fun K e' =>
          eapply prim_exec_fill' with K e' _ ; [ done | done | ] ;
          eapply exec_tick_success
        )
    end ;
    done.
  (* in this tactic, the parameter ‘afterwards’ allows to unify the expression
   * resulting from the step before running the tactic ‘prim_step’;
   * this matters when the reduction rule to apply is directed by the syntax of
   * the result (more specifically, ‘CasFailS’ would be picked instead of
   * ‘CasSucS’ if we did not unify the result with ‘#true’ beforehand). *)
  Local Ltac tick_then_step_then afterwards :=
    eapply prim_exec_transitive_nofork ; first (
      exec_tick_success
    ) ;
    eapply prim_exec_cons_nofork, afterwards ; first (
      prim_step
    ).
  Local Ltac tick_then_step_then_stop :=
    tick_then_step_then prim_exec_nil.

  Lemma simulation_head_step_success n e1 σ1 κ e2 σ2 efs :
    σ2 !! ℓ = None →
    head_step e1 σ1 κ e2 σ2 efs →
    prim_exec «e1» S«σ1, S n» «e2» S«σ2, n» T«efs».
  Proof.
    intros Hℓ Hstep.
    destruct Hstep as
      [ (* RecS *) f x e σ
      | (* PairS *) v1 v2 σ
      | (* InjLS *) v σ
      | (* InjRS *) v σ
      | (* BetaS *) f x e1 v2 e' σ  ->
      | (* UnOpS *) op v v' σ  Hopeval
      | (* BinOpS *) op v1 v2 v' σ  Hopeval
      | (* IfTrueS  *) e1 e2 σ
      | (* IfFalseS *) e1 e2 σ
      | (* FstS *) v1 v2 σ
      | (* SndS *) v1 v2 σ
      | (* CaseLS *) v0 e1 e2 σ
      | (* CaseRS *) v0 e1 e2 σ
      | (* ForkS *) e σ
      | (* AllocS *) v σ l  Hfree_l
      | (* LoadS *) l v σ  Hbound_l
      | (* StoreS *) l v σ  Hisbound_l
      | (* CasFailS *) l v1 v2 vl σ  Hbound_l Hneq_vl_v1
      | (* CasSucS *) l v1 v2 σ  Hbound_l
      | (* FaaS *) l i1 i2 σ  Hbound_l
      ];
    simpl_trans;
    (try (
      assert (ℓ ≠ l) as I by (by apply lookup_insert_None in Hℓ as [ _ I ]) ;
      rewrite translationS_insert insert_commute ; last exact I
    )).
    (* RecS f x e σ : *)
    - eapply (prim_exec_cons _ _ _ _ _ [] _ _ []).
      + prim_step.
      + exec_tick_success.
    (* PairS *)
    - tick_then_step_then_stop.
    (* InjLS *)
    - tick_then_step_then_stop.
    (* InjRS *)
    - tick_then_step_then_stop.
    (* BetaS f x e1 v2 e' σ : *)
    - rewrite 2! translation_subst'.
      by tick_then_step_then_stop.
    (* UnOpS op v v' σ : *)
    - tick_then_step_then_stop.
      by apply un_op_eval_translation.
    (* BinOpS op v1 v2 v' σ : *)
    - tick_then_step_then_stop.
      by apply bin_op_eval_translation.
    (* IfTrueS e1 e2 σ : *)
    - tick_then_step_then_stop.
    (* IfFalseS e1 e2 σ : *)
    - tick_then_step_then_stop.
    (* FstS v1 v2 σ : *)
    - tick_then_step_then_stop.
    (* SndS v1 v2 σ : *)
    - tick_then_step_then_stop.
    (* CaseLS v0 e1 e2 σ : *)
    - tick_then_step_then exec_tick_case_branch.
    (* CaseRS v0 e1 e2 σ : *)
    - tick_then_step_then exec_tick_case_branch.
    (* ForkS e σ : *)
    - replace T« [e] » with ([« e »] ++ []) by apply app_nil_r.
      eapply prim_exec_cons.
      + prim_step.
      + exec_tick_success.
    (* AllocS v σ l : *)
    - tick_then_step_then_stop.
      apply lookup_insert_None ; auto using lookup_translationS_None.
    (* LoadS l v σ : *)
    - tick_then_step_then_stop.
      assert (ℓ ≠ l) as I by (intros <- ; rewrite -> Hℓ in * ; discriminate).
      rewrite lookup_insert_ne ; last exact I.
      by apply lookup_translationS_Some.
    (* StoreS l v σ : *)
    - tick_then_step_then_stop.
      rewrite lookup_insert_ne ; last exact I.
      by apply lookup_translationS_is_Some.
    (* CasFailS l v1 v2 vl σ : *)
    - tick_then_step_then_stop.
      + assert (ℓ ≠ l) as I by (intros <- ; rewrite -> Hℓ in * ; discriminate).
        rewrite lookup_insert_ne ; last done.
        by apply lookup_translationS_Some.
      + eauto using translationV_injective.
      + by apply vals_cas_compare_safe_translationV.
    (* CasSucS l v1 v2 σ : *)
    - tick_then_step_then_stop.
      + rewrite lookup_insert_ne ; last exact I.
        by apply lookup_translationS_Some.
      + by apply vals_cas_compare_safe_translationV.
    (* FaaS l i1 i2 σ : *)
    - tick_then_step_then_stop.
      rewrite lookup_insert_ne ; last exact I.
      change (#i1)%V with V« #i1 ».
      by apply lookup_translationS_Some.
  Qed.

  Lemma simulation_prim_step_success n e1 σ1 κ e2 σ2 efs :
    σ2 !! ℓ = None →
    prim_step e1 σ1 κ e2 σ2 efs →
    prim_exec «e1» S«σ1, S n» «e2» S«σ2, n» T«efs».
  Proof.
    intros Hℓ [ K e1' e2' -> -> H ].
    rewrite 2! translation_fill.
    by eapply prim_exec_fill, simulation_head_step_success.
  Qed.

  Lemma simulation_step_success n t1 σ1 κ t2 σ2 :
    σ2 !! ℓ = None →
    step (t1, σ1) κ (t2, σ2) →
    rtc erased_step (T«t1», S«σ1, S n») (T«t2», S«σ2, n»).
  Proof.
    intros Hℓ Hstep.
    destruct Hstep as [ e1 σ1_ e2 σ2_ efs t t' E1 E2 Hprimstep ] ;
    injection E1 as -> <- ;
    injection E2 as -> <-.
    repeat rewrite ? fmap_app ? fmap_cons.
    by eapply exec_frame_singleton_thread_pool, prim_exec_exec,
       simulation_prim_step_success.
  Qed.

  Lemma simulation_exec_success m n t1 σ1 t2 σ2 :
    σ2 !! ℓ = None →
    relations.nsteps erased_step m (t1, σ1) (t2, σ2) →
    rtc erased_step (T«t1», S«σ1, m+n») (T«t2», S«σ2, n»).
  Proof.
    make_eq (t1, σ1) as config1 E1.
    make_eq (t2, σ2) as config2 E2.
    intros Hℓ Hnsteps.
    revert t1 σ1 E1 ;
    induction Hnsteps as [ config | m' config1 (t3, σ3) config2 [κ Hstep] Hsteps IHnsteps ] ;
    intros t1 σ1 E1.
    - destruct E2 ; injection E1 as -> ->.
      apply rtc_refl.
    - destruct E2, E1.
      specialize (IHnsteps eq_refl t3 σ3 eq_refl).
      assert (σ3 !! ℓ = None) as Hℓ3 by (eapply loc_fresh_in_dom_nsteps ; cycle 1 ; eassumption).
      eapply rtc_transitive.
      + eapply simulation_step_success ; cycle -1 ; eassumption.
      + apply IHnsteps.
  Qed.

  Lemma simulation_exec_success' m n t1 σ1 t2 σ2 :
    σ2 !! ℓ = None →
    (m ≤ n)%nat →
    relations.nsteps erased_step m (t1, σ1) (t2, σ2) →
    rtc erased_step (T«t1», S«σ1, n») (T«t2», S«σ2, n-m»).
  Proof.
    intros Hℓ I.
    replace #n with #(m + (n-m))%nat ; last (repeat f_equal ; lia).
    by apply simulation_exec_success.
  Qed.

  (* from a reduction of the translated expression,
   * deduce a reduction of the source expression. *)

  (* note: this does not depend on the operational behavior of `tick`. *)

  Local Ltac exhibit_prim_step e2 :=
    eexists _, e2, _, _ ; simpl ; prim_step.

  Local Ltac eexhibit_prim_step :=
    eexists _, _, _, _ ; simpl ; prim_step.

  Lemma active_item_translation_reducible ki v σ m :
    ectx_item_is_active ki →
    loc_fresh_in_expr ℓ (fill_item ki v) →
    reducible (fill_item Ki«ki» V«v») S«σ, m» →
    reducible (fill_item ki v) σ.
  Proof.
    intros Hactive Hfresh (e2' & σ2' & efs &
                           [κ Hheadstep % active_item_prim_step_is_head_step]) ;
      last by apply is_active_translationKi.
    make_eq (fill_item Ki«ki» V«v») as e1' Ee1' ; rewrite Ee1' in Hheadstep.
    make_eq (S«σ, m») as σ1' Eσ1' ; rewrite Eσ1' in Hheadstep.
    destruct Hheadstep  as
      [ (* RecS *) f x e σ1
      | (* PairS *) v1 v2 σ1
      | (* InjLS *) v1 σ1
      | (* InjRS *) v1 σ1
      | (* BetaS *) f x e1 v2 e' σ1  ->
      | (* UnOpS *) op v1 v' σ1  Hopeval
      | (* BinOpS *) op v1 v2 v' σ1  Hopeval
      | (* IfTrueS  *) e1 e2 σ1
      | (* IfFalseS *) e1 e2 σ1
      | (* FstS *) v1 v2 σ1
      | (* SndS *) v1 v2 σ1
      | (* CaseLS *) v0 e1 e2 σ1
      | (* CaseRS *) v0 e1 e2 σ1
      | (* ForkS *) e σ1
      | (* AllocS *) v1 σ1 l  Hfree_l
      | (* LoadS *) l v1 σ1  Hbound_l
      | (* StoreS *) l v1 σ1  Hisbound_l
      | (* CasFailS *) l v1 v2 vl σ1  Hbound_l Hneq_vl_v1
      | (* CasSucS *) l v1 v2 σ1  Hbound_l
      | (* FaaS *) l i1 i2 σ1  Hbound_l
      ];
    destruct ki ; try contradiction Hactive ; try discriminate Ee1' ;
    injection Ee1' ; clear Ee1' ;
    repeat (intros -> || intros <- || intros -> % translationV_lit_inv || intros E) ;
    destruct Eσ1'.
    (* replacing the state S«σ, m» with S«σ»: *)
    all: first [
        apply lookup_insert_None in Hfree_l as [Hfree_l _]
      | apply lookup_insert_Some in Hbound_l as [ [<- _] | [_ Hbound_l] ] ; first naive_solver
      | apply lookup_insert_is_Some in Hisbound_l as [ <- | [_ Hisbound_l] ] ; first naive_solver
      | idtac
    ].
    (* PairS *)
    - eexhibit_prim_step.
    (* InjLS *)
    - eexhibit_prim_step.
    (* InjRS *)
    - eexhibit_prim_step.
    (* BetaS *)
    - destruct v ; try discriminate E.
      by eexhibit_prim_step.
    (* UnOpS *)
    - eexhibit_prim_step.
      by eapply un_op_eval_translation_inv.
    (* BinOpS *)
    - eexhibit_prim_step.
      by eapply bin_op_eval_translation_inv.
    (* IfTrueS *)
    - eexhibit_prim_step.
    (* IfFalseS *)
    - eexhibit_prim_step.
    (* FstS *)
    - destruct v ; try discriminate E.
      eexhibit_prim_step.
    (* SndS *)
    - destruct v ; try discriminate E.
      eexhibit_prim_step.
    (* CaseLS *)
    - destruct v ; try discriminate E.
      eexhibit_prim_step.
    (* CaseRS *)
    - destruct v ; try discriminate E.
      eexhibit_prim_step.
    (* AllocS *)
    - eexhibit_prim_step.
      by eapply lookup_translationS_None_inv.
    (* LoadS *)
    - apply lookup_translationS_Some_inv in Hbound_l as (? & ? & _).
      by eexhibit_prim_step.
    (* StoreS *)
    - eexhibit_prim_step.
      by eapply lookup_translationS_is_Some_inv.
    (* CasFailS *)
    - apply lookup_translationS_Some_inv in Hbound_l as (? & ? & ->).
      exhibit_prim_step (Val #false).
      + done.
      + intros ? % (f_equal translationV). contradiction.
      + by apply vals_cas_compare_safe_translationV_inv.
    (* CasSucS *)
    - apply lookup_translationS_Some_inv in Hbound_l as (? & ? & -> % translationV_injective).
      exhibit_prim_step (Val #true)%E.
      done. by apply vals_cas_compare_safe_translationV_inv.
    (* FaaS *)
    - apply lookup_translationS_Some_inv in Hbound_l as (? & ? & -> % eq_sym % translationV_lit_inv).
      by eexhibit_prim_step.
  Qed.

  (* assuming the safety of the translated expression,
   * a proof that the original expression is m-safe. *)

  Lemma safe_translation__nsafe_here m e σ :
    loc_fresh_in_expr ℓ e →
    (m > 0)%nat →
    safe «e» S«σ, m» →
    is_Some (to_val e) ∨ reducible e σ.
  Proof.
    intros Hfresh Im Hsafe.
    (* case analysis on whether e is a value… *)
    destruct (to_val e) as [ v | ] eqn:Hnotval.
    (* — if e is a value, then we get the result immediately: *)
    - left. eauto.
    (* — if e is not a value, then we show that it is reducible: *)
    - right.
      (* we decompose e into a maximal evaluation context K and a head-redex: *)
      pose proof (not_val_fill_active_item _ Hnotval) as He ; clear Hnotval.
      destruct He as [ (K & x & ->) |
                     [ (K & e1 & ->) |
                     [ (K & f & x & e1 & ->) |
                       (K & ki & v & -> & Hactive) ] ]].
      (* — either e = K[Var x]: *)
      + (* then [«fill K x»] is stuck: *)
        exfalso. clear -Hsafe. rewrite translation_fill in Hsafe.
        apply safe_fill_inv in Hsafe. destruct Hsafe as [_ Hsafe].
        destruct (Hsafe _ _ x eq_refl (rtc_refl _ _)) as
            [[? [=]]|(?&?&?&?&[K' ?? Hx ? Hred])]; first set_solver+; simpl in *.
        destruct (decide (K' = [])) as [->|(K''&Ki&->)%exists_last]; last first.
        { rewrite !fill_app in Hx. by destruct Ki. }
        simpl in Hx. subst e1'. inversion Hred.
      (* — either e = K[Fork e1]: *)
      + (* then we easily derive a reduction from e: *)
        eexists _, _, _, _. apply Ectx_step', ForkS.
      (* — either e = K[Rec f x e1]: *)
      + (* then we easily derive a reduction from e: *)
        eexists _, _, _, _. apply Ectx_step', RecS.
      (* — or e = K[ki[v]] where ki is an active item: *)
      + (* it is enough to show that ki[v] is reducible: *)
        apply loc_fresh_in_expr_fill_inv in Hfresh ;
        rewrite -> translation_fill in Hsafe ; apply safe_fill_inv in Hsafe ;
        apply reducible_fill ;
        clear K.
        (* we deduce the reducibility of ki[v] from that of «ki»[«v»]: *)
        eapply active_item_translation_reducible ; [ done | done | ].
        (* remind that « ki[v] » = «ki»[tick «v»]: *)
        rewrite -> translation_fill_item_active in Hsafe ; last done.
        (* we have that «ki»[tick «v»] reduces to «ki»[«v»]
         * (m ≥ 1 so ‘tick’ can be run): *)
        assert (
          prim_exec (fill_item Ki«ki» (tick V«v»)) S«σ, m»
                    (fill_item Ki«ki» V«v»)        S«σ, m-1» []
        ) as Hsteps % prim_exec_exec.
        {
          assert (fill [Ki«ki»] = fill_item Ki«ki») as E by reflexivity ; destruct E.
          apply prim_exec_fill. apply safe_fill_inv in Hsafe.
          rewrite {+1} (_ : m = S (m-1)) ; last lia.
          apply exec_tick_success.
        }
        (* using the safety of «ki»[tick «v»], we proceed by case analysis… *)
        eapply Hsafe in Hsteps as [ Hisval | Hred ] ; auto using elem_of_list_here.
        (* — either «ki»[«v»] is a value: this is not possible because ki is active. *)
        * simpl in Hisval. rewrite active_item_not_val in Hisval ;
          [ by apply is_Some_None in Hisval | by apply is_active_translationKi ].
        (* — or «ki»[«v»] reduces to something: this is precisely what we need. *)
        * exact Hred.
  Qed.
  Lemma safe_translation__nsafe m n e σ t2 σ2 e2 :
    loc_fresh_in_expr ℓ e2 →
    σ2 !! ℓ = None →
    safe «e» S«σ, m» →
    relations.nsteps erased_step n ([e], σ) (t2, σ2) →
    (n < m)%nat →
    e2 ∈ t2 →
    is_Some (to_val e2) ∨ reducible e2 σ2.
  Proof.
    intros Hℓe Hℓσ Hsafe Hnsteps Inm He2.
    assert (safe «e2» S«σ2, m-n») as Hsafe2.
    {
      eapply safe_exec.
      - eapply elem_of_list_fmap_1. eassumption.
      - eassumption.
      - change [«e»] with T«[e]». apply simulation_exec_success' ; [ assumption | lia | assumption ].
    }
    assert (m - n > 0)%nat by lia.
    by eapply safe_translation__nsafe_here.
  Qed.

  (* assuming the adequacy of the translated expression,
   * a proof that the original expression has m-adequate results. *)

  (* FIXME : this is a weaker result than the adequacy result of Iris,
     where the predicate can also speak about the final state. *)
  Lemma adequate_translation__nadequate_result m n φ e σ t2 σ2 v2 :
    σ2 !! ℓ = None →
    adequate NotStuck «e» S«σ, m» (λ v σ, φ (invtranslationV v)) →
    relations.nsteps erased_step n ([e], σ) (Val v2 :: t2, σ2) →
    (n ≤ m)%nat →
    φ v2.
  Proof.
    intros Hfresh Hadq Hnsteps Inm.
    assert (safe «e» S«σ, m») as Hsafe by by eapply safe_adequate.
    replace (φ v2) with ((φ ∘ invtranslationV) (translationV v2))
      by (simpl ; by rewrite invtranslationV_translationV).
    eapply (adequate_result _ _ _ (λ v σ, φ (invtranslationV v))); first done.
    simpl. change [«e»%E] with T«[e]».
    replace (Val «v2» :: _) with (T«Val v2 :: t2») by done.
    eapply simulation_exec_success' ; eauto.
  Qed.

End SimulationLemma. (* we close the section here as we now want to quantify over all locations *)

(* now let’s combine the two results. *)

Lemma adequate_translation__nadequate m φ e σ :
  (∀ {Hloc : TickCounter}, adequate NotStuck «e» S«σ, m» (λ v σ, φ (invtranslationV v))) →
  nadequate NotStuck m e σ φ.
Proof.
  intros Hadq.
  split.
  (* (1) adequate result: *)
  - intros n t2 σ2 v2 Hnsteps Inm.
    (* build a location ℓ which is not in the domain of σ2: *)
    pose (Hloc := Build_TickCounter (fresh (dom (gset loc) σ2)) : TickCounter).
    assert (σ2 !! ℓ = None)
      by (simpl ; eapply (not_elem_of_dom (D:=gset loc)), is_fresh).
    by eapply adequate_translation__nadequate_result.
  (* (2) safety: *)
  - intros n t2 σ2 e2 _ Hnsteps Inm He2.
    (* build a location ℓ which is fresh in e2 and in the domain of σ2: *)
    pose (set1 := loc_set_of_expr e2 : gset loc).
    pose (set2 := dom (gset loc) σ2 : gset loc).
    pose (Hloc := Build_TickCounter (fresh (set1 ∪ set2)) : TickCounter).
    eassert (ℓ ∉ set1 ∪ set2) as [Hℓ1 Hℓ2] % not_elem_of_union
      by (unfold ℓ ; apply is_fresh).
    assert (loc_fresh_in_expr ℓ e2)
      by by apply loc_not_in_set_is_fresh_in_expr.
    assert (σ2 !! ℓ = None)
      by by (simpl ; eapply (not_elem_of_dom (D:=gset loc))).
    specialize (Hadq Hloc) as Hsafe % safe_adequate.
    by eapply safe_translation__nsafe.
Qed.

End Simulation.


Require Import Spec.ConcurExec.

Require Import ProofAutomation.
Require Import Spec.Equiv.Automation.

Require Import Helpers.Instances.
Require Import Morphisms.

Section OpSemantics.

  Context {Op:Type -> Type}.
  Context {State:Type}.
  Variable op_step: OpSemantics Op State.

  Local Obligation Tactic := try RelInstance_t.

  (** A strong notion of execution equivalence, independent of semantics *)

  Definition exec_equiv_ts (ts1 ts2 : threads_state Op) :=
    forall (s : State) tr,
      exec op_step s ts1 tr <->
      exec op_step s ts2 tr.

  Global Program Instance exec_equiv_ts_equivalence :
    Equivalence exec_equiv_ts.

  Local Definition exec_equiv_opt (p1 : maybe_proc Op) p2 :=
    forall (ts : threads_state _) tid,
      exec_equiv_ts (ts [[ tid := p1 ]]) (ts [[ tid := p2 ]]).

  Definition exec_equiv `(p1 : proc Op T) (p2 : proc _ T) :=
    exec_equiv_opt (Proc p1) (Proc p2).

  Definition exec_equiv_rx `(p1 : proc Op T) (p2 : proc _ T) :=
    forall TR (rx : T -> proc _ TR),
      exec_equiv (Bind p1 rx) (Bind p2 rx).

  Global Program Instance exec_equiv_opt_equivalence :
    Equivalence exec_equiv_opt.

  Global Program Instance exec_equiv_equivalence :
    Equivalence (@exec_equiv T).

  Global Program Instance exec_equiv_rx_equivalence :
    Equivalence (@exec_equiv_rx T).

  Global Instance thread_upd_exec_equiv_proper :
    Proper (eq ==> eq ==> exec_equiv_opt ==> exec_equiv_ts) (@thread_upd Op).
  Proof.
    intros.
    intros ts0 ts1 H; subst.
    intros tid tid' H'; subst.
    intros o0 o1 H'.

    unfold exec_equiv_ts; split; intros.
    - apply H'; eauto.
    - apply H'; eauto.
  Qed.

  Global Instance Proc_exec_equiv_proper :
    Proper (exec_equiv ==> exec_equiv_opt) (@Proc Op T).
  Proof.
    intros.
    unfold exec_equiv.
    intros ts0 ts1 H; subst.
    eauto.
  Qed.

  Hint Constructors exec_tid.
  Hint Constructors exec_till.

  Hint Extern 1 (exec _ _ _ _ _) =>
  match goal with
  | |- exec_till _ _ _ ?ts _ => first [ is_evar ts; fail 1 | eapply ConcurExec.exec_ts_eq ]
  end : exec.

  Theorem exec_equiv_ret_None : forall `(v : T),
      exec_equiv_opt (Proc (Ret v)) NoProc.
  Proof.
    split; intros.
    - ExecEquiv tt.
    - change tr with (prepend tid nil tr).
      eapply ExecOne with (tid := tid).
      autorewrite with t; eauto.
      rewrite mapping_finite; auto.
      econstructor.
      match goal with
      | |- context[S (thread_max ?ts)] =>
        rewrite thread_upd_same_eq with (tid := S (thread_max ts))
      end.
      autorewrite with t; eauto.
      rewrite mapping_finite; eauto.
  Qed.

  Theorem exec_equiv_rx_proof_helper : forall `(p1 : proc Op T) p2,
      (forall tid tid' `(s : State) s' (ts: threads_state _) tr spawned evs `(rx : _ -> proc _ TR) result,
          exec_tid op_step tid s (Bind p1 rx) s' result spawned evs ->
          ts tid' = NoProc ->
          tid <> tid' ->
          exec op_step s' (ts [[tid' := spawned]] [[tid := match result with
                                                           | inl _ => NoProc
                                                           | inr p' => Proc p'
                                                           end]]) tr ->
          exec op_step s (ts [[tid := Proc (Bind p2 rx)]]) (prepend tid evs tr)) ->
      (forall tid tid' `(s : State) s' (ts: threads_state _) tr evs spawned `(rx : _ -> proc _ TR) result,
          exec_tid op_step tid s (Bind p2 rx) s' result spawned evs ->
          ts tid' = NoProc ->
          tid <> tid' ->
          exec op_step s' (ts [[tid' := spawned]] [[tid := match result with
                                                           | inl _ => NoProc
                                                           | inr p' => Proc p'
                                                           end]]) tr ->
          exec op_step s (ts [[tid := Proc (Bind p1 rx)]]) (prepend tid evs tr)) ->
      exec_equiv_rx p1 p2.
  Proof.
    split; intros.
    - ExecEquiv tt.
    - ExecEquiv tt.
  Qed.

  Theorem exec_equiv_rx_bind_bind : forall `(p1 : proc Op T1) `(p2 : T1 -> proc Op T2) `(p3 : T2 -> proc Op T3),
      exec_equiv_rx (Bind (Bind p1 p2) p3) (Bind p1 (fun v => Bind (p2 v) p3)).
  Proof.
    split; intros.
    - ExecEquiv p1.
      ExecPrefix tid tid'.
      destruct result0; eauto.
    - ExecEquiv p1.
      ExecPrefix tid tid'.
      destruct result; eauto.
  Qed.

  Theorem exec_equiv_ret_bind : forall `(v : T) `(p : T -> proc Op T'),
      exec_equiv_rx (Bind (Ret v) p) (p v).
  Proof.
    intros.
    eapply exec_equiv_rx_proof_helper; intros; exec_tid_simpl.
    - simpl.
      rewrite thread_upd_same_eq with (tid:=tid') in H2 by eauto.
      eauto.
    - abstract_tr.
      ExecPrefix tid tid'.
      ExecPrefix tid tid'.
      rewrite <- prepend_app; simpl; auto.
  Qed.

  Theorem exec_equiv_bind_ret : forall `(p : proc Op T),
      exec_equiv (Bind p Ret) p.
  Proof.
    unfold exec_equiv; split; intros.

    - ExecEquiv p.
      destruct result0.
      + ExecPrefix tid tid'.
        eapply exec_equiv_ret_None; eauto.
      + ExecPrefix tid tid'.

    - ExecEquiv p.
      destruct result; guess_ExecPrefix.
      eapply exec_equiv_ret_None; eauto.
  Qed.

  Global Instance exec_equiv_rx_to_exec_equiv :
    subrelation (@exec_equiv_rx T) exec_equiv.
  Proof.
    unfold subrelation, exec_equiv_rx; intros.
    rewrite <- exec_equiv_bind_ret with (p := x).
    rewrite <- exec_equiv_bind_ret with (p := y).
    eauto.
  Qed.

  Theorem exec_equiv_bind_bind : forall `(p1 : proc Op T1) `(p2 : T1 -> proc Op T2) `(p3 : T2 -> proc Op T3),
      exec_equiv (Bind (Bind p1 p2) p3) (Bind p1 (fun v => Bind (p2 v) p3)).
  Proof.
    intros.
    rewrite exec_equiv_rx_bind_bind; reflexivity.
  Qed.

  Theorem exec_equiv_bind_a : forall `(p : proc Op T) `(p1 : T -> proc _ T') p2,
      (forall x, exec_equiv (p1 x) (p2 x)) ->
      exec_equiv (Bind p p1) (Bind p p2).
  Proof.
    unfold exec_equiv; split; intros.
    - ExecEquiv p.
      ExecPrefix tid tid'.
      destruct result0; eauto.
      eapply H; eauto.

    - ExecEquiv p.
      ExecPrefix tid tid'.
      destruct result0; eauto.
      eapply H; eauto.
  Qed.

  Local Theorem exec_equiv_congruence : forall T (p1 p2: proc Op T) T' (rx1 rx2: T -> proc Op T'),
      exec_equiv_rx p1 p2 ->
      (forall x, exec_equiv_rx (rx1 x) (rx2 x)) ->
      exec_equiv_rx (Bind p1 rx1) (Bind p2 rx2).
  Proof.
    intros.
    unfold exec_equiv_rx; intros.
    repeat rewrite exec_equiv_bind_bind.
    etransitivity.
    eapply H.
    eapply exec_equiv_bind_a; intros.
    eapply H0.
  Qed.

  Theorem exec_equiv_rx_bind_a : forall `(p : proc Op T) `(p1 : T -> proc _ T') p2,
      (forall x, exec_equiv_rx (p1 x) (p2 x)) ->
      exec_equiv_rx (Bind p p1) (Bind p p2).
  Proof.
    intros.
    eapply exec_equiv_rx_proof_helper; intros.
    - exec_tid_inv.
      exec_tid_inv.
      ExecPrefix tid tid'.
      destruct result; eauto.
      eapply H; eauto.
      apply exec_equiv_bind_bind.
      apply exec_equiv_bind_bind in H3.
      eapply exec_equiv_bind_a; intros; eauto; simpl.
      symmetry.
      eapply H; eauto.
    - exec_tid_inv.
      exec_tid_inv.
      ExecPrefix tid tid'.
      destruct result; eauto.
      eapply H; eauto.
      apply exec_equiv_bind_bind.
      apply exec_equiv_bind_bind in H3.
      eapply exec_equiv_bind_a; intros; eauto; simpl.
      eapply H; eauto.
  Qed.

  Theorem exec_equiv_atomicret_ret : forall `(v : T),
      exec_equiv_rx (Atomic (Ret v)) (Ret v).
  Proof.
    intros.
    eapply exec_equiv_rx_proof_helper; intros; exec_tid_simpl.
    - repeat atomic_exec_inv.
      ExecPrefix tid tid'.
    - ExecPrefix tid tid'.
  Qed.

  Theorem exec_equiv_until : forall `(p : option T -> proc Op T) (c : T -> bool) v,
      exec_equiv_rx (Until c p v) (until1 c p v).
  Proof.
    intros.
    eapply exec_equiv_rx_proof_helper; intros.
    - exec_tid_simpl.
      rewrite thread_upd_same_eq with (tid:=tid') in H2 by congruence.
      simpl; eauto.
    - abstract_tr.
      ExecPrefix tid tid'.
      ExecPrefix tid tid'.
      rewrite <- prepend_app; auto.
  Qed.

  Theorem exec_equiv_spawn : forall `(p1 : proc Op T) p2,
      exec_equiv p1 p2 ->
      exec_equiv_rx (Spawn p1) (Spawn p2).
  Proof.
    intros.
    eapply exec_equiv_rx_proof_helper; intros.
    - exec_tid_simpl.
      ExecPrefix tid tid'.
      rewrite thread_upd_ne_comm in * by auto.
      match goal with
      | H : exec_equiv _ _ |- _ =>
        apply H; eauto
      end.
    - exec_tid_simpl.
      ExecPrefix tid tid'.
      rewrite thread_upd_ne_comm in * by auto.
      match goal with
      | H : exec_equiv _ _ |- _ =>
        apply H; eauto
      end.
  Qed.

  Global Instance Bind_exec_equiv_proper :
    Proper (exec_equiv_rx ==>
                          pointwise_relation T exec_equiv_rx ==>
                          @exec_equiv_rx TR) Bind.
  Proof.
    unfold Proper, respectful, pointwise_relation; intros.
    apply exec_equiv_congruence; auto.
  Qed.

  Global Instance Spawn_exec_equiv_proper :
    Proper (@exec_equiv T ==> exec_equiv_rx) Spawn.
  Proof.
    unfold Proper, respectful, pointwise_relation; intros.
    apply exec_equiv_spawn; auto.
  Qed.

  Global Instance exec_proper_exec_equiv :
    Proper (eq ==> exec_equiv_ts ==> eq ==> iff) (@exec Op State op_step).
  Proof.
    unfold Proper, respectful; intros; subst; eauto.
  Qed.

  Global Instance SpawnN_exec_equiv_proper :
      Proper (eq ==> (exec_equiv (T:=T)) ==> exec_equiv_rx) SpawnN.
  Proof.
    unfold Proper, respectful; intros; subst.
    induction y; simpl.
    - reflexivity.
    - rewrite H0.
      setoid_rewrite IHy.
      reflexivity.
  Qed.

End OpSemantics.


Set Implicit Arguments.

Require Import LibTactics.
Require Import LNameless_Meta.
Require Import LNameless_Isomorphism.
Require Import LNameless_Fsub_Iso.
Require Import LN_Template_Two_Sort.
Require Import LN_Fsub_basic_Infrastructure.

(** ** Fsub Part 1A and 2A *)

(** Reference: Chargueraud's POPL solution using Locally Nameless style
   and cofinite quantification *)

(** * Properties of Subtyping *)

(** "apply_fresh T as x" is used to apply inductive rule which
   use an universal quantification over a cofinite set *)

Ltac apply_fresh_base_simple lemma gather :=
  let L0 := gather in let L := beautify_fset L0 in
  first [apply (@lemma L) | eapply (@lemma L)].

Ltac apply_fresh_base lemma gather var_name :=
  apply_fresh_base_simple lemma gather;
  try match goal with |- forall _, _ `notin` _ -> _ =>
    let Fr := fresh "Fr" in intros var_name Fr; destruct_notin end.

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_atoms x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto*.

(** These tactics help applying a lemma which conclusion mentions
  an environment (E & F) in the particular case when F is empty *)

Ltac get_env :=
  match goal with
  | |- wft ?E _ => E
  | |- sub ?E _ _  => E
  | |- typing ?E _ _ => E
  end.

Tactic Notation "apply_empty_bis" tactic(get_env) constr(lemma) :=
  let E := get_env in rewrite <- (app_nil_1 _ E);
  eapply lemma; try rewrite app_nil_1.

Lemma sub_reflexivity : forall E T,
  okt E ->
  wft E T ->
  sub E T T .
Proof.
  introv Ok WI. poses W (type_from_wft WI). gen E.
  induction W; intros; inversions WI; eauto.
  apply_fresh* sub_all as Y.
Qed.

(* ********************************************************************** *)
(** Weakening *)

Lemma sub_weakening : forall E F G S T,
   sub (E ++ G) S T ->
   okt (E ++ F ++ G) ->
   sub (E ++ F ++ G) S T.
Proof.
  introv Typ. gen_eq (E ++ G) as H. gen E.
  induction Typ; introv EQ Ok; subst; auto.
  (* case: fvar trans *)
  eapply sub_trans_tvar; auto; eapply binds_weaken; auto.
  (* case: all *)
  apply_fresh* sub_all as Y. apply_ih_bind* H0.
Qed.

(* ********************************************************************** *)
(** Narrowing and transitivity *)

Section NarrowTrans.

Definition transitivity_on Q := forall E S T,
  sub E S Q -> sub E Q T -> sub E S T.

Hint Unfold transitivity_on.

Hint Resolve wft_narrow.

Implicit Arguments binds_mid_eq [A x a b E F].

Lemma sub_narrowing_aux : forall Q F E Z P S T,
  transitivity_on Q ->
  sub (E ++ Z ~<: Q ++ F) S T ->
  sub F P Q ->
  sub (E ++ Z ~<: P ++ F) S T.
Proof.
  introv TransQ SsubT PsubQ.
  gen_eq (E ++ Z ~<: Q ++ F) as G. gen E.
  induction SsubT; introv EQ; subst.

  apply sub_top; eauto.

  apply sub_refl_tvar; eauto.

  puts (@okt_narrow E0 F Q).
  elim sub_regular with (E0 ++ Z ~<: Q ++ F) U T; intros; auto.
  case (X == Z); intros EQ; subst.
    assert (bind_sub U = bind_sub Q).
      apply binds_mid_eq with Z F E0; auto.
    inversion H3; subst; clear H3.
    apply (@sub_trans_tvar P).
      apply binds_app_3; auto.
    apply TransQ; auto.
    do_rew <- (app_assoc) (apply_empty* sub_weakening); auto.
  apply* (@sub_trans_tvar U); auto.
  analyze_binds H.

  apply sub_arrow; auto.

  apply_fresh* sub_all as Y. apply_ih_bind* H0.
Qed.

Lemma sub_transitivity : forall Q,
  transitivity_on Q.
Proof.
  intro Q. introv SsubQ QsubT. asserts* W (type Q).
  gen E S T. gen_eq Q as Q' eq. gen Q' eq.
  induction W; intros Q' EQ E S SsubQ;
    induction SsubQ; try discriminate; inversions EQ;
      intros T QsubT; inversions QsubT;
        eauto 4 using sub_trans_tvar.
  (* case: all / top -> only needed to fix well-formedness,
     by building back what has been deconstructed too much *)
  assert (sub E (typ_all S1 S2) (typ_all T1 T2)).
    apply_fresh* sub_all as y.
  auto*.
  (* case: all / all *)
  apply_fresh sub_all as Y. auto*.
  forward~ (H0 Y) as K. apply (K (T2 open_tt_var Y)); auto.
  puts (IHW T1); simpl; apply_empty* (@sub_narrowing_aux T1 E).
Qed.

Lemma sub_narrowing : forall Q E F Z P S T,
  sub F P Q ->
  sub (E ++ Z ~<: Q ++ F) S T ->
  sub (E ++ Z ~<: P ++ F) S T.
Proof.
  intros.
  apply sub_narrowing_aux with Q; auto.
  apply* sub_transitivity.
Qed.

End NarrowTrans.

(* ********************************************************************** *)
(** Type substitution preserves subtyping *)

Lemma sub_through_subst_tt : forall Q E F Z S T P,
  sub (E ++ Z ~<: Q ++ F) S T ->
  sub F P Q ->
  sub (map (subst_tb Z P) E ++ F) (M_yy.M.Tfsubst S Z P) (M_yy.M.Tfsubst T Z P).
Proof.
  introv SsubT PsubQ.
  gen_eq (E ++ Z ~<: Q ++ F) as G. gen E.
  induction SsubT; introv EQ; subst.
  apply sub_top; eauto.

  apply sub_reflexivity; eauto.

  elim sub_regular with F P Q;
    [intros Hokt Hwft; inversion Hwft as [Hp Hq]; clear Hwft | idtac]; auto.
  elim sub_regular with  (E0 ++ Z ~<: Q ++ F) U T;
    [intros Hokt0 Hwft0; inversion Hwft0 as [Hu Ht]; clear Hwft0 | idtac]; auto.
  gsimpl; simpl_alist in *.
    apply (@sub_transitivity Q).
      apply_empty* sub_weakening.
    pattern Q; rewrite* (@M_yy.M.Tfsubst_no_occur Q X P).
      assert (bind_sub U = bind_sub Q).
        apply binds_mid_eq with X F E0; auto.
      inversion H0; subst; clear H0; auto.
    apply notin_fv_wf with (E:= F); auto.
    apply fresh_mid_tail with (bind_sub Q) E0; auto.
  analyze_binds H.
    apply (@sub_trans_tvar (M_yy.M.Tfsubst U Z P)); auto; simpl.
    replace (bind_sub (M_yy.M.Tfsubst U Z P)) with (subst_tb Z P (bind_sub U)); auto.
  apply sub_trans_tvar with (U:= U); auto.
  pattern U; rewrite* (@M_yy.M.Tfsubst_no_occur U Z P).
  apply notin_fv_wf with (E:= F); auto.
    apply wft_from_env_has_sub with X; auto.
  apply fresh_mid_tail with (bind_sub Q) E0; auto.

  gsimpl; simpl_alist in *; apply sub_arrow.

  gsimpl; simpl_alist in *; apply_fresh* sub_all as X.
   unsimpl (subst_tb Z P (bind_sub T1)).
   do 2 grewrite Ybfsubst_permutation_var_wf; auto.
   apply_ih_map_bind* H0.
Qed.

(* ********************************************************************** *)
(** * Properties of Typing *)

(* ********************************************************************** *)
(** Weakening *)

Lemma typing_weakening : forall E F G e T,
   typing (E ++ G) e T ->
   okt (E ++ F ++ G) ->
   typing (E ++ F ++ G) e T.
Proof.
  introv Typ. gen_eq (E ++ G) as H. gen E.
  induction Typ; introv EQ Ok; subst; auto.

  apply_fresh* typing_abs as x. forward~ (H x) as K.
  apply_ih_bind (H0 x); auto.
  apply okt_typ; auto.
  elim typing_regular with (x ~: V ++ E0 ++ G) (e1 open_ee_var x) T1; intros; auto.
  inversion H1; auto.

  apply typing_app with T1; auto.

  apply_fresh* typing_tabs as X. forward~ (H X) as K.
  apply_ih_bind (H0 X); auto.
  apply okt_sub; auto.
  elim typing_regular with (X ~<: V ++ E0 ++ G) (e1 open_te_var X) (T1 open_tt_var X); intros; auto.
  inversion H1; auto.

  eapply typing_tapp; eauto. eapply sub_weakening; eauto.
  eapply typing_sub; eauto. eapply sub_weakening; eauto.
Qed.

(* ********************************************************************** *)
(** Strengthening *)

Lemma sub_strengthening : forall x U E F S T,
  sub (E ++ x ~: U ++ F) S T ->
  sub (E ++ F) S T.
Proof.
  intros x U E F S T SsubT.
  gen_eq (E ++ x ~: U ++ F) as G. gen E.
  induction SsubT; introv EQ; subst; use wft_strengthen.
  (* case: fvar trans *)
  apply (@sub_trans_tvar U0); auto.
  analyze_binds H.
  (* case: all *)
  apply_fresh* sub_all as X. apply_ih_bind* H0.
Qed.

(************************************************************************ *)
(** Preservation by Type Narrowing *)

Lemma typing_narrowing : forall Q E F X P e T,
  sub F P Q ->
  typing (E ++ X ~<: Q ++ F) e T ->
  typing (E ++ X ~<: P ++ F) e T.
Proof.
  introv PsubQ Typ. gen_eq (E ++ X ~<: Q ++ F) as E'. gen E.
  induction Typ; introv EQ; subst.

  analyze_binds H0; apply typing_var; eauto.

  apply_fresh* typing_abs as y. apply_ih_bind* H0.
  eapply typing_app; eauto.
  apply_fresh* typing_tabs as Y. apply_ih_bind* H0.
  eapply typing_tapp; eauto. eapply (@sub_narrowing Q); eauto.
  eapply typing_sub; eauto. eapply (@sub_narrowing Q); eauto.
Qed.

(************************************************************************ *)
(** Preservation by Term Substitution *)

Lemma typing_through_subst_ee : forall U E F x T e u,
  typing (E ++ x ~: U ++ F) e T ->
  typing F u U ->
  typing (E ++ F) (M_tt.M.Tfsubst e x u) T.
Proof.
  introv TypT TypU. gen_eq (E ++ x ~: U ++ F) as E'. gen E.
  induction TypT; introv EQ; subst; gsimpl; simpl_alist in *.

  assert (bind_typ T = bind_typ U) as Hbind.
    apply binds_mid_eq with x0 F E0; auto.
  inversion Hbind; subst; clear Hbind; auto.
  apply_empty* typing_weakening.

  analyze_binds H0; apply typing_var; eauto.

  apply_fresh* typing_abs as y.
  grewrite Tbfsubst_permutation_var_TTwf; auto.
  apply_ih_bind* H0.

  eapply typing_app; eauto.

  apply_fresh* typing_tabs as Y.
  grewrite noRepr_THbfsubst_permutation_var_1_wf.
  apply_ih_bind* H0.
  elim (term_TTwf (proj32 (typing_regular TypU))); tauto.

  eapply typing_tapp; eauto. eapply sub_strengthening; eauto.

  eapply typing_sub; eauto. eapply sub_strengthening; eauto.
Qed.

(************************************************************************ *)
(** Preservation by Type Substitution *)

Lemma typing_through_subst_te : forall Q E F Z e T P,
  typing (E ++ Z ~<: Q ++ F) e T ->
  sub F P Q ->
  typing (map (subst_tb Z P) E ++ F) (M_yt.M.Tfsubst e Z P) (M_yy.M.Tfsubst T Z P).
Proof.
  introv Typ PsubQ. gen_eq (E ++ Z ~<: Q ++ F) as G. gen E.
  induction Typ; introv EQ; subst; gsimpl; simpl_alist in *.

  analyze_binds H0; apply typing_var; eauto.
    apply binds_app_2.
    replace (bind_typ (M_yy.M.Tfsubst T Z P)) with (subst_tb Z P (bind_typ T)); auto.
  apply binds_app_3.
  rewrite* <- (@M_yy.M.Tfsubst_no_occur T Z P).
  apply notin_fv_wf with (E:= F); auto.
    apply wft_from_env_has_typ with x; auto.
  apply fresh_mid_tail with (bind_sub Q) E0; auto.

  apply_fresh* typing_abs as y.
  unsimpl (subst_tb Z P (bind_typ V)).
  grewrite noRepr_THbfsubst_permutation_var.
  apply_ih_map_bind* H0.

  eapply typing_app; eauto.
  apply IHTyp1; auto.

  apply_fresh* typing_tabs as Y.
    unsimpl (subst_tb Z P (bind_sub V)).
    grewrite THbfsubst_permutation_var_wf; auto.
    grewrite Ybfsubst_permutation_var_wf; auto.
    apply_ih_map_bind* H0.

  rewrite* <- Ybfsubst_permutation_core_Ywf.
  apply typing_tapp with (M_yy.M.Tfsubst T1 Z P); auto.
  apply sub_through_subst_tt with Q; auto.

  eapply typing_sub; eauto. eapply sub_through_subst_tt; eauto.
Qed.

(* ********************************************************************** *)
(** * Preservation *)

(* ********************************************************************** *)
(** Inversions for Typing *)

Lemma typing_inv_abs : forall E S1 e1 T,
  typing E (trm_abs S1 e1) T ->
  forall U1 U2, sub E T (typ_arrow U1 U2) ->
     sub E U1 S1
  /\ exists S2, exists L, forall x, x `notin` L ->
     typing (x ~: S1 ++ E) (e1 open_ee_var x) S2 /\ sub E S2 U2.
Proof.
  introv Typ. gen_eq (trm_abs S1 e1) as e. gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 Sub; inversions EQ.
  inversions* Sub. use (@sub_transitivity T).
Qed.

Lemma typing_inv_tabs : forall E S1 e1 T,
  typing E (trm_tabs S1 e1) T ->
  forall U1 U2, sub E T (typ_all U1 U2) ->
     sub E U1 S1
  /\ exists S2, exists L, forall X, X `notin` L ->
     typing (X ~<: U1 ++ E) (e1 open_te_var X) (S2 open_tt_var X)
     /\ sub (X ~<: U1 ++ E) (S2 open_tt_var X) (U2 open_tt_var X).
Proof.
  intros E S1 e1 T H. gen_eq (trm_tabs S1 e1) as e. gen S1 e1.
  induction H; intros S1 b EQ U1 U2 Sub; inversion EQ.
  inversions Sub. splits; auto.
   exists T1. let L1 := gather_atoms in exists L1.
   intros Y Fr; destruct_notin. splits; auto.
   simpl; apply_empty* (@typing_narrowing S1).
  use (@sub_transitivity T).
Qed.

(* ********************************************************************** *)
(** Preservation Result *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen e'. induction Typ; introv Red;
   try solve [ inversion Red ].
  (* case: app *)
  inversions Red; try solve [ eapply typing_app; eauto ].
  destructi (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    eapply sub_reflexivity; eauto.
  pick_fresh X; destruct_notin.
  forward~ (P2 X) as K. destruct K.

  rewrite M_tt.M.Tbfsubst_var_intro with (a:=X); simpl; auto.
  apply_empty (@typing_through_subst_ee V); eauto.
  eapply (@typing_sub S2); eauto. apply_empty* sub_weakening.

  (* case: tapp *)
  inversions Red; try solve [ eapply typing_tapp; eauto ].
  destructi (typing_inv_tabs Typ (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    eapply sub_reflexivity; eauto.
  pick_fresh X; destruct_notin. forward~ (P2 X) as K. destruct K.
  rewrite M_yt.M.Tbfsubst_var_intro with (a:=X); simpl; auto.
  rewrite M_yy.M.Tbfsubst_var_intro with (a:=X); simpl; auto.
  unsimpl (E ++ map (subst_tb X T) empty_env).
  generalize (@typing_through_subst_te T1 nil); simpl; intros; eauto.
  (* case sub *)
  eapply typing_sub; eauto.
Qed.

(* ********************************************************************** *)
(** * Progress *)

(* ********************************************************************** *)
(** Canonical Forms *)

Lemma canonical_form_abs : forall t U1 U2,
  value t -> typing empty_env t (typ_arrow U1 U2) ->
  exists V, exists e1, t = trm_abs V e1.
Proof.
  introv Val Typ. gen_eq (@empty_env bind) as E.
  gen_eq (typ_arrow U1 U2) as T. gen U1 U2.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
    subst. inversion H. inversion H0. auto*.
Qed.

Lemma canonical_form_tabs : forall t U1 U2,
  value t -> typing empty_env t (typ_all U1 U2) ->
  exists V, exists e1, t = trm_tabs V e1.
Proof.
  introv Val Typ. gen_eq (@empty_env bind) as E.
  gen_eq (typ_all U1 U2) as T. gen U1 U2.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
    subst. inversion H. inversion H0. auto*.
Qed.

(* ********************************************************************** *)
(** Progress Result *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq (@empty_env bind) as E. poses Typ' Typ.
  induction Typ; intros EQ; subst.
  (* case: var *)
  inversion H0.
  (* case: abs *)
  left*.
  (* case: app *)
  right. destruct* IHTyp1 as [Val1 | [e1' Rede1']].
    destruct* IHTyp2 as [Val2 | [e2' Rede2']].
      destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]].
        subst. exists* (M_tt.M.Tbsubst e3 0 e2).
  (* case: tabs *)
  left*.
  (* case: tapp *)
  right. destruct* IHTyp as [Val1 | [e1' Rede1']].
    destruct (canonical_form_tabs Val1 Typ) as [S [e3 EQ]].
      subst. exists* (M_yt.M.Tbsubst e3 0 T).
  (* case: sub *)
  auto*.
Qed.


(* File: NSound.v  (last edited on 27/10/2000) (c) Klaus Weich  *)

Require Export Le_Ks.
Require Export Derivable_Tools.

Definition nsound (work : nf_list) (ds : disjs) (ni : nested_imps)
  (ai : atomic_imps) (a : atoms) (context : flist) :=
  forall c : normal_form,
  in_ngamma work ds ni ai a c -> Derivable context (nf2form c).

Lemma nsound_eqv :
 forall (work : nf_list) (ds : disjs) (ni1 ni2 : nested_imps)
   (ai : atomic_imps) (a : atoms) (context : flist),
 eqv_ni ni1 ni2 ->
 nsound work ds ni1 ai a context -> nsound work ds ni2 ai a context.
intros work ds ni1 ni2 ai a context eq12 sound.
unfold nsound in |- *.
intros c in_ngamma.
apply sound.
apply in_ngamma_eqv with ni2.
apply eqv_sym; assumption.
assumption.
Qed.

Lemma nsound_le :
 forall (work : nf_list) (ds : disjs) (ni1 ni2 : nested_imps)
   (ai : atomic_imps) (a : atoms) (context : flist),
 le_ni ni1 ni2 ->
 nsound work ds ni1 ai a context -> nsound work ds ni2 ai a context.
intros work ds ni1 ni2 ai a context le sound.
unfold nsound in |- *.
intros c in_ngamma.
apply sound.
apply in_ngamma_ge with ni2; assumption.
Qed.

Lemma nsound_ge :
 forall (work : nf_list) (ds : disjs) (ni1 ni2 : nested_imps)
   (ai : atomic_imps) (a : atoms) (context : flist),
 le_ni ni2 ni1 ->
 nsound work ds ni1 ai a context -> nsound work ds ni2 ai a context.
intros work ds ni1 ni2 ai a context le sound.
unfold nsound in |- *.
intros c in_ngamma.
apply sound.
apply in_ngamma_le with ni2; assumption.
Qed.

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

Lemma nsound_shift_work_ds :
 forall (i j : Int) (work : nf_list) (ds : disjs) (ni : nested_imps)
   (ai : atomic_imps) (a : atoms) (context : flist),
 nsound (NDisj i j :: work) ds ni ai a context ->
 nsound work ((i, j) :: ds) ni ai a context.
intros i j work ds ni ai a context sound.
unfold nsound in |- *.
intros c in_ngamma.
apply sound.
apply in_ngamma_shift_ds_work; assumption.
Qed.

Lemma nsound_shift_work_ni :
 forall (x : nested_imp) (work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai : atomic_imps) (a : atoms)
   (context : flist),
 nsound (NImp_NF (nested_imp2nimp x) :: work) ds ni ai a context ->
 nsound work ds (x :: ni) ai a context.
intros x work ds ni ai a context sound.
unfold nsound in |- *.
intros c in_ngamma.
apply sound.
apply in_ngamma_shift_ni_work; assumption.
Qed.

Lemma nsound_shift_work_ai :
 forall (i : Int) (b : normal_form) (work : nf_list)
   (ds : disjs) (ni : nested_imps) (ai ai' : atomic_imps)
   (a : atoms) (context : flist),
 EQUIV_INS nf_list i (cons b) nf_nil ai ai' ->
 nsound (AImp i b :: work) ds ni ai a context ->
 nsound work ds ni ai' a context.
intros i b work ds ni ai ai' a context equiv_ins sound.
unfold nsound in |- *.
intros c in_ngamma.
apply sound.
apply in_ngamma_shift_ai_work with ai'; assumption.
Qed.

Lemma nsound_shift_work_a :
 forall (i : Int) (work : nf_list) (ds : disjs) (ni : nested_imps)
   (ai : atomic_imps) (a a' : atoms) (context : flist),
 EQUIV_INS unit i (fun _ : unit => tt) tt a a' ->
 nsound (NAtom i :: work) ds ni ai a context ->
 nsound work ds ni ai a' context.
intros i work ds ni ai a a' context equiv_ins sound.
unfold nsound in |- *.
intros c in_ngamma.
apply sound.
apply in_ngamma_shift_a_work with a'; assumption.
Qed.

Lemma nsound_shift_work_ni_x_ni :
 forall (x : nested_imp) (work : nf_list) (ds : disjs)
   (ni1 ni2 : nested_imps) (ai : atomic_imps) (a : atoms)
   (context : flist),
 nsound (NImp_NF (nested_imp2nimp x) :: work) ds (ni1 ++ ni2) ai a context ->
 nsound work ds (ni1 ++ x :: ni2) ai a context.
intros x work ds ni1 ni2 ai a context sound.
unfold nsound in |- *.
intros c in_ngamma.
apply sound.
apply in_ngamma_shift_ni_x_ni_work; assumption.
Qed.

Lemma nsound_shift_ni_x_ni_work :
 forall (x : nested_imp) (work : nf_list) (ds : disjs)
   (ni1 ni2 : nested_imps) (ai : atomic_imps) (a : atoms)
   (context : flist),
 nsound work ds (ni1 ++ x :: ni2) ai a context ->
 nsound (NImp_NF (nested_imp2nimp x) :: work) ds (ni1 ++ ni2) ai a context.
intros x work ds ni1 ni2 ai a context sound.
unfold nsound in |- *.
intros c in_ngamma.
apply sound.
apply in_ngamma_shift_work_ni_x_ni; assumption.
Qed.

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

Remark nsound_app_work :
 forall (bs work : nf_list) (ds : disjs) (ni : nested_imps)
   (ai : atomic_imps) (a : atoms) (context : flist),
 (forall (n : nat) (b : normal_form),
  my_nth normal_form n bs b -> Derivable context (nf2form b)) ->
 nsound work ds ni ai a context -> nsound (bs ++ work) ds ni ai a context.
intros bs work ds ni ai a context der_bs sound.
unfold nsound in |- *.
intros c in_ngamma.
elim (in_ngamma_work_app_rev bs work ds ni ai a c in_ngamma); clear in_ngamma.
intros in_ngamma.
apply sound; assumption.
intros nth; elim nth; clear nth.
intros n nth.
apply der_bs with n; assumption.
Qed.

Lemma nsound_cons_ds_tail :
 forall (work : nf_list) (i j : Int) (ds : disjs) (ni : nested_imps)
   (ai : atomic_imps) (a : atoms) (context : flist),
 nsound work ((i, j) :: ds) ni ai a context -> nsound work ds ni ai a context.
intros work i j ds ni ai a context sound.
unfold nsound in |- *.
intros c in_ngamma.
apply sound.
apply in_ngamma_cons_ds_tail; assumption.
Qed.

Remark nsound_del_ai :
 forall (i : Int) (work : nf_list) (ds : disjs) (ni : nested_imps)
   (ai ai' : atomic_imps) (a : atoms) (context : flist),
 EQUIV_DEL nf_list i ai ai' ->
 nsound work ds ni ai a context -> nsound work ds ni ai' a context.
intros i work ds ni ai ai' a context equiv_del sound.
unfold nsound in |- *.
intros c in_ngamma.
apply sound.
apply in_ngamma_del_ai_tail with i ai'; assumption.
Qed.

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

Lemma nsound_cons_work_cons_context :
 forall (c : normal_form) (work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai : atomic_imps) (a : atoms)
   (context : flist),
 nsound work ds ni ai a context ->
 nsound (c :: work) ds ni ai a (nf2form c :: context).
intros c work ds ni ai a context sound.
unfold nsound in |- *.
intros c0 in_gamma.
elim (in_ngamma_cons_work_rev c work ds ni ai a c0 in_gamma); clear in_gamma.
intros in_gamma.
apply derivable_weak.
apply sound; assumption.
intros eq;  rewrite eq; clear eq.
apply Derivable_Intro with (Var 0).
apply ByAssumption.
apply My_NthO.
Qed.

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

Lemma nsound_cons_work_weak :
 forall (b c : normal_form) (work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai : atomic_imps) (a : atoms)
   (context : flist),
 (Derivable context (nf2form b) -> Derivable context (nf2form c)) ->
 nsound (b :: work) ds ni ai a context ->
 nsound (c :: work) ds ni ai a context.
intros b c work ds ni ai a context der_ab sound.
unfold nsound in |- *.
intros c0 in_ngamma.
elim (in_ngamma_cons_work_rev c work ds ni ai a c0 in_ngamma);
 clear in_ngamma.
intros in_ngamma.
apply sound.
apply in_ngamma_cons_work_tail; assumption.
intros eq;  rewrite eq; clear eq c0.
apply der_ab.
apply sound.
apply in_ngamma_cons_work_head.
Qed.

Lemma nsound_shift_work_ai_strength :
 forall (i : Int) (bs work : nf_list) (ds : disjs)
   (ni : nested_imps) (ai ai' : atomic_imps) (a a' : atoms)
   (context : flist),
 EQUIV_INS unit i (fun _ : unit => tt) tt a a' ->
 LOOKUP nf_list i ai bs ->
 EQUIV_DEL nf_list i ai ai' ->
 nsound work ds ni ai a' context -> nsound (bs ++ work) ds ni ai' a' context.
intros i bs work ds ni ai ai' a a' context equiv_ins lookup equiv_del sound.
apply nsound_app_work; try assumption.
intros n b nth.
apply derivable_a_a_imp_b__derivable_b with (Atom i).
apply sound with (c := NAtom i).
apply in_ngamma_ins_a_head with a; assumption.
apply sound with (c := AImp i b).
apply In_Atomic_Imps with (i := i) (b := b) (n := n) (bs := bs); assumption.
apply nsound_del_ai with i ai; assumption.
Qed.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Theory.Core Compilers.Compilers Elab.Elab Elab.ElabCompilers
  Tools.Matches.
From Pyrosome.Lang Require Import SimpleVSubst SimpleVCPS SimpleEvalCtx SimpleEvalCtxCPS
     SimpleUnit NatHeap SimpleVCPSHeap SimpleVCC.
Import Core.Notations.
(*TODO: repackage this in compilers*)
Import CompilerDefs.Notations.

Require Coq.derive.Derive.

(*TODO: make this divide more sensible*)
Definition heap_id'_def : compiler :=
  match # from (unit_lang ++ heap ++ nat_exp++ nat_lang) with
  | {{s #"heap"}} => {{s#"heap"}}
  end.

Derive heap_id'
       SuchThat (elab_preserving_compiler subst_cc
                                          (heap_cps_ops (*TODO: remove via lemma*)
                                             ++ cc_lang (*TODO: remove via lemma*)
                                             ++ prod_cc
                                             ++ cps_prod_lang
                                             ++ unit_lang
                                             ++ heap
                                             ++ nat_exp
                                             ++ nat_lang
                                             ++ block_subst
                                             ++ value_subst)
                                          heap_id'_def
                                          heap_id'
                                          (unit_lang ++ heap ++ nat_exp++ nat_lang))
       As heap_id'_preserving.
Proof.
  auto_elab_compiler.
  - cleanup_elab_after eredex_steps_with heap "heap_comm".
  - cleanup_elab_after eredex_steps_with heap "lookup_miss".
  - cleanup_elab_after eredex_steps_with heap "lookup_empty".
Qed.
#[export] Hint Resolve heap_id'_preserving : elab_pfs.

(*TODO: move to value_subst? could conflict w/ cmp_forget
  not currently used
TODO: variant of one in SimpleVCC.v
*)
(*TODO: generalize? reverse for tactics?*)
Definition forget_eq_wkn'_def : lang :=
  {[l
      [:= "G" : #"env", "A" : #"ty"
         ----------------------------------------------- ("forget_eq_wkn")
         #"cmp" #"wkn" #"forget" = #"forget"
         : #"sub" (#"ext" "G" "A") #"emp"
      ]
  ]}.
Derive forget_eq_wkn'
       SuchThat (elab_lang_ext value_subst
                               forget_eq_wkn'_def
                               forget_eq_wkn')
       As forget_eq_wkn'_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve forget_eq_wkn'_wf : elab_pfs.

Definition heap_cc_def : compiler :=
  match # from heap_cps_ops with
  | {{s #"configuration" "G"}} =>
    {{s #"configuration" (#"ext" #"emp" "G")}}
  | {{e #"config" "H" "G" "A" "e"}} =>
    {{e #"config" "H" "e"}}
  | {{e #"get" "G" "v" "e"}} =>
    {{e #"get" "v" (#"blk_subst" (#"snoc" #"forget" (#"pair" {ovar 1} #"hd")) "e")}}
  | {{e #"set" "G" "v" "v'" "e" }} =>
    {{e #"set" "v" "v'" "e" }}
  end.

(*TODO: make proof brief*)
Derive heap_cc
       SuchThat (elab_preserving_compiler (heap_id'++subst_cc)
                                          (heap_cps_ops
                                             ++ cc_lang
                                             ++ prod_cc
                                             ++ forget_eq_wkn'
                                             ++ cps_prod_lang
                                             ++ unit_lang
                                             ++ heap
                                             ++ nat_exp
                                             ++ nat_lang
                                             ++ block_subst
                                             ++ value_subst)
                                          heap_cc_def
                                          heap_cc
                                          heap_cps_ops)
       As heap_cc_preserving.
Proof.
  auto_elab_compiler.
  {
    reduce.
    repeat (term_cong; unfold Model.eq_term; try term_refl; compute_eq_compilation).
    eapply eq_term_trans; cycle 1.
    {
      term_cong; unfold Model.eq_term.
      - term_refl.
      - term_refl.
      - compute_eq_compilation.
        estep_under forget_eq_wkn' "forget_eq_wkn".
      - term_refl.
      - term_refl.
    }
    compute_eq_compilation.
    eapply eq_term_trans; cycle 1.
    1:estep_under value_subst "cmp_snoc".
    compute_eq_compilation.
    eapply eq_term_trans; cycle 1.
    {
      term_cong; unfold Model.eq_term.
      - term_refl.
      - term_refl.
      - term_refl.
      - term_refl.
      - compute_eq_compilation.
        eapply eq_term_trans; cycle 1.
        {
          term_cong; unfold Model.eq_term.
          - term_refl.
          - term_refl.
          -
            eapply eq_term_trans; cycle 1.
            {
              compute_eq_compilation.
              eredex_steps_with forget_eq_wkn' "forget_eq_wkn".
            }
            compute_eq_compilation.
            {
              term_cong; unfold Model.eq_term.
              - term_refl.
              - term_refl.
              - term_refl.
              - term_refl.
              - compute_eq_compilation.
                eredex_steps_with value_subst "id_emp_forget".
            }
          - term_refl.
          - term_refl.
        }
        compute_eq_compilation.
        eapply eq_term_trans; cycle 1.
        {
          term_cong; unfold Model.eq_term.
          - term_refl.
          - term_refl.
          - eapply eq_term_sym.
            eredex_steps_with value_subst "id_right".
          - term_refl.
          - term_refl.
        }
        compute_eq_compilation.
        by_reduction.
    }
    eapply eq_term_trans; cycle 1.
    {
      eapply eq_term_sym.
      eredex_steps_with value_subst "id_right".
    }
    compute_eq_compilation.
    term_refl.
  }
  {
    compute_eq_compilation.
    eapply eq_term_trans.
    {
      eredex_steps_with heap_cps_ops "eval get".
    }
    compute_eq_compilation.
    reduce.
    term_cong; try term_refl; unfold Model.eq_term; compute_eq_compilation.
    term_cong; try term_refl; unfold Model.eq_term; compute_eq_compilation.
    term_cong; try term_refl; unfold Model.eq_term; compute_eq_compilation.
    eapply eq_term_trans.
    {
      eapply eq_term_sym.
      eredex_steps_with forget_eq_wkn' "forget_eq_wkn".
    }
    compute_eq_compilation.
    eapply eq_term_trans; cycle 1.
    {
      eredex_steps_with value_subst "id_right".
    }
    compute_eq_compilation.
    term_cong; try term_refl; unfold Model.eq_term; compute_eq_compilation.
    by_reduction.
  }
Unshelve.
  all: repeat t'.
Qed.
#[export] Hint Resolve heap_cc_preserving : elab_pfs.