Require TRS.
Require ATS.

Require Import TRS.
Require Import Common.

Variable mem env1 env2 : list type2.
Variable lhs : pattern2_vector mem env1.
Variable w : where_clause env1 env2.

(* Fixpoint var_lift t G (x : var G t)  : member t (insertAt t' G n) := *)
(*     match x with *)
(*       | HFirst G' => match n return member t (insertAt t' (t :: G') n) with *)
(*                        | O => HNext HFirst *)
(*                        | _ => HFirst *)
(*                      end *)
(*       | HNext t'' G' x' => match n return member t (insertAt t' (t'' :: G') n) with *)
(*                              | O => HNext (HNext x') *)
(*                              | S n' => HNext (liftVar x' t' n') *)
(*                            end *)
(*     end. *)

(* Arguments expr1 : clear implicits.  *)
(* Arguments expr1 E t.  *)

(* Section test.  *)

(*   Definition lift_expr1 t q t' : expr1 q t' -> expr1 (t::q) t'. Admitted.  *)

(*   Definition replacement E t := match t with  *)
(*                                   | Treg t => expr1 E t *)
(*                                   | _ => var E t *)
(*                                 end.  *)

(*   Definition subst E F := dlist (replacement E)          F.  *)

(*   Definition apply_subst E F t (s : subst E F) (e : expr1 E t) : expr1 F t.  *)
(*   induction e.  *)
(*   eapply Eprim; eauto.  *)
(*   eapply dlist_map.  *)

(*   refine (let f := fix f t : expr1 F t :=  *)

(*               match t with  *)

(* match e with *)
(*                     | Eprim args res f x => _ *)
(*                     | Econstant c => _ *)
(*                     | Eunion id fl case => _ *)
(*                     | Etuple l v => _ *)

(*                     | Eget t v => _ *)
(*                     | Eget_regfile size t v n x => _ *)
(*                     | Efirst n t v => _ *)
(*                     | Eisfull n t v => _ *)
(*                     | Eisempty n t v => _ *)

(*               end *)
(*           in f t e *)
(*          ). *)
(*   Focus 2.  *)
(*   apply Econstant.  *)
(*         induction e.  *)

(*   Definition replacement_fst E a : replacement (a :: E) a.  *)
(*   destruct a; try apply var_0.  apply Eget. apply var_0.   *)
(*   Defined.  *)

(*   Definition replacement_lift a E t : replacement E t -> replacement (a::E) t. *)
(*   intros. unfold replacement in *. destruct t.  *)
(*   apply lift_expr1.  *)
(*   apply X.  *)
(*   apply var_S; auto.   *)
(*   apply var_S; auto.  *)
(*   Defined.  *)

(*   Definition subst_id E : subst E E.  *)
(*   induction E.   *)
(*   constructor.  *)
(*   constructor.  *)
(*     apply replacement_fst.  *)
(*   unfold subst in IHE.  *)
(*   eapply dlist_map. 2: apply IHE.  *)
(*   apply replacement_lift.  *)
(*   Defined.  *)

(*   Definition build_subst t E F :  *)
(*     pattern1 F t -> @expr1 E t ->  *)
(*     subst E F.  *)
(*   Proof. *)
(*     intros p e.  *)
(*     unfold subst.  *)
(*     inversion p; subst.  *)
(*     constructor. apply e.  *)
(*     constructor.  *)
(*     constructor.  *)
(*     constructor.  *)
(*     admit.  *)
(*     induction X.  *)
(*     constructor. *)
(*     admit.  *)
(*   Defined.  *)

(*   Definition build_subst_where  E F (W : where_clause E F) : subst E F.  *)
(*   Proof.  *)
(*     induction W. *)
(*     apply subst_id.  *)

(*     assert (T := build_subst _ _ _ p e).  *)

(*     Definition subst_combine E F G :  *)
(*       subst (E ++ F) G ->  *)
(*       subst E F ->  *)
(*       subst E G.  *)
(*     intros.  *)
(*     eapply dlist_map in X. apply X.  *)
(*     intros. clear - X1 X0.   *)
(*     unfold replacement in *.  *)
(*     destruct x.  *)
(*     Definition apply_subst :  *)

(* Definition t :  dlist (fun t => match t with  *)
(*                                  | Treg t => @expr1 mem t *)
(*                                  | _ => var mem t *)
(*                                end *)
(*                       ) env1.  *)
(* induction lhs. *)
(* apply dlist_nil. *)
(* Definition zob E t : pattern2 E t ->  *)
(*                      dlist (fun t => match t with  *)
(*                                       | Treg t => @expr1 mem t  *)
(*                                       | _ => var mem t *)
(*                                     end) E. *)
(* Admitted.   *)
(* apply zob in p.  *)
(* induction E.  *)
(* simpl.  *)

(* eapply dlist_map.  intros. 2:apply IHp.  *)
(* simpl in *.  *)
(* destruct x; auto using var_S, lift_expr1.  *)
(* simpl.  *)

(* constructor. 2: apply IHE.  *)

(* simpl.  *)
(* apply  *)
(* simpl.  *)
(* Definition t : forall t, var env1 (Treg t) -> @expr1 mem t.  *)
(* (* compute the part that depend on the pattern_vector *) *)
(* induction lhs. *)
(* intros.  inversion X. *)
(* intros t' v.  *)

(* Definition test : forall T P E F (t : T),  *)
(*                     (var E t -> P t) ->  *)
(*                     (var F t -> P t) ->  *)
(*                     (var (E ++ F) t -> P t).  *)
(* induction E.  simpl. tauto.  *)
(* simpl. intros. *)
(* induction X1.   *)
(*  tauto. destruct X1.  *)
(* induction  *)

(* simpl.  *)
(* Inductive pattern : list type2 -> list type0 -> Type := *)
(*     Pvar1 : forall t , pattern [Treg (T01 t)] [t]  *)
(*   | Phole1 : forall t, pattern [] [t] *)
(*   | Pconstant : forall c : Common.constant, *)
(*                 pattern [] ([(Common.cst_ty c)]) *)
(*   | Ptuple : forall (E : list type2) (l : list type1), *)
(*                pattern_vector E l -> pattern E (Ttuple l) *)
(*   with pattern_disjunct : list type2 -> type1_id_list -> Type := *)
(*     pattern_disjunct_hd : forall (E : list type2)  *)
(*                              (id : Common.ident) (t : type1) *)
(*                              (q : type1_id_list), *)
(*                            pattern E t -> pattern_disjunct E (id of t :: q) *)
(*   | pattern_disjunct_tl : forall (E : list type2)  *)
(*                              (id : Common.ident) (t : type1) *)
(*                              (q : type1_id_list), *)
(*                            pattern_disjunct E q -> *)
(*                            pattern_disjunct E (id of t :: q) *)
(*   with pattern_vector : list type2 -> list type1 -> Type := *)
(*     pattern_vector_nil : pattern_vector [] [] *)
(*   | pattern_vector_cons : forall (E F : list type2)  *)
(*                             (t : type1) (q : list type1), *)
(*                           pattern E t -> *)
(*                           pattern_vector F q -> *)
(*                           pattern_vector (E ++ F) (t :: q).  *)

(* Inductive type1 : Type := *)
(*     T01 : Common.type0 -> type1 *)
(*   | Ttuple : list type1 -> type1 *)
(*   with type1_id_list : Type := *)
(*     type1_id_list_nil : type1_id_list *)
(*   | type1_id_list_cons : Common.ident -> *)
(*                          type1 -> type1_id_list -> type1_id_list *)

(* Definition V : ATS.transition  *)


Set Primitive Projections.
Record prod A B := pair { fst : A ; snd : B }.
Arguments pair {_ _} _ _.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
Definition ap11 {A B} {f g:A->B} (h:f=g) {x y:A} (p:x=y) : f x = g y.
Admitted.
Goal forall x y z w : Set, (x, y) = (z, w).
Proof.
  intros.
  apply ap11. (* Toplevel input, characters 21-25:
Error: In environment
x : Set
y : Set
z : Set
w : Set
Unable to unify "?31 ?191 = ?32 ?192" with "(x, y) = (z, w)".
 *)


From iris.algebra Require Import frac.
From iris.proofmode Require Import tactics.
From cap_machine Require Import rules logrel addr_reg_sample fundamental multiple_updates region_invariants_static.
From cap_machine.examples Require Import contiguous stack_macros_helpers.
From iris.base_logic Require Export na_invariants.

(* A toy malloc implementation *)

(* The routine is initially provided a capability to a contiguous range of
   memory. It implements a bump-pointer allocator, where all memory before the
   pointer of the capability has been allocated, and all memory after is free.
   Allocating corresponds to increasing the pointer and returning the
   corresponding sub-slice.

   There is no free: when all the available memory has been allocated, the
   routine cannot allocate new memory and will fail instead.

   This is obviously not very realistic, but is good enough for our simple case
   studies. *)

Section SimpleMalloc.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          {stsg : STSG Addr region_type Σ} {heapg : heapG Σ}
          {nainv: logrel_na_invs Σ}
          `{MP: MachineParameters}.

  Definition malloc_subroutine_instrs' (offset: Z) :=
    [lt_z_r r_t3 0 r_t1;
     move_r r_t2 PC;
     lea_z r_t2 4;
     jnz r_t2 r_t3;
     fail_end;
     move_r r_t2 PC;
     lea_z r_t2 offset;
     load_r r_t2 r_t2;
     geta r_t3 r_t2;
     lea_r r_t2 r_t1;
     geta r_t1 r_t2;
     move_r r_t4 r_t2;
     subseg_r_r r_t4 r_t3 r_t1;
     sub_r_r r_t3 r_t3 r_t1;
     lea_r r_t4 r_t3;
     move_r r_t3 r_t2;
     sub_z_r r_t1 0%Z r_t1;
     lea_r r_t3 r_t1;
     getb r_t1 r_t3;
     lea_r r_t3 r_t1;
     store_r r_t3 r_t2;
     move_r r_t1 r_t4;
     move_z r_t2 0%Z;
     move_z r_t3 0%Z;
     move_z r_t4 0%Z;
     jmp r_t0].

  Definition malloc_subroutine_instrs_length : Z :=
    Eval cbv in (length (malloc_subroutine_instrs' 0%Z)).

  Definition malloc_subroutine_instrs :=
    malloc_subroutine_instrs' (malloc_subroutine_instrs_length - 5).

  Ltac iPrologue_pre :=
    match goal with
    | Hlen : length ?a = ?n |- _ =>
      let a' := fresh "a" in
      destruct a as [| a' a]; inversion Hlen; simpl
    end.

  Ltac iPrologue prog :=
    (try iPrologue_pre);
    iDestruct prog as "[Hi Hprog]";
    iApply (wp_bind (fill [SeqCtx])).

  Ltac iEpilogue prog :=
    iNext; iIntros prog; iSimpl;
    iApply wp_pure_step_later;auto;iNext.

  Ltac iCorrectPC i j :=
    eapply isCorrectPC_contiguous_range with (a0 := i) (an := j); eauto; [];
    cbn; solve [ repeat constructor ].

  Ltac iContiguous_next Ha index :=
    apply contiguous_of_contiguous_between in Ha;
    generalize (contiguous_spec _ Ha index); auto.

  Definition malloc_inv (b e : Addr) : iProp Σ :=
    (∃ b_m a_m,
       [[b, b_m]] ↦ₐ [[ malloc_subroutine_instrs ]]
     ∗ b_m ↦ₐ (inr (RWX, Global, b_m, e, a_m))
     ∗ [[a_m, e]] ↦ₐ [[ region_addrs_zeroes a_m e ]]
     ∗ ⌜(b_m < a_m)%a ∧ (a_m <= e)%a⌝
    )%I.

  (* TODO: move this to the rules_AddSubLt.v file. *)
  Lemma wp_AddSubLt_fail E ins dst n1 r2 w wdst cap pc_p pc_g pc_b pc_e pc_a :
    decodeInstrW w = ins
    → is_AddSubLt ins dst (inl n1) (inr r2)
      (* → (pc_a + 1)%a = Some pc_a' *)
        → isCorrectPC (inr (pc_p, pc_g, pc_b, pc_e, pc_a))
          → {{{ PC ↦ᵣ inr (pc_p, pc_g, pc_b, pc_e, pc_a) ∗ pc_a ↦ₐ w ∗ dst ↦ᵣ wdst ∗ r2 ↦ᵣ inr cap }}}
              Instr Executable
            @ E
      {{{ RET FailedV; True }}}.
  Proof.
    iIntros (Hdecode Hinstr Hvpc φ) "(HPC & Hpc_a & Hdst & Hr2) Hφ".
    iDestruct (rules_base.map_of_regs_3 with "HPC Hdst Hr2") as "[Hmap (%&%&%)]".
    iApply (wp_AddSubLt with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
      by erewrite regs_of_is_AddSubLt; eauto; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.
    destruct Hspec as [* Hsucc |].
    { (* Success (contradiction) *) simplify_map_eq. }
    { (* Failure, done *) by iApply "Hφ". }
  Qed.

  Lemma simple_malloc_subroutine_spec (wsize: Word) (cont: Word) b e rmap N E φ :
    dom (gset RegName) rmap = all_registers_s ∖ {[ PC; r_t0; r_t1 ]} →
    (* (size > 0)%Z → *)
    ↑N ⊆ E →
    (  na_inv logrel_nais N (malloc_inv b e)
     ∗ na_own logrel_nais E
     ∗ ([∗ map] r↦w ∈ rmap, r ↦ᵣ w)
     ∗ r_t0 ↦ᵣ cont
     ∗ PC ↦ᵣ inr (RX, Global, b, e, b)
     ∗ r_t1 ↦ᵣ wsize
     ∗ ▷ ((na_own logrel_nais E
          ∗ [∗ map] r↦w ∈ <[r_t2 := inl 0%Z]>
                         (<[r_t3 := inl 0%Z]>
                         (<[r_t4 := inl 0%Z]>
                          rmap)), r ↦ᵣ w)
          ∗ r_t0 ↦ᵣ cont
          ∗ PC ↦ᵣ updatePcPerm cont
          ∗ (∃ (ba ea : Addr) (size : Z),
                ⌜wsize = inl size⌝
            ∗ ⌜(b <= ba ∧ ea ≤ e)%Z⌝
            ∗ ⌜(size > 0)%Z⌝
            ∗ ⌜(ba + size)%a = Some ea⌝
            ∗ r_t1 ↦ᵣ inr (RWX, Global, ba, ea, ba)
            ∗ [[ba, ea]] ↦ₐ [[region_addrs_zeroes ba ea]])
          -∗ WP Seq (Instr Executable) {{ φ }}))
    ⊢ WP Seq (Instr Executable) {{ λ v, φ v ∨ ⌜v = FailedV⌝ }}%I.
  Proof.
    iIntros (Hrmap_dom (* Hsize *) HN) "(#Hinv & Hna & Hrmap & Hr0 & HPC & Hr1 & Hφ)".
    iMod (na_inv_acc with "Hinv Hna") as "(>Hmalloc & Hna & Hinv_close)"; auto.
    rewrite /malloc_inv.
    iDestruct "Hmalloc" as (b_m a_m) "(Hprog & Hmemptr & Hmem & Hbounds)".
    iDestruct "Hbounds" as %[Hbm_am Ham_e].
    (* Get some registers *)
    assert (is_Some (rmap !! r_t2)) as [r2w Hr2w].
    { rewrite elem_of_gmap_dom Hrmap_dom. set_solver. }
    assert (is_Some (rmap !! r_t3)) as [r3w Hr3w].
    { rewrite elem_of_gmap_dom Hrmap_dom. set_solver. }
    assert (is_Some (rmap !! r_t4)) as [r4w Hr4w].
    { rewrite elem_of_gmap_dom Hrmap_dom. set_solver. }
    iDestruct (big_sepM_delete _ _ r_t2 with "Hrmap") as "[Hr2 Hrmap]".
      eassumption.
    iDestruct (big_sepM_delete _ _ r_t3 with "Hrmap") as "[Hr3 Hrmap]".
      by rewrite lookup_delete_ne //.
    iDestruct (big_sepM_delete _ _ r_t4 with "Hrmap") as "[Hr4 Hrmap]".
      by rewrite !lookup_delete_ne //.

    rewrite /(region_mapsto b b_m).
    set ai := region_addrs b b_m.
    assert (Hai: region_addrs b b_m = ai) by reflexivity.
    iDestruct (big_sepL2_length with "Hprog") as %Hprog_len.
    cbn in Hprog_len.
    assert ((b + malloc_subroutine_instrs_length)%a = Some b_m) as Hb_bm.
    { rewrite /malloc_subroutine_instrs_length.
      rewrite region_addrs_length /region_size in Hprog_len. solve_addr. }
    assert (contiguous_between ai b b_m) as Hcont.
    { apply contiguous_between_of_region_addrs; eauto.
      rewrite /malloc_subroutine_instrs_length in Hb_bm. solve_addr. }

    assert (HPC: ∀ a, a ∈ ai → isCorrectPC (inr (RX, Global, b, e, a))).
    { intros a Ha.
      pose proof (contiguous_between_middle_bounds' _ _ _ _ Hcont Ha) as [? ?].
      constructor; eauto. solve_addr. }

    (* lt r_t3 0 r_t1 *)
    destruct ai as [|a l];[inversion Hprog_len|].
    destruct l as [|? l];[inversion Hprog_len|].
    pose proof (contiguous_between_cons_inv_first _ _ _ _ Hcont) as ->.
    iPrologue "Hprog".
    destruct (wsize) as [size|].
    2: { iApply (wp_AddSubLt_fail with "[$HPC $Hi $Hr3 $Hr1]");
         [apply decode_encode_instrW_inv|right;right;eauto|..].
         { apply HPC; repeat constructor. }
         iEpilogue "_". iApply wp_value. by iRight.
    }
    iApply (wp_add_sub_lt_success_z_r with "[$HPC $Hi $Hr3 $Hr1]");
      [apply decode_encode_instrW_inv|right;right;eauto|iContiguous_next Hcont 0|..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hprog_done & Hr1 & Hr3)".
    (* move r_t2 PC *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_move_success_reg_fromPC with "[$HPC $Hi $Hr2]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 1|auto|..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr2)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* lea r_t2 4 *)
    do 3 (destruct l as [|? l];[inversion Hprog_len|]).
    assert (a0 + 4 = Some a3)%a as Hlea1.
    { apply contiguous_between_incr_addr_middle with (i:=1) (j:=4) (ai:=a0) (aj:=a3) in Hcont;auto. }
    iPrologue "Hprog".
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr2]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 2|try done..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr2)". iCombine "Hi" "Hprog_done" as "Hprog_done".

    (* we need do destruct on the cases for the size *)
    destruct (decide (0 < size)%Z) as [Hsize | Hsize].
    2: {
      (* the program will not jump, and go to the fail instruction *)
      (* jnz  r_t2 r_t3 *)
      assert (rules_AddSubLt.denote (Lt r_t3 (inl 0%Z) (inr r_t1)) 0 size = 0) as ->.
      { simpl. clear -Hsize. apply Z.ltb_nlt in Hsize. rewrite Hsize. auto. }
      iPrologue "Hprog".
      iApply (wp_jnz_success_next with "[$HPC $Hi $Hr2 $Hr3]");
        [apply decode_encode_instrW_inv| |iContiguous_next Hcont 3|..].
      { apply HPC; repeat constructor. }
      iEpilogue "(HPC & Hi & Hr2 & Hr3)". iCombine "Hi" "Hprog_done" as "Hprog_done".
      (* fail *)
      iPrologue "Hprog".
      iApply (wp_fail with "[$HPC $Hi]");
        [apply decode_encode_instrW_inv|..].
      { apply HPC; repeat constructor. }
      iEpilogue "_". iApply wp_value. by iRight.
    }

    (* otherwise we continue malloc *)
    iPrologue "Hprog".
    assert (rules_AddSubLt.denote (Lt r_t3 (inl 0%Z) (inr r_t1)) 0 size = 1) as ->.
    { simpl. clear -Hsize. apply Z.ltb_lt in Hsize. rewrite Hsize. auto. }
    iApply (wp_jnz_success_jmp with "[$HPC $Hi $Hr2 $Hr3]");
        [apply decode_encode_instrW_inv| |iContiguous_next Hcont 3|..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr2 & Hr3)". iCombine "Hi" "Hprog_done" as "Hprog_done".

    (* move r_t2 PC *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog". iCombine "Hi" "Hprog_done" as "Hprog_done".
    iDestruct "Hprog" as "[Hi Hprog]".
    iApply (wp_move_success_reg_fromPC with "[$HPC $Hi $Hr2]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 5|auto..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr2)".
    (* lea r_t2 malloc_instrs_length *)
    destruct l as [|? l];[inversion Hprog_len|]. iCombine "Hi" "Hprog_done" as "Hprog_done".
    iPrologue "Hprog".
    assert ((a3 + (malloc_subroutine_instrs_length - 5))%a = Some b_m) as Hlea.
    { assert (b + 5 = Some a3)%a. apply contiguous_between_incr_addr with (i:=5) (ai:=a3) in Hcont;auto.
      clear -H Hb_bm. solve_addr. }
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr2]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 6|apply Hlea|try done..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr2)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* load r_t2 r_t2 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    (* FIXME *)
    assert ((b_m =? a5)%a = false) as Hbm_a.
    { apply Z.eqb_neq. intro.
      pose proof (contiguous_between_middle_bounds _ 7 a5 _ _ Hcont eq_refl) as [? ?].
      solve_addr. }
    iApply (wp_load_success_same with "[$HPC $Hi $Hr2 Hmemptr]");
      [auto(*FIXME*)|apply decode_encode_instrW_inv|apply HPC; repeat constructor|
       auto| |iContiguous_next Hcont 7|..].
    { apply le_addr_withinBounds.
      - generalize (contiguous_between_length _ _ _ Hcont). cbn.
        clear; solve_addr.
      - revert Hbm_am Ham_e; solve_addr. }
    { rewrite Hbm_a; iFrame. }
    rewrite Hbm_a. iEpilogue "(HPC & Hr2 & Hi & Hmemptr)".
    iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* geta r_t3 r_t2 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_Get_success with "[$HPC $Hi $Hr3 $Hr2]");
      [apply decode_encode_instrW_inv|done| |iContiguous_next Hcont 8|auto..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr2 & Hr3)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    cbn [rules_Get.denote].
    (* lea_r r_t2 r_t1 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    destruct (a_m + size)%a as [a_m'|] eqn:Ha_m'; cycle 1.
    { iAssert ([∗ map] k↦x ∈ (∅:gmap RegName Word), k ↦ᵣ x)%I as "Hregs".
        by rewrite big_sepM_empty.
      iDestruct (big_sepM_insert with "[$Hregs $HPC]") as "Hregs'".
        by apply lookup_empty.
      iClear "Hregs". iRename "Hregs'" into "Hregs".
      iDestruct (big_sepM_insert with "[$Hregs $Hr1]") as "Hregs".
        by rewrite lookup_insert_ne // lookup_empty.
      iDestruct (big_sepM_insert with "[$Hregs $Hr2]") as "Hregs".
        by rewrite !lookup_insert_ne // lookup_empty.
      iApply (wp_lea with "[$Hregs $Hi]");
        [apply decode_encode_instrW_inv| |done|..].
      { apply HPC; repeat constructor. }
      { rewrite /regs_of /regs_of_argument !dom_insert_L dom_empty_L. set_solver-. }
      iNext. iIntros (regs' retv) "(Hspec & ? & ?)". iDestruct "Hspec" as %Hspec.
      destruct Hspec as [| Hfail].
      { exfalso. simplify_map_eq. }
      { cbn. iApply wp_pure_step_later; auto. iNext.
        iApply wp_value. auto. } }
    iApply (wp_lea_success_reg with "[$HPC $Hi $Hr2 $Hr1]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 9|try done..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr1 & Hr2)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* geta r_t1 r_t2 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_Get_success with "[$HPC $Hi $Hr1 $Hr2]");
      [apply decode_encode_instrW_inv|done| |iContiguous_next Hcont 10|auto..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr2 & Hr1)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    cbn [rules_Get.denote].
    (* move r_t4 r_t2 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_move_success_reg with "[$HPC $Hi $Hr4 $Hr2]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 11|auto..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr4 & Hr2)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* subseg r_t4 r_t3 r_t1 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    destruct (isWithin a_m a_m' b_m e) eqn:Ha_m'_within; cycle 1.
    { iAssert ([∗ map] k↦x ∈ (∅:gmap RegName Word), k ↦ᵣ x)%I as "Hregs'".
        by rewrite big_sepM_empty.
      iDestruct (big_sepM_insert with "[$Hregs' $HPC]") as "Hregs".
        by apply lookup_empty.
      iClear "Hregs'".
      iDestruct (big_sepM_insert with "[$Hregs $Hr1]") as "Hregs".
        by rewrite lookup_insert_ne // lookup_empty.
      iDestruct (big_sepM_insert with "[$Hregs $Hr3]") as "Hregs".
        by rewrite !lookup_insert_ne // lookup_empty.
      iDestruct (big_sepM_insert with "[$Hregs $Hr4]") as "Hregs".
        by rewrite !lookup_insert_ne // lookup_empty.
      iApply (wp_Subseg with "[$Hregs $Hi]");
        [apply decode_encode_instrW_inv| |done|..].
      { apply HPC; repeat constructor. }
      { rewrite /regs_of /regs_of_argument !dom_insert_L dom_empty_L. set_solver-. }
      iNext. iIntros (regs' retv) "(Hspec & ? & ?)". iDestruct "Hspec" as %Hspec.
      destruct Hspec as [| Hfail].
      { exfalso. unfold addr_of_argument in *. simplify_map_eq.
        repeat match goal with H:_ |- _ => apply z_to_addr_eq_inv in H end; subst.
        congruence. }
      { cbn. iApply wp_pure_step_later; auto. iNext. iApply wp_value. auto. } }
    iApply (wp_subseg_success with "[$HPC $Hi $Hr4 $Hr3 $Hr1]");
      [apply decode_encode_instrW_inv| |split;apply z_to_addr_z_of|try done..].
    { apply HPC; repeat constructor. }
    { iContiguous_next Hcont 12. }
    iEpilogue "(HPC & Hi & Hr3 & Hr1 & Hr4)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* sub r_t3 r_t3 r_t1 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_add_sub_lt_success_dst_r with "[$HPC $Hi $Hr1 $Hr3]");
      [apply decode_encode_instrW_inv|auto|iContiguous_next Hcont 13|try done..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr1 & Hr3)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    cbn [denote].
    (* lea r_t4 r_t3 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_lea_success_reg with "[$HPC $Hi $Hr4 $Hr3]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 14|try done..].
    { apply HPC; repeat constructor. }
    { transitivity (Some a_m); auto. clear; solve_addr. }
    iEpilogue "(HPC & Hi & Hr3 & Hr4)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t3 r_t2 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_move_success_reg with "[$HPC $Hi $Hr3 $Hr2]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 15|auto..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr3 & Hr2)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* sub r_t1 0 r_t1 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_add_sub_lt_success_z_dst with "[$HPC $Hi $Hr1]");
      [apply decode_encode_instrW_inv|auto|iContiguous_next Hcont 16|try done..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr1)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    cbn [denote].
    (* lea r_t3 r_t1 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_lea_success_reg with "[$HPC $Hi $Hr3 $Hr1]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 17|try done..].
    { apply HPC; repeat constructor. }
    { transitivity (Some 0)%a; auto. clear; solve_addr. }
    iEpilogue "(HPC & Hi & Hr1 & Hr3)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* getb r_t1 r_t3 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_Get_success with "[$HPC $Hi $Hr1 $Hr3]");
      [apply decode_encode_instrW_inv|done| |iContiguous_next Hcont 18|try done..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr3 & Hr1)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    cbn [rules_Get.denote].
    (* lea r_t3 r_t1 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_lea_success_reg with "[$HPC $Hi $Hr3 $Hr1]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 19|try done..].
    { apply HPC; repeat constructor. }
    { transitivity (Some b_m)%a; auto. clear; solve_addr. }
    iEpilogue "(HPC & Hi & Hr1 & Hr3)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* store r_t3 r_t2 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_store_success_reg with "[$HPC $Hi $Hr2 $Hr3 $Hmemptr]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 20|try done..].
    { apply HPC; repeat constructor. }
    { split;try done. apply le_addr_withinBounds.
      - generalize (contiguous_between_length _ _ _ Hcont). cbn.
        clear; solve_addr.
      - revert Hbm_am Ham_e; solve_addr. }
    iEpilogue "(HPC & Hi & Hr2 & Hr3 & Hmemptr)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t1 r_t4 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_move_success_reg with "[$HPC $Hi $Hr1 $Hr4]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 21|auto..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr1 & Hr4)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t2 0 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_move_success_z with "[$HPC $Hi $Hr2]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 22|auto..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr2)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t3 0 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_move_success_z with "[$HPC $Hi $Hr3]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 23|auto..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr3)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t4 0 *)
    destruct l as [|? l];[inversion Hprog_len|].
    iPrologue "Hprog".
    iApply (wp_move_success_z with "[$HPC $Hi $Hr4]");
      [apply decode_encode_instrW_inv| |iContiguous_next Hcont 24|auto..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr4)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* jmp r_t0 *)
    iPrologue "Hprog".
    iApply (wp_jmp_success with "[$HPC $Hi $Hr0]");
      [apply decode_encode_instrW_inv|..].
    { apply HPC; repeat constructor. }
    iEpilogue "(HPC & Hi & Hr0)". iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* continuation *)
    destruct l;[|inversion Hprog_len].
    pose proof (contiguous_between_bounds _ _ _ Hcont).
    assert ((a_m <= a_m')%a ∧ (a_m' <= e)%a).
    { unfold isWithin in Ha_m'_within. (* FIXME? *)
      rewrite andb_true_iff !Z.leb_le in Ha_m'_within |- *.
      revert Ha_m' Hsize; clear. solve_addr. }
    rewrite (region_addrs_zeroes_split _ a_m') //;[].
    iDestruct (region_mapsto_split _ _ a_m' with "Hmem") as "[Hmem_fresh Hmem]"; auto.
    { rewrite replicate_length //. }
    iDestruct ("Hinv_close" with "[Hprog_done Hmemptr Hmem $Hna]") as ">Hna".
    { iNext. iExists b_m, a_m'. iFrame.
      rewrite /malloc_subroutine_instrs /malloc_subroutine_instrs'.
      unfold region_mapsto. rewrite Hai. cbn.
      do 25 iDestruct "Hprog_done" as "[? Hprog_done]". iFrame.
      iPureIntro.
      unfold isWithin in Ha_m'_within. (* FIXME? *)
      rewrite andb_true_iff !Z.leb_le in Ha_m'_within |- *.
      revert Ha_m' Hsize; clear; solve_addr. }

    iApply (wp_wand with "[-]").
    { iApply "Hφ". iFrame.
      iDestruct (big_sepM_insert with "[$Hrmap $Hr4]") as "Hrmap".
      by rewrite lookup_delete. rewrite insert_delete.
      iDestruct (big_sepM_insert with "[$Hrmap $Hr3]") as "Hrmap".
      by rewrite lookup_insert_ne // lookup_delete //.
      rewrite insert_commute // insert_delete.
      iDestruct (big_sepM_insert with "[$Hrmap $Hr2]") as "Hrmap".
      by rewrite !lookup_insert_ne // lookup_delete //.
      rewrite (insert_commute _ r_t2 r_t4) // (insert_commute _ r_t2 r_t3) //.
      rewrite insert_delete.
      rewrite (insert_commute _ r_t3 r_t2) // (insert_commute _ r_t4 r_t2) //.
      rewrite (insert_commute _ r_t4 r_t3) //. iFrame.
      iExists a_m, a_m', size. iFrame. repeat iSplit; auto; iPureIntro.
      clear -H Hbm_am. solve_addr. destruct H0;auto. lia.
    }
    { auto. }
  Qed.

  Ltac consider_next_reg r1 r2 :=
    destruct (decide (r1 = r2));[subst;rewrite lookup_insert;eauto|rewrite lookup_insert_ne;auto].

  Lemma related_sts_pub_world_revoked_permanent W a :
    (std W) !! a = Some Revoked →
    related_sts_pub_world W (<s[a:=Permanent]s>W).
  Proof.
    intros Ha.
    rewrite /related_sts_pub_world /=.
    split;[|apply related_sts_pub_refl].
    rewrite /related_sts_pub. split.
    - rewrite dom_insert_L. set_solver.
    - intros i x y Hx Hy.
      destruct (decide (a = i)).
      + subst.
        rewrite Hx in Ha. inversion Ha.
        rewrite lookup_insert in Hy. inversion Hy.
        right with (Permanent);[|left]. constructor.
      + rewrite lookup_insert_ne in Hy;auto.
        rewrite Hx in Hy.
        inversion Hy; subst.
        left.
  Qed.

  Lemma std_update_multiple_insert_commute W a (l: list Addr) ρ ρ' :
     a ∉ l →
     std_update_multiple (<s[a:=ρ']s> W) l ρ = <s[a:=ρ']s> (std_update_multiple W l ρ).
   Proof.
     intros Hne.
     induction l; auto; simpl.
     apply not_elem_of_cons in Hne as [Hne Hnin].
     rewrite IHl;auto.
     rewrite /std_update /revoke /loc /std /=. rewrite insert_commute;auto.
   Qed.

  Lemma related_sts_pub_update_multiple_perm W l :
    Forall (λ k, std W !! k = Some Revoked) l →
    related_sts_pub_world W (std_update_multiple W l Permanent).
  Proof.
    intros Hforall. induction l.
    - apply related_sts_pub_refl_world.
    - simpl.
      apply list.Forall_cons in Hforall as [ Ha_std Hforall].
      eapply related_sts_pub_trans_world;[apply IHl; auto|].
      destruct (decide (a ∈ l)).
      { rewrite (_: <s[a:=Permanent]s>(std_update_multiple W l Permanent) = std_update_multiple W l Permanent) /=.
          by apply related_sts_pub_refl_world.
         rewrite /std_update insert_id /=. by destruct (std_update_multiple W l Permanent).
           by apply std_sta_update_multiple_lookup_in_i. }
      destruct W as [Hstd Hloc].
      apply related_sts_pub_world_revoked_permanent in Ha_std.
      eapply related_sts_pub_trans_world;[apply std_update_mutiple_related_monotone,Ha_std|].
      rewrite std_update_multiple_insert_commute //. apply related_sts_pub_refl_world.
  Qed.

  Lemma update_region_revoked_perm E W l v φ `{∀ Wv, Persistent (φ Wv)} :
    (std W) !! l = Some Revoked ->
    future_priv_mono φ v -∗
    sts_full_world W -∗
    region W -∗
    l ↦ₐ v -∗ φ (W,v) -∗ rel l φ ={E}=∗ region (<s[l := Permanent ]s>W)
                             ∗ sts_full_world (<s[l := Permanent ]s>W).
  Proof.
    iIntros (Hrev) "#Hmono Hsts Hreg Hl #Hφ #Hrel".
    rewrite region_eq /region_def.
    iDestruct "Hreg" as (M Mρ) "(Hγrel & #Hdom & #Hdom' & Hpreds)".
    iDestruct "Hdom" as %Hdom. iDestruct "Hdom'" as %Hdom'.
    rewrite RELS_eq /RELS_def.
    rewrite rel_eq /rel_def REL_eq /REL_def. iDestruct "Hrel" as (γ) "[HREL Hsaved]".
    iDestruct (reg_in γrel (M) with "[$Hγrel $HREL]") as %HMeq.
    rewrite /region_map_def HMeq big_sepM_insert; [|by rewrite lookup_delete].
    iDestruct "Hpreds" as "[Hl' Hr]".
    iDestruct "Hl'" as (ρ Hl) "[Hstate Hresources]".
    iDestruct (sts_full_state_std with "Hsts Hstate") as %Hρ.
    rewrite Hrev in Hρ. inversion Hρ as [Hρrev]. subst.
    iMod (sts_update_std _ _ _ Permanent with "Hsts Hstate") as "[Hsts Hstate]".
    assert (related_sts_pub_world W (<s[l := Permanent ]s> W)) as Hrelated.
    { apply related_sts_pub_world_revoked_permanent; auto. }
    iDestruct (region_map_monotone with "Hr") as "Hr";[apply Hrelated|].
    pose proof (related_sts_pub_priv_world _ _ Hrelated) as Hrelated'.
    iDestruct ("Hmono" $! _ _ Hrelated' with "Hφ") as "Hφ'".
    assert (is_Some (M !! l)) as [x Hsome].
    { apply elem_of_gmap_dom. rewrite -Hdom. apply elem_of_gmap_dom. eauto. }
    iDestruct (region_map_delete_nonstatic with "Hr") as "Hr"; [intros m;intros Hcontr;congruence|].
    iDestruct (region_map_insert_nonmonostatic Permanent with "Hr") as "Hr";auto.
    iDestruct (big_sepM_delete _ _ l _ Hsome with "[Hl Hstate $Hr]") as "Hr".
    { iExists Permanent. iFrame. iSplitR;[iPureIntro;apply lookup_insert|].
      iExists φ. rewrite HMeq lookup_insert in Hsome.
      inversion Hsome. repeat (iSplit; auto). }
    rewrite /std_update /=. iFrame "Hsts".
    iExists M. iFrame. rewrite -HMeq. iFrame.
    iModIntro. iExists _. iFrame. iPureIntro.
    apply insert_id in Hsome. apply insert_id in Hl. rewrite -Hsome -Hl. split.
    - repeat rewrite dom_insert_L;rewrite Hdom;set_solver.
    - repeat rewrite dom_insert_L;rewrite Hdom';set_solver.
  Qed.

  Lemma extend_region_perm_sepL2_from_rev φ E W l1 l2 `{∀ Wv, Persistent (φ Wv)}:
     Forall (λ k, std W !! k = Some Revoked) l1 →
     sts_full_world W -∗ region W -∗
     ([∗ list] k;v ∈ l1;l2, k ↦ₐ v ∗ φ (W, v) ∗ future_priv_mono φ v ∗ rel k φ)

     ={E}=∗

     region (std_update_multiple W l1 Permanent)
     ∗ ([∗ list] k ∈ l1, rel k φ)
     ∗ sts_full_world (std_update_multiple W l1 Permanent).
  Proof.
    revert l2. induction l1.
    { cbn. intros. iIntros "? ? ?". iFrame. eauto. }
    { intros ? [? ?]%Forall_cons_1. iIntros "Hsts Hr Hl".
      iDestruct (big_sepL2_length with "Hl") as %Hlen.
      iDestruct (NoDup_of_sepL2_exclusive with "[] Hl") as %[Hal1 ND]%NoDup_cons.
      { iIntros (? ? ?) "(H1 & ? & ?) (H2 & ? & ?)".
        iApply (addr_dupl_false with "H1 H2"). }
      destruct l2; [ by inversion Hlen |].
      iDestruct (big_sepL2_cons with "Hl") as "[(Ha & Hφ & #Hf & #Hrel) Hl]".
      iMod (IHl1 with "Hsts Hr Hl") as "(Hr & ? & Hsts)"; auto.
      iMod (update_region_revoked_perm with "Hf Hsts Hr Ha [Hφ] Hrel") as "(? & ?)"; auto.
      { erewrite std_sta_update_multiple_lookup_same_i;auto. }
      { iApply ("Hf" with "[] Hφ"). iPureIntro.
        apply related_sts_pub_priv_world,related_sts_pub_update_multiple_perm. auto. }
      iFrame "∗ #". done.
    }
  Qed.

  (* dummy helper to move the later in front of the implication *)
  Lemma helper W' g x a :
    (∀ (r0 : leibnizO Reg) (W'0 : prodO (leibnizO (STS_std_states Addr region_type))
                                           (leibnizO (STS_states * STS_rels))),
        future_world g a W' W'0 → ▷ ((interp_expr interp r0) W'0) (updatePcPerm x)) -∗
    (▷ ∀ (r0 : leibnizO Reg) (W'0 : prodO (leibnizO (STS_std_states Addr region_type))
                                           (leibnizO (STS_states * STS_rels))),
          future_world g a W' W'0 → ((interp_expr interp r0) W'0) (updatePcPerm x)).
  Proof.
    iIntros "Ha". iApply bi.later_forall. iIntros (r0). iApply bi.later_forall. iIntros (W'').
    iSpecialize ("Ha" $! r0 W'').
    destruct g;simpl.
    all: iIntros (Hfuture). all: iSpecialize ("Ha" $! Hfuture);iNext;iFrame.
  Qed.

  Lemma simple_malloc_subroutine_valid W N b e :
    Forall (λ a, W.1 !! a = Some Revoked) (region_addrs b e) →
    na_inv logrel_nais N (malloc_inv b e) -∗
    ([∗ list] a ∈ region_addrs b e, rel a (λne Wv, interp Wv.1 Wv.2)) -∗
    interp W (inr (E,Global,b,e,b)).
  Proof.
    iIntros (Hrev) "#Hmalloc #Hrels".
    rewrite fixpoint_interp1_eq /=. iIntros (r W' Hrelated). iAlways. iNext.
    iIntros "(#[% Hregs_valid] & Hregs & Hr & Hsts & Hown)".
    iSplit;auto.
    iDestruct (big_sepM_delete _ _ PC with "Hregs") as "[HPC Hregs]";[rewrite lookup_insert;eauto|].
    destruct H with r_t0 as [? ?].
    iDestruct (big_sepM_delete _ _ r_t0 with "Hregs") as "[r_t0 Hregs]";[rewrite !lookup_delete_ne// !lookup_insert_ne//;eauto|].
    destruct H with r_t1 as [? ?].
    iDestruct (big_sepM_delete _ _ r_t1 with "Hregs") as "[r_t1 Hregs]";[rewrite !lookup_delete_ne// !lookup_insert_ne//;eauto|].
    iApply (wp_wand with "[-]").
    iApply (simple_malloc_subroutine_spec with "[- $Hown $Hmalloc $Hregs $r_t0 $HPC $r_t1]");[|solve_ndisj|].
    3: { iSimpl. iIntros (v) "[H | ->]". iExact "H". iIntros (Hcontr); done. }
    { rewrite !dom_delete_L dom_insert_L. apply regmap_full_dom in H as <-. set_solver. }
    iDestruct ("Hregs_valid" $! r_t0 with "[]") as "Hr0_valid";auto.
    rewrite /RegLocate H0.
    iDestruct (jmp_or_fail_spec with "Hr0_valid") as "Hcont".
    destruct (decide (isCorrectPC (updatePcPerm x))).
    2: { iNext. iIntros "(_ & _ & HPC & _)". iApply "Hcont". iFrame. iIntros (Hcontr). done. }
    iDestruct "Hcont" as (p g b' e' a Heq) "Hcont". simplify_eq.
    iDestruct (helper with "Hcont") as "Hcont'".
    iNext. iIntros "((Hown & Hregs) & Hr_t0 & HPC & Hres)".
    iDestruct "Hres" as (ba ea size Hsizeq Hsize Hbounds Hpos) "[Hr_t1 Hbe]".
    (* some usefull lemmas about [ba ea] *)
    assert (∃ l1 l2, region_addrs b e = l1 ++ region_addrs ba ea ++ l2) as [l1 [l2 Heqapp] ].
    { exists (region_addrs b ba),(region_addrs ea e).
      rewrite -region_addrs_split;[|solve_addr].
      rewrite -region_addrs_split;[auto|solve_addr]. }
    (* The following lemma can be derived from the fact that we own the resources for ba,ea, which means they cannot
       be in region W' *)
    iAssert (⌜Forall (λ k : Addr, std W' !! k = Some Revoked) (region_addrs ba ea)⌝)%I as %Hrev'.
    { rewrite Heqapp in Hrev. apply Forall_app in Hrev as [_ Hrev]. apply Forall_app in Hrev as [Hrev _].
      revert Hrev. rewrite !Forall_forall. iIntros (Hrev x Hin). specialize (Hrev x Hin).
      pose proof (related_sts_priv_world_std_sta_is_Some W W' x Hrelated) as [ρ Hρ];[eauto|].
      rewrite /region_mapsto.
      iDestruct (big_sepL_elem_of _ _ x with "Hrels") as "Hrel".
      { rewrite Heqapp. apply elem_of_app. right. apply elem_of_app. by left. }
      apply elem_of_list_lookup in Hin as [k Hk].
      iDestruct (big_sepL2_extract_l with "Hbe") as "[_ Hb]";[eauto|].
      iDestruct "Hb" as (w') "Hw'".
      destruct ρ;auto. (* all the following will lead to duplicate resources for x *)
      - iDestruct (region_open_monotemp with "[$Hrel $Hr $Hsts]") as (v) "(_ & _ & _ & Hw & _)";[eauto|auto|..].
        iDestruct (addr_dupl_false with "Hw' Hw") as "?";auto.
      - iDestruct (region_open_perm with "[$Hrel $Hr $Hsts]") as (v) "(_ & _ & _ & Hw & _)";[eauto|auto|..].
        iDestruct (addr_dupl_false with "Hw' Hw") as "?";auto.
      - iMod (region_open_monostatic with "[$Hr $Hsts]") as "(_ & _ & ? & H & %)";[apply Hρ|..].
        rewrite /region_invariants_static.static_resources.
        apply elem_of_gmap_dom in H2 as [? Hx].
        iDestruct (big_sepM_delete with "H") as "[H ?]";[apply Hx|].
        iDestruct "H" as (?) "[HH Hw]".
        iDestruct (addr_dupl_false with "Hw' Hw") as "?";auto.
      - iDestruct (region_open_uninitialized with "[$Hrel $Hr $Hsts]") as "(_ & _ & _ & Hw)";[eauto|auto|..].
        iDestruct (addr_dupl_false with "Hw' Hw") as "?";auto.
    }
    (* Next is the interesting part of the spec: we must allocate the invariants making the malloced region valid *)
    iMod (extend_region_perm_sepL2_from_rev (λ Wv, interp Wv.1 Wv.2) _ _
                                            (region_addrs ba ea)
                                            (region_addrs_zeroes ba ea) with "Hsts Hr [Hbe]") as "(Hr & #Hvalid & Hsts)";auto.
    { rewrite Heqapp.
      iDestruct (big_sepL_app with "Hrels") as "[_ Hrels']".
      iDestruct (big_sepL_app with "Hrels'") as "[Hrels'' _]".
      iDestruct (big_sepL2_to_big_sepL_l _ _ (region_addrs_zeroes ba ea) with "Hrels''") as "Hrels3".
      { by rewrite /region_addrs_zeroes region_addrs_length replicate_length. }
      iDestruct (big_sepL2_sep with "[Hrels3 Hbe]") as "Hbe";[iFrame "Hbe"; iFrame "Hrels3"|].
      iApply (big_sepL2_mono with "Hbe").
      iIntros (k a' w Hin1 Hin2) "(Ha & Hrel)". iFrame.
      apply region_addrs_zeroes_lookup in Hin2 as ->. iSplit.
      - by rewrite fixpoint_interp1_eq /=.
      - iAlways. iIntros (W1 W2 Hrelated') "Hv /=". by rewrite !fixpoint_interp1_eq /=.
    }
    rewrite -!(delete_insert_ne _ r_t1)//.
    iDestruct (big_sepM_insert with "[$Hregs $Hr_t1]") as "Hregs";[apply lookup_delete|rewrite insert_delete].
    rewrite -!(delete_insert_ne _ r_t0)//.
    iDestruct (big_sepM_insert with "[$Hregs $Hr_t0]") as "Hregs";[apply lookup_delete|rewrite insert_delete delete_insert_delete].
    rewrite -!(delete_insert_ne _ PC)//.
    iDestruct (big_sepM_insert with "[$Hregs $HPC]") as "Hregs";[apply lookup_delete|rewrite insert_delete].
    set regs := <[PC:=updatePcPerm (inr (p, g, b', e', a))]>
                            (<[r_t0:=inr (p, g, b', e', a)]> (<[r_t1:=inr (RWX, Global, ba, ea, ba)]> (<[r_t2:=inl 0%Z]> (<[r_t3:=inl 0%Z]> (<[r_t4:=inl 0%Z]> r))))).
    iDestruct ("Hcont'" $! regs with "[] [$Hown Hregs $Hr $Hsts]") as "[_ Hcont'']".
    { destruct g; iPureIntro;[apply related_sts_pub_priv_world..|
                              apply related_sts_pub_a_world]; try apply related_sts_pub_update_multiple_perm;auto. }
    { rewrite /regs. iSplitR "Hregs".
      - iSplit.
        + iPureIntro. intros x. consider_next_reg x PC. consider_next_reg x r_t0. consider_next_reg x r_t1.
          consider_next_reg x r_t2. consider_next_reg x r_t3. consider_next_reg x r_t4.
        + iIntros (x Hne). rewrite /RegLocate. consider_next_reg x PC;[contradiction|].
          consider_next_reg x r_t0.
          { iDestruct ("Hregs_valid" $! r_t0 with "[]") as "Hr0_valid'";auto. rewrite H0.
            iApply (interp_monotone with "[] Hr0_valid'"). iPureIntro. apply related_sts_pub_update_multiple_perm;auto. }
          consider_next_reg x r_t1.
          { rewrite !fixpoint_interp1_eq. iApply (big_sepL_mono with "Hvalid").
            iIntros (k y Hky) "Ha". iFrame. iPureIntro. simpl.
            rewrite std_sta_update_multiple_lookup_in_i;auto.
            apply elem_of_list_lookup. exists k. auto.
          }
          consider_next_reg x r_t2. by rewrite !fixpoint_interp1_eq.
          consider_next_reg x r_t3. by rewrite !fixpoint_interp1_eq.
          consider_next_reg x r_t4. by rewrite !fixpoint_interp1_eq.
          iSpecialize ("Hregs_valid" $! _ Hne).
          iApply (interp_monotone with "[] Hregs_valid"). iPureIntro. apply related_sts_pub_update_multiple_perm;auto.
      - rewrite insert_insert. iFrame.
    }
    iApply (wp_wand with "Hcont''").
    iIntros (v) "HH". iIntros (Hv).
    iDestruct ("HH" $! Hv) as (? ?) "(Hfull & Hvals & % & Hown & Hsts & Hr)".
    iExists _,_. iFrame. iPureIntro.
    eapply related_sts_priv_trans_world;[|apply H4].
    apply related_sts_pub_priv_world. apply related_sts_pub_update_multiple_perm;auto.
  Qed.

End SimpleMalloc.


Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.
Require Import ZArith.
Require Import tweetnacl20140427.tweetNaclBase.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.verif_salsa_base.
Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.Snuffle.
Require Import tweetnacl20140427.spec_salsa.

Require Import tweetnacl20140427.verif_fcore_jbody.

Opaque Snuffle.Snuffle.

Lemma SnuffleS i l: Snuffle (S i) l = bind (Snuffle i l) (Snuffle 1). reflexivity. Qed.

Fixpoint WcontI (xs: list int) (j:nat) (l:list val):Prop :=
   match j with O => Zlength l = 16
   | (S n) => Zlength l = 16 /\
              exists t0 t1 t2 t3,
              Znth ((5 * (Z.of_nat n) + 4 * 0) mod 16) (map Vint xs) = Vint t0 /\
              Znth ((5 * (Z.of_nat n) + 4 * 1) mod 16) (map Vint xs) = Vint t1 /\
              Znth ((5 * (Z.of_nat n) + 4 * 2) mod 16) (map Vint xs) = Vint t2 /\
              Znth ((5 * (Z.of_nat n) + 4 * 3) mod 16) (map Vint xs) = Vint t3 /\
              exists wl, WcontI xs n wl /\
                match Wcopyspec t0 t1 t2 t3 with
                 (s0,s1,s2,s3) => wlistJ' wl (Z.of_nat n) s0 s1 s2 s3 l
                end
  end.

Lemma WcontI_Zlength xs j l: WcontI xs j l -> Zlength l=16.
Proof. intros. destruct j; eapply H. Qed.

Lemma WWI r w (W: WcontI r 4 w) (R:Zlength r = 16):
      exists wi, w=map Vint wi /\ snuffleRound r = Some wi.
Proof.
apply listD16 in R.
destruct R as [x0 [x1 [x2 [x3 [x4 [x5 [x6 [x7
              [x8 [x9 [x10 [x11 [x12 [x13 [x14 [x15 XX]]]]]]]]]]]]]]]]. subst r.
destruct W as [HW H1].
destruct H1 as [t0 [t1 [t2 [t3 [T0 [T1 [T2 [T3 [w1 [[_ H1] W1]]]]]]]]]]. simpl in T0, T1, T2, T3.
rewrite Z.mod_small in T0. 2: omega.
rewrite Zmod_eq in T1. 2: omega.
rewrite Zmod_eq in T2. 2: omega.
rewrite Zmod_eq in T3. 2: omega. simpl in T0, T1, T2, T3.
destruct H1 as [t4 [t5 [t6 [t7 [T4 [T5 [T6 [T7 [w2 [[_ H1] W2]]]]]]]]]]. simpl in T4, T5, T6, T7.
rewrite Zmod_eq in T4. 2: omega.
rewrite Zmod_eq in T5. 2: omega.
rewrite Zmod_eq in T6. 2: omega.
rewrite Zmod_eq in T7. 2: omega. simpl in T4, T5, T6, T7.
destruct H1 as [t8 [t9 [t10 [t11 [T8 [T9 [T10 [T11 [w3 [[_ H1] W3]]]]]]]]]]. simpl in T8, T9, T10, T11.
rewrite Z.mod_small in T8. 2: omega.
rewrite Z.mod_small in T9. 2: omega.
rewrite Zmod_eq in T10. 2: omega.
rewrite Zmod_eq in T11. 2: omega. simpl in T8, T9, T10, T11.
destruct H1 as [t12 [t13 [t14 [t15 [T12 [T13 [T14 [T15 [w4 [L4 W4]]]]]]]]]]. simpl in T12, T13, T14, T15.
rewrite Z.mod_small in T12. 2: omega.
rewrite Z.mod_small in T13. 2: omega.
rewrite Z.mod_small in T14. 2: omega.
rewrite Z.mod_small in T15. 2: omega.
unfold Znth in *. simpl in  T0, T1, T2, T3, T4, T5, T6, T7, T8, T9, T10, T11, T12, T13, T14, T15.
symmetry in T0; inv T0. symmetry in T1; inv T1. symmetry in T2; inv T2. symmetry in T3; inv T3.
symmetry in T4; inv T4. symmetry in T5; inv T5. symmetry in T6; inv T6. symmetry in T7; inv T7.
symmetry in T8; inv T8. symmetry in T9; inv T9. symmetry in T10; inv T10. symmetry in T11; inv T11.
symmetry in T12; inv T12. symmetry in T13; inv T13. symmetry in T14; inv T14. symmetry in T15; inv T15.
red in L4.
simpl in W4.
remember (Int.xor x4 (Int.rol (Int.add x0 x12) (Int.repr 7))) as z1.
remember (Int.xor x8 (Int.rol (Int.add z1 x0) (Int.repr 9))) as z2.
remember (Int.xor x12 (Int.rol (Int.add z2 z1) (Int.repr 13))) as z3.
remember (Int.xor x0 (Int.rol (Int.add z3 z2) (Int.repr 18))) as z0.
apply listD16 in L4.
destruct L4 as [y0 [y1 [y2 [y3 [y4 [y5 [y6 [y7
               [y8 [y9 [y10 [y11 [y12 [y13 [y14 [y15 XX]]]]]]]]]]]]]]]]. subst w4.
destruct W4 as [_ W4]; simpl in W4.
(*rewrite Z.mod_small in W4. 2: omega.
rewrite Z.mod_small in W4. 2: omega.
rewrite Z.mod_small in W4. 2: omega.
rewrite Z.mod_small in W4. 2: omega.*)
unfold upd_Znth, sublist in W4; simpl in W4. subst w3.
simpl in W3.
remember (Int.xor x9 (Int.rol (Int.add x5 x1) (Int.repr 7))) as z6.
remember (Int.xor x13 (Int.rol (Int.add z6 x5) (Int.repr 9))) as z7.
remember (Int.xor x1 (Int.rol (Int.add z7 z6) (Int.repr 13))) as z4.
remember (Int.xor x5 (Int.rol (Int.add z4 z7) (Int.repr 18))) as z5.
destruct W3 as [_ W3]; simpl in W3.
unfold upd_Znth, sublist in W3; simpl in W3. subst w2.
destruct W2 as [_ W2]. simpl in W2.
remember (Int.xor x14 (Int.rol (Int.add x10 x6) (Int.repr 7))) as z11.
remember (Int.xor x2 (Int.rol (Int.add z11 x10) (Int.repr 9))) as z8.
remember (Int.xor x6 (Int.rol (Int.add z8 z11) (Int.repr 13))) as z9.
remember (Int.xor x10 (Int.rol (Int.add z9 z8) (Int.repr 18))) as z10.
unfold upd_Znth, sublist in W2; simpl in W2. subst w1.
destruct W1 as [_ W1]; simpl in W1.
remember (Int.xor x3 (Int.rol (Int.add x15 x11) (Int.repr 7))) as z12.
remember (Int.xor x7 (Int.rol (Int.add z12 x15) (Int.repr 9))) as z13.
remember (Int.xor x11 (Int.rol (Int.add z13 z12) (Int.repr 13))) as z14.
remember (Int.xor x15 (Int.rol (Int.add z14 z13) (Int.repr 18))) as z15.
unfold upd_Znth, sublist in W1; simpl in W1. subst w. clear HW.
exists [z0; z1; z2; z3; z4; z5; z6; z7;
        z8; z9; z10; z11; z12; z13; z14; z15].
split. reflexivity.
rewrite Int.add_commut in Heqz0, Heqz2, Heqz3, Heqz4, Heqz5, Heqz7, Heqz8,
  Heqz9, Heqz10, Heqz13, Heqz14, Heqz15.
subst z0 z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 z11 z12 z13 z14 z15. reflexivity.
Qed.

Definition array_copy3_statement:=
Sfor (Sset _m (Econst_int (Int.repr 0) tint))
     (Ebinop Olt (Etempvar _m tint) (Econst_int (Int.repr 16) tint) tint)
     (Ssequence
        (Sset _t'19
           (Ederef
              (Ebinop Oadd (Evar _w (tarray tuint 16)) (Etempvar _m tint)
                 (tptr tuint)) tuint))
        (Sassign
           (Ederef
              (Ebinop Oadd (Evar _x (tarray tuint 16)) (Etempvar _m tint)
                 (tptr tuint)) tuint) (Etempvar _t'19 tuint)))
     (Sset _m
        (Ebinop Oadd (Etempvar _m tint) (Econst_int (Int.repr 1) tint) tint)).

Lemma array_copy3 Espec:
forall FR c k h nonce out
       i w x y t (xlist wlist:list val)
       (WZ: forall m, 0<=m<16 -> exists mval, Znth m wlist =Vint mval),
@semax CompSpecs Espec
  (func_tycontext f_core SalsaVarSpecs SalsaFunSpecs nil)
  (PROP  ()
   LOCAL  (temp _j (Vint (Int.repr 4)); temp _i (Vint (Int.repr i)); lvar _t (tarray tuint 4) t;
   lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
   lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
   temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at Tsh (tarray tuint 16) wlist w;
         data_at Tsh (tarray tuint 16) xlist x))
 array_copy3_statement
  (normal_ret_assert
  (PROP  ()
   LOCAL  (temp _j (Vint (Int.repr 4)); temp _i (Vint (Int.repr i)); lvar _t (tarray tuint 4) t;
      lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
      lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
      temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at Tsh (tarray tuint 16) wlist w;
         data_at Tsh (tarray tuint 16) wlist x))).
Proof. intros. abbreviate_semax.
Time assert_PROP (Zlength wlist = 16 /\ Zlength xlist = 16) as WXL by entailer!. (*1.4 versus 5.4*)
destruct WXL as [WL XL].
unfold array_copy3_statement.
Time forward_for_simple_bound 16 (EX m:Z,
  (PROP  ()
   LOCAL  (temp _j (Vint (Int.repr 4)); temp _i (Vint (Int.repr i)); lvar _t (tarray tuint 4) t;
   lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
   lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
   temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at Tsh (tarray tuint 16) wlist w;
         EX mlist:_, !!(forall mm, 0<=mm<m -> Znth mm mlist = Znth mm wlist)
                && data_at Tsh (tarray tuint 16) mlist x))).
  (*1.2 versus 2.7*)
{ Exists xlist. Time entailer!. (*2.6 versus 6.7*) intros; omega. }
{ Intros mlist. rename H into M. rename i0 into m. rename H0 into HM.
  destruct (WZ _ M) as [mval MVAL].
  freeze [0;2] FR1.
  Time forward; change (@Znth val Vundef) with (@Znth val _); rewrite MVAL. (*3.5 versus 8.7*)
  Time solve[entailer!]. (*0.9 versus 3.3*)
  thaw FR1.
  Time assert_PROP (Zlength mlist = 16) as ML by entailer!. (*1.2 versus 3.5*)
  Time forward. (*3.2 versus 9*)
   { Exists (upd_Znth m mlist (Vint mval)).
     Time entailer!. (*2.8 versus 5.6*)
     intros mm ?.
     destruct (zeq mm m); subst.
     + rewrite MVAL, upd_Znth_same; trivial. omega.
     + rewrite <- HM. 2: omega.
       apply upd_Znth_diff; trivial; omega. }
}
{ Time entailer!. (*1.8 versus 4.3*)
  Intros mlist.
  assert_PROP (Zlength mlist = 16) as ML by entailer.
  apply derives_refl'. f_equal.
  eapply Znth_extensional. omega.
  intros kk K. apply H2. omega. }
Time Qed. (*June 4th, 2017 (laptop): 1s*)

Definition f_core_loop3_statement :=
Sfor (Sset _i (Econst_int (Int.repr 0) tint))
     (Ebinop Olt (Etempvar _i tint) (Econst_int (Int.repr 20) tint) tint)
     (Ssequence
        (Sfor (Sset _j (Econst_int (Int.repr 0) tint))
           (Ebinop Olt (Etempvar _j tint) (Econst_int (Int.repr 4) tint) tint)
           (Ssequence
              (Sfor (Sset _m (Econst_int (Int.repr 0) tint))
                 (Ebinop Olt (Etempvar _m tint)
                    (Econst_int (Int.repr 4) tint) tint)
                 (Ssequence
                    (Sset _t'33
                       (Ederef
                          (Ebinop Oadd (Evar _x (tarray tuint 16))
                             (Ebinop Omod
                                (Ebinop Oadd
                                   (Ebinop Omul
                                      (Econst_int (Int.repr 5) tint)
                                      (Etempvar _j tint) tint)
                                   (Ebinop Omul
                                      (Econst_int (Int.repr 4) tint)
                                      (Etempvar _m tint) tint) tint)
                                (Econst_int (Int.repr 16) tint) tint)
                             (tptr tuint)) tuint))
                    (Sassign
                       (Ederef
                          (Ebinop Oadd (Evar _t (tarray tuint 4))
                             (Etempvar _m tint) (tptr tuint)) tuint)
                       (Etempvar _t'33 tuint)))
                 (Sset _m
                    (Ebinop Oadd (Etempvar _m tint)
                       (Econst_int (Int.repr 1) tint) tint)))
              (Ssequence
                 (Ssequence
                    (Ssequence
                       (Sset _t'31
                          (Ederef
                             (Ebinop Oadd (Evar _t (tarray tuint 4))
                                (Econst_int (Int.repr 0) tint) (tptr tuint))
                             tuint))
                       (Ssequence
                          (Sset _t'32
                             (Ederef
                                (Ebinop Oadd (Evar _t (tarray tuint 4))
                                   (Econst_int (Int.repr 3) tint)
                                   (tptr tuint)) tuint))
                          (Scall (Some _t'5)
                             (Evar _L32
                                (Tfunction (Tcons tuint (Tcons tint Tnil))
                                   tuint cc_default))
                             [Ebinop Oadd (Etempvar _t'31 tuint)
                                (Etempvar _t'32 tuint) tuint;
                             Econst_int (Int.repr 7) tint])))
                    (Ssequence
                       (Sset _t'30
                          (Ederef
                             (Ebinop Oadd (Evar _t (tarray tuint 4))
                                (Econst_int (Int.repr 1) tint) (tptr tuint))
                             tuint))
                       (Sassign
                          (Ederef
                             (Ebinop Oadd (Evar _t (tarray tuint 4))
                                (Econst_int (Int.repr 1) tint) (tptr tuint))
                             tuint)
                          (Ebinop Oxor (Etempvar _t'30 tuint)
                             (Etempvar _t'5 tuint) tuint))))
                 (Ssequence
                    (Ssequence
                       (Ssequence
                          (Sset _t'28
                             (Ederef
                                (Ebinop Oadd (Evar _t (tarray tuint 4))
                                   (Econst_int (Int.repr 1) tint)
                                   (tptr tuint)) tuint))
                          (Ssequence
                             (Sset _t'29
                                (Ederef
                                   (Ebinop Oadd (Evar _t (tarray tuint 4))
                                      (Econst_int (Int.repr 0) tint)
                                      (tptr tuint)) tuint))
                             (Scall (Some _t'6)
                                (Evar _L32
                                   (Tfunction (Tcons tuint (Tcons tint Tnil))
                                      tuint cc_default))
                                [Ebinop Oadd (Etempvar _t'28 tuint)
                                   (Etempvar _t'29 tuint) tuint;
                                Econst_int (Int.repr 9) tint])))
                       (Ssequence
                          (Sset _t'27
                             (Ederef
                                (Ebinop Oadd (Evar _t (tarray tuint 4))
                                   (Econst_int (Int.repr 2) tint)
                                   (tptr tuint)) tuint))
                          (Sassign
                             (Ederef
                                (Ebinop Oadd (Evar _t (tarray tuint 4))
                                   (Econst_int (Int.repr 2) tint)
                                   (tptr tuint)) tuint)
                             (Ebinop Oxor (Etempvar _t'27 tuint)
                                (Etempvar _t'6 tuint) tuint))))
                    (Ssequence
                       (Ssequence
                          (Ssequence
                             (Sset _t'25
                                (Ederef
                                   (Ebinop Oadd (Evar _t (tarray tuint 4))
                                      (Econst_int (Int.repr 2) tint)
                                      (tptr tuint)) tuint))
                             (Ssequence
                                (Sset _t'26
                                   (Ederef
                                      (Ebinop Oadd (Evar _t (tarray tuint 4))
                                         (Econst_int (Int.repr 1) tint)
                                         (tptr tuint)) tuint))
                                (Scall (Some _t'7)
                                   (Evar _L32
                                      (Tfunction
                                         (Tcons tuint (Tcons tint Tnil))
                                         tuint cc_default))
                                   [Ebinop Oadd (Etempvar _t'25 tuint)
                                      (Etempvar _t'26 tuint) tuint;
                                   Econst_int (Int.repr 13) tint])))
                          (Ssequence
                             (Sset _t'24
                                (Ederef
                                   (Ebinop Oadd (Evar _t (tarray tuint 4))
                                      (Econst_int (Int.repr 3) tint)
                                      (tptr tuint)) tuint))
                             (Sassign
                                (Ederef
                                   (Ebinop Oadd (Evar _t (tarray tuint 4))
                                      (Econst_int (Int.repr 3) tint)
                                      (tptr tuint)) tuint)
                                (Ebinop Oxor (Etempvar _t'24 tuint)
                                   (Etempvar _t'7 tuint) tuint))))
                       (Ssequence
                          (Ssequence
                             (Ssequence
                                (Sset _t'22
                                   (Ederef
                                      (Ebinop Oadd (Evar _t (tarray tuint 4))
                                         (Econst_int (Int.repr 3) tint)
                                         (tptr tuint)) tuint))
                                (Ssequence
                                   (Sset _t'23
                                      (Ederef
                                         (Ebinop Oadd
                                            (Evar _t (tarray tuint 4))
                                            (Econst_int (Int.repr 2) tint)
                                            (tptr tuint)) tuint))
                                   (Scall (Some _t'8)
                                      (Evar _L32
                                         (Tfunction
                                            (Tcons tuint (Tcons tint Tnil))
                                            tuint cc_default))
                                      [Ebinop Oadd (Etempvar _t'22 tuint)
                                         (Etempvar _t'23 tuint) tuint;
                                      Econst_int (Int.repr 18) tint])))
                             (Ssequence
                                (Sset _t'21
                                   (Ederef
                                      (Ebinop Oadd (Evar _t (tarray tuint 4))
                                         (Econst_int (Int.repr 0) tint)
                                         (tptr tuint)) tuint))
                                (Sassign
                                   (Ederef
                                      (Ebinop Oadd (Evar _t (tarray tuint 4))
                                         (Econst_int (Int.repr 0) tint)
                                         (tptr tuint)) tuint)
                                   (Ebinop Oxor (Etempvar _t'21 tuint)
                                      (Etempvar _t'8 tuint) tuint))))
                          (Sfor (Sset _m (Econst_int (Int.repr 0) tint))
                             (Ebinop Olt (Etempvar _m tint)
                                (Econst_int (Int.repr 4) tint) tint)
                             (Ssequence
                                (Sset _t'20
                                   (Ederef
                                      (Ebinop Oadd (Evar _t (tarray tuint 4))
                                         (Etempvar _m tint) (tptr tuint))
                                      tuint))
                                (Sassign
                                   (Ederef
                                      (Ebinop Oadd
                                         (Evar _w (tarray tuint 16))
                                         (Ebinop Oadd
                                            (Ebinop Omul
                                               (Econst_int (Int.repr 4) tint)
                                               (Etempvar _j tint) tint)
                                            (Ebinop Omod
                                               (Ebinop Oadd
                                                  (Etempvar _j tint)
                                                  (Etempvar _m tint) tint)
                                               (Econst_int (Int.repr 4) tint)
                                               tint) tint) (tptr tuint))
                                      tuint) (Etempvar _t'20 tuint)))
                             (Sset _m
                                (Ebinop Oadd (Etempvar _m tint)
                                   (Econst_int (Int.repr 1) tint) tint))))))))
           (Sset _j
              (Ebinop Oadd (Etempvar _j tint) (Econst_int (Int.repr 1) tint)
                 tint)))
        (Sfor (Sset _m (Econst_int (Int.repr 0) tint))
           (Ebinop Olt (Etempvar _m tint) (Econst_int (Int.repr 16) tint)
              tint)
           (Ssequence
              (Sset _t'19
                 (Ederef
                    (Ebinop Oadd (Evar _w (tarray tuint 16))
                       (Etempvar _m tint) (tptr tuint)) tuint))
              (Sassign
                 (Ederef
                    (Ebinop Oadd (Evar _x (tarray tuint 16))
                       (Etempvar _m tint) (tptr tuint)) tuint)
                 (Etempvar _t'19 tuint)))
           (Sset _m
              (Ebinop Oadd (Etempvar _m tint) (Econst_int (Int.repr 1) tint)
                 tint))))
     (Sset _i
        (Ebinop Oadd (Etempvar _i tint) (Econst_int (Int.repr 1) tint) tint)).

Lemma f_core_loop3: forall (Espec : OracleKind) FR
c k h nonce out w x y t (xI:list int),
@semax CompSpecs Espec
  (func_tycontext f_core SalsaVarSpecs SalsaFunSpecs nil)
  (PROP  ()
   LOCAL  (temp _i (Vint (Int.repr 16)); lvar _t (tarray tuint 4) t;
   lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
   lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
   temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at_ Tsh (tarray tuint 4) t;
         data_at_ Tsh (tarray tuint 16) w;
         data_at Tsh (tarray tuint 16) (map Vint xI) x))
 f_core_loop3_statement
  (normal_ret_assert
  (PROP  ()
   LOCAL  (temp _i (Vint (Int.repr 20)); lvar _t (tarray tuint 4) t; lvar _y (tarray tuint 16) y;
       lvar _x (tarray tuint 16) x; lvar _w (tarray tuint 16) w; temp _in nonce;
       temp _out out; temp _c c; temp _k k; temp _h (Vint (Int.repr h)))
   SEP (FR; data_at_ Tsh (tarray tuint 4) t; data_at_ Tsh (tarray tuint 16) w;
        EX r:_, !!(Snuffle 20 xI = Some r) &&
           data_at Tsh (tarray tuint 16) (map Vint r) x))).
Proof. intros. abbreviate_semax.
unfold f_core_loop3_statement.
freeze [0;1;2] FR1.
Time assert_PROP (Zlength (map Vint xI) = 16) as XIZ by entailer!. (*0.9*)
thaw FR1.
rewrite Zlength_map in XIZ.
drop_LOCAL 0%nat.
Time forward_for_simple_bound 20 (EX i:Z,
  (PROP  ()
   LOCAL  (lvar _t (tarray tuint 4) t;
   lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
   lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
   temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at_ Tsh (tarray tuint 4) t; data_at_ Tsh (tarray tuint 16) w;
         EX r:_, !!(Snuffle (Z.to_nat i) xI = Some r) &&
             data_at Tsh (tarray tuint 16) (map Vint r) x))). (*0.9*)
{ Exists xI. Time entailer!. (*2.6*) }

{ rename H into I. Intros r. rename H into R.
  assert (XI: length xI = 16%nat). eapply (Zlength_length _ _ 16). omega. trivial.
  assert (RL:= Snuffle_length _ _ _ R XI).
  assert (RZL: Zlength r = 16). rewrite Zlength_correct, RL; reflexivity.

  Time forward_for_simple_bound 4 (EX j:Z,
  (PROP  ()
   LOCAL  (temp _i (Vint (Int.repr i)); lvar _t (tarray tuint 4) t;
   lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
   lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
   temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at_ Tsh (tarray tuint 4) t;
      EX l:_, !!(WcontI r (Z.to_nat j) l) && data_at Tsh (tarray tuint 16) l w;
      data_at Tsh (tarray tuint 16) (map Vint r) x))). (*1.5*)
  { Time entailer!. (*2.5*) Exists (list_repeat 16 Vundef). Time entailer!. (*0.1*) }
  { rename H into J. rename i0 into j.
    Intros wlist. rename H into WCONT.
    destruct (Znth_mapVint r ((5 * j + 4 * 0) mod 16)) as [t0 T0].
      rewrite RZL; apply Z_mod_lt; omega.
    destruct (Znth_mapVint r ((5 * j + 4 * 1) mod 16)) as [t1 T1].
      rewrite RZL; apply Z_mod_lt; omega.
    destruct (Znth_mapVint r ((5 * j + 4 * 2) mod 16)) as [t2 T2].
      rewrite RZL; apply Z_mod_lt; omega.
    destruct (Znth_mapVint r ((5 * j + 4 * 3) mod 16)) as [t3 T3].
      rewrite RZL; apply Z_mod_lt; omega.
    eapply semax_post_flipped'.
    apply (Jbody _ FR c k h nonce out w x y t i j r I J wlist _ _ _ _ T0 T1 T2 T3).
    Intros W. Exists W.
    Time entailer!. (*6.1*) (*TODO: eliminate old_go_lower*)
    rewrite Z.add_comm, Z2Nat.inj_add; try omega.
    assert (X: (Z.to_nat 1 + Z.to_nat j = S (Z.to_nat j))%nat) by reflexivity.
    rewrite X. simpl. split. assumption.
    exists t0, t1, t2, t3. simpl in T0, T1, T2, T3. rewrite Z2Nat.id, T0, T1, T2, T3.
    repeat split; trivial.
    exists wlist. split; trivial. omega. }

  Intros wlist. rename H into HW.
  destruct (WWI _ _ HW RZL) as [wints [WI SNUFF]]. subst wlist.
  freeze [0;1] FR2.
  eapply semax_post_flipped'.
  apply (array_copy3 _ (FRZL FR2) c k h nonce out
                  i w x y t (map Vint r) (map Vint wints)); trivial.
           intros. apply Znth_mapVint.
              destruct (snuffleRound_length _ _ SNUFF) as [WL _].
              rewrite Zlength_correct, WL; simpl; omega.
  Exists wints. rewrite Z.add_comm, Z2Nat.inj_add; try omega.
  Time entailer!. (*4.3*)(*TODO: eliminate old_go_lower*)
  rewrite SnuffleS, R; trivial.
  thaw FR2; cancel. }
 apply ENTAIL_refl.
Time Qed. (*June4th, 2017 (laptop): Finished transaction in 1.781 secs (1.072u,0.028s) (successful)*)


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paco.
From Paco Require Import paconotation_internal paco_internal pacotac_internal.
From Paco Require Export paconotation.
From Fairness Require Import pind_internal.
Set Implicit Arguments.

Section PIND8.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable T7 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5), Type.

(** ** Predicates of Arity 8
*)

Definition pind8(gf : rel8 T0 T1 T2 T3 T4 T5 T6 T7 -> rel8 T0 T1 T2 T3 T4 T5 T6 T7)(r: rel8 T0 T1 T2 T3 T4 T5 T6 T7) : rel8 T0 T1 T2 T3 T4 T5 T6 T7 :=
  @curry8 T0 T1 T2 T3 T4 T5 T6 T7 (pind (fun R0 => @uncurry8 T0 T1 T2 T3 T4 T5 T6 T7 (gf (@curry8 T0 T1 T2 T3 T4 T5 T6 T7 R0))) (@uncurry8 T0 T1 T2 T3 T4 T5 T6 T7 r)).

Definition upind8(gf : rel8 T0 T1 T2 T3 T4 T5 T6 T7 -> rel8 T0 T1 T2 T3 T4 T5 T6 T7)(r: rel8 T0 T1 T2 T3 T4 T5 T6 T7) := pind8 gf r /8\ r.
Arguments pind8 : clear implicits.
Arguments upind8 : clear implicits.
#[local] Hint Unfold upind8 : core.

Lemma monotone8_inter (gf gf': rel8 T0 T1 T2 T3 T4 T5 T6 T7 -> rel8 T0 T1 T2 T3 T4 T5 T6 T7)
      (MON1: monotone8 gf)
      (MON2: monotone8 gf'):
  monotone8 (gf /9\ gf').
Proof.
  red; intros. destruct IN. split; eauto.
Qed.

Lemma _pind8_mon_gen (gf gf': rel8 T0 T1 T2 T3 T4 T5 T6 T7 -> rel8 T0 T1 T2 T3 T4 T5 T6 T7) r r'
    (LEgf: gf <9= gf')
    (LEr: r <8= r'):
  pind8 gf r <8== pind8 gf' r'.
Proof.
  apply curry_map8. red; intros. eapply pind_mon_gen. apply PR.
  - intros. apply LEgf, PR0.
  - intros. apply LEr, PR0.
Qed.

Lemma pind8_mon_gen (gf gf': rel8 T0 T1 T2 T3 T4 T5 T6 T7 -> rel8 T0 T1 T2 T3 T4 T5 T6 T7) r r' x0 x1 x2 x3 x4 x5 x6 x7
    (REL: pind8 gf r x0 x1 x2 x3 x4 x5 x6 x7)
    (LEgf: gf <9= gf')
    (LEr: r <8= r'):
  pind8 gf' r' x0 x1 x2 x3 x4 x5 x6 x7.
Proof.
  eapply _pind8_mon_gen; [apply LEgf | apply LEr | apply REL].
Qed.

Lemma pind8_mon_bot (gf gf': rel8 T0 T1 T2 T3 T4 T5 T6 T7 -> rel8 T0 T1 T2 T3 T4 T5 T6 T7) r' x0 x1 x2 x3 x4 x5 x6 x7
    (REL: pind8 gf bot8 x0 x1 x2 x3 x4 x5 x6 x7)
    (LEgf: gf <9= gf'):
  pind8 gf' r' x0 x1 x2 x3 x4 x5 x6 x7.
Proof.
  eapply pind8_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Definition top8 { T0 T1 T2 T3 T4 T5 T6 T7} (x0: T0) (x1: T1 x0) (x2: T2 x0 x1) (x3: T3 x0 x1 x2) (x4: T4 x0 x1 x2 x3) (x5: T5 x0 x1 x2 x3 x4) (x6: T6 x0 x1 x2 x3 x4 x5) (x7: T7 x0 x1 x2 x3 x4 x5 x6) := True.

Lemma pind8_mon_top (gf gf': rel8 T0 T1 T2 T3 T4 T5 T6 T7 -> rel8 T0 T1 T2 T3 T4 T5 T6 T7) r x0 x1 x2 x3 x4 x5 x6 x7
    (REL: pind8 gf r x0 x1 x2 x3 x4 x5 x6 x7)
    (LEgf: gf <9= gf'):
  pind8 gf' top8 x0 x1 x2 x3 x4 x5 x6 x7.
Proof.
  eapply pind8_mon_gen; eauto. red. auto.
Qed.

Lemma upind8_mon_gen (gf gf': rel8 T0 T1 T2 T3 T4 T5 T6 T7 -> rel8 T0 T1 T2 T3 T4 T5 T6 T7) r r' x0 x1 x2 x3 x4 x5 x6 x7
    (REL: upind8 gf r x0 x1 x2 x3 x4 x5 x6 x7)
    (LEgf: gf <9= gf')
    (LEr: r <8= r'):
  upind8 gf' r' x0 x1 x2 x3 x4 x5 x6 x7.
Proof.
  destruct REL. split; eauto.
  eapply pind8_mon_gen; [apply H | apply LEgf | apply LEr].
Qed.

Lemma upind8_mon_bot (gf gf': rel8 T0 T1 T2 T3 T4 T5 T6 T7 -> rel8 T0 T1 T2 T3 T4 T5 T6 T7) r' x0 x1 x2 x3 x4 x5 x6 x7
    (REL: upind8 gf bot8 x0 x1 x2 x3 x4 x5 x6 x7)
    (LEgf: gf <9= gf'):
  upind8 gf' r' x0 x1 x2 x3 x4 x5 x6 x7.
Proof.
  eapply upind8_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Lemma upind8mon_top (gf gf': rel8 T0 T1 T2 T3 T4 T5 T6 T7 -> rel8 T0 T1 T2 T3 T4 T5 T6 T7) r x0 x1 x2 x3 x4 x5 x6 x7
    (REL: upind8 gf r x0 x1 x2 x3 x4 x5 x6 x7)
    (LEgf: gf <9= gf'):
  upind8 gf' top8 x0 x1 x2 x3 x4 x5 x6 x7.
Proof.
  eapply upind8_mon_gen; eauto. red. auto.
Qed.

Section Arg8.

Variable gf : rel8 T0 T1 T2 T3 T4 T5 T6 T7 -> rel8 T0 T1 T2 T3 T4 T5 T6 T7.
Arguments gf : clear implicits.

Theorem _pind8_mon: _monotone8 (pind8 gf).
Proof.
  red; intros. eapply curry_map8, _pind_mon; apply uncurry_map8; assumption.
Qed.

Theorem _pind8_acc: forall
  l r (OBG: forall rr (DEC: rr <8== r) (IH: rr <8== l), pind8 gf rr <8== l),
  pind8 gf r <8== l.
Proof.
  intros. apply curry_adjoint2_8.
  eapply _pind_acc. intros.
  apply curry_adjoint2_8 in DEC. apply curry_adjoint2_8 in IH.
  apply curry_adjoint1_8.
  eapply le8_trans. 2: eapply (OBG _ DEC IH).
  apply curry_map8.
  apply _pind_mon; try apply le1_refl; apply curry_bij2_8.
Qed.

Theorem _pind8_mult_strong: forall r,
  pind8 gf r <8== pind8 gf (upind8 gf r).
Proof.
  intros. apply curry_map8.
  eapply le1_trans; [eapply _pind_mult_strong |].
  apply _pind_mon; intros [] H. apply H.
Qed.

Theorem _pind8_fold: forall r,
  gf (upind8 gf r) <8== pind8 gf r.
Proof.
  intros. apply uncurry_adjoint1_8.
  eapply le1_trans; [| apply _pind_fold]. apply le1_refl.
Qed.

Theorem _pind8_unfold: forall (MON: _monotone8 gf) r,
  pind8 gf r <8== gf (upind8 gf r).
Proof.
  intros. apply curry_adjoint2_8.
  eapply _pind_unfold; apply monotone8_map; assumption.
Qed.

Theorem pind8_acc: forall
  l r (OBG: forall rr (DEC: rr <8= r) (IH: rr <8= l), pind8 gf rr <8= l),
  pind8 gf r <8= l.
Proof.
  apply _pind8_acc.
Qed.

Theorem pind8_mon: monotone8 (pind8 gf).
Proof.
  apply monotone8_eq.
  apply _pind8_mon.
Qed.

Theorem upind8_mon: monotone8 (upind8 gf).
Proof.
  red; intros.
  destruct IN. split; eauto.
  eapply pind8_mon. apply H. apply LE.
Qed.

Theorem pind8_mult_strong: forall r,
  pind8 gf r <8= pind8 gf (upind8 gf r).
Proof.
  apply _pind8_mult_strong.
Qed.

Corollary pind8_mult: forall r,
  pind8 gf r <8= pind8 gf (pind8 gf r).
Proof. intros; eapply pind8_mult_strong in PR. eapply pind8_mon; eauto. intros. destruct PR0. eauto. Qed.

Theorem pind8_fold: forall r,
  gf (upind8 gf r) <8= pind8 gf r.
Proof.
  apply _pind8_fold.
Qed.

Theorem pind8_unfold: forall (MON: monotone8 gf) r,
  pind8 gf r <8= gf (upind8 gf r).
Proof.
  intro. eapply _pind8_unfold; apply monotone8_eq; assumption.
Qed.

End Arg8.

Arguments pind8_acc : clear implicits.
Arguments pind8_mon : clear implicits.
Arguments upind8_mon : clear implicits.
Arguments pind8_mult_strong : clear implicits.
Arguments pind8_mult : clear implicits.
Arguments pind8_fold : clear implicits.
Arguments pind8_unfold : clear implicits.

End PIND8.

Global Opaque pind8.

#[export] Hint Unfold upind8 : core.
#[export] Hint Resolve pind8_fold : core.
#[export] Hint Unfold monotone8 : core.


Require Export cd.

Require Export String ListSet List Arith Bool.
Open Scope nat_scope.
Open Scope type_scope.
Open Scope string_scope.
Open Scope list_scope.
Import ListNotations.

(* ----- intergrate two class ------- *)
Parameter R : Class -> Class -> Class -> list Assoc.

Parameter CA : Class -> Class -> asKind -> Assoc.

Definition CreateAsEnd (c : Class) :=
  BAsEnd "_" c (Nat 0, Star).

Definition CreateAssoc (ne : NamedElement) (c1 c2 : Class) :=
  BAssoc ne none (CreateAsEnd c1, CreateAsEnd c2).

Inductive refineone : SimpleUML -> SimpleUML -> Prop :=
| import:  forall c' ci cj C T P S G,
    not (set_In c' C) ->
    set_In ci C /\ set_In cj C ->
    let C' := (c':: C) in
    let S' := set_union eqAssoc_dec (R ci cj c') S in
    refineone (mkSimpleUML C T P S G) (mkSimpleUML C' T P S' G)
| dec1: forall c' ci C T P S G,
    not (set_In c' C) ->
    set_In ci C ->
    let C' := (c':: C) in
    let G' := (BGen ci c') :: G in
    refineone (mkSimpleUML C T P S G) (mkSimpleUML C' T P S G')
| dec2 : forall c' ci C T P S G,
    not (set_In c' C) ->
    set_In ci C ->
    let C' := (c' :: C) in
    let S' := (CA c' ci composite) :: S in
    refineone (mkSimpleUML C T P S G) (mkSimpleUML C' T P S' G)
| dec3 : forall c' ci C T P S G,
    not (set_In c' C) ->
    set_In ci C ->
    let C' := (c' :: C) in
    let S' := (CA c' ci aggregate) :: S in
    refineone (mkSimpleUML C T P S G) (mkSimpleUML C' T P S' G)
| intro1 : forall c' ci C T P S G,
    not (set_In c' C) ->
    set_In ci C ->
    let C' := (c' :: C) in
    let S' := (CA c' ci none) :: S in
    refineone (mkSimpleUML C T P S G) (mkSimpleUML C' T P S' G)
| intro2 : forall c' ci C T P S G,
    not (set_In c' C) ->
    set_In ci C ->
    let C' := (c' :: C) in
    let S' := (CA c' ci directed) :: S in
    refineone (mkSimpleUML C T P S G) (mkSimpleUML C' T P S' G)
.

Inductive refine : SimpleUML -> SimpleUML -> Prop :=
| one : forall m1 m2,
    refineone m1 m2 -> refine m1 m2
| reflex : forall m,
    refine m m
| trans : forall m1 m2 m3,
    refine m1 m2 -> refine m2 m3 -> refine m1 m3
.

Theorem wellFormed_preserve :
  forall m1 m2,
    WellFormed m1 ->
    refineone m1 m2 ->
    WellFormed m2.
Proof.
  intros m1 m2 H1 H2.
  inversion H1. unfold UniqueClass in H.
  inversion H2; subst; simpl in H.
Admitted.

Require Import Relations.

Theorem refine_refl :
   reflexive _  refine.
Proof.
  unfold reflexive.
  intro x. apply reflex.
Qed.

Theorem refine_trans :
  transitive _ refine.
Proof.
  unfold transitive.
  intros x y z. apply trans.
Qed.

Theorem class_preserve :
  forall c m1 m2,
    refineone m1 m2 ->
    set_In c (MClass_Instance m1) ->
    set_In c (MClass_Instance m2).
Proof.
  intros c m1 m2 H.
  induction H; intros H1; simpl;
    simpl in H1; right; assumption.
Qed.

Theorem gen_preserve :
  forall sub super m1 m2,
    refineone m1 m2 ->
    set_In (BGen super sub) (MGen_Instance m1) ->
    set_In (BGen super sub) (MGen_Instance m2).
Proof.
  intros sub super m1 m2 H.
  induction H; intros H1; simpl in H1; simpl; try assumption.
  - right; assumption.
Qed.