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.


(*
 * © 2021 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List
     Lia
     Program.Equality.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Tactics
     Simulation
     SyntacticallySafe

     Theory.KeysTheory

     ModelCheck.ModelCheck
     ModelCheck.Commutation
     ModelCheck.InvariantSearchLemmas
     ModelCheck.ProtocolFunctions
     ModelCheck.RealWorldStepLemmas
     ModelCheck.SafeProtocol
     ModelCheck.SilentStepElimination
     ModelCheck.SteppingTactics
     ModelCheck.UniverseInversionLemmas
     ModelCheck.NoResends
.

From SPICY Require IdealWorld RealWorld.
From Frap Require Export Invariant.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

Import Tacs Gen.

Set Implicit Arguments.

Open Scope protocol_scope.

Ltac eq1 :=
  invert_base_equalities1
  || match goal with
    | [ H : List.In _ _ |- _ ] => unfold List.In in H; (* intuition idtac *) split_ors

    | [ H : _ $+ (_,_) $? _ = Some ?UD |- _ ] =>
      match type of UD with
      | RealWorld.user_data _ =>
        apply lookup_some_implies_in in H; (* unfold List.In in H; intuition idtac *) simpl in H
      | _ => apply lookup_split in H; (* intuition idtac *) split_ors
      end
    | [ H : _ #+ (_,_) #? _ = Some ?UD |- _ ] =>
      apply ChMaps.ChMap.lookup_split in H; (* intuition idtac *) split_ors

    | [ H : _ = {| RealWorld.users := _ |} |- _ ]
      => apply split_real_univ_fields in H; split_ex; subst
    | [ |- RealWorld.protocol (RealWorld.adversary _) = RealWorld.Return _ ] =>
      unfold RealWorld.protocol, RealWorld.adversary
    | [ H : lameAdv _ ?adv |- RealWorld.protocol ?adv = _ ] => unfold lameAdv in H; eassumption

    | [ H : RealWorld.users _ $? _ = Some _ |- _ ] => unfold RealWorld.users in H

    | [ H : _ = RealWorld.mkUserData _ _ _ |- _ ] => inversion H; clear H

    | [ H : Action _ = Action _ |- _ ] =>
      injection H; subst
    | [ H : RealWorld.Return _ = RealWorld.Return _ |- _ ] => apply invert_return in H

    | [ H: RealWorld.SignedCiphertext _ = RealWorld.SignedCiphertext _ |- _ ] =>
      injection H; subst
    | [ H: RealWorld.SigCipher _ _ _ _ = RealWorld.SigCipher _ _ _ _ |- _ ] =>
      injection H; subst
    | [ H: RealWorld.SigEncCipher _ _ _ _ _ = RealWorld.SigEncCipher _ _ _ _ _ |- _ ] =>
      injection H; subst
    | [ H : _ = RealWorld.Output _ _ _ _ |- _ ] => apply output_act_eq_inv in H; split_ex; subst
    | [ H : RealWorld.Output _ _ _ _ = _ |- _ ] => apply output_act_eq_inv in H; split_ex; subst
    | [ H : _ = RealWorld.Input _ _ _ |- _ ] => apply input_act_eq_inv in H; split_ex; subst
    | [ H : RealWorld.Input _ _ _ = _ |- _ ] => apply input_act_eq_inv in H; split_ex; subst
    | [ H : MkCryptoKey _ _ _ = _ |- _ ] => apply key_eq_inv in H; split_ex; subst

    | [ H: _ = {| IdealWorld.read := _ |} |- _ ] => injection H
    | [ H: {| IdealWorld.read := _ |} = _ |- _ ] => injection H

    | [ H : keyId _ = _ |- _] => inversion H; clear H

    | [ H : realServer 0 _ _ = _ |- _ ] => rewrite realserver_done in H
    | [ H : realServer _ _ _ = _ |- _ ] => erewrite unroll_realserver_step in H by reflexivity
    end.

Ltac ch := (repeat equality1); subst; rw_step1.
(* Ltac ch := (repeat equality1); subst; rw_step1. *)
Ltac chu := repeat ch.

Ltac process_map_in_H H :=
  repeat ( (rewrite add_eq_o in H by trivial)
         || (rewrite add_neq_o in H by congruence)
         || (rewrite lookup_empty_none in H) )
  ; repeat
      match goal with
      | [ H : Some _ = Some _ |- _ ] => apply some_eq_inv in H; subst
      | [ H : None = Some _ |- _ ] => discriminate H
      end.

Ltac finish_honest_cmds_safe1 :=
    (* (progress solve_concrete_perm_merges) || *)
    match goal with
    (* from solve_concrete_perm_merges *)
    | [ |- context [true || _]  ] => rewrite orb_true_l
    | [ |- context [_ || true]  ] => rewrite orb_true_r
    | [ |- context [$0 $k++ _] ] => rewrite merge_perms_left_identity
    | [ |- context [_ $k++ $0] ] => rewrite merge_perms_right_identity

    | [ H : _ = {| RealWorld.users := _;
                   RealWorld.adversary := _;
                   RealWorld.all_ciphers := _;
                   RealWorld.all_keys := _ |} |- _ ] =>
      time ( let to := type of H in idtac "Universe Invert: " to; invert H )

    | [ |- honest_cmds_safe _ ] => unfold honest_cmds_safe; intros; simpl in *
    | [ |- next_cmd_safe _ _ _ _ _ _ ] => unfold next_cmd_safe; intros
    | [ H : _ $+ (?id1,_) $? ?id2 = Some ?ud |- context [ ?id2 ] ] =>
      match type of ud with
      | RealWorld.user_data _ =>
        is_var id2; destruct (id1 ==n id2); subst
        ; process_map_in_H H
        (* ; repeat ( discriminate H *)
        (*          || (rewrite add_eq_o in H by trivial) *)
        (*          || (rewrite add_neq_o in H by congruence) *)
        (*          || (rewrite lookup_empty_none in H) ) *)
        (* clean_map_lookups *)
      end
    | [ H : nextAction (RealWorld.protocol _) _ |- _ ] =>
      unfold RealWorld.protocol in H
    | [ H : nextAction (realServer 0 _ _) _ |- _ ] =>
      rewrite realserver_done in H
    | [ H : nextAction (realServer _ _ _) _ |- _ ] =>
      erewrite unroll_realserver_step in H by reflexivity
    | [ H : nextAction _ _ |- _ ] =>
      apply invert_na in H; cbn in H; destruct H; subst; invert_base_equalities1; subst
    | [ H : mkKeys _ $? _ = _ |- _ ] => unfold mkKeys in H; simpl in H
    | [ |- context [ RealWorld.findUserKeys _ ] ] =>
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty by eauto
    | [ H : RealWorld.findKeysMessage _ $? _ = _ |- _ ] =>
      unfold RealWorld.findKeysMessage in H; simpl in H
    | [ |- (_ -> _) ] => intros
    | [ H : _ $+ (?id1,_) $? ?id2 = _ |- context [ _ $? ?id2 ] ] =>
      progress (process_map_in_H H)
      (* ( progress ( *)
      (*       repeat ( *)
      (*           (rewrite add_neq_o in H by congruence) *)
      (*           || (rewrite add_eq_o in H by trivial) *)
      (*           || (rewrite lookup_empty_none in H) *)
      (* ))) *)
      || (is_var id2; destruct (id1 ==n id2); subst; process_map_in_H H)
      (* || (let to := type of H in idtac "Map inverting :" to; is_var id2; destruct (id1 ==n id2); subst; clean_map_lookups) *)
    | [ |- context [ _ $+ (_,_) $? _ ] ] =>
      (* ( progress clean_map_lookups ) *)
      ( progress (
          repeat (
              (rewrite add_eq_o by trivial)
              (* || (rewrite add_neq_o by solve_simple_ineq) *)
              || (rewrite add_neq_o by congruence)
              || (rewrite lookup_empty_none)
        )))

    | [ H : _ $k++ _ $? ?k = Some _ |- context [ _ $? ?k ]] => (*  *)
        apply merge_perms_split in H; destruct H
    | [ |- context [ _ $k++ _ $? _ ] ] => rewrite !lookup_in_merge_perm
    | [ |- RealWorld.msg_pattern_safe _ _ ] => econstructor
    | [ |- RealWorld.honest_key _ _ ] => econstructor
    | [ |- context [ ?m $? _ ] ] => unfold m
    | [ |- Forall _ _ ] => econstructor
    | [ |- exists x y, (_ /\ _)] => (do 2 eexists); repeat simple apply conj; eauto 2
    | [ |- _ /\ _ ] => repeat simple apply conj
    | [ |- ~ List.In _ ?lst ] =>
      match lst with
      | context [OrderedTypeEx.Nat_as_OT.compare ?x ?x] =>
        let EQ := fresh "EQ" in
        let RW := fresh "RW"
        in pose proof (@OTF.elim_compare_eq x x eq_refl) as EQ; destruct EQ as [EQ RW]
           ; rewrite RW
           ; progress vm_compute
      | _ =>  progress vm_compute
      end
    | [ |- ~ (_ \/ _) ] => unfold not; intros; split_ors; subst; try contradiction
    | [ H : context [ _ \/ False ] |- False ] =>
      destruct H; try contradiction
    | [ H : (_,_) = (_,_) |- _ ] => invert H
    end.

Ltac finish_honest_cmds_safe :=
  repeat (finish_honest_cmds_safe1 || (progress simplify_terms) (* ; simpl; cbn *)).

Definition safety_inv :=
  fun t__hon t__adv st => @safety t__hon t__adv st /\ alignment st /\ @returns_align t__hon t__adv st.

Definition noresends_inv :=
  fun t__hon t__adv st => no_resends_U (fst (fst st)) /\ alignment st /\ @returns_align t__hon t__adv st.

#[export] Hint Opaque safety_inv : core.

Definition can_con_map {V} (m : Map.t V) : Map.t V.
  let m' := eval simpl in (fold (fun k v acc => acc $+ (k, v)) m $0)
    in apply m'.
Defined.

Lemma can_con_map_correct : forall {V} (m : Map.t V),
    can_con_map m = m.
Proof.
  induction m using P.map_induction_bis; intros; Equal_eq; eauto.
  unfold can_con_map.
  rewrite fold_add; eauto.
  fold (can_con_map m).
  rewrite IHm; trivial.
  Morphisms.solve_proper.
  unfold transpose_neqkey; intros.
  maps_equal.
Qed.

Ltac ccm m H :=
  replace m with (can_con_map m) in H by apply can_con_map_correct
  ; try match goal with
        | [ H : context [ can_con_map ?cm ] |- _ ] =>
          (unfold can_con_map,fold in H; simpl in H)
        end.

Ltac ccmag m :=
  replace m with (can_con_map m) by apply can_con_map_correct
  ; match goal with
    | [ |- context [ can_con_map ?cm ] ] =>
      (unfold can_con_map,fold); simpl
    end.

Ltac rwuf :=
  unfold RealWorld.buildUniverse, RealWorld.build_data_step
  , RealWorld.key_heap, RealWorld.msg_heap, RealWorld.c_heap
  , RealWorld.from_nons, RealWorld.sent_nons, RealWorld.cur_nonce
  , RealWorld.protocol, RealWorld.all_keys, RealWorld.all_ciphers
  , RealWorld.users, RealWorld.adversary
  in *.

Tactic Notation "canonicalize" "ideal" "goal" :=
  rwuf
  ; match goal with
    | [ |- context [{| IdealWorld.users := ?usrs |}]] => ccmag usrs
    end.

Ltac idealUnivSilentStep' uid :=
  eapply IdealWorld.LStepUser with (u_id := uid)
  ; simpl
  ; [ solve [ simple_clean_maps; trivial ]
    | solve [ idealUserSilentStep ]
    ].

Ltac step_ideal1' uid :=
  idtac "stepping " uid
  ; eapply TrcFront
  ; [ idealUnivSilentStep' uid |].

Ltac multistep_ideal' usrs :=
  canonicalize ideal goal;
  match usrs with
  | ?us $+ (?uid,_) =>
    idtac "multi stepping " uid
    ; (repeat step_ideal1' uid)
    ; multistep_ideal' us
  | _ => eapply TrcRefl
  end.

Ltac run_ideal_silent_steps_to_end' :=
  canonicalize ideal goal;
  match goal with
  | [ |- istepSilent ^* {| IdealWorld.users := ?usrs |} ?U ] =>
    is_evar U
    ; multistep_ideal' usrs
  end.

Ltac discharge_ideal_proto_equality :=
  repeat
    match goal with
    | [ |- context [ IdealWorld.protocol _ = _ ] ] => unfold IdealWorld.protocol
    | [ |- idealServer 0 _ _ = _ ] => rewrite idealserver_done
    | [ |- idealServer _ _ _ = _ ] => erewrite unroll_idealserver_step by reflexivity
    | [ |- _ = _ ] => reflexivity
    end.

(* note the automation here creates a bunch of extra existentials while
 * doint the search for available steps.  This creates several nats
 * that need to be resolved at the end of proofs that use it.
 * Should look at fixing this. *)
Ltac find_step_or_solve' :=
  (* simpl in *; *)
  match goal with
  | [ H1 : forall _ _ _, indexedRealStep _ _ ?ru _ -> False
    , H2 : ?usrs $? _ = Some ?ur
    , H3 : RealWorld.protocol ?ur = RealWorld.Return _ |- _ ] =>

    ( assert (exists uid lbl ru', indexedRealStep uid lbl ru ru')
      by (eexists ?[uid]; (do 2 eexists); find_indexed_real_step usrs ?uid)
      ; split_ex; exfalso; eauto
    )
    || ( repeat solve_returns_align1
        ; ( (do 3 eexists); rwuf; (* simpl in *; *) (repeat eq1)
            ; subst
            ; repeat simple apply conj
            ; [ solve [ run_ideal_silent_steps_to_end' ]
              | solve [ simpl; simple_clean_maps; trivial ]
              | solve [ discharge_ideal_proto_equality ]
              | reflexivity
              ]
      ))
  end.

Ltac cleanup1 :=
  match goal with
  | [ H : True |- _ ] => clear H
  | [ H : ?X = ?X |- _ ] => clear H
  | [ H : ?x <> ?y |- _ ] =>
    match type of x with
    | nat => concrete x; concrete y; clear H
    end
  | [ H : ?x = ?y -> False |- _ ] =>
    match type of x with
    | nat => concrete x; concrete y; clear H
    end
  | [ H: RealWorld.keys_mine _ $0 |- _ ] => clear H
  | [ H : _ $+ (?k1,_) $? ?k2 = None |- _ ] =>
    (* (rewrite add_neq_o in H by solve_simple_ineq) *)
    (rewrite add_eq_o in H by trivial)
    || (rewrite add_neq_o in H by congruence)
    || (destruct (k1 ==n k2); subst)
  | [ H : Map.In ?k ?m -> False |- _ ] =>
    change (Map.In k m -> False) with (~ Map.In k m) in H
    ; rewrite F.not_find_in_iff in H
  | [ H : context [ ChMaps.ChannelType.eq _ _ ] |- _ ] => unfold ChMaps.ChannelType.eq in H
  | [ H : _ #+ (?k1,_) #? ?k2 = None |- _ ] =>
    (rewrite ChMaps.ChMap.F.add_neq_o in H by solve_simple_ineq)
    || (rewrite ChMaps.ChMap.F.add_eq_o in H by trivial)
    || (destruct (ChMaps.ChMap.F.eq_dec k1 k2); subst)

  | [ H : (Some _ = None -> False) -> ?c |- _ ] =>
    assert (c) by (apply H; intros; discriminate); clear H
  | [ H : (Some _ <> None) -> ?c |- _ ] =>
    assert (c) by (apply H; intros; discriminate); clear H
  | [ H : context [ sharePerm _ _ ] |- _ ] => unfold sharePerm in H
  | [ H : context [ $0 $? _ ] |- _ ] => rewrite lookup_empty_none in H
  | [ H : $0 $? _ = None |- _ ] => clear H
  | [ H : #0 #? _ = None |- _ ] => clear H
  | [ H : context [ add_key_perm _ _ _ ] |- _ ] => unfold add_key_perm in H

  | [ H : context [ (?uid,_) = (?x,_) \/ False] |- _ ] =>
    concrete uid; destruct H

  | [ H : MessageEq.content_eq ?m _ _ |- _ ] =>
    match type of m with
    | RealWorld.message.message Nat => fail 2
    | _ => unfold MessageEq.content_eq in H
    end
  | [ H : match ?acc with _ => _ end |- _ ] =>
    match type of acc with
    | IdealWorld.IW_message.access => destruct acc
    | _ => fail 1
    end

  | [ H : context [ _ #+ (?k,_) #? ?k ] |- _ ] =>
    is_not_evar k
    ; rewrite ChMaps.ChMap.F.add_eq_o in H by trivial
  | [ H : context [ _ #+ (?k1,_) #? ?k2 ] |- _ ] =>
    is_not_evar k1
    ; is_not_evar k2
    ; rewrite ChMaps.ChMap.F.add_neq_o in H by congruence
  | [ H : mkKeys _ $? _ = _ |- _ ] => unfold mkKeys in H
  | [ H : ~ RealWorld.msg_accepted_by_pattern _ _ _ _ _ |- _ ] => clear H
  | [ H : RealWorld.msg_accepted_by_pattern _ _ _ _ _ -> False |- _ ] => clear H
  | [ H : IdealWorld.screen_msg _ _ |- _ ] => invert H
  | [ H : IdealWorld.permission_subset _ _ |- _ ] => invert H
  | [ H : IdealWorld.check_perm _ _ _ |- _ ] => unfold IdealWorld.check_perm in H
  | [ H : IdealWorld.message.Permission _ = _ |- _ ] => invert H
  | [ H : context [ IdealWorld.addMsg _ _ _ ] |- _ ] => unfold IdealWorld.addMsg in H
  | [ H : Forall _ [] |- _ ] => clear H
  | [ H : context [true || _]  |- _] => rewrite orb_true_l in H
  | [ H : context [_ || true]  |- _] => rewrite orb_true_r in H
  | [ H : context [false || _]  |- _] => rewrite orb_false_l in H
  | [ H : context [_ || false]  |- _] => rewrite orb_false_r in H
  | [ H : context [$0 $k++ _] |- _] => rewrite merge_perms_left_identity in H
  | [ H : context [_ $k++ $0] |- _] => rewrite merge_perms_right_identity in H
  | [ H : context [_ $k++ _ $? _] |- _ ] => rewrite lookup_in_merge_perm in H
  (* | [ H : context [_ $k++ _]  |- _] => *)
  (*   erewrite reduce_merge_perms in H by (clean_map_lookups; eauto) *)
  (* | [ H : context [_ $k++ _]  |- _] => *)
  (*   unfold merge_perms, add_key_perm, fold in H; clean_map_lookups *)

  | [ H : context [ _ $+ (?k1,_) $? ?k2] |- _ ] =>
    (* (rewrite add_neq_o in H by solve_simple_ineq) *)
    (rewrite add_eq_o in H by trivial)
    || (rewrite add_neq_o in H by congruence)
  | [ H : context [ ?m $? _ ] |- _ ] =>
    progress (unfold m in H)

  | [ |- context [$0 $k++ _] ] => rewrite !merge_perms_left_identity
  | [ |- context [_ $k++ $0] ] => rewrite !merge_perms_right_identity

  | [ H : context [[] ++ _] |- _ ] => rewrite !app_nil_l in H
  | [ H : context [_ ++ []] |- _ ] => rewrite !app_nil_r in H
  end || discriminate || eq1.

Ltac print_nosilents :=
  repeat
    match goal with
    | [ H : NoSilent ?uidA _ |- _ ] => idtac "NoSilent ready for assert: " uidA; fail
    end.

Ltac prove_gt_pred :=
  intros
  ; simpl in *
  ; repeat
      match goal with
      | [ H : context [ _ $+ (_,_) $- _ ] |- _ ] =>
        repeat (
            (rewrite map_add_remove_neq in H by congruence)
            || (rewrite map_add_remove_eq in H by trivial)
            || (rewrite remove_empty in H)
          )
      | [ H : _ $+ (?uid,_) $? ?uid' = Some _ |- _ ] =>
        destruct (uid ==n uid'); subst; simple_clean_maps; try lia
      | [ H : NoSilent ?uid _ |- ~ indexedRealStep ?uid _ _ _ ] =>
        eapply NoSilent_no_indexed_silent_step
        ; eauto 2
      end.

Ltac assert_gt_pred U uid :=
  let P := fresh "P"
  in assert (forall uid' ud' U', U.(RealWorld.users) $? uid' = Some ud'
                            -> uid' > uid
                            -> ~ indexedRealStep uid' Silent U U') as P by prove_gt_pred
     ; pose proof (upper_users_cant_step_rewrite P); clear P
.

Ltac solve_all_users_no_silent :=
  repeat
    lazymatch goal with
    | [ |- _ -> _ ] => intros
    | [ |- ~ indexedRealStep ?uid _ _ _ ] => eapply all_users_NoSilent_no_indexed_silent_step
    | [ H : RealWorld.users _ $? _ = Some _ |- _ ] => unfold RealWorld.users in H
    | [ H : _ $+ (?conUid,_) $? ?uid = Some _ |- NoSilent ?uid _ ] =>
      destruct (conUid ==n uid); subst; simple_clean_maps
    | [ H : NoSilent ?uid _  |- NoSilent ?uid _ ] => exact H
    end.

Ltac assert_no_silents U :=
  let P := fresh "P"
  in assert (forall uid U', ~ indexedRealStep uid Silent U U') as P by solve_all_users_no_silent
.

Ltac getNextAction p :=
  match p with
  | RealWorld.Bind ?n _ => getNextAction n
  | ?n                  => idtac n
  end.

Ltac assertSilentStatus uid U p :=
  let rec assertSilentStatus' pr :=
      lazymatch pr with
      | RealWorld.Bind ?n _ => assertSilentStatus' n
      | RealWorld.Send _ _  => assert (NoSilent uid U) by (econstructor; unfold not; intros; rstep)
      | RealWorld.Recv _    => assert (NoSilent uid U) by (econstructor; unfold not; intros; rstep)
      | ?n                  => assert (exists U', indexedRealStep uid Silent U U') by solve_indexedRealStep
      end
  in lazymatch p with
     | RealWorld.Return _  => assert (NoSilent uid U) by (econstructor; unfold not; intros; rstep)
     | _                   => assertSilentStatus' p
     end.

Ltac find_silent_step U us :=
  let MAX := fresh "MEQ"
  in  remember (O.max_elt us) eqn:MAX
      ; unfold O.max_elt in MAX
      ; simpl in MAX
      ; lazymatch type of MAX with
        | _ = Some (?uid,?u) =>
          match goal with
          | [ H : NoSilent uid U |- _ ] => idtac "already have it"; find_silent_step U (us $- uid)
          | _ =>
            let p := (eval cbn in u.(RealWorld.protocol))
            in  assertSilentStatus uid U p
                ; subst; split_ex
                ; lazymatch goal with
                  | [ H : NoSilent uid _ |- _ ] => find_silent_step U (us $- uid)
                  | [ H : indexedRealStep uid Silent _ _ |- _ ] => assert_gt_pred U uid
                  end
          end
        | _ => assert_no_silents U
        end
(* ; clear MAX *)
.

Ltac solve_noresends :=
  unfold NoResends.no_resends_U, fst, RealWorld.users
  ; rewrite Forall_natmap_forall; intros
  ; focus_user; simpl
  ; unfold NoResends.no_resends
  ; repeat
      match goal with
      | [ |- NoDup [] ] => apply NoDup_nil
      | [ |- NoDup (_ :: _) ] => apply NoDup_cons
      | [ |- ~ List.In _ _ ] =>
        unfold not; simpl; intros; split_ors; repeat invert_base_equalities1; try contradiction
      end
  ; eauto.

Ltac finish_noresends_invariant :=
  rwuf
  ; try match goal with
        | [ |- context [{| RealWorld.users := ?users |} ]] =>
          ccmag users
        end
  ; unfold noresends_inv, safety, alignment, returns_align
  ; repeat simple apply conj
  ; [ solve_noresends
    | trivial
    | unfold labels_align; intros; rstep; subst; solve_labels_align
    | try solve [ simpl; intros; find_step_or_solve' ]
    ].

Ltac finish_invariant :=
  rwuf
  ; try match goal with
    | [ |- context [{| RealWorld.users := ?users |} ]] =>
      ccmag users
    end
  ; unfold safety_inv, safety, alignment, returns_align
  ; repeat simple apply conj
  ; [ finish_honest_cmds_safe; simple_clean_maps; eauto 8
    | trivial
    | unfold labels_align; intros; rstep; subst; solve_labels_align
    | try solve [ simpl; intros; find_step_or_solve' ]
    ].

Ltac prove_honest_heaps_sane :=
  repeat
    match goal with
    | [ H : _ |- _ ] => clear H
    end
  ; unfold InvariantSearchLemmas.honest_heaps_sane
  ; intros
  ; match goal with
    | [ USRS : _ $+ (_,_) $? _ = Some _ |- _ ] =>
      repeat
        match type of USRS with
        | _ $+ (?uid1,_) $? ?uid2 = Some _ => destruct (uid1 ==n uid2); subst; simple_clean_maps
        end
    end
  ; unfold RealWorld.c_heap, RealWorld.key_heap, List.In
  ; split
  ; intros
  ; repeat
      match goal with
      | [ |- In ?kid2 _ ] =>
        rewrite in_find_iff; unfold not; intros
      | [ H : _ \/ _ |- _ ] => destruct H
      | [ H : _ $+ (?kid1,_) $? ?kid2 = None |- False ] =>
        destruct (kid1 ==n kid2); subst; simple_clean_maps
      | [ H : _ $k++ _ $? _ = Some _ |- False ] =>
        apply KeysTheory.merge_perms_split in H; destruct H; solve_concrete_maps
      end
  ; trivial.

Ltac forward_nosilents :=
  lazymatch goal with
  | [ XX : NoSilent _ _ |- _ ] =>
    match goal with
    | [ H : honest_heaps_sane ?usrs ?cs ?gks -> propNoSilent _ _ |- _ ] =>
      ( let HHS := fresh "HHS" in
        assert (InvariantSearchLemmas.honest_heaps_sane usrs cs gks) as HHS by prove_honest_heaps_sane
        ; apply H in HHS
        ; clear H
        ; repeat
            match goal with
            | [ NS : NoSilent ?uid _ |- _ ] =>
              idtac "asserting nosilent " uid
              ; generalize (HHS _ NS)
              ; clear NS
            end
        ; clear HHS
        ; intros
      ) || fail 3
    end
  | [ H : honest_heaps_sane _ _ _ ->  _ |- _ ] =>
    clear H
  | _ => idtac
  end.
  (* try  *)
  (*   match goal with *)
  (*   | [ PROPNS : propNoSilent _ _ |- _ ] => *)
  (*     repeat  *)
  (*       match goal with *)
  (*       | [ NS : NoSilent ?uid _ |- _ ] => *)
  (*         idtac "asserting nosilent " uid *)
  (*         ; generalize (PROPNS _ NS) *)
  (*         ; clear NS *)
  (*       end *)
  (*     ; clear PROPNS *)
  (*     ; intros *)
  (*   end. *)

Ltac clear_nosilents :=
  idtac "Clearing NoSilents"
  ; repeat
      match goal with
      | [ H : NoSilent _ _ |- _ ] => clear H
      | [ H : propNoSilent _ _ |- _ ] => clear H
      | [ H : honest_heaps_sane _ _ _ ->  _ |- _ ] => clear H
      end.

Ltac invSS1 :=
  discriminate
  || match goal with
    | [ STEP : (stepSS (t__adv := _)) ^* (?U,_,_) _
      , IRS : indexedRealStep ?uid Silent ?U ?RU
      , P : (forall _ _, _ > ?uid -> _)
        |- _ ] =>

      ( let PROOF := fresh "PROOF" in
        pose proof (InvariantSearchLemmas.ssteps_inv_silent STEP eq_refl IRS P) as PROOF
        ; clear STEP IRS P RU
        ; unfold RealWorld.users, RealWorld.all_ciphers, RealWorld.all_keys in PROOF
        ; split_ex
        ; clear_nosilents
        (* ; forward_nosilents *)
        ; idtac "Found silents"
      ) || fail 1

    | [ H : action_matches _ _ _ _ |- _] => invert H
    | [H : indexedRealStep _ _ _ _ |- _ ] =>
      invert H
    | [H : RealWorld.step_universe _ ?u _ _ |- _] =>
      concrete u; chu
    | [H : RealWorld.step_user _ None _ _ |- _] =>
      invert H
    | [H : RealWorld.step_user _ _ ?u _ |- _] =>
      concrete u; chu
    | [ H : indexedIdealStep _ _ _ _ |- _ ] => istep (* run _after_ real steps *)

    | [ STEP : (stepSS (t__adv := _)) ^* (?ru,?iu,?b) _
      , P : (forall _ _, ~ indexedRealStep _ Silent _  _)
        |- _ ] =>

      progress ( unfold not in P )

    | [ STEP : (stepSS (t__adv := _)) ^* (?ru,?iu,?b) (_,_,_)
      , P : (forall _ _, indexedRealStep _ Silent _ _ -> False)
        |- _ ] =>

      concrete ru
      ; match goal with
        | [ LA : labels_align (?ru,?iu,?b) |- _ ] =>
          let PROOF := fresh "PROOF" in
          pose proof (ssteps_inv_labeled P STEP LA eq_refl) as PROOF
          ; clear STEP P LA
          ; clear_nosilents
          ; destruct PROOF
          ; split_ex
          ; subst

        | _ =>
          idtac "proving alignment 4"
          ; assert (labels_align (ru,iu,b)) by ((repeat prove_alignment1); eauto)
        end

    | [ STEP : (stepSS (t__adv := _)) ^* ?st ?st'
      , P : (forall _ _, indexedRealStep _ Silent _ _ -> False)
        |- _ ] =>

      match st with
      | (_,_,_) => idtac
      | _ => destruct st as [[?ru ?iu] ?b]
      end
      ; match st' with
        | (_,_,_) => idtac
        | _ => destruct st' as [[?ru' ?iu'] ?b']
        end

    | [ H : (stepSS (t__adv := _)) ^* (?U,_,_) _ |- _ ] =>

      match U with
      | {| RealWorld.users := ?usrs |} =>
        match usrs with
        | context [ {| RealWorld.protocol := realServer 0 _ _ |} ] =>
          idtac "rewriting server done"; rewrite realserver_done in H
        | context [ {| RealWorld.protocol := realServer _ _ _ |} ] =>
          idtac "unrolling server"; erewrite unroll_realserver_step in H by reflexivity
        | _ =>
          idtac "finding silent steps..."
          (* ; forward_nosilents *)
          ; find_silent_step U usrs
          ; clear_nosilents
        end
      end

    | [ H : forall _ _ _, _ -> _ -> _ -> _ <-> _ |- _ ] => clear H
    | [ H : forall _ _ _ _, _ -> _ -> _ -> _ -> _ <-> _ |- _ ] => clear H
    | [ H : (forall _ _ _, indexedRealStep _ _ ?ru _ ->
                      exists _ _ _, (indexedIdealStep _ _) ^* ?iu _ /\ _) |- _ ] =>
      clear H

    | [ |- safety_inv (?ru,_,_) ] =>
      concrete ru; clear_nosilents; solve [ finish_invariant ]

    | [ |- noresends_inv (?ru,_,_) ] =>
      concrete ru; clear_nosilents; solve [ finish_noresends_invariant ]

    | [ H : _ \/ _ |- _ ] => destruct H; split_ex; subst
    end.

Tactic Notation "canonicalize" "context" :=
  rwuf
  ; try
      match goal with
      | [ H : stepSS (?ru,?iu,_) _ |- _ ] =>
        match ru with
        | context [{| RealWorld.users := ?usrs |}] =>
          ccm usrs H
        end
        ; match iu with
          | context [{| IdealWorld.users := ?usrs |}] =>
            ccm usrs H
          end
      | [ H : (stepSS (t__adv:=_)) ^* (?ru,?iu,_) _ |- _ ] =>
        match ru with
        | context [{| RealWorld.users := ?usrs |}] =>
          ccm usrs H
        end
        ; match iu with
          | context [{| IdealWorld.users := ?usrs |}] =>
            ccm usrs H
          end
      end
  ; try
      match goal with
      | [ H : _ -> propNoSilent _ ?ru |- _ ] =>
        match ru with
        | context [{| RealWorld.users := ?usrs |}] =>
          ccm usrs H
        end
      end.

Ltac find_runtime :=
  repeat
    match goal with
    | [ |- boundRunningTimeUniv (_ $+ (?usr,_)) _ ] =>
      eapply BrtRecur with (uid := usr); eauto 2; simpl
    | [ |- boundRunningTime _ _ ] => econstructor; eauto 2
    | [ |- _ -> _ ] => intros
    | [ |- boundRunningTimeUniv (_ $+ (?usr,_) $- _) _ ] =>
      repeat
        (rewrite map_add_remove_neq by congruence)
      || (rewrite map_add_remove_eq by trivial)
      || (rewrite remove_empty)
    | [ |- boundRunningTimeUniv $0 _ ] => apply BrtEmpty
    | [ |- queues_size _ = _ ] => unfold queues_size, fold; trivial
    end.

Lemma findKeysMessage_getKey_compatible :
  forall (m : RealWorld.message.message Access),
  exists kp,
    RealWorld.findKeysMessage m $? getKey m = Some kp.
Proof.
  intros.
  dependent destruction m.
  unfold getKey; simpl.
  destruct acc
  ; simpl
  ; eauto.
Qed.

Lemma findKeysMessage_getKey_verify_pr_compatible :
  forall (m : bool * RealWorld.message.message Access),
  exists kp, RealWorld.findKeysMessage (snd m) $? getKey (snd m) = Some kp.
Proof.
  intros.
  destruct m.
  dependent destruction m; unfold getKey; simpl.
  eauto.
Qed.

Lemma findKeysMessage_getKey_pr_compatible1 :
  forall t (m : RealWorld.message.message (TPair Access t)),
  exists kp,
    RealWorld.findKeysMessage m $? getKey (RealWorld.message.msgFst m) = Some kp.
Proof.
  intros.
  induct m; simpl.
  clear IHm1 IHm2.
  pose proof (findKeysMessage_getKey_compatible m1); split_ex.
  cases (RealWorld.findKeysMessage m2 $? getKey m1)
  ; eexists
  ; eauto.
Qed.

Lemma findKeysMessage_getKey_pr_compatible2 :
  forall t (m : RealWorld.message.message (TPair t Access)),
  exists kp,
    RealWorld.findKeysMessage m $? getKey (RealWorld.message.msgSnd m) = Some kp.
Proof.
  intros.
  induct m; simpl.
  clear IHm1 IHm2.
  pose proof (findKeysMessage_getKey_compatible m2); split_ex.
  cases (RealWorld.findKeysMessage m1 $? getKey m2)
  ; eexists
  ; eauto.
Qed.

Ltac typechecks1 :=
  simple_clean_maps1
  || match goal with
    | [ |- syntactically_safe _ _ _ (RealWorld.Return _) _ ] =>
      solve [ eapply SafeReturn; repeat typechecks1 ] || apply SafeReturnUntyped
    | [ |- syntactically_safe _ _ _ _ _ ] =>
      econstructor
    | [ |- _ -> _ ] => intros
    | [ H : RealWorld.findKeysMessage _ $? _ = Some _ |- _ ] => progress (simpl in H)
    | [ H : _ $+ (?k1,_) $? ?k2 = Some _ |- _ ] =>
      destruct (k1 ==n k2); subst
    | [ H : _ $k++ _ $? _ = Some _ |- _ ] =>
      apply merge_perms_split in H; split_ors
    | [ |- HonestKey _ (fst ?k) ] => destruct k; simpl; eapply HonestPermission
    | [ |- HonestKey _ (getKey (snd ?m)) ] =>
      pose proof (findKeysMessage_getKey_verify_pr_compatible m); split_ex
      ; eapply HonestKeyFromMsgVerify with (v := m); eauto 2
    | [ |- HonestKey _ (getKey (RealWorld.message.msgFst ?m)) ] =>
      pose proof (findKeysMessage_getKey_pr_compatible1 m); split_ex
      ; eapply HonestFromMsg with (msg := m); eauto 2
    | [ |- HonestKey _ (getKey (RealWorld.message.msgSnd ?m)) ] =>
      pose proof (findKeysMessage_getKey_pr_compatible2 m); split_ex
      ; eapply HonestFromMsg with (msg := m); eauto 2
    | [ |- HonestKey _ (getKey ?m) ] =>
      pose proof (findKeysMessage_getKey_compatible m); split_ex
      ; eapply HonestFromMsg with (msg := m); eauto 2
    | [ |- HonestKey _ _ ] => eapply HonestPermission
    | [ |- HonestKey _ _ /\ _ ] => split; trivial
    | [ |- List.In _ _ ] => progress simpl
    | [ |- _ \/ _ ] => (left; reflexivity) || right
    | [ |- List.In _ ?l ] => is_evar l; eauto 2
    | [ |- _ <> _ ] => congruence
    end.

Ltac verify_context_soundness :=
  match goal with
  | [ |- typingcontext_sound _ _ _ _ ] =>
    unfold typingcontext_sound
    ; repeat simple apply conj; intros; simpl
  | [ H : HonestKey _ ?kid |- RealWorld.findUserKeys _ $? ?kid = Some true ] =>
    unfold RealWorld.findUserKeys,fold; simpl; invert H
  | [ H : List.In _ _ |- _ ] => simpl in H; split_ors; try contradiction
  | [ H : {| cmd_type := _ |} = _ |- _ ] => apply safe_typ_eq in H; split_ex; subst; try discriminate
  | [ H : JMeq.JMeq _ _ |- _ ] => invert H
  | [ |- _ $k++ _ $? _ = Some true ] => KeysTheory.solve_perm_merges
  end || invert_base_equalities1.

Ltac build_summary :=
  repeat
    match goal with
    | [ |- _ $+ (?k1,_) $? ?k2 = Some _ ] => rewrite add_neq_o by congruence
    | [ |- _ $? ?k2 = Some _ ] => rewrite add_eq_o by reflexivity
    end.

(* Ltac t := (repeat eq1); try invSS1. *)
(* Ltac u := (repeat cleanup1); invSS1(* ; istep *); (repeat cleanup1). *)
Ltac do_trsys_step := invSS1; (repeat cleanup1); subst.

Ltac transition_system_step :=
  rwuf; do_trsys_step; canonicalize context.


(****************************************************************************)
(* 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.
********)