Require Import Common.Definitions.
Require Import Common.Util.
Require Export Common.Values.
Require Export Common.Linking.
Require Import Common.Memory.
Require Import Lib.Monads.
Require Import Lib.Extra.

From mathcomp Require Import ssreflect ssrfun ssrbool seq eqtype.
From extructures Require Import fmap.

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

Set Bullet Behavior "Strict Subproofs".

(* NOTE: Technically a [Variant], i.e., there is no use for the [Inductive]
   principle in proofs, but it is required to derive a QuickChick generator. *)
Inductive register : Type :=
  R_ONE | R_COM | R_AUX1 | R_AUX2 | R_RA | R_SP | R_ARG.

Definition label := nat.

Variant imvalue : Type :=
| IInt : Z -> imvalue
| IPtr : Pointer.t -> imvalue.

Definition imm_to_val (im : imvalue) : value :=
  match im with
  | IInt n => Int n
  | IPtr p => Ptr p
  end.

Variant instr :=
| INop : instr
| ILabel : label -> instr
(* register operations *)
| IConst : imvalue -> register -> instr
| IMov : register -> register -> instr
| IBinOp : binop -> register -> register -> register -> instr
(* memory operations *)
| ILoad : register -> register -> instr
| IStore : register -> register -> instr
| IAlloc : register -> register -> instr
(* conditional and unconditional jumps *)
| IBnz : register -> label -> instr
| IJump : register -> instr
| IJal : label -> instr
(* components interaction *)
| ICall : Component.id -> Procedure.id -> instr
| IReturn : instr
(* termination *)
| IHalt : instr.

Definition code := list instr.

Module Intermediate.

Module Register.
  Definition t : Type := NMap value.

  Definition to_nat (r : register) : nat :=
    match r with
    | R_ONE  => 0
    | R_COM  => 1
    | R_AUX1 => 2
    | R_AUX2 => 3
    | R_RA   => 4
    | R_SP   => 5
    | R_ARG  => 6
    end.

  Definition init :=
    mkfmap [(to_nat R_ONE, Undef);
            (to_nat R_COM, Undef);
            (to_nat R_AUX1, Undef);
            (to_nat R_AUX2, Undef);
            (to_nat R_RA, Undef);
            (to_nat R_SP, Undef);
            (to_nat R_ARG, Undef)].

  Definition get (r : register) (regs : t) : value :=
    match getm regs (to_nat r) with
    | Some val => val
    (* this should never happen (i.e. regs should be well-formed) *)
    | None => Undef
    end.

  Definition set (r : register) (val : value) (regs : t) : t :=
    setm regs (to_nat r) val.

  Definition invalidate (regs : t) : t :=
    mkfmap [(to_nat R_ONE, Undef);
            (to_nat R_COM, get R_COM regs);
            (to_nat R_AUX1, Undef);
            (to_nat R_AUX2, Undef);
            (to_nat R_RA, Undef);
            (to_nat R_SP, Undef);
            (to_nat R_ARG, Undef)].

  Lemma invalidate_eq : forall regs1 regs2,
    get R_COM regs1 = get R_COM regs2 ->
    invalidate regs1 = invalidate regs2.
  Proof.
    intros regs1 regs2 Hregs.
    unfold invalidate.
    congruence.
  Qed.
End Register.

Module EntryPoint.
  Definition t := NMap (NMap Block.id).

  Definition get (C: Component.id) (P: Procedure.id) (E: t) : option Block.id :=
    match getm E C with
    | Some addrs => getm addrs P
    | None => None
    end.

  Lemma get_some C P E b : get C P E = Some b -> C \in domm E.
  Proof.
    unfold get. intros Hget.
    destruct (E C) as [M |] eqn:Hcase; last discriminate.
    apply /dommP. eauto.
  Qed.
End EntryPoint.

(* programs *)

Record program := mkProg {
  prog_interface: Program.interface;
  prog_procedures: NMap (NMap code);
  prog_buffers: NMap {fmap Block.id -> nat + list value};
  prog_main: bool
}.

(* well-formedness of programs *)

Definition well_formed_instruction
           (p: program) (C: Component.id) (P: Procedure.id) (i: instr) : Prop :=
  match i with
  | IBnz r l =>
    (* the branch refers to a label inside the current procedure C.P *)
    exists Cprocs Pcode,
      getm (prog_procedures p) C = Some Cprocs /\
      getm Cprocs P = Some Pcode /\
      In (ILabel l) Pcode
  | IJal l =>
    (* the jump refers to a label inside the current component C *)
    exists Cprocs P' P'code,
      getm (prog_procedures p) C = Some Cprocs /\
      getm Cprocs P' = Some P'code /\
      In (ILabel l) P'code
  | ICall C' P' =>
    (* a call is well-formed only if it targets another component and the
       interface is allowing it to happen *)
    C <> C' /\ imported_procedure (prog_interface p) C C' P'
  | IConst (IPtr ptr) r =>
    (* static pointers refers to static buffers *)
    exists bufs,
      getm (prog_buffers p) (Pointer.component ptr) = Some bufs /\
      In (Pointer.block ptr) (map fst bufs)
  (* the other instruction are well-formed by construction *)
  | IConst (IInt i) r => True
  | ILabel l => True
  | INop => True
  | IMov r1 r2 => True
  | IBinOp bop r1 r2 r3 => True
  | ILoad r1 r2 => True
  | IStore r1 r2 => True
  | IAlloc r1 r2 => True
  | IJump r => True
  | IReturn => True
  | IHalt => True
  end.

Record well_formed_program (p: program) := {
  (* the interface is sound (but maybe not closed)
     RB: Currently not used in the proofs. *)
  wfprog_interface_soundness:
    sound_interface (prog_interface p);
  (* there are procedures only for the declared components *)
  wfprog_defined_procedures:
    domm (prog_interface p) = domm (prog_procedures p);
  (* each exported procedure actually exists *)
  wfprog_exported_procedures_existence:
    forall C CI,
      getm (prog_interface p) C = Some CI ->
    forall P,
      Component.is_exporting CI P ->
    exists Cprocs Pcode,
      getm (prog_procedures p) C = Some Cprocs /\
      getm Cprocs P = Some Pcode;
  (* each instruction of each procedure is well-formed *)
  wfprog_well_formed_instructions:
    forall C Cprocs,
      getm (prog_procedures p) C = Some Cprocs ->
    forall P Pcode,
      getm Cprocs P = Some Pcode ->
    forall i, In i Pcode -> well_formed_instruction p C P i;
  (* there are buffers only for the declared components *)
  wfprog_defined_buffers:
    domm (prog_interface p) = domm (prog_buffers p);
  (* if the main component exists, then the main procedure must exist as well *)
  wfprog_main_existence:
      prog_main p ->
    exists main_procs,
      getm (prog_procedures p) Component.main = Some main_procs /\ Procedure.main \in domm main_procs;
  (* Iff the main component is in the interface, a main procedure is given. *)
  wfprog_main_component:
    (* (RB: Old-style fix, later changed from a simple implication.) *)
    (* prog_main p = None -> *)
    (* Component.main \notin domm (prog_interface p) *)
    Component.main \in domm (prog_interface p) <->
    prog_main p;
  (* wfprog_main_id: *)
  (*   forall mainP, *)
  (*     prog_main p = Some mainP -> *)
  (*     mainP = 0 *)
}.

(* a closed program is a program with a closed interface and an existing main
   procedure *)
Record closed_program (p: program) := {
  (* the interface must be closed (and consequently sound) *)
  cprog_closed_interface:
    closed_interface (prog_interface p);
  (* the main procedure must exist *)
  cprog_main_existence:
    exists main_procs,
      prog_main p /\
      getm (prog_procedures p) Component.main = Some main_procs /\ 0 \in domm main_procs
}.

Definition linkable_mains (prog1 prog2 : program) : Prop :=
  ~~ (prog_main prog1 && prog_main prog2).

Lemma linkable_mains_sym : forall (prog1 prog2 : program),
  linkable_mains prog1 prog2 -> linkable_mains prog2 prog1.
Proof.
  intros prog1 prog2.
  unfold linkable_mains, andb, negb.
  destruct (prog_main prog1);
    destruct (prog_main prog2);
    intuition.
Qed.

(* RB: TODO: Remove superfluous linkable_main assumptions from development.
   Observe the relation to PS.domm_partition_in_union_in_neither. *)
Theorem linkable_implies_linkable_mains : forall (p1 p2 : program),
  well_formed_program p1 ->
  well_formed_program p2 ->
  linkable (prog_interface p1) (prog_interface p2) ->
  linkable_mains p1 p2.
Proof.
  intros p1 p2 Hwf1 Hwf2 [_ Hdisjoint].
  unfold linkable_mains.
  destruct (prog_main p1) as [|] eqn:Hmain1;
    destruct (prog_main p2) as [|] eqn:Hmain2;
    try reflexivity.
  (* All that remains is the contradictory case. *)
  pose proof (proj2 (wfprog_main_component Hwf1)) as Hdomm1.
  rewrite Hmain1 in Hdomm1. specialize (Hdomm1 isT).
  pose proof (proj2 (wfprog_main_component Hwf2)) as Hdomm2.
  rewrite Hmain2 in Hdomm2. specialize (Hdomm2 isT).
  pose proof fdisjointP _ _ Hdisjoint _ Hdomm1 as Hcontra.
  now rewrite Hdomm2 in Hcontra.
Qed.

Definition matching_mains (prog1 prog2 : program) : Prop :=
  prog_main prog1 <-> prog_main prog2.

Definition program_link (p1 p2: program): program :=
  {| prog_interface := unionm (prog_interface p1) (prog_interface p2);
     prog_procedures := unionm (prog_procedures p1) (prog_procedures p2);
     prog_buffers := unionm (prog_buffers p1) (prog_buffers p2);
     prog_main := prog_main p1 || prog_main p2 |}.

Lemma program_linkC p1 p2 :
  well_formed_program p1 ->
  well_formed_program p2 ->
  linkable (prog_interface p1) (prog_interface p2) ->
  program_link p1 p2 = program_link p2 p1.
Proof.
  case: p1 p2 => [i1 p1 b1 m1] [i2 p2 b2 m2] /= Hwf1 Hwf2 [_ Hdis_i].
  have Hdis_p: fdisjoint (domm p1) (domm p2).
    by rewrite -(wfprog_defined_procedures Hwf1) -(wfprog_defined_procedures Hwf2).
  congr mkProg=> /=; try rewrite unionmC //.
    by rewrite -(wfprog_defined_buffers Hwf1) -(wfprog_defined_buffers Hwf2).
      by rewrite orb_comm.
Qed.

Theorem linking_well_formedness:
  forall p1 p2,
    well_formed_program p1 ->
    well_formed_program p2 ->
    linkable (prog_interface p1) (prog_interface p2) ->
    well_formed_program (program_link p1 p2).
Proof.
  move=> p1 p2 Hwf1 Hwf2 [Hsound Hdis_i]; split=> //.
  - simpl.
    repeat rewrite domm_union.
    by do 2![rewrite wfprog_defined_procedures //].
  - move=> /= C CI H1 P H2.
    rewrite unionmE -mem_domm -(wfprog_defined_procedures Hwf1) !mem_domm.
    rewrite unionmE in H1.
    case Hwhere: (prog_interface p1 C) H1 => [CI'|] //=.
    + move=> [?]; subst CI'.
      destruct (wfprog_exported_procedures_existence Hwf1 Hwhere H2)
        as [Cprocs [Pcode [Hproc Hcode]]].
      rewrite Hproc. simpl.
      exists Cprocs. exists Pcode.
      split; auto.
    + suffices Hno_p1 : prog_procedures p1 C = None.
        move=> H1.
        destruct (wfprog_exported_procedures_existence Hwf2 H1 H2)
          as [Cprocs [Pcode [Hproc Hcode]]].
        exists Cprocs. exists Pcode.
        split; auto.
      now apply/dommPn; rewrite -(wfprog_defined_procedures Hwf1); apply/dommPn.
  - move=> C Cprocs H1 P Pcode H2.
    without loss H: p1 p2 Hwf1 Hwf2 Hsound Hdis_i H1 / prog_procedures p1 C = Some Cprocs.
    { move: H1; rewrite /= unionmE.
      case e: (prog_procedures p1 C)=> [Cprocs'|] //=.
        move=> [<-]; apply=> //.
        by rewrite unionmE e.
      move=> Hp2_C Hgen i Hi; rewrite program_linkC //.
      apply Hgen=> //.
      + by rewrite unionmC // fdisjointC.
      + by rewrite fdisjointC.
      + by rewrite unionmE Hp2_C. }
    move=> i Hi.
    move: (wfprog_well_formed_instructions Hwf1 H H2 Hi).
    case: i Hi=> //=.
    + (* IConst *)
      case=> // ptr r Hi [bufs [p1_bufs Hbufs]].
      by exists bufs; rewrite unionmE p1_bufs.
    + (* IBnz *)
      move=> r l Hi [Cprocs' [Pcode']].
      rewrite H=> - [[<-] {Cprocs'}].
      rewrite H2=> - [[<-] {Pcode'}] Hl.
      by exists Cprocs, Pcode; rewrite unionmE H.
    + (* IJal *)
      move=> l Hi [Cprocs' [P' [Pcode']]].
      rewrite H=> - [[<-] {Cprocs'}].
      case=> H2' Hl.
      by exists Cprocs, P', Pcode'; rewrite unionmE H.
    + (* ICall *)
      move=> C' P' Hi [CC' [CI [p1_C Himport]]]; split=> //.
      exists CI; split=> //.
      by rewrite /Program.has_component unionmE p1_C.
  - rewrite /= !domm_union.
    by do 2![rewrite wfprog_defined_buffers //].
  - rewrite /=. case /orP => [mainP | mainP].
    + have Hmain1 := @wfprog_main_existence _ Hwf1 mainP.
      case: Hmain1 => [main_procs [p1_main HmainP]] //=.
        by exists main_procs; rewrite unionmE p1_main.
    + have Hmain2 := @wfprog_main_existence _ Hwf2 mainP.
      case: Hmain2 => [main_procs [p2_main HmainP]] //=.
      exists main_procs; rewrite unionmC 1?unionmE 1?p2_main //.
      by rewrite -(wfprog_defined_procedures Hwf1) -(wfprog_defined_procedures Hwf2).
  - inversion Hwf1 as [_ _ _ _ _ _ Hmain_comp1].
    inversion Hwf2 as [_ _ _ _ _ _ Hmain_comp2].
    split;
      intros Hprog_main1.
    + assert (Hprog_main2 := Hprog_main1).
      simpl in *.
      destruct (Component.main \in domm (prog_interface p1)) eqn:Hcase1;
        destruct (Component.main \in domm (prog_interface p2)) eqn:Hcase2.
      * (* Contra/easy. *)
        pose proof (proj1 Hmain_comp1 Hcase1) as Hmain1. now rewrite Hmain1.
      * apply proj1 in Hmain_comp1.
        specialize (Hmain_comp1 Hcase1). rewrite Hmain_comp1. by [].
      * destruct (prog_main p1) as [main1 |] eqn:Hmain1.
        -- reflexivity.
        -- apply proj1 in Hmain_comp2.
           specialize (Hmain_comp2 Hcase2). assumption.
      * (* Contra. *)
        destruct (@dommP _ _ _ _ Hprog_main1) as [CI HCI]. rewrite unionmE in HCI.
        apply negb_true_iff in Hcase1. apply negb_true_iff in Hcase2.
        now rewrite (@dommPn _ _ _ _ Hcase1) (@dommPn _ _ _ _ Hcase2) in HCI.
    + inversion Hprog_main1 as [Hmain].
      destruct (prog_main p1) as [main1 |] eqn:Hcase1;
        destruct (prog_main p2) as [main2 |] eqn:Hcase2.
      * (* Contra/easy. RB: NOTE: Three cases can be solved as instances of a
           little lemma, or a tactic. Is it useful elsewhere? *)
        apply proj2 in Hmain_comp1. specialize (Hmain_comp1 isT).
        destruct (@dommP _ _ _ _ Hmain_comp1) as [CI HCI].
        apply /dommP. exists CI. now rewrite unionmE HCI.
      * apply proj2 in Hmain_comp1. specialize (Hmain_comp1 isT).
        destruct (@dommP _ _ _ _ Hmain_comp1) as [CI HCI].
        apply /dommP. exists CI. now rewrite unionmE HCI.
      * apply proj2 in Hmain_comp2. specialize (Hmain_comp2 isT).
        destruct (@dommP _ _ _ _ Hmain_comp2) as [CI HCI].
        apply /dommP. exists CI. simpl. now rewrite (unionmC Hdis_i) unionmE HCI.
      * discriminate.
Qed.

(* Given a list of components, create the map that associates to
   each component the preallocated buffers according to program p.
   If no buffers are found, use the empty map as a default (this
   will not happen in regular use!). *)
Definition alloc_static_buffers p comps :=
  mkfmapf (fun C =>
    ComponentMemory.prealloc (odflt emptym (prog_buffers p C))) comps.

Definition prepare_initial_memory (p: program) : Memory.t :=
  alloc_static_buffers p (domm (prog_interface p)).

(* RB: Are the names of reserve_[component|procedure]_blocks swapped? *)
(* For each pair of procedure id and code in procs_code, build the triad of
   component memory, procedure code map and component entry point map by
   folding over them:
    - Reserve a new block id in the component memory.
    - Map that block id to the procedure code in the procedure block map.
    - If the procedure is public, map the procedure id to the memory block id
      in the component entry point map.
   From the calling point, observe on the one hand that the initial values of
   the accumulators are the existing component memory and two empty maps. On the
   other hand, observe also that procs_code are the contents of a map in
   associative list form, and each procedure is is therefore unique. *)
Definition reserve_component_blocks' p C acc procs_code
  : ComponentMemory.t * NMap code * NMap Block.id :=
  let is_main_proc comp_id proc_id :=
      match prog_main p with
      | true =>
        (Component.main =? comp_id) && (Procedure.main =? proc_id)
      | false => false
      end in
  let aux acc procs_code :=
      let '(Cmem, Cprocs, Centrypoints) := acc in
      let '(P, Pcode) := procs_code in
    let (Cmem', b) := ComponentMemory.reserve_block Cmem in
    let Cprocs' := setm Cprocs b Pcode in
    (* if P is exported or is the main procedure, add an external entrypoint *)
    match getm (prog_interface p) C with
    | Some Ciface =>
      if (P \in Component.export Ciface) || is_main_proc C P then
        let Centrypoints' := setm Centrypoints P b in
        (Cmem', Cprocs', Centrypoints')
      else
        (Cmem', Cprocs', Centrypoints)
    | None =>
      (* this case shouldn't happen for well formed p *)
      (Cmem', Cprocs', Centrypoints)
    end
  in fold_left aux procs_code acc.

(* The simplified version substitutes the accumulator for the component memory.
   It reserves as many new memory blocks as needed at once (one for each item in
   procs_code) and in the process obtains the new component memory, exploiting
   the independence of the operations on each item in procs_code in what follows.
    - Zip the list of new blocks matching the list of procedure code and create a
      new piecewise map from it.
    - Zip the list of procedure ids and the list of new block ids and create a
      partial map from it, refactoring the code handling entry points in the old
      function.
   If the new function to reserve a number of blocks does not present new blocks
   in the same order as the sequential run, slightly different, but isomorphic,
   maps may be produced. *)
Definition reserve_component_blocks p C Cmem procs_code
  : ComponentMemory.t * NMap code * NMap Block.id :=
  let is_main_proc comp_id proc_id :=
      match prog_main p with
      | true =>
        (Component.main =? comp_id) && (Procedure.main =? proc_id)
      | false => false
      end in
  (* if P is exported or is the main procedure, add an external entrypoint *)
  let map_entrypoint '(P, b) :=
      match getm (prog_interface p) C with
      | Some Ciface =>
        if (P \in Component.export Ciface) || is_main_proc C P then Some (P, b)
        else None
      | None => None (* this case shouldn't happen for well formed p *)
      end in
  let (Cmem', bs) := ComponentMemoryExtra.reserve_blocks Cmem (length procs_code) in
  let (procs, code) := (unzip1 procs_code, unzip2 procs_code) in
  let Cprocs := mkfmap (zip bs code) in
  let Centrypoints := mkfmap (pmap map_entrypoint (zip procs bs)) in
  (Cmem', Cprocs, Centrypoints).

(* In the foreseen, controlled use of this function, we always go on the Some
   branch. For each component C, we read its (initial) memory and use it to
   construct the initial state of C, recursing after we update its maps. Given
   identical inputs (component memories, which we have by compositionality of
   that piece of code) the outputs will be identical. *)
(* For each pair of component id and component procedures in comps_code, build
   the triad of program memory memory, component code map and entry point map by
   folding over them. For each pair, reserve component blocks and update the maps
   for the current component.
     As in the function to reserve component blocks, from the calling point,
   observe that the initial values of the accumulators are, again, the existing
   memory, partially initialized, and two empty maps; and that, again, comps_proc
   is an alternative representation of a map, and the procedure on each pair is
   independent from all others. *)
Fixpoint reserve_procedure_blocks' p acc comps_code
  : Memory.t * NMap (NMap code) * EntryPoint.t :=
  let aux acc comps_code :=
      let '(mem, procs, entrypoints) := acc in
      let '(C, Cprocs) := comps_code in
    match getm mem C with
    | Some Cmem =>
      let '(Cmem', Cprocs, Centrypoints) :=
          reserve_component_blocks' p C (Cmem, emptym, emptym) (elementsm Cprocs) in
      let mem' := setm mem C Cmem' in
      let procs' := setm procs C Cprocs in
      let entrypoints' := setm entrypoints C Centrypoints in
      (mem', procs', entrypoints')
    | None =>
      (* this shouldn't happen if memory was initialized before the call *)
      (* we just skip initialization for this component *)
      (mem, procs, entrypoints)
    end
  in fold_left aux comps_code acc.

(* The simplified function builds a partial map by applying the refactored
   per-component process over each pair, noting that in some cases (which should
   never occur!) initialization is skipped, then unpack the parts and repack them
   in the expected map formats.
     Note that we are creating a new memory instead of explicitly updating the
   old memory. Both processes should be equivalent if the map is actually total,
   as is expected. *)
Fixpoint reserve_procedure_blocks p (mem : Memory.t) comps_code
  : Memory.t * NMap (NMap code) * EntryPoint.t :=
  let map_component_memory '(C, Cprocs) :=
    match getm mem C with
    | Some Cmem => Some (C, reserve_component_blocks p C Cmem (elementsm Cprocs))
      (* this shouldn't happen if memory was initialized before the call *)
      (* we just skip initialization for this component *)
    | None => None
    end in
  let acc := pmap map_component_memory comps_code in
  let '(comps', mems, procs, eps) := (unzip1 acc, unzip1 (unzip1 (unzip2 acc)),
                                      unzip2 (unzip1 (unzip2 acc)), unzip2 (unzip2 acc)) in
  (mkfmap (zip comps' mems), mkfmap (zip comps' procs), mkfmap (zip comps' eps)).

(* RB: TODO: Make sure these functions are only used with initial memories. *)
Definition prepare_procedures' (p: program) (mem: Memory.t)
  : Memory.t * NMap (NMap code) * EntryPoint.t :=
  reserve_procedure_blocks' p (mem, emptym, emptym) (elementsm (prog_procedures p)).

(* The main function to prepare the procedures of a program from a memory simply
   calls the helper, now without a trivial accumulator. *)
Definition prepare_procedures (p: program) (mem: Memory.t)
  : Memory.t * NMap (NMap code) * EntryPoint.t :=
  reserve_procedure_blocks p mem (elementsm (prog_procedures p)).

(* For each component, integrate the (now separate) fetching of its procedures,
   obtention of its initial component memory and then reserve_component_blocks.
   The logic of reserve_procedure_blocks is implicit in the map-like nature of
   its results. (By splitting the definition and proving some intermediate
   results on the auxiliary, the composition of the parts will be easier.) *)
(* Definition prepare_procedures_initial_memory_aux (p: program) := *)
(*   mkfmapf *)
(*     (fun C => *)
(*        let Cprocs := odflt emptym ((prog_procedures p) C) in *)
(*        let Cmem := ComponentMemory.prealloc (odflt emptym ((prog_buffers p) C)) in *)
(*        reserve_component_blocks p C (Cmem, emptym, emptym) (elementsm Cprocs)) *)
(*     (domm (prog_interface p)). *)

Definition prepare_procedures_initial_memory_aux' (p: program) :=
  mkfmapf
    (fun C =>
       let Cprocs := odflt emptym ((prog_procedures p) C) in
       let Cmem := ComponentMemory.prealloc (odflt emptym ((prog_buffers p) C)) in
       reserve_component_blocks' p C (Cmem, emptym, emptym) (elementsm Cprocs))
    (domm (prog_interface p)).

(* As above, replace the old function with the new, and remove accumulators. *)
Definition prepare_procedures_initial_memory_aux (p: program) :=
  mkfmapf
    (fun C =>
       let Cprocs := odflt emptym ((prog_procedures p) C) in
       let Cmem := ComponentMemory.prealloc (odflt emptym ((prog_buffers p) C)) in
       reserve_component_blocks p C Cmem (elementsm Cprocs))
    (domm (prog_interface p)).

(* Ultimately, we want this equivalence -- possibly modulo an isomorphism on
   concrete block id values -- to hold. *)
Theorem prepare_procedures_initial_memory_aux_equiv (p: program) :
  prepare_procedures_initial_memory_aux p = (* New version. *)
  prepare_procedures_initial_memory_aux' p. (* Old version. *)
Proof.
Admitted.

(* Decompose the results of the auxiliary call, composed as a whole in the
   result of reserving component blocks, turning a map of triples into a triple
   of identically indexed maps *)
Definition prepare_procedures_initial_memory (p: program)
  : Memory.t * NMap (NMap code) * EntryPoint.t :=
  let m := prepare_procedures_initial_memory_aux p in
  (mapm (fun x => x.1.1) m, mapm (fun x => x.1.2) m, mapm snd m).

(* We want to ensure something like this:
     Goal
       forall p, prepare_procedures_initial_memory p =
                 prepare_procedures p (prepare_initial_memory p).
  Possibly assuming the well-formedness of the program. *)
Theorem prepare_procedures_initial_memory_equiv :
  forall p,
    prepare_procedures_initial_memory p =
    prepare_procedures p (prepare_initial_memory p).
Admitted.

(* initialization of a linked program *)

Definition prepare_procedures_memory (p: program) : Memory.t :=
  let '(mem, _, _) := prepare_procedures_initial_memory p in
  mem.

(* RB: TODO: Relocate these simple helpers, review names, etc.
   For now, trying to keep cruft out of the higher-level proofs. *)
Lemma mapm_eq: forall (T : ordType) (S S' : Type) (m1 m2 : {fmap T -> S}) (f : S -> S'),
  m1 = m2 -> (mapm f m1) = (mapm f m2).
Proof.
  intros T S S' m1 m2 f Heq.
  subst.
  reflexivity.
Qed.

Lemma in_domm_program_link:
  forall Cid p,
    Cid \in domm (prog_interface p) ->
  forall c,
    Cid \in domm (prog_interface (program_link p c)).
Proof.
  intros Cid p Hin c.
  simpl.
  rewrite mem_domm.
  rewrite mem_domm in Hin.
  rewrite unionmE.
  rewrite Hin.
  assumption.
Qed.

Lemma domm_partition_program_link_in_neither p c :
  well_formed_program p ->
  well_formed_program c ->
  closed_program (program_link p c) ->
  Component.main \notin domm (prog_interface p) ->
  Component.main \notin domm (prog_interface c) ->
  False.
Proof.
  intros [_ _ _ _ _ _ [_ Hmainp]] [_ _ _ _ _ _ [_ Hmainc]]
         [_ [main [Hmain [_ _]]]] Hmainp' Hmainc'.
  destruct (prog_main p) as [|] eqn:Hcasep.
  - specialize (Hmainp is_true_true).
    rewrite Hmainp in Hmainp'.
    discriminate.
  - destruct (prog_main c) as [|] eqn:Hcasec.
    +  specialize (Hmainc is_true_true).
       rewrite Hmainc in Hmainc'.
       discriminate.
    + simpl in Hmain.
      rewrite Hcasep Hcasec in Hmain.
      discriminate.
Qed.

Lemma fsetid (T : ordType) (s: seq.seq T) :
  fset (fset s) = fset s.
Proof. by apply /eq_fset => x; rewrite in_fset. Qed.

(* First, prove domain preservation for all of the (already existing, plus
   recent improvements) initialization code. *)
Lemma domm_prepare_procedures_initial_memory_aux: forall p,
  (*well_formed_program p ->*)
  domm (prepare_procedures_initial_memory_aux p) = domm (prog_interface p).
Proof.
  intros p.
  unfold prepare_procedures_initial_memory_aux.
  rewrite domm_mkfmapf.
  apply fsetid.
Qed.

(* FG : maybe relocate this in extructures? (when rewritten in proper SSReflect) *)
Lemma fdisjoint_partition_notinboth (T: ordType) (s1 s2 : {fset T}) :
  fdisjoint s1 s2 ->
  forall x,
    x \in s2 ->
    x \in s1 ->
    False.
Proof.
  unfold fdisjoint. move => Hinter x Hs2 Hs1.
  have H' : x \in (s1 :&: s2)%fset by rewrite in_fsetI Hs1 Hs2.
  have H'' : (s1 :&: s2)%fset = fset0 by apply /eqP.
  rewrite H'' in H'. inversion H'.
Qed.

(* Better name, maybe ? *)
(* keeping it generic over program/context *)
Lemma prog_link_procedures_unionm :
  forall p1 p2 Cid,
    well_formed_program p1 ->
    (* well_formed_program p2 -> *)
    (Cid \in domm (prog_interface p1)) = true ->
    (Cid \in domm (prog_interface p2)) = false -> (* not used, to remove  or keep as sanity check ? *)
    (prog_procedures (program_link p1 p2)) Cid = (prog_procedures p1) Cid.
Proof.
  intros p1 p2 Cid Hwfp Hp _.
  rewrite unionmE. rewrite <- mem_domm. inversion Hwfp as [? Hproc _ _ _ _ _]. (* if no binding of 1st hypothesis : anomaly : "make_elim_branch_assumptions" *)
  rewrite Hproc in Hp. rewrite Hp. reflexivity.
Qed.

(* maybe write a tactic that does the core except the inversion ... ? *)
(* or suppress the prog_smth part and keep it generic for all types of program_link ? *)
Lemma prog_link_buffers_unionm :
  forall p1 p2 Cid,
    well_formed_program p1 ->
    (* well_formed_program p2 -> *)
    (Cid \in domm (prog_interface p1)) = true ->
    (Cid \in domm (prog_interface p2)) = false -> (* same *)
    (prog_buffers (program_link p1 p2)) Cid = (prog_buffers p1) Cid.
Proof.
  intros p1 p2 Cid Hwfp Hp _. simpl.
  rewrite unionmE. rewrite <- mem_domm. inversion Hwfp as [? _ _ _ Hbuf _ _]. (* if no binding of 1st hypothesis : anomaly : "make_elim_branch_assumptions" *)
  rewrite Hbuf in Hp. rewrite Hp. reflexivity.
Qed.

(* RB: TODO: Simplify hypotheses if possible. *)
Lemma prepare_procedures_initial_memory_aux_after_linking:
  forall p c,
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    linkable_mains p c ->
    prepare_procedures_initial_memory_aux (program_link p c) =
    unionm (prepare_procedures_initial_memory_aux p)
           (prepare_procedures_initial_memory_aux c).
Proof.
  intros p c Hwfp Hwfc Hlinkable Hmains.
  unfold prepare_procedures_initial_memory_aux.
  apply eq_fmap. intros Cid.
  (* Case analysis on component provenance after some common preprocessing. *)
  destruct (Cid \in domm (prog_interface p)) eqn:Hp;
    destruct (Cid \in domm (prog_interface c)) eqn:Hc.
  - (* Contra. *)
    inversion Hlinkable as [_ Hdisjoint].
    have Hcontra : False by apply (fdisjoint_partition_notinboth Hdisjoint Hc Hp).
    inversion Hcontra.
  - rewrite unionmE.
    rewrite !mkfmapfE.
    rewrite Hp Hc.
    have Hpc : Cid \in domm (prog_interface (program_link p c))
      by apply in_domm_program_link.
    rewrite Hpc.
    have Helts : (elementsm (odflt emptym ((prog_procedures (program_link p c)) Cid))) =
            (elementsm (odflt emptym ((prog_procedures p) Cid)))
      by rewrite (prog_link_procedures_unionm Hwfp Hp Hc).
    rewrite Helts.
    have Hprealloc : ComponentMemory.prealloc (odflt emptym ((prog_buffers (program_link p c)) Cid)) =
            ComponentMemory.prealloc (odflt emptym ((prog_buffers p) Cid))
      by rewrite (prog_link_buffers_unionm Hwfp Hp Hc).
    rewrite Hprealloc.
    simpl.
    unfold reserve_component_blocks.
    rewrite unionmE.
    have [Cid_int Hp']: (exists x, (prog_interface p) Cid = Some x)
      by  apply /dommP.
    rewrite Hp'.
    simpl.
    destruct (prog_main p) as [|] eqn:Hmainp;
      destruct (prog_main c) as [|] eqn:Hmainc.
    + easy. (* Contra. *)
    + reflexivity.
    + destruct Cid as [| n].
      * (* Contra. *)
        inversion Hwfp as [_ _ _ _ _ _ Hmain_compp].
        (* specialize (Hmain_compp Hmainp). *)
        (* have Hp'' : (prog_interface p) 0 = None by apply /dommPn. *)
        (* rewrite Hp'' in Hp'. *)
        apply proj1 in Hmain_compp.
        specialize (Hmain_compp Hp).
        rewrite Hmainp in Hmain_compp.
        discriminate.
      * reflexivity.
    + reflexivity. (* Easy case. *)
  - (* RB: TODO: Refactor symmetric case to last one. *)
    rewrite unionmE.
    rewrite !mkfmapfE.
    rewrite Hp Hc.
    have Hpc : Cid \in domm (prog_interface (program_link p c))
      by rewrite (program_linkC Hwfp Hwfc Hlinkable) ;
      apply in_domm_program_link.
    rewrite Hpc.
    have Helts: (elementsm (odflt emptym ((prog_procedures (program_link p c)) Cid))) =
            (elementsm (odflt emptym ((prog_procedures c) Cid)))
      by rewrite (program_linkC Hwfp Hwfc Hlinkable) (prog_link_procedures_unionm Hwfc Hc Hp).
    rewrite Helts.
    have Hprealloc : ComponentMemory.prealloc (odflt emptym ((prog_buffers (program_link p c)) Cid)) =
            ComponentMemory.prealloc (odflt emptym ((prog_buffers c) Cid))
      by rewrite (program_linkC Hwfp Hwfc Hlinkable) (prog_link_buffers_unionm Hwfc Hc Hp).
    rewrite Hprealloc.
    simpl.
    unfold reserve_component_blocks.
    rewrite unionmE.
    have Hp': (prog_interface p) Cid = None
      by apply /dommPn; rewrite Hp.
    rewrite Hp'.
    have [Cid_int Hc'] : exists x, (prog_interface c) Cid = Some x
      by apply /dommP.
    rewrite Hc'.
    destruct (prog_main p) as [|] eqn:Hmainp;
      destruct (prog_main c) as [|] eqn:Hmainc.
    + (* Contra. *)
      unfold linkable_mains in Hmains.
      rewrite Hmainp Hmainc in Hmains.
      discriminate.
    + simpl. rewrite Hmainp Hmainc.
      destruct Cid as [| n].
      * (* Contra, *)
        inversion Hwfc as [_ _ _ _ _ _ Hmain_compc].
        (* specialize (Hmain_compc Hmainc). *)
        (* have Hc'' : (prog_interface c) 0 = None by apply /dommPn. *)
        (* rewrite Hc'' in Hc'. *)
        apply proj1 in Hmain_compc.
        specialize (Hmain_compc Hc).
        rewrite Hmainc in Hmain_compc.
        discriminate.
      * reflexivity.
    + simpl. rewrite Hmainp Hmainc. reflexivity.
    + simpl. rewrite Hmainp Hmainc. reflexivity.
  - (* in neither, pretty immediate *)
    by rewrite unionmE !mkfmapfE domm_union in_fsetU Hp Hc.
Qed.

(* Now it's easy to extend this to the parts of the final result. *)
Lemma domm_prepare_procedures_memory: forall p,
  domm (prepare_procedures_memory p) = domm (prog_interface p).
Proof.
  intros p.
  unfold prepare_procedures_memory, prepare_procedures_initial_memory.
  rewrite domm_map.
  rewrite domm_prepare_procedures_initial_memory_aux.
  reflexivity.
Qed.

Theorem prepare_procedures_memory_after_linking:
  forall p c,
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    linkable_mains p c ->
    prepare_procedures_memory (program_link p c) =
    unionm (prepare_procedures_memory p) (prepare_procedures_memory c).
Proof.
  intros p c Hwfp Hwfc Hlinkable Hmains.
  unfold prepare_procedures_memory,
         prepare_procedures_initial_memory, prepare_procedures_initial_memory_aux.
  rewrite <- mapm_unionm. apply mapm_eq.
  apply prepare_procedures_initial_memory_aux_after_linking; assumption.
Qed.

(* Search _ prepare_procedures_memory. *)
(* Search _ PS.to_partial_memory unionm. *)
Lemma prepare_procedures_memory_left p c :
  linkable (prog_interface p) (prog_interface c) ->
  to_partial_memory
    (unionm (prepare_procedures_memory p) (prepare_procedures_memory c))
    (domm (prog_interface c)) =
  prepare_procedures_memory p.
Proof.
  intros [_ Hdisjoint].
  unfold to_partial_memory, merge_memories.
  rewrite <- domm_prepare_procedures_memory,
         -> filterm_union,
         -> fdisjoint_filterm_full,
         -> fdisjoint_filterm_empty, -> unionm0;
    first reflexivity;
    try rewrite -> !domm_prepare_procedures_memory; congruence.
Qed.

Lemma prepare_procedures_memory_right p c :
  linkable (prog_interface p) (prog_interface c) ->
  to_partial_memory
    (unionm (prepare_procedures_memory p) (prepare_procedures_memory c))
    (domm (prog_interface p)) =
  prepare_procedures_memory c.
Proof.
  intros Hlinkable.
  rewrite unionmC; try assumption.
  apply prepare_procedures_memory_left with (c := p) (p := c).
  now apply linkable_sym.
  inversion Hlinkable.
  now rewrite !domm_prepare_procedures_memory.
Qed.

Definition prepare_procedures_procs (p: program) : NMap (NMap code) :=
  let '(_, procs, _) := prepare_procedures_initial_memory p in
  procs.

Theorem prepare_procedures_procs_after_linking:
  forall p c,
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    linkable_mains p c ->
    prepare_procedures_procs (program_link p c) =
    unionm (prepare_procedures_procs p) (prepare_procedures_procs c).
Proof.
  intros p c Hwfp Hwfc Hlinkable Hmains.
  unfold prepare_procedures_procs,
         prepare_procedures_initial_memory, prepare_procedures_initial_memory_aux.
  rewrite <- mapm_unionm. apply mapm_eq.
  apply prepare_procedures_initial_memory_aux_after_linking; assumption.
Qed.

Definition prepare_procedures_entrypoints (p: program) : EntryPoint.t :=
  let '(_, _, entrypoints) := prepare_procedures_initial_memory p in
  entrypoints.

Lemma domm_prepare_procedures_entrypoints: forall p,
  domm (prepare_procedures_entrypoints p) = domm (prog_interface p).
Proof.
  intros p.
  unfold prepare_procedures_entrypoints, prepare_procedures_initial_memory.
  rewrite domm_map.
  rewrite domm_prepare_procedures_initial_memory_aux.
  reflexivity.
Qed.

Theorem prepare_procedures_entrypoints_after_linking:
  forall p c,
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    linkable_mains p c ->
    prepare_procedures_entrypoints (program_link p c) =
    unionm (prepare_procedures_entrypoints p)
           (prepare_procedures_entrypoints c).
Proof.
  intros p c Hwfp Hwfc Hlinkable Hmains.
  unfold prepare_procedures_entrypoints,
         prepare_procedures_initial_memory, prepare_procedures_initial_memory_aux.
  rewrite <- mapm_unionm. apply mapm_eq.
  apply prepare_procedures_initial_memory_aux_after_linking; assumption.
Qed.

Corollary prepare_procedures_initial_memory_after_linking:
  forall p c,
    well_formed_program p ->
    well_formed_program c ->
    linkable (prog_interface p) (prog_interface c) ->
    linkable_mains p c ->
    prepare_procedures_initial_memory (program_link p c) =
    (unionm (prepare_procedures_memory p)
            (prepare_procedures_memory c),
     unionm (prepare_procedures_procs p)
            (prepare_procedures_procs c),
     unionm (prepare_procedures_entrypoints p)
            (prepare_procedures_entrypoints c)).
Proof.
  intros p c Hwfp Hwfc Hlinkable Hmains.
  rewrite <- prepare_procedures_memory_after_linking; try assumption.
  rewrite <- prepare_procedures_procs_after_linking; try assumption.
  rewrite <- prepare_procedures_entrypoints_after_linking; try assumption.
  reflexivity.
Qed.

(* RB: Slight "misnomer" because of the presence of matching_mains.
   Closely connected to linkable, but not exactly the same at this
   level. Is there a benefit to combining these two in a definition? *)
Lemma interface_preserves_closedness_r :
  forall p1 p2 p2',
    well_formed_program p1 ->
    well_formed_program p2' ->
    prog_interface p2 = prog_interface p2' ->
    linkable (prog_interface p1) (prog_interface p2) ->
    closed_program (program_link p1 p2) ->
    linkable_mains p1 p2 ->
    matching_mains p2 p2' ->
    closed_program (program_link p1 p2').
Proof.
  intros p1 p2 p2'
         Hwf1 Hwf2' Hsame_int Hlinkable
         [Hclosed [mainP [Hmain [Hprocs]]]]
         Hlinkable_mains Hmatching_mains.
  constructor.
  - simpl in Hclosed.
    rewrite Hsame_int in Hclosed.
    apply Hclosed.
  - destruct (prog_main p1) as [|] eqn:Hmain1;
      destruct (prog_main p2) as [|] eqn:Hmain2.
    + unfold linkable_mains in Hlinkable_mains.
      rewrite Hmain1 Hmain2 in Hlinkable_mains.
      discriminate.
    + (* main is in p1.*)
      (* unfold program_link in Hmain. *)
      (* rewrite Hmain1 in Hmain. *)
      (* simpl in Hmain. *)
      (* inversion Hmain; subst mainP; clear Hmain. *)
      (* Likewise main_procs (used only in second sub-goal). *)
      unfold program_link in Hprocs; simpl in Hprocs.
      destruct (wfprog_main_existence Hwf1 Hmain1)
        as [main_procs1 [Hmain_procs1 Hin1]].
      rewrite unionmE Hmain_procs1 in Hprocs.
      (* inversion Hprocs; subst main_procs; clear Hprocs. *)
      (* Instantiate and solve. *)
      exists main_procs1. split; [| split].
      * unfold program_link.
        rewrite Hmain1.
        reflexivity.
      * unfold program_link; simpl.
        rewrite unionmE Hmain_procs1.
        reflexivity.
      * assumption.
    + (* main is in p2'. *)
      destruct (prog_main p2') as [|] eqn:Hmain2';
      last (destruct Hmatching_mains as [Hmatching_mains _];
            rewrite Hmatching_mains in Hmain2';
            last assumption;
            inversion Hmain2').
      (* Likewise main_procs (used only in second sub-goal). *)
      destruct (wfprog_main_existence Hwf2' Hmain2')
        as [main_procs2' [Hmain_procs2' Hin2']].
      exists main_procs2'. split; [| split].
      * unfold program_link.
        rewrite Hmain1 Hmain2'.
        reflexivity.
      * unfold program_link; simpl.
        inversion Hlinkable as [_ Hdisjoint].
        inversion Hwf1 as [_ Hdomm1 _ _ _ _].
        inversion Hwf2' as [_ Hdomm2' _ _ _ _].
        rewrite Hsame_int Hdomm1 Hdomm2' in Hdisjoint.
        rewrite (unionmC Hdisjoint) unionmE Hmain_procs2'.
        reflexivity.
      * assumption.
    + simpl in Hmain.
      rewrite Hmain1 in Hmain.
      rewrite Hmain2 in Hmain.
      discriminate.
Qed.

(* RB: TODO: Revisit uses of matching_mains as hypotheses and see when they can
   be removed due to their being derivable from this result. *)
Lemma interface_implies_matching_mains :
  forall p1 p2,
    well_formed_program p1 ->
    well_formed_program p2 ->
    prog_interface p1 = prog_interface p2 ->
    matching_mains p1 p2.
Proof.
  intros p1 p2 Hwf1 Hwf2 Hiface.
  unfold matching_mains.
  destruct (prog_main p1) as [|] eqn:Hcase1;
    destruct (prog_main p2) as [|] eqn:Hcase2.
  - easy.
  - split; last easy.
    exfalso.
    inversion Hwf2 as [_ _ _ _ _ _ [Hmain2' _]].
    inversion Hwf1 as [_ _ _ _ _ _ [_ Hmain1']].
    rewrite Hcase1 in Hmain1'. specialize (Hmain1' is_true_true).
    rewrite -> Hcase2, <- Hiface in Hmain2'. apply Hmain2' in  Hmain1'.
    discriminate.
  - split; first easy.
    exfalso.
    inversion Hwf1 as [_ _ _ _ _ _ [Hmain1' _]].
    inversion Hwf2 as [_ _ _ _ _ _ [_ Hmain2']].
    rewrite Hcase2 in Hmain2'. specialize (Hmain2' is_true_true).
    rewrite -> Hcase1, -> Hiface in Hmain1'. apply Hmain1' in  Hmain2'.
    discriminate.
  - easy.
Qed.

Lemma closed_interface_union : forall p1 p2,
  closed_interface (prog_interface (program_link p1 p2)) =
  closed_interface (unionm (prog_interface p1) (prog_interface p2)).
Proof.
  easy.
Qed.

Lemma compose_mergeable_interfaces : forall p1 p2,
  linkable (prog_interface p1) (prog_interface p2) ->
  closed_program (program_link p1 p2) ->
  mergeable_interfaces (prog_interface p1) (prog_interface p2).
Proof.
  intros p1 p2 Hlinkable Hclosed.
  split.
  - assumption.
  - inversion Hclosed as [Hclosed_iface _].
    rewrite closed_interface_union in Hclosed_iface.
    assumption.
Qed.

End Intermediate.


Require Import String.
Require Import Bool.

Require Import core.utils.Utils.
Require Import core.Model.
Require Import core.TransformationConfiguration.
Require Import core.SyntaxCertification.
Require Import core.Engine.
Require Import core.Semantics.
Require Import core.EqDec.
Require Import core.Metamodel.
Require Import core.Certification.
Require Import core.Syntax.
Require Import core.modeling.ModelingEngine.
Require Import core.modeling.ModelingMetamodel.
Require Import core.modeling.ConcreteExpressions.
Require Import core.modeling.ModelingSemantics.
Require Import core.modeling.ModelingTransformationConfiguration.

Section ModelingCertification.

(* Context {tc: TransformationConfiguration} {mtc: ModelingTransformationConfiguration tc}. *)

(** * Resolve *)

(* Theorem tr_resolveAll_in:
  forall (tls: list TraceLink) (sm: SourceModel) (name: string)
    (type: TargetModelClass) (sps: list(list SourceModelElement)),
    resolveAll tls sm name type sps = resolveAllIter tls sm name type sps 0.
Proof.
  crush.
Qed. *)

Theorem tr_resolveAllIter_in:
  forall
     {tc: TransformationConfiguration} {mtc: ModelingTransformationConfiguration tc}
    (tls: list TraceLink) (sm: SourceModel) (name: string)
    (type: TargetModelClass) (sps: list(list SourceModelElement)) (iter: nat)
    (te: denoteModelClass type),
    (exists tes: list (denoteModelClass type),
        resolveAllIter tls sm name type sps iter = Some tes /\ In te tes) <->
    (exists (sp: list SourceModelElement),
        In sp sps /\
        resolveIter tls sm name type sp iter = Some te).
Proof.
  intros.
      intros.
  split.
  - intros.
    destruct H. destruct H.
    unfold resolveAllIter in H.
    inversion H.
    rewrite <- H2 in H0.
    apply in_flat_map in H0.
    destruct H0. destruct H0.
    destruct ((toModelClass type x0)) eqn: type_cast_ca; simpl in H1.
    + destruct H1.
      ++ apply in_flat_map in H0.
         destruct H0. destruct H0.
         exists x1.
         split.
         * exact H0.
         * unfold resolveIter.
           destruct (Semantics.resolveIter tls sm name x1 iter); crush.
      ++ contradiction.
    + contradiction.
  - intro.
    destruct H. destruct H.
    destruct (resolveAllIter tls sm name type sps iter) eqn: resolveAll.
    --  exists l. split. auto.
        unfold resolveAllIter in resolveAll.
        inversion resolveAll.
        apply in_flat_map.
        unfold resolveIter in H0.
        destruct (Semantics.resolveIter tls sm name x iter) eqn: resolve_ca; simpl in H0.
        * exists t.
          split.
          ** apply in_flat_map.
             exists x.
             split.
             *** auto.
             *** rewrite resolve_ca. simpl. auto.
          ** rewrite H0. simpl. left. auto.
        * simpl in H0. inversion H0.
    --  unfold resolveAllIter in resolveAll.
        crush.
Qed.

(* Theorem tr_resolve_in:
  forall (tls: list TraceLink) (sm: SourceModel) (name: string)
    (type: TargetModelClass) (sp: list SourceModelElement),
    resolve tls sm name type sp = resolveIter tls sm name type sp 0.
Proof.
  crush.
Qed. *)

(* this one direction, the other one is not true since exists cannot gurantee uniqueness in find *)
Theorem tr_resolveIter_leaf:
  forall
     {tc: TransformationConfiguration} {mtc: ModelingTransformationConfiguration tc}
    (tls:list TraceLink) (sm : SourceModel) (name: string) (type: TargetModelClass)
    (sp: list SourceModelElement) (iter: nat) (x: denoteModelClass type),
    resolveIter tls sm name type sp iter = return x ->
      (exists (tl : TraceLink),
        In tl tls /\
        Is_true (list_beq SourceModelElement SourceElement_eqb (TraceLink_getSourcePattern tl) sp) /\
        ((TraceLink_getIterator tl) = iter) /\
        ((TraceLink_getName tl) = name)%string /\
        (toModelClass type (TraceLink_getTargetElement tl) = Some x)).
Proof.
intros.
unfold resolveIter in H.
destruct (Semantics.resolveIter tls sm name sp iter) eqn: resolve_ca.
- simpl in H.
  unfold Semantics.resolveIter in resolve_ca.
  destruct ( find
               (fun tl : TraceLink =>
                Semantics.list_beq SourceModelElement SourceElement_eqb
                  (TraceLink_getSourcePattern tl) sp &&
                (TraceLink_getIterator tl =? iter) &&
                (TraceLink_getName tl =? name)%string)) eqn: find_ca.
  -- apply find_some in find_ca.
     destruct find_ca.
     exists t0.
     symmetry in H1.
     apply andb_true_eq in H1.
     destruct H1.
     apply andb_true_eq in H1.
     destruct H1.
     crush.
     --- apply beq_nat_true. crush.
     --- apply String.eqb_eq. crush.
  -- inversion resolve_ca.
- simpl in H. inversion H.
Qed.

(* Set Typeclasses Debug Verbosity 2. *)

Context {SourceModelElement SourceModelLink: Type}.
Context {eqdec_sme: EqDec SourceModelElement}. (* need decidable equality on source model elements *)
Context {TargetModelElement TargetModelLink: Type}.
Context {eqdec_tme: EqDec TargetModelElement}. (* need decidable equality on source model elements *)

Instance smm : Metamodel := {
  ModelElement := SourceModelElement;
  ModelLink := SourceModelLink;
  elements_eqdec := eqdec_sme;
}.

Instance tmm : Metamodel := {
  ModelElement := TargetModelElement;
  ModelLink := TargetModelLink;
  elements_eqdec := eqdec_tme;
}.

Instance tc : TransformationConfiguration := {
  SourceMetamodel := smm;
  TargetMetamodel := tmm;
}.

Context {SourceModelClass SourceModelReference: Type}.
Context {TargetModelClass TargetModelReference: Type}.

Context {denoteSourceElemSubType : SourceModelClass -> Set}.
Context {toSourceElemSubType: forall (t: SourceModelClass), SourceModelElement -> option (denoteSourceElemSubType t)}.
Context {toSourceElemSumType: forall (t: SourceModelClass), (denoteSourceElemSubType t) -> SourceModelElement}.

Context {denoteSourceLinkSubType : SourceModelReference -> Set}.
Context {toSourceLinkSubType: forall (t: SourceModelReference), SourceModelLink -> option (denoteSourceLinkSubType t)}.
Context {toSourceLinkSumType: forall (t: SourceModelReference), (denoteSourceLinkSubType t) -> SourceModelLink}.

Context {denoteTargetElemSubType : TargetModelClass -> Set}.
Context {toTargetElemSubType: forall (t: TargetModelClass), TargetModelElement -> option (denoteTargetElemSubType t)}.
Context {toTargetElemSumType: forall (t: TargetModelClass), (denoteTargetElemSubType t) -> TargetModelElement}.

Context {denoteTargetLinkSubType : TargetModelReference -> Set}.
Context {toTargetLinkSubType: forall (t: TargetModelReference), TargetModelLink -> option (denoteTargetLinkSubType t)}.
Context {toTargetLinkSumType: forall (t: TargetModelReference), (denoteTargetLinkSubType t) -> TargetModelLink}.

Instance SourceElements : Sum SourceModelElement SourceModelClass := {
denoteSubType := denoteSourceElemSubType;
toSubType := toSourceElemSubType;
toSumType := toSourceElemSumType;
}.

Instance SourceLinks : Sum SourceModelLink SourceModelReference := {
denoteSubType := denoteSourceLinkSubType;
toSubType := toSourceLinkSubType;
toSumType := toSourceLinkSumType;
}.

Instance TargetElements : Sum TargetModelElement TargetModelClass:= {
denoteSubType := denoteTargetElemSubType;
toSubType := toTargetElemSubType;
toSumType := toTargetElemSumType;
}.

Instance TargetLinks : Sum TargetModelLink TargetModelReference:= {
denoteSubType := denoteTargetLinkSubType;
toSubType := toTargetLinkSubType;
toSumType := toTargetLinkSumType;
}.

Instance msmm: ModelingMetamodel SourceMetamodel:= {
  ModelClass := SourceModelClass;
  ModelReference := SourceModelReference;
  elements := SourceElements;
  links := SourceLinks;
}.

Instance mtmm: ModelingMetamodel TargetMetamodel := {
  ModelClass := TargetModelClass;
  ModelReference := TargetModelReference;
  elements := TargetElements;
  links := TargetLinks;
}.

Instance mtc : ModelingTransformationConfiguration tc := {
  smm := msmm;
  tmm := mtmm;
}.

Instance ModelingCoqTLEngine : @ModelingTransformationEngine _ _ _ CoqTLEngine.
Proof.
eexists.
exact tr_resolveAllIter_in.
exact tr_resolveIter_leaf.
Qed.

End ModelingCertification.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* 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.                                           *)
(****************************************************************************)

From Coq Require Import NArith PeanoNat Strings.String Lists.List.
From Cava Require Import Arrow.ArrowExport BitArithmetic VectorUtils.

Require Import Aes.Pkg Aes.MixColumns Aes.Sbox Aes.SubBytes Aes.ShiftRows
        Aes.CipherRound Aes.KeyExpand Aes.AesTest.

Import ListNotations.
Import KappaNotation.
Open Scope kappa_scope.

Definition key_expand_and_round (sbox_impl: SboxImpl) :=
  <[ fun "key_expand_and_round"
    (op_i: _ Bit)
    (round: _ (Vector Bit 4))
    (data_i: _ (Vector (Vector (Vector Bit 8) 4) 4))
    (key: _ (Vector (Vector (Vector Bit 8) 4) 8))
    (step_i: _ Bit)
    (clear_i: _ Bit)
    : << Vector (Vector (Vector Bit 8) 4) 4 (* data *)
      ,  Vector (Vector (Vector Bit 8) 4) 8 (* key *)
      >> =>

    let key_words = !aes_transpose
      (if op_i == !CIPH_FWD
      then key[:7:4]
      else key[:3:0])
      in
    let round_key =
      if op_i == !CIPH_FWD
      then key_words
      else !aes_mix_columns !CIPH_INV key_words in

    let data_o =
      !(cipher_round_combined sbox_impl) op_i data_i round_key (round == #0) (round == #14) in

    let new_key = !(aes_key_expand sbox_impl) op_i step_i clear_i round key in
    (data_o, new_key)
  ]>.

Definition aes_cipher_core_mealy
  (sbox_impl: SboxImpl) :=
  <[ fun "aes_cipher_core_mealy" state input
    : <<
       (* state *)
       << Bit (* op_s *)
       , Vector (Vector (Vector Bit 8) 4) 4 (*data_s*)
       , Vector (Vector (Vector Bit 8) 4) 8 (*key_s *)
       , Vector Bit 4 (* next round *)
       >>,

       (* output *)
       << Bit (* valid output *)
       , Bit (* Accept data *)
       , Bit (* Accept key *)
       , Vector (Vector (Vector Bit 8) 4) 4 (*data_o*)
       >>
      >> =>

    let '(op_s, data_s, key_s, current_round) = state in
    let '(op_i, data_i, data_valid, key_i, key_valid, data_o_ready) = input in

    let step = false' in
    let clear = false' in

    let round_inc = current_round +% #1 in

    let done = (current_round == #14) || (current_round == #15) in
    let reset = (current_round == #15) && data_o_ready in

    let '(data_n, key_n) =
      if current_round == #15
      then (data_s, key_s)
      else !(key_expand_and_round sbox_impl)
        op_i current_round data_s key_s step clear in

    let next_round =
      if done then
        if reset then #0
        else #15
      else round_inc in

    ( ( op_s
      , if done && data_valid then data_i else data_n
      , if done && key_valid then key_i else key_n
      , next_round )
    , ( (current_round == #15)
      , done
      , done
      , data_i )
    )

  ]>.

(* TODO(#357): op_i needs valid flag and to be respected *)
Definition aes_cipher_core
  (sbox_impl: SboxImpl) :=
  <[ fun "aes_cipher_core"
    (op_i: _ Bit)
    (data_i: _ (Vector (Vector (Vector Bit 8) 4) 4))
    (data_valid: _ Bit)
    (key_i: _ (Vector (Vector (Vector Bit 8) 4) 8))
    (key_valid: _ Bit)
    (data_o_ready: _ Bit)

    : <<
         Bit (* valid output *)
       , Bit (* Accept data *)
       , Bit (* Accept key *)
       , Vector (Vector (Vector Bit 8) 4) 4 (*data_o*)
       >> =>

    !(mealy_machine (aes_cipher_core_mealy sbox_impl))
      (op_i, data_i, data_valid, key_i, key_valid, data_o_ready)
  ]>.

Definition test_input : list
  (bool *
    (denote_kind << Vector (Vector (Vector Bit 8) 4) 4 >> * (bool *
    (denote_kind << Vector (Vector (Vector Bit 8) 4) 8 >> * (bool * bool))))) :=
  [
    (false,
      (@reshape _ 4 4 (reshape test_data), (false,
      (@reshape _ 8 4 (reshape test_key), (false, false )))))
  ].

(*
(* TODO(#357): evaluate *)
Eval vm_compute in
  (interp_sequential (((aes_cipher_core SboxLut) : Kappa _ _) _) test_input).
*)


Require Import ContractSem.
Require Import ConcreteWord.
Require Import ZArith.

Module ConcreteSem := (ContractSem.Make ConcreteWord.ConcreteWord).
Include ConcreteSem.

Definition example2_program : program :=
  PUSH1 (word_of_N 0) ::
        SLOAD ::
        DUP1 ::
        PUSH1 (word_of_N 2) ::
        JUMPI ::
        PUSH1 (word_of_N 1) ::
        ADD ::
        PUSH1 (word_of_N 0) ::
        SSTORE ::
        PUSH1 (word_of_N 0) ::
        (* TODO: change some of these arguments to value, address *)
        PUSH1 (word_of_N 0) ::
        PUSH1 (word_of_N 0) ::
        PUSH1 (word_of_N 0) ::
        PUSH1 (word_of_N 0) ::
        PUSH1 (word_of_N 0) ::
        PUSH1 (word_of_N 0) ::
        CALL ::
        ISZERO ::
        PUSH1 (word_of_N 0) ::
        JUMPI ::
        PUSH1 (word_of_N 0) ::
        PUSH1 (word_of_N 0) ::
        SSTORE ::
        STOP ::
        nil.

Variable example2_address : address.

Definition example2_depth_n_state  (n : word) (st : account_state) :=
  (n = 0%Z /\
   st.(account_address) = example2_address /\
   is_true (ST.equal word_eq (st.(account_storage)) empty_storage) /\
   st.(account_code) = example2_program /\
   st.(account_ongoing_calls) = nil ) \/
  (n = 1%Z /\
   st.(account_code) = example2_program /\
   storage_load 0%Z (account_storage st) = 1%Z /\
   st.(account_address) = example2_address /\
   is_true (ST.equal word_eq (storage_store 0%Z 0%Z st.(account_storage)) empty_storage)  /\
   exists ve, (st.(account_ongoing_calls) = ve :: nil /\
               ve.(venv_prg_sfx) =
               ISZERO ::
                      PUSH1 (word_of_N 0) ::
                      JUMPI ::
                      PUSH1 (word_of_N 0) ::
                      PUSH1 (word_of_N 0) ::
                      SSTORE ::
                      STOP ::
                      nil
               /\
               is_true (ST.equal word_eq (storage_store 0%Z 0%Z ve.(venv_storage)) empty_storage) /\
               is_true (ST.equal word_eq (venv_storage_at_call ve) empty_storage))
  )
.

Definition something_to_call :=
  {|
    callarg_gaslimit := 0%Z;
    callarg_code := address_of_word 0%Z;
    callarg_recipient := address_of_word 0%Z;
    callarg_value := 0%Z;
    callarg_data := cut_memory 0%Z 0%Z empty_memory;
    callarg_output_begin := 0%Z;
    callarg_output_size := storage_load 0%Z empty_storage |}.

(* TODO: remove duplicate somehow *)
CoFixpoint call_but_fail_on_reentrance (depth : word) :=
  if word_eq word_zero depth then
    Respond
      (fun _ =>
         ContractAction (ContractCall something_to_call)
                        (call_but_fail_on_reentrance word_one))
      (fun _ => ContractAction ContractFail (call_but_fail_on_reentrance word_zero))
      (ContractAction ContractFail (call_but_fail_on_reentrance word_zero))
  else if word_eq word_one depth then
         Respond
           (fun _ => ContractAction ContractFail (call_but_fail_on_reentrance word_one))
           (fun _ => ContractAction (ContractReturn nil) (call_but_fail_on_reentrance word_zero))
           (ContractAction ContractFail (call_but_fail_on_reentrance word_zero))
       else
         Respond
           (fun _ => ContractAction ContractFail (call_but_fail_on_reentrance depth))
           (fun retval => ContractAction ContractFail (call_but_fail_on_reentrance (word_sub depth word_one)))
           (ContractAction ContractFail (call_but_fail_on_reentrance (word_sub depth word_one))).

Lemma call_but_fail_on_reentrace_0_eq :
  call_but_fail_on_reentrance 0%Z =
  Respond
    (fun _ =>
       ContractAction (ContractCall something_to_call)
                      (call_but_fail_on_reentrance word_one))
    (fun _ => ContractAction ContractFail (call_but_fail_on_reentrance word_zero))
    (ContractAction ContractFail (call_but_fail_on_reentrance word_zero)).
Proof.
  rewrite (response_expander_eq (call_but_fail_on_reentrance 0%Z)).
  auto.
Qed.

Lemma call_but_fail_on_reentrace_1_eq :
  call_but_fail_on_reentrance 1%Z =
  Respond
    (fun _ => ContractAction ContractFail (call_but_fail_on_reentrance word_one))
    (fun retval => ContractAction (ContractReturn nil) (call_but_fail_on_reentrance word_zero))
    (ContractAction ContractFail (call_but_fail_on_reentrance word_zero)).
Proof.
  rewrite (response_expander_eq (call_but_fail_on_reentrance 1%Z)).
  auto.
Qed.

Definition example2_spec (depth: word) : response_to_world :=
  call_but_fail_on_reentrance depth.

Lemma update_remove_eq :
  forall orig,
    is_true (ST.equal word_eq orig empty_storage) ->
    is_true
      (ST.equal word_eq
                (storage_store 0%Z 0%Z (ST.add 0%Z 1%Z orig))
                empty_storage).
Proof.
  intros orig nst2.
  apply ST.equal_1.
  split.
  {
    intro k.
    unfold storage_store.
    simpl.
    split.
    { intro H.
      apply False_ind.
      case_eq (word_eq k 0%Z).
      { intro k0.
        apply ST.Raw.remove_1 in H; auto.
        { apply ST.Raw.add_sorted.
          apply ST.sorted. }
        apply ST.E.eq_sym.
        assumption.
      }
      {
        intro neq.
        unfold ST.Raw.PX.In in H.
        case H as [e H].
        apply ST.Raw.remove_3 in H.
        {
          apply ST.Raw.add_3 in H.
          {
            apply ST.equal_2 in nst2.
            case nst2 as [I _].
            generalize (I k).
            unfold ST.Raw.PX.In.
            intro I'.
            case I' as [I0 _].
            simpl in I0.
            case I0.
            {
              exists e.
              apply H.
            }
            {
              intros x J.
              eapply ST.Raw.empty_1.
              apply J.
            }
          }
          {
            intro K.
            apply ST.E.eq_sym in K.
            congruence.
          }
        }
        {
          apply ST.Raw.add_sorted.
          apply ST.sorted.
        }
      }
    }
    {
      intro H.
      apply False_ind.
      case H.
      intros x Hx.
      apply (ST.Raw.empty_1 Hx).
    }
  }
  {
    intros k e e' H I.
    apply False_ind.
    generalize I.
    unfold empty_storage.
    generalize (ST.empty_1 I).
    auto.
  }
Qed.

Theorem example2_spec_impl_match :
  forall st n,
    example2_depth_n_state n st ->
    account_state_responds_to_world
      st (example2_spec n%Z) (fun _ _ => True).
Proof.
  unfold example2_spec.
  cofix.
  intros st n n_state.
  case n_state.
  {
    intro nst.
    destruct nst as [nst0 nst1].
    case nst1 as [nst1 nst2].
    case nst2 as [nst2 nst3].
    case nst3 as [nst3 nst4].
    subst.
    clear n_state.
    subst.
    rewrite call_but_fail_on_reentrace_0_eq.
    apply AccountStep.
    {
      unfold respond_to_call_correctly.
      intros ce a con.
      split; [ solve [auto] | ].
      intros _ next.
      intro s.
      simpl.
      rewrite nst3.
      repeat (case s as [| s]; [ solve [left; auto] | ]).
      assert (stl : forall idx, storage_load idx (account_storage st) = storage_load idx empty_storage).
      {
        intro idx.
        unfold storage_load.
        apply ST.equal_2 in nst2.
        unfold ST.Equivb in nst2.
        unfold ST.Raw.Equivb in nst2.
        simpl.
        case_eq (ST.find (elt:=word) idx (account_storage st)); auto.
        intros w H.
        apply ST.find_2 in H.
        apply False_ind.
        assert (ST.Raw.PX.In idx (ST.this (account_storage st))) as K.
        {
          unfold ST.Raw.PX.In.
          exists w.
          assumption.
        }
        case nst2 as [EE _].
        rewrite EE in K.
        unfold ST.Raw.PX.In in K.
        case K.
        intros content K'.
        apply (@ST.Raw.empty_1 word idx content).
        assumption.
      }
      simpl.
      rewrite !stl.
      unfold storage_load.
      unfold empty_storage.
      simpl.
      repeat (case s as [| s]; [ solve [left; auto] | cbn ]).
      right.
      inversion next; subst.
      clear next.
      rewrite get_update_balance.
      admit.
      Admitted.
(*

      eexists.
      eexists.
      eexists.
      split; try reflexivity.
      simpl.
(*      rewrite <- contract_action_expander_eq in next at 1. *)

      apply example2_spec_impl_match.
        unfold example2_depth_n_state.
        right.
        split; auto.
        split; auto.
        split.
        {
          unfold storage_load.
          erewrite ST.find_1.
          { eauto. }
          apply ST.add_1.
          auto.
        }
        split; auto.
        split.
        {
          apply update_remove_eq.
          assumption.
        }
        eexists; eauto.
        split.
        {
          rewrite nst4.
          intuition.
        }
        {
          split; auto.
          split; auto.
          apply update_remove_eq.
          assumption.
        }
      }
    {
      unfold respond_to_return_correctly.
      intros ? ? ? ?.
      simpl.
      rewrite nst4.
      congruence.
    }
    {
      intros ? ? ?.
      simpl.
      rewrite nst4.
      congruence.
    }
  }
  {
    intros H.
    destruct H as [n1 st_code].
    destruct st_code as [st_code st_load].
    destruct st_load as [st_load st_ongoing].
    subst.
    unfold example2_spec.
    rewrite call_but_fail_on_reentrace_1_eq.
    apply AccountStep.
    { (* call *)
      intros callenv act continuation.
      split; [solve [auto] | ].
      intros _ H.
      inversion H; subst.
      clear H.
        intro s.
        repeat (case s as [| s]; [ solve [left; auto] | ]).
        simpl.
        rewrite st_code.
        unfold example2_program.
        cbn.
        repeat (case s as [| s]; [ solve [left; auto] | ]).
        cbn.
        rewrite st_load.
        simpl.
        rewrite st_code.
        simpl.
        right.
        eexists.
        eexists.
        eexists.
        split; [ solve [eauto] | ].
        unfold build_venv_called.
        cbn.
        apply example2_spec_impl_match.
        unfold example2_depth_n_state.
        intuition.
      }
    { (* return *)
      unfold respond_to_return_correctly.
      intros rr venv cont act.
      elim st_ongoing.
      intros prev prevH.
      case prevH as [st_str prevH].
      case prevH as [prevH prevH'].
      case prevH' as [prevH' prevH''].
      case prevH'' as [prevH'' prevH'''].
      simpl.
      rewrite prevH'.
      intro H.
      inversion H; subst.
      clear H.
      intros act_cont_eq.
      intro s.
      rewrite prevH''.
      repeat (case s as [| s]; [ solve [left; auto] | ]).
      simpl.
      right.
      f_equal.
      inversion act_cont_eq; subst.

      eexists.
      eexists.
      eexists.
      split; [reflexivity | ].
      inversion act_cont_eq; subst.
      apply example2_spec_impl_match.
      unfold example2_depth_n_state.
      left.
      repeat (split; auto); tauto.
    }
    {
      unfold respond_to_fail_correctly.
      intros venv cont act.
      case st_ongoing as [st_addr st_ongoing].
      case st_ongoing as [st_storage st_ongoing].
      case st_ongoing as [ve veH].
      case veH as [st_ongoing ve_sfx].
      case ve_sfx as [ve_sfx ve_str].
      simpl.
      rewrite st_ongoing.
      intro venvH.
      inversion venvH; subst.
      clear venvH.
      intros act_cont_H.
      inversion act_cont_H; subst.
      clear act_cont_H.
      intro s.
      rewrite ve_sfx.
      repeat (case s as [| s]; [ solve [left; auto] | ]).
      simpl.
      rewrite st_code.
      simpl.
      right.
      f_equal.
      eexists.
      eexists.
      eexists.
      split; [reflexivity | ].
      simpl.
      apply example2_spec_impl_match.
      unfold example2_depth_n_state.
      left.
      repeat split; auto; tauto.
    }
  }
Qed.
********)


From stdpp Require Export namespaces.
From iris.algebra Require Import gmap_view namespace_map agree frac.
From iris.algebra Require Export dfrac.
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Export own.
From iris.prelude Require Import options.
Import uPred.

(** This file provides a generic mechanism for a language-level point-to
connective [l ↦{dq} v] reflecting the physical heap.  This library is designed to
be used as a singleton (i.e., with only a single instance existing in any
proof), with the [gen_heapG] typeclass providing the ghost names of that unique
instance.  That way, [mapsto] does not need an explicit [gname] parameter.
This mechanism can be plugged into a language and related to the physical heap
by using [gen_heap_interp σ] in the state interpretation of the weakest
precondition. See heap-lang for an example.

If you are looking for a library providing "ghost heaps" independent of the
physical state, you will likely want explicit ghost names and are thus better
off using [algebra.lib.gmap_view] together with [base_logic.lib.own].

This library is generic in the types [L] for locations and [V] for values and
supports fractional permissions.  Next to the point-to connective [l ↦{dq} v],
which keeps track of the value [v] of a location [l], this library also provides
a way to attach "meta" or "ghost" data to locations. This is done as follows:

- When one allocates a location, in addition to the point-to connective [l ↦ v],
  one also obtains the token [meta_token l ⊤]. This token is an exclusive
  resource that denotes that no meta data has been associated with the
  namespaces in the mask [⊤] for the location [l].
- Meta data tokens can be split w.r.t. namespace masks, i.e.
  [meta_token l (E1 ∪ E2) ⊣⊢ meta_token l E1 ∗ meta_token l E2] if [E1 ## E2].
- Meta data can be set using the update [meta_token l E ==∗ meta l N x] provided
  [↑N ⊆ E], and [x : A] for any countable [A]. The [meta l N x] connective is
  persistent and denotes the knowledge that the meta data [x] has been
  associated with namespace [N] to the location [l].

To make the mechanism as flexible as possible, the [x : A] in [meta l N x] can
be of any countable type [A]. This means that you can associate e.g. single
ghost names, but also tuples of ghost names, etc.

To further increase flexibility, the [meta l N x] and [meta_token l E]
connectives are annotated with a namespace [N] and mask [E]. That way, one can
assign a map of meta information to a location. This is particularly useful when
building abstractions, then one can gradually assign more ghost information to a
location instead of having to do all of this at once. We use namespaces so that
these can be matched up with the invariant namespaces. *)

(** To implement this mechanism, we use three resource algebras:

- A [gmap_view L V], which keeps track of the values of locations.
- A [gmap_view L gname], which keeps track of the meta information of
  locations. More specifically, this RA introduces an indirection: it keeps
  track of a ghost name for each location.
- The ghost names in the aforementioned authoritative RA refer to namespace maps
  [namespace_map (agree positive)], which store the actual meta information.
  This indirection is needed because we cannot perform frame preserving updates
  in an authoritative fragment without owning the full authoritative element
  (in other words, without the indirection [meta_set] would need [gen_heap_interp]
  as a premise).
 *)

(** The CMRAs we need, and the global ghost names we are using. *)

Class gen_heapPreG (L V : Type) (Σ : gFunctors) `{Countable L} := {
  gen_heap_preG_inG :> inG Σ (gmap_viewR L (leibnizO V));
  gen_meta_preG_inG :> inG Σ (gmap_viewR L gnameO);
  gen_meta_data_preG_inG :> inG Σ (namespace_mapR (agreeR positiveO));
}.

Class gen_heapG (L V : Type) (Σ : gFunctors) `{Countable L} := GenHeapG {
  gen_heap_inG :> gen_heapPreG L V Σ;
  gen_heap_name : gname;
  gen_meta_name : gname
}.
Global Arguments GenHeapG L V Σ {_ _ _} _ _.
Global Arguments gen_heap_name {L V Σ _ _} _ : assert.
Global Arguments gen_meta_name {L V Σ _ _} _ : assert.

Definition gen_heapΣ (L V : Type) `{Countable L} : gFunctors := #[
  GFunctor (gmap_viewR L (leibnizO V));
  GFunctor (gmap_viewR L gnameO);
  GFunctor (namespace_mapR (agreeR positiveO))
].

Global Instance subG_gen_heapPreG {Σ L V} `{Countable L} :
  subG (gen_heapΣ L V) Σ → gen_heapPreG L V Σ.
Proof. solve_inG. Qed.

Section definitions.
  Context `{Countable L, hG : !gen_heapG L V Σ}.

  Definition gen_heap_interp (σ : gmap L V) : iProp Σ := ∃ m : gmap L gname,
    (* The [⊆] is used to avoid assigning ghost information to the locations in
    the initial heap (see [gen_heap_init]). *)
    ⌜ dom _ m ⊆ dom (gset L) σ ⌝ ∧
    own (gen_heap_name hG) (gmap_view_auth 1 (σ : gmap L (leibnizO V))) ∗
    own (gen_meta_name hG) (gmap_view_auth 1 (m : gmap L gnameO)).

  Definition mapsto_def (l : L) (dq : dfrac) (v: V) : iProp Σ :=
    own (gen_heap_name hG) (gmap_view_frag l dq (v : leibnizO V)).
  Definition mapsto_aux : seal (@mapsto_def). Proof. by eexists. Qed.
  Definition mapsto := mapsto_aux.(unseal).
  Definition mapsto_eq : @mapsto = @mapsto_def := mapsto_aux.(seal_eq).

  Definition meta_token_def (l : L) (E : coPset) : iProp Σ :=
    ∃ γm, own (gen_meta_name hG) (gmap_view_frag l DfracDiscarded γm) ∗
          own γm (namespace_map_token E).
  Definition meta_token_aux : seal (@meta_token_def). Proof. by eexists. Qed.
  Definition meta_token := meta_token_aux.(unseal).
  Definition meta_token_eq : @meta_token = @meta_token_def := meta_token_aux.(seal_eq).

  Definition meta_def `{Countable A} (l : L) (N : namespace) (x : A) : iProp Σ :=
    ∃ γm, own (gen_meta_name hG) (gmap_view_frag l DfracDiscarded γm) ∗
          own γm (namespace_map_data N (to_agree (encode x))).
  Definition meta_aux : seal (@meta_def). Proof. by eexists. Qed.
  Definition meta := meta_aux.(unseal).
  Definition meta_eq : @meta = @meta_def := meta_aux.(seal_eq).
End definitions.
Global Arguments meta {L _ _ V Σ _ A _ _} l N x.

(** FIXME: Refactor these notations using custom entries once Coq bug #13654
has been fixed. *)
Local Notation "l ↦{ dq } v" := (mapsto l dq v)
  (at level 20, format "l  ↦{ dq }  v") : bi_scope.
Local Notation "l ↦□ v" := (mapsto l DfracDiscarded v)
  (at level 20, format "l  ↦□  v") : bi_scope.
Local Notation "l ↦{# q } v" := (mapsto l (DfracOwn q) v)
  (at level 20, format "l  ↦{# q }  v") : bi_scope.
Local Notation "l ↦ v" := (mapsto l (DfracOwn 1) v)
  (at level 20, format "l  ↦  v") : bi_scope.

Section gen_heap.
  Context {L V} `{Countable L, !gen_heapG L V Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : V → iProp Σ.
  Implicit Types σ : gmap L V.
  Implicit Types m : gmap L gname.
  Implicit Types l : L.
  Implicit Types v : V.

  (** General properties of mapsto *)
  Global Instance mapsto_timeless l dq v : Timeless (l ↦{dq} v).
  Proof. rewrite mapsto_eq. apply _. Qed.
  Global Instance mapsto_fractional l v : Fractional (λ q, l ↦{#q} v)%I.
  Proof.
    intros p q. rewrite mapsto_eq /mapsto_def -own_op gmap_view_frag_add //.
  Qed.
  Global Instance mapsto_as_fractional l q v :
    AsFractional (l ↦{#q} v) (λ q, l ↦{#q} v)%I q.
  Proof. split; [done|]. apply _. Qed.
  Global Instance mapsto_persistent l v : Persistent (l ↦□ v).
  Proof. rewrite mapsto_eq. apply _. Qed.

  Lemma mapsto_valid l dq v : l ↦{dq} v -∗ ⌜✓ dq⌝%Qp.
  Proof.
    rewrite mapsto_eq. iIntros "Hl".
    iDestruct (own_valid with "Hl") as %?%gmap_view_frag_valid. done.
  Qed.
  Lemma mapsto_valid_2 l dq1 dq2 v1 v2 : l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝.
  Proof.
    rewrite mapsto_eq. iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %[??]%gmap_view_frag_op_valid_L.
    auto.
  Qed.
  (** Almost all the time, this is all you really need. *)
  Lemma mapsto_agree l dq1 dq2 v1 v2 : l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "H1 H2".
    iDestruct (mapsto_valid_2 with "H1 H2") as %[_ ?].
    done.
  Qed.

  Lemma mapsto_combine l dq1 dq2 v1 v2 :
    l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ l ↦{dq1 ⋅ dq2} v1 ∗ ⌜v1 = v2⌝.
  Proof.
    iIntros "Hl1 Hl2". iDestruct (mapsto_agree with "Hl1 Hl2") as %->.
    iCombine "Hl1 Hl2" as "Hl".
    rewrite mapsto_eq /mapsto_def -own_op gmap_view_frag_op.
    auto.
  Qed.

  Lemma mapsto_frac_ne l1 l2 dq1 dq2 v1 v2 :
    ¬ ✓(dq1 ⋅ dq2) → l1 ↦{dq1} v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
  Proof.
    iIntros (?) "Hl1 Hl2"; iIntros (->).
    by iDestruct (mapsto_valid_2 with "Hl1 Hl2") as %[??].
  Qed.
  Lemma mapsto_ne l1 l2 dq2 v1 v2 : l1 ↦ v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
  Proof. apply mapsto_frac_ne. intros ?%exclusive_l; [done|apply _]. Qed.

  (** Permanently turn any points-to predicate into a persistent
      points-to predicate. *)
  Lemma mapsto_persist l dq v : l ↦{dq} v ==∗ l ↦□ v.
  Proof. rewrite mapsto_eq. apply own_update, gmap_view_persist. Qed.

  (** General properties of [meta] and [meta_token] *)
  Global Instance meta_token_timeless l N : Timeless (meta_token l N).
  Proof. rewrite meta_token_eq /meta_token_def. apply _. Qed.
  Global Instance meta_timeless `{Countable A} l N (x : A) : Timeless (meta l N x).
  Proof. rewrite meta_eq /meta_def. apply _. Qed.
  Global Instance meta_persistent `{Countable A} l N (x : A) : Persistent (meta l N x).
  Proof. rewrite meta_eq /meta_def. apply _. Qed.

  Lemma meta_token_union_1 l E1 E2 :
    E1 ## E2 → meta_token l (E1 ∪ E2) -∗ meta_token l E1 ∗ meta_token l E2.
  Proof.
    rewrite meta_token_eq /meta_token_def. intros ?. iDestruct 1 as (γm1) "[#Hγm Hm]".
    rewrite namespace_map_token_union //. iDestruct "Hm" as "[Hm1 Hm2]".
    iSplitL "Hm1"; eauto.
  Qed.
  Lemma meta_token_union_2 l E1 E2 :
    meta_token l E1 -∗ meta_token l E2 -∗ meta_token l (E1 ∪ E2).
  Proof.
    rewrite meta_token_eq /meta_token_def.
    iDestruct 1 as (γm1) "[#Hγm1 Hm1]". iDestruct 1 as (γm2) "[#Hγm2 Hm2]".
    iDestruct (own_valid_2 with "Hγm1 Hγm2") as %[_ ->]%gmap_view_frag_op_valid_L.
    iDestruct (own_valid_2 with "Hm1 Hm2") as %?%namespace_map_token_valid_op.
    iExists γm2. iFrame "Hγm2". rewrite namespace_map_token_union //. by iSplitL "Hm1".
  Qed.
  Lemma meta_token_union l E1 E2 :
    E1 ## E2 → meta_token l (E1 ∪ E2) ⊣⊢ meta_token l E1 ∗ meta_token l E2.
  Proof.
    intros; iSplit; first by iApply meta_token_union_1.
    iIntros "[Hm1 Hm2]". by iApply (meta_token_union_2 with "Hm1 Hm2").
  Qed.

  Lemma meta_token_difference l E1 E2 :
    E1 ⊆ E2 → meta_token l E2 ⊣⊢ meta_token l E1 ∗ meta_token l (E2 ∖ E1).
  Proof.
    intros. rewrite {1}(union_difference_L E1 E2) //.
    by rewrite meta_token_union; last set_solver.
  Qed.

  Lemma meta_agree `{Countable A} l i (x1 x2 : A) :
    meta l i x1 -∗ meta l i x2 -∗ ⌜x1 = x2⌝.
  Proof.
    rewrite meta_eq /meta_def.
    iDestruct 1 as (γm1) "[Hγm1 Hm1]"; iDestruct 1 as (γm2) "[Hγm2 Hm2]".
    iDestruct (own_valid_2 with "Hγm1 Hγm2") as %[_ ->]%gmap_view_frag_op_valid_L.
    iDestruct (own_valid_2 with "Hm1 Hm2") as %Hγ; iPureIntro.
    move: Hγ. rewrite -namespace_map_data_op namespace_map_data_valid.
    move=> /to_agree_op_inv_L. naive_solver.
  Qed.
  Lemma meta_set `{Countable A} E l (x : A) N :
    ↑ N ⊆ E → meta_token l E ==∗ meta l N x.
  Proof.
    rewrite meta_token_eq meta_eq /meta_token_def /meta_def.
    iDestruct 1 as (γm) "[Hγm Hm]". iExists γm. iFrame "Hγm".
    iApply (own_update with "Hm"). by apply namespace_map_alloc_update.
  Qed.

  (** Update lemmas *)
  Lemma gen_heap_alloc σ l v :
    σ !! l = None →
    gen_heap_interp σ ==∗ gen_heap_interp (<[l:=v]>σ) ∗ l ↦ v ∗ meta_token l ⊤.
  Proof.
    iIntros (Hσl). rewrite /gen_heap_interp mapsto_eq /mapsto_def meta_token_eq /meta_token_def /=.
    iDestruct 1 as (m Hσm) "[Hσ Hm]".
    iMod (own_update with "Hσ") as "[Hσ Hl]".
    { eapply (gmap_view_alloc _ l (DfracOwn 1)); done. }
    iMod (own_alloc (namespace_map_token ⊤)) as (γm) "Hγm".
    { apply namespace_map_token_valid. }
    iMod (own_update with "Hm") as "[Hm Hlm]".
    { eapply (gmap_view_alloc _ l DfracDiscarded); last done.
      move: Hσl. rewrite -!(not_elem_of_dom (D:=gset L)). set_solver. }
    iModIntro. iFrame "Hl". iSplitL "Hσ Hm"; last by eauto with iFrame.
    iExists (<[l:=γm]> m). iFrame. iPureIntro.
    rewrite !dom_insert_L. set_solver.
  Qed.

  Lemma gen_heap_alloc_big σ σ' :
    σ' ##ₘ σ →
    gen_heap_interp σ ==∗
    gen_heap_interp (σ' ∪ σ) ∗ ([∗ map] l ↦ v ∈ σ', l ↦ v) ∗ ([∗ map] l ↦ _ ∈ σ', meta_token l ⊤).
  Proof.
    revert σ; induction σ' as [| l v σ' Hl IH] using map_ind; iIntros (σ Hdisj) "Hσ".
    { rewrite left_id_L. auto. }
    iMod (IH with "Hσ") as "[Hσ'σ Hσ']"; first by eapply map_disjoint_insert_l.
    decompose_map_disjoint.
    rewrite !big_opM_insert // -insert_union_l //.
    by iMod (gen_heap_alloc with "Hσ'σ") as "($ & $ & $)";
      first by apply lookup_union_None.
  Qed.

  Lemma gen_heap_valid σ l dq v : gen_heap_interp σ -∗ l ↦{dq} v -∗ ⌜σ !! l = Some v⌝.
  Proof.
    iDestruct 1 as (m Hσm) "[Hσ _]". iIntros "Hl".
    rewrite /gen_heap_interp mapsto_eq.
    by iDestruct (own_valid_2 with "Hσ Hl") as %[??]%gmap_view_both_valid_L.
  Qed.

  Lemma gen_heap_update σ l v1 v2 :
    gen_heap_interp σ -∗ l ↦ v1 ==∗ gen_heap_interp (<[l:=v2]>σ) ∗ l ↦ v2.
  Proof.
    iDestruct 1 as (m Hσm) "[Hσ Hm]".
    iIntros "Hl". rewrite /gen_heap_interp mapsto_eq /mapsto_def.
    iDestruct (own_valid_2 with "Hσ Hl") as %[_ Hl]%gmap_view_both_valid_L.
    iMod (own_update_2 with "Hσ Hl") as "[Hσ Hl]".
    { eapply gmap_view_update. }
    iModIntro. iFrame "Hl". iExists m. iFrame.
    iPureIntro. apply (elem_of_dom_2 (D:=gset L)) in Hl.
    rewrite dom_insert_L. set_solver.
  Qed.
End gen_heap.

(** This variant of [gen_heap_init] should only be used when absolutely needed.
The key difference to [gen_heap_init] is that the [inG] instances in the new
[gen_heapG] instance are related to the original [gen_heapPreG] instance,
whereas [gen_heap_init] forgets about that relation. *)
Lemma gen_heap_init_names `{Countable L, !gen_heapPreG L V Σ} σ :
  ⊢ |==> ∃ γh γm : gname,
    let hG := GenHeapG L V Σ γh γm in
    gen_heap_interp σ ∗ ([∗ map] l ↦ v ∈ σ, l ↦ v) ∗ ([∗ map] l ↦ _ ∈ σ, meta_token l ⊤).
Proof.
  iMod (own_alloc (gmap_view_auth 1 (∅ : gmap L (leibnizO V)))) as (γh) "Hh".
  { exact: gmap_view_auth_valid. }
  iMod (own_alloc (gmap_view_auth 1 (∅ : gmap L gnameO))) as (γm) "Hm".
  { exact: gmap_view_auth_valid. }
  iExists γh, γm.
  iAssert (gen_heap_interp (hG:=GenHeapG _ _ _ γh γm) ∅) with "[Hh Hm]" as "Hinterp".
  { iExists ∅; simpl. iFrame "Hh Hm". by rewrite dom_empty_L. }
  iMod (gen_heap_alloc_big with "Hinterp") as "(Hinterp & $ & $)".
  { apply map_disjoint_empty_r. }
  rewrite right_id_L. done.
Qed.

Lemma gen_heap_init `{Countable L, !gen_heapPreG L V Σ} σ :
  ⊢ |==> ∃ _ : gen_heapG L V Σ,
    gen_heap_interp σ ∗ ([∗ map] l ↦ v ∈ σ, l ↦ v) ∗ ([∗ map] l ↦ _ ∈ σ, meta_token l ⊤).
Proof.
  iMod (gen_heap_init_names σ) as (γh γm) "Hinit".
  iExists (GenHeapG _ _ _ γh γm).
  done.
Qed.


Require Import Coq.Lists.List.
Require Export ParDB.Spec.
Require Export ParDB.Lemmas.
Require Export ParDB.Inst.

Require Export SpecSyntax.
Require Export SpecTyping.

Arguments wkm _ {_ _} _.
Arguments comp _ _ {_ _ } _ _ _.

Record WtRen (Γ Δ: Env) (ζ: Sub Ix) : Prop :=
  { wtr_tyvar : ∀ {α k},
                  ⟨ α ∷ k ∈ Γ ⟩ →
                  ⟨ ζ α ∷ k ∈ Δ ⟩;
    wtr_covar : ∀ {c τ1 τ2 k},
                  ⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩ →
                  ⟨ ζ c : τ1[ζ] ~ τ2[ζ] ∷ k ∈ Δ ⟩;
    wtr_tmvar : ∀ {x τ},
                  ⟨ x : τ ∈ Γ ⟩ →
                  ⟨ ζ x : τ[ζ] ∈ Δ ⟩
  }.

Notation "⟨ ζ : Γ -> Δ ⟩" := (WtRen Γ Δ ζ)
  (at level 0,
   ζ at level 98,
   Γ at level 98,
   Δ at level 98).

Arguments wtr_tyvar {_ _ _} _ {_ _} _.
Arguments wtr_covar {_ _ _} _ {_ _ _ _} _.
Arguments wtr_tmvar {_ _ _} _ {_ _} _.

Record WtSub (Γ Δ: Env) (ζ: Sub Exp) : Prop :=
  { wts_tyvar : ∀ {α k},
                  ⟨ α ∷ k ∈ Γ ⟩ →
                  ⟨ Δ ⊢ ζ α ∷ k ⟩;
    wts_covar : ∀ {c τ1 τ2 k},
                  ⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩ →
                  ⟨ Δ ⊢ ζ c : τ1[ζ] ~ τ2[ζ] ∷ k ⟩;
    wts_tmvar : ∀ {x τ},
                  ⟨ x : τ ∈ Γ ⟩ →
                  ⟨ Δ ⊢ ζ x : τ[ζ] ⟩;
  }.
Notation "⟨ ζ : Γ => Δ ⟩" := (WtSub Γ Δ ζ)
  (at level 0, ζ at level 98, Γ at level 98, Δ at level 98).

Arguments wts_tyvar {_ _ _} _ {_ _} _.
Arguments wts_covar {_ _ _} _ {_ _ _ _} _.
Arguments wts_tmvar {_ _ _} _ {_ _} _.

Hint Constructors Ty : ws.
Hint Constructors Co : ws.
Hint Constructors Red : ws.
Hint Constructors RedStar : ws.
Hint Constructors Tm : ws.
Hint Resolve wtr_tyvar : ws.
Hint Resolve wtr_covar : ws.
Hint Resolve wtr_tmvar : ws.
Hint Resolve wts_tyvar : ws.
Hint Resolve wts_covar : ws.
Hint Resolve wts_tmvar : ws.

(* Lemma getEvarInvHere { Γ T U } : *)
(*   ⟪ 0 : T ∈ (Γ ▻ U) ⟫ → T = U. *)
(* Proof. inversion 1; auto. Qed. *)

(* Lemma getEvarInvThere {Γ i T U} : *)
(*   ⟪ (S i) : T ∈ Γ ▻ U ⟫ → ⟪ i : T ∈ Γ ⟫. *)
(* Proof. inversion 1; auto. Qed. *)
(* Hint Resolve getEvarInvThere : wsi. *)

Ltac crushTypingMatchH :=
  match goal with
    | [H: ⟨ 0 : _ ∈ _ ⟩                    |- _] => inversion H; clear H; subst*
    | [H: ⟨ (S _) : _ ∈ _ ⟩                |- _] => inversion H; clear H; subst*
    | [H: ⟨ 0 ∷ _ ∈ _ ⟩                    |- _] => inversion H; clear H; subst*
    | [H: ⟨ (S _) ∷ _ ∈ _ ⟩                |- _] => inversion H; clear H; subst*
    | [H: ⟨ 0 : _ ~ _ ∷ _ ∈ _ ⟩            |- _] => inversion H; clear H; subst*
    | [H: ⟨ (S _) : _ ~ _ ∷ _ ∈ _ ⟩        |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ : _ ∈ nil ⟩                  |- _] => inversion H; clear H; subst*
    (* Ty *)
    | [H: ⟨ _ ⊢ var _ ∷ _ ⟩                |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ τabs _ _ ∷ _ ⟩             |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ τapp _ _ ∷ _ ⟩             |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ arr _ _ ∷ _ ⟩              |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ arrτ _ _ ∷ _ ⟩             |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ arrγ _ _ _ _ ∷ _ ⟩         |- _] => inversion H; clear H; subst*
    (* Co *)
    | [H: ⟨ _ ⊢ var _          : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coτabs _ _     : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coτapp _ _     : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coarr _ _      : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coarrτ _ _     : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coarrγ _ _ _ _ : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarr₁ _    : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarr₂ _    : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarrτ _ _  : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarrγ₁ _   : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarrγ₂ _   : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coinvarrγ₂ _   : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ cobeta _ _ _   : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ corefl _       : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ cosym _        : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ cotrans _ _    : _ ~ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    (* Red *)
    | [H: ⟨ _ ⊢ var _ : _ ↝ _ ∷ _ ⟩        |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ coτabs _ _ : _ ↝ _ ∷ _ ⟩   |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ _ : arr _ _ ↝ _ ∷ _ ⟩      |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ _ : arrτ _ _ ↝ _ ∷ _ ⟩     |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ _ : arrγ _ _ _ _ ↝ _ ∷ _ ⟩ |- _] => inversion H; clear H; subst*
    (* Tm *)
    | [H: ⟨ _ ⊢ var _ : _        ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ abs _ _ : _      ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ absτ _ _ : _     ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ absγ _ _ _ _ : _ ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ app _ _ : _      ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ appτ _ _ : _     ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ appγ _ _ : _     ⟩         |- _] => inversion H; clear H; subst*
    | [H: ⟨ _ ⊢ cast _ _ : _     ⟩         |- _] => inversion H; clear H; subst*

    (* | [ wi : ⟪ ?i : _ ∈ (_ ▻ _) ⟫ *)
    (*     |- context [match ?i with _ => _ end] *)
    (*   ] => destruct i *)
    | [ wi : ⟨ ?i : _ ∈ (_ ▻ _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i ∷ _ ∈ (_ ▻ _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i : _ ~ _ ∷ _ ∈ (_ ▻ _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i : _ ∈ (_ ► _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i ∷ _ ∈ (_ ► _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i : _ ~ _ ∷ _ ∈ (_ ► _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i : _ ∈ (_ ◅ _ ~ _ ∷ _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i ∷ _ ∈ (_ ◅ _ ~ _ ∷ _) ⟩ |- _] => destruct i eqn: ?; cbn in *
    | [ wi : ⟨ ?i : _ ~ _ ∷ _ ∈ (_ ► _) ⟩ |- _] => inversion wi; clear wi
    | [ wi : ⟨ ?i : _ ~ _ ∷ _ ∈ (_ ◅ _ ~ _ ∷ _) ⟩ |- _] => destruct i eqn: ?; cbn in *

    | [ |- ⟨ _ ⊢ (_ :: _) : _ ↝* _ ∷ _ ⟩ ] => econstructor
    | [ |- ⟨ _ ⊢ nil : _ ↝* _ ∷ _ ⟩ ] => econstructor
    | [ |- ⟨ _ ⊢ coarrγ _ _ _ _ : _ ↝ _ ∷ _ ⟩ ] => econstructor
    | [ |- ⟨ _ ⊢ _ : arrγ _ _ _ _ ↝ _ ∷ _ ⟩ ] => econstructor
    | [ |- ⟨ _ ⊢ cotrans _ _ : _ ~ _ ∷ _ ⟩ ] => econstructor

    (* | [ wi : ⟨ ?i : _ ∈ (_ ► _) ⟩ *)
    (*     |- context [(_ · _) ?i] *)
    (*   ] => destruct i eqn: ?; cbn in * *)
    (* | [ wi : ⟨ ?i : _ ∈ (_ ◅ _ ~ _ ∷ _) ⟩ *)
    (*     |- context [(_ · _) ?i] *)
    (*   ] => destruct i eqn: ?; cbn in * *)
    (* | [ |- ⟪ _ ⊢ var _ : _ ⟫         ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ abs _ _ : _ ⟫       ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ app _ _ : _ ⟫       ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ unit : _ ⟫          ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ true : _ ⟫          ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ false : _ ⟫         ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ ite _ _ _ : _ ⟫     ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ pair _ _ : _ ⟫      ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ proj₁ _ : _ ⟫       ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ proj₂ _ : _ ⟫       ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ inl _ : _ ⟫         ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ inr _ : _ ⟫         ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ caseof _ _ _ : _ ⟫  ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ seq _ _ : _ ⟫       ] => econstructor *)
    (* | [ |- ⟪ _ ⊢ fixt _ _ _ : _ ⟫    ] => econstructor *)
  end.

Hint Constructors GetTyVar : ws.
Hint Constructors GetCoVar : ws.
Hint Constructors GetTmVar : ws.

Local Ltac crush :=
  intros;
  repeat
    (cbn in *;
     repeat crushSyntaxMatch;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasRewriteH;
     repeat crushSyntaxRefold;
     (* repeat crushTypingMatchH; *)
     subst*;
     try discriminate;
     eauto 200 with core ws;
     idtac
    ).

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

Lemma wtRen_closed {ζ Δ} :
  ⟨ ζ : nil -> Δ ⟩.
Proof. constructor; inversion 1. Qed.
Hint Resolve wtRen_closed : ws.

Lemma wtRen_idm Γ :
  ⟨ idm Ix : Γ -> Γ ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtRen_idm : ws.

Lemma wtRen_comp {Γ₁ Γ₂ Γ₃ ξ₁ ξ₂} :
  ⟨ ξ₁ : Γ₁ -> Γ₂ ⟩ →
  ⟨ ξ₂ : Γ₂ -> Γ₃ ⟩ →
  ⟨ ξ₁ >=> ξ₂ : Γ₁ -> Γ₃ ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtRen_comp : ws.

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

Lemma wtRen_wkm_tyvar Γ k :
  ⟨ wkm Ix : Γ -> Γ ► k ⟩.
Proof. constructor; intros; rewrite ?ap_wkm_ix; crush. Qed.
Hint Resolve wtRen_wkm_tyvar : ws.

Lemma wtRen_wkm_covar Γ τ1 τ2 k :
  ⟨ wkm Ix : Γ -> Γ ◅ τ1 ~ τ2 ∷ k ⟩.
Proof. constructor; intros; rewrite ?ap_wkm_ix; crush. Qed.
Hint Resolve wtRen_wkm_covar : ws.

Lemma wtRen_wkm_tmvar Γ τ :
  ⟨ wkm Ix : Γ -> Γ ▻ τ ⟩.
Proof. constructor; intros; rewrite ?ap_wkm_ix; crush. Qed.
Hint Resolve wtRen_wkm_tmvar : ws.

Lemma wtRen_snoc_tyvar {Γ Δ ζ α k} :
  ⟨ ζ : Γ -> Δ ⟩ →
  ⟨ α ∷ k ∈ Δ ⟩ →
  ⟨ ζ · α : Γ ► k -> Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite <- ?ap_wkm_ix, ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtRen_snoc_tyvar : ws.

Lemma wtRen_snoc_covar {Γ Δ ζ c τ1 τ2 k} :
  ⟨ ζ : Γ -> Δ ⟩ →
  ⟨ c : τ1[ζ] ~ τ2[ζ] ∷ k ∈ Δ ⟩ →
  ⟨ ζ · c : Γ ◅ τ1 ~ τ2 ∷ k -> Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite <- ?ap_wkm_ix, ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtRen_snoc_covar : ws.

Lemma wtRen_snoc_tmvar {Γ Δ ζ x τ} :
  ⟨ ζ : Γ -> Δ ⟩ →
  ⟨ x : τ[ζ] ∈ Δ ⟩ →
  ⟨ ζ · x : Γ ▻ τ -> Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite <- ?ap_wkm_ix, ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtRen_snoc_tmvar : ws.

Lemma wtRen_up_tyvar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ -> Γ₂ ⟩) :
  ∀ k, ⟨ ζ↑ : Γ₁ ► k -> Γ₂ ► k ⟩.
Proof. rewrite up_def. constructor; crush. Qed.
Hint Resolve wtRen_up_tyvar : ws.

Lemma wtRen_up_covar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ -> Γ₂ ⟩) :
  ∀ τ1 τ2 k, ⟨ ζ↑ : Γ₁ ◅ τ1 ~ τ2 ∷ k -> Γ₂ ◅ τ1[ζ] ~ τ2[ζ] ∷ k ⟩.
Proof.
  rewrite up_def.
  constructor; crush.
  - inversion H; clear H; crush.
  - inversion H; clear H; crush.
    + rewrite <- ?(ap_wkm_ix (X:=Exp)), ?ap_comp.
      rewrite ?wkm_snoc_cancel.
      rewrite <- ?ap_comp, ?(ap_wkm_ix (X:=Exp)).
      constructor.
    + rewrite <- ?(ap_wkm_ix (X:=Exp)), ?ap_comp.
      rewrite ?wkm_snoc_cancel.
      rewrite <- ?ap_comp, ?(ap_wkm_ix (X:=Exp)).
      constructor.
      now apply (wtr_covar wζ).
  - inversion H; clear H; crush.
    rewrite <- (ap_wkm_ix (X:=Exp)), ap_comp.
    rewrite wkm_snoc_cancel.
    rewrite <- ap_comp, (ap_wkm_ix (X:=Exp)).
    constructor.
    now apply (wtr_tmvar wζ).
Qed.
Hint Resolve wtRen_up_covar : ws.

Lemma wtRen_up_tmvar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ -> Γ₂ ⟩) :
  ∀ τ, ⟨ ζ↑ : Γ₁ ▻ τ -> Γ₂ ▻ τ[ζ] ⟩.
Proof.
  rewrite up_def.
  constructor; crush.
  - inversion H; clear H; crush.
  - inversion H; clear H; crush.
    rewrite <- ?(ap_wkm_ix (X:=Exp)), ?ap_comp.
    rewrite ?wkm_snoc_cancel.
    rewrite <- ?ap_comp, ?(ap_wkm_ix (X:=Exp)).
    constructor.
    now apply (wtr_covar wζ).
  - inversion H; clear H; crush.
    + rewrite <- ap_wkm_ix, ap_comp.
      rewrite wkm_snoc_cancel.
      rewrite <- ap_comp, ap_wkm_ix.
      constructor.
    + rewrite <- (ap_wkm_ix (X:=Exp)) , ap_comp.
      rewrite wkm_snoc_cancel.
      rewrite <- ap_comp, (ap_wkm_ix (X:=Exp)).
      constructor.
      now apply (wtr_tmvar wζ).
Qed.
Hint Resolve wtRen_up_tmvar : ws.

Lemma ty_ren {Γ τ k} (wτ: ⟨ Γ ⊢ τ ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ -> Δ ⟩ → ⟨ Δ ⊢ τ[ζ] ∷ k ⟩.
Proof. induction wτ; crush. Qed.
Hint Resolve ty_ren : ws.

Lemma co_ren {Γ γ τ1 τ2 k} (wγ: ⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ -> Δ ⟩ → ⟨ Δ ⊢ γ[ζ] : τ1[ζ] ~ τ2[ζ] ∷ k ⟩.
Proof.
  induction wγ; intros ? ζ wζ; crush.
  - rewrite <- ?ap_liftSub.
    rewrite ?apply_beta1_comm.
    rewrite ?up_liftSub.
    rewrite ?ap_liftSub.
    econstructor; eauto with ws.
  - rewrite <- ?ap_liftSub.
    rewrite ?apply_beta1_comm.
    rewrite ?up_liftSub.
    rewrite ?ap_liftSub.
    econstructor; eauto with ws.
Qed.
Hint Resolve co_ren : ws.

Lemma red_ren {Γ γ τ1 τ2 k} (wγ: ⟨ Γ ⊢ γ : τ1 ↝ τ2 ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ -> Δ ⟩ → ⟨ Δ ⊢ γ[ζ] : τ1[ζ] ↝ τ2[ζ] ∷ k ⟩.
Proof.
  induction wγ; intros ? ζ wζ; crush.
  - rewrite <- ?ap_liftSub.
    rewrite ?apply_beta1_comm.
    rewrite ?up_liftSub.
    rewrite ?ap_liftSub.
    econstructor; eauto with ws.
Qed.
Hint Resolve red_ren : ws.

Lemma redstar_ren {Γ γs τ1 τ2 k} (wγ: ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ -> Δ ⟩ → ⟨ Δ ⊢ γs[ζ] : τ1[ζ] ↝* τ2[ζ] ∷ k ⟩.
Proof.
  induction wγ; intros ? ζ wζ; crush.
Qed.
Hint Resolve redstar_ren : ws.

Lemma tm_ren {Γ s τ} (wt: ⟨ Γ ⊢ s : τ ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ -> Δ ⟩ → ⟨ Δ ⊢ s[ζ] : τ[ζ] ⟩.
Proof.
  induction wt; intros ? ζ wζ; crush.
  - constructor; crush.
    rewrite <- ap_wkm_ix.
    rewrite apply_wkm_comm.
    rewrite ap_wkm_ix.
    apply IHwt; crush.
  - constructor; crush.
    rewrite <- ap_wkm_ix.
    rewrite apply_wkm_comm.
    rewrite ap_wkm_ix.
    apply IHwt; crush.
  - rewrite <- ?ap_liftSub.
    rewrite apply_beta1_comm.
    rewrite up_liftSub.
    rewrite ?ap_liftSub.
    crush.
  - econstructor; crush.
Qed.
Hint Resolve tm_ren : ws.

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

Lemma wtSub_closed ζ Δ : ⟨ ζ : nil => Δ ⟩.
Proof. constructor; inversion 1. Qed.
Hint Resolve wtSub_closed : ws.

Lemma wtSub_idm (Γ: Env) : ⟨ idm Exp : Γ => Γ ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtSub_idm : ws.

Lemma wtSub_wkm_tyvar Γ k :
  ⟨ wkm Exp : Γ => Γ ► k ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtSub_wkm_tyvar : ws.

Lemma wtSub_wkm_covar Γ τ1 τ2 k :
  ⟨ wkm Exp : Γ => Γ ◅ τ1 ~ τ2 ∷ k ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtSub_wkm_covar : ws.

Lemma wtSub_wkm_tmvar Γ τ :
  ⟨ wkm Exp : Γ => Γ ▻ τ ⟩.
Proof. constructor; crush. Qed.
Hint Resolve wtSub_wkm_tmvar : ws.

Lemma wtSub_snoc_tyvar {Γ Δ ζ τ k} :
  ⟨ ζ : Γ => Δ ⟩ →
  ⟨ Δ ⊢ τ ∷ k ⟩ →
  ⟨ ζ · τ : Γ ► k => Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtSub_snoc_tyvar : ws.

Lemma wtSub_snoc_covar {Γ Δ ζ γ τ1 τ2 k} :
  ⟨ ζ : Γ => Δ ⟩ →
  ⟨ Δ ⊢ γ : τ1[ζ] ~ τ2[ζ] ∷ k ⟩ →
  ⟨ ζ · γ : Γ ◅ τ1 ~ τ2 ∷ k => Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtSub_snoc_covar : ws.

Lemma wtSub_snoc_tmvar {Γ Δ ζ s τ} :
  ⟨ ζ : Γ => Δ ⟩ →
  ⟨ Δ ⊢ s : τ[ζ] ⟩ →
  ⟨ ζ · s : Γ ▻ τ => Δ ⟩.
Proof.
  intros wζ wx; constructor; crush; repeat crushTypingMatchH;
    rewrite ?ap_comp, ?wkm_snoc_cancel; crush.
Qed.
Hint Resolve wtSub_snoc_tmvar : ws.

Lemma wtSub_up_tyvar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ => Γ₂ ⟩) :
  ∀ k, ⟨ ζ↑ : Γ₁ ► k => Γ₂ ► k ⟩.
Proof.
  rewrite up_def.
  constructor; crush.
  - inversion H; clear H; crush.
    rewrite <- ap_wkm_ix; crush.
  - inversion H; clear H; crush.
    rewrite ?ap_comp.
    rewrite ?wkm_snoc_cancel.
    rewrite <- ?ap_comp.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
  - inversion H; clear H; crush.
    rewrite ?ap_comp.
    rewrite ?wkm_snoc_cancel.
    rewrite <- ?ap_comp.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
Qed.
Hint Resolve wtSub_up_tyvar : ws.

Lemma wtSub_up_covar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ => Γ₂ ⟩) :
  ∀ τ1 τ2 k, ⟨ ζ↑ : Γ₁ ◅ τ1 ~ τ2 ∷ k => Γ₂ ◅ τ1[ζ] ~ τ2[ζ] ∷ k ⟩.
Proof.
  rewrite up_def.
  constructor; crush.
  - inversion H; clear H; crush.
    rewrite <- ap_wkm_ix; crush.
  - inversion H; clear H; crush.
    + constructor.
      rewrite ?ap_comp.
      rewrite ?wkm_snoc_cancel.
      rewrite <- ?ap_comp.
      constructor.
    + rewrite ?ap_comp.
      rewrite ?wkm_snoc_cancel.
      rewrite <- ?ap_comp.
      rewrite <- ?(ap_wkm_ix (X:=Exp)).
      crush.
  - inversion H; clear H; crush.
    rewrite ?ap_comp.
    rewrite ?wkm_snoc_cancel.
    rewrite <- ?ap_comp.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
Qed.
Hint Resolve wtSub_up_covar : ws.

Lemma wtSub_up_tmvar {Γ₁ Γ₂ ζ} (wζ: ⟨ ζ : Γ₁ => Γ₂ ⟩) :
  ∀ τ, ⟨ ζ↑ : Γ₁ ▻ τ => Γ₂ ▻ τ[ζ] ⟩.
Proof.
  rewrite up_def.
  constructor; crush.
  - inversion H; clear H; crush.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
  - inversion H; clear H; crush.
    rewrite ?ap_comp.
    rewrite ?wkm_snoc_cancel.
    rewrite <- ?ap_comp.
    rewrite <- ?(ap_wkm_ix (X:=Exp)).
    crush.
  - inversion H; clear H; crush.
    + rewrite ap_comp.
      rewrite wkm_snoc_cancel.
      rewrite <- ap_comp.
      repeat constructor.
    + rewrite ap_comp.
      rewrite wkm_snoc_cancel.
      rewrite <- ap_comp.
      rewrite <- ?(ap_wkm_ix (X:=Exp)).
      crush.
Qed.
Hint Resolve wtSub_up_tmvar : ws.

Lemma ty_sub {Γ τ k} (wτ: ⟨ Γ ⊢ τ ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ => Δ ⟩ → ⟨ Δ ⊢ τ[ζ] ∷ k ⟩.
Proof. induction wτ; crush. Qed.
Hint Resolve ty_sub : ws.

Lemma co_sub {Γ γ τ1 τ2 k} (wγ: ⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ => Δ ⟩ → ⟨ Δ ⊢ γ[ζ] : τ1[ζ] ~ τ2[ζ] ∷ k ⟩.
Proof. induction wγ; crush. Qed.
Hint Resolve co_sub : ws.

Lemma tm_sub {Γ s τ} (wt: ⟨ Γ ⊢ s : τ ⟩) :
  ∀ Δ ζ, ⟨ ζ : Γ => Δ ⟩ → ⟨ Δ ⊢ s[ζ] : τ[ζ] ⟩.
Proof.
  induction wt; intros ? ζ wζ; crush.
  - constructor; crush.
  - constructor; crush.
  - econstructor; crush.
Qed.
Hint Resolve tm_sub : ws.